tc_.pl1 09/09/87 1351.5rew 09/09/87 1349.9 429534 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-30,LJAdams), approve(86-11-11,MCR7485), audit(86-12-19,Margolin), install(87-01-06,MR12.0-1255): Modified to support MOWSE. 2) change(86-11-26,LJAdams), approve(86-11-26,MCR7584), audit(86-12-19,Margolin), install(87-01-06,MR12.0-1255): Initial DSA coding has been maintained in an non-executable form. 3) change(87-01-16,LJAdams), approve(87-01-16,PBF7485), audit(87-01-16,Gilcrease), install(87-01-19,MR12.0-1287): Do not perform cleanup_init for control order initialize_mowse_terminal. This will be handled when error code is fed back to video_utils_. 4) change(87-02-03,LJAdams), approve(87-02-03,MCR7642), audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030): The initial terminal modes were not being properly propagated. 5) change(87-02-13,LJAdams), approve(87-02-13,MCR7642), audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030): Do not support a MOWSE terminal type unless the line type is MOWSE. 6) change(87-03-11,LJAdams), approve(87-03-11,MCR7646), audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030): Use terminal_type_data to get the information for the existance of a protocol (dependency). Changed ttd_version to ttd_version_3. 7) change(87-05-20,LJAdams), approve(87-05-20,MCR7699), audit(87-06-30,RBarstad), install(87-08-04,MR12.1-1055): Provided support for MOWSE_FANSI protocol. Changed name of include file terminal_type_protocols.incl.pl1 which was to long to term_type_protocols.incl.pl1. 8) change(87-06-03,LJAdams), approve(87-06-03,MCR7584), audit(87-06-30,RBarstad), install(87-08-04,MR12.1-1055): Added initial break table for DSA. 9) change(87-09-04,LJAdams), approve(87-09-04,PBF7485), audit(87-09-04,RBarstad), install(87-09-09,MR12.1-1102): Moved placement of call to ws_tty_$abort to avoid data transmission before ws_tty_ was ready to receive data. END HISTORY COMMENTS */ /* tc_.pl1 Terminal Control utilities -- init, shutdown, reconnect/reinit, primitive desk management. This program is called from the I/O Module interface */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ /* */ /* Written by Benson Margulies, sometime in 1981 */ /* Modified 21 January 1982 by Chris Jones to add ^tabecho to initial modes */ /* Modified 11 April 1982 by Richard Lamson to add get_foreign_terminal_data order call for user SUPDUP support. */ /* Modified 14 July 1982 to fix bug in above change in which important tc_data values were not initialized for non-SUPDUP users of STYs. */ /* Modified 10 September 1982 by William M. York to add the send_buffered_output control order. */ /* Modified 20 September 1982 by WMY to remove the send_buffered_output control order, since window_$sync is a better mechanism. */ /* Modified January 1983 by WMY to stop validating the cursor position for calls that don't modify the screen (e.g. unechoed input). */ /* Modified 1 August 1983 by Jon A. Rochlis to remove special casing the terminal_info control order, since ring0 appears to handle it correctly and we don't (i.e. answerback). */ /* Modified 9 September 1983 by JR to map error_table_$no_table into the new error_table_$unsupported terminal. It must be an error_table_ code as opposed a video_et_ code because it will be used at reconnection time. */ /* Modified 1 October 1983 by JR to add support for partial screen width windows and to really delete the terminal_info code. */ /* Modified 6 January 1983 by JR to add the randomize_redisplay control order to make Barmar happy. */ /* Modified 18 March 1984 by JR to add support for the set_term_type order. Init and shut have been modified (mostly init). They have been split into two parts, the terminal type dependent part (video info, etc.) and the general tc_data part. */ /* Modified 7 September 1984 by C. Marker to add set_line_speed order. */ /* Modified 31 October 1984 by BIM for fix to uninitialized variable. */ /* Modified 7 February 1985 by JR to make get_capabilities fill in the overprint flag. */ /* Modified June 1985 by Roger Negaret to support DSA networks. */ tc_: procedure; return; declare tc_disconnect$check entry (pointer, fixed binary (35)); declare tc_request$init entry (pointer); declare tc_request$shut entry (pointer, fixed bin (35)); declare tc_screen$init entry (pointer, fixed binary, fixed binary); declare tc_screen$shut entry (pointer); declare tc_input$init entry (pointer); declare tc_input$shut entry (pointer); declare tc_request entry (pointer, pointer, fixed bin, fixed binary (35)); declare tc_$init_ttp_info entry (ptr, char (*), fixed bin (35)); declare tc_$shut_ttp_info entry (ptr); declare ttt_info_$initial_string entry (character (*), character (*) var, fixed binary (35)); declare ttt_info_$video_info entry (character (*), fixed binary, pointer, pointer, fixed binary (35)); declare ttt_info_$terminal_data entry (character (*), fixed binary, fixed binary, pointer, fixed binary (35)); declare hcs_$tty_attach entry (character (*), fixed bin (71), fixed bin, fixed bin, fixed bin (35)); declare hcs_$tty_detach entry (fixed bin, fixed bin, fixed bin, fixed bin (35)); declare hcs_$tty_abort entry (fixed bin, fixed bin, fixed bin, fixed bin (35)); declare hcs_$tty_order entry (fixed bin, character (*), pointer, fixed bin, fixed bin (35)); declare dsa_tty_$attach entry (character (*), fixed bin (71), fixed bin (35), fixed bin, fixed bin (35)); declare dsa_tty_$detach entry (fixed bin (35), fixed bin, fixed bin, fixed bin (35)); declare dsa_tty_$abort entry (fixed bin (35), fixed bin, fixed bin, fixed bin (35)); declare dsa_tty_$order entry (fixed bin (35), character (*), pointer, fixed bin, fixed bin (35)); declare ws_tty_$attach entry (ptr, char (*), fixed bin (71), fixed bin, fixed bin (35)); declare ws_tty_$detach entry (ptr, fixed bin, fixed bin, fixed bin (35)); declare ws_tty_$abort entry (ptr, fixed bin, fixed bin, fixed bin (35)); declare ws_tty_$order entry (ptr, char (*), ptr, fixed bin, fixed bin (35)); declare continue_to_signal_ entry (fixed binary (35)); declare ( hcs_$set_ips_mask, hcs_$reset_ips_mask ) entry (bit (36) aligned, bit (36) aligned); declare ( ipc_$mask_ev_calls, ipc_$unmask_ev_calls ) entry (fixed bin (35)); declare get_system_free_area_ entry () returns (ptr); declare dsa_error_table_$try_again external static fixed bin (35); declare ( error_table_$unimplemented_version, error_table_$smallarg, error_table_$no_table, error_table_$null_info_ptr, error_table_$unsupported_terminal, error_table_$incompatible_term_type, video_et_$window_too_big, video_et_$bad_window_id, video_et_$capability_lacking, video_et_$no_video_info, video_et_$terminal_cannot_position, video_et_$out_of_window_bounds ) external static fixed bin (35); declare tty_state fixed bin; declare X_code fixed bin (35); declare iox_$control entry (ptr, char (*), ptr, fixed bin (35)); declare ( TC_data_ptr pointer, Code fixed bin (35), Request_ptr pointer, Terminal_type character (*), Channel character (*), Event fixed bin (71), Window_id bit (36) aligned, Reconnection_flag bit (1), MOWSE_ptr ptr ) parameter; declare 1 windows (100) based (tc_data.desk_ptr), 2 flags aligned, 3 in_use bit (1) unaligned, 3 status_pending bit (1) unaligned, 3 pad bit (34) unaligned, 2 location aligned, 3 top_row fixed bin, 3 n_rows fixed bin, 3 first_column fixed bin, 3 n_columns fixed bin, 2 window_id bit (36) aligned, /* for now, bit (index in this table) */ 2 window_iocb_ptr ptr, /* so we can do set_window_status orders */ 2 pending_status bit (36) aligned; /* may be longer someday */ /* first bit is PIATTY (ITS hangup signal) */ declare 1 ttd aligned like terminal_type_data automatic; declare 1 mowse_info static, 2 tc_data_ptr ptr, 2 ttd aligned like terminal_type_data; declare wx fixed bin; declare ips_mask bit (36) aligned; declare cleanup condition; declare terminal_control_disconnection_ condition; declare (addr, after, bin, bit, clock, hbound, index, lbound, length, max, null, reverse, rtrim, substr, unspec) builtin; /* CONSTANTS */ declare UNMASK_ALL bit (36) aligned initial (""b) internal static options (constant); dcl INITIAL_BREAKTEST bit (128) unaligned internal static options (constant) init (""b); /* noone in their right mind would use that for a breaktable, so it will compare unequal, and get set in hardcore */ dcl INITIAL_MODES char (128) internal static options (constant) init ( "force,rawo,rawi,fulldpx,^echoplex,^prefixnl,breakall,^hndlquit,^crecho,^lfecho,^replay,^polite,^tabecho" ); dcl MOWSE_DEVICE char (9) internal static options (constant) init ("mowse_i/o"); dcl MOWSE_INITIAL_MODES char (128) internal static options (constant) init ("force,ll79,pl23"); dcl iox_$modes entry (ptr, char (*), char (*), fixed bin (35)); init: entry (TC_data_ptr, Channel, Event, Terminal_type, Reconnection_flag, MOWSE_ptr, Code); if ^Reconnection_flag then do; allocate tc_data set (tc_data_ptr); tc_data.screen_data_ptr = null (); /* for cleanup handler */ tc_data.input_buffer_ptr = null (); tc_data.desk_ptr = null (); end; else tc_data_ptr = TC_data_ptr; if substr (Channel, 1, 4) = "dsa." then do; /* DSA */ tc_data.network_type = DSA_NETWORK_TYPE; call dsa_tty_$attach (Channel, Event, tc_data.tty_handle, tty_state, Code); end; else if index (Channel, MOWSE_DEVICE) = 1 then do;/* MOWSE */ tc_data.network_type = MOWSE_NETWORK_TYPE; tc_data.mowse_terminal_iocb_ptr = MOWSE_ptr; end; else do; /* MCS */ tc_data.network_type = MCS_NETWORK_TYPE; call hcs_$tty_attach (Channel, Event, tc_data.devx, tty_state, Code); end; if Code ^= 0 then do; free tc_data; return; end; on cleanup call cleanup_init; tc_data.event = Event; tc_data.state.pending.have_sent_protocol = ""b; tc_data.state.pending.async_same_window = ""b; tc_data.state.pending.protocol_evs (*) = 0; tc_data.state.pending.blocked_windows (*) = ""b; call init_ttp_info_1 (Code); if Code ^= 0 then do; free tc_data; return; end; tc_data.breaktest = INITIAL_BREAKTEST; call init_ttp_info_2 (Code); if Code ^= 0 then do; call cleanup_init; return; end; if tc_data.network_type ^= MOWSE_NETWORK_TYPE then do; call init_ttp_info_3 (Code); if Code ^= 0 then do; call cleanup_init; return; end; end; else do; /* mowse terminal type data is set after video */ /* has been attached */ mowse_info.ttd = ttd; mowse_info.tc_data_ptr = tc_data_ptr; end; if ^Reconnection_flag then do; allocate windows; /* set the desk ptr */ unspec (windows) = ""b; windows (*).in_use = "0"b; end; if Code ^= 0 then return; TC_data_ptr = tc_data_ptr; return; /* Initialize only the terminal dependant info in tc_data */ init_ttp_info: entry (TC_data_ptr, Terminal_type, Code); call init_ttp_info_1 (Code); if Code ^= 0 then return; call init_ttp_info_2 (Code); if tc_data.network_type ^= MOWSE_NETWORK_TYPE then call init_ttp_info_3 (Code); /* we should not get here if were MOWSE */ return; /* Split into two operations, so init can tell the difference, if we fail. */ init_ttp_info_1: proc (Code); dcl Code fixed bin (35); call get_video_data (Code); if Code ^= 0 then return; call verify_capabilities (tc_data.ttt_video_ptr, Code); if Code ^= 0 then return; return; end init_ttp_info_1; init_ttp_info_2: proc (Code); dcl Code fixed bin (35); /* Now initialize the folks down below. If that all works, which it can only not by signalling, then we massage the terminal */ call tc_request$init (tc_data_ptr); call tc_input$init (tc_data_ptr); call tc_screen$init (tc_data.screen_data_ptr, tc_data.rows, tc_data.columns); return; end init_ttp_info_2; init_ttp_info_3: proc (Code); dcl Code fixed bin (35); call setup_terminal (Code); /* Now place terminal in known state */ call clear_screen_proc; return; end init_ttp_info_3; request: entry (TC_data_ptr, Request_ptr, Code); tc_data_ptr = TC_data_ptr; Code = 0; call request_proc (Request_ptr, Code); return; request_proc: procedure (R_ptr, Code); declare R_ptr pointer; declare Code fixed bin (35); request_ptr = R_ptr; if request_header.window_id ^= (36)"1"b then do; wx = find_window (request_header.window_id, Code); /* it best be there */ if Code ^= 0 then return; call check_bounds (Code); if Code ^= 0 then return; call tc_request (tc_data_ptr, request_ptr, windows (wx).first_column + windows (wx).n_columns - 1 /* last column in the window */, Code); end; else call tc_request (tc_data_ptr, request_ptr, tc_data.columns, Code); /* better not be I/D chars */ end request_proc; check_in_window: entry (TC_data_ptr, Row, N_rows, Col, N_cols, Window_id, Window_iocb_ptr, Code); declare (Row, N_rows) fixed bin; declare (Col, N_cols) fixed bin; declare Window_iocb_ptr ptr; tc_data_ptr = TC_data_ptr; Code = 0; call check_in_window_proc (Row, N_rows, Col, N_cols, Window_id, Window_iocb_ptr); return; check_in_window_proc: procedure (Row, N_rows, Col, N_cols, Window_id, Window_iocb_ptr); declare (Row, N_rows) fixed bin; declare (Col, N_cols) fixed bin; declare Window_id bit (36) aligned; declare Window_iocb_ptr ptr; if Row < 1 /* no hyperspace */ | N_rows < 1 /* or degenerates */ | Row + N_rows - 1 > tc_data.rows /* too big */ | Col < 1 /* check the other dimension also */ | N_cols < 1 | Col + N_cols - 1 > tc_data.columns then do; Code = video_et_$window_too_big; return; end; wx = find_free_slot (); /* uninterruptable, no windows (uggh) */ Window_id = windows (wx).window_id; windows (wx).top_row = Row; windows (wx).n_rows = N_rows; windows (wx).first_column = Col; windows (wx).n_columns = N_cols; windows (wx).window_iocb_ptr = Window_iocb_ptr; return; end check_in_window_proc; check_out_window: entry (TC_data_ptr, Window_id, Code); Code = 0; tc_data_ptr = TC_data_ptr; call check_out_window_proc (Window_id); return; check_out_window_proc: procedure (Window_id); declare Window_id bit (36) aligned; wx = find_window (Window_id, Code); if Code ^= 0 then return; windows (wx).in_use = "0"b; return; end check_out_window_proc; resize_window: entry (TC_data_ptr, Window_id, Row, N_rows, Col, N_cols, Code); tc_data_ptr = TC_data_ptr; Code = 0; call resize_window_proc (Window_id, Row, N_rows, Col, N_cols); return; resize_window_proc: procedure (Window_id, Row, N_rows, Col, N_cols); declare Window_id bit (36) aligned; declare Row fixed bin; declare N_rows fixed bin; declare Col fixed bin; declare N_cols fixed bin; if Row < 1 /* no hyperspace */ | N_rows < 1 /* or degenerates */ | Row + N_rows - 1 > tc_data.rows /* too big */ | Col < 1 /* check the other dimension also */ | N_cols < 1 | Col + N_cols - 1 > tc_data.columns then do; Code = video_et_$window_too_big; return; end; wx = find_window (Window_id, Code); if Code ^= 0 then return; windows (wx).top_row = Row; windows (wx).n_rows = N_rows; windows (wx).first_column = Col; windows (wx).n_columns = N_cols; return; end resize_window_proc; get_capabilities: entry (TC_data_ptr, C_ptr, Code); declare C_ptr pointer; tc_data_ptr = TC_data_ptr; Code = 0; call get_capabilities_proc (C_ptr); return; get_capabilities_proc: procedure (C_ptr); declare C_ptr pointer; capabilities_info_ptr = C_ptr; if capabilities_info.version ^= capabilities_info_version then do; Code = error_table_$unimplemented_version; return; end; /* These are physical capabilities -- window_io_ is expected to know which we will simulate. */ capabilities_info.screensize.columns = tc_data.terminal.columns; capabilities_info.screensize.rows = tc_data.terminal.rows; ttyvtblp = tc_data.ttt_video_ptr; capabilities_info.scroll_region = tty_video_table.sequences (INSERT_LINES).present & tty_video_table.sequences (DELETE_LINES).present; capabilities_info.insert_chars = tty_video_table.sequences (INSERT_CHARS).present; capabilities_info.insert_mode = tty_video_table.sequences (END_INSERT_CHARS).present; capabilities_info.delete_chars = tty_video_table.sequences (DELETE_CHARS).present; capabilities_info.overprint = tty_video_table.overstrike_available; capabilities_info.line_speed = tc_data.terminal.line_speed; return; end get_capabilities_proc; /* Caller of this better be damned sure order is innocuous */ random_order: entry (TC_data_ptr, Order, Info_ptr, Code); declare Order character (*); declare Info_ptr pointer; tc_data_ptr = TC_data_ptr; call call_order (Order, Info_ptr, Code); return; get_terminal_info: procedure (ttp, baud_rate, code); declare ttp char (*); /* in */ declare baud_rate fixed bin; /* out */ declare code fixed bin (35); /* out */ declare 1 ti aligned like terminal_info automatic; baud_rate = 0; code = 0; /* First, pick up the terminal type from ring 0, if our caller did not give us one */ ti.version = 1; call call_order ("terminal_info", addr (ti), (0)); if ttp ^= "" then ti.term_type = ttp; tc_data.ttp = ti.term_type; ttd.version = ttd_version_3; call ttt_info_$terminal_data (ti.term_type, (0), ti.baud_rate, addr (ttd), code); if code ^= 0 then return; baud_rate = ti.baud_rate; end get_terminal_info; get_video_data: procedure (code); /* This should not do anything to the terminal */ declare baud_rate fixed bin; /* in */ declare code fixed bin (35); /* in */ if Terminal_type ^= "" then /* use caller supplied type */ call get_terminal_info (Terminal_type, baud_rate, code); else call get_terminal_info ("", baud_rate, code); if code ^= 0 then return; call check_protocol (ttd.protocol, code); if code ^= 0 then do; call cleanup_init; return; end; call get_video_info_ptr (ttp, baud_rate, tc_data.ttt_video_ptr, code); if code ^= 0 then return; if tc_data.ttt_video_ptr = null () then code = video_et_$no_video_info; ttyvtblp = tc_data.ttt_video_ptr; /* fill in important values in tc_data */ tc_data.rows = tty_video_table.screen_height; tc_data.columns = tty_video_table.screen_line_length; tc_data.line_speed = baud_rate; /* user may be coming in via SUPDUP, so issue a get_foreign_terminal_data order to get screen dimensions, etc. This order call will also succeed on STY connections, but the modes returned will not be what the following code looks for, so no tc_data values will get changed. */ my_ftd.version = FOREIGN_TERMINAL_DATA_VERSION_1; my_ftd.area_ptr = get_system_free_area_ (); call call_order ("get_foreign_terminal_data", addr (my_ftd), X_code); if X_code = 0 then do; mode_string_info_ptr = my_ftd.mode_string_info_ptr; do i = 1 to mode_string_info.number; mode_value_ptr = addr (mode_string_info.modes (i)); if /* case */ mode_value.mode_name = "line_length" then tc_data.columns = mode_value.numeric_value; else if mode_value.mode_name = "page_length" then tc_data.rows = mode_value.numeric_value; else if mode_value.mode_name = "ospeed" then tc_data.line_speed = mode_value.numeric_value; else if mode_value.mode_name = "insert_delete_lines" | mode_value.mode_name = "idel_lines" then if ^mode_value.boolean_value then do; call delete_sequence (INSERT_LINES); call delete_sequence (DELETE_LINES); end; else ; else if mode_value.mode_name = "insert_delete_chars" | mode_value.mode_name = "idel_chars" then if ^mode_value.boolean_value then do; call delete_sequence (INSERT_CHARS); call delete_sequence (DELETE_CHARS); end; else ; end; end; return; delete_sequence: procedure (sequence_number); if sequence_number <= tty_video_table.nseq then tty_video_table.sequences (sequence_number).present = "0"b; return; declare sequence_number fixed binary; end delete_sequence; %include foreign_terminal_data; %include mode_string_info; declare 1 my_ftd auto like foreign_terminal_data; declare i fixed binary; end get_video_data; get_video_info_ptr: procedure (ttp, baud_rate, video_info_ptr, code); dcl ttp char (*); dcl baud_rate fixed bin; dcl video_info_ptr ptr; dcl code fixed bin (35); call ttt_info_$video_info (ttp, baud_rate, null (), video_info_ptr, code); if code = error_table_$no_table then code = error_table_$unsupported_terminal; return; end get_video_info_ptr; verify_capabilities: procedure (video_table_ptr, code); dcl video_table_ptr ptr; /* Make sure she flies */ /* Must have one of abs poistioning, up/down/right/left, or home/right/down */ declare code fixed bin (35); code = 0; ttyvtblp = video_table_ptr; if ^((tty_video_table.sequences (ABS_POS).present | (tty_video_table.sequences (CURSOR_UP).present & tty_video_table.sequences (CURSOR_DOWN).present & tty_video_table.sequences (CURSOR_RIGHT).present & tty_video_table.sequences (CURSOR_LEFT).present) | (tty_video_table.sequences (HOME).present & tty_video_table.sequences (CURSOR_DOWN).present & tty_video_table.sequences (CURSOR_RIGHT).present))) then code = video_et_$terminal_cannot_position; end verify_capabilities; setup_terminal: procedure (code); declare code fixed bin (35); /* Type */ if tc_data.network_type = DSA_NETWORK_TYPE then do; /* For DSA, we always initialize a break table */ dcl 1 dsa_break_table like echo_neg_data aligned; /* Here, because used only once */ dsa_break_table.version = echo_neg_data_version_2; dsa_break_table.break(*) = "1"b; /* All chars sets. Why not */ /* The remainder is ignored by dsa_tty_index_ */ call call_order ("set_echo_break_table", addr (dsa_break_table), code); if code ^= 0 then return; end; if tc_data.network_type = MOWSE_NETWORK_TYPE then do; call ws_tty_$abort (tc_data.mowse_terminal_iocb_ptr, (1) /* resetread */, tty_state, (0)); call call_order ("set_terminal_data", addr (mowse_info.ttd), code); end; else call call_order ("set_terminal_data", addr (ttd), code); if code ^= 0 then return; /* Modes */ if tc_data.network_type = MOWSE_NETWORK_TYPE then call iox_$modes (tc_data.mowse_terminal_iocb_ptr, MOWSE_INITIAL_MODES, tc_data.old_mode_string, code); else call set_modes (INITIAL_MODES, tc_data.old_mode_string, code); if code = error_table_$smallarg then code = 0; if code ^= 0 then return; call send_initial_string (code); /* depends on our presence in rawo */ if code ^= 0 then return; if tc_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$abort (tc_data.tty_handle, (1) /* resetread */, tty_state, (0)); else /* MCS */ call hcs_$tty_abort (tc_data.devx, (1) /* resetread */, tty_state, (0)); call call_order ("printer_off", null (), (0)); end setup_terminal; send_initial_string: procedure (code); declare code fixed bin (35); declare initial_string character (512) varying; declare 1 tct aligned like request_text; code = 0; call ttt_info_$initial_string (tc_data.ttp, initial_string, code); if code ^= 0 then return; if length (initial_string) = 0 then return; tct.operation = OP_WRITE_RAW; tct.row = 1; tct.col = 1; begin; declare i_s_non_varying char (length (initial_string)); i_s_non_varying = initial_string; tct.text_ptr = addr (i_s_non_varying); tct.text_length = length (initial_string); call tc_request (tc_data_ptr, addr (tct), tc_data.columns /* why not? */, (0)); end; end send_initial_string; call_order: procedure (order, info, code); declare order character (*); declare info pointer; declare code fixed bin (35); declare tty_state fixed bin; declare tc_block entry (pointer, pointer, bit (36) aligned); code = 0; if tc_data.network_type = DSA_NETWORK_TYPE then do; /* DSA */ try_again: call dsa_tty_$order (tc_data.tty_handle, order, info, tty_state, code); if code = dsa_error_table_$try_again then do; call tc_block (tc_data_ptr, request_ptr, UNMASK_ALL); code = 0; goto try_again; end; end; else if tc_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ call ws_tty_$order (tc_data.mowse_terminal_iocb_ptr, order, info, tty_state, code); else /* MCS */ call hcs_$tty_order (tc_data.devx, order, info, tty_state, code); call tc_disconnect$check (tc_data_ptr, code); end call_order; check_protocol: procedure (op, code); dcl op fixed bin; dcl code fixed bin(35); if (op > hbound(protocol_names,1)) | (op < lbound(protocol_names,1)) then op = -1; goto PROTOCOL (op); PROTOCOL (-1): /* ERROR */ code = error_table_$incompatible_term_type; return; PROTOCOL (0): /* NO_PROTOCOL */ if tc_data.network_type = MOWSE_NETWORK_TYPE then goto PROTOCOL (-1); return; PROTOCOL (1): /* MOWSE */ if tc_data.network_type ^= MOWSE_NETWORK_TYPE then goto PROTOCOL (-1); return; PROTOCOL (2): /* MOWSE_FANSI */ return; /* valid with all network types */ end check_protocol; set_modes: procedure (new_modes, old_modes, code); dcl (new_modes, old_modes) char (*); dcl code fixed bin (35); mode_block: begin; /* size is unknown till here */ declare modes_ptr pointer; declare 1 t_modes_info aligned, 2 mode_length fixed bin (21), 2 modes char (max (length (new_modes), length (old_modes))); modes_ptr = addr (t_modes_info); t_modes_info.mode_length = length (t_modes_info.modes); t_modes_info.modes = new_modes; call call_order ("modes", modes_ptr, code); if code ^= 0 & code ^= error_table_$smallarg then do; old_modes = t_modes_info.modes; /* the mode(s) in error are in here */ return; end; if length (old_modes) = 0 then return; if t_modes_info.mode_length = 0 then do; old_modes = ""; return; end; if code = 0 then do; old_modes = t_modes_info.modes; return; end; /* from this point on we have a smallarg */ code = 0; /* but we do not admit it. */ if substr (reverse (rtrim (old_modes)), 1, 1) = "." /* the hardcore returned an even mode, which it should */ then return; /* from this point the hardcore returned a fragment of a mode */ old_modes = reverse (after (reverse (t_modes_info.modes), ",")); if length (rtrim (old_modes)) = length (old_modes) then old_modes = reverse (after (reverse (old_modes), ",")); /* leave room for a "." */ substr (old_modes, length (rtrim (old_modes)) + 1, 1) = "."; end mode_block; end set_modes; shut: entry (TC_data_ptr); tc_data_ptr = TC_data_ptr; if tc_data_ptr = null () then return; /* turn off hairy features that we do not want to go off */ ips_mask = ""b; on cleanup begin; if ips_mask ^= ""b then do; call hcs_$reset_ips_mask (ips_mask, ""b); call ipc_$unmask_ev_calls (0); end; end; call hcs_$set_ips_mask (""b, ips_mask); call ipc_$mask_ev_calls (0); tc_data.state.pending.count = 0; on terminal_control_disconnection_ go to give_up_shut; call clear_screen_proc; call send_initial_string (0); call set_modes (tc_data.old_mode_string, "", (0)); give_up_shut: call cleanup_init; if tc_data.ttt_video_ptr ^= null then free tc_data.ttt_video_ptr -> tty_video_table; free tc_data; TC_data_ptr = null (); call ipc_$unmask_ev_calls (0); call hcs_$reset_ips_mask (ips_mask, ""b); return; /* This entry is called when changing the terminal type. It cleans up terminal type dependent info from tc_data but leaves all else alone. */ shut_ttp_info: entry (TC_data_ptr); tc_data_ptr = TC_data_ptr; if tc_data.ttt_video_ptr ^= null () then free tc_data.ttt_video_ptr -> tty_video_table; if tc_data.screen_data_ptr ^= null () then call tc_screen$shut (tc_data.screen_data_ptr); call tc_request$shut (tc_data_ptr, (0)); return; cleanup_init: procedure; if tc_data.screen_data_ptr ^= null () then call tc_screen$shut (tc_data.screen_data_ptr); if tc_data.input_buffer_ptr ^= null () then call tc_input$shut (tc_data_ptr); if tc_data.desk_ptr ^= null () then free windows; call tc_request$shut (tc_data_ptr, (0)); if tc_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$detach (tc_data.tty_handle, (0), (0), (0)); else if tc_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ call ws_tty_$detach (tc_data.mowse_terminal_iocb_ptr, (0), (0), (0)); else /* MCS */ call hcs_$tty_detach (tc_data.devx, (0), (0), (0)); end cleanup_init; find_free_slot: procedure returns (fixed bin); declare w fixed bin; do w = 1 to hbound (windows, 1); if ^windows (w).in_use then do; /* this should mask, or stacq, or something */ windows (w).in_use = "1"b; windows (w).status_pending = "0"b; windows (w).pad = ""b; windows (w).window_id = substr (reverse (bit (clock (), 72)), 1, 19) || bit (w, 17); return (w); end; end; signal tc_too_many_windows_; declare tc_too_many_windows_ condition; end find_free_slot; find_window: procedure (window_id, code) returns (fixed bin); declare window_id bit (36) aligned; declare code fixed bin (35); declare wx fixed bin; wx = bin (substr (window_id, 20), 17); if windows (wx).window_id ^= window_id then do; code = video_et_$bad_window_id; return (0); end; return (wx); end find_window; check_bounds: procedure (code); declare code fixed bin (35); /* The screen is assumed to have one "phantom" position beyond its specified width, where the cursor may be positioned, but text may (possible) not be displayed. The cursor may be positioned anyplace including the phantom column, but text may not be placed there, for after putting out the text the cursor would have noplace to go. This may be nondelux, but it works. Also, characters may not be solicted from that column, for we could not echo. */ if request_header.row < 1 /* not in the sky */ | request_header.col < 1 /* or in china */ | request_header.row < windows (wx).top_row /* or not in */ | request_header.row > windows (wx).top_row + windows (wx).n_rows - 1 | request_header.col < windows (wx).first_column | request_header.col > windows (wx).first_column + windows (wx).n_columns then go to OUT_OF_BOUNDS; go to OP (request_header.operation); OP (0): /* OP_ERROR */ return; OP (1): /* OP_POSITION_CURSOR */ call check_bounds_within_phantom; return; OP (2): /* OP_CLEAR_REGION */ call check_bounds_within_phantom; if request_clear_region.rows > /* extent requested */ (windows (wx).n_rows - (request_header.row - windows (wx).top_row)) then go to OUT_OF_BOUNDS; if (request_clear_region.columns - request_header.col - 1) > windows (wx).n_columns then go to OUT_OF_BOUNDS; /* this will permit zero width regions in phantom col */ return; OP (14): /* OP_OVERWRITE_TEXT */ OP (3): /* OP_INSERT_TEXT */ call check_bounds_within_phantom; /* allow starting in phantom col */ /* make sure final column isn't beyond phantom col */ if (request_header.col + request_text.text_length) > windows (wx).first_column + windows (wx).n_columns + 1 then go to OUT_OF_BOUNDS; return; OP (6): /* OP_DELETE_CHARS */ call check_bounds_within_window; if (request_header.col + request_delete_chars.count) > windows (wx).first_column + windows (wx).n_columns + 1 then go to OUT_OF_BOUNDS; return; OP (7): /* OP_SCROLL_REGION */ /* coords are not payed attention to */ if windows (wx).n_columns ^= tc_data.columns then /* naughty, naughty, a partial width window! */ do; /* no i-del lines for these windows. tc_request should do this check, but it doesn't know about windows ... sigh */ Code = video_et_$capability_lacking; return; end; if request_scroll_region.start_line < windows (wx).top_row /* */ | request_scroll_region.start_line > windows (wx).top_row + windows (wx).n_rows - 1 /* */ | request_scroll_region.n_lines < 1 | request_scroll_region.start_line + request_scroll_region.n_lines > windows (wx).top_row + windows (wx).n_rows then go to OUT_OF_BOUNDS; return; OP (9): /* OP_GET_CHARS_ECHO */ call check_bounds_within_window; if request_read.buffer_length + request_read.col > windows (wx).first_column + windows (wx).n_columns + 1 then go to OUT_OF_BOUNDS; return; OP (11): /* OP_WRITE_SYNC_GET_CHARS_NO_ECHO */ call check_bounds_within_window; if request_read.prompt_length + request_read.col > windows (wx).first_column + windows (wx).n_columns + 1 then go to OUT_OF_BOUNDS; return; /* we don't check bounds for unechoed input, raw output and things that don't change the screen. */ OP (10): /* OP_GET_CHARS_NO_ECHO */ OP (16): /* OP_READ_ONE */ OP (13): /* OP_READ_STATUS */ OP (12): /* OP_GET_CURSOR_POSITION */ OP (15): /* OP_WRITE_RAW */ OP (8): /* OP_BELL */ return; OUT_OF_BOUNDS: Code = video_et_$out_of_window_bounds; return; check_bounds_within_phantom: procedure; if request_header.col < windows (wx).first_column /* left */ | request_header.col > windows (wx).first_column + windows (wx).n_columns + 1 /* right */ then go to OUT_OF_BOUNDS; return; check_bounds_within_window: entry; if request_header.col < windows (wx).first_column | request_header.col > windows (wx).first_column + windows (wx).n_columns - 1 then go to OUT_OF_BOUNDS; end check_bounds_within_phantom; end check_bounds; /**** The code that follows logically belongs in tc_io_. It has been transplanted here to avoid having the tc_io_ stack frame pushed for every video operation. ****/ set_up: procedure; Code = 0; actual_iocbp = Iocbp -> iocb.actual_iocb_ptr; attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr; mask = ""b; return; end set_up; declare Iocbp pointer; declare actual_iocbp pointer; declare mask bit (36) aligned; %page; %include tc_io_attach_data_; %include tc_desk_info_; %include iocb; %page; tc_io_control: entry (Iocbp, Order, Info_ptr, Code); call set_up; tc_data_ptr = attach_data.tc_info_ptr; declare line_speed_ptr pointer; declare line_speed fixed bin based (line_speed_ptr); declare sub_error_ condition; dcl 1 fsc_info like mowse_io_flush_subchannel_info; attach_data.operation_hlock = attach_data.operation_hlock + 1; on terminal_control_disconnection_ call disconnect_handler; on cleanup attach_data.operation_hlock = attach_data.operation_hlock - 1; on sub_error_ call perhaps_internal_error; if /* case */ Order = "window_operation" then call request_proc (Info_ptr, Code); else if Order = "clear_screen" then call clear_screen_proc; else if Order = "get_screen_image_ptr" then call get_screen_image_proc (Info_ptr); /* POINTER IS OUTPUT ! */ else if Order = "get_capabilities" then call get_capabilities_proc (Info_ptr); else if Order = "check_in_window" then do; tc_desk_info_ptr = Info_ptr; call check_in_window_proc (tc_desk_window_info.first_row, tc_desk_window_info.n_rows, tc_desk_window_info.first_column, tc_desk_window_info.n_columns, tc_desk_window_info.window_id, tc_desk_window_info.window_iocb_ptr); end; else if Order = "check_out_window" then do; tc_desk_info_ptr = Info_ptr; call check_out_window_proc (tc_desk_window_info.window_id); end; else if Order = "resize_window" then do; tc_desk_info_ptr = Info_ptr; call resize_window_proc (tc_desk_window_info.window_id, tc_desk_window_info.first_row, tc_desk_window_info.n_rows, tc_desk_window_info.first_column, tc_desk_window_info.n_columns); end; else if Order = "set_line_speed" then do; line_speed_ptr = Info_ptr; tc_data.line_speed = line_speed; end; else if Order = "debug_on" then attach_data.debug = "1"b; else if Order = "debug_off" then attach_data.debug = "0"b; else if Order = "set_term_type" then do; begin; sttip = Info_ptr; if sttip = null () then do; Code = error_table_$null_info_ptr; return; end; if set_term_type_info.version ^= stti_version_1 then do; Code = error_table_$unimplemented_version; return; end; call set_term_type_proc (set_term_type_info.name, Code); return; end; /* begin */ end; /* case do */ else if Order = "reconnection" then call reconnection_proc (Code); else if Order = "randomize_redisplay" then /* to prevent position_cursor from optimizing */ tc_data.state.cursor_valid = "0"b; else if Order = "initialize_mowse_terminal" then do; fsc_info.subchannel = FG; fsc_info.version = mowse_io_info_version_1; call iox_$control (tc_data.mowse_terminal_iocb_ptr, "flush_subchannel", addr (fsc_info), Code); call init_ttp_info_3 (Code); if Code ^= 0 then return; call ws_tty_$attach (tc_data.mowse_terminal_iocb_ptr, Channel, Event, tty_state, Code); end; else call call_order (Order, Info_ptr, Code); /* Trust our caller */ reconnection_proc: proc (Code); dcl new_ttp char (32); dcl video_info_ptr ptr; dcl Code fixed bin (35); dcl user_info_$terminal_data entry (char (*), char (*), char (*), fixed bin, char (*)); dcl tc_io_$reconnection entry (ptr, fixed bin (35)); dcl video_utils_$turn_off_login_channel entry (fixed bin (35)); call user_info_$terminal_data ("", new_ttp, "", (0), ""); /* get new terminal type */ /* see if the new terminal will fly before trying to tweak tc_io_ */ call get_video_info_ptr (new_ttp, 0, video_info_ptr, Code); if Code ^= 0 then do; REVOKE_VIDEO: call video_utils_$turn_off_login_channel (Code); return; end; call verify_capabilities (video_info_ptr, Code); if video_info_ptr ^= null () /* let's play it safe */ then free video_info_ptr -> tty_video_table; if Code ^= 0 then goto REVOKE_VIDEO; /* looks good ... let's tell tc_ */ call tc_io_$reconnection (attach_data_ptr, Code); if Code ^= 0 then goto REVOKE_VIDEO; /* Now inform window (and therefore applications) of the change */ dcl 1 WSI aligned like window_status_info; dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); WSI.version = window_status_version_1; WSI.status_string = W_STATUS_TTP_CHANGE | W_STATUS_SCREEN_INVALID | W_STATUS_RECONNECTION; do wx = 1 to hbound (windows, 1); if windows (wx).in_use then call iox_$control (windows (wx).window_iocb_ptr, "set_window_status", addr (WSI), (0)); end; /* do */ return; end reconnection_proc; set_term_type_proc: proc (new_ttp, Code); dcl new_ttp char (*); dcl Code fixed bin (35); dcl video_info_ptr ptr; /* First a dry run to make sure the new ttp will fly */ call get_terminal_info(new_ttp, (0), Code); if Code ^= 0 then return; call check_protocol (ttd.protocol, Code); if Code ^= 0 then return; call get_video_info_ptr (new_ttp, 0, video_info_ptr, Code); if Code ^= 0 then return; call verify_capabilities (video_info_ptr, Code); if video_info_ptr ^= null () /* play it safe */ then free video_info_ptr -> tty_video_table; if Code ^= 0 then return; /* Update tc_'s idea of the terminal type */ call tc_$shut_ttp_info (tc_data_ptr); call tc_$init_ttp_info (tc_data_ptr, set_term_type_info.name, Code); if Code ^= 0 then return; /* Boy are we in trouble if this doesn't work */ /* Now inform window (and therefore applications) of the change */ dcl 1 WSI aligned like window_status_info; dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); WSI.version = window_status_version_1; WSI.status_string = W_STATUS_TTP_CHANGE | W_STATUS_SCREEN_INVALID; do wx = 1 to hbound (windows, 1); if windows (wx).in_use then call iox_$control (windows (wx).window_iocb_ptr, "set_window_status", addr (WSI), (0)); end; /* do */ return; end set_term_type_proc; clear_screen_proc: procedure; declare 1 rcr aligned like request_clear_region; rcr.sentinel = REQUEST_SENTINEL; rcr.request_id = clock (); rcr.window_id = (36)"1"b; /* Special internal op */ rcr.coords = 1; /* will set both values */ rcr.operation = OP_CLEAR_SCREEN_NO_OPT; rcr.extent.rows = tc_data.terminal.rows; rcr.extent.columns = tc_data.terminal.columns; call request_proc (addr (rcr), (0)); return; end clear_screen_proc; get_screen_image_proc: procedure (si_ptr); declare si_ptr pointer; si_ptr = tc_data.screen_data_ptr; /* violate modularization, but its cheaper */ return; end get_screen_image_proc; reinit_return: if tc_data.state.pending.count < 0 then tc_data.state.pending.count = 0; if attach_data.operation_hlock ^= 0 then attach_data.operation_hlock = attach_data.operation_hlock - 1; return; hangup_return: attach_data.operation_hlock = attach_data.operation_hlock - 1; return; disconnect_handler: procedure; /* The disconnection strategy is different from that of tty_ */ /* If we are a login_channel, and a disconnection occurs, we wait for the reconnection, but we want applications to know that something is wrong. also, none of the checked-in windows will be valid after a detach/reattach. So when window_io_ gets an invalid-window-id fom us/tc_, it must attempt to re-check-in, and consider that evidence that it can trust no screen state. Thus "completing the operation" on disconnections is not neccessary ... we wait for the reconnection, and then return invalid_window_id. We cannot return a more mnemotic code because the disconnect, detach, attach could have happened while we were not even on the stack to notice. If we are not a login channel, then the disconnection is just a hungup channel, which we translate back into io_no_permission and return it to the caller. */ declare video_et_$bad_window_id fixed bin (35) ext static; declare find_condition_info_ entry (pointer, pointer, fixed binary (35)); declare video_utils_$turn_off_for_debug entry; declare timer_manager_$sleep entry (fixed binary (71), bit (2)); declare video_data_$error_name external static character (32); %include condition_info; %include condition_info_header; %include tc_disconnect_info; %include sub_error_info; declare 1 ci aligned like condition_info; declare error_table_$io_no_permission external static fixed bin (35); ci.version = condition_info_version_1; call find_condition_info_ (null (), addr (ci), (0)); tcdi_ptr = ci.info_ptr; if tc_data.network_type = DSA_NETWORK_TYPE then do; if tc_disconnect_info.tty_handle ^= attach_data.tty_handle then do; call continue_to_signal_ (0); return; end; end; else if tc_data.network_type = MOWSE_NETWORK_TYPE then do; if tc_disconnect_info.mowse_terminal_iocb_ptr ^= attach_data.mowse_terminal_iocb_ptr then do; call continue_to_signal_ (0); return; end; end; else if tc_disconnect_info.devx ^= attach_data.tty_index then do; call continue_to_signal_ (0); return; end; if ^attach_data.login_channel then do; Code = error_table_$io_no_permission; call force_unmask; go to hangup_return; end; /* We are a login channel */ call force_unmask; do while ("1"b); /* wait one minute for AS to take care of us */ if attach_data.async_detach then goto reconnected; call timer_manager_$sleep (2, "11"b /* rel secs */); end; reconnected: Code = video_et_$bad_window_id; go to hangup_return; perhaps_internal_error: entry; ci.version = 1; call find_condition_info_ (null (), addr (ci), (0)); sub_error_info_ptr = ci.info_ptr; if sub_error_info.name ^= video_data_$error_name then do; call continue_to_signal_ (0); return; end; /* Its ours, and noone elses */ if attach_data.login_channel then do; if attach_data.debug then do; call video_utils_$turn_off_for_debug; call continue_to_signal_ (0); ci.info_ptr -> condition_info_header.cant_restart = "1"b; return; end; call shut (attach_data.tc_info_ptr); call init (attach_data.tc_info_ptr, attach_data.device_used, attach_data.event_wait.channel_id (1), "", "0"b /* not reconnection */, attach_data.mowse_terminal_iocb_ptr, Code); if Code = 0 then Code = video_et_$bad_window_id; go to reinit_return; end; /* login channel case */ call continue_to_signal_ (0); /* emit the error msg */ return; end disconnect_handler; force_unmask: procedure; declare hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); call hcs_$reset_ips_mask ((36)"1"b, ""b); end force_unmask; %page; %include net_event_message; %include tty_video_tables; %page; %include tc_data_; %page; %include tc_operations_; %page; %include terminal_type_data; %include term_type_protocols; %include terminal_info; %page; %include set_term_type_info; %page; /* So we can do a set_window_status at reconnection and ttp change time */ %include window_control_info; %page; %include window_status; %page; %include sub_err_flags; %page; %include terminal_capabilities; %page; %include mowse_messages; %page; %include mowse_io_control_info; %page; %include mowse; %include mcs_echo_neg; end tc_;  tc_block.pl1 08/13/87 1333.0rew 08/13/87 1323.9 62037 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-09-17,LJAdams), approve(86-11-11,MCR7485), audit(86-12-16,Margolin), install(87-01-06,MR12.0-1255): Correct stringrange problem - after function was completed it continued to loop until stack was exhausted. END HISTORY COMMENTS */ /* Benson I. Margulies, sometime in 1981 */ /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */ /* Modified 24 May 1982 by William M. York to eliminate an optimization for the first level of block which led to a loop sending and receiving wakeups. */ /* Modified 14 September 1982 by WMY to add the $internal entrypoint. This is intended for use by other parts of tc_ (e.g. check_echonego in tc_input) which want to block with protocol, but have no window_ level request structure to pass in. */ /* Modified 20 September 1982 by WMY to remove the $internal entrypoint. We must ALWAYS block on the behalf of some particular window for the async stuff to work right, so all callers will just have to be changed to pass in a request_ptr. */ /* Modified 7 February 1985 by Jon Rochlis to add RESTORE_MASK so we can restore the user's ips mask before we block, instead of just unmasking everything. */ tc_block: procedure (TC_data_ptr, Request_ptr, mask_type); declare TC_data_ptr pointer; declare Request_ptr pointer; /* ordinarily, we unmask for the block, but in the case of awaiting a mark we want to allow only quit. This is to prevent other stuff from happening when we are doing a critical sync, because if the async thing should need to sync to a mark, we would lack one to give it. This is really poor, a major limitation on async input. (Now instead of unmasking, we usually restore the old mask ... JR 2/7/85) */ declare mask_type bit (36) aligned; declare UNMASK_ALL bit (36) aligned initial (""b) internal static options (constant); declare UNMASK_QUIT_ONLY bit (36) aligned initial ("1"b) internal static options (constant); declare UNMASK_NOTHING bit (36) aligned initial ("01"b) internal static options (constant); declare RESTORE_MASK bit (36) aligned initial ("001"b) internal static options (constant); declare 1 EWI aligned like event_wait_info automatic; declare 1 event_wait aligned, 2 n_channels fixed bin, 2 pad bit (36) aligned, 2 channels (2) fixed bin (71); declare ipc_$block entry (ptr, ptr, fixed bin (35)); declare ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); declare tc_error entry (fixed bin (35), character (*)); declare ( tc_mask$close, tc_mask$open_all, tc_mask$open_quit ) external entry; declare tc_mask$restore entry (bit (36) aligned); declare hcs_$get_ips_mask entry (bit (36) aligned); declare ips_mask bit (36) aligned; declare saved_change_pclock fixed bin (35); declare code fixed bin (35); declare cleanup condition; declare addr builtin; tc_data_ptr = TC_data_ptr; request_ptr = Request_ptr; state.pending.count = tc_data.state.pending.count + 1; state_have_sent_protocol (tc_data.state.pending.count) = "0"b; state_async_same_window (tc_data.state.pending.count) = "0"b; tc_data.state.pending.blocked_windows (tc_data.state.pending.count) = request_header.window_id; event_wait.n_channels = 0; event_wait.pad = ""b; event_wait.channels (1) = tc_data.event; /* Set up a second event channel to block on in conjunction with the actual input channel. A wakeup will be sent on this protocol channel by later (recursive) invocations of tc_block when they receive real input wakeups. */ event_wait.n_channels = 2; if tc_data.state.pending.protocol_evs (tc_data.state.pending.count) = 0 then do; call ipc_$create_ev_chn (event_wait.channels (2), (0)); tc_data.state.pending.protocol_evs (tc_data.state.pending.count) = event_wait.channels (2); end; else event_wait.channels (2) = tc_data.state.pending.protocol_evs (tc_data.state.pending.count); ips_mask = request_header.saved_ips_mask; on cleanup begin; state.pending.count = state.pending.count - 1; if mask_type = RESTORE_MASK then call hcs_$get_ips_mask (request_header.saved_ips_mask); end; saved_change_pclock = tc_data.change_pclock; if mask_type = UNMASK_QUIT_ONLY /* actually, this lets trm_ and sus_ and neti through, as well */ then call tc_mask$open_quit; else if mask_type = UNMASK_ALL then call tc_mask$open_all; else if mask_type = UNMASK_NOTHING then ; else if mask_type = RESTORE_MASK then call tc_mask$restore (ips_mask); call ipc_$block (addr (event_wait), addr (EWI), code); call tc_mask$close (); /* superfluous if we didnt unmask */ revert cleanup; tc_data.state.pending.count = tc_data.state.pending.count - 1; if code ^= 0 then call tc_error (code, "Terminal Control could not block."); if (tc_data.change_pclock ^= saved_change_pclock) then do; request_header.async_interruption = "1"b; if state_async_same_window (tc_data.state.pending.count + 1) then request_header.this_window = "1"b; end; start_if_we_have_to: begin; declare hcs_$wakeup entry (bit (*), fixed bin (71), fixed bin (71), fixed bin (35)); declare get_process_id_ entry () returns (bit (36)); /* This code checks to see if anyone is waiting on protocol wakeups (i.e. this is a recursive call), and sends a wakeup to the protocol channel one above us. Only one wakeup will be sent on each level. */ if tc_data.state.pending.count > 0 then if ^state_have_sent_protocol (tc_data.state.pending.count) then do; /* Somebody is blocked */ call hcs_$wakeup (get_process_id_ (), tc_data.state.pending.protocol_evs (tc_data.state.pending.count), 0, code); if code ^= 0 then call tc_error (code, "wakeup failed"); state_have_sent_protocol (tc_data.state.pending.count) = "1"b; /* only send ONE wakeup */ end; end start_if_we_have_to; %page; %include tc_data_; %include tc_operations_; %include event_wait_info; end tc_block;  tc_disconnect.pl1 08/13/87 1333.0r 08/13/87 1323.9 23301 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-12-17,LJAdams), approve(86-12-17,MCR7485), audit(86-12-19,Margolin), install(87-01-06,MR12.0-1255): Modified to support MOWSE. 2) change(86-12-17,LJAdams), approve(86-12-17,MCR7584), audit(86-12-19,Margolin), install(87-01-06,MR12.0-1255): Modified to support DSA. 3) change(87-01-05,LJAdams), approve(87-01-05,MCR7485), audit(87-01-05,Blair), install(87-01-06,MR12.0-1255): Initialize tc_data_ptr. END HISTORY COMMENTS */ /* Understander of disconnections for Terminal Control */ /* Benson I. Margulies, sometime in 1981 */ /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */ tc_disconnect: procedure; return; declare error_table_$io_no_permission external static fixed bin (35); declare (addr, currentsize, null, string) builtin; declare Code fixed bin (35); declare TC_data_ptr pointer; declare signal_ entry () options (variable); %include condition_info_header; %include tc_disconnect_info; declare 1 tcdi aligned like tc_disconnect_info; %include tc_data_; %include net_event_message; check: entry (TC_data_ptr, Code); if Code ^= error_table_$io_no_permission then return; tc_data_ptr = TC_data_ptr; string (tcdi.action_flags) = ""b; tcdi.length = currentsize (tcdi); tcdi.cant_restart = "1"b; tcdi.info_string = "A terminal managed by video terminal control has hungup."; tcdi.status_code = 0; tcdi.tc_data_ptr = TC_data_ptr; if tc_data.network_type = DSA_NETWORK_TYPE then tcdi.tty_handle = tc_data.tty_handle; else if tc_data.network_type = MOWSE_NETWORK_TYPE then tcdi.mowse_terminal_iocb_ptr = tc_data.mowse_terminal_iocb_ptr; else tcdi.devx = tc_data.devx; call signal_ ("terminal_control_disconnection_", null (), addr (tcdi)); return; end tc_disconnect;  tc_error.pl1 08/13/87 1333.0rew 08/13/87 1323.8 11457 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Benson I. Margulies, sometime in 1981 */ /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */ tc_error: procedure (code, msg) options (support); declare code fixed bin (35); declare msg character (*); declare null builtin; declare sub_err_ entry () options (variable); declare video_data_$error_name character (32) external static; call sub_err_ (code, video_data_$error_name, "s", null (), (0), "Internal error in video system terminal control.^/ ^a.", msg); /* may not return with "s" there */ end tc_error;  tc_input.pl1 10/07/88 1414.7rew 10/07/88 1412.5 300366 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-07-08,Coren), approve(86-07-08,MCR7300), audit(86-07-08,Beattie), install(86-07-08,MR12.0-1089): Changed to use v1_echo_neg_data for compatibility. 2) change(86-07-15,LJAdams), approve(86-11-11,MCR7485), audit(86-12-16,Margolin), install(87-01-06,MR12.0-1255): Modified to support MOWSE. 3) change(86-11-26,LJAdams), approve(86-11-26,MCR7584), audit(86-12-16,Margolin), install(87-01-06,MR12.0-1255): Initial DSA coding has been maintained in a non-executable form. 4) change(87-02-10,LJAdams), approve(87-03-19,MCR7642), audit(87-04-24,Gilcrease), install(87-05-14,MR12.1-1030): Passing a (-1) parameter to ws_tty_$read_echoed on the initial read. 5) change(87-02-12,RBarstad), approve(87-03-19,MCR7642), audit(87-04-24,Gilcrease), install(87-05-14,MR12.1-1030): Don't try to reset the break table if operation is OP_READ_ONE. The break table is not needed on read one char and it was never init'ed in the request_read structure by window_ anyway. 6) change(87-02-17,RBarstad), approve(87-03-19,MCR7642), audit(87-04-24,Gilcrease), install(87-05-14,MR12.1-1030): Added block bit to read_with_mark call. 7) change(87-06-02,RBarstad), approve(87-02-17,MCR7485), audit(87-06-30,Gilcrease), install(87-08-04,MR12.1-1055): In ...$read_and_buffer changed the (-1) back to "dummy" and added the "screen_left" variable for readability. 8) change(87-06-15,LJAdams), approve(87-06-15,MCR7584), audit(87-06-30,Gilcrease), install(87-08-04,MR12.1-1055): When calling dsa_tty_$read_echoed set return code to 0 to prevent blockage of interactive messages. 9) change(88-09-27,LJAdams), approve(88-09-27,MCR8001), audit(88-10-06,Farley), install(88-10-07,MR12.2-1148): There was a problem with the bounds of the data and/or control buffers being pointed to by the input buffer being exceeded; to correct this a check has been implemented in add_1_to_buffer, and common to ensure that the current buffer length as kept track of in the input_buffer structure plus the characters to be added will not exceed bounds of the existing data/control buffer arrays. If the check fails the push_buffer routine is called to push the data down by eliminating those characters marked for deletion. If this fails the size of the data_buffer and the control_buffer is increased by calling the grow_buffer routine. END HISTORY COMMENTS */ /* Terminal Control Input Processing -- low level Initial implementation -- May 1981 This program accesses hcs_$tty_* directly. This programmed is destined to stay in Terminal Control when it is divested from the video system. Design and Initial Coding by Benson I. Margulies, inspiration by JRD, BSG, the cow's stomach, and lots of help from MND. */ /* Modified April 82 by William York to call the new tty_read_echoed entrypoint, the replacement for echo_negotiate_get_chars. */ /* Modified 23 June 82 by WMY to fix a bug in try_to_satisfy which caused spurious double echoing of asynchronous output that interrupted get_echoed_chars calls. */ /* Modified 19 August 1982 by WMY to go blocked waiting for FNP interrupt when we get the echnego_awaiting_stop_sync code back from tty_read_echoed while closing out echo negotiation. This FINALLY fixes the "looping while reading input" bug. */ /* Modified 24 August 1982 to fix a bug in the above fix. The close_out_echnego routine now calls ipc_$block directly instead of tc_block, since it doesn't want to deal with request structures from the caller. */ /* Modified 10 September 1982 by WMY to fix a bug in the fix to the above fix. It now calls tc_block$internal to make sure that protocol wakeups happen. */ /* Modified 20 September 1982 by WMY. Oh well, one more time. Changed the check_echnego entry to take a request_ptr as a parameter, and call regular tc_block with that request_ptr. We ALWAYS have to block on the behalf of some particular window for async stuff to work right. */ /* Modified 22 September 1982 by WMY to remove the code that attempts to sync to the output already written if the input buffer length is 0. This code went blocked until the user typed something, waiting for ring 0 to return the mark. This was useless, and until ring 0 can be changed to return the mark without actually waiting for new input, tc_input will just return if the input buffer size is 0. */ /* Modified 14 August 1984 by Jon A. Rochlis to remove the Code parameter from the init entry, since it is never used. It appears never to be used by the tc_input entry either, and I am real tempted to remove it altogether. */ /* Modified 7 February 1985 by JR to use RESTORE_MASK instead of UNMASK_ALL when calling tc_block. This will restore the user's mask instead of arbitrarly unmasking everything. */ /* Modified June 1985 by Roger Negaret to support DSA networks. */ /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */ tc_input: procedure (TC_data_ptr, Request_ptr, Code); go to do_input; /* skip over all these dcls */ /* Parameters */ declare ( Request_ptr pointer, TC_data_ptr pointer, Code fixed bin (35) ) parameter; %page; %include net_event_message; %include tc_operations_; %page; %include tc_data_; %page; %include tc_input_buffer_; %page; %include mcs_echo_neg; %page; declare code fixed bin (35); declare tty_state fixed bin; declare dsa_tty_$read_echoed entry (fixed bin (35), ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, fixed bin, fixed bin (35)); declare ws_tty_$read_echoed entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, fixed bin, fixed bin (35)); declare add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; declare tc_request$write_echo entry (pointer, char (*)); declare tc_error entry (fixed binary (35), character (*)); declare tc_screen$text entry (pointer, fixed bin, fixed bin, bit (1) aligned, character (*)); declare tc_disconnect$check entry (pointer, fixed bin (35)); declare ( video_et_$tc_tty_error, video_et_$tc_mark_missing ) external static fixed bin (35); declare BUF_LEN fixed bin internal static options (constant) init (2048); declare UNMASK_NOTHING bit (36) aligned initial ("01"b) internal static options (constant); declare RESTORE_MASK bit (36) aligned initial ("001"b) internal static options (constant); declare (addr, byte, hbound, index, length, min, null, rank, rtrim, string, substr, unspec) builtin; init: entry (TC_data_ptr); /* The structure tc_data must be already allocated . This program fills in the input side data */ tc_data_ptr = TC_data_ptr; state.echnego_outstanding = "0"b; allocate input_buffer set (input_buffer_ptr); tc_data.input_buffer_ptr = input_buffer_ptr; input_buffer.buffer_length = BUF_LEN; allocate control_buffer set (input_buffer.control_ptr); allocate data_buffer set (input_buffer.data_ptr); input_buffer.n_valid = 0; input_buffer.n_shifts = 0; input_buffer.n_chars_valid = 0; return; shut: entry (TC_data_ptr); tc_data_ptr = TC_data_ptr; input_buffer_ptr = tc_data.input_buffer_ptr; free data_buffer; free control_buffer; free input_buffer; tc_data.input_buffer_ptr = null (); return; do_input: tc_data_ptr = TC_data_ptr; input_buffer_ptr = tc_data.input_buffer_ptr; Code = 0; request_ptr = Request_ptr; declare 1 i_op aligned automatic, /* the stack is the q */ 2 buffer_ptr pointer, 2 buffer_length fixed bin (21), 2 cur_buffer_ptr pointer, 2 cur_buffer_length fixed bin (21), 2 write_buffer_count fixed bin (21), 2 flags aligned, 3 echo bit (1) unaligned, 3 mark_was_outstanding bit (1) unaligned, 3 write_sync_read bit (1) unaligned, 3 just_one_char bit (1) unaligned, 3 pad bit (32) unaligned, 2 buffer_index fixed bin (21); /* last place we scanned, relative to buffers */ /* ASSERT echonegotiation cannot be pending. */ /* ASSERT the request is get_chars_no_echo, get_chars_echo, read_status, or write_sync_get_chars_no_echo */ if request_header.operation = OP_READ_STATUS then do; call read_status; return; end; /* ASSERT that a mark is cast after each output by tc_request */ /* There are two limitations on the current mark implementation. (1) There is only one mark. (2) We cannot get the mark back unless there is some other input from the terminal. As a result, the only available strategy for now is this: After each output, cast the mark. If it is already outstanding, then it is lost. For an asyncronous request for input, we wait for the last mark left out. This syncs us correctly. For a write-sync-read, the prompt has already been written and marked, and we were called masked. */ /* One final case - a zero-length input request of any flavor is interpreted as a request to sync input to output, using the last mark we put out */ /* Ring zero cannot currently return us the mark unless new input is typed by the user after the mark is written. This causes us to go blocked waiting for some input if we want to read the mark. Since that is pretty useless, we will give up this sync attempt until ring 0 can be changed to return the mark if it is there without requiring that new input be typed. -WMY 9/22/82 */ /* Old code to sync to mark, currently out of service. if request_read.buffer_length = 0 then do; if mark_outstanding () then call retrieve_mark; go to request_satisfied; end; */ if request_read.buffer_length = 0 then goto request_satisfied; unspec (i_op) = ""b; /* turn all the flags off */ i_op.mark_was_outstanding = mark_outstanding (); i_op.write_sync_read = (request_header.operation = OP_WRITE_SYNC_GET_CHARS_NO_ECHO); i_op.just_one_char = (request_header.operation = OP_READ_ONE); i_op.buffer_index = 1; /* assume this request is interested in whole buffer. If it requires a mark, this will get reset by retrieve_mark */ /* ASSERT mark_outstanding, trust tc_request to have wrote mark after cursorpos */ if i_op.write_sync_read then call retrieve_mark; i_op.buffer_ptr, i_op.cur_buffer_ptr = request_read.buffer_ptr; i_op.buffer_length, i_op.cur_buffer_length = request_read.buffer_length; if request_header.operation = OP_GET_CHARS_ECHO then i_op.echo = "1"b; if request_header.operation ^= OP_READ_ONE then if (request_read.breaks ^= tc_data.breaktest) then call set_break_table; request_read.returned_length = 0; if i_op.just_one_char then do; if ^request_read.returned_break_flag /* This is really a block_flag */ then do; call read_to_mark_no_block (RESTORE_MASK); request_read.returned_break_flag = try_to_satisfy (); go to request_satisfied; end; end; /* The count of 1 in the READ_ONE call will cause the following to do the right thing */ do while (^try_to_satisfy ()); call read_and_buffer; end; request_satisfied: /* move the buffer down if we can */ if tc_data.state.pending.count = 0 /** **/ & input_buffer.n_valid ^< 1 then begin; declare (i, first_valid_x) fixed bin (21); do first_valid_x = 1 to input_buffer.n_valid while (control_buffer (first_valid_x).deleted); end; /* set i to first nondeleted */ if first_valid_x ^> input_buffer.n_valid/** **/ & first_valid_x > 1 then do; do i = first_valid_x to input_buffer.n_valid; control_buffer (i - first_valid_x + 1) = control_buffer (i); data_buffer (i - first_valid_x + 1) = data_buffer (i); end; input_buffer.n_valid = input_buffer.n_valid - first_valid_x + 1; end; else if first_valid_x > input_buffer.n_valid then do; if input_buffer.n_valid + 1 > input_buffer.buffer_length then call grow_buffer; else input_buffer.n_valid = 0; end; end; return; /* ASSERT the ips mask is masked down */ check_echnego: entry (TC_data_ptr, Request_ptr); tc_data_ptr = TC_data_ptr; request_ptr = Request_ptr; input_buffer_ptr = tc_data.input_buffer_ptr; if state.echnego_outstanding then call close_out_echnego; else if state.pending.count > 0 then call read_to_mark_no_block (UNMASK_NOTHING); return; mark_outstanding: procedure returns (bit (1) aligned); return (state.last_mark_back < state.current_mark); end mark_outstanding; mark_in_buffer: procedure (mark) returns (bit (1) aligned); /* Search the buffer for a mark, if it is there return 1 and set buffer_index to point to just after it. */ declare mark fixed bin (9) unsigned; declare s_pos fixed bin (21); /* we start looking here */ declare m_pos fixed bin (21); declare mark_ptr pointer; declare MARK character (1); unspec (MARK) = MARK_CONTROL; s_pos = 1; do while (s_pos < input_buffer.n_valid); m_pos = index (substr (control_buffer_as_chars, s_pos, input_buffer.n_valid - s_pos + 1), MARK); if m_pos = 0 then return ("0"b); /* no marks at all */ m_pos = s_pos + m_pos - 1; /* index of mark in real buffer */ mark_ptr = addr (data_buffer (m_pos)); if mark_ptr -> data_mark.mark_number = mark then do; i_op.buffer_index = m_pos + 1; return ("1"b); end; s_pos = m_pos + 1; /* look again after this mark */ end; /* the do loop */ return ("0"b); end mark_in_buffer; read_to_mark: procedure (mask_type); /* do a tty read to mark to try to find the outstanding mark */ declare mark_index fixed bin (21); declare n_chars_read fixed bin (21); declare mask_type bit (36) aligned; declare hcs_$tty_read_with_mark entry (fixed bin, character (*), fixed bin (21), fixed bin (21), fixed bin, fixed bin (35)); declare ws_tty_$read_with_mark entry (ptr, char (*), bit (1) aligned, fixed bin (21), fixed bin (21), fixed bin, fixed bin (35)); declare dsa_tty_$read_with_mark entry (fixed bin (35), character (*), fixed bin (21), fixed bin (21), fixed bin, fixed bin (35)); declare never_block bit (1) aligned; never_block = "0"b; go to read_common; read_to_mark_no_block: entry (mask_type); never_block = "1"b; read_common: read: /* goto here after block returns */ n_chars_read = 0; /* WRITE AROUND A HARDCORE BUG, that INTERPRESTS THIS AS A BUFFER OFFSET */ if tc_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$read_with_mark (tc_data.tty_handle, tc_data.tty_read_buffer, n_chars_read, mark_index, tty_state, code); else if tc_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ call ws_tty_$read_with_mark (tc_data.mowse_terminal_iocb_ptr, tc_data.tty_read_buffer, never_block, n_chars_read, mark_index, tty_state, code); else /* MCS */ call hcs_$tty_read_with_mark (tc_data.devx, tc_data.tty_read_buffer, n_chars_read, mark_index, tty_state, code); if code ^= 0 then call tc_disconnect$check (tc_data_ptr, code); if code ^= 0 then call tty_read_error (code); /* this is not supposed to happen */ if mark_index > 0 then do; /* the prodigal returneth */ if mark_index > 1 then call add_chars_to_buffer (1, mark_index - 1); /* mark_index is index if first character after */ /* Until we have multiple marks, the only one we find can be the current one */ call add_mark_to_buffer (state.current_mark); state.last_mark_back = state.current_mark; call add_chars_to_buffer (mark_index, n_chars_read - mark_index + 1); end; else if n_chars_read > 0 then call add_chars_to_buffer (1, n_chars_read); else /* got no data, block */ if never_block then return; else do; call block (mask_type); /* unmask, block, mask */ go to read; end; end read_to_mark; retrieve_mark: procedure; /* When retrieving the mark, we desire block to use special ips masking techniques to avoid async tasks from being run. Since this is not lisp, we cannot lambda-bind some flag, and a controlled variable would be ugly. So we have to pass a parameter down through read_to_mark */ do while (^mark_in_buffer (state.current_mark)); /* ASSERT that there is a mark outstanding if the current mark is not in the buffer */ if ^mark_outstanding () then call tc_error (video_et_$tc_mark_missing, ""); /* This code used to only unmask QUIT, to avoid async happenings while stopped at WriteSyncRead. This is not really useful because the current mark mechanism is not precise enough to be worth this limitation. */ call read_to_mark (RESTORE_MASK); end; end retrieve_mark; try_to_satisfy: procedure returns (bit (1) aligned); /* see if we can fill up and finish this input request. starting at buffer_index, we scan characters. we skip "dead" characters, and stop on break, or count. Any marks we find we remove, as there can be extraneous marks if we get to set marks on all output some time. */ /* for now we just examine characters in a loop, no fancy searching. We can go for the performance some other day */ declare our_x fixed bin (21); /* current index into input_buffer's */ declare her_x fixed bin (21); /* current index into user buffer */ declare her_buffer (i_op.cur_buffer_length) character (1) unaligned based (i_op.cur_buffer_ptr); /* use array for char-loop approach */ declare only_echoed bit (1) aligned; only_echoed = "0"b; go to common; try_to_satisfy$$already_echoed_only: entry returns (bit (1) aligned); /* RV is a dummy */ only_echoed = "1"b; common: call init_echo_buffer; her_x = 1; our_x = i_op.buffer_index; /* start after our mark */ if input_buffer.n_valid = 0 then return ("0"b); /* why call them back from heaven? */ do while (our_x <= input_buffer.n_valid); /* this terminator happens only when we run out of stuff without satisfying */ if control_buffer (our_x).mark then control_buffer (our_x).deleted = "1"b; else if ^control_buffer (our_x).deleted then begin; /* consider this character */ declare (break_char, needs_echo) bit (1) aligned; declare rank_of_char fixed bin; rank_of_char = rank (data_buffer (our_x).character); /* All chars > \177 are breaks. */ if rank_of_char > 127 then break_char = "1"b; else break_char = tc_break_array (rank_of_char); needs_echo = ^control_buffer (our_x).echoed & i_op.echo; /* Contract is not to return breaks and async_term. There is no good reason for this, but I hesitate to change this without study of window_io_video_. Both would certainly have to be changed. */ if only_echoed & (break_char | needs_echo) then go to found_unechoed; her_buffer (her_x) = data_buffer (our_x).character; her_x = her_x + 1; control_buffer (our_x).deleted = "1"b; if break_char then do; request_read.returned_break_flag = "1"b; go to success; /* try to zonk buffer */ end; if needs_echo then call echo_char (data_buffer (our_x).character); if her_x = hbound (her_buffer, 1) + 1 /* DONE */ then do; request_read.returned_break_flag = "0"b; go to success; end; end; /* if ^deleted */ our_x = our_x + 1; end; /* do loop */ /* If we got here, we ran out of buffer */ request_read.returned_length = request_read.returned_length + (her_x - 1); i_op.cur_buffer_ptr = add_char_offset_ (i_op.cur_buffer_ptr, (her_x - 1)); i_op.cur_buffer_length = i_op.cur_buffer_length - (her_x - 1); i_op.buffer_index = our_x; /* avoid examining same thing twice */ input_buffer.n_chars_valid = input_buffer.n_chars_valid - (her_x - 1); call dump_echo_buffer; return ("0"b); /* we are going to return "1"b */ /* Or we hit a character that we cound not returned because */ /* it had not been echoed. In both cases our_x is one past the last one */ /* that should be returned. */ found_unechoed: success: request_read.returned_length = request_read.returned_length + her_x - 1; input_buffer.n_chars_valid = input_buffer.n_chars_valid - (her_x - 1); if ^only_echoed then call dump_echo_buffer; return ("1"b); end try_to_satisfy; read_and_buffer: procedure; /* Caller of tty_read and get_chars_echo_etc. bufferer of read characters. */ /* we must manage the echo_negotiation flag. */ declare n_chars_read fixed bin (21); /* We can ignore the mark here on the first read call. There is only one reason the mark could be out. It could be left from some output that no call attempted to sync to. This is not interesting, and is not worth giving up negotiation for. We can claim that it is "in" in case someone tries to sync. The mark could be put out asyncronously, but we will close out negotiation before. */ if i_op.echo then do; /* try to negotiate */ state.last_mark_back = state.current_mark; /* fake it */ /* ASSERT: negotiation is not in progress. Thus n_chars_echoed must be zero on return. */ declare dummy fixed bin (21); declare screen_left fixed bin; screen_left = min ((tc_data.columns - request_read.col + 1), i_op.cur_buffer_length); if tc_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$read_echoed (tc_data.tty_handle, addr (tc_data.tty_read_buffer), (0) /* offset */, length (tc_data.tty_read_buffer), n_chars_read, dummy, screen_left, tty_state, code); else if tc_data.network_type = MOWSE_NETWORK_TYPE then call ws_tty_$read_echoed (tc_data.mowse_terminal_iocb_ptr, addr (tc_data.tty_read_buffer), (0), length (tc_data.tty_read_buffer), n_chars_read, dummy, screen_left, tty_state, code); else /* MCS */ call hcs_$tty_read_echoed (tc_data.devx, addr (tc_data.tty_read_buffer), (0) /* offset */, length (tc_data.tty_read_buffer), n_chars_read, dummy, screen_left, tty_state, code); if code ^= 0 then call tc_disconnect$check (tc_data_ptr, code); if code ^= 0 /* we cannot get awaiting_stop_sync because echoing was OFF */ then call tty_read_error (code); if n_chars_read = 0 then do; /* we have entered negotiation */ state.echnego_outstanding = "1"b; call block (RESTORE_MASK); /* now put them in buffer and stop echoing */ call close_out_echnego; return; end; else do; /* it gave us characters */ call add_chars_to_buffer (1, n_chars_read); return; end; end; else call read_to_mark (RESTORE_MASK); end read_and_buffer; add_mark_to_buffer: procedure (mark); declare mark fixed bin (9) unsigned; call add_1_to_buffer (MARK_CONTROL, byte (mark)); end add_mark_to_buffer; /* procedure for adding unechoed characters to the buffer */ add_chars_to_buffer: procedure (start, how_many); declare (start, how_many) fixed bin (21); declare 1 ce unaligned like control_entry; string (ce) = NORMAL_CONTROL; go to chars_common; add_echoed_chars_to_buffer: entry (start, how_many); string (ce) = ECHOED_CONTROL; chars_common: input_buffer.n_chars_valid = input_buffer.n_chars_valid + how_many; go to common; add_1_to_buffer: entry (a_ce, the_char); declare a_ce bit (9); declare istart fixed bin (21); declare the_char character (1) aligned; if input_buffer.n_valid + 1 > input_buffer.buffer_length then input_buffer.n_valid = push_buffer (input_buffer.n_valid); input_buffer.n_valid = input_buffer.n_valid + 1; string (control_buffer (input_buffer.n_valid)) = a_ce; substr (data_buffer_as_chars, input_buffer.n_valid, 1) = the_char; return; common: if input_buffer.n_valid + how_many >= input_buffer.buffer_length then input_buffer.n_valid = push_buffer (input_buffer.n_valid); istart = input_buffer.n_valid + 1; input_buffer.n_valid = input_buffer.n_valid + how_many; begin; declare cx fixed bin; do cx = istart to istart + how_many; control_buffer (cx) = ce; end; end; substr (data_buffer_as_chars, istart, how_many) = substr (tc_data.tty_read_buffer, start, how_many); end add_chars_to_buffer; push_buffer: procedure (nvalid) returns (fixed bin (21)); declare nvalid fixed bin (21); declare i fixed bin (21); declare first_valid_x fixed bin (21); /* There was a problem with the bounds of the input buffer being */ /* exceeded; to correct this a check has been implemented in */ /* add_1_to_buffer, and common to ensure that the current buffer length */ /* plus the characters to be added will not exceed bounds of the */ /* input_buffer. If the check fails this routine is called to push the */ /* buffer down if we can. If this fails the size of the data_buffer */ /* the control_buffer is increased by calling grow_buffer. */ do first_valid_x = 1 to nvalid while (control_buffer (first_valid_x).deleted); end; /* set i to first nondeleted */ if first_valid_x ^> nvalid & first_valid_x > 1 then do; do i = first_valid_x to nvalid; control_buffer (i - first_valid_x + 1) = control_buffer (i); data_buffer (i - first_valid_x + 1) = data_buffer (i); end; nvalid = nvalid - first_valid_x + 1; end; else if first_valid_x > nvalid then call grow_buffer; return (nvalid); end push_buffer; grow_buffer: procedure; new_buf_size = input_buffer.buffer_length + BUF_LEN; allocate new_control_buf set (new_control_buf_ptr); allocate new_data_buf set (new_data_buf_ptr); unspec (new_control_buf) = ""b; substr (new_control_buf_ptr -> temp_data, 1, input_buffer.buffer_length) = substr (input_buffer.control_ptr -> temp_data, 1, input_buffer.buffer_length); unspec (new_data_buf) = ""b; substr (new_data_buf_ptr -> temp_data, 1, input_buffer.buffer_length) = substr (input_buffer.data_ptr -> temp_data, 1, input_buffer.buffer_length); free control_buffer; free data_buffer; input_buffer.buffer_length = new_buf_size; input_buffer.control_ptr = new_control_buf_ptr; input_buffer.data_ptr = new_data_buf_ptr; end grow_buffer; block: procedure (mask_type); declare mask_type bit (36) aligned; declare tc_block entry (pointer, pointer, bit (36) aligned); if tc_data.network_type ^= MOWSE_NETWORK_TYPE then call tc_block (tc_data_ptr, request_ptr, mask_type); if request_header.async_interruption then do; /* pretend to have the mark, since state is uncertain */ call add_mark_to_buffer (state.current_mark); state.last_mark_back = state.current_mark; go to ASYNC_INTERRUPTION; end; end block; close_out_echnego: procedure; declare (n_chars_read, n_chars_echoed) fixed bin (21); declare error_table_$echnego_awaiting_stop_sync fixed bin (35) external static; declare tc_block entry (pointer, pointer, bit (36) aligned); /* ASSERT echo negotiation is already in progress */ code = error_table_$echnego_awaiting_stop_sync; do while (code = error_table_$echnego_awaiting_stop_sync); /* ASSERT: a zero col-left argument turns off negotiation according to the echo negotiation protocol */ if tc_data.network_type = DSA_NETWORK_TYPE then do; /* DSA */ call dsa_tty_$read_echoed (tc_data.tty_handle, addr (tc_data.tty_read_buffer), (0), length (tc_data.tty_read_buffer), n_chars_read, n_chars_echoed, (0), tty_state, code); code = 0; end; else if tc_data.network_type = MOWSE_NETWORK_TYPE then call ws_tty_$read_echoed (tc_data.mowse_terminal_iocb_ptr, addr (tc_data.tty_read_buffer), (0), length (tc_data.tty_read_buffer), n_chars_read, n_chars_echoed, (0), tty_state, code); else /* MCS */ call hcs_$tty_read_echoed (tc_data.devx, addr (tc_data.tty_read_buffer), (0), length (tc_data.tty_read_buffer), n_chars_read, n_chars_echoed, (0), tty_state, code); /* if FNP echo negotiation is on, we must wait for the wakeup which signifies the FNP has stopped negotiating. If we don't block here, we will pick up this wakeup unexpectedly later. After we are through blocking, go back and read again. */ if code = error_table_$echnego_awaiting_stop_sync & tc_data.network_type ^= MOWSE_NETWORK_TYPE then call tc_block (tc_data_ptr, request_ptr, UNMASK_NOTHING); if code = 0 then do; if n_chars_echoed > 0 then do; /* got stuff back, add it to buffer and update screen image */ call add_echoed_chars_to_buffer (1, n_chars_echoed); call add_chars_to_buffer (1 + n_chars_echoed, n_chars_read - n_chars_echoed); begin; declare echoed character (n_chars_echoed) defined (tc_data.tty_read_buffer) position (1); call tc_screen$text (tc_data.screen_data_ptr, state.row, state.col, "0"b, echoed); end; state.col = state.col + n_chars_echoed; end; else if n_chars_read > 0 then call add_chars_to_buffer (1, n_chars_read); end; /* if code = 0 */ end; /* do loop */ state.echnego_outstanding = "0"b; return; end close_out_echnego; echo_char: procedure (char_to_echo); declare char_to_echo character (1); /* We borrow the tty_read_buffer as an echo buffer. This is because echo characters are only saved for the duration of a call to try_to_satisfy */ substr (tc_data.tty_read_buffer, i_op.write_buffer_count, 1) = char_to_echo; i_op.write_buffer_count = i_op.write_buffer_count + 1; return; init_echo_buffer: entry; i_op.write_buffer_count = 1; return; dump_echo_buffer: entry; if i_op.write_buffer_count > 1 then begin; declare to_echo character (i_op.write_buffer_count - 1) defined (tc_data.tty_read_buffer) position (1); call tc_request$write_echo (tc_data_ptr, to_echo); end; end echo_char; tty_read_error: procedure (code); declare code fixed bin (35); declare msg character (100) aligned; declare convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned); call convert_status_code_ (code, (8)" ", msg); call tc_error (video_et_$tc_tty_error, rtrim (msg)); end tty_read_error; set_break_table: procedure; declare hcs_$tty_order entry (fixed bin, character (*), pointer, fixed bin, fixed bin (35)); declare ws_tty_$order entry (ptr, char (*), ptr, fixed bin, fixed bin (35)); declare dsa_tty_$order entry (fixed bin (35), character (*), pointer, fixed bin, fixed bin (35)); tc_data.breaktest = request_read.breaks; /* This is being commented out until the change for MCR7300 is put in place declare 1 echh like echo_neg_data; */ declare 1 echh like v1_echo_neg_data; unspec (echh) = ""b; echh.version = echo_neg_data_version_1; echh.break = tc_break_array; if tc_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$order (tc_data.tty_handle, "set_echo_break_table", addr (echh), tty_state, code); else if tc_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ call ws_tty_$order (tc_data.mowse_terminal_iocb_ptr, "set_echo_break_table", addr (echh), tty_state, code); else /* MCS */ call hcs_$tty_order (tc_data.devx, "set_echo_break_table", addr (echh), tty_state, code); if code ^= 0 then call tc_disconnect$check (tc_data_ptr, code); if code ^= 0 then call tty_read_error (code); end set_break_table; ASYNC_INTERRUPTION: /**** We cannot try to return any extra stuff in the buffer, because the cursor is in the wrong place for echoing. We could call tc_request asyncronously to reposition the cursor, but that would be a bigger pain. */ begin; declare dummy bit (1) aligned; if i_op.echo then dummy = try_to_satisfy$$already_echoed_only (); request_read.returned_break_flag = "0"b; go to request_satisfied; end ASYNC_INTERRUPTION; read_status: procedure; declare bx fixed bin; call read_to_mark_no_block (RESTORE_MASK); request_read_status.returned_length = 0; do bx = 1 to input_buffer.n_valid; if string (control_buffer (bx)) = NORMAL_CONTROL then request_read_status.returned_length = request_read_status.returned_length + 1; end; /* Anybody that blocks on this ASYNC had damn better send a wakeup */ request_read_status.event_channel = tc_data.event; return; end read_status; end tc_input;  tc_io_.pl1 10/17/90 0821.7rew 10/17/90 0816.1 267714 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-23,LJAdams), approve(86-11-11,MCR7485), audit(86-12-19,Margolin), install(87-01-06,MR12.0-1255): Modified to support MOWSE. 2) change(86-11-26,LJAdams), approve(86-11-26,MCR7584), audit(86-12-19,Margolin), install(87-01-06,MR12.0-1255): Initial DSA coding has been maintained in a non-executable form. 3) change(87-02-17,LJAdams), approve(87-03-19,PBF7584), audit(87-04-24,Gilcrease), install(87-05-14,MR12.1-1030): Incorrect paramaters being passed to dsa_tty_$connect. 4) change(88-09-26,LJAdams), approve(88-09-26,MCR8001), audit(88-10-06,Farley), install(88-10-07,MR12.2-1148): In the reconnection entrypoint attach_data.tc_info_ptr was not being checked for a null value before starting to process. 5) change(90-09-20,Bubric), approve(90-10-01,MCR8211), audit(90-10-01,Itani), install(90-10-17,MR12.4-1044): Have the calls to the routine 'nothing' changed to calls to the routine 'null_entry_'. END HISTORY COMMENTS */ /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */ tc_io_: procedure; /* This is an interim implementation of the terminal control level I/O module. Its successor, terminal_io_, will be rather more complete. This program provides the Terminal Management layer of the Video System, translating logical video operations into physical terminal operations. It does not provide any Window Management, so that video operations so that the video environment is not available until another attachment is made atop this one. This program was created by creatively merging JR Davis' vtty_ and the old terminal io module, tty_. vtty_ was written by James Raymond Davis, with the guidance of ** * Steve H.Webber ** * ** * Larry E.Johnson ** * ** * Bernard S.Greenberg ** * * October 1980 *************************************************************************** If I have seen further than others ... Benson Ira Margulies, May 22, 1981. */ /* Modified 3 April 1984 by Jon A. Rochlis to add the entry for reconnection. Q: So where is terminal_io_? A: That day is not today, at least not at Honeywell. */ /* Modified June 1985 by Roger Negaret to support DSA networks. */ /* Modified Mar 1986 by Cox for new ipc_$create_event_channel call sequence */ /* Parameters */ dcl Iocbp pointer parameter; dcl Code fixed bin (35) parameter; dcl Com_err_switch bit (1) aligned parameter; dcl Ignore bit (1) aligned parameter; dcl Open_mode fixed bin parameter; dcl Attach_options (*) character (*) varying parameter; /* Automatic */ dcl dsa_connection_info_ptr ptr; dcl dsa_connection_info_len fixed bin (21); dcl access_class_range (2) bit (72); dcl actual_iocbp ptr; /* copy of iocb.actual_ioc_ptr */ dcl device char (32); dcl terminal_type character (32); dcl do_not_block bit (1); dcl i fixed bin; dcl iocbp ptr; /* copy of arg_iocb_ptr */ dcl hangup bit (1); dcl login_channel bit (1); dcl mask bit (36) aligned; /* ips mask */ dcl mowse_terminal_iocbp ptr; dcl phone_no char (32); /* phone to which to dial */ dcl password char (12); dcl password_given bit (1); dcl resource_description character (256); dcl state fixed bin; /* state returned by hcs_$tty_ calls */ dcl 1 dma aligned like dial_manager_arg; dcl 1 ipcas aligned like ipc_create_arg_structure; dcl 1 dm_flags aligned, 2 dialup bit (1) unal, 2 hungup bit (1) unal, 2 control bit (1) unal, 2 pad bit (33) unal; dcl 1 event_message like event_wait_info aligned; dcl error_string char (32); /* builtins */ dcl (addr, hbound, index, lbound, null, string, substr) builtin; /* Constants */ dcl ME character (32) internal static options (constant) initial ("tc_io_"); dcl MOWSE_DEVICE character (9) internal static options (constant) initial ("mowse_i/o"); /* Based */ dcl system_free_area area based (get_system_free_area_ ()); dcl connection_info (dsa_connection_info_len) fixed bin (35) based (dsa_connection_info_ptr); /* External Static */ dcl ( error_table_$too_many_args, error_table_$resource_attached, error_table_$action_not_performed, error_table_$inconsistent, error_table_$not_detached, error_table_$badopt, error_table_$bad_mode, error_table_$bad_ptr, error_table_$noarg, error_table_$wrong_no_of_args ) fixed bin (35) ext; dcl (any_other, cleanup) condition; /* Procedures */ dcl com_err_ entry options (variable); dcl convert_dial_message_$return_io_module entry (fixed bin (71), char (*), char (*), fixed bin, 1 structure aligned, 2 bit (1) unal, 2 bit (1) unal, 2 bit (1) unal, 2 bit (33) unal, fixed bin (35)); dcl ( dial_manager_$dial_out, dial_manager_$privileged_attach, dial_manager_$release_channel, dial_manager_$release_channel_no_hangup, dial_manager_$terminate_dial_out ) entry (ptr, fixed bin (35)); dcl get_system_free_area_ entry () returns (pointer); dcl ioa_$rsnnl entry options (variable); dcl null_entry_ entry (); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$create_event_channel entry (ptr, fixed bin (71), fixed bin (35)); dcl ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35)); dcl hcs_$delete_channel entry (fixed bin (71), fixed bin (35)); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$tty_attach entry (char (*), fixed bin (71), fixed bin, fixed bin, fixed bin (35)); dcl hcs_$tty_detach entry (fixed bin, fixed bin, fixed bin, fixed bin (35)); dcl hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35)); dcl hcs_$tty_order entry (fixed bin, character (*), pointer, fixed bin, fixed bin (35)); dcl dsa_tty_$attach entry (char (*), fixed bin (71), fixed bin (35), fixed bin, fixed bin (35)); dcl dsa_tty_$connect entry (char (*), ptr, fixed bin (71), char (*) var, ptr, char (*), fixed bin (35), ptr, fixed bin (21), char (*) var, (2) bit (72), fixed bin (35)); dcl dsa_tty_$detach entry (fixed bin (35), fixed bin, fixed bin, fixed bin (35)); dcl dsa_tty_$event entry (fixed bin (35), fixed bin (71), fixed bin, fixed bin (35)); dcl dsa_tty_$order entry (fixed bin (35), character (*), pointer, fixed bin, fixed bin (35)); dcl ws_tty_$event entry (ptr, fixed bin (71), fixed bin, fixed bin (35)); dcl ws_tty_$order entry (ptr, char (*), ptr, fixed bin, fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ( ipc_$mask_ev_calls, ipc_$unmask_ev_calls ) entry (fixed bin (35)); dcl user_info_$terminal_data entry (char (*), char (*), char (*), fixed bin, char (*)); dcl tc_$init entry (ptr, char (*), fixed bin (71), char (*), bit (1), ptr, fixed bin (35)); dcl tc_$shut entry (pointer); dcl tc_$shut_ttp_info entry (ptr); dcl tc_$tc_io_control entry; /* tc_io_attach */ /* The name tty_attach is hung on here so that reconnection can be fooled into believing that this is indeed tty_. In the next release, when tc_io_ becomes terminal_io_ and replaces tty_, this will be a useful compatability feature as well. */ tc_io_attach: tty_attach: entry (Iocbp, Attach_options, Com_err_switch, Code); Code = 0; mask = ""b; iocbp = Iocbp; if hbound (Attach_options, 1) < 1 then call error (error_table_$noarg, "Usage: tc_io_ {device} {-control_args}"); terminal_type, resource_description, device, phone_no, password = ""; password_given = "0"b; login_channel, do_not_block = ""b; hangup = "1"b; attach_data_ptr = null (); on cleanup call clean_up_attach; if iocbp -> iocb.attach_descrip_ptr ^= null () then call error (error_table_$not_detached, ""); do i = lbound (Attach_options, 1) to hbound (Attach_options, 1); if /* case */ index (Attach_options (i), "-") ^= 1 then do; /* channel name */ if device ^= "" then call error (error_table_$wrong_no_of_args, "Multiple devices specified."); device = Attach_options (i); end; else if Attach_options (i) = "-login_channel" then login_channel = "1"b; else if Attach_options (i) = "-hangup_on_detach" then hangup = "1"b; else if Attach_options (i) = "-no_hangup_on_detach" then hangup = "0"b; else if Attach_options (i) = "-terminal_type" | Attach_options (i) = "-ttp" then do; i = i + 1; if terminal_type ^= "" then call error (error_table_$too_many_args, "The -terminal_type control arguments may only be given once."); if i <= hbound (Attach_options, 1) then if index (Attach_options (i), "-") = 1 then call error (error_table_$noarg, "Control argument found in place of terminal type."); else terminal_type = Attach_options (i); else call error (error_table_$noarg, "-terminal_type given without a terminal type."); end; else if Attach_options (i) = "-resource" | Attach_options (i) = "-rsc" then do; i = i + 1; if resource_description ^= "" then call error (error_table_$too_many_args, "A second resource description was given."); if i <= hbound (Attach_options, 1) then if index (Attach_options (i), "-") = 1 then call error (error_table_$noarg, "Control argument found in place of resource description."); else ; else call error (error_table_$noarg, "-resource given without a description."); resource_description = Attach_options (i); end; else if Attach_options (i) = "-destination" | Attach_options (i) = "-ds" then do; i = i + 1; if phone_no ^= "" then call error (error_table_$too_many_args, "Multiple dial_out destinations given."); if i > hbound (Attach_options, 1) then call error (error_table_$noarg, "Phone number."); phone_no = Attach_options (i); end; else if Attach_options (i) = "-password" | Attach_options (i) = "-pwd" | Attach_options (i) = "-pw" then do; i = i + 1; if i > hbound (Attach_options, 1) then call error (error_table_$noarg, "Password."); password = Attach_options (i); password_given = "1"b; end; else if Attach_options (i) = "-no_block" then do; do_not_block = "1"b; end; else if Attach_options (i) = "-mowse" then do; i = i + 1; if i > hbound (Attach_options, 1) then call error (error_table_$noarg, "-mowse given without a switch name."); call iox_$find_iocb ((Attach_options (i)), mowse_terminal_iocbp, Code); if Code ^= 0 then call error (Code, "Invalid switch name."); device = MOWSE_DEVICE; end; else call error (error_table_$badopt, (Attach_options (i))); end; if login_channel & ((phone_no ^= "") | (password ^= "")) then call error (error_table_$inconsistent, "-login_channel and -destination."); if login_channel & (device ^= "") then call error (error_table_$inconsistent, "-login_channel and an explicit device."); if login_channel & (resource_description ^= "") then call error (error_table_$inconsistent, "-login_channel and -resource."); if login_channel then call user_info_$terminal_data ("", "", device, (0), ""); if device = "" then call error (error_table_$noarg, "No device given."); allocate attach_data set (attach_data_ptr) in (system_free_area); attach_data.tc_info_ptr = null (); /* to avoid an over-gravid attach data block the video part hangs off specially */ string (attach_data.flags) = ""b; attach_data.device_id = device; if index (attach_data.device_id, MOWSE_DEVICE) = 1 then attach_data.mowse_terminal_iocb_ptr = mowse_terminal_iocbp; else attach_data.mowse_terminal_iocb_ptr = null; attach_data.terminal_type = terminal_type; attach_data.device_used = device; /* unless dm_ changes it */ attach_data.resource_desc = resource_description; attach_data.dial_phone = phone_no; attach_data.phone_given = (phone_no ^= ""); attach_data.login_channel = login_channel; attach_data.no_block = do_not_block; attach_data.hangup = hangup; attach_data.operation_hlock = 0; /* we always try to get the channel with hcs_, to avoid changing the dial_manager_ event channel if we do not have to. All we cound do wrong here is successfully attach a channel with the wrong reservation characteristics etc. we always pass a bogus event channel in until open time. */ call attach_common (error_string, Code); if Code ^= 0 then call error (Code, error_string); attach_common: /* also called at reconnection time */ proc (error_string, Code); dcl error_string char (*); dcl Code fixed bin (35); call try_hcs_attach (Code); if Code ^= 0 then do; if attach_data.login_channel then do; error_string = "Cannot attach login channel."; return; end; if attach_data.network_type = DSA_NETWORK_TYPE then do; call dsa_tty_$connect (attach_data.device_id, get_system_free_area_ (), 0, attach_data.dial_phone, null (), attach_data.device_used, (0), dsa_connection_info_ptr, dsa_connection_info_len, (""), access_class_range, Code); if Code ^= 0 then do; error_string = "Could not connect channel."; return; end; /*** free the connection info */ free connection_info; end; else if attach_data.network_type = MOWSE_NETWORK_TYPE then do; /* MOWSE */ error_string = "Could not assign channel."; return; end; else do; /* MCS_NETWORK_TYPE */ call try_dial_manager_attach (Code); if Code ^= 0 then do; error_string = "Could not assign channel."; return; end; end; call try_hcs_attach (Code); if Code ^= 0 then do; error_string = "Could not attach channel."; return; end; end; return; end attach_common; call make_atd; on any_other call handler; /* should be on */ call set_ips_mask; iocbp -> iocb.attach_descrip_ptr = addr (attach_data.attach_descrip); iocbp -> iocb.attach_data_ptr = attach_data_ptr; iocbp -> iocb.detach_iocb = tc_io_detach; iocbp -> iocb.open = tc_io_open; call iox_$propagate (iocbp); revert any_other; call reset_ips_mask; RETURN: return; make_atd: procedure; /* format: off */ call ioa_$rsnnl ( "^a ^[-login_channel^s^;^a^]^[ -mowse^]^[ -resource ^a^;^s^]^[ -destination ^a^;^s^]^[ -password^;^]^[ -no_block^]^[ ^[-no_hangup_on_detach^;-hangup_on_detach^]^]" , attach_data.attach_descrip, (0), ME, attach_data.login_channel, attach_data.device_used, (attach_data.network_type = MOWSE_NETWORK_TYPE), (attach_data.resource_desc ^= ""), attach_data.resource_desc, attach_data.phone_given, attach_data.dial_phone, password_given, attach_data.no_block, ^attach_data.login_channel, ^attach_data.hangup); /* format: ^off */ end make_atd; /* Error calls com_err_ if the loud switch is set and goes to the attach return */ error: proc (err_code, message); dcl err_code fixed bin (35); /* Multics standard error Code */ dcl message char (*); /* Additional error information */ dcl sub_err_ entry () options (variable); if Com_err_switch then call com_err_ (err_code, ME, "^a IOCB ^a.", iocbp -> iocb.name, message); else call sub_err_ (err_code, ME, "c" /* continue unless someone handles */, null (), (0), "^a IOCB ^a.", iocbp -> iocb.name, message); Code = err_code; call clean_up_attach; goto RETURN; end error; /* This entry detaches the terminal and frees the information about it. It ignores the Code and does the following: 1. The event channel is released. 2. The channel is released if it was attached with dial_manager_. 3. The table space in this dim for the attachment is freed iff the hlock is clear. */ tc_io_detach: entry (Iocbp, Code); call set_up; /* set no lock, but get actual_iocb_ptr */ call hcs_detach; call release_channel; /* if we got it with dm_, let it go */ on any_other call handler; /* should be on */ call set_ips_mask; actual_iocbp -> iocb.attach_descrip_ptr = null (); actual_iocbp -> iocb.attach_data_ptr = null (); actual_iocbp -> iocb.detach_iocb = iox_$err_not_attached; actual_iocbp -> iocb.open = iox_$err_not_attached; actual_iocbp -> iocb.control = iox_$err_not_attached; call iox_$propagate (actual_iocbp); if attach_data.operation_hlock = 0 /* no outstanding operations */ then free attach_data; else attach_data.async_detach = "1"b; /* warn other incarnations */ revert any_other; /* avoid unneccessary fatal errors */ call reset_ips_mask; return; /* This entry sets the open description and the legal operation entries in the iocb. This so-called I/O module only excepts the control operation. We are an I/O mudule so that (1) we can be reconnected, and (2) find_iocb can find us, (3) pat will display us. */ tc_io_open: entry (Iocbp, Open_mode, Ignore, Code); call set_up; if Open_mode = Stream_input_output /* sure, why not */ then attach_data.open_descrip = iox_modes (Open_mode); else do; Code = error_table_$bad_mode; return; end; call open_common ("0"b /* no reconnection */, Code); if Code ^= 0 then return; open_common: proc (reconnection_flag, Code); dcl reconnection_flag bit (1); dcl Code fixed bin (35); if attach_data.network_type ^= MOWSE_NETWORK_TYPE then do; call allocate_ev_channel; /* in case user supplied with set_event */ call ipc_$mask_ev_calls (Code); /* do not let user Code run till we are really open */ if Code ^= 0 then return; end; /* leave it free for tc_ to do an hcs_ tty attach */ if attach_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$detach (attach_data.tty_handle, (0), (0), Code); else if attach_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ ; /* mowse does not have to detach a switch */ else /* MCS */ call hcs_$tty_detach (attach_data.tty_index, (0), (0), Code); if Code ^= 0 then do; call ipc_$unmask_ev_calls ((0)); return; end; call tc_$init (attach_data.tc_info_ptr, attach_data.device_used, attach_data.event_wait.channel_id (1), attach_data.terminal_type, reconnection_flag, attach_data.mowse_terminal_iocb_ptr, Code); if Code ^= 0 then do; call ipc_$unmask_ev_calls ((0)); return; end; return; end open_common; on any_other call handler; call set_ips_mask; actual_iocbp -> iocb.open_descrip_ptr = addr (attach_data.open_descrip); actual_iocbp -> iocb.detach_iocb = iox_$err_not_closed; actual_iocbp -> iocb.open = iox_$err_not_closed; actual_iocbp -> iocb.close = tc_io_close; actual_iocbp -> iocb.control = tc_$tc_io_control; call iox_$propagate (actual_iocbp); call reset_ips_mask; revert any_other; call ipc_$unmask_ev_calls ((0)); if attach_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$order (attach_data.tty_handle, "start", null (), state, (0)); else if attach_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ call ws_tty_$order (attach_data.mowse_terminal_iocb_ptr, "start", null (), state, (0)); else /* MCS */ call hcs_$tty_order (attach_data.tty_index, "start", null (), state, (0)); Code = 0; return; /* This procedure closes the io switch and returns a zero Code. the terminal is hardcore detached at this point, but dm_ attachment is left for real detachment. This will cause the interface to be reasonable, as another user cannot snarf the "attached" channel */ tc_io_close: entry (Iocbp, Code); call set_up; call tc_$shut (attach_data.tc_info_ptr); call close_common (Code); /* also called at reconnection */ close_common: proc (Code); dcl Code fixed bin (35); /* turn off wakeups from the channel */ if attach_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$event (attach_data.tty_handle, (0), (0), (0)); else if attach_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ call ws_tty_$event (attach_data.mowse_terminal_iocb_ptr, (0), (0), (0)); else /* MCS */ call hcs_$tty_event (attach_data.tty_index, (0), (0), (0)); if attach_data.assigned_ev_channel /* fast channel, give back to hardcore */ then call hcs_$delete_channel (attach_data.event_wait.channel_id (1), Code); else if attach_data.created_ev_channel /* we created regular channel */ then call ipc_$delete_ev_chn (attach_data.event_wait.channel_id (1), Code); attach_data.have_ev_channel = ^(attach_data.assigned_ev_channel | attach_data.created_ev_channel); /* if user supplied it sticks */ end close_common; on any_other call handler; /* should be on */ call set_ips_mask; actual_iocbp -> iocb.open_descrip_ptr = null; actual_iocbp -> iocb.detach_iocb = tc_io_detach; actual_iocbp -> iocb.open = tc_io_open; actual_iocbp -> iocb.control = iox_$err_not_open; actual_iocbp -> iocb.modes = iox_$err_not_open; call iox_$propagate (actual_iocbp); call reset_ips_mask; return; /* This is called by the reconnection control order. It re-initializes all terminal specific info and hopefully leaves all else alone. */ reconnection: entry (P_attach_data_ptr, Code); dcl P_attach_data_ptr ptr; attach_data_ptr = P_attach_data_ptr; /* close */ if attach_data.tc_info_ptr = null then do; Code = error_table_$bad_ptr; return; end; call tc_$shut_ttp_info (attach_data.tc_info_ptr); call close_common (Code); if Code ^= 0 then return; /* detach */ call hcs_detach (); call release_channel (); /* attach */ call user_info_$terminal_data ("", "", device, (0), ""); attach_data.device_id, attach_data.device_used = device; call attach_common ("", Code); /* open */ call open_common ("1"b /* reconnection */, Code); call ipc_$unmask_ev_calls ((0)); return; /* This entry allows other parts of terminal_io_ to easily (perish the thought) call up a process termination. */ terminate_the_process: entry (Code); call terminate_this_process (Code); /* This program only needs to mask for the simple operations of filling in the iocb. Any fault taken there is serious enough, and unlikely enough, to warrent process termination. Thus we do not use the utilities that are around for masking ips when an error could occur, or quits must be tolerated. */ handler: procedure options (non_quick); /* visible in ifd */ dcl error_table_$unable_to_do_io fixed (35) ext; if mask ^= ""b then call terminate_this_process (error_table_$unable_to_do_io); end handler; terminate_this_process: procedure (cd) options (non_quick); dcl cd fixed bin (35); dcl terminate_process_ ext entry (char (*), ptr); dcl 1 ti aligned automatic, 2 version fixed, 2 code fixed (35); ti.version = 0; ti.code = cd; call terminate_process_ ("fatal_error", addr (ti)); end terminate_this_process; allocate_ev_channel: procedure; /* Assign event channel */ if attach_data.have_ev_channel /* user supplied a channel via "set_event" order */ then return; /*** Try to get a fast channel, first; */ /*** If no success create a wait event channel. */ ipcas.version = ipc_create_arg_structure_v1; ipcas.channel_type = FAST_EVENT_CHANNEL_TYPE; ipcas.call_entry = null_entry_; ipcas.call_data_ptr = null (); ipcas.call_priority = 0; call ipc_$create_event_channel (addr (ipcas), attach_data.event_wait.channel_id (1), Code); if Code = 0 then attach_data.assigned_ev_channel = "1"b; else do; ipcas.channel_type = WAIT_EVENT_CHANNEL_TYPE; call ipc_$create_event_channel (addr (ipcas), attach_data.event_wait.channel_id (1), Code); if Code ^= 0 then call error (Code, "Could not create a wait event channel."); end; attach_data.have_ev_channel = "1"b; return; end allocate_ev_channel; try_hcs_attach: procedure (Code); dcl Code fixed bin (35); Code = 0; /* The network_type is initialized here. */ /* set no event -- it will be set with tty_event at open time */ if substr (device, 1, 4) = "dsa." /* DSA */ then do; attach_data.network_type = DSA_NETWORK_TYPE; call dsa_tty_$attach (attach_data.device_used, 0, attach_data.tty_handle, state, Code); end; else if index (device, MOWSE_DEVICE) = 1 then do; /* MOWSE */ attach_data.network_type = MOWSE_NETWORK_TYPE; end; else do; /* MCS */ attach_data.network_type = MCS_NETWORK_TYPE; call hcs_$tty_attach (attach_data.device_used, 0, attach_data.tty_index, state, Code); end; end try_hcs_attach; try_dial_manager_attach: procedure (Code); dcl Code fixed bin (35); Code = 0; call ipc_$create_ev_chn (attach_data.dial_manager_event.channel_id (1), Code); if Code ^= 0 then return; dma.version = dial_manager_arg_version_2; dma.dial_channel = attach_data.dial_manager_event.channel_id (1); dma.dial_qualifier = ""; dma.channel_name = attach_data.device_id; if attach_data.phone_given then dma.dial_out_destination = attach_data.dial_phone; else dma.dial_out_destination = ""; dma.reservation_string = resource_description; if attach_data.flags.phone_given then call dial_manager_$dial_out (addr (dma), Code); else call dial_manager_$privileged_attach (addr (dma), Code); /* If this is a priv_attach, then if we already have it then everything is fine. If user specified the destination, then we must dial to it. */ if (Code = error_table_$resource_attached) & ^attach_data.flags.phone_given then do; /*** must release is still "0"b at this point */ Code = 0; /* do not go blocked, as has nothing further to say */ return; end; if Code ^= 0 then do; dm_call_failed_: call ipc_$delete_ev_chn (attach_data.dial_manager_event.channel_id (1), (0)); attach_data.flags.must_release = "0"b; /* avoid freeing an ipc channel twice (fatal proc error) */ return; end; attach_data.flags.must_release = "1"b; /* it cant hurt to try */ call ipc_$block (addr (attach_data.dial_manager_event), addr (event_message), Code); /* wait for news from initializer */ if Code ^= 0 then goto dm_call_failed_; call convert_dial_message_$return_io_module (event_message.message, device, (""), (0), dm_flags, Code); if Code ^= 0 then go to dm_call_failed_; if ^dm_flags.dialup then do; Code = error_table_$action_not_performed; go to dm_call_failed_; end; attach_data.flags.must_release = "1"b; attach_data.device_used = device; /* starnames unstarred here */ return; end try_dial_manager_attach; release_channel: procedure; declare Code fixed bin (35); if attach_data.flags.must_release then do; dma.version = dial_manager_arg_version_2; dma.channel_name = attach_data.device_used; dma.dial_channel = attach_data.dial_manager_event.channel_id (1); if attach_data.flags.phone_given then call dial_manager_$terminate_dial_out (addr (dma), Code); if ^attach_data.flags.hangup then call dial_manager_$release_channel_no_hangup (addr (dma), Code); call dial_manager_$release_channel (addr (dma), Code); call ipc_$delete_ev_chn (attach_data.dial_manager_event.channel_id (1), Code); attach_data.flags.must_release = "0"b; end; end release_channel; hcs_detach: procedure; if attach_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$detach (attach_data.tty_handle, 0, (0), (0)); else if attach_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ ; /* mowse has no switch to detach */ else /* MCS */ call hcs_$tty_detach (attach_data.tty_index, 0, (0), (0)); end hcs_detach; set_up: procedure; Code = 0; actual_iocbp = Iocbp -> iocb.actual_iocb_ptr; attach_data_ptr = actual_iocbp -> iocb.attach_data_ptr; mask = ""b; return; end set_up; clean_up_attach: procedure; if attach_data_ptr = null () then return; if attach_data.tty_index > 0 then call hcs_detach; if attach_data.must_release then call release_channel; free attach_data; end clean_up_attach; set_ips_mask: procedure; if mask = ""b then call hcs_$set_ips_mask (""b, mask); return; reset_ips_mask: entry; if mask ^= ""b then call hcs_$reset_ips_mask (mask, mask); end set_ips_mask; /* include files */ %include net_event_message; %include iox_entries; %include iox_modes; %page; %include tc_io_attach_data_; %include tc_desk_info_; %page; %include iocb; %include dial_manager_arg; %include event_wait_info; %include ipc_create_arg; %include terminal_info; end tc_io_;  tc_mask.pl1 08/13/87 1333.0rew 08/13/87 1323.7 21015 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* IPS mask utility for Terminal Control */ /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */ tc_mask: procedure; return; /* June 1981, Benson I. Margulies */ declare video_data_$shut_mask bit (36) aligned external static; declare video_data_$open_mask bit (36) aligned external static; declare video_data_$only_quit_mask bit (36) aligned external static; declare video_data_$alrm_only_mask bit (36) aligned external static; declare Old_mask bit (36) aligned parameter; declare old_mask bit (36) aligned; declare hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); declare hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); all: entry returns (bit (36) aligned); call set_mask (video_data_$shut_mask, old_mask); return (old_mask); restore: entry (Old_mask); call reset_mask (Old_mask, ""b); return; close: entry; call swap_to (video_data_$shut_mask); return; open_all: entry; call swap_to (video_data_$open_mask); return; open_alrm: entry; call swap_to (video_data_$alrm_only_mask); return; open_quit: entry; call swap_to (video_data_$only_quit_mask); return; set_mask: procedure (new, old); declare (new, old) bit (36) aligned; call hcs_$set_ips_mask (new, old); end set_mask; reset_mask: procedure (old, older); declare (old, older) bit (36) aligned; call hcs_$reset_ips_mask (old, older); end reset_mask; swap_to: procedure (new); declare new bit (36) aligned; call hcs_$set_ips_mask (new, ""b); end swap_to; end tc_mask;  tc_request.pl1 08/13/87 1333.0r 08/13/87 1323.6 402192 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(81-06-01,Margulies), approve(), audit(), install(): There is a temporary crock in place here, for handling error_table_$bigarg returned from hcs_$tty_write_whole_string. See the call to it for details IT MUST BE REMOVED when hardcore is fixed. 2) change(82-05-01,York), approve(), audit(), install(): There is another temporary crock in the insert_text procedure, relating to the two different types of insert-char sequences supported by various terminals. See the comment in place for more Info. Change the pad character from DEL to NUL (or high to low for you PL/I builtin fans). This fixes padding problems with the Heath/Zenith-19, but probably breaks some other terminal... 3) change(82-05-01,York), approve(), audit(), install(): Initialize cost_of_cha_cha in the position_cursor optimzation routine, avoiding weird usuless motion. 4) change(82-07-16,York), approve(), audit(), install(): Position the cursor correctly and send the correct output to the terminal when simulating insert-chars on terminals lacking the capability. 5) change(82-07-16,York), approve(), audit(), install(): Insert a crock in insert_text to keep the screen image updated when doing insert-chars operations on the Teleray 1061 and related terminals. 6) change(82-07-16,York), approve(), audit(), install(): Fix the delete_chars routine so that it does not try to do an actual delete_chars terminal operation on terminals that don't have it. 7) change(82-07-30,York), approve(), audit(), install(): Buffer all output to the terminal generated by one call to tc_request and send it in one call to hcs_ 8) change(82-08-12,York), approve(), audit(), install(): Extend this buffering to work across calls to tc_request, and only send to ring 0 when the buffer fills or an input request is received. 9) change(82-08-30,York), approve(), audit(), install(): Dump the output buffer before raw output is sent to ring 0 and before input is re-echoed, and to send raw output via tty_write_whole_string. 10) change(82-09-10,York), approve(), audit(), install(): Add the send_buffered_output entrypoint as an external interface to write_global_buffer. This is used by the send_buffered_output control order. 11) change(82-09-20,York), approve(), audit(), install(): Remove the send_buffered_output entrypoint, since a call to window_$sync does the right thing. Also changed to pass tc_input$check_echnego the request_ptr as an argument. 12) change(83-01-01,York), approve(), audit(), install(): Not position the cursor on calls that don't modify the screen (e.g. unechoed reads). 13) change(83-09-07,Rochlis), approve(), audit(), install(): Remove the special casing of error_table_$bigarg in the hcs_$tty_write_whole_string call. Now we will get a wakeup and bigarg means we really have problems. 14) change(83-10-09,Rochlis), approve(), audit(), install(): Support partial screen width windows. 15) change(85-09-14,Rochlis), approve(86-05-15,MCR7276), audit(86-05-28,Gilcrease), install(86-06-04,MR12.0-1070): Fix unitialized variable bug in position cursor. Goodbye to the insert mode bug, thanks to Allen Grider. 16) change(86-05-21,LJAdams), approve(86-05-27,MCR7428), audit(86-05-28,Gilcrease), install(86-06-04,MR12.0-1070): The "encode" procedure has an alignment problem. value is declared as fixed bin which equates to 36 bits; bits is declared as (6) bit (3) unaligned which equates to 18 bits. When an unspec (value) = unspec (bits) is done a stringsize condition occurs and only the upper half of the word was being stored. Solution change the declaration of bits to: dcl bits (-5:6) bit (3) unaligned. 17) change(86-11-11,LJAdams), approve(86-11-11,MCR7485), audit(86-12-16,Margolin), install(87-01-06,MR12.0-1255): Modified to support MOWSE. 18) change(86-11-26,LJAdams), approve(86-11-26,MCR7584), audit(86-12-16,Margolin), install(87-01-06,MR12.0-1255): Initial DSA coding has been maintained in a non-executable form. END HISTORY COMMENTS */ /* Terminal Control Request Processing level This program is the interpreter of terminal operations. For input side (save read status) we position the cursor, and pass the batton to tc_input. All else is done here, including the grokking of the ttt video tables. */ /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */ tc_request: procedure (TC_data_ptr, Request_ptr, Last_column, Code); go to do_output; declare ( (TC_data_ptr, Request_ptr) pointer, Last_column fixed bin, Code fixed bin (35) ) parameter; declare hcs_$tty_write_whole_string entry (fixed bin, character (*), bit (1) aligned, fixed bin (21), fixed bin, fixed bin (35)); declare hcs_$tty_write entry (fixed bin, pointer, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, fixed bin (35)); declare ws_tty_$write_whole_string entry (ptr, char (*), bit (1), fixed bin (21), fixed bin, fixed bin (35)); declare ws_tty_$write entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, fixed bin (35)); declare dsa_tty_$write_whole_string entry (fixed bin (35), character (*), bit (1) aligned, fixed bin (21), fixed bin, fixed bin (35)); declare dsa_tty_$write entry (fixed bin (35), pointer, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, fixed bin (35)); declare tc_screen$operation entry (pointer, fixed bin, fixed bin, fixed bin, fixed bin); declare tc_screen$get_in_line entry (pointer, fixed bin, fixed bin, character (*)); declare tc_screen$text entry (pointer, fixed bin, fixed bin, bit (1) aligned, character (*)); declare tc_screen$is_region_clear entry (pointer, fixed binary, fixed binary, fixed binary, fixed binary) returns (bit (1) aligned); declare tc_input entry (pointer, pointer, fixed bin (35)); declare tc_disconnect$check entry (pointer, fixed bin (35)); declare tc_input$check_echnego entry (pointer, pointer); declare tc_error entry (fixed binary (35), character (*)); declare tc_block entry (pointer, pointer, bit (36) aligned); declare ( video_et_$capability_lacking, video_et_$tc_illegal_request, video_et_$tc_cannot_position, video_et_$tc_missing_operation, video_et_$tc_tty_error ) fixed bin (35) ext static; declare OMEGA fixed bin init (100000) internal static options (constant); /* compiler limitation of 256 chars, should be bigger. */ declare MANY_SPACES char (256) static options (constant) init (""); declare last_column fixed bin; declare (request_row, request_col) fixed bin; declare request_row_count fixed bin; declare request_column_count fixed bin; declare request_string_ptr pointer; declare request_string_length fixed bin (21); declare request_count fixed bin; declare tty_state fixed bin; declare save_row character (200); /* pretty big terminal */ declare code fixed bin (35); declare (addr, bin, byte, divide, hbound, lbound, length, min, rank, rtrim, substr, unspec, verify) builtin; declare 1 new_state aligned based, 2 pay_attention aligned, /* use these to see those below */ 3 insert bit (1) unaligned, /* flags.insert_mode is useful */ 3 cursor bit (1) unaligned, /* flags.cursor_valid */ 3 position bit (1) unaligned, /* cursor_position */ 2 flags aligned, 3 insert_mode bit (1) unaligned, 3 cursor_valid bit (1) unaligned, 2 cursor_position aligned, 3 row fixed bin, 3 col fixed bin; init: entry (TC_data_ptr); tc_data_ptr = TC_data_ptr; state.pending.count = 0; state.cursor_valid = "0"b; state.current_mark = 0; state.last_mark_back = 0; tc_data.global_buffer_index = 0; /* the buffer length should be based on line speed or something */ /* this won't be so important after tty_write_whole_string is changed to send a wakeup when space is available. */ tc_data.global_buffer_limit = 256; return; shut: entry (TC_data_ptr, Code); /* Since we are usually in tc_request on behalf of some window, we need a fabricated window operation structure for tc_block to play with. */ /* The following code commented out since it breaks reconnection. Fix it to not cause the terminal_control_disconnection_ signal if we are shutting. Removed for 10.1 installation deadline. dcl 1 dummy_request_header aligned like request_header; Code = 0; tc_data_ptr = TC_data_ptr; request_ptr = addr (dummy_request_header); dummy_request_header.sentinel = REQUEST_SENTINEL; dummy_request_header.request_id = 0; dummy_request_header.window_id = ""b; dummy_request_header.operation = 5; call write_global_buffer (); */ return; /* ASSERT: this entrypoint is called MASKED!! */ do_output: tc_data_ptr = TC_data_ptr; request_ptr = Request_ptr; last_column = Last_column; ttyvtblp = tc_data.ttt_video_ptr; request_header.async_interruption, request_header.this_window = "0"b; /* The following test is performed to avoid unnecessary external calls to tc_input for each output operation. Modularity has been sacrificed in the name of efficiency. */ if state.echnego_outstanding | (state.pending.count > 0) then call tc_input$check_echnego (tc_data_ptr, request_ptr); if tc_data.pending.count > 0 then begin; /* Note window hits */ declare wx fixed bin; do wx = 1 to tc_data.pending.count; if request_header.window_id = tc_data.state.pending.blocked_windows (wx) then state_async_same_window (wx) = "1"b; end; end; tc_data.change_pclock = tc_data.change_pclock + 1; if request_header.operation < lbound (REQUEST, 1) | request_header.operation > hbound (REQUEST, 1) then do; REQUEST (5): call tc_error (video_et_$tc_illegal_request, ""); go to request_done; end; /* Come Here if something happened while we blocked and we have to try again */ recompute_operation_here: /* Make automatic copies of coords for faster procedure calls. This means that any routine that wants to set the coord values had better be called with request_header.row and .col, not the copies. */ request_row = request_header.row; request_col = request_header.col; go to REQUEST (request_header.operation); /* We should check for insert-mode on certain echoed-input calls, but that will be a limitation for now */ REQUEST (9): /* GET CHARS */ call position_cursor (request_row, request_col); /* Don't position the cursor for calls that will not echo. This makes "raw" input work way back up at the iox_ level. */ REQUEST (16): /* READ_ONE */ REQUEST (10): /* GET CHARS NO ECHO */ REQUEST (13): /* READ STATUS */ call write_global_buffer; /* Must do this before input */ call tc_input (tc_data_ptr, request_ptr, code); /* do input req */ go to request_done; REQUEST (11): /* WRITE SYNC READ */ request_string_ptr = request_read.prompt_ptr; request_string_length = request_read.prompt_length; call overwrite_text (request_row, request_col, request_string_ptr, request_string_length); call write_global_buffer; /* must dump output before input */ call tc_input (tc_data_ptr, request_ptr, code); go to request_done; REQUEST (1): /* POSITION CURSOR */ call position_cursor (request_row, request_col); go to request_done; REQUEST (2): /* CLEAR REGION */ request_row_count = request_clear_region.rows; request_column_count = request_clear_region.columns; call clear_region (request_row, request_col, request_row_count, request_column_count); go to request_done; REQUEST (4): /* CLEAR SCREEN NO OPT */ call clear_screen; go to request_done; REQUEST (3): /* INSERT_TEXT */ request_string_ptr = request_text.text_ptr; request_string_length = request_text.text_length; call insert_text (request_row, request_col, request_string_ptr, request_string_length, last_column); go to request_done; REQUEST (14): /* OVERWRITE_TEXT */ request_string_ptr = request_text.text_ptr; request_string_length = request_text.text_length; call overwrite_text (request_row, request_col, request_string_ptr, request_string_length); go to request_done; REQUEST (15): /* RAW TEXT */ call write_raw_text (request_row, request_col, request_text_string); go to request_done; REQUEST (6): /* DELETE CHARS */ call delete_chars (request_row, request_col, request_delete_chars.count, last_column); go to request_done; REQUEST (7): /* SCROLL REGION */ request_row = request_scroll_region.start_line; request_row_count = request_scroll_region.n_lines; request_count = request_scroll_region.distance; call scroll_region (request_scroll_region.start_line, request_scroll_region.n_lines, request_scroll_region.distance); go to request_done; REQUEST (8): /* BELL */ call bell (request_row, request_col); go to request_done; REQUEST (12): /* GET POSITION */ request_header.row = state.row; request_header.col = state.col; /* output */ go to request_done; /* Here begins the hard work */ position_cursor: procedure (a_row, a_col); declare (a_row, a_col) fixed bin; declare (row, col) fixed bin; declare (least_cost, cost_of_abs, cost_of_home, cost_of_cha_cha, cost_of_home_cha_cha) fixed bin; declare 1 ns aligned like new_state; /* Put the cursor THERE, in absolute screen coords */ row = a_row; col = a_col; unspec (ns) = ""b; if state.cursor_valid then if state.cursor_position.row = row then if state.cursor_position.col = col then return; /* Perhaps we are heading for home? */ /* DUMP ASSUMPTION: HOME is cheaper than anything else. Boy do we need an expense metric. Perhaps weights in the ttt? */ ns.pay_attention.position, ns.pay_attention.cursor = "1"b; ns.row = row; ns.col = col; ns.cursor_valid = "1"b; if (row = 1) & (col = 1) & available (HOME) then do; /* Lassie come ... */ call do_operation (HOME, 1, 1, 1, ns); return; end; /* What follows is a fair, and no better, chooser of method to do an arbitrary position. The faster the terminal, the less important it is to get the least characters. Instead, CPU time should be held down. This approach is middling for both costs */ /* ASSUME: we can at least do cha-cha (up down right left) or abs pos */ cost_of_abs = cost (ABS_POS); /* n characters */ cost_of_home = cost (HOME); /* OMEGA if not available */ cost_of_cha_cha = OMEGA; /* don't want to do this if we can avoid it */ cost_of_home_cha_cha = cost_of_home + cost_repeat (CURSOR_DOWN, row - 1) + cost_repeat (CURSOR_RIGHT, col - 1); if state.cursor_valid then do; /* we can only compute a real cha-cha cost if the cursor is valid */ cost_of_cha_cha = 0; if row > state.row then cost_of_cha_cha = cost_of_cha_cha + cost_repeat (CURSOR_DOWN, (row - state.row)); else if row < state.row then cost_of_cha_cha = cost_of_cha_cha + cost_repeat (CURSOR_UP, (state.row - row)); if col > state.col then cost_of_cha_cha = cost_of_cha_cha + cost_repeat (CURSOR_RIGHT, (col - state.col)); else if col < state.col then cost_of_cha_cha = cost_of_cha_cha + cost_repeat (CURSOR_LEFT, (state.col - col)); end; /* cost of cha cha is less than OMEGA iff the required functions were there */ least_cost = min (cost_of_abs, cost_of_cha_cha, cost_of_home_cha_cha); if least_cost >= OMEGA then call tc_error (video_et_$tc_cannot_position, ""); if cost_of_abs = least_cost then call do_operation (ABS_POS, row, col, (1), ns); /* ns is already correct for atomic position call */ else if cost_of_home_cha_cha = least_cost then do; ns.row, ns.col = 1; /* state reflects home call */ call do_operation (HOME, 1, 1, (1), ns); if row > 1 then do; ns.row = row; /* now we do just the row */ call do_operation (CURSOR_DOWN, (0), (0), row - 1, ns); end; if col > 1 then do; ns.col = col; /* and the col here ... ns.row is correct */ call do_operation (CURSOR_RIGHT, (0), (0), col - 1, ns); end; end; else do; /* cha-cha from current cursor position */ ns.cursor_position = state.cursor_position; /* wherever we are */ if row > state.row then do; ns.row = row; /* twiddle row */ call do_operation (CURSOR_DOWN, (0), (0), row - state.row, ns); end; else if row < state.row then do; ns.row = row; call do_operation (CURSOR_UP, (0), (0), state.row - row, ns); end; if col > state.col then do; ns.col = col; call do_operation (CURSOR_RIGHT, (0), (0), col - state.col, ns); end; else if state.col > col then do; ns.col = col; call do_operation (CURSOR_LEFT, (0), (0), state.col - col, ns); end; end; end position_cursor; clear_screen: procedure; call clear_region_noopt (1, 1, tc_data.terminal.rows, tc_data.terminal.columns); end clear_screen; clear_region: procedure (a_row, a_col, a_n_rows, a_n_cols); declare (a_row, a_col, a_n_rows, a_n_cols) fixed bin; declare (row, col, n_rows, n_cols) fixed bin; declare i fixed bin; declare 1 ns aligned like new_state; declare noopt bit (1) aligned; noopt = "0"b; go to opt_common; clear_region_noopt: entry (a_row, a_col, a_n_rows, a_n_cols); noopt = "1"b; opt_common: unspec (ns) = ""b; /* hopefully, we do nuthin */ /* copy for call efficiency */ row = a_row; col = a_col; n_rows = a_n_rows; n_cols = a_n_cols; /* anything to clear? */ if n_cols = 0 then do; call position_cursor (row, col); return; end; /* Check for whole screen case. */ if row = 1 & col = 1 & n_rows = tc_data.rows & n_cols = tc_data.columns then if available (CLEAR_SCREEN) then do; call do_operation (CLEAR_SCREEN, (0), (0), (1), ns); return; end; /* Check to see if the whole region is already clear. */ if ^noopt & tc_screen$is_region_clear (tc_data.screen_data_ptr, row, col, n_rows, n_cols) then return; if (-1 + row + n_rows = tc_data.rows) /* all the rows from here */ & (col = 1) /* starting in first col */ & (n_cols = tc_data.columns) /* full width */ then do; /* EOS */ if available (CLEAR_TO_EOS) then do; call position_cursor (row, col); /* hacks state */ call do_operation (CLEAR_TO_EOS, (0), (0), (1), ns); call position_cursor (row, col); return; end; end; if (-1 + col + n_cols = tc_data.columns) /* Full width */ & available (CLEAR_TO_EOL) then do; /* CLEOL assumed better than delete-lines, insert lines */ do i = row to row + n_rows - 1; if noopt | ^tc_screen$is_region_clear (tc_data.screen_data_ptr, i, col, 1, n_cols) then do; call position_cursor (i, col); call do_operation (CLEAR_TO_EOL, (0), (0), (1), ns); end; end; call position_cursor (row, col); return; end; /* But if we cant tell easily that CLEOL is correct, we prefer i-del-lines */ if col = 1 & n_cols = tc_data.columns & available (DELETE_LINES) & available (INSERT_LINES) then do; call position_cursor (row, 1); call do_operation (DELETE_LINES, (0), (0), n_rows, ns); if -1 + row + n_rows < tc_data.rows then do; call do_operation (INSERT_LINES, (0), (0), n_rows, ns); call position_cursor (row, col); end; return; end; /* This is still pretty primitive. I/DEL chars might be faster sometimes */ begin; declare n_after fixed bin; declare first_after fixed bin; declare have_cleol bit (1) aligned; have_cleol = available (CLEAR_TO_EOL); first_after = col + n_cols; n_after = tc_data.columns - (first_after - 1); do i = row to -1 + row + n_rows; if noopt | ^tc_screen$is_region_clear (tc_data.screen_data_ptr, i, col, 1, n_cols) then do; if have_cleol & (noopt | tc_screen$is_region_clear (tc_data.screen_data_ptr, i, first_after, 1, n_after)) then do; call position_cursor (i, col); call do_operation (CLEAR_TO_EOL, (0), (0), (1), ns); end; else do; call position_cursor (i, col);/* erase only as many chars as necessary */ if have_cleol & n_after + cost (CLEAR_TO_EOL) < n_cols /* cheaper to CEOL and repaint stuff to the right? */ then do; /* CEOL and repaint */ call tc_screen$get_in_line (tc_data.screen_data_ptr, i, first_after, save_row); call do_operation (CLEAR_TO_EOL, (0), (0), (1), ns); call position_cursor (i, first_after); call write_text (i, first_after, addr (save_row), length (rtrim (save_row))); end; else do; /* erase with spaces and leave other windows to the right alone */ call tc_screen$get_in_line (tc_data.screen_data_ptr, i, col, save_row); call write_text (i, col, addr (MANY_SPACES), length (rtrim (substr (save_row, 1, n_cols)))); /* write as few spaces as possible */ end; end; end; end; end; call position_cursor (row, col); end clear_region; insert_text: procedure (a_row, a_col, text_ptr, text_length, last_column); declare (a_row, a_col, last_column) fixed bin; declare (row, col) fixed bin; declare text_ptr pointer; declare text_length fixed bin (21); declare overwrite bit (1); declare 1 ns aligned like new_state; declare clear_start fixed bin; overwrite = "0"b; go to common; overwrite_text: entry (a_row, a_col, text_ptr, text_length); overwrite = "1"b; common: unspec (ns) = ""b; row = a_row; col = a_col; if overwrite then if state.insert_mode /* could only happen if END avail */ then do; ns.pay_attention.insert = "1"b; ns.insert_mode = "0"b; call do_operation (END_INSERT_CHARS, (0), (0), (1), ns); unspec (ns) = ""b; end; else ; else do; /* request to insert */ if available (END_INSERT_CHARS) & tc_data.columns = last_column then if ^state.insert_mode then do; ns.pay_attention.insert = "1"b; ns.insert_mode = "1"b; call do_operation (INSERT_CHARS, (0), (0), (1), ns); unspec (ns) = ""b; end; else ; else do; /* At this point we know that the terminal does not have an insert-character mode. It may have an "open up some space" insert chars operation, a la the Teleray 1061. If so, we have to call do_operation with the INSERT_CHARS op to get the sequences to the terminal, and then we have to call tc_screen again to update the screen image, since it knows that the INSERT_CHARS op doesn't change the screen on terminals with an insert char mode. The two different types of INSERT_CHARS should have been made two different ops when the TTF video stuff was set up, and should be split when the TTF is upgraded (MR 10.2?). -WMY 7/16/82. */ if available (INSERT_CHARS) & tc_data.columns = last_column then do; call do_operation (INSERT_CHARS, (0), (0), (text_length), ns); /* assume no cursor motion */ begin; dcl some_spaces char (text_length) defined (MANY_SPACES) position (1); call tc_screen$text (tc_data.screen_data_ptr, row, col, "1"b /* fake insert mode */, some_spaces); end; end; else do; /* we get here if the terminal doesn't have i-chars or if we aren't the rightmost window */ /* we have no real insert chars operation, so we have to replay the part of the line past the inserted text, so get it from the screen image */ call tc_screen$get_in_line (tc_data.screen_data_ptr, row, col, save_row); call position_cursor (row, col); call write_text (row, col, text_ptr, text_length); /* shorten to fit in what's left of the line. */ save_row = substr (save_row, 1, last_column - (col + text_length) + 1); /* now strip any trailing whitespace from this new string and write it. */ call write_text (row, col + text_length, addr (save_row), length (rtrim (save_row))); /* now clear the rest of the line */ clear_start = col + text_length + length (rtrim (save_row)); call clear_region (row, clear_start, 1, last_column - clear_start + 1); call position_cursor (row, col + text_length); return; end; end; end; call position_cursor (row, col); call write_text (row, col, text_ptr, text_length); end insert_text; delete_chars: procedure (a_row, a_col, a_count, last_column); declare (a_row, a_col, a_count, last_column) fixed bin; declare (row, col, count) fixed bin; declare 1 ns aligned like new_state; declare clear_start fixed bin; declare write_length fixed bin (21); unspec (ns) = ""b; row = a_row; col = a_col; count = a_count; call position_cursor (row, col); if available (DELETE_CHARS) & last_column = tc_data.columns then call do_operation (DELETE_CHARS, (0), (0), count, ns); else do; /* nasty simulation */ call tc_screen$get_in_line (tc_data.screen_data_ptr, row, col + count, save_row); write_length = length (rtrim (substr (save_row, 1, last_column - col - count + 1))); /* be sure not to write in the next window */ call write_text (row, col, addr (save_row), write_length); /* now clear the rest of the line. this should help with whitespace optomization. */ clear_start = col + write_length; call clear_region (row, clear_start, 1, last_column - clear_start + 1); call position_cursor (row, col); end; end delete_chars; scroll_region: procedure (a_row, n_rows, a_distance); declare (a_row, n_rows, a_distance) fixed bin; declare (row, distance) fixed bin; declare save_row fixed bin; declare save_col fixed bin; declare 1 ns aligned like new_state; if ^(available (INSERT_LINES) & available (DELETE_LINES)) then go to capabilities_lacking; /* too hard to simulate */ row = a_row; distance = a_distance; if distance = 0 then return; /* ??? */ unspec (ns) = ""b; save_row = state.row; save_col = state.col; if distance > 0 /* down */ then do; if (row + n_rows - 1) = tc_data.rows then do; /* insert is all we need */ call position_cursor (row, 1); call do_operation (INSERT_LINES, (0), (0), distance, ns); end; else do; call position_cursor (row + n_rows - distance, 1); call do_operation (DELETE_LINES, (0), (0), distance, ns); call position_cursor (row, 1); call do_operation (INSERT_LINES, (0), (0), distance, ns); end; end; else do; /* up */ call position_cursor (row, 1); call do_operation (DELETE_LINES, (0), (0), -distance, ns); if (row + n_rows - 1) ^= tc_data.rows /* bottom region */ then do; call position_cursor (row + n_rows + distance, 1); /* it is negative */ call do_operation (INSERT_LINES, (0), (0), -distance, ns); end; end; call position_cursor (save_row, save_col); end scroll_region; bell: procedure (a_row, a_col); declare (a_row, a_col) fixed bin; declare (row, col) fixed bin; row = a_row; col = a_col; call position_cursor (row, col); /* visual effect too */ call write_bell; /* knows it 0 length on screen */ end bell; cost: procedure (op) returns (fixed bin); declare op fixed bin; declare count fixed bin; count = 1; go to cost_common; cost_repeat: entry (op, a_count) returns (fixed bin); declare a_count fixed bin; count = a_count; cost_common: ttyvseqp = addr (tty_video_table.sequences (op)); if ^tty_video_seq.present then return (OMEGA); /* Quite expensive */ if tty_video_seq.able_to_repeat then return (tty_video_seq.len); else return (count * tty_video_seq.len); available: entry (op) returns (bit (1) aligned); ttyvseqp = addr (tty_video_table.sequences (op)); return (tty_video_seq.present); end cost; do_operation: procedure (op, a_op_row, a_op_col, op_n, a_new_state); /* If op_row or op_col is zero we use current position, if something demands coords. This makes for redundant positions, but so be it for now */ /* ASSERT: that even a line's worth of text will fit into the hardcore's take it or leave it buffer. */ /* This program manages state. For each operation, it makes the character string for the terminal, and calculates the net effect on the cursor position, updating the state structure, and the screen image via tc_screen. */ declare (op, op_row, op_col, op_n, a_op_row, a_op_col) fixed binary; declare 1 a_new_state aligned like new_state; declare 1 ns aligned like new_state; declare 1 seq aligned like tty_video_seq based (ttyvseqp); declare chars character (seq.len) based (chars_ptr); declare chars_ptr pointer; ttyvseqp = addr (tty_video_table.sequences (op)); /* Do this first do avoid faults in the begin block prologue. */ ns = state, by name; if a_new_state.pay_attention.cursor then ns.cursor_valid = a_new_state.cursor_valid; if a_new_state.pay_attention.insert then ns.insert_mode = a_new_state.insert_mode; if a_new_state.pay_attention.position then ns.cursor_position = a_new_state.cursor_position; begin; declare i fixed bin; declare loop fixed bin; declare cx fixed bin; declare vchars character (seq.len) defined (tty_video_table.video_chars) position (seq.seq_index); op_row = a_op_row; if op_row = 0 then op_row = state.row; op_col = a_op_col; if op_col = 0 then op_col = state.col; /* HOME is a bit magic */ if op = HOME then op_row, op_col = 1; if ^seq.present then call tc_error (video_et_$tc_missing_operation, ""); chars_ptr = addr (vchars); /* so we can see chars in probe */ if ^seq.interpret /* easy */ then do; do i = 1 to op_n; /* supply repeats */ call add_to_buffer (chars); call pad; end; go to update_state; end; /* don't bother if nothing is going to happen */ else if (op_n > 0) then do; if seq.able_to_repeat then loop = 1; else loop = op_n; do i = 1 to loop; do cx = 1 to seq.len; begin; declare the_char character (1) defined (chars) position (cx); declare 1 encoded unaligned like tty_numeric_encoding based (enc_ptr); declare enc_ptr pointer; enc_ptr = addr (the_char); if ^encoded.must_be_on then call add_to_buffer (the_char); else cx = cx + encode (encoded); end; /* begin */ end; /* do over chars in seq */ call pad; end; /* over repeat count */ end; /* was nontrivial */ update_state: state = ns, by name; if op_n > 0 then call tc_screen$operation (tc_data.screen_data_ptr, op, op_row, op_col, op_n); end; /* simulated terminal */ return; pad: procedure; if seq.cpad_present then do; if seq.cpad_in_chars then call add_pad_to_buffer ((seq.cpad)); else call add_pad_to_buffer (divide (seq.cpad /* .0001 secs */ * tc_data.line_speed, 10000, 21, 0)); end; end pad; encode: procedure (thing) returns (fixed bin); /* ASSERT that n is positive. what should negatives look like? */ declare 1 thing unaligned like tty_numeric_encoding; declare value fixed bin; declare skip fixed bin; skip = 0; go to VALUE (thing.l_c_or_n); VALUE (0): /* LINE */ value = op_row; go to got_value; VALUE (1): /* COLUMN */ value = op_col; go to got_value; VALUE (2): /* N */ value = op_n; got_value: if ^thing.offset_is_0 then do; value = value + thing.offset; skip = 1; end; if thing.express_in_decimal then do; if thing.num_digits = 0 then call add_to_buffer_ltrim_char (value); else call add_to_buffer_last_n (value, (thing.num_digits)); end; else if thing.express_in_octal then do; /* this is a mess, cause pl1 do not grok octal */ begin; declare bits (-5:6) bit (3) unaligned; declare ib fixed bin; declare saw_nonzero bit (1); declare start fixed bin; saw_nonzero = "0"b; unspec (bits) = unspec (value); if thing.num_digits = 0 then start = 1; else start = 6 - thing.num_digits + 1; do ib = start to 6; if bits (ib) = "000"b then if saw_nonzero | start > 1 then call add_to_buffer ("0"); else ; /* suppress */ else do; call add_to_buffer (byte (bin (bits (ib), 3) + rank ("0"))); saw_nonzero = "1"b; end; end; end; /* begin */ end; /* octalness */ else call add_to_buffer (byte (value)); return (skip); end encode; end do_operation; /* parallel routine to do_operation for writing text to the terminal and updating the screen image. */ write_text: procedure (op_row, op_col, text_ptr, text_length); dcl (op_row, op_col) fixed bin; dcl text_ptr pointer; dcl text_length fixed bin (21); dcl text char (text_length) based (text_ptr); /* Can not be called with 0 values for row and col. */ call add_to_buffer_splittable (text_ptr, text_length); state.row = op_row; state.col = op_col + text_length; call tc_screen$text (tc_data.screen_data_ptr, op_row, op_col, (state.insert_mode), text); return; write_bell: entry; call add_to_buffer (byte (7)); return; end write_text; /* Internal procedures for handling the buffering and sending of data to ring 0 tty routines. */ add_to_buffer: procedure (string); /* Entry to add a string to the output buffer. Always ensures that the entire string is added without breaks, so tty sequences won't get broken */ dcl string character (*); dcl chunk_length fixed bin; dcl stuff_idx fixed bin; dcl ok_to_split bit (1) aligned; dcl a_stuff_ptr pointer; dcl a_stuff_length fixed bin (21); dcl stuff_ptr pointer; dcl stuff_length fixed bin (21); dcl stuff char (stuff_length) based (stuff_ptr); stuff_ptr = addr (string); stuff_length = length (string); ok_to_split = "0"b; goto add_to_buffer_common; add_to_buffer_splittable: entry (a_stuff_ptr, a_stuff_length); /* Entry to write potentially large strings, which can be split up arbitrarily among different calls to ring 0. */ stuff_ptr = a_stuff_ptr; stuff_length = a_stuff_length; ok_to_split = "1"b; goto add_to_buffer_common; add_to_buffer_common: /* Make sure that there is room in the buffer, and flush it out if it is full. */ if (tc_data.global_buffer_index + length (stuff)) > tc_data.global_buffer_limit then if ok_to_split then do; /* first fill the buffer completely and write it */ stuff_idx = 1; do while ((length (stuff) - stuff_idx + 1) > tc_data.global_buffer_limit); chunk_length = tc_data.global_buffer_limit - tc_data.global_buffer_index; substr (tc_data.global_output_buffer, tc_data.global_buffer_index + 1, chunk_length) = substr (stuff, stuff_idx, chunk_length); tc_data.global_buffer_index = tc_data.global_buffer_limit; call write_global_buffer; stuff_idx = stuff_idx + chunk_length; end; /* now put the remaining stuff in the buffer */ chunk_length = length (stuff) - stuff_idx + 1; substr (tc_data.global_output_buffer, tc_data.global_buffer_index + 1, chunk_length) = substr (stuff, stuff_idx); tc_data.global_buffer_index = tc_data.global_buffer_index + chunk_length; return; end; else call write_global_buffer; /* not OK to split */ /* Add entire string. This better not be bigger than the buffer */ substr (tc_data.global_output_buffer, tc_data.global_buffer_index + 1, length (stuff)) = stuff; tc_data.global_buffer_index = tc_data.global_buffer_index + length (stuff); return; end add_to_buffer; add_pad_to_buffer: procedure (number); declare number fixed bin; declare pad_length fixed bin; /* the 254 here is due to a compiler limitation in init clauses */ declare pad_string char (254) static options (constant) init ((254)""); pad_length = min (number, length (pad_string)); begin; dcl defined_pad char (pad_length) defined (pad_string) pos (1); call add_to_buffer (defined_pad); end; return; end add_pad_to_buffer; add_to_buffer_ltrim_char: procedure (number); declare number fixed bin; declare pic_ picture "9999"; declare char_temp char (4); declare first_nonspace fixed bin; pic_ = number; first_nonspace = verify (pic_, "0"); /* digits start here, there must be 1 */ if first_nonspace = 0 then first_nonspace = 4; add_in_number: char_temp = pic_; begin; dcl defined_pic char (length (char_temp) - first_nonspace + 1) defined (char_temp) pos (first_nonspace); call add_to_buffer (defined_pic); end; return; add_to_buffer_last_n: entry (number, digits); declare digits fixed bin; pic_ = number; first_nonspace = 5 - digits; /* first digit we want */ go to add_in_number; end add_to_buffer_ltrim_char; /* Internal routine to write the buffered output to the terminal */ write_global_buffer: procedure; declare to_write character (tc_data.global_buffer_index) defined (tc_data.global_output_buffer) position (1); declare n_wrote fixed bin (21); if length (to_write) = 0 then return; tc_data.change_pclock = tc_data.change_pclock + 1; write: n_wrote = 0; if tc_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$write_whole_string (tc_data.tty_handle, to_write, "1"b /* MARK */, n_wrote, tty_state, code); else if tc_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ call ws_tty_$write_whole_string (tc_data.mowse_terminal_iocb_ptr, to_write, "1"b, n_wrote, tty_state, code) ; else /* MCS */ call hcs_$tty_write_whole_string (tc_data.devx, to_write, "1"b /* MARK */, n_wrote, tty_state, code); if code ^= 0 then call tc_disconnect$check (TC_data_ptr, code); if code ^= 0 then do; /* If the stuff couldn't be written, all our assumptions about the cursor position on the actual terminal are wrong. */ tc_data.state.cursor_valid = "0"b; call tty_write_error (code); end; if length (to_write) > 0 & n_wrote = 0 /* did not happen */ then do; if tc_data.network_type ^= MOWSE_NETWORK_TYPE then call block; go to write; end; call bump_mark; tc_data.global_buffer_index = 0; /* indicate buffer empty */ end write_global_buffer; write_no_mark: procedure (text); declare text character (*); declare n_wrote fixed bin (21); /* ASSERT text_to_echo is aligned */ declare buffer_ptr pointer; declare offset fixed bin (21); declare n_left fixed bin (21); declare char_offset_ entry (ptr) returns (fixed bin (21)) reducible; declare add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; if length (text) = 0 then return; n_left = length (text); buffer_ptr = addr (text); offset = char_offset_ (buffer_ptr); /**** The hardcore demands a word aligned buffer ****/ if offset > 0 then buffer_ptr = add_char_offset_ (buffer_ptr, -offset); /* first write out any buffered stuff to get in sync */ call write_global_buffer; echo_write: if tc_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$write (tc_data.tty_handle, buffer_ptr, offset, n_left, n_wrote, tty_state, code); else if tc_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ call ws_tty_$write (tc_data.mowse_terminal_iocb_ptr, buffer_ptr, offset, n_left, n_wrote, tty_state, code); else /* MCS */ call hcs_$tty_write (tc_data.devx, buffer_ptr, offset, n_left, n_wrote, tty_state, code); if code ^= 0 then call tc_disconnect$check (tc_data_ptr, code); if code ^= 0 then call tty_write_error (code); if n_wrote < n_left then do; /* Lets try it again */ /* This should NEVER happen. */ if tc_data.network_type ^= MOWSE_NETWORK_TYPE then call block; n_left = n_left - n_wrote; offset = offset + n_wrote; go to echo_write; end; return; end write_no_mark; /* This should be the only non-error return point from tc_request. */ request_done: Code = 0; return; capabilities_lacking: Code = video_et_$capability_lacking; go to request_done; block: procedure; declare UNMASK_NOTHING bit (36) aligned initial ("01"b) internal static options (constant); call tc_block (tc_data_ptr, request_ptr, UNMASK_NOTHING); end block; tty_write_error: procedure (code); declare code fixed bin (35); declare msg character (100) aligned; declare convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned); call convert_status_code_ (code, (8)" ", msg); call tc_error (video_et_$tc_tty_error, rtrim (msg)); end tty_write_error; write_raw_text: procedure (row, col, text); declare (row, col) fixed bin; declare text character (*); declare n_wrote fixed bin (21); declare code fixed bin (35); declare tty_state fixed bin; declare offset fixed bin (21); declare text_length fixed bin (21); if length (text) = 0 then return; offset = 0; text_length = length (text); tc_data.change_pclock = tc_data.change_pclock + 1; /* first write out any buffered stuff */ call write_global_buffer; write: begin; declare to_write character (text_length) defined (text) position (1 + offset); n_wrote = 0; /* write the whole string at once, with mark */ if tc_data.network_type = DSA_NETWORK_TYPE then /* DSA */ call dsa_tty_$write_whole_string (tc_data.tty_handle, to_write, "1"b /* with mark */, n_wrote, tty_state, code); else if tc_data.network_type = MOWSE_NETWORK_TYPE then /* MOWSE */ call ws_tty_$write_whole_string (tc_data.mowse_terminal_iocb_ptr, to_write, "1"b, n_wrote, tty_state, code); else /* MCS */ call hcs_$tty_write_whole_string (tc_data.devx, to_write, "1"b /* with mark */, n_wrote, tty_state, code); if code ^= 0 then call tc_disconnect$check (tc_data_ptr, code); if code ^= 0 then call tty_write_error (code); end; if n_wrote < text_length then do; if tc_data.network_type ^= MOWSE_NETWORK_TYPE then call block; text_length = text_length - n_wrote; offset = offset + n_wrote; go to write; end; state.cursor_valid = "0"b; /* who knows what it did ? */ call bump_mark; end write_raw_text; RECOMPUTE_OPERATION: if request_header.this_window /* it happened in the same window */ then go to request_done; else go to recompute_operation_here; /* was not this window */ bump_mark: procedure; if state.current_mark = 511 /* using the size condition is expensive */ then do; state.current_mark = 1; state.last_mark_back = 0; end; state.current_mark = state.current_mark + 1; end bump_mark; write_echo: entry (TC_data_ptr, text_to_echo); declare text_to_echo character (*) parameter; tc_data_ptr = TC_data_ptr; call write_no_mark (text_to_echo); call tc_screen$text (tc_data.screen_data_ptr, state.row, state.col, "0"b, text_to_echo); state.col = state.col + length (text_to_echo); return; %page; %include net_event_message; %page; %include tc_data_; %page; %include tc_operations_; %page; %include condition_info_header; %page; %include tc_asyncronity_info; %page; %include tty_video_tables; end tc_request;  tc_screen.pl1 08/13/87 1333.0rew 08/13/87 1323.6 59562 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Terminal Control Screen Image Management */ /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */ tc_screen: procedure; return; /* Coded June 1981 by, Benson I. Margulies, because I had no choice. */ declare ( Screen_data_ptr pointer, Operation fixed bin, Op_row fixed bin, Op_col fixed bin, Op_count fixed bin, Text character (*), Insert bit (1) aligned, Rows fixed bin, Columns fixed bin ) parameter; /* a virtual video terminal, more or less. Insert mode is replaced with extra entrypoints to simplify things. */ %page; %include tty_video_tables; %page; %include tc_screen_image; %page; declare (length, string, substr) builtin; declare discovered_clear_screen bit (1) aligned; declare line fixed bin; init: entry (Screen_data_ptr, Rows, Columns); screen_n_lines = Rows; screen_n_columns = Columns; allocate screen; string (screen.lines (*)) = ""; screen.is_clear = "1"b; Screen_data_ptr = screen_ptr; return; shut: entry (Screen_data_ptr); free Screen_data_ptr -> screen; return; operation: entry (Screen_data_ptr, Operation, Op_row, Op_col, Op_count); screen_ptr = Screen_data_ptr; go to OPERATION (Operation); OPERATION (0): /* ERROR */ OPERATION (1): /* POSITION CURSOR */ OPERATION (4): /* HOME */ OPERATION (10): /* INSERT_CHARS */ OPERATION (11): /* END INSERT CHARS */ OPERATION (6): /* UP, down, etc. */ OPERATION (7): OPERATION (8): OPERATION (9): return; OPERATION (2): /* Clear screen */ string (screen.lines (*)) = ""; screen.is_clear = "1"b; return; OPERATION (3): /* clear to EOS */ /* too hard to check for is_clear */ substr (screen.lines (Op_row), Op_col) = ""; if Op_row < screen.n_lines then begin; declare lines (screen.n_lines - Op_row) character (screen.n_columns) defined (screen.lines (Op_row + 1)); lines (*) = ""; end; return; OPERATION (12): /* DELETE CHARS */ if screen.is_clear then return; substr (screen.lines (Op_row), Op_col) = substr (screen.lines (Op_row), Op_col + Op_count); return; OPERATION (13): /* INSERT LINES */ if screen.is_clear then return; begin; declare new_home (screen.n_lines - Op_row + 1 - Op_count) character (screen.n_columns) defined (screen.lines (Op_row + Op_count)); declare old_stuff (screen.n_lines - Op_row + 1 - Op_count) character (screen.n_columns) defined (screen.lines (Op_row)); declare to_blank (Op_count) character (screen.n_columns) defined (screen.lines (Op_row)); new_home = old_stuff; to_blank = ""; end; return; OPERATION (14): /* DELETE LINES */ if screen.is_clear then return; begin; declare old_stuff (screen.n_lines - Op_row + 1 - Op_count) character (screen.n_columns) defined (screen.lines (Op_row + Op_count)); declare new_home (screen.n_lines - Op_row + 1 - Op_count) character (screen.n_columns) defined (screen.lines (Op_row)); declare to_blank (Op_count) character (screen.n_columns) defined (screen.lines (screen.n_lines - Op_count + 1)); new_home = old_stuff; to_blank = ""; end; return; OPERATION (5): /* EOL */ if screen.is_clear then return; if Op_row <= screen.n_lines then substr (screen.lines (Op_row), Op_col) = ""; else signal SCREEN_ERROR_; declare SCREEN_ERROR_ condition; return; text: entry (Screen_data_ptr, Op_row, Op_col, Insert, Text); screen_ptr = Screen_data_ptr; if length (Text) = 0 then return; if Text ^= "" then screen.is_clear = "0"b; begin; declare line character (screen.n_columns) defined (screen.lines (Op_row)); if ^Insert then substr (line, Op_col, length (Text)) = Text; else do; (nostringsize): /* whatever the prefix */ substr (line, Op_col + length (Text)) = substr (line, Op_col); /* would take stringsize */ substr (line, Op_col, length (Text)) = Text; end; end; return; clear_in_line: entry (Screen_data_ptr, Op_row, Op_col, Op_count); screen_ptr = Screen_data_ptr; if screen.is_clear then return; substr (screen.lines (Op_row), Op_col, Op_count) = ""; return; get_in_line: entry (Screen_data_ptr, Op_row, Op_col, Text); screen_ptr = Screen_data_ptr; if screen.is_clear then Text = ""; else Text = substr (screen.lines (Op_row), Op_col); return; may_echo_negotiate: entry (Screen_data_ptr, Op_row, Op_col) returns (bit (1) aligned); screen_ptr = Screen_data_ptr; if screen.is_clear then return ("1"b); return (substr (screen.lines (Op_row), Op_col + 1) = ""); is_region_clear: entry (Screen_data_ptr, Op_row, Op_col, Rows, Columns) returns (bit (1) aligned); screen_ptr = Screen_data_ptr; if screen.is_clear then return ("1"b); /* Case statement for efficiency */ /* though Isub defining could probably do it in one nasty dcl */ if Op_col = 1 /* start at origin */ & Op_row = 1 /* ditto */ & Rows = screen.n_lines /* all the way down */ & Columns = screen.n_columns /* and across */ then return (is_the_screen_clear ()); if Rows > 4 /* just a heuristic for cost */ then if is_the_screen_clear () /* perhaps the screen is empty? */ then return ("1"b); /* we have to look at a region */ do line = Op_row to Op_row + Rows - 1; if substr (screen.lines (line), Op_col, Columns) ^= "" then return ("0"b); end; return ("1"b); is_the_screen_clear: /* interrogate screen.is_clear FIRST */ procedure returns (bit (1) aligned); if string (screen.lines (*)) = "" then do; screen.is_clear = "1"b; return ("1"b); end; else return ("0"b); end is_the_screen_clear; end tc_screen;  video_alm_util_.alm 08/13/87 1333.0rew 08/13/87 1324.1 13851 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name video_alm_util_ " alm utilites for the cases when the compiler " cant generate reasonable code " Benson I. Margulies, September 1981 " Title of contents entry XOR_chars " declare video_alm_util_$XOR_chars entry (fixed bin (21), pointer, pointer, pointer) " call video_alm_util_$XOR_chars (n_chars, in_1, in_2, out) " Offsets off of the arg list equ n_chars,2 equ in_1,4 equ in_2,6 equ out,8 XOR_chars: ldq pr0|n_chars,* " how many chars epp2 pr0|in_1,* " ptr to ptr to string epp2 pr2|0,* " ptr to string epp3 pr0|in_2,* " ptr to ptr to string epp3 pr3|0,* " ptr to string epp5 pr0|out,* " ptr to ptr to string epp5 pr5|0,* " ptr to string " move one string into the output slot mlr (pr,rl),(pr,rl),fill(000) desc9a pr2|0,ql desc9a pr5|0,ql mpy 9,dl " now length is bits csl (pr,rl),(pr,rl),fill(0),bool(06) " XOR descb pr3|0,ql descb pr5|0,ql short_return end  video_data_.cds 08/13/87 1333.0rew 08/13/87 1324.2 42705 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1987 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* HISTORY COMMENTS: 1) change(86-11-26,LJAdams), approve(86-11-26,MCR7485), audit(86-12-16,Margolin), install(87-01-06,MR12.0-1255): Changed version number for video. END HISTORY COMMENTS */ /* terminal control and window control data segment. */ /* June 1981, Benson I. Margulies */ /* Modified 8 October 1983 by Jon A. Rochlis to add version number */ /* Modified 2 June 1984 by JR to add the EXL flags and to remove saved_sus_handler since it is longer needed */ /* format: style2 */ video_data_: procedure; %include cds_args; declare 1 cdsa aligned like cds_args; declare create_ips_mask_ entry (pointer, fixed binary, bit (36) aligned); declare create_data_segment_ entry (pointer, fixed binary (35)); declare com_err_ entry () options (variable); declare code fixed bin (35); declare create_ips_mask_err condition; declare 1 video_text aligned, 2 terminal_switch character (32), 2 shut_mask bit (36) aligned, 2 open_mask bit (36) aligned, 2 only_quit_mask bit (36) aligned, 2 alrm_only_mask bit (36) aligned, 2 as_only_mask bit (36) aligned, 2 error_name character (32), 2 version character (12), 2 exl_video_system bit (1) unaligned, 2 mbz bit (35) unaligned, 2 pad_end bit (0) aligned; declare 1 video_static aligned, 2 terminal_iocb pointer, 2 exl_initialized bit (1) unaligned, 2 mbz bit (35) unaligned, 2 pad_end bit (0) aligned; declare quit_name (4) character (32) aligned static internal init ("quit", "trm_", "sus_", "neti") options (constant); declare alrm_only_name (1) character (32) aligned static internal init ("alrm") options (constant); declare as_only_name (3) character (32) aligned static internal init ("trm_", "sus_", "neti") options (constant); declare all_name (1) character (32) aligned static internal init ("-all") options (constant); declare pad_name (1) character (32) static internal init ("pad*") options (constant); declare ME character (32) static internal init ("video_data_") internal static options (constant); declare (addr, currentsize, hbound, null, string, unspec) builtin; unspec (video_text) = ""b; unspec (video_static) = ""b; on create_ips_mask_err begin; call com_err_ (0, ME, "IPS mask generation failed."); go to give_up; end; call create_ips_mask_ (addr (quit_name), hbound (quit_name, 1), video_text.only_quit_mask); video_text.only_quit_mask = ^video_text.only_quit_mask; call create_ips_mask_ (addr (all_name), hbound (all_name, 1), video_text.shut_mask); video_text.open_mask = ^video_text.shut_mask; call create_ips_mask_ (addr (as_only_name), hbound (as_only_name, 1), video_text.as_only_mask); call create_ips_mask_ (addr (alrm_only_name), hbound (alrm_only_name, 1), video_text.alrm_only_mask); video_text.error_name = "internal terminal control"; video_text.terminal_switch = "user_terminal_"; video_text.version = "MR12"; video_text.exl_video_system = "0"b; /* video_utils_ will use this when deciding whether or not to call use_exl_video_system */ video_static.terminal_iocb = null (); video_static.exl_initialized = "0"b; string (cdsa.switches) = ""b; cdsa.switches.separate_static, cdsa.switches.have_static, cdsa.switches.have_text = "1"b; cdsa.p (1) = addr (video_text); cdsa.len (1) = currentsize (video_text); cdsa.struct_name (1) = "video_text"; cdsa.p (2) = addr (video_static); cdsa.len (2) = currentsize (video_static); cdsa.struct_name (2) = "video_static"; cdsa.seg_name = ME; cdsa.num_exclude_names = 1; cdsa.exclude_array_ptr = addr (pad_name); call create_data_segment_ (addr (cdsa), code); if code ^= 0 then call com_err_ (code, ME); return; give_up: end video_data_;  video_et_.alm 08/13/87 1333.0r w 08/13/87 1324.0 43533 " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** " *********************************************************** " * * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1981 * " * * " * * " *********************************************************** " video_et_ error codes for the video system " June 1981, Benson I. Margulies " Added no_more_handler_in_use for the get_more_handler order -- JR 8/7/83 name video_et_ include et_macros et video_et_ ec out_of_window_bounds,rqt_oowb, (The request was not within the boundaries of the requesting window.) ec no_video_info,term^tv, (There is no video information defined for this terminal.) ec terminal_cannot_position,cant_pos, (The terminal does not support cursor positioning.) ec capability_lacking,cant_do, (The terminal hardware does not support the requested operation.) ec bad_window_id,bad_wnid, (The supplied window id was not valid.) ec overlapping_windows,wnoverlp, (Two windows may not overlap on the screen.) ec tc_illegal_request,tcbadreq, (Illegal terminal control operation requested.) ec tc_cannot_position,tc^absps, (Terminal control could not choose an ABS_POS sequence.) ec tc_missing_operation,tc^tmseq, (Terminal control attempted to use an operation not defined for the terminal.) ec tc_tty_error,tc^ttyop, (Terminal control made an incorrect call to hardcore terminal management.) ec tc_mark_missing,tcnomark, (Terminal control misplaced a synchronization mark.) ec tc_block_failed,tcblkerr, (Terminal control could not block on tty event.) ec tc_out_of_terminal_bounds,tc^inbds, (Terminal control attempt to position beyond screen boundaries.) ec not_terminal_switch,^term, (The specified switch is not managed by terminal control.) ec switch_not_attached_with_tty_,(sw^tty), (The specified switch is not attached with the tty_ I/O module.) ec window_status_pending,(wstatus), (There is window interrupt status pending for the specified window.) ec bad_window_request,(badwreq), (Internal error in window control: illegal operation.) ec string_not_printable,(w^ascii), (A character supplied to a window_ text entrypoint was not a single width printing ASCII character.) ec cursor_position_undefined,nocurps, (The current cursor position is not defined in the specified window.) ec window_too_big,(bigwind), (The screen is too small to accomodate a window of the requested size.) ec overlapping_more_responses,(badmore), (A common character has been found in the ""yes"" and ""no"" strings.) ec insuff_room_for_window,noroom,(Insufficient room to create window.) ec nonvariable_window,nonvar,(Window is not variable.) ec window_too_small,toosmall,(Tried to adjust window past minimum size.) ec negative_screen_size,negssize,(Negative screen size specified.) ec negative_window_size,negwsize,(Negative window size specified.) ec nonexistent_window,nonexist,(Specified window does not exist.) ec overlaps_other_window,woverlap,(Specified window overlaps other windows.) ec overlaps_screen_edge,soverlap,(Specified window overlaps screen edge.) ec unable_to_create_window,nowcreat,(Unable to create window.) ec unable_to_create_screenobj,noscreat,(Unable to create screen object.) ec unable_to_dest_window,nowdestr,(Unable to destroy window.) ec windows_still_exist,exist,(Windows still exist.) ec window_inconsistencies,inconsis,(Inconsistencies in window specification.) ec no_variable_windows,novar,(There are no variable windows on the screen.) ec unable_to_call_wsys,nowsys,(Unable to invoke the window system.) ec wsys_not_invoked,notinv,(The window system has not been invoked.) ec wsys_invoked,inv,(The window system has already been invoked.) ec help_requested,help,(User requests usage information.) ec exit_now,quit,(Immediate termination requested.) ec bad_window_image,badimag, (A window image supplied to window_display_ was not the same size as the window.) ec switch_not_window,sw^wind, (The specified switch is not attached as a window.) ec no_more_handler_in_use,^moreh,(No more handler is in use for specified window.) end  video_utils_.pl1 05/10/89 1202.7rew 05/10/89 1159.9 395874 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-05-23,LJAdams), approve(86-11-11,MCR7485), audit(87-01-06,Margolin), install(87-01-06,MR12.0-1255): Modified to support MOWSE. 2) change(86-11-26,LJAdams), approve(86-11-26,MCR7584), audit(87-01-06,Margolin), install(87-01-06,MR12.0-1255): Initial DSA coding has been maintained in a non-executable form. 3) change(87-01-14,LJAdams), approve(87-01-14,PBF7485), audit(87-01-14,Gilcrease), install(87-01-14,MR12.0-1280): Do not create video_data_$terminal_iocb until we are sure MOWSE is present. 4) change(87-01-16,LJAdams), approve(87-01-16,PBF7485), audit(87-01-16,Gilcrease), install(87-01-19,MR12.0-1287): If an errors executing control order initialize_mowse_terminal return. 5) change(87-05-20,LJAdams), approve(87-05-20,MCR7699), audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055): Added support for MOWSE_FANSI protocol. Made sure all ips signals are UNMASKED prior to starting video. 6) change(87-06-16,LJAdams), approve(87-06-16,MCR7584), audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055): Change editing_chars_version_2 to editing_chars_version_3 which includes the redisplay character. 7) change(88-09-19,Brunelle), approve(88-09-19,MCR7813), audit(88-10-05,Blair), install(88-10-17,MR12.2-1171): Change get_special control order to add version number in structure so we get new format of the special chars structure. 8) change(89-02-27,Lee), approve(89-03-14,MCR8075), audit(89-04-20,Flegel), install(89-05-10,MR12.3-1041): phx19064 (Video 87) - modified to use the current editing char values rather than the default erase/kill (#@) values when video is invoked. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ /* various useful things in the video system. */ /* BIM June 1981 */ /* Modified 14 December 1981 by Chris Jones to copy modes in common with tty_ on invocation */ /* Modified 16 December 1981 by Chris Jones to copy editing chars on invocation, and restore modes and editing_chars on exit. */ /* Modified January 1883 by William York to call window_$sync before shutting down. */ /* Modified ? by Barry Margolin to find the -login_channel switch instead of assuming user_i/o. */ /* Modified 18 May 1983 by WMY to save all the tty_ state there is upon invocation and to restore it on revocation. */ /* Modified August 1983 by Jon A. Rochlis to add ssu usage recording. */ /* Modified 26 January 1984 by JR to set the output conversion and special tables in use by tty_ via control orders to terminal control, which will be passed to ring0. Window_io_ can get them back and use them as defaults by asking terminal control. */ /* Modified 24 May 1984 by JR to remove the sus_signal_handler stuff, since the reconnection control order doesn't need it, and it will actually break things in one case (reconnection on an unsupported terminal). */ /* Modified 30 May 1984 by JR to put in the conditional calls to use_exl_video_system$(setup cleanup) */ /* Modified 01 September 1984 by JR to add edited mode to the list of common modes. */ /* Modified 22 November 1984 by JR to explicity reset video_data_$terminal_iocb if we fail to invoke the video system. This is needed since turn_off_login_channel (among others) relies on terminal_iocb ^= null() ==> video is on. */ /* Modified 27 December 1984 by JR to make get_tty_state use version number constants from tty_convert.incl.pl1 instead of hardcoding the constants. */ /* Modified June 1985 by Roger Negaret to support DSA networks. */ video_utils_: procedure; return; %page; dcl user_io_modes char (512); dcl saved_ips_mask bit (36) aligned; dcl ips_mask_name (1) char (32) aligned init ("-all"); dcl sci_ptr ptr; dcl complete_tty_state_ptr pointer internal static; /* Structure in which to save all interesting tty_ state information. */ dcl 1 complete_tty_state aligned based (complete_tty_state_ptr), 2 modes_string char (512) unaligned, 2 editing_chars_ptr pointer, 2 delay_ptr pointer, 2 framing_chars_ptr pointer, 2 ifc_ptr pointer, 2 ofc_ptr pointer, 2 input_translation_ptr pointer, 2 input_conversion_ptr pointer, 2 output_conversion_ptr pointer, 2 output_translation_ptr pointer, 2 special_ptr pointer; dcl 1 fsc_info like mowse_io_flush_subchannel_info; dcl common_modes (7) char (8) init ("vertsp", "can", "erkl", "esc", "red", "ctl_char", "edited") static options (constant); dcl create_ips_mask_ entry (ptr, fixed bin, bit(36) aligned); dcl hcs_$set_ips_mask entry (bit(36) aligned, bit(36) aligned); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl ipc_$mask_ev_calls entry (fixed bin (35)); dcl ipc_$unmask_ev_calls entry (fixed bin (35)); dcl mode_string_$get entry (ptr, char (*), fixed bin (35)); dcl mode_string_$get_mode entry (char (*), char (*), ptr, fixed bin (35)); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$record_usage entry (ptr, ptr, fixed bin (35)); dcl use_exl_video_system$cleanup entry (fixed bin (35)); dcl window_$destroy_all entry (pointer); dcl video_data_$terminal_switch character (32) external; dcl video_data_$terminal_iocb pointer external; dcl video_data_$exl_video_system bit (1) external static; dcl video_data_$exl_initialized bit (1) external; dcl error_table_$action_not_performed external fixed bin (35); dcl error_table_$no_table external fixed bin (35); dcl error_table_$undefined_order_request fixed bin (35) ext static; dcl video_et_$wsys_invoked fixed bin (35) ext static; dcl video_data_$version external char (12); dcl any_other condition; dcl sub_error_ condition; dcl cleanup_label label variable; dcl mowse_terminal_switch char (15) internal static options (constant) init ("mowse_terminal_"); dcl mowse_iocb_ptr pointer static; /* remember where mowse_terminal_ was */ dcl network_type fixed bin (4) unsigned static; /* remember on which network we are */ dcl target_iocb pointer static; /* remember what switch to use */ dcl (addr, codeptr, hbound, lbound, index, length, ltrim, min, null, rtrim, substr) builtin; %page; turn_on_login_channel: entry (error_code, reason); declare error_code fixed bin (35); declare reason character (*); declare acode fixed bin (35); declare use_exl_video_system$setup entry (fixed bin (35)); error_code = 0; if video_data_$terminal_iocb ^= null () then do; error_code = video_et_$wsys_invoked; reason = ""; return; end; /*** set the network id: */ call network_login_channel (target_iocb, network_type, error_code); if error_code ^= 0 then do; reason = "Could not find a tty_ or mowse attachment."; return; end; call create_ips_mask_ (addr(ips_mask_name), hbound(ips_mask_name,1), saved_ips_mask); /* everthing masked */ saved_ips_mask = ^saved_ips_mask; /* unmask everything to start */ call hcs_$set_ips_mask (saved_ips_mask, ""b); /* initially there is no old mask value */ if network_type = MOWSE_NETWORK_TYPE then goto mowse_network; else if network_type = DSA_NETWORK_TYPE then goto dsa_network; else goto mcs_network; %page; dsa_network: network_type = DSA_NETWORK_TYPE; reason = "Creating switch " || video_data_$terminal_switch; call iox_$find_iocb (video_data_$terminal_switch, video_data_$terminal_iocb, error_code); if error_code ^= 0 then return; cleanup_label = UNDO_DSA_$mask; on any_other call handle_any_other (cleanup_label); /* we could be cl_intermediary, but they get called without any state */ /* Before we close the channel, copy any tty_ state information that we want to preserve across the attachment. */ call get_tty_state; call hcs_$set_ips_mask (""b, saved_ips_mask); call ipc_$mask_ev_calls ((0)); /* in case some joker blocks */ reason = "Closing terminal switch."; call iox_$close (target_iocb, error_code); if error_code ^= 0 then goto UNDO_DSA_$mask; cleanup_label = DSA_REOPEN; reason = "Detaching terminal switch."; call iox_$detach_iocb (target_iocb, error_code); if error_code ^= 0 then goto DSA_REOPEN; /* Old attachment gone, attach the tc_io_ switch. */ cleanup_label = DSA_REATTACH; reason = "Attaching switch " || rtrim (video_data_$terminal_switch) || " as tc_io_ -login_channel ."; on sub_error_ call attach_handler (cleanup_label); call iox_$attach_ptr (video_data_$terminal_iocb, "tc_io_ -login_channel", codeptr (video_utils_), error_code); revert sub_error_; if error_code ^= 0 then go to DSA_REATTACH; cleanup_label = UNDO_DSA_$video; reason = "Opening switch " || video_data_$terminal_switch; call iox_$open (video_data_$terminal_iocb, Stream_input_output, ""b, error_code); if error_code ^= 0 then go to UNDO_DSA_$video; call iox_$control (video_data_$terminal_iocb, "set_output_conversion", complete_tty_state.output_conversion_ptr, (0)); call iox_$control (video_data_$terminal_iocb, "set_special", complete_tty_state.special_ptr, (0)); /* RL: phx19064 - use editing chars which are current set */ call iox_$control (video_data_$terminal_iocb, "set_editing_chars", complete_tty_state.editing_chars_ptr, (0)); reason = "attaching ""window_io_ " || rtrim (video_data_$terminal_switch) || """"; on sub_error_ call attach_handler (cleanup_label); call iox_$attach_ptr (target_iocb, "window_io_ " || rtrim (video_data_$terminal_switch), codeptr (video_utils_), error_code); if error_code ^= 0 then goto UNDO_DSA_$video; revert sub_error_; cleanup_label = UNDO_DSA_$attach; reason = "opening terminal switch."; call iox_$open (target_iocb, Stream_input_output, ""b, error_code); if error_code ^= 0 then goto UNDO_DSA_$attach; cleanup_label = UNDO_DSA; reason = "Initializing EXL video system."; if video_data_$exl_video_system & ^video_data_$exl_initialized then do; call use_exl_video_system$setup (error_code); if error_code ^= 0 then goto UNDO_DSA; video_data_$exl_initialized = "1"b; end; goto finished; %page; UNDO_DSA: call close_switch; UNDO_DSA_$attach: call detach_switch; UNDO_DSA_$video: call close_video; DSA_REATTACH: call reattach; DSA_REOPEN: call reopen; UNDO_DSA_$mask: goto unmask_return; %page; mcs_network: network_type = MCS_NETWORK_TYPE; reason = "Creating switch " || video_data_$terminal_switch; call iox_$find_iocb (video_data_$terminal_switch, video_data_$terminal_iocb, error_code); if error_code ^= 0 then return; /* Before we close the channel, copy any tty_ state information that we want to preserve across the attachment. */ cleanup_label = UNDO_MCS_$mask; on any_other call handle_any_other (cleanup_label); /* we could be cl_intermediary, but they get called without any state */ call get_tty_state; call hcs_$set_ips_mask (""b, saved_ips_mask); call ipc_$mask_ev_calls ((0)); /* in case some joker blocks */ reason = "Closing terminal switch."; call iox_$close (target_iocb, error_code); if error_code ^= 0 then go to UNDO_MCS_$mask; cleanup_label = MCS_REOPEN; reason = "Detaching terminal switch."; call iox_$detach_iocb (target_iocb, error_code); if error_code ^= 0 then go to MCS_REOPEN; /* Old attachment gone, attach the tc_io_ switch. */ cleanup_label = MCS_REATTACH; reason = "Attaching switch " || rtrim (video_data_$terminal_switch) || " as tc_io_ -login_channel ."; on sub_error_ call attach_handler (cleanup_label); call iox_$attach_ptr (video_data_$terminal_iocb, "tc_io_ -login_channel", codeptr (video_utils_), error_code); revert sub_error_; if error_code ^= 0 then go to MCS_REATTACH; cleanup_label = UNDO_MCS_$video; reason = "Opening switch " || video_data_$terminal_switch; call iox_$open (video_data_$terminal_iocb, Stream_input_output, ""b, error_code); if error_code ^= 0 then go to UNDO_MCS_$video; call iox_$control (video_data_$terminal_iocb, "set_output_conversion", complete_tty_state.output_conversion_ptr, (0)); call iox_$control (video_data_$terminal_iocb, "set_special", complete_tty_state.special_ptr, (0)); /* RL: phx19064 - use editing chars which are current set */ call iox_$control (video_data_$terminal_iocb, "set_editing_chars", complete_tty_state.editing_chars_ptr, (0)); reason = "attaching ""window_io_ " || rtrim (video_data_$terminal_switch) || """"; on sub_error_ call attach_handler (cleanup_label); call iox_$attach_ptr (target_iocb, "window_io_ " || rtrim (video_data_$terminal_switch), codeptr (video_utils_), error_code); if error_code ^= 0 then goto UNDO_MCS_$video; revert sub_error_; cleanup_label = UNDO_MCS_$attach; reason = "opening terminal switch."; call iox_$open (target_iocb, Stream_input_output, ""b, error_code); if error_code ^= 0 then goto UNDO_MCS_$attach; cleanup_label = UNDO_MCS; reason = "Initializing EXL video system."; if video_data_$exl_video_system & ^video_data_$exl_initialized then do; call use_exl_video_system$setup (error_code); if error_code ^= 0 then goto UNDO_MCS; video_data_$exl_initialized = "1"b; end; goto finished; %page; UNDO_MCS: call close_switch; UNDO_MCS_$attach: call detach_switch; UNDO_MCS_$video: call close_video; MCS_REATTACH: call reattach; MCS_REOPEN: call reopen; UNDO_MCS_$mask: goto unmask_return; %page; mowse_network: dcl 1 mowse_io_term_state like mowse_io_terminal_state, mowse_io_term_ptr ptr; network_type = MOWSE_NETWORK_TYPE; mowse_io_term_ptr = addr (mowse_io_term_state); mowse_io_term_state.version = mowse_io_info_version_1; call iox_$control (target_iocb, "get_terminal_emulator_state", mowse_io_term_ptr, error_code); if error_code ^= 0 then do; error_code = error_table_$action_not_performed; reason = "Control order not performed."; return; end; else if ^mowse_io_term_state.state then do; /* MOWSE not attached */ error_code = error_table_$action_not_performed; reason = "MOWSE not active."; return; end; reason = "Creating switch " || video_data_$terminal_switch; call iox_$find_iocb (video_data_$terminal_switch, video_data_$terminal_iocb, error_code); if error_code ^= 0 then return; call get_tty_state; call hcs_$set_ips_mask (""b, saved_ips_mask); call ipc_$mask_ev_calls ((0)); cleanup_label = UNDO_MOWSE_$mask; on any_other call handle_any_other (cleanup_label); /* we could be cl_intermediary, but they get called without any state */ reason = "Creating switch " || mowse_terminal_switch; call iox_$find_iocb (mowse_terminal_switch, mowse_iocb_ptr, error_code); /* iocb.name = mowse_terminal_ */ if error_code ^= 0 then goto UNDO_MOWSE_$mask; reason = "Moving mowse attachment."; call iox_$move_attach (target_iocb, mowse_iocb_ptr, error_code); /* moving user_i/o to mowse_terminal_ */ if error_code ^= 0 then goto UNDO_MOWSE_$mask; cleanup_label = UNDO_MOWSE_$move_attach; reason = "Attaching switch " || mowse_terminal_switch || " as tc_io_ -mowse"; on sub_error_ call attach_handler (cleanup_label); call iox_$attach_ptr (video_data_$terminal_iocb, "tc_io_ -mowse " || mowse_terminal_switch, codeptr (video_utils_), error_code); /* iocb.name = user_terminal_ */ revert sub_error_; if error_code ^= 0 then goto UNDO_MOWSE_$move_attach; cleanup_label = UNDO_MOWSE_$video; reason = "Opening switch " || video_data_$terminal_switch; call iox_$open (video_data_$terminal_iocb, Stream_input_output, ""b, error_code); if error_code ^= 0 then goto UNDO_MOWSE_$video; call iox_$control (video_data_$terminal_iocb, "set_output_conversion", complete_tty_state.output_conversion_ptr, (0)); call iox_$control (video_data_$terminal_iocb, "set_special", complete_tty_state.special_ptr, error_code); /* RL: phx19064 - use editing chars which are current set */ call iox_$control (video_data_$terminal_iocb, "set_editing_chars", complete_tty_state.editing_chars_ptr, (0)); if error_code ^= 0 then goto UNDO_MOWSE_$video; reason = "attaching ""window_io_ " || rtrim (video_data_$terminal_switch) || """"; on sub_error_ call attach_handler (cleanup_label); call iox_$attach_ptr (target_iocb, "window_io_ " || rtrim (video_data_$terminal_switch), codeptr (video_utils_), error_code); /* iocb.name = user_i/o */ if error_code ^= 0 then goto UNDO_MOWSE_$video; revert sub_error_; cleanup_label = UNDO_MOWSE_$attach; reason = "opening terminal switch."; call iox_$open (target_iocb, Stream_input_output, ""b, error_code); if error_code ^= 0 then goto UNDO_MOWSE_$attach; cleanup_label = UNDO_MOWSE; reason = "Initializing EXL video system."; if video_data_$exl_video_system & ^video_data_$exl_initialized then do; call use_exl_video_system$setup (error_code); if error_code ^= 0 then goto UNDO_MOWSE; video_data_$exl_initialized = "1"b; end; goto finished; %page; UNDO_MOWSE: call close_switch; UNDO_MOWSE_$attach: call detach_switch; UNDO_MOWSE_$video: call close_video; UNDO_MOWSE_$move_attach: call move_attach; mowse_iocb_ptr = null; UNDO_MOWSE_$mask: goto unmask_return; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * */ finished: revert any_other; /* Wheeeee. we did it. */ reason = ""; error_code = 0; call iox_$modes (target_iocb, user_io_modes, "", (0)); unmask_return: call hcs_$reset_ips_mask (saved_ips_mask, ""b); call ipc_$unmask_ev_calls ((0)); if network_type = MOWSE_NETWORK_TYPE then do; call iox_$control (video_data_$terminal_iocb, "initialize_mowse_terminal", null (), error_code); if error_code ^= 0 then do; reason = "Executing control order initialize_mowse_terminal."; call close_switch; call detach_switch; call close_video; call move_attach; mowse_iocb_ptr = null; end; end; call iox_$control (video_data_$terminal_iocb, "quit_enable", null (), (0)); record_usage: call ssu_$standalone_invocation (sci_ptr, "video", video_data_$version, null (), video_utils_, (0)); call ssu_$record_usage (sci_ptr, codeptr (video_utils_), (0)); call ssu_$destroy_invocation (sci_ptr); simple_error_return: if error_code ^= 0 then video_data_$terminal_iocb = null (); /* We may have set this, but it shouldn't be left that way if we failed to invoke video */ return; %page; /* Routines that perform the basic switch operations needed */ close_switch: proc; call iox_$close (target_iocb, acode); if acode ^= 0 then call must_kill_process (acode, "Can't close terminal switch."); return; end close_switch; /* * * * * * * * * * * * * * * * * * * * * * * * * */ detach_switch: proc; call iox_$detach_iocb (target_iocb, acode); if acode ^= 0 then call must_kill_process (acode, "Can't detach terminal switch."); return; end detach_switch; /* * * * * * * * * * * * * * * * * * * * * * * * * */ close_video: proc; call iox_$close (video_data_$terminal_iocb, (0)); call iox_$detach_iocb (video_data_$terminal_iocb, (0)); call iox_$destroy_iocb (video_data_$terminal_iocb, (0)); return; end close_video; /* * * * * * * * * * * * * * * * * * * * * * * * * */ move_attach: proc; call iox_$move_attach (mowse_iocb_ptr, target_iocb, acode); if acode ^= 0 then call must_kill_process (acode, "Can't move attachment."); return; end move_attach; /* * * * * * * * * * * * * * * * * * * * * * * * * */ reattach: proc; call iox_$attach_ptr (target_iocb, "tty_ -login_channel", codeptr (video_utils_), acode); if acode ^= 0 then call must_kill_process (acode, "Can't attach tty_"); return; end reattach; /* * * * * * * * * * * * * * * * * * * * * * * * * */ reopen: proc; call iox_$open (target_iocb, Stream_input_output, ""b, acode); if acode ^= 0 then call must_kill_process (acode, "Can't open terminal switch."); call iox_$control (target_iocb, "quit_enable", null (), (0)); call iox_$modes (target_iocb, "default", "", (0)); return; end reopen; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * */ turn_off_login_channel: entry (error_code); /* this entry is less careful, but much more brutal ..... */ error_code = 0; if video_data_$terminal_iocb = null () then return; /* Make sure that all buffered output is sent. */ call window_$sync (iox_$user_io, (0)); if network_type = MOWSE_NETWORK_TYPE then do; fsc_info.subchannel = FG; fsc_info.version = mowse_io_info_version_1; call iox_$control (video_data_$terminal_iocb, "flush_subchannel", addr (fsc_info), error_code); end; saved_ips_mask = ""b; call hcs_$set_ips_mask (""b, saved_ips_mask); call ipc_$mask_ev_calls ((0)); call window_$destroy_all (video_data_$terminal_iocb); if network_type = MOWSE_NETWORK_TYPE then call mowse_turn_off; else if network_type = DSA_NETWORK_TYPE then call dsa_turn_off; else call mcs_turn_off; return; %page; dsa_turn_off: proc; call iox_$close (target_iocb, (0)); call iox_$detach_iocb (target_iocb, (0)); call iox_$close (video_data_$terminal_iocb, (0)); call iox_$detach_iocb (video_data_$terminal_iocb, (0)); call iox_$destroy_iocb (video_data_$terminal_iocb, (0)); video_data_$terminal_iocb = null (); call force_detach_hcs; error_code = 0; call iox_$attach_ptr (target_iocb, "tty_ -login_channel", codeptr (video_utils_), error_code); if error_code ^= 0 then call must_kill_process (error_code, "Can't attach tty_"); call iox_$open (target_iocb, Stream_input_output, ""b, error_code); if error_code ^= 0 then call must_kill_process (error_code, "Can't open terminal switch"); call hcs_$reset_ips_mask (saved_ips_mask, ""b); call ipc_$unmask_ev_calls ((0)); if video_data_$exl_video_system & video_data_$exl_initialized then do; call use_exl_video_system$cleanup ((0)); video_data_$exl_initialized = "0"b; end; call iox_$control (target_iocb, "quit_enable", null (), (0)); call set_tty_state; return; end dsa_turn_off; %page; mcs_turn_off: proc; call iox_$close (target_iocb, (0)); call iox_$detach_iocb (target_iocb, (0)); call iox_$close (video_data_$terminal_iocb, (0)); call iox_$detach_iocb (video_data_$terminal_iocb, (0)); call iox_$destroy_iocb (video_data_$terminal_iocb, (0)); video_data_$terminal_iocb = null (); call force_detach_hcs; error_code = 0; call iox_$attach_ptr (target_iocb, "tty_ -login_channel", codeptr (video_utils_), error_code); if error_code ^= 0 then call must_kill_process (error_code, "Can't attach tty_"); call iox_$open (target_iocb, Stream_input_output, ""b, error_code); if error_code ^= 0 then call must_kill_process (error_code, "Can't open terminal switch"); call hcs_$reset_ips_mask (saved_ips_mask, ""b); call ipc_$unmask_ev_calls ((0)); if video_data_$exl_video_system & video_data_$exl_initialized then do; call use_exl_video_system$cleanup ((0)); video_data_$exl_initialized = "0"b; end; call iox_$control (target_iocb, "quit_enable", null (), (0)); call set_tty_state; return; end mcs_turn_off; %page; mowse_turn_off: proc; error_code = 0; call iox_$close (target_iocb, error_code); /* iocb.name = user_i/o */ call iox_$detach_iocb (target_iocb, error_code); if error_code ^= 0 then call must_kill_process (error_code, "Can't detach user_terminal"); call iox_$close (video_data_$terminal_iocb, (0)); call iox_$detach_iocb (video_data_$terminal_iocb, (0)); call iox_$destroy_iocb (video_data_$terminal_iocb, (0)); video_data_$terminal_iocb = null (); call iox_$move_attach (mowse_iocb_ptr, target_iocb, error_code); /* move mowse_terminal_ to user_i/o */ if error_code ^= 0 then call must_kill_process (error_code, "Can't move attach mowse_terminal_"); call hcs_$reset_ips_mask (saved_ips_mask, ""b); call ipc_$unmask_ev_calls ((0)); if video_data_$exl_video_system & video_data_$exl_initialized then do; call use_exl_video_system$cleanup ((0)); video_data_$exl_initialized = "0"b; end; return; end mowse_turn_off; %page; turn_off_for_debug: entry; declare iox_$init_standard_iocbs entry; call hcs_$set_ips_mask (""b, ""b); /* we will force open */ declare unique_chars_ entry (bit (*)) returns (character (15)); declare u character (15); declare iocbp pointer; u = unique_chars_ (""b); call iox_$find_iocb (rtrim (u) || ".user_output", iocbp, (0)); call iox_$move_attach (iox_$user_output, iocbp, (0)); call iox_$find_iocb (rtrim (u) || ".user_input", iocbp, (0)); call iox_$move_attach (iox_$user_input, iocbp, (0)); call iox_$find_iocb (rtrim (u) || ".error_output", iocbp, (0)); call iox_$move_attach (iox_$error_output, iocbp, (0)); call iox_$find_iocb (rtrim (u) || ".user_i/o", iocbp, (0)); call iox_$move_attach (iox_$user_io, iocbp, (0)); call iox_$init_standard_iocbs; error_code = 0; if network_type = MOWSE_NETWORK_TYPE then do; call iox_$move_attach (mowse_iocb_ptr, iox_$user_io, error_code); if error_code ^= 0 then call must_kill_process (error_code, "Can't attach mowse_io_."); end; else do; call force_detach_hcs; call iox_$attach_ptr (iox_$user_io, "tty_ -login_channel", codeptr (video_utils_), error_code); if error_code ^= 0 then call must_kill_process (error_code, "Can't attach tty_."); call iox_$open (iox_$user_io, Stream_input_output, ""b, error_code); if error_code ^= 0 then call must_kill_process (error_code, "Can't open user_io."); end; call hcs_$reset_ips_mask ((36)"1"b, ""b); return; %page; force_detach_hcs: procedure; declare user_info_$terminal_data entry (char (*), char (*), char (*), fixed bin, char (*)); declare target character (32); declare hcs_$tty_index entry (character (*), fixed bin, fixed bin, fixed bin (35)); declare hcs_$tty_detach entry (fixed bin, fixed bin, fixed bin, fixed bin (35)); declare dsa_tty_$index entry (character (*), fixed bin (35), fixed bin, fixed bin (35)); declare dsa_tty_$detach entry (fixed bin (35), fixed bin, fixed bin, fixed bin (35)); declare tty_handle fixed bin (35); declare devx fixed bin; /* Now make sure we can attach tty, by cheating. this error_code should go away when things get more stable */ call user_info_$terminal_data ("", "", target, (0), ""); if network_type = DSA_NETWORK_TYPE then do; call dsa_tty_$index (target, tty_handle, (0), (0)); call dsa_tty_$detach (tty_handle, (0), (0), (0)); end; else do; /* MCS_NETWORK_TYPE */ call hcs_$tty_index (target, devx, (0), (0)); call hcs_$tty_detach (devx, (0), (0), (0)); end; /* Now attaching tty_ is pretty certain to work */ end force_detach_hcs; %page; must_kill_process: procedure (reason, why) options (non_quick); declare why character (*); declare reason fixed bin (35); declare terminate_process_ entry (character (*), pointer); declare 1 ti aligned, 2 version fixed bin, 2 status fixed bin (35); ti.version = 0; ti.status = reason; call terminate_process_ ("fatal_error", addr (ti)); end; %page; attach_handler: handle_any_other: procedure (return_label); dcl return_label label variable; %include condition_info_header; %include sub_error_info; %include condition_info; declare 1 ci aligned like condition_info; declare find_condition_info_ entry (pointer, pointer, fixed binary (35)); declare trace_stack_ entry (pointer, fixed binary, fixed binary, character (32) aligned); on any_other call must_kill_process (0, "Error in error handler."); ci.version = 1; call find_condition_info_ (null (), addr (ci), (0)); if ci.condition_name = "cleanup" then return; begin; declare sw character (32) aligned; declare iocbp pointer; declare unique_chars_ entry (bit (*)) returns (character (15)); sw = unique_chars_ (""b); call iox_$attach_name ((sw), iocbp, "vfile_ video_dump_." || rtrim (sw), null (), (0)); call iox_$open (iocbp, Stream_output, ""b, (0)); call trace_stack_ (null (), 1 /* not -bf, but not -lg */, -1 /* all the way back */, sw); call iox_$close (iocbp, (0)); call iox_$detach_iocb (iocbp, (0)); call iox_$destroy_iocb (iocbp, (0)); end; if ci.condition_name = "sub_error_" then do; sub_error_info_ptr = ci.info_ptr; reason = rtrim (reason) || " " || rtrim (sub_error_info.name) || ": " || sub_error_info.info_string; error_code = sub_error_info.status_code; end; else if ci.info_ptr ^= null then do; condition_info_header_ptr = ci.info_ptr; reason = "Unexpected " || ci.condition_name || " occured; " || condition_info_header.info_string || " while " || rtrim (ltrim (reason)); error_code = condition_info_header.status_code; end; go to cleanup_label; end attach_handler; %page; /* This routine extracts all the useful information from the tty_ attachment and builds a structure which we save for later. When video is revoked, this data will be used to restore the user's former state. */ get_tty_state: procedure; dcl mode_idx fixed bin; dcl tty_modes char (512); dcl temp_ptr pointer; dcl (no_input_conversion, no_input_translation, no_output_conversion, no_output_translation) bit (1) aligned; dcl 1 auto_mode_value like mode_value; dcl 1 auto_mode_string_info aligned, 2 version fixed bin, 2 number fixed bin, 2 modes (8) like mode_value; /* must be one greater than common_modes (for pl=>more) */ dcl 1 auto_editing_chars aligned like editing_chars; dcl 1 auto_delay_struc aligned like delay_struc; dcl 1 auto_framing_chars aligned like framing_chars; dcl 1 auto_input_flow_control_info aligned like input_flow_control_info; dcl 1 auto_output_flow_control_info aligned like output_flow_control_info; dcl 1 auto_input_conversion aligned like cv_trans_struc; dcl 1 auto_input_translation aligned like cv_trans_struc; dcl 1 auto_output_conversion aligned like cv_trans_struc; dcl 1 auto_output_translation aligned like cv_trans_struc; dcl 1 auto_get_special_info_struc aligned like get_special_info_struc; /* this structure isn't in any include file */ dcl 1 framing_chars aligned based, 2 frame_begin char (1) unaligned, 2 frame_end char (1) unaligned; dcl get_system_free_area_ entry () returns (ptr); %include tty_editing_chars; %include tty_convert; %include flow_control_info; reason = "Getting modes."; call iox_$modes (target_iocb, "", tty_modes, error_code); if error_code ^= 0 then goto simple_error_return; /* Parse the mode string to set initial values for the video modes that have tty_ equivalents. */ auto_mode_string_info.version = mode_string_info_version_2; auto_mode_string_info.number = 0; mode_value_ptr = addr (auto_mode_value); mode_value.version = mode_value_version_3; do mode_idx = lbound (common_modes, 1) to hbound (common_modes, 1); call mode_string_$get_mode (tty_modes, common_modes (mode_idx), mode_value_ptr, error_code); if error_code = 0 then do; auto_mode_string_info.number = auto_mode_string_info.number + 1; auto_mode_string_info.modes (auto_mode_string_info.number) = mode_value; end; end; /* Special case more mode. If ^pl is set, ^more will be too. */ call mode_string_$get_mode (tty_modes, "pl", mode_value_ptr, error_code); if error_code = 0 then if mode_value.boolean_valuep & ^mode_value.boolean_value then do; mode_value.mode_name = "more"; auto_mode_string_info.number = auto_mode_string_info.number + 1; auto_mode_string_info.modes (auto_mode_string_info.number) = mode_value; end; /* Now build the mode string for later. */ reason = "Building mode string."; call mode_string_$get (addr (auto_mode_string_info), user_io_modes, error_code); if error_code ^= 0 then goto simple_error_return; auto_editing_chars.version = editing_chars_version_3; if network_type ^= MOWSE_NETWORK_TYPE then do; reason = "Getting editing chars."; call iox_$control (target_iocb, "get_editing_chars", addr (auto_editing_chars), error_code); if error_code ^= 0 then goto simple_error_return; if network_type = MCS_NETWORK_TYPE then do; auto_delay_struc.version = DELAY_VERSION; reason = "Getting delays."; call iox_$control (target_iocb, "get_delay", addr (auto_delay_struc), error_code); if error_code ^= 0 then goto simple_error_return; /* set default field to zero for later set_delay call */ auto_delay_struc.default = 0; reason = "Getting framing characters."; call iox_$control (target_iocb, "get_framing_chars", addr (auto_framing_chars), error_code); if error_code ^= 0 then goto simple_error_return; reason = "Getting input flow control characters."; call iox_$control (target_iocb, "get_ifc_info", addr (auto_input_flow_control_info), error_code); if error_code ^= 0 then goto simple_error_return; reason = "Getting output flow control characters."; call iox_$control (target_iocb, "get_ofc_info", addr (auto_output_flow_control_info), error_code); if error_code ^= 0 then goto simple_error_return; end; end; auto_input_conversion.version = CV_TRANS_VERSION; auto_input_translation.version = CV_TRANS_VERSION; auto_output_conversion.version = CV_TRANS_VERSION; auto_output_translation.version = CV_TRANS_VERSION; auto_input_conversion.default = 0; auto_input_translation.default = 0; auto_output_conversion.default = 0; auto_output_translation.default = 0; no_input_conversion = "0"b; no_input_translation = "0"b; no_output_conversion = "0"b; no_output_translation = "0"b; if network_type ^= MOWSE_NETWORK_TYPE then do; reason = "Getting input conversions."; call iox_$control (target_iocb, "get_input_conversion", addr (auto_input_conversion), error_code); if error_code ^= 0 then if error_code = error_table_$no_table then no_input_conversion = "1"b; else goto simple_error_return; reason = "Getting input translations."; call iox_$control (target_iocb, "get_input_translation", addr (auto_input_translation), error_code); if error_code ^= 0 then if error_code = error_table_$no_table then no_input_translation = "1"b; else goto simple_error_return; end; reason = "Getting output conversions."; call iox_$control (target_iocb, "get_output_conversion", addr (auto_output_conversion), error_code); if error_code ^= 0 then if error_code = error_table_$no_table then no_output_conversion = "1"b; else goto simple_error_return; reason = "Getting output translations."; call iox_$control (target_iocb, "get_output_translation", addr (auto_output_translation), error_code); if error_code ^= 0 then if error_code = error_table_$no_table then no_output_translation = "1"b; else goto simple_error_return; reason = "Getting special table."; auto_get_special_info_struc.version = SPECIAL_INFO_STRUCT_VERSION_1; auto_get_special_info_struc.area_ptr = get_system_free_area_ (); call iox_$control (target_iocb, "get_special", addr (auto_get_special_info_struc), error_code); if error_code ^= 0 then goto simple_error_return; /* Now that all state has been read out of tty_, save it. */ allocate complete_tty_state set (complete_tty_state_ptr); complete_tty_state.modes_string = tty_modes; allocate editing_chars set (temp_ptr); temp_ptr -> editing_chars = auto_editing_chars; complete_tty_state.editing_chars_ptr = temp_ptr; if network_type = MCS_NETWORK_TYPE then do; allocate delay_struc set (temp_ptr); temp_ptr -> delay_struc = auto_delay_struc; complete_tty_state.delay_ptr = temp_ptr; allocate framing_chars set (temp_ptr); temp_ptr -> framing_chars = auto_framing_chars; complete_tty_state.framing_chars_ptr = temp_ptr; allocate input_flow_control_info set (temp_ptr); temp_ptr -> input_flow_control_info = auto_input_flow_control_info; complete_tty_state.ifc_ptr = temp_ptr; allocate output_flow_control_info set (temp_ptr); temp_ptr -> output_flow_control_info = auto_output_flow_control_info; complete_tty_state.ofc_ptr = temp_ptr; end; if no_input_conversion then complete_tty_state.input_conversion_ptr = null (); else do; allocate cv_trans_struc set (temp_ptr); temp_ptr -> cv_trans_struc = auto_input_conversion; complete_tty_state.input_conversion_ptr = temp_ptr; end; if no_input_translation then complete_tty_state.input_translation_ptr = null (); else do; allocate cv_trans_struc set (temp_ptr); temp_ptr -> cv_trans_struc = auto_input_translation; complete_tty_state.input_translation_ptr = temp_ptr; end; if no_output_conversion then complete_tty_state.output_conversion_ptr = null (); else do; allocate cv_trans_struc set (temp_ptr); temp_ptr -> cv_trans_struc = auto_output_conversion; complete_tty_state.output_conversion_ptr = temp_ptr; end; if no_output_translation then complete_tty_state.output_translation_ptr = null (); else do; allocate cv_trans_struc set (temp_ptr); temp_ptr -> cv_trans_struc = auto_output_translation; complete_tty_state.output_translation_ptr = temp_ptr; end; /* The special structure was allocated earlier. */ complete_tty_state.special_ptr = auto_get_special_info_struc.table_ptr; return; set_tty_state: entry; /* This entry counts on not getting this far unless video has been invoked by turn_on_login_channel. */ call iox_$modes (target_iocb, complete_tty_state.modes_string, (""), (0)); call iox_$control (target_iocb, "set_editing_chars", complete_tty_state.editing_chars_ptr, (0)); free complete_tty_state.editing_chars_ptr -> editing_chars; if network_type = MCS_NETWORK_TYPE then do; call iox_$control (target_iocb, "set_delay", complete_tty_state.delay_ptr, (0)); free complete_tty_state.delay_ptr -> delay_struc; call iox_$control (target_iocb, "set_framing_chars", complete_tty_state.framing_chars_ptr, (0)); free complete_tty_state.framing_chars_ptr -> framing_chars; call iox_$control (target_iocb, "input_flow_control_chars", complete_tty_state.ifc_ptr, (0)); free complete_tty_state.ifc_ptr -> input_flow_control_info; call iox_$control (target_iocb, "output_flow_control_chars", complete_tty_state.ofc_ptr, (0)); free complete_tty_state.ofc_ptr -> output_flow_control_info; end; if complete_tty_state.input_conversion_ptr ^= null () then do; call iox_$control (target_iocb, "set_input_conversion", complete_tty_state.input_conversion_ptr, (0)); free complete_tty_state.input_conversion_ptr -> cv_trans_struc; end; if complete_tty_state.input_translation_ptr ^= null () then do; call iox_$control (target_iocb, "set_input_translation", complete_tty_state.input_translation_ptr, (0)); free complete_tty_state.input_translation_ptr -> cv_trans_struc; end; if complete_tty_state.output_conversion_ptr ^= null () then do; call iox_$control (target_iocb, "set_output_conversion", complete_tty_state.output_conversion_ptr, (0)); free complete_tty_state.output_conversion_ptr -> cv_trans_struc; end; if complete_tty_state.output_translation_ptr ^= null () then do; call iox_$control (target_iocb, "set_output_translation", complete_tty_state.output_translation_ptr, (0)); free complete_tty_state.output_translation_ptr -> cv_trans_struc; end; call iox_$control (target_iocb, "set_special", complete_tty_state.special_ptr, (0)); free complete_tty_state.special_ptr -> special_chars_struc; free complete_tty_state_ptr -> complete_tty_state; return; end get_tty_state; %page; network_login_channel: entry (targetp, networkp, codep); dcl targetp ptr parm, networkp fixed bin (4) unsigned parm, codep fixed bin (35) parm; dcl Pmowse ptr; targetp = null; networkp = 0; codep = 0; targetp = find_appropriate_iocb ("mowse_io_", "mowse_tty"); /* iocb.name = mowse_i/o */ if targetp ^= null then do; /* determine if its attached on login_channel */ targetp = targetp -> iocb.syn_son; /* syned iocb; iocb.name = user_i/o */ Pmowse = find_appropriate_iocb ("tty_", "-login_channel"); /* iocb.name = mowse_tty */ if Pmowse ^= null then do; networkp = MOWSE_NETWORK_TYPE; return; end; end; targetp = find_appropriate_iocb ("tty_", "-login_channel"); if targetp = null () then do; codep = error_table_$action_not_performed; reason = "No tty_ attachment found."; return; end; call iox_$control (targetp, "get_network_type", addr (networkp), codep); if codep = error_table_$undefined_order_request then do; networkp = MCS_NETWORK_TYPE; /* MCS doesn't support this operation */ codep = 0; end; else if codep = 0 then do; if networkp ^= MCS_NETWORK_TYPE & networkp ^= DSA_NETWORK_TYPE & networkp ^= MOWSE_NETWORK_TYPE then do; codep = error_table_$action_not_performed; reason = "Invalid network type."; return; end; end; else do; reason = "Unable to get network type."; return; end; return; %page; find_appropriate_iocb: procedure (dim_name, dim_arg) returns (pointer); %include iocb; declare dim_name char (*) parameter, dim_arg char (*) parameter, iocb_ptr pointer, n fixed binary, based_vcs char (256) varying based, descrip char (256) varying, dim_lth fixed bin, error fixed bin (35); dim_lth = length (dim_name) + 1; error = 0; do n = 1 by 1 while (error = 0); call iox_$find_iocb_n (n, iocb_ptr, error); if error = 0 then do; if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do; descrip = iocb_ptr -> iocb.attach_descrip_ptr -> based_vcs; if substr (descrip, 1, min (length (descrip), dim_lth)) = dim_name & index (descrip, dim_arg) ^= 0 then return (iocb_ptr); end; end; end; return (null ()); end find_appropriate_iocb; %page; %include iocbx; %page; %include tty_attach_data_; %page; %include net_event_message; %page; %include iox_entries; %page; %include iox_modes; %page; %include window_dcls; %page; %include mode_string_info; %page; %include tty_editing_chars; %page; %include mowse_io_control_info; %page; %include mowse_messages; %page; %include mowse; end video_utils_;  window_.pl1 08/13/87 1333.0rew 08/13/87 1323.5 290457 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1986 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(81-01-01,Margulies), approve(), audit(), install(): These are the journalization comments from window_io_video_, which is now incorporated in this module. video operations for window_io_ asyncronous event management in this program is different from that in terminal control. In terminal control, the program can detect something happening during a block, and then give up on what it was going to write and recompute based on the state after the async occurence. Here, terminal controlwill do what we call it to do, unless a nonlocal goto is used to unwind the terminal control operation. This is a trifle dangerous, as the calls to terminal control are nonatomic ... they may consist of several distinct terminal operations. NB: OP_WRITE_SYNC_GET_CHARS_NO_ECHO is obsolete. In the current terminal control implementation, it is equivalent to a WRITE, followed by a SYNC, followed by a GET. The window operation, and for that matter the tc operation, may become meaningful again in a later implementation, and there was not time to gut the callers. Modified 21 January 1982 by Chris Jones to re-enable quits after reconnection Modified 16 August 1982 by William M. York to fix W_GET_ECHOED_CHARS so it doesn't try to update the cursor position after an async event occurs in the current window. Since the cursor has moved somewhere else, this caused the cursor state to become invalid. Modified 16 September 1982 by WMY to fix W_GET_ECHOED_CHARS to handle the case where tc_ returned because of async interruption and the input buffer happened to be full. This bug caused looping and process death. Modified 21 September 1982 by WMY fix a bug in W_SYNC which passed the wrong structure down to tc_. Modified 29 October 1982 by WMY to update the attach_data.col after a successful OP_WRITE_SYNC_GET_CHARS_NO_ECHO to include the prompt. 2) change(81-01-01,WMY), approve(), audit(), install(): Set status on raw output calls, but ignore that status when the next raw output call comes in. Modified 1 October 1983 by Jon A. Rochlis to add support for partial screen width windows. Modified 30 September 1983 by Jon A. Rochlis to add support for partial screen width windows to create_window. Modified 9 October 1983 by JR to map error_table_$undefined_order_request into video_et_$wsys_not_invoked. Modified 9 October 1983 by Jon A. Rochlis to add first cut at window_$edit_line. Modifed December 1983 - February 1984 by Bill Gimbel and JR to move window_io_video_ to this module. Modified 27 December 1984 by JR to only update attach_data state if calls to tc_ were successful. This prevent inconsistent states which could hang a process. Modified 7 February 1985 by JR to store the current ips mask in tc's request structure so tc_block can restore it before going blocked. user interface to extended video operations 3) change(87-02-13,LJAdams), approve(87-03-19,MCR7642), audit(87-04-24,Gilcrease), install(87-05-14,MR12.1-1030): The entry points insert_text and overwrite_text are calling require_cursor_valid after masking IPS signals. If the cursor position is invalid because the write_raw_text entry was previously called, the require_cursor_valid procedure will exit window_ leaving the signals masked. (phx20711). END HISTORY COMMENTS */ /* format: style2,linecom,^indnoniterdo,indcomtxt,^inditerdo,dclind5,idind25 */ window_: procedure; return; declare 1 simple_r aligned like request_header; declare real_window_iocb_ptr pointer; declare target_iocbp pointer; declare this_request_ptr pointer; declare this_is_an_input_request bit (1) aligned; declare saved_ips_mask bit (36) aligned; declare cleanup condition; declare ( hcs_$set_ips_mask, hcs_$reset_ips_mask ) entry (bit (36) aligned, bit (36) aligned); declare ( video_et_$window_status_pending, video_et_$bad_window_id, video_et_$cursor_position_undefined, video_et_$string_not_printable ) external static fixed bin (35); declare ( Iocb_ptr pointer, Distance fixed bin, Line fixed bin, Col fixed bin, N_lines fixed bin, N_cols fixed bin, Count fixed bin, N_to_get fixed bin (21), Text character (*), Prompt character (*), Text_got fixed bin (21), Break character (1) varying, Code fixed bin (35) ) parameter; declare (addcharno, addr, character, clock, currentsize, length, ltrim, max, null, rtrim, string, substr, unspec, verify) builtin; position_cursor: entry (Iocb_ptr, Line, Col, Code); dcl (line, col) fixed bin; call get_attach_data_ptr; line = Line; col = Col; pc_common: on cleanup call clean_things_up (); call setup_request (addr (simple_r), OP_POSITION_CURSOR, line, col); call do_request (addr (simple_r)); if Code = 0 then do; /* only update state, if the operation worked */ attach_data.line = line; attach_data.col = col; attach_data.cursor_valid = "1"b; end; go to done; position_cursor_rel: entry (Iocb_ptr, Line, Col, Code); call get_attach_data_ptr; call require_cursor_valid; line = Line + attach_data.line; col = Col + attach_data.col; goto pc_common; change_column: entry (Iocb_ptr, Col, Code); call get_attach_data_ptr; call require_cursor_valid; line = attach_data.line; col = Col; go to pc_common; change_line: entry (Iocb_ptr, Line, Code); call get_attach_data_ptr; call require_cursor_valid; col = attach_data.col; line = Line; go to pc_common; declare 1 rqr aligned like request_clear_region; clear_window: entry (Iocb_ptr, Code); clear_window_label: call get_attach_data_ptr; on cleanup call clean_things_up (); call setup_request (addr (rqr), OP_CLEAR_REGION, 1, 1); rqr.rows = attach_data.current.rows; rqr.columns = attach_data.current.columns; call do_request (addr (rqr)); if Code = 0 then do; attach_data.line, attach_data.col = 1; attach_data.cursor_valid = "1"b; /* This is an awful modularity violation since this variable should only be touched by window_io_iox_. However, until there are more control orders for window operations, we are stuck with it. */ attach_data.lines_written_since_read = 0; end; go to done; clear_to_end_of_window: entry (Iocb_ptr, Code); call get_attach_data_ptr; call require_cursor_valid; if attach_data.col = 1 /* Are we at */ & attach_data.line = 1 /* The Origin? */ then go to clear_window_label; /* Much Easier */ on cleanup call clean_things_up (); call setup_request (addr (rqr), OP_CLEAR_REGION, attach_data.line, attach_data.col); /* first approx */ if attach_data.col > 1 then do; rqr.rows = 1; rqr.columns = attach_data.current.columns - attach_data.col + 1; call do_request (addr (rqr)); /* clear off current line */ if rqr.row < attach_data.current.rows then do; /* now do full-width part */ rqr.columns = attach_data.current.columns; rqr.row = rqr.row + 1; rqr.rows = attach_data.current.rows - attach_data.line; /* + 1 canceled by the row we already got */ rqr.col = 1; if rqr.rows > 1 then call do_request (addr (rqr)); end; end; else do; /* start at col 1 */ rqr.columns = attach_data.current.columns; rqr.rows = attach_data.current.rows - attach_data.line + 1; if rqr.rows ^< 1 then call do_request (addr (rqr)); end; if attach_data.col > 1 /* we had to clear end of line */ then do; call clean_things_up (); call setup_request (addr (simple_r), OP_POSITION_CURSOR, attach_data.line, attach_data.col); call do_request (addr (simple_r)); end; /* do */ go to done; clear_to_end_of_line: entry (Iocb_ptr, Code); call get_attach_data_ptr; call require_cursor_valid; on cleanup call clean_things_up (); call setup_request (addr (rqr), OP_CLEAR_REGION, attach_data.line, attach_data.col); rqr.rows = 1; rqr.columns = attach_data.current.columns - attach_data.col + 1; call do_request (addr (rqr)); go to done; clear_region: entry (Iocb_ptr, Line, Col, N_lines, N_cols, Code); call get_attach_data_ptr; on cleanup call clean_things_up (); call setup_request (addr (rqr), OP_CLEAR_REGION, Line, Col); rqr.extent.rows = N_lines; rqr.extent.columns = N_cols; call do_request (addr (rqr)); if Code = 0 then do; attach_data.col = Col; attach_data.line = Line; attach_data.cursor_valid = "1"b; end; go to done; declare 1 rqt aligned like request_text; insert_text: entry (Iocb_ptr, Text, Code); call get_attach_data_ptr; call require_cursor_valid; on cleanup call clean_things_up (); call setup_request (addr (rqt), OP_INSERT_TEXT, attach_data.line, attach_data.col); go to tx_common; overwrite_text: entry (Iocb_ptr, Text, Code); call get_attach_data_ptr; call require_cursor_valid; on cleanup call clean_things_up (); call setup_request (addr (rqt), OP_OVERWRITE_TEXT, attach_data.line, attach_data.col); tx_common: call validate_text (Text); rqt.text_ptr = addr (Text); rqt.text_length = length (Text); call do_request (addr (rqt)); if Code = 0 then attach_data.col = attach_data.col + rqt.text_length; go to done; write_raw_text: entry (Iocb_ptr, Text, Code); call get_attach_data_ptr; if attach_data.status_pending & ^attach_data.ignore_status then if unspec (attach_data.status) ^= unspec (W_STATUS_SCREEN_INVALID) then do; Code = video_et_$window_status_pending; goto error_return; end; on cleanup call clean_things_up (); call setup_request (addr (rqt), OP_WRITE_RAW, attach_data.line, attach_data.col); if ^attach_data.cursor_valid then do; rqt.row = attach_data.line_origin; /* as good a place as any */ rqt.col = 1; end; rqt.text_ptr = addr (Text); rqt.text_length = length (Text); call do_request (addr (rqt)); if Code = 0 then do; attach_data.cursor_valid = "0"b; attach_data.status.screen_invalid = "1"b; attach_data.status_pending = "1"b; end; go to done; delete_chars: entry (Iocb_ptr, Count, Code); call get_attach_data_ptr; declare 1 rqd aligned like request_delete_chars; call require_cursor_valid; on cleanup call clean_things_up (); call setup_request (addr (rqd), OP_DELETE_CHARS, attach_data.line, attach_data.col); rqd.count = Count; call do_request (addr (rqd)); go to done; get_cursor_position: entry (Iocb_ptr, Line, Col, Code); call get_attach_data_ptr; call require_cursor_valid; Line = attach_data.line; Col = attach_data.col; return; bell: entry (Iocb_ptr, Code); call get_attach_data_ptr; call require_cursor_valid; on cleanup call clean_things_up (); call setup_request (addr (simple_r), OP_BELL, attach_data.line, attach_data.col); call do_request (addr (simple_r)); go to done; declare 1 rqg aligned like request_read; declare rqg_text character (rqg.buffer_length) based (rqg.buffer_ptr); get_unechoed_chars: entry (Iocb_ptr, N_to_get, Text, Text_got, Break, Code); call get_attach_data_ptr; on cleanup call clean_things_up (); call setup_request (addr (rqg), OP_GET_CHARS_NO_ECHO, attach_data.line, attach_data.col); /* we don't check the cursor position for unechoed input */ rqg.prompt_ptr = null (); go to get_common; get_echoed_chars: entry (Iocb_ptr, N_to_get, Text, Text_got, Break, Code); call get_attach_data_ptr; call require_cursor_valid; on cleanup call clean_things_up (); call setup_request (addr (rqg), OP_GET_CHARS_ECHO, attach_data.line, attach_data.col); rqg.prompt_ptr = null (); get_common: Break = ""; rqg.buffer_ptr = addr (Text); rqg.buffer_length = N_to_get; rqg.breaks = attach_data.breaks; Text_got = 0; get_some_more: rqg.returned_break_flag = "0"b; rqg.returned_length = 0; rqg.col = attach_data.col + attach_data.column_origin - 1; call do_request (addr (rqg)); Text_got = Text_got + rqg.returned_length; /* This gets complicated. If something asynchronous has happened in this window, we don't really know where the cursor is, and we certainly shouldn't set the cursor position to our now invalid idea of where it is. If it happened in some other window, update the cursor state and get some more chars. */ if rqg.async_interruption /* ASSERT cannot be on if returned_break_flag is on */ then do; /* something went BONG */ if rqg.this_window then do; attach_data.status.async_change = "1"b; attach_data.status_pending = "1"b; /* If we got something, return it and q status for next call. if we got nothing, might as well return the status this call. but never return status AND characters. */ if Text_got = 0 then Code = video_et_$window_status_pending; go to done; end; else do; /* Some Other Window */ rqg.buffer_ptr = addcharno (rqg.buffer_ptr, rqg.returned_length); rqg.buffer_length = rqg.buffer_length - rqg.returned_length; /* update the cursor state so far */ if rqg.operation = OP_GET_CHARS_ECHO then attach_data.col = attach_data.col + rqg.returned_length; if rqg.operation = OP_WRITE_SYNC_GET_CHARS_NO_ECHO then do; /* don't reprint prompt, just read response */ rqg.operation = OP_GET_CHARS_NO_ECHO; attach_data.col = rqg.col + rqg.prompt_length; end; /* At this point we know that tc_ level returned because something asynchronous happened in another window. If the user was in the phantom column at the time, the call to tc_ returned enough characters to fill our caller's buffer, so return. */ if rqg.returned_length = rqg.buffer_length then goto done; else goto get_some_more; end; end; /* The async term case */ /* no async, so update the cursor position */ if rqg.operation = OP_GET_CHARS_ECHO then do; attach_data.col = attach_data.col + rqg.returned_length; if rqg.returned_break_flag & (rqg.returned_length > 0) then attach_data.col = attach_data.col - 1; /* The last one isn't really there */ end; else if rqg.operation = OP_WRITE_SYNC_GET_CHARS_NO_ECHO then attach_data.col = rqg.col + rqg.prompt_length; if rqg.returned_break_flag & rqg.returned_length > 0 then do; Text_got = Text_got - 1; Break = substr (rqg_text, rqg.returned_length, 1); end; go to done; get_one_unechoed_char: get_one_unechoed: entry (Iocb_ptr, One, Block_flag, Code); declare One character (1) varying; declare one_char character (1); declare Block_flag bit (1) aligned; call get_attach_data_ptr; call require_cursor_valid; on cleanup call clean_things_up (); call setup_request (addr (rqg), OP_READ_ONE, attach_data.line, attach_data.col); rqg.buffer_ptr = addr (one_char); rqg.buffer_length = 1; one_some_more: /* returned_break_flag is the block flag on input, and the break_flag on output */ rqg.returned_break_flag = Block_flag; call do_request (addr (rqg)); /* Several things could have happened in the call to tc_. 1) called in with block flag off, no asyncronosity possible cause we didn't block regardless of what we got back. 2) called in with block flag, nothing async happens while blocked, got char. 3) called in with block flag, async event happend, no char back. */ if rqg.async_interruption then if rqg.this_window then do; attach_data.status.async_change = "1"b; attach_data.status_pending = "1"b; Code = video_et_$window_status_pending; go to done; end; else goto one_some_more; if ^Block_flag & ^rqg.returned_break_flag then One = ""; else One = one_char; go to done; write_sync_read: entry (Iocb_ptr, Prompt, N_to_get, Text, Text_got, Break, Code); call get_attach_data_ptr; call require_cursor_valid; on cleanup call clean_things_up (); call setup_request (addr (rqg), OP_WRITE_SYNC_GET_CHARS_NO_ECHO, attach_data.line, attach_data.col); rqg.prompt_ptr = addr (Prompt); rqg.prompt_length = length (Prompt); goto get_common; sync: entry (Iocb_ptr, Code); call get_attach_data_ptr; on cleanup call clean_things_up (); call setup_request (addr (rqg), OP_GET_CHARS_NO_ECHO, attach_data.line, attach_data.col); rqg.buffer_length = 0; call do_request (addr (rqg)); /* lengths are 0 */ go to done; /* This is somewhat of a kludge, but is a first cut at allowing the video system line editor to be called from a window_ context, rather than an iox_ context. It is very un-window_ like, since we don't make a control order for tc_io_, but instead call window_io_iox_ directly. When the editor moves out of window_io_iox_ and window_io_ is taught about this then it can be changed. All we are at the moment is a blown up transfer vector! */ edit_line: entry (Iocb_ptr, Window_edit_line_info_ptr, Buffer_ptr, Buffer_len, N_read, Code); declare Window_edit_line_info_ptr pointer parameter; declare Buffer_ptr pointer parameter; declare Buffer_len fixed binary (21) parameter; declare N_read fixed binary (21) parameter; declare window_io_iox_$edit_line entry (ptr, ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); call get_attach_data_ptr; call require_cursor_valid; call window_io_iox_$edit_line (real_window_iocb_ptr /* set by get_attach_data_ptr */, Window_edit_line_info_ptr, Buffer_ptr, Buffer_len, N_read, Code); return; scroll_region: entry (Iocb_ptr, Line, N_lines, Distance, Code); declare 1 rsr aligned like request_scroll_region; call get_attach_data_ptr; call require_cursor_valid; on cleanup call clean_things_up (); call setup_request (addr (rsr), OP_SCROLL_REGION, 1, 1); /* The coords are not interesting */ rsr.n_lines = N_lines; rsr.distance = Distance; rsr.start_line = Line + attach_data.line_origin - 1; call do_request (addr (rsr)); go to done; /* Create and Destroy utilities -- the beginnings of the window side of desk management. */ declare window_list_ptr pointer; declare 1 window_list aligned based (window_list_ptr), 2 sentinel character (4) aligned, 2 n_windows fixed bin, 2 window_names (wl_n_windows refer (window_list.n_windows)) character (32) unaligned; declare wl_n_windows fixed bin; declare (i, j) fixed bin; declare code fixed bin (35); declare value_$get_data entry (pointer, bit (36) aligned, character (*), pointer, pointer, fixed binary (18), fixed binary (35)); declare value_$set_data entry (pointer, bit (36) aligned, character (*), pointer, fixed binary (18), pointer, pointer, fixed binary (18), fixed binary (35)); declare ( error_table_$null_info_ptr, error_table_$unimplemented_version ) fixed bin (35) ext static; declare video_et_$switch_not_window fixed bin (35) external static; get_window_list: procedure (terminal_name); declare terminal_name character (*); declare value_name character (45) /* 32 + 13 */; declare no_create bit (1) aligned; declare WINDOW_LIST_VALUE_NAME_SUFFIX character (12) init ("window_list_") internal static options (constant); no_create = "0"b; go to common; get_window_list$$no_create: entry (terminal_name); no_create = "1"b; common: window_list_ptr = null (); value_name = rtrim (terminal_name) || WINDOW_LIST_VALUE_NAME_SUFFIX; call value_$get_data (null (), "10"b /* perprocess */, value_name, get_system_free_area_ (), window_list_ptr, (0), code); if window_list_ptr = null () then do; if no_create then return; wl_n_windows = 1; allocate window_list set (window_list_ptr); window_list.sentinel = "WNDL"; window_list.n_windows = 0; /* careful here, to avoid pl1 illegalities */ end; return; store_window_list: entry (terminal_name); declare size_of_window_list fixed bin (18); value_name = rtrim (terminal_name) || WINDOW_LIST_VALUE_NAME_SUFFIX; if window_list_ptr ^= null () then size_of_window_list = currentsize (window_list); else size_of_window_list = 0; call value_$set_data (null (), "10"b /* perprocess */, value_name, window_list_ptr, size_of_window_list, null (), null (), (0), (0)); /* we ignore the code */ if window_list_ptr ^= null () then free window_list; return; end; create: create_window: entry (Terminal_iocb_ptr, Window_info_ptr, Window_iocb_ptr, Code); declare Terminal_iocb_ptr pointer parameter; declare terminal_iocb_ptr pointer; declare Window_iocb_ptr pointer parameter; declare Window_info_ptr pointer parameter; terminal_iocb_ptr = Terminal_iocb_ptr; window_position_info_ptr = Window_info_ptr; Code = 0; if window_position_info_ptr = null () | Window_iocb_ptr = null () | Terminal_iocb_ptr = null () then do; Code = error_table_$null_info_ptr; return; end; if window_position_info.version ^= window_position_info_version then do; Code = error_table_$unimplemented_version; return; end; begin; declare atd character (128); atd = "window_io_ " || iocb_name (terminal_iocb_ptr) || " -first_line " || ltrim (rtrim (character (window_position_info.origin.line))); if window_position_info.height > 0 then atd = rtrim (atd) || " -n_lines " || ltrim (rtrim (character (window_position_info.height))); if window_position_info.origin.column > 0 then atd = rtrim (atd) || " -first_column " || ltrim (rtrim (character (window_position_info.origin.column))); if window_position_info.width > 0 then atd = rtrim (atd) || " -n_columns " || ltrim (rtrim (character (window_position_info.width))); call iox_$attach_ptr (Window_iocb_ptr, atd, null (), Code); if Code ^= 0 then return; end; call iox_$open (Window_iocb_ptr, Stream_input_output, ""b, Code); if Code ^= 0 then do; call iox_$detach_iocb (Window_iocb_ptr, (0)); return; end; call get_window_list$$no_create (iocb_name (terminal_iocb_ptr)); begin; declare new_window_list_ptr pointer; if window_list_ptr = null () then wl_n_windows = 1; else wl_n_windows = window_list.n_windows + 1; allocate window_list set (new_window_list_ptr); new_window_list_ptr -> window_list.sentinel = "WNDL"; if window_list_ptr ^= null () then do; do i = 1 to window_list.n_windows; new_window_list_ptr -> window_list.window_names (i) = window_list.window_names (i); end; free window_list; end; else i = 1; window_list_ptr = new_window_list_ptr; window_list.window_names (i) = iocb_name (Window_iocb_ptr); end; /* the begin block */ call store_window_list (iocb_name (terminal_iocb_ptr)); return; destroy: destroy_window: entry (Window_iocb_ptr, Code); call iox_$control (Window_iocb_ptr, "get_terminal_iocb_ptr", terminal_iocb_ptr, Code); if Code ^= 0 then return; call get_window_list (iocb_name (terminal_iocb_ptr)); do i = 1 to window_list.n_windows; if window_list.window_names (i) = iocb_name (Window_iocb_ptr) then do; if i < window_list.n_windows then do j = i + 1 to window_list.n_windows; window_list.window_names (j - 1) = window_list.window_names (j); end; go to SUCCESS; end; end; Code = video_et_$switch_not_window; return; SUCCESS: call iox_$close (Window_iocb_ptr, (0)); call iox_$detach_iocb (Window_iocb_ptr, (0)); begin; declare new_window_list_ptr pointer; wl_n_windows = window_list.n_windows - 1; if wl_n_windows = 0 then free window_list; else do; allocate window_list set (new_window_list_ptr); do i = 1 to wl_n_windows; new_window_list_ptr -> window_list.window_names (i) = window_list.window_names (i); end; free window_list; window_list_ptr = new_window_list_ptr; end; end; /* the begin */ call store_window_list (iocb_name (terminal_iocb_ptr)); return; destroy_all: destroy_all_windows: entry (Terminal_iocb_ptr); /* No code interesting */ declare iocb_ptr pointer; terminal_iocb_ptr = Terminal_iocb_ptr; call get_window_list$$no_create (iocb_name (terminal_iocb_ptr)); if window_list_ptr = null then return; do i = 1 to window_list.n_windows; iocb_ptr = find_iocb (window_list.window_names (i)); call iox_$close (iocb_ptr, (0)); call iox_$detach_iocb (iocb_ptr, (0)); end; free window_list; call store_window_list (iocb_name (terminal_iocb_ptr)); return; iocb_name: procedure (iocb_ptr) returns (character (32)) reducible; declare iocb_ptr pointer; return (iocb_ptr -> iocb.name); end iocb_name; find_iocb: procedure (iocb_name) returns (pointer); declare iocb_ptr pointer; declare iocb_name character (*); call iox_$find_iocb (iocb_name, iocb_ptr, (0)); return (iocb_ptr); end find_iocb; %page; setup_request: procedure (r_header_ptr, op, l, c); declare r_header_ptr pointer; declare (op, l, c) fixed bin; this_request_ptr, request_ptr = r_header_ptr; attach_data.async_count = attach_data.async_count + 1; call hcs_$set_ips_mask (""b, saved_ips_mask); request_header.saved_ips_mask = saved_ips_mask; /* If there is status pending for this window, return a code. Raw output handles its own status below. */ if (op ^= OP_WRITE_RAW) & attach_data.status_pending & ^attach_data.ignore_status then do; Code = video_et_$window_status_pending; go to done; end; this_is_an_input_request = (op = OP_GET_CHARS_ECHO | op = OP_GET_CHARS_NO_ECHO | op = OP_WRITE_SYNC_GET_CHARS_NO_ECHO | op = OP_READ_ONE); request_header.sentinel = REQUEST_SENTINEL; request_header.window_id = attach_data.window_id; request_header.request_id = clock (); request_header.operation = op; request_header.row = l + attach_data.line_origin - 1; request_header.col = c + attach_data.column_origin - 1; string (request_header.flags) = ""b; end setup_request; do_request: procedure (request_ptr); declare request_ptr pointer; target_iocbp = attach_data.target_iocb_ptr; /* terminal control will unmask if it blocks. */ /* we must just note if it signals */ /* the condition handler is elsewhere established to keep this block quick */ /* but this is the right place for the handler to destect ips mask changes which happen while down in tc. Sigh, I wonder if the cost is worth it -- JR 2/10/85 */ on cleanup begin; if request_header.saved_ips_mask ^= saved_ips_mask then saved_ips_mask = request_header.saved_ips_mask; end; call iox_$control (target_iocbp, "window_operation", request_ptr, Code); if Code = video_et_$bad_window_id then begin; /* reconnection, get us a new id if we can */ declare 1 auto_desk_info aligned like tc_desk_window_info; auto_desk_info.window_id = attach_data.window_id; auto_desk_info.first_row = attach_data.line_origin; auto_desk_info.n_rows = attach_data.current.rows; auto_desk_info.first_column = attach_data.column_origin; auto_desk_info.n_columns = attach_data.current.columns; auto_desk_info.window_iocb_ptr = real_window_iocb_ptr; call iox_$control (target_iocbp, "check_out_window", addr (auto_desk_info), (0)); /* JustinCase */ call iox_$control (target_iocbp, "check_in_window", addr (auto_desk_info), Code); if Code ^= 0 then go to terminal_control_died; attach_data.window_id = auto_desk_info.window_id; attach_data.status_pending = "1"b; attach_data.status.screen_invalid = "1"b; call iox_$control (target_iocbp, "quit_enable", null (), (0)); Code = video_et_$window_status_pending; go to done; end; if ^this_is_an_input_request & request_ptr -> request_header.async_interruption & request_ptr -> request_header.this_window then go to ASYNC_EVENT; end do_request; clean_things_up: procedure; attach_data.async_count = max (0, attach_data.async_count - 1); if saved_ips_mask ^= ""b then call hcs_$reset_ips_mask (saved_ips_mask, (""b)); saved_ips_mask = ""b; return; end clean_things_up; /* IMPORTANT: This routine must be invoked before we mask and hack the async counter because it branches to "error_return", not "done" */ require_cursor_valid: procedure; if ^attach_data.cursor_valid then do; Code = video_et_$cursor_position_undefined; go to error_return; end; end require_cursor_valid; /* IMPORTANT: This routine must be invoked before we mask and hack the async counter because it branches to "error_return", not "done" */ get_attach_data_ptr: procedure; dcl error_table_$undefined_order_request fixed bin (35) ext static; dcl video_et_$wsys_not_invoked fixed bin (35) ext static; Code = 0; real_window_iocb_ptr = null (); saved_ips_mask = ""b; call iox_$control (Iocb_ptr, "get_window_iocb_ptr", real_window_iocb_ptr, Code); if Code = error_table_$undefined_order_request | real_window_iocb_ptr = null () /* discard_ will return a zero error code! */ then Code = video_et_$wsys_not_invoked; /* much better */ if Code ^= 0 then goto error_return; attach_data_ptr = real_window_iocb_ptr -> iocb.attach_data_ptr; return; end get_attach_data_ptr; terminal_control_died: /* insert debugging code here */ go to done; /* Only branch here if we haven't masked. This is needed because we might not even have a valid iocb at this point, so we can't muck with attach data! */ error_return: return; done: revert cleanup; /* At least keep things from getting more confused */ call clean_things_up (); return; ASYNC_EVENT: on cleanup call clean_things_up; call setup_request (addr (simple_r), OP_GET_CURSOR_POSITION, (0), (0)); call do_request (addr (simple_r)); if simple_r.row ^< attach_data.line_origin /* after the top */ & simple_r.row ^> (attach_data.line_origin + attach_data.current.rows - 1) /* and before the bottom */ then do; /* if the cursor landed in this window */ attach_data.line = simple_r.row; /* note where */ attach_data.col = simple_r.col; end; attach_data.status_pending = "1"b; attach_data.status.async_change = "1"b; Code = video_et_$window_status_pending; go to done; validate_text: procedure (text); declare text character (*); declare printable character (96) init ( " ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890!@#$%^&*()-_=+`~\|{}'"";:/?.>,<[]!" ) internal static options (constant); if verify (text, printable) > 0 then do; Code = video_et_$string_not_printable; go to done; end; end validate_text; %include tc_desk_info_; %page; %include iox_dcls; %page; %include iox_modes; %page; %include iocb; %page; %include window_control_info; %page; %include window_io_attach_data_; %page; %include tc_operations_; end window_;  window_call.pl1 08/13/87 1333.0rew 08/13/87 1323.4 201807 /****^ ****************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* Command interface for video */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ /* Benson I. Margulies, too late in the summer of 1981 */ /* Modified by Chris Jones, 29 October 1981, to handle "undocumented" keys and control args. */ /* Modified by Jon A. Rochlis, 14 June 1983, to add supported_terminal and video_invoked keywords. */ /* Modified by JR, 1 October 1983, to add support for partial screen width windows. */ /* Modified by JR, 28 June 1984, to add get_window_width, since I forgot about it in October. */ /* Modified by C. Marker 6 September 1984, to add -line_speed. */ wdc: window_call: procedure options (variable); declare cu_$arg_list_ptr entry returns (ptr); declare arg_list_ptr pointer; arg_list_ptr = cu_$arg_list_ptr (); begin; /* to allow some useful declarations */ declare 1 irep (window_call_data_$n_ctl_args) aligned, 2 allowed bit (1) aligned, 2 required bit (1) aligned, 2 found bit (1) aligned, 2 argument fixed bin, 2 arg aligned, /* if there was a following key */ 3 value fixed bin, 3 ptr pointer unaligned, 3 length fixed bin (21); declare key character (32); declare keyx fixed bin (21); declare 1 this_f aligned like function based (this_f_ptr); declare this_f_ptr pointer; declare argument_ptr pointer; declare argument_length fixed bin (21); declare argument character (argument_length) based (argument_ptr); declare rs_ptr pointer; declare rs_length fixed bin (21); declare return_string character (rs_length) varying based (rs_ptr); declare save_argument character (32); declare this_is_an_af bit (1) aligned; declare error_reporter entry options (variable) variable; declare n_arguments fixed bin; declare iocb_ptr pointer; declare code fixed bin (35); declare (ctlx, argx) fixed bin; declare ME character (32) init ("window_call") internal static options (constant); declare com_err_ entry () options (variable); declare active_fnc_err_ entry () options (variable); declare requote_string_ entry (character (*)) returns (character (*)); declare cu_$af_return_arg_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); declare cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); declare cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); declare ioa_ entry () options (variable); declare video_utils_$turn_on_login_channel entry (fixed binary (35), character (*)); declare video_utils_$turn_off_login_channel entry (fixed binary (35)); declare ( error_table_$nodescr, error_table_$not_act_fnc, error_table_$noarg, error_table_$bad_arg, error_table_$badopt, error_table_$active_function, error_table_$bad_conversion, video_et_$wsys_invoked, video_et_$wsys_not_invoked ) ext static fixed bin (35); declare video_data_$terminal_iocb pointer external; declare (addr, character, length, ltrim, null, substr, translate) builtin; %page; %include window_dcls; %include window_control_info; %include iox_dcls; %include iox_modes; %page; /* Someday ... */ call cu_$af_return_arg_rel (n_arguments, rs_ptr, rs_length, code, arg_list_ptr); if n_arguments = 0 | code = error_table_$nodescr then do; /* was called as AF, no args */ if code = 0 then call active_fnc_err_ (0, ME, "Usage: window_call call KEY ARGUMENTS."); else call com_err_ (0, ME, "Usage: window_call KEY ARGUMENTS."); go to RETURN; end; if code = error_table_$not_act_fnc then do; this_is_an_af = "0"b; error_reporter = com_err_; end; else do; /* Code MUST be 0, by contract */ this_is_an_af = "1"b; error_reporter = active_fnc_err_; end; wcd_functions_ptr = addr (window_call_data_$functions); wcd_names_ptr = addr (window_call_data_$names); wcd_string_ptr = addr (window_call_data_$string); wcd_ctl_args_ptr = addr (window_call_data_$ctl_args); call cu_$arg_ptr_rel (1, argument_ptr, argument_length, (0), arg_list_ptr); if character (argument, 1) = "-" then do; call error_reporter (error_table_$noarg, ME, "The function keyword must be the first argument."); go to RETURN; end; do keyx = 1 to window_call_data_$n_keys while (argument ^= ""); if argument = window_call_data_names (keyx).long | argument = window_call_data_names (keyx).short | argument = window_call_data_names (keyx).undocumented_long | argument = window_call_data_names (keyx).undocumented_short then go to HAVE_KEYX; end; call ERROR_REPORTER (error_table_$badopt, ME, "Unrecognized key ""^a"".", argument); go to RETURN; HAVE_KEYX: key = window_call_data_names (keyx).long; this_f_ptr = addr (window_call_data_functions (keyx)); if this_is_an_af & ^this_f.af_allowed then do; call active_fnc_err_ (error_table_$active_function, ME); go to RETURN; end; /* Now we are ready to parse for this_f */ irep.found (*) = "0"b; irep.arg (*).ptr = null; irep.arg (*).length = 0; irep = this_f.args, by name; /* pick up flags */ irep = window_call_data_ctl_args, by name; main_argument_loop: do argx = 2 to n_arguments; call cu_$arg_ptr_rel (argx, argument_ptr, argument_length, (0), arg_list_ptr); /* first see if its a control argument. It has to be, we have no positionals */ if character (argument, 1) ^= "-" | length (argument) < 2 then do; call ERROR_REPORTER (error_table_$badopt, ME, "The argument ^a is out of place.", argument); go to RETURN; end; /* Now, is it a control argument we (1) recognize at all, and (2) allow for this key? */ do ctlx = 1 to window_call_data_$n_ctl_args; if (substr (argument, 2) = window_call_data_ctl_args (ctlx).name.long | substr (argument, 2) = window_call_data_ctl_args (ctlx).name.undocumented_long | substr (argument, 2) = window_call_data_ctl_args (ctlx).name.short | substr (argument, 2) = window_call_data_ctl_args (ctlx).name.undocumented_short) & irep (ctlx).allowed then go to HAVE_CTLX; end; /* Unrecognized */ call ERROR_REPORTER (error_table_$badopt, ME, "^a.", argument); go to RETURN; HAVE_CTLX: irep (ctlx).found = "1"b; if irep (ctlx).argument ^= A_NONE then do; /* trailing parameter dept */ argx = argx + 1; save_argument = argument; if argx > n_arguments then do; NOARG: call ERROR_REPORTER (error_table_$noarg, ME, "Control argument ^a requires a ^[^s^;numeric^;string^] parameter.", save_argument, irep (ctlx).argument); go to RETURN; end; call cu_$arg_ptr_rel (argx, argument_ptr, argument_length, (0), arg_list_ptr); if irep (ctlx).argument = A_NUMBER then do; irep (ctlx).value = cv_dec_check_ (argument, code); if code ^= 0 then do; if character (argument, 1) = "-" then go to NOARG; if code <= length (argument) then call ERROR_REPORTER (error_table_$bad_conversion, ME, "Converting ^a to an integer.", argument); else call ERROR_REPORTER (code, ME, "Converting ^a to an integer.", argument); go to RETURN; end; end; else do; irep (ctlx).ptr = argument_ptr; irep (ctlx).length = argument_length; end; end; end main_argument_loop; /* Last Parse Step. Make sure all the requirements were met */ do ctlx = 1 to window_call_data_$n_ctl_args; if irep (ctlx).required & ^irep (ctlx).found then do; USAGE: call ERROR_REPORTER (error_table_$noarg, ME, "Usage: window_call ^a ^a.", key, substr (window_call_data_string, this_f.usage.index, this_f.usage.length)); go to RETURN; end; end; /* Here Endeth the Parse. */ /* Here come the semantics. One action routine for each function. */ go to DO_IT (keyx); /* we trust keyx */ /* The order of these must match the order they are generated in window_call_data_. A perfect job for pl1_macro, but thats too much hair for now. Anyway, we would have to carry constants invented in one program into another. */ DO_IT (1): /* clear window */ call get_iocb; /* use -io_switch or user_i/o */ call window_$clear_window (iocb_ptr, code); go to CHECK_RETURN; DO_IT (2): /* Bell */ call get_iocb; call window_$bell (iocb_ptr, code); go to CHECK_RETURN; DO_IT (3): /* Clear Region */ call get_iocb; if ^irep (C_COLUMN).found then irep (C_COLUMN).value = 1; if ^irep (C_N_COLUMNS).found then do; call get_window_info; irep (C_N_COLUMNS).value = window_info.width - irep (C_COLUMN).value + 1; end; call window_$clear_region (iocb_ptr, irep (C_LINE).value, irep (C_COLUMN).value, irep (C_N_LINES).value, irep (C_N_COLUMNS).value, code); go to CHECK_RETURN; DO_IT (4): /* Clear to end of line */ call get_iocb; call window_$clear_to_end_of_line (iocb_ptr, code); go to CHECK_RETURN; DO_IT (5): call get_iocb; call window_$clear_to_end_of_window (iocb_ptr, code); go to CHECK_RETURN; DO_IT (6): call get_iocb; call window_$delete_chars (iocb_ptr, irep (C_COUNT).value, code); go to CHECK_RETURN; DO_IT (7): /* Get Position */ begin; declare (l, c) fixed bin; call get_iocb; call window_$get_cursor_position (iocb_ptr, l, c, code); if code ^= 0 then go to CHECK_RETURN; if this_is_an_af then return_string = ltrim (character (l)) || " " || ltrim (character (c)); else call ioa_ ("Line = ^d; Column = ^d.", l, c); go to RETURN; end; DO_IT (8): /* Get echoed chars */ call get ("1"b); /* Does not return */ DO_IT (9): /* Get unechoed */ call get ("0"b); DO_IT (10): /* insert_text */ call get_iocb; declare text character (irep (C_STRING).length) based (irep (C_STRING).ptr); call window_$insert_text (iocb_ptr, text, code); go to CHECK_RETURN; DO_IT (11): /* Overwrite_text */ call get_iocb; call window_$overwrite_text (iocb_ptr, text, code); go to CHECK_RETURN; DO_IT (12): /* position cursor */ call get_iocb; call window_$position_cursor (iocb_ptr, irep (C_LINE).value, irep (C_COLUMN).value, code); go to CHECK_RETURN; DO_IT (13): /* position cursor rel */ call get_iocb; call window_$position_cursor_rel (iocb_ptr, irep (C_LINE).value, irep (C_COLUMN).value, code); go to CHECK_RETURN; DO_IT (14): /* Scroll Region */ call get_iocb; if ^irep (C_LINE).found then irep (C_LINE).value = 1; if ^irep (C_N_LINES).found then do; call get_window_info; irep (C_N_LINES).value = window_info.height - irep (C_LINE).value + 1; end; call window_$scroll_region (iocb_ptr, irep (C_LINE).value, irep (C_N_LINES).value, irep (C_COUNT).value, code); go to CHECK_RETURN; DO_IT (15): /* SYNC */ call get_iocb; call window_$sync (iocb_ptr, code); go to CHECK_RETURN; DO_IT (16): /* Write Sync Read */ begin; declare buffer character (irep (C_COUNT).value); declare break character (1) varying; declare n_read fixed bin (21); declare prompt character (irep (C_STRING).length) based (irep (C_STRING).ptr); call get_iocb; call window_$write_sync_read (iocb_ptr, prompt, length (buffer), buffer, n_read, break, code); if code ^= 0 then go to CHECK_RETURN; begin; declare read character (n_read) defined (buffer) position (1); if this_is_an_af then return_string = requote_string_ (read) || " " || requote_string_ ((break)); else call ioa_ ("Read = ^a; Break = ^a.", requote_string_ (read), requote_string_ ((break))); end; /* inner begin */ end; /* outer begin */ go to RETURN; /* INVOKE */ DO_IT (17): if video_data_$terminal_iocb ^= null () then do; call ERROR_REPORTER (video_et_$wsys_invoked, ME); go to RETURN; end; begin options (non_quick); declare reason character (512); declare line_speed fixed bin; if irep (C_LINE_SPEED).found then do; /* we have line speed */ line_speed = irep (C_LINE_SPEED).value; if line_speed < 0 then do; call ERROR_REPORTER (error_table_$bad_arg, ME, "^a", "Negative value not allowed for line speed."); go to RETURN; end; end; call video_utils_$turn_on_login_channel (code, reason); if code ^= 0 then do; call ERROR_REPORTER (code, ME, "^a", reason); go to RETURN; end; if irep (C_LINE_SPEED).found then do; /* we have line speed */ call iox_$control (video_data_$terminal_iocb, "set_line_speed", addr (line_speed), code); if code ^= 0 then go to CHECK_RETURN; end; go to RETURN; end; /* REVOKE */ DO_IT (18): call video_utils_$turn_off_login_channel ((0)); go to RETURN; /* CREATE */ DO_IT (19): begin options (non_quick); declare wiocbp pointer; declare 1 wpi aligned like window_position_info; declare switch_name character (irep (C_SWITCH).length) based (irep (C_SWITCH).ptr); call iox_$find_iocb (switch_name, wiocbp, code); if code ^= 0 then go to CHECK_RETURN; wpi.version = window_position_info_version_1; if irep (C_LINE).found then wpi.origin.line = irep (C_LINE).value; else wpi.origin.line = 1; if irep (C_N_LINES).found then wpi.extent.height = irep (C_N_LINES).value; else wpi.extent.height = 0; if irep (C_COLUMN).found then wpi.origin.column = irep (C_COLUMN).value; else wpi.origin.column = 0; if irep (C_N_COLUMNS).found then wpi.extent.width = irep (C_N_COLUMNS).value; else wpi.extent.width = 0; call window_$create (video_data_$terminal_iocb, addr (wpi), wiocbp, code); if code ^= 0 then go to CHECK_RETURN; return; end; DO_IT (20): call get_iocb; /* Delete Window */ call window_$destroy (iocb_ptr, code); if code ^= 0 then go to CHECK_RETURN; return; /* Change Window */ DO_IT (21): call get_iocb; call get_window_info; /* Life is more complicated with partial width windows. One can now change widths as well as heights ... up until this point, one had to specify at least one of C_LINE/C_N_LINES, now one must specify one of those *or* one of C_COLUMN/C_N_COLUMNS. */ if ^(irep (C_LINE).found | irep (C_N_LINES).found | irep (C_COLUMN).found | irep (C_N_COLUMNS).found) then go to USAGE; if irep (C_LINE).found then window_info.origin.line = irep (C_LINE).value; if irep (C_N_LINES).found then window_info.height = irep (C_N_LINES).value; else do; /* use rest of screen */ call get_capabilities (video_data_$terminal_iocb); if window_info.origin.line + window_info.height - 1 > ci.rows then window_info.height = ci.rows - window_info.origin.line + 1; end; if irep (C_COLUMN).found then window_info.origin.column = irep (C_COLUMN).value; if irep (C_N_COLUMNS).found then window_info.width = irep (C_N_COLUMNS).value; else do; /* use rest of screen */ call get_capabilities (video_data_$terminal_iocb); if window_info.origin.column + window_info.width - 1 > ci.columns then window_info.width = ci.columns - window_info.origin.column + 1; end; call iox_$control (iocb_ptr, "set_window_info", addr (window_info), code); go to CHECK_RETURN; DO_IT (22): /* get first line */ call get_iocb; call get_window_info; if this_is_an_af then return_string = ltrim (character (window_info.origin.line)); else call ioa_ ("First line = ^d.", window_info.origin.line); go to RETURN; DO_IT (23): /* get n lines */ call get_iocb; call get_window_info; if this_is_an_af then return_string = ltrim (character (window_info.height)); else call ioa_ ("Height = ^d.", window_info.height); go to RETURN; DO_IT (24): /* get n columns */ call get_iocb; call get_window_info; if this_is_an_af then return_string = ltrim (character (window_info.width)); else call ioa_ ("Width = ^d.", window_info.width); go to RETURN; %include terminal_capabilities; declare 1 ci aligned like capabilities_info; DO_IT (25): /* get_terminal_height */ call get_capabilities (video_data_$terminal_iocb); if this_is_an_af then return_string = ltrim (character (ci.screensize.rows)); else call ioa_ ("Terminal Height = ^d rows.", ci.screensize.rows); go to RETURN; DO_IT (26): /* get terminal width */ call get_capabilities (video_data_$terminal_iocb); if this_is_an_af then return_string = ltrim (character (ci.screensize.columns)); else call ioa_ ("Terminal Width = ^d columns.", ci.screensize.columns); go to RETURN; DO_IT (27): /* Get one (but always block) */ call get_iocb; begin; declare one character (1) varying; call window_$get_one_unechoed_char (iocb_ptr, one, "1"b, code); if code ^= 0 then go to CHECK_RETURN; if this_is_an_af then return_string = requote_string_ ((one)); else call ioa_ ("Char = ""^a""", one); return; end; DO_IT(28): /* supported terminal */ %include terminal_info; dcl 1 ti like terminal_info; dcl supported_ttp bit(1); dcl ttp_length fixed binary, ttp_ptr pointer; dcl ttp char (ttp_length) based (ttp_ptr); dcl ttt_info_$video_info entry (char(*), fixed bin, ptr, ptr, fixed bin(35)); dcl error_table_$no_table fixed bin(35) ext static; dcl uppercase char (26) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl lowercase char (26) static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); if irep(C_TERMINAL_TYPE).found then do; /* user gave us a terminal type */ ttp_length = irep(C_TERMINAL_TYPE).length; ttp_ptr = irep(C_TERMINAL_TYPE).ptr; end; else do; /* user didn't give us one, let's get the current type */ ti.version = 1; call iox_$control(iox_$user_io, "terminal_info", addr(ti), code); if code ^= 0 then goto CHECK_RETURN; ttp_length = length(ti.term_type); ttp_ptr = addr(ti.term_type); end; ttp = translate(ttp, uppercase, lowercase); /* ttt_info_ is case sensitive */ call ttt_info_$video_info (ttp, (0), null(), null(), code); if code ^= 0 & code ^= error_table_$no_table then goto CHECK_RETURN; if code = error_table_$no_table then supported_ttp = "0"b; else supported_ttp = "1"b; if this_is_an_af then if supported_ttp then return_string = "true"; else return_string = "false"; else call ioa_ ("The ^a terminal type is ^[not ^]supported by the video system.", ttp, ^supported_ttp); goto RETURN; DO_IT(29): /* video invoked? */ dcl video_invoked bit(1); video_invoked = video_data_$terminal_iocb ^= null(); if this_is_an_af then if video_invoked then return_string = "true"; else return_string = "false"; else call ioa_ ("The video system has ^[not ^]been invoked.", ^video_invoked); goto RETURN; get_capabilities: procedure (iocb_ptr); declare iocb_ptr ptr; ci.version = capabilities_info_version_1; call iox_$control (iocb_ptr, "get_capabilities", addr (ci), code); if code ^= 0 then go to CHECK_RETURN; end get_capabilities; get: procedure (echo_flag); declare break character (1) varying; declare buffer character (irep (C_COUNT).value); declare echo_flag bit (1) aligned; declare n_read fixed bin (21); call get_iocb; if echo_flag then call window_$get_echoed_chars (iocb_ptr, length (buffer), buffer, n_read, break, code); else call window_$get_unechoed_chars (iocb_ptr, length (buffer), buffer, n_read, break, code); if code ^= 0 then go to CHECK_RETURN; begin; declare read character (n_read) defined (buffer) pos (1); if this_is_an_af then return_string = requote_string_ (read) || " " || requote_string_ ((break)); else call ioa_ ("Read = ^a, Break = ^a.", requote_string_ (read), requote_string_ ((break))); end; go to RETURN; end get; get_iocb: procedure; if ^irep (C_SWITCH).found then iocb_ptr = iox_$user_io; else begin; declare switch_name character (irep (C_SWITCH).length) based (irep (C_SWITCH).ptr); call iox_$look_iocb (switch_name, iocb_ptr, code); if code ^= 0 then go to CHECK_RETURN; end; end get_iocb; declare 1 window_info aligned like window_position_info; get_window_info: procedure; window_info.version = window_position_info_version_1; call iox_$control (iocb_ptr, "get_window_info", addr (window_info), code); if code ^= 0 then go to CHECK_RETURN; end get_window_info; CHECK_RETURN: if code ^= 0 then call ERROR_REPORTER (code, ME, "(^a)", key); go to RETURN; ERROR_REPORTER: procedure options (variable, support); declare code fixed bin (35) based (code_ptr); declare code_ptr pointer; declare error_table_$undefined_order_request fixed bin (35) ext static; declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); declare cu_$generate_call entry (entry, ptr); call cu_$arg_ptr (1, code_ptr, (0), (0)); /* assume we are called with at least one */ if code = error_table_$undefined_order_request then cu_$arg_list_ptr () -> arg_list.arg_ptrs (1) = addr (video_et_$wsys_not_invoked); call cu_$generate_call (error_reporter, cu_$arg_list_ptr ()); %include arg_list; end ERROR_REPORTER; end; /* The begin block */ RETURN: return; %page; %include window_call_info_; end window_call;  window_call_data_.cds 08/13/87 1333.0rew 08/13/87 1324.1 121581 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* CDS program defining the parameters and usage of the various functions of window call */ /* Benson I. Margulies, sometime in 1981 */ /* Modified by Chris Jones, 7 December 1981, to handle "undocumented" keys and control args */ /* Modified 29 June 1982 by William York to fix the control args for the clear_region key */ /* Modified 14 June 1983 by Jon A. Rochlis to add "supported_terminal" and "video_invoked" keywords as well as -ttp control arg */ /* Modified 1 October 1983 by JR to add support for partial screen width windows by allowing change_window and create_window to take column and n_column arguments */ /* Modified 28 June 1984 by JR to add get_window_width, since I forgot about it in October. */ /* Modified 6 September 1984 by C. Marker to add -line_speed which will allow a user to specify this speed of his connection. */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ window_call_data_: procedure; /* we dont believe in positional arguments, save the key. everything is control arguments, taking various things afterwards. */ declare 1 f aligned like function based (f_ptr); declare f_ptr pointer; declare 1 ca aligned like ctl_arg_info based (ca_ptr); declare ca_ptr pointer; declare get_temp_segments_ entry (character (*), (*) pointer, fixed binary (35)); declare release_temp_segments_ entry (character (*), (*) pointer, fixed binary (35)); declare ME character (32) init ("window_call_data_") internal static options (constant); declare ( TEXT init (1), STATIC init (2) ) fixed bin internal static options (constant); declare sys_info$max_seg_size fixed bin (19) ext static; declare tsp (3) pointer; declare headerspace (sys_info$max_seg_size) bit (36) aligned based (tsp (1)); declare functionspace (sys_info$max_seg_size) bit (36) aligned based (tsp (2)); declare stringspace character (sys_info$max_seg_size * 4) based (tsp (3)); declare fx fixed bin (19); declare sx fixed bin (21); declare h_ptr pointer; /* No refer extents, because we construct with addrel technology, and do not touch the functions at all until the very end. */ declare 1 header based (h_ptr) aligned, 2 n_keys fixed bin, 2 n_ctl_args fixed bin, 2 string_length fixed bin (21), 2 names (header.n_keys) aligned, 3 long character (32) unaligned, 3 undocumented_long character (32) unaligned, 3 short character (8) unaligned, 3 undocumented_short character (8) unaligned, 2 functions (header.n_keys) like function aligned, 2 ctl_args (header.n_ctl_args) like ctl_arg_info aligned, 2 string character (header.string_length) unaligned; declare code fixed bin (35); declare com_err_ entry () options (variable); declare 1 cdsa aligned like cds_args; declare create_data_segment_ entry (pointer, fixed binary (35)); declare cleanup condition; declare (addr, currentsize, null, string) builtin; tsp (*) = null (); on cleanup call clean_it_up; call get_temp_segments_ (ME, tsp, (0)); /* if it fails, we fault through null */ fx = 0; sx = 0; h_ptr = addr (headerspace (1)); header.n_keys = 0; /* hx is not interesting until all the functions are ready */ /* 1 */ f_ptr = get_function ("clear_window", "clwd", "", "cw", "{-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; /* accept -io_switch */ /* 2 */ f_ptr = get_function ("bell", "", "", "", "{-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; /* 3 */ f_ptr = get_function ("clear_region", "clrgn", "", "cr", "{-io_switch WINDOW_NAME} -line LINE -height N_LINES -column COLUMN -width N_COLUMNS"); f.args (C_SWITCH).allowed = "1"b; f.args (C_LINE).allowed = "1"b; f.args (C_LINE).required = "1"b; f.args (C_N_LINES).allowed = "1"b; /* No Default, too dangerous */ f.args (C_N_LINES).required = "1"b; f.args (C_COLUMN).allowed = "1"b; f.args (C_COLUMN).required = "1"b; f.args (C_N_COLUMNS).allowed = "1"b; f.args (C_N_COLUMNS).required = "1"b; /* 4 */ f_ptr = get_function ("clear_to_end_of_line", "cleol", "", "cteol", "{-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; /* 5 */ f_ptr = get_function ("clear_to_end_of_window", "cleowd", "", "cteow", "{-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; /* 6 */ f_ptr = get_function ("delete_chars", "dlch", "", "dc", "-count N {-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.args (C_COUNT).allowed = "1"b; f.args (C_COUNT).required = "1"b; /* 7 */ f_ptr = get_function ("get_position", "gpos", "get_cursor_position", "gcp", "{-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.af_allowed = "1"b; /* 8 */ f_ptr = get_function ("get_echoed_chars", "gech", "", "gec", "-count N {-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.args (C_COUNT).allowed = "1"b; f.args (C_COUNT).required = "1"b; f.af_allowed = "1"b; /* 9 */ f_ptr = get_function ("get_unechoed_chars", "guch", "", "guc", "-count N {-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.args (C_COUNT).allowed = "1"b; f.args (C_COUNT).required = "1"b; f.af_allowed = "1"b; /* 10 */ f_ptr = get_function ("insert_text", "itx", "", "it", "-string TEXT {-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.args (C_STRING).allowed = "1"b; f.args (C_STRING).required = "1"b; /* 11 */ f_ptr = get_function ("overwrite_text", "otx", "", "ot", "-string TEXT {-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.args (C_STRING).allowed = "1"b; f.args (C_STRING).required = "1"b; /* 12 */ f_ptr = get_function ("set_position", "spos", "position_cursor", "pc", "-line LINE -column COLUMN {-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.args (C_LINE).allowed, f.args (C_LINE).required = "1"b; f.args (C_COLUMN).allowed, f.args (C_COLUMN).required = "1"b; /* 13 */ f_ptr = get_function ("set_position_rel", "sposrel", "position_cursor_rel", "pcr", "-line LINE_DELTA -column COLUMN_DELTA {-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.args (C_LINE).allowed, f.args (C_LINE).required = "1"b; f.args (C_COLUMN).allowed, f.args (C_COLUMN).required = "1"b; /* 14 */ f_ptr = get_function ("scroll_region", "scrgn", "", "sr", "{-line START -height SIZE} -count SCROLL_DISTANCE {-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.args (C_LINE).allowed = "1"b; f.args (C_N_LINES).allowed = "1"b; f.args (C_COUNT).allowed, f.args (C_COUNT).required = "1"b; /* 15 */ f_ptr = get_function ("sync", "", "", "", "{-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; /* 16 */ f_ptr = get_function ("write_sync_read", "wsr", "", "", "-count N_TO_READ -string PROMPT {-io_switch WINDOW_NAME}") ; f.args (C_SWITCH).allowed = "1"b; f.af_allowed = "1"b; f.args (C_COUNT).allowed, f.args (C_COUNT).required = "1"b; f.args (C_STRING).allowed, f.args (C_STRING).required = "1"b; /* 17 */ f_ptr = get_function ("invoke", "", "", "", "{-line_speed LINE_SPEED}"); f.args (C_LINE_SPEED).allowed = "1"b; /* 18 */ f_ptr = get_function ("revoke", "", "", "", ""); /* 19 */ f_ptr = get_function ("create_window", "crwd", "", "crw", "-io_switch WINDOW_NAME {-line FIRST_LINE} {-column FIRST_COLUMN} {-height N_LINES} {-width N_COLUMNS}"); f.args (C_SWITCH).allowed, f.args (C_SWITCH).required = "1"b; f.args (C_LINE).allowed, f.args (C_N_LINES).allowed = "1"b; f.args (C_COLUMN).allowed = "1"b; f.args (C_N_COLUMNS).allowed = "1"b; /* 20 */ f_ptr = get_function ("delete_window", "dlwd", "destroy_window", "dsw", "-io_switch WINDOW_NAME"); f.args (C_SWITCH).required, f.args (C_SWITCH).allowed = "1"b; /* 21 */ f_ptr = get_function ("change_window", "chgwd", "", "chw", "{-io_switch WINDOW_NAME} {-line N} {-height N} {-column N} {-width N}"); f.args (C_SWITCH).allowed = "1"b; f.args (C_LINE).allowed = "1"b; f.args (C_N_LINES).allowed = "1"b; f.args (C_COLUMN).allowed = "1"b; f.args (C_N_COLUMNS).allowed = "1"b; /* 22 */ f_ptr = get_function ("get_first_line", "gfl", "", "", "{-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.af_allowed = "1"b; /* 23 */ f_ptr = get_function ("get_window_height", "gwdhgt", "get_n_lines", "gnl", "{-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.af_allowed = "1"b; /* 24 */ f_ptr = get_function ("get_window_width", "gwdwid", "get_n_cols", "gnc", "{-io_switch WINDOW_NAME}"); f.args (C_SWITCH).allowed = "1"b; f.af_allowed = "1"b; /* 25 */ f_ptr = get_function ("get_terminal_height", "gtmhgt", "", "gtmh", ""); f.af_allowed = "1"b; /* 26 */ f_ptr = get_function ("get_terminal_width", "gtmwid", "", "gtmw", ""); f.af_allowed = "1"b; /* 27 */ f_ptr = get_function ("get_one_unechoed_char", "gouch", "", "gouc", "{-io_switch WINDOW}"); f.af_allowed = "1"b; f.args (C_SWITCH).allowed = "1"b; /* 28 */ f_ptr = get_function ("supported_terminal", "", "supported_ttp", "", "-ttp TERMINAL_TYPE"); f.af_allowed = "1"b; f.args (C_TERMINAL_TYPE).allowed = "1"b; /* 29 */ f_ptr = get_function ("video_invoked", "", "", "", ""); f.af_allowed = "1"b; /* Now header.n_keys is correct, we can copy the functions */ begin; declare 1 farray (header.n_keys) aligned like function based (fa_ptr); declare fa_ptr pointer; fa_ptr = addr (functionspace (1)); header.functions = farray; /* Page faults! get um while their hot! */ end; /* Now build the control arguments in the functionspace seg */ /* These calls must be in the order of the C_ constants for this to work */ fx = 0; call make_ctl_arg ("line", "", "", "ln", A_NUMBER); call make_ctl_arg ("column", "col", "", "cl", A_NUMBER); call make_ctl_arg ("count", "ct", "", "", A_NUMBER); call make_ctl_arg ("height", "hgt", "n_lines", "nl", A_NUMBER); call make_ctl_arg ("io_switch", "is", "", "iosw", A_STRING); call make_ctl_arg ("screen", "", "", "", A_STRING); call make_ctl_arg ("string", "str", "", "", A_STRING); call make_ctl_arg ("width", "wid", "n_columns", "nc", A_NUMBER); call make_ctl_arg ("terminal_type", "ttp", "", "", A_STRING); call make_ctl_arg ("line_speed", "ls", "", "", A_NUMBER); header.n_ctl_args = N_CTL_ARGS; begin; declare 1 ctlargs (N_CTL_ARGS) aligned like ctl_arg_info based (cas_ptr); declare cas_ptr pointer; cas_ptr = addr (functionspace (1)); header.ctl_args = ctlargs; end; /* now for usage strings */ header.string_length = sx; /* points at last character */ begin; declare stringwewant character (header.string_length) defined (stringspace) position (1); header.string = stringwewant; end; cdsa.sections (TEXT).p = addr (header); cdsa.sections (TEXT).len = currentsize (header); cdsa.sections (STATIC).p = null (); cdsa.sections (STATIC).len = 0; cdsa.struct_name = "header"; cdsa.seg_name = ME; cdsa.num_exclude_names = 0; cdsa.exclude_array_ptr = null (); string (cdsa.switches) = ""b; cdsa.switches.have_text = "1"b; call create_data_segment_ (addr (cdsa), code); call clean_it_up; if code ^= 0 then call com_err_ (code, ME); return; clean_it_up: procedure; call release_temp_segments_ (ME, tsp, (0)); end clean_it_up; get_function: procedure (lname, sname, ulname, usname, usage) returns (pointer); declare (lname, sname, ulname, usname, usage) character (*); declare nf_ptr pointer; declare 1 nf aligned like function based (nf_ptr); declare usage_x fixed bin (21); declare (string, length) builtin; fx = fx + 1; /* point to first word of new one */ nf_ptr = addr (functionspace (fx)); fx = fx + currentsize (nf) - 1; /* point to last word of new one */ usage_x = sx + 1; begin; declare u_in_string character (length (usage)) defined (stringspace) position (usage_x); u_in_string = usage; sx = sx + length (usage); nf.usage.index = usage_x; nf.usage.length = length (usage); end; header.n_keys = header.n_keys + 1; header.names (header.n_keys).long = lname; header.names (header.n_keys).short = sname; header.names (header.n_keys).undocumented_long = ulname; header.names (header.n_keys).undocumented_short = usname; string (nf.args) = ""b; return (nf_ptr); end get_function; make_ctl_arg: procedure (lname, sname, ulname, usname, atype); declare (lname, sname, ulname, usname) character (*); declare atype fixed bin; fx = fx + 1; ca_ptr = addr (functionspace (fx)); ca.name.long = lname; ca.name.short = sname; ca.name.undocumented_long = ulname; ca.name.undocumented_short = usname; ca.argument = atype; fx = fx + currentsize (ca) - 1; end make_ctl_arg; %include window_call_info_; %include cds_args; end window_call_data_;  window_display_.pl1 08/13/87 1333.0r 08/13/87 1323.4 116460 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ window_display_: procedure (P_window, P_image, P_code); /* Written by James R.Davis February 1981 SKrupp was here 5/7/81 fixed bug where image_memory.assoc(*).window should be initialized to null when image_memory is allocated. Maintained by Kyzivat.SST 6/11/81 corrected a problem where data was transmitted via ioa_, and thus had trailing blanks removed. Also added a minimal form of redisplay which works on changed lines but doesn't detect inserted or deleted lines. Also made change to clear changed part of the window when the size of the image changes. Also added an entrypoint to totally refresh the window. 6/12/81 Made minor tweaks to improve the efficiency of access to the image arrays. Stolen by Benson I. Margulies Updated to new window_ calling sequence, July 1981. IPS masking added in august. Changed to use terminal control's screen image, September 2, 1981. Adopted by William M. York in 1982. */ /* Modified 20 October 1982 by WMY to use clear_to_end_of_line rather than overwriting with spaces. */ /* Modified 21 October 1982 by WMY to perform simple insert/delete characters optimizations. */ /* Modified 25 October 1982 by WMY to clear regions, not just line-at-a-time. */ /* Modified 9 December 1982 by WMY to restrict the cases where insert/delete characters is used in response to complaints from XMAIL users. */ /* Modified 8 January 1983 by Jon A. Rochlis to add support for partial width windows (i.e. windows who don't start at col 1, or who are shorter than screen width). */ dcl P_window pointer parameter; dcl P_image (*) char (*) unaligned parameter; dcl P_code fixed binary (35) parameter; dcl saved_mask bit (36) aligned; dcl terminal_iocb_ptr pointer; dcl video_data_$as_only_mask bit (36) aligned external static; dcl cleanup condition; dcl nlines fixed bin; dcl ncols fixed bin; dcl lx fixed bin; dcl long_string character (256) unaligned; dcl start_col fixed bin; dcl start_line fixed bin; dcl region_start_line fixed bin; dcl short_image bit (1) aligned; dcl hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned); dcl (addr, hbound, length, min, null, string) builtin; dcl 1 wpi aligned like window_position_info; %page; %include tc_screen_image; %page; %include window_dcls; %page; %include window_control_info; %page; %include iox_dcls; saved_mask = ""b; on cleanup begin; if saved_mask ^= ""b then call hcs_$reset_ips_mask (saved_mask, ""b); end; P_code = 0; show_block: begin; dcl temp_line char (length (P_image (1))) defined (long_string) position (1); nlines = hbound (P_image, 1); ncols = length (P_image (1)); call iox_$control (P_window, "get_terminal_iocb_ptr", terminal_iocb_ptr, P_code); if P_code ^= 0 then go to RETURN; wpi.version = window_position_info_version_1; call iox_$control (P_window, "get_window_info", addr (wpi), P_code); if P_code ^= 0 then go to RETURN; start_col = wpi.origin.column; start_line = wpi.origin.line; /* We mask down, to prevent async changes from invalidating the image we are using */ /* Perhaps a pclock would be more polite */ call hcs_$set_ips_mask (video_data_$as_only_mask, saved_mask); /* First try some global optimization. Clear any groups of lines in the new image that are blank. */ do lx = 1 to wpi.extent.height; region_start_line = lx; /* skip blank lines */ do lx = lx to wpi.extent.height while (P_image(lx) = ""); end; if lx > region_start_line then do; call window_$clear_region (P_window, region_start_line, 1, lx - region_start_line, wpi.extent.width, P_code); if P_code ^= 0 then goto RETURN; end; end; call iox_$control (terminal_iocb_ptr, "get_screen_image_ptr", screen_ptr, P_code); if P_code ^= 0 then go to RETURN; short_image = (ncols < wpi.extent.width); do lx = start_line to start_line + nlines - 1; begin; /* lx is terminal screen line no */ dcl cur_image character (wpi.extent.width) defined (screen.lines (lx)) position (start_col) unaligned; dcl image_line_no fixed bin; image_line_no = lx - start_line + 1; if cur_image ^= P_image (image_line_no) then call redisplay_one_line (cur_image, P_image (image_line_no), temp_line, image_line_no /* Window line */, P_code); if P_code ^= 0 then go to RETURN; end; end; /*** !! See >udd>m>bsg>mepap for details of the (better) Emacs redisplay ***/ call hcs_$reset_ips_mask (saved_mask, ""b); saved_mask = ""b; if nlines < wpi.extent.height then do; call window_$clear_region (P_window, nlines + 1, (1), wpi.extent.height - nlines, wpi.extent.width, P_code); if P_code ^= 0 then go to RETURN; end; RETURN: if saved_mask ^= ""b then call hcs_$reset_ips_mask (saved_mask, ""b); return; /* Real guts of redisplay. The basic algorithm is to first check for a simple insertion or deletion of characters at one point in the new string. If we find one, fix it up and go on to the next step. That next step is to find all the sections of the current screen image (old line) that differ from the new line and overwrite the new stuff. */ redisplay_one_line: proc (old_arg, new_arg, diff_arg, lineno, code); dcl old_arg char (*) parameter; dcl new_arg char (*) parameter; dcl diff_arg char (*) parameter; dcl lineno fixed bin parameter; dcl code fixed bin (35) parameter; dcl diff_l fixed bin; dcl new_l fixed bin; dcl SPACE char (1) init (" ") static options (constant); dcl SAME char (1) init ("" /* byte (0) */) static options (constant); dcl RUN_OF_SAME char (4) init ("") internal static options (constant); dcl pos fixed bin; dcl i fixed bin; dcl real_len fixed bin; dcl len fixed bin; dcl diff_string char(diff_l) based (addr (diff_arg)); dcl (addr, before, length, rtrim, substr, verify) builtin; if new_arg = "" then do; call window_$position_cursor (P_window, lineno, 1, code); if code ^= 0 then return; call window_$clear_to_end_of_line (P_window, code); return; end; /* we consider as much as the shorter string. */ diff_l = min (length (old_arg), length (new_arg)); /* The PL/1 code for the bool bif is horrible. unspec (diff) = bool (unspec (old), unspec (new), "0110"b ); */ /* XOR produces "000000000"b (^@) for equality */ dcl video_alm_util_$XOR_chars entry (fixed bin, pointer, pointer, pointer); /* Find the place where they are different */ call video_alm_util_$XOR_chars (diff_l, addr (old_arg), addr (new_arg), addr (diff_arg)); /* Now try to be clever about simple insert/delete characters optimizations. */ pos = verify (diff_string, SAME); /* Skip common stuff */ if pos = 0 then go to CHECK_SHORT_IMAGE; len = length (rtrim (diff_string, SAME)); crossmatch: begin; dcl old_in_new fixed bin; dcl new_in_old fixed bin; dcl count fixed bin; dcl old_string char(len - pos + 1) defined (old_arg) position (pos); dcl new_string char(len - pos + 1) defined (new_arg) position (pos); if (old_string = "") | (new_string = "") then goto no_crossmatch; /* check for simple delete chars. */ new_in_old = index (old_string, substr (new_string, 1, 4)); /* and simple insert chars. */ old_in_new = index (new_string, substr (old_string, 1, 4)); /* Make sure the match extends to the end of the string */ if new_in_old > 0 then if substr (old_string, new_in_old) ^= substr (new_string, 1, length (old_string) - new_in_old + 1) then new_in_old = 0; if old_in_new > 0 then if substr (new_string, old_in_new) ^= substr (old_string, 1, length (new_string) - old_in_new + 1) then old_in_new = 0; /* find shortest distance for a match */ if (new_in_old = 0) & (old_in_new = 0) then goto no_crossmatch; else if (new_in_old = 0) then count = old_in_new; else if (old_in_new = 0) then count = -(new_in_old); else if (old_in_new < new_in_old) then count = old_in_new; else count = -(new_in_old); if (count > 0) then do; /* Insert chars case. */ /* first clear out stuff at end */ if length (old_string) > wpi.extent.width - (count - 1) then do; call window_$position_cursor (P_window, lineno, wpi.extent.width - (count - 1) + 1, code); if code ^= 0 then return; call window_$clear_to_end_of_line (P_window, code); if code ^= 0 then return; end; /* now insert new stuff in middle */ call window_$position_cursor (P_window, lineno, pos, code); if code ^= 0 then return; call window_$insert_text (P_window, substr (new_string, 1, count - 1), code); if code ^= 0 then return; end; else do; /* Delete chars case. */ count = - count; call window_$position_cursor (P_window, lineno, pos, code); if code ^= 0 then return; call window_$delete_chars (P_window, count - 1, code); if code ^= 0 then return; end; /* Now we have to re-try the match. */ call video_alm_util_$XOR_chars (diff_l, addr (old_arg), addr (new_arg), addr (diff_arg)); no_crossmatch: end crossmatch; diff_l = length (rtrim (diff_string, SAME)); /* Can't be zero or verify above would fail. */ /* Get length of new neglecting number of trailing spaces. */ new_l = length (rtrim (new_arg, SPACE)); /* new_l can't = 0 or check for new = "" above would have caught it. */ /* We only want to process the different characters, or until we run out of new stuff. */ real_len = min (new_l, diff_l); overwrite_changes: begin; dcl new char (real_len) defined (new_arg) position (1); dcl diff char (real_len) defined (diff_arg) position (1); dcl trimmed fixed bin; /* Find the first spot where the strings differ. */ pos = verify (diff, SAME); if pos = 0 then goto CLEAR_IF_NECESSARY; call window_$position_cursor (P_window, lineno, pos, code); if code ^= 0 then return; /* Loop through rest of string overwriting parts that are different with new stuff. Stop when we have passed all the common stuff of reached the end of the new string. */ do while (pos <= real_len); /* How many characters before a run of 4 characters that are the same in both strings? */ i = length (before (substr (diff, pos), RUN_OF_SAME)); /* If we overshoot the end of the new stuff, back up. */ if (pos + i - 1) > real_len then i = real_len - pos + 1; call window_$overwrite_text (P_window, substr (new, pos, i), code); if code ^= 0 then return; pos = pos + i; /* Now skip over the next chunk the new and old have in common. */ i = verify (substr (diff, pos), SAME) - 1; if i < 0 then pos = real_len + 1; /* all same to end */ else do; /* Skip over stuff that's the same. */ call window_$position_cursor_rel (P_window, 0, i, code); if code ^= 0 then return; pos = pos + i; end; /* We are now either all done, or at the beginning of some stuff that's different between the two strings. */ end; /* do while */ end overwrite_changes; CLEAR_IF_NECESSARY: /* If the new line ends in whitespace and is shorter than the old stuff, clear the rest of the line. */ if real_len = new_l /* see assignment of real_len above */ then do; call window_$position_cursor (P_window, lineno, new_l + 1, code); if code ^= 0 then return; call window_$clear_to_end_of_line (P_window, code); if code ^= 0 then return; end; CHECK_SHORT_IMAGE: /* If the supplied screen image is shorter than the width of the window, clear to the end of line. */ if short_image then call window_$clear_region (P_window, lineno, ncols + 1, (1), wpi.extent.width - ncols, code); return; end redisplay_one_line; end show_block; end window_display_;  window_editor_utils_.alm 08/13/87 1333.0rew 08/13/87 1324.0 9225 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** name window_editor_utils_ " Macro to generate a call to an external entrypoint in window_io_iox_ macro call_wii segdef &1 &1: getlp tra window_io_iox_$&2 &end call_wii insert_text,insert_text_ call_wii delete_text,delete_text_ call_wii delete_text_save,delete_text_save_ call_wii move_forward,move_forward_ call_wii move_backward,move_backward_ call_wii move_forward_word,move_forward_word_ call_wii move_backward_word,move_backward_word_ call_wii get_top_kill_ring_element,get_top_kill_ring_element_ call_wii rotate_kill_ring,rotate_kill_ring_ end window_editor_utils_  window_io_.pl1 10/20/88 1452.0rew 10/20/88 1422.9 202059 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Window Manager - implements a virtual terminal see MTB 462 ** MCR 4748 Benson I. Margulies, from crt_ of James R Davis, June, 1981 James R Davis, from 20 July 80 to February 11 81 with guidance (spiritual and material) from: Steven H. Webber Larry E. Johnson Bernard S. Greenberg and help from Krupp Suzanne */ /****^ HISTORY COMMENTS: 1) change(81-12-01,CJones), approve(), audit(), install(): Modified to make more_mode=fold the default on non-scrollable terminals. Modified 16 December 1981 by Chris Jones to use currently defined editing chars rather than # and @. Modified 26 January 1982 by William York to implement user-settable more handlers. Modified 3 June 1982 by WMY to change the default more_mode for non-scrolling terminals from fold back to wrap. Modified 18 October 1982 by WMY to initialize the new attach_data variables conversion_tct_table, window_image, and token_characters. Modified 1 Octobter 1983 by Jon A. Rochlis to add support for partial screen width windows. Modified 8 January 1984 by JR to stop setting attach_data.capabilities at open time. Since this isn't updated and is only used to prevent setting more_mode=SCROLL on windows which don't support scroll region (here and in wioctl_$modes). Also moved setting more_mode=WRAP for such terminals to attach time, since a get_capabilities must be done there anyway. Modified 26 January 1984 by JR to get the output_conversion and special tables from terminal_control (really ring0), instead of the TTF. Modified 1 February 1984 by JR to set IOCB.control to wioctl_$control instead of window_io_video_ (which is going away). Modified 22 March 1984 by Barmar to add an initialization for attach_data.auditor_iocb_ptr. Modified 28 March 1984 by JR to set window_iocb_ptr for tc_desk_info_. Modified 28 December 1984 by JR to zero code variables. 2) change(87-03-17,LJAdams), approve(87-04-03,MCR7646), audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030): Changed ttd_version to ttd_version_3. 3) change(87-06-16,LJAdams), approve(87-06-16,MCR7584), audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055): Changed editing_chars_version_2 to editing_chars_version_3. 4) change(88-09-19,Brunelle), approve(88-09-19,MCR7813), audit(88-10-05,Blair), install(88-10-17,MR12.2-1171): Add version setting to call to get_special to get data in new special_chars format. 5) change(88-10-20,Brunelle), approve(88-10-20,PBF7813), audit(88-10-20,Farley), install(88-10-20,MR12.2-1175): Correct problem of overwriting beyond end of structure, wiping out data allocated beyond end of structure. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ window_io_: procedure; return; dcl Com_err_sw bit (1) parameter; dcl Iocb_ptr ptr parameter; dcl Code fixed bin (35) parameter; dcl Attach_options (*) char (*) var parameter; dcl Open_mode fixed bin parameter; /* opening mode */ dcl Ignore bit (1) parameter; /* obsolete opening arg */ declare 1 auto_desk_info aligned like tc_desk_window_info; declare 1 IOCB aligned like iocb based (iocb_ptr); declare 1 auto_capabilities aligned like capabilities_info; declare code fixed bin (35); declare ips_mask bit (36) aligned init ((36)"0"b); declare target_iocbp pointer; declare target_switch character (32); declare 1 atd_switches unaligned, ( 2 debug, 2 modes, 2 target, 2 top, 2 height, 2 left, 2 width ) bit (1) unaligned, 2 pad bit (29) unaligned; declare modes character (512); declare first_line fixed bin; declare n_lines fixed bin; declare first_column fixed bin; declare n_columns fixed bin; declare iocb_ptr pointer; /* Entries */ declare window_$clear_window entry (pointer, fixed bin (35)); declare ( window_io_iox_$get_chars, window_io_iox_$get_line, window_io_iox_$put_chars, wioctl_$control, wioctl_$modes ) entry; declare ( window_io_iox_$init, window_io_iox_$shut ) entry (pointer); declare ioa_$rsnnl entry() options(variable); declare cleanup condition; declare cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35)); declare ttt_info_$terminal_data entry (character (*), fixed binary, fixed binary, pointer, fixed binary (35)); declare ME character (32) init ("window_io_") internal static options (constant); declare ( error_table_$bad_conversion, error_table_$badopt, error_table_$too_many_args, error_table_$bad_mode, error_table_$noarg, error_table_$undefined_order_request, video_et_$window_too_big, video_et_$not_terminal_switch ) fixed bin (35) ext; declare (addr, bin, byte, character, copy, hbound, lbound, maxlength, null, rank, string, substr) builtin; declare next_option_valid bit (1); declare option_length fixed bin (21); declare current_option fixed bin; window_io_attach: entry (Iocb_ptr, Attach_options, Com_err_sw, Code); Code = 0; iocb_ptr = Iocb_ptr; if hbound (Attach_options, 1) < 1 then do; Code = error_table_$noarg; call attach_error (Code, "Usage: ^a terminal_switch {-control_args}", ME); end; string (atd_switches) = ""b; option_length = maxlength (Attach_options (1)); do current_option = lbound (Attach_options, 1) to hbound (Attach_options, 1); begin; declare option character (option_length) varying defined (Attach_options (current_option)); declare next_option character (option_length) varying defined (Attach_options (current_option + 1)); next_option_valid = current_option < hbound (Attach_options, 1); if character (option, 1) ^= "-" then do;/* terminal switch */ if atd_switches.target then call attach_error (error_table_$too_many_args, "Only one terminal switch name may be given. ^a was the second.", option); target = "1"b; target_switch = option; end; else if option = "-first_line" then call num_opt ("-first_line", atd_switches.top, first_line); else if option = "-height" | option = "-n_lines" | option = "-length" then call num_opt (option, atd_switches.height, n_lines); else if option = "-first_column" then call num_opt ("-first_column", atd_switches.left, first_column); else if option = "-n_columns" | option = "-width" then call num_opt ("-n_columns", atd_switches.width, n_columns); else if option = "-modes" then do; if atd_switches.modes then call attach_error (error_table_$too_many_args, "-modes may only be given once."); if ^next_option_valid then no_modes: call attach_error (error_table_$noarg, "No modes given with -modes."); if character (next_option, 1) = "-" then go to no_modes; modes = next_option; current_option = current_option + 1; end; else call attach_error (error_table_$badopt, "Unrecognized control argument ^a.", option); num_opt: procedure (o_name, o_flag, o_value); declare o_name character (*) varying; declare o_flag bit (1); declare o_value fixed bin; if o_flag then call attach_error (error_table_$too_many_args, "Only one ^a may be specified.", o_name); o_flag = "1"b; if ^next_option_valid then no_num: call attach_error (error_table_$noarg, "A number must be supplied with ^a", o_name); if character (next_option, 1) = "-" then go to no_num; o_value = cv_dec_check_ ((next_option), code); if code ^= 0 then call attach_error (error_table_$bad_conversion, "Could not convert ^a to an integer.", next_option); current_option = current_option + 1; end num_opt; end /* the begin */; end; if ^atd_switches.target then call attach_error (error_table_$noarg, "A terminal switch must be specified."); call iox_$look_iocb (target_switch, target_iocbp, code); if code ^= 0 then call attach_error (code, "Switch ^a does not exist.", target_switch); auto_capabilities.version = capabilities_info_version_1; call iox_$control (target_iocbp, "get_capabilities", addr (auto_capabilities), code); if code ^= 0 then if code = error_table_$undefined_order_request then call attach_error (video_et_$not_terminal_switch, "^a.", target_switch); else call attach_error (code, "^a.", target_switch); if ^atd_switches.top then first_line = 1; if atd_switches.height then if n_lines > auto_capabilities.rows - first_line + 1 then call attach_error (video_et_$window_too_big, "^d lines starting on line ^d will not fit on a screen ^d lines long.", n_lines, first_line, auto_capabilities.rows); else ; else n_lines = auto_capabilities.rows - first_line + 1; if ^atd_switches.left then first_column = 1; if atd_switches.width then if n_columns > auto_capabilities.columns - first_column + 1 then call attach_error (video_et_$window_too_big, "^d columns starting at column ^d will not fit on a screen ^d columns wide.", n_columns, first_column, auto_capabilities.columns); else ; else n_columns = auto_capabilities.columns - first_column + 1; attach_data_ptr = null (); on cleanup call cleanup_attach; allocate attach_data in (attach_data_area); attach_data.target_iocb_ptr = target_iocbp; attach_data.window_id = ""b; attach_data.async_count = 0; string (attach_data.flags) = ""b; call ioa_$rsnnl ("^a ^a -first_line ^i -n_lines ^i -first_column ^i -n_columns ^i", attach_data.attach_description, (0), ME, target_switch, first_line, n_lines, first_column, n_columns); attach_data.lines_written_since_read = 0; attach_data.discard_output = "0"b; attach_data.cursor_position.row_at_rawo, attach_data.col_at_rawo, attach_data.cursor_position.line, attach_data.cursor_position.col = 1; if ^auto_capabilities.scroll_region | n_columns ^= auto_capabilities.columns /* partial width window, no scroll region yet */ then attach_data.more_mode = MORE_MODE_WRAP; else attach_data.more_mode = MORE_MODE_SCROLL; attach_data.more_prompt = "More? (^a for more; ^a to discard output.)"; attach_data.more_responses.n_yeses, attach_data.more_responses.n_noes = 1; attach_data.more_responses.more_yeses = byte (bin ("015"b3)); attach_data.more_responses.more_noes = byte (bin ("177"b3)); attach_data.more_handler_in_use = "0"b; attach_data.flags.debug = atd_switches.debug; attach_data.flags.more_processing, attach_data.flags.can, attach_data.flags.esc, attach_data.flags.erkl = "1"b; attach_data.current.rows = n_lines; attach_data.current.columns = n_columns; attach_data.current.line_origin = first_line; attach_data.current.column_origin = first_column; attach_data.kill_ring_info.top_killer = null (); attach_data.kill_ring_info.army = null (); /* Get this window its own screen-section image. */ allocate window_image in (attach_data_area) set (attach_data.window_image_ptr); attach_data.auditor_iocb_ptr = null (); /* Set the conversion and special tables. */ dcl 1 cts aligned like cv_trans_struc; dcl 1 gsi aligned like get_special_info_struc; dcl temp_special_ptr ptr; dcl (got_conversions, got_specials) bit (1); dcl 1 ti aligned like terminal_info; dcl 1 ttd aligned like terminal_type_data; dcl cv_trans_idx fixed bin; dcl conversion_type fixed bin; got_conversions, got_specials = "1"b; /* assume we can get info from terminal control */ cts.version = CV_TRANS_VERSION; call iox_$control (target_iocbp, "get_output_conversion", addr (cts), Code); if Code ^= 0 then got_conversions = "0"b; gsi.area_ptr = get_system_free_area_ (); gsi.version = SPECIAL_INFO_STRUCT_VERSION_1; call iox_$control (target_iocbp, "get_special", addr (gsi), Code); if Code ^= 0 then got_specials = "0"b; if ^got_conversions | ^got_specials then /* couldn't get something from terminal control, try using the TTF defaults */ do; ti.version = terminal_info_version; call iox_$control (target_iocbp, "terminal_info", addr (ti), Code); if Code ^= 0 then call attach_error (Code, "No terminal info available from terminal control."); ttd.version = ttd_version_3; call ttt_info_$terminal_data (ti.term_type, (0), (0), addr (ttd), Code); if Code ^= 0 then call attach_error (Code, "No terminal type data for terminal type ^a.", ti.term_type); end; allocate cv_trans in (attach_data_area) set (attach_data.output_cv_ptr); if got_conversions then attach_data.output_cv_ptr -> cv_trans = cts.cv_trans; else attach_data.output_cv_ptr -> cv_trans = ttd.output_cv_ptr -> cv_trans_struc.cv_trans; /* Set up tct table for quick conversion scan. */ /* Fill in first 128 entries in string from regular table. */ do cv_trans_idx = 0 to 127; substr (conversion_tct_table, cv_trans_idx + 1, 1) = byte (attach_data.output_cv_ptr -> cv_trans.value (cv_trans_idx)); end; /* Now handle next 128, giving defaults if necessary. */ do cv_trans_idx = 128 to 255; conversion_type = attach_data.output_cv_ptr -> cv_trans.value (cv_trans_idx); if conversion_type = OUTPUT_CONVERT_ORDINARY /* bull */ then substr (conversion_tct_table, cv_trans_idx + 1, 1) = byte (OUTPUT_CONVERT_OCTAL); else substr (conversion_tct_table, cv_trans_idx + 1, 1) = byte (conversion_type); end; /* Now take care of things beyond limits of conversion table. */ substr (conversion_tct_table, 257, 256) = copy (byte (OUTPUT_CONVERT_OCTAL), 256); if got_specials then temp_special_ptr = gsi.table_ptr; else temp_special_ptr = ttd.special_ptr; sc_escape_len = temp_special_ptr -> special_chars_struc.special_chars.escape_length; sc_input_escape_len = temp_special_ptr -> special_chars_struc.special_chars.input_escapes.len; allocate special_chars in (attach_data_area) set (attach_data.special_ptr); attach_data.special_ptr -> special_chars = addr (temp_special_ptr -> special_chars_struc.special_chars) -> special_chars; if got_specials then free gsi.table_ptr -> special_chars_struc; /* Set editing chars */ dcl 1 auto_editing_chars aligned like editing_chars; auto_editing_chars.version = editing_chars_version_3; call iox_$control (target_iocbp, "get_editing_chars", addr (auto_editing_chars), Code); if Code ^= 0 then call attach_error (Code, "Unable to get the editing characters."); attach_data.erase_char = auto_editing_chars.erase; attach_data.kill_char = auto_editing_chars.kill; attach_data.input_escape_char = "\"; /* 'til tty_ learns how to get/set it */ /* ***** Break Table ***** */ attach_data.breaks = (32)"1"b; call add_to_breaks_array (bin ("177"b3 /* DEL */)); call add_to_breaks_array (rank (attach_data.erase_char)); call add_to_breaks_array (rank (attach_data.kill_char)); call add_to_breaks_array (rank (attach_data.input_escape_char)); attach_data.line_editor_breaks = attach_data.breaks; attach_data.token_character_count = 65; attach_data.token_characters = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_-$"; attach_data.top_killer = alloc_killer (); killer.next, killer.prev = attach_data.top_killer; call set_ips_mask; IOCB.attach_data_ptr = addr (attach_data); IOCB.attach_descrip_ptr = addr (attach_data.attach_description); IOCB.open = window_io_open; IOCB.detach_iocb = window_io_detach; call iox_$propagate (iocb_ptr); call reset_ips_mask; return; add_to_breaks_array: proc (bit_offset); dcl bit_offset fixed bin; if (bit_offset >= lbound (breaks_array, 1)) & (bit_offset <= hbound (breaks_array, 1)) then breaks_array (bit_offset) = "1"b; end add_to_breaks_array; window_io_open: entry (Iocb_ptr, Open_mode, Ignore, Code); Code = 0; iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr; if Open_mode ^= Stream_input_output then do; Code = error_table_$bad_mode; return; end; attach_data_ptr = IOCB.attach_data_ptr; target_iocbp = attach_data.target_iocb_ptr; auto_desk_info.first_row = attach_data.line_origin; auto_desk_info.n_rows = attach_data.current.rows; auto_desk_info.first_column = attach_data.column_origin; auto_desk_info.n_columns = attach_data.current.columns; auto_desk_info.window_iocb_ptr = iocb_ptr; call iox_$control (target_iocbp, "check_in_window", addr (auto_desk_info), Code); if Code ^= 0 then return; attach_data.window_id = auto_desk_info.window_id; /* Clear window image on opening. */ window_image_string = ""; attach_data.open_description = "stream_input_output Video"; call window_io_iox_$init (iocb_ptr); call set_ips_mask; IOCB.open = iox_$err_not_closed; IOCB.detach_iocb = iox_$err_not_closed; IOCB.get_chars = window_io_iox_$get_chars; IOCB.get_line = window_io_iox_$get_line; IOCB.put_chars = window_io_iox_$put_chars; IOCB.modes = wioctl_$modes; IOCB.control = wioctl_$control; IOCB.close = window_io_close; IOCB.open_descrip_ptr = addr (attach_data.open_description); call iox_$propagate (iocb_ptr); call reset_ips_mask; call window_$clear_window (iocb_ptr, (0)); Code = 0; return; window_io_close: entry (Iocb_ptr, Code); Code = 0; iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr; attach_data_ptr = IOCB.attach_data_ptr; call window_io_iox_$shut (iocb_ptr); call set_ips_mask; IOCB.open_data_ptr = null (); IOCB.open_descrip_ptr = null; IOCB.detach_iocb = window_io_detach; IOCB.close = iox_$err_not_open; IOCB.open = window_io_open; IOCB.modes, IOCB.control, IOCB.get_line, IOCB.get_chars, IOCB.put_chars = iox_$err_not_open; call iox_$propagate (iocb_ptr); call reset_ips_mask; return; window_io_detach: entry (Iocb_ptr, Code); Code = 0; iocb_ptr = Iocb_ptr; attach_data_ptr = IOCB.attach_data_ptr; if attach_data.output_cv_ptr ^= null () then free attach_data.output_cv_ptr -> cv_trans in (attach_data_area); if attach_data.special_ptr ^= null () then free attach_data.special_ptr -> special_chars in (attach_data_area); if attach_data.window_image_ptr ^= null () then free window_image in (attach_data_area); /* Disband the army (kill the killers?) */ begin; dcl k ptr; dcl n ptr; do k = attach_data.army repeat n while (k ^= null ()); /* execute killers */ n = k -> killer.next; free k -> killer in (attach_data_area); end; do k = attach_data.top_killer repeat n while (k ^= null ()); n = k -> killer.next; free k -> killer in (attach_data_area); if n = attach_data.top_killer then n = null (); /* end of ring, force end of loop */ end; end; /* killer freeing begin block */ auto_desk_info.window_id = attach_data.window_id; target_iocbp = attach_data.target_iocb_ptr; call iox_$control (target_iocbp, "check_out_window", addr (auto_desk_info), (0)); call set_ips_mask; IOCB.attach_data_ptr = null (); IOCB.attach_descrip_ptr = null (); call iox_$propagate (iocb_ptr); call reset_ips_mask; free attach_data; return; /* Error calls com_err_ if the loud switch is set and goes to the attach return */ attach_error: procedure options (non_quick, variable); declare error_msg character (256); declare error_msg_len fixed bin; declare code fixed bin (35) based (code_ptr); declare code_ptr pointer; declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); declare cu_$arg_list_ptr entry returns (ptr); declare ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned); declare com_err_ entry () options (variable); declare sub_err_ entry () options (variable); call ioa_$general_rs (cu_$arg_list_ptr (), 2 /* ctl string */, 3 /* first sub arg */, error_msg, error_msg_len, "0"b /* no pad */, "0"b /* no nl */); call cu_$arg_ptr (1, code_ptr, (0), (0)); /* get code */ if Com_err_sw then call com_err_ (code, ME, "^a", substr (error_msg, 1, error_msg_len)); else call sub_err_ (code, ME, "h", null (), (0), "^a", substr (error_msg, 1, error_msg_len)); Code = code; go to return_; end attach_error; return_: return; set_ips_mask: procedure; declare ( hcs_$set_ips_mask, hcs_$reset_ips_mask ) entry (bit (36) aligned, bit (36) aligned); if ips_mask = ""b then call hcs_$set_ips_mask (""b, ips_mask); return; reset_ips_mask: entry; if ips_mask ^= ""b then call hcs_$reset_ips_mask (ips_mask, ips_mask); end set_ips_mask; cleanup_attach: procedure; if attach_data_ptr ^= null () then do; auto_desk_info.window_id = attach_data.window_id; if attach_data.window_id ^= ""b then if target_iocbp ^= null () then call iox_$control (target_iocbp, "check_out_window", addr (auto_desk_info), (0)); free attach_data; end; end cleanup_attach; alloc_killer: procedure returns (pointer); dcl new pointer; killer_alloc_size = killer_initial_alloc_size; allocate killer in (attach_data_area) set (new); new -> killer.next, new -> killer.prev = null (); new -> killer.words = ""; return (new); end alloc_killer; %page; %include window_io_attach_data_; %page; %include iox_entries; %include iox_modes; %page; %include tty_editing_chars; %include terminal_type_data; %include terminal_info; %include iocb; %page; %include tty_convert; %page; %include tc_desk_info_; end window_io_;  window_io_iox_.pl1 10/17/88 1108.0rew 10/17/88 1025.5 909153 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /* Window_io_iox_ ... line editor and output converter for video */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ window_io_iox_: procedure; return; /* BIM June 1981 */ /* Modified by Chris Jones, December 1981, to add more_mode=fold processing and to remove beep from empty kill */ /* Modified January 1982 by Chris Jones to finish input escape processing and make BS act as an erase character */ /* Modified 26 January 1982 by William York to add user-settable more handlers */ /* Modified 28 April 1982 by WMY to fix a bug in async handling during raw output requests. Added the REPUT_RAW label. */ /* Modified 7 May 1982 by WMY to fix a bug where the call for the second half of a long_record input line reads a new input line from the user instead, and to stop flushing the entire kill ring when CR is typed. */ /* Modified 16 May 1982 by WMY to stop more_mode=fold from crawling up the screen one line at a time, and to make ^L clear the screen before redisplaying the input line (just like ESC ^L), and to put a limit on growth of the kill ring. */ /* Modified 10 September 1982 by WMY to perform a send_buffered_output control order after reading an input line and after processing each put_chars call. This makes tc_ level output buffering less visible to the iox_ caller. */ /* Modified 20 September 1982 by WMY to change the send_buffered_output control order to a window_$sync call. */ /* Modified 1 October 1982 by WMY to make QUIT during more breaks work. */ /* Modified 4 October 1982 by WMY for a complete re-write. Implemented mid-line editing, input line redisplay, etc. */ /* Modified January 1983 by WMY to reset the window status when exiting raw mode. */ /* Modified Februrary 1983 by WMY to add user-settable key bindings. */ /* Modified April 1983 by WMY to fix bugs (no rtrim of output lines and kill merging across CR) and add input conversion support. */ /* Modified April 1983 by WMY to add window_util_ entrypoints for use by external editor routines. */ /* Modified April 1983 by WMY to restructure code so that calls from external editor routines will work correctly. */ /* Modified 6 June 1983 by WMY to try re-sizing the window if a call to window_ gets a out_of_window_bounds error code. The assumption here is that the terminal's screen has shrunk due to reconnection. */ /* Modified 23-24 June 1983 by Jon A. Rochlis to implement numeric arguments to editor routines, stop non-echoed input from being saved on the kill ring, and to give user routines the keysequences which invoked them. */ /* Modified 25 June 1983 by JR to add ESC-L, ESC-U, ESC-C, and ESC-T builtin requests. */ /* Modified 9 October 1983 by JR to add first cut at edit_line */ /* Modified December 1983 by JR to add support for vertical windows. */ /* Modified 1 February 1984 by JR to make the deffault bindings for builtins be case-insensitive. I.e. ESC-f and ESC-F will be bound at init time to FORWARD_WORD. This should make CLJ happy. */ /* Modified 29 February 1984 by Barmar to make free_dispatch_tables externally available */ /* Modified 22 March 1984 by Barmar to make get_line initialize user_data_ptr to null, and to be better at cleaning up. */ /* Modified 29 April 1984 by JR to add LEI.suppress_redisplay. */ /* Modified 27 May 1984 by JR to make async_or_error deal with reconnection and ttp_change status. */ /* Modified 01 September 1984 by JR to support edited mode. */ /****^ HISTORY COMMENTS: 1) change(86-05-17,GDixon), approve(86-05-17,MCR7357), audit(86-07-10,Farley), install(86-07-18,MR12.0-1098): Change call from tct_$translate to find_char_$translate_first_in_table. The tct_ subroutine was renamed. 2) change(88-09-19,Brunelle), approve(88-09-19,MCR7813), audit(88-10-05,Blair), install(88-10-17,MR12.2-1171): Change convert_special_sequence to return a special char sequence of up to 15 chars instead of 3. This implements special chars version 2 data structure. END HISTORY COMMENTS */ /* Simulate standard tty stuff in a window */ /* Parameters */ dcl Iocb_ptr pointer parameter; dcl Buffer_ptr pointer parameter; dcl Buffer_len fixed bin (21) parameter; dcl Code fixed bin (35) parameter; dcl N_returned fixed bin (21) parameter; /* Parameters for utility entrypoints */ dcl a_lei_ptr pointer parameter; dcl a_count fixed bin (21) parameter; dcl a_kill_direction bit (1) aligned parameter; dcl a_text char (*) parameter; dcl a_code fixed bin (35) parameter; dcl a_table_ptr pointer parameter; /* Based */ dcl Buffer character (Buffer_len) based (Buffer_ptr); /* Automatic */ dcl temp_ptr pointer; dcl key_idx fixed bin; dcl get_line_entry_line fixed bin; dcl get_line_entry_column fixed bin; dcl iocb_ptr pointer; dcl number_to_save fixed bin (21); dcl char_varying char (1) varying; dcl char_nonvarying char (1); dcl char_count fixed bin; dcl code fixed bin (35); dcl redisplay_buffer_ptr pointer; /* This buffer is made to be 4 times longer than the input buffer in line_editor_info. */ dcl redisplay_buffer char (2048) based (redisplay_buffer_ptr); dcl window_line_used_ptr pointer; dcl WINDOW_LINE_USED (attach_data.current.rows) bit (1) based (window_line_used_ptr); dcl lei_ptr pointer; dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl 1 automatic_line_editor_info aligned like line_editor_info; dcl saved_buffer_length fixed bin; dcl 1 saved_buffer aligned based (attach_data.saved_buffer_ptr), 2 saved_length fixed bin, 2 text char (saved_buffer_length refer (saved_buffer.saved_length)) varying; /* Global variables. */ dcl REAL_CL_INTERMEDIARY entry (1 structure aligned, 2 bit (1) unaligned, 2 bit (35) unaligned) variable; dcl BREAKS_CHANGED bit (1); dcl SAVED_BREAKS bit (128) unaligned; dcl ASYNC_EVENT label variable local; dcl ERROR_COUNT fixed bin; dcl PROCESSED_SO_FAR fixed bin; dcl cleanup condition; /* Constants */ dcl TEN_SPACES char (10) static options (constant) init (" "); dcl CONTINUATION_CHARS char (2) static options (constant) init ("\c"); dcl FORWARD_KILL bit (1) aligned static options (constant) init ("0"b); dcl BACKWARD_KILL bit (1) aligned static options (constant) init ("1"b); dcl NL char (1) static options (constant) init (" "); dcl DEL char (1) static options (constant) init (""); dcl BELL char (1) static options (constant) init (""); dcl uppercase char (26) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl lowercase char (26) static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); /* External */ dcl ( error_table_$long_record, error_table_$action_not_performed, error_table_$unimplemented_version, error_table_$bad_subr_arg, video_et_$window_status_pending, video_et_$out_of_window_bounds, video_et_$cursor_position_undefined, video_et_$capability_lacking ) ext static fixed bin (35); /* Builtins */ dcl (addcharno, addr, bin, byte, copy, divide, fixed, index, length, max, maxlength, min, mod, null, rank, reverse, rtrim, search, sign, string, substr, translate, unspec, verify) builtin; /* Entries */ dcl cu_$get_cl_intermediary entry (entry); dcl cu_$set_cl_intermediary entry (entry); nulle: /* borrow as reference entry variable */ init: entry (Iocb_ptr); iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr; attach_data_ptr = iocb_ptr -> iocb.attach_data_ptr; attach_data.saved_buffer_ptr = null (); allocate dispatch_table set (dispatch_table_ptr); /* First make all non-printing keys unbound. */ dispatch_table.key (*).type = UNDEFINED; dispatch_table.key (127).type = UNDEFINED; /* Now get the self-inserts. */ do key_idx = 32 to 126; dispatch_table.key (key_idx).type = SELF_INSERT; end; dispatch_table.key (1).type = MOVE_TO_BEGINNING_OF_LINE; /* ^A */ dispatch_table.key (2).type = BACKWARD_CHARACTER; /* ^B */ dispatch_table.key (4).type = FORWARD_DELETE_CHARACTER; /* ^D */ dispatch_table.key (5).type = MOVE_TO_END_OF_LINE;/* ^E */ dispatch_table.key (6).type = FORWARD_CHARACTER; /* ^F */ dispatch_table.key (8).type = BACKWARD_DELETE_CHARACTER; /* ^H */ dispatch_table.key (9).type = SELF_INSERT; /* ^I */ dispatch_table.key (10).type = TERMINATE_INPUT_LINE; /* ^J */ dispatch_table.key (11).type = KILL_TO_END_OF_LINE; /* ^K */ dispatch_table.key (12).type = CLEAR_WINDOW; /* ^L */ dispatch_table.key (13).type = TERMINATE_INPUT_LINE; /* ^M */ dispatch_table.key (17).type = QUOTE_CHARACTER; /* ^Q */ dispatch_table.key (20).type = TWIDDLE_CHARACTERS;/* ^T */ dispatch_table.key (21).type = MULTIPLIER; /* ^U */ dispatch_table.key (25).type = YANK_FROM_KILL_RING; /* ^Y */ dispatch_table.key (31).type = DISPLAY_EDITOR_DOCUMENTATION; /* ^_ */ dispatch_table.key (127).type = BACKWARD_DELETE_CHARACTER; /* DEL */ dispatch_table.key (rank (attach_data.kill_char)).type = KILL_TO_BEGINNING_OF_LINE; dispatch_table.key (rank (attach_data.erase_char)).type = BACKWARD_DELETE_CHARACTER; dispatch_table.key (rank (attach_data.input_escape_char)).type = PROCESS_INPUT_ESCAPE; dispatch_table.name (*), dispatch_table.description (*), dispatch_table.info_dir (*), dispatch_table.info_entry (*) = ""; attach_data.dispatch_table_ptr = dispatch_table_ptr; /* Allocate a second-level dispatch table for ESC prefix */ allocate dispatch_table set (temp_ptr); /* Start out with all unbound. */ temp_ptr -> dispatch_table.key (*).type = UNDEFINED; dispatch_table.key (27).next_table = temp_ptr; dispatch_table.key (27).type = -1; dispatch_table_ptr = temp_ptr; /* Fill in ESC prefix values. */ dispatch_table.key (rank ("0")).type = NUMBER_READER_0; dispatch_table.key (rank ("1")).type = NUMBER_READER_1; dispatch_table.key (rank ("2")).type = NUMBER_READER_2; dispatch_table.key (rank ("3")).type = NUMBER_READER_3; dispatch_table.key (rank ("4")).type = NUMBER_READER_4; dispatch_table.key (rank ("5")).type = NUMBER_READER_5; dispatch_table.key (rank ("6")).type = NUMBER_READER_6; dispatch_table.key (rank ("7")).type = NUMBER_READER_7; dispatch_table.key (rank ("8")).type = NUMBER_READER_8; dispatch_table.key (rank ("9")).type = NUMBER_READER_9; dispatch_table.key (rank ("-")).type = NEGATIVE_NUMBER_READER; dispatch_table.key (rank ("b")).type = BACKWARD_WORD; dispatch_table.key (rank ("c")).type = INITIAL_CAPITAL; dispatch_table.key (rank ("d")).type = FORWARD_DELETE_WORD; dispatch_table.key (rank ("f")).type = FORWARD_WORD; dispatch_table.key (rank ("l")).type = LOWERCASE_WORD; dispatch_table.key (rank ("t")).type = TWIDDLE_WORDS; dispatch_table.key (rank ("u")).type = UPPERCASE_WORD; dispatch_table.key (rank ("y")).type = YANK_PREVIOUS_FROM_KILL_RING; dispatch_table.key (rank ("B")).type = BACKWARD_WORD; dispatch_table.key (rank ("C")).type = INITIAL_CAPITAL; dispatch_table.key (rank ("D")).type = FORWARD_DELETE_WORD; dispatch_table.key (rank ("F")).type = FORWARD_WORD; dispatch_table.key (rank ("L")).type = LOWERCASE_WORD; dispatch_table.key (rank ("T")).type = TWIDDLE_WORDS; dispatch_table.key (rank ("U")).type = UPPERCASE_WORD; dispatch_table.key (rank ("Y")).type = YANK_PREVIOUS_FROM_KILL_RING; dispatch_table.key (rank ("?")).type = DISPLAY_EDITOR_DOCUMENTATION; dispatch_table.key (rank ("")).type = BACKWARD_DELETE_WORD; dispatch_table.key (rank (attach_data.erase_char)).type = BACKWARD_DELETE_WORD; dispatch_table.name (*), dispatch_table.description (*), dispatch_table.info_dir (*), dispatch_table.info_entry (*) = ""; return; shut: entry (Iocb_ptr); iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr; attach_data_ptr = iocb_ptr -> iocb.attach_data_ptr; call free_dispatch_tables (attach_data.dispatch_table_ptr); if attach_data.saved_buffer_ptr ^= null () then free attach_data.saved_buffer_ptr -> saved_buffer; return; free_dispatch_tables: entry (a_table_ptr); do key_idx = 0 to 127; if a_table_ptr -> dispatch_table.key (key_idx).type = -1 then call free_dispatch_tables (a_table_ptr -> dispatch_table.key (key_idx).next_table); end; free a_table_ptr -> dispatch_table; return; /* So much for the easy stuff */ edit_line: entry (Iocb_ptr, Window_edit_line_info_ptr, Buffer_ptr, Buffer_len, N_returned, Code); declare Window_edit_line_info_ptr pointer parameter; window_edit_line_info_ptr = Window_edit_line_info_ptr; if window_edit_line_info.version ^= window_edit_line_info_version_1 then do; Code = error_table_$unimplemented_version; return; end; if window_edit_line_info.line_length < 0 then do; Code = error_table_$bad_subr_arg; return; end; goto GET_LINE_COMMON; get_line: entry (Iocb_ptr, Buffer_ptr, Buffer_len, N_returned, Code); window_edit_line_info_ptr = null (); GET_LINE_COMMON: iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr; attach_data_ptr = iocb_ptr -> iocb.attach_data_ptr; Code = 0; N_returned = 0; /* Perform a reset_more. */ attach_data.discard_output = "0"b; /* Now make sure that the next async output won't more break once the user has entered the input line editor. */ attach_data.lines_written_since_read = 0; if Buffer_len = 0 | Buffer_ptr = null () then return; /* Is there stuff left over from last time? If so, just return the old stuff. This call must have occurred after one which returned error_table_$long_record. */ if attach_data.saved_buffer_ptr ^= null () then do; N_returned = min (Buffer_len, length (saved_buffer.text)); substr (Buffer, 1, N_returned) = substr (saved_buffer.text, 1, N_returned); /* Still couldn't take it all? */ if Buffer_len < length (saved_buffer.text) then do; saved_buffer.text = substr (saved_buffer.text, N_returned + 1); Code = error_table_$long_record; end; else do; free attach_data.saved_buffer_ptr -> saved_buffer; attach_data.saved_buffer_ptr = null (); end; return; end; /* Get pointer to automatic storage copy of editor state. */ lei_ptr = addr (automatic_line_editor_info); LEI.version = line_editor_info_version_2; LEI.iocb_ptr = iocb_ptr; LEI.repetition_count = 1; LEI.numarg_given = "0"b; LEI.return_from_editor = "0"b; LEI.suppress_redisplay = "0"b; /* redisplay unless the editor routine says otherwise */ LEI.line_length = 0; LEI.cursor_index = 1; LEI.input_buffer = ""; LEI.merge_next_kill = "0"b; LEI.old_merge_next_kill = "0"b; LEI.last_kill_direction = "0"b; LEI.user_data_ptr = null (); /* Put the initial text in the buffer if we were called via edit_line */ if window_edit_line_info_ptr ^= null () then do; if window_edit_line_info.line_length ^= 0 then do; begin; dcl initial_text char (window_edit_line_info.line_length) based (window_edit_line_info.line_ptr); call insert_in_buffer (lei_ptr, initial_text, Code); if Code ^= 0 then return; LEI.cursor_index = 1; /* back to the start of the line */ window_edit_line_info_ptr = null (); /* don't do this again */ end; /* begin */ end; end; /* Set up the global state variables. */ get_line_entry_line = attach_data.line; get_line_entry_column = attach_data.col; ERROR_COUNT = 0; BREAKS_CHANGED = "0"b; SAVED_BREAKS = attach_data.breaks; REAL_CL_INTERMEDIARY = nulle; redisplay_buffer_ptr = null (); window_line_used_ptr = null (); on cleanup call get_line_cleanup (); /* the cleanup handler is established, allocate storage */ alloc WINDOW_LINE_USED set (window_line_used_ptr); alloc redisplay_buffer set (redisplay_buffer_ptr); /* when something async happens in this window, go to this label */ ASYNC_EVENT = RESTART_GET_LINE; /* We change the cl_intermediary so that we can detect screen changes caused by pushing new levels. */ call cu_$get_cl_intermediary (REAL_CL_INTERMEDIARY); call cu_$set_cl_intermediary (cl_pusher); /* Check for window status or undefined cursor. */ call window_$position_cursor_rel (iocb_ptr, 0, 0, code); if code = video_et_$window_status_pending then do; if attach_data.status.reconnection | attach_data.status.ttp_change then call resize_window(); attach_data.status_pending = "0"b; string (attach_data.status) = ""b; end; else if code = video_et_$cursor_position_undefined/* define it -- assume we did rawo mode */ then do; call window_$position_cursor (iocb_ptr, attach_data.row_at_rawo, attach_data.col_at_rawo, code); call async_or_error (code); end; else if code ^= 0 then do; /* who knows what happened? */ Code = code; go to return_from_get_line; /* So we free everything */ end; /* Read and buffer an input line. The buffer always end with a linefeed, since we talk to the user till we get one */ get_input_line: call read_input_line (lei_ptr); /* Now we have a whole input line. Save it in the kill ring. */ number_to_save = LEI.line_length; if substr (LEI.input_buffer, LEI.line_length, 1) = NL then number_to_save = number_to_save - 1; if number_to_save > 0 then do; LEI.old_merge_next_kill = "0"b; if ^attach_data.suppress_echo then call add_to_kill_ring (lei_ptr, 1, number_to_save, FORWARD_KILL); end; /* Return entire line or until caller's buffer fills. */ N_returned = min (Buffer_len, LEI.line_length); substr (Buffer, 1, N_returned) = substr (LEI.input_buffer, 1, N_returned); LEI.line_length = LEI.line_length - N_returned; if LEI.line_length > 0 then do; /* Caller can't take all the input available, so save the rest until he calls in again. */ saved_buffer_length = LEI.line_length; allocate saved_buffer set (attach_data.saved_buffer_ptr); saved_buffer.text = substr (LEI.input_buffer, N_returned + 1, LEI.line_length); Code = error_table_$long_record; end; /* Start counting output lines from here. */ attach_data.lines_written_since_read = 0; call window_$sync (iocb_ptr, code); /* don't check code, we're on the way out anyway. */ return_from_get_line: call get_line_cleanup (); return; get_line_cleanup: procedure; declare 1 b aligned like break_table_info; if redisplay_buffer_ptr ^= null () then free redisplay_buffer; if window_line_used_ptr ^= null () then free WINDOW_LINE_USED; if REAL_CL_INTERMEDIARY ^= nulle then call cu_$set_cl_intermediary (REAL_CL_INTERMEDIARY); if BREAKS_CHANGED then do; b.version = break_table_info_version; string(b.breaks) = SAVED_BREAKS; call iox_$control (iocb_ptr, "set_break_table", addr (b), (0)); BREAKS_CHANGED = "0"b; end; if LEI.user_data_ptr ^= null then call free_user_data (LEI.user_data_ptr); return; end get_line_cleanup; RESTART_GET_LINE: /* Prepnl */ if attach_data.col ^= 1 then call get_to_next_line; /* reset the origin to current position */ get_line_entry_line = attach_data.line; get_line_entry_column = attach_data.col; goto get_input_line; free_user_data: procedure (leud_ptr); dcl leud_ptr pointer parameter; /* always non-null */ dcl temp_ptr ptr; dcl freen_ entry (ptr); /* Since we only have a pointers to structure headers */ dcl 1 LEUDH aligned like line_editor_user_data_header based (leud_ptr); do while (leud_ptr ^= null ()); temp_ptr = LEUDH.next_user_data_ptr; call freen_ (leud_ptr); leud_ptr = temp_ptr; end; return; end free_user_data; /* Routine to set the screen image to the current stuff on the screen. */ initialize_window_image: procedure; dcl line_idx fixed bin; dcl code fixed bin (35); call iox_$control (attach_data.target_iocb_ptr, "get_screen_image_ptr", screen_ptr, code); call async_or_error (code); do line_idx = 1 to attach_data.current.rows; window_image (line_idx) = substr (screen.lines (line_idx + attach_data.current.line_origin - 1), attach_data.column_origin, attach_data.current.columns); /* be sure to only get the stuff that is in our window */ end; WINDOW_LINE_USED = "0"b; /* Clear whole array. */ return; end initialize_window_image; /* Routine to read input, processing editor requests, until a newline is typed. May be called with a partially filled buffer if an async event occurrs. */ read_input_line: procedure (lei_ptr); dcl lei_ptr pointer parameter; dcl break_char character (1) varying; dcl number_returned fixed bin (21); dcl number_to_read fixed bin (21); dcl (read_start_line, read_start_column) fixed bin; dcl code fixed bin (35); /* this dcl limits us to terminals with screens narrower than 1024 chars */ dcl read_buffer char (1024); dcl 1 LEI aligned like line_editor_info based (lei_ptr); /* First include whatever async output may be on the screen. */ call initialize_window_image (); if LEI.line_length > 0 /* if there is old stuff, redisplay */ then call redisplay_input_line (lei_ptr); do while ("1"b); /* process_break will exit us */ /* How much screen left on this line? (and in the window!) */ number_to_read = attach_data.current.columns - attach_data.col + 1; number_returned = 0; break_char = ""; read_start_line = attach_data.line; read_start_column = attach_data.col; /* If buffer is full, do not echo negotiate. We will eventually execute a request that deletes some stuff from the buffer. */ if LEI.line_length >= length (LEI.input_buffer) then do; call window_$get_one_unechoed (iocb_ptr, break_char, "1"b, code); call async_or_error (code); end; else do; /* If buffer is almost full, read fewer chars. */ number_to_read = min (number_to_read, length (LEI.input_buffer) - LEI.line_length); /* If we are in the middle of the line or up against the right edge of the window, or echoing is off, read single chars */ if (LEI.cursor_index <= LEI.line_length) | (number_to_read <= 0) | attach_data.suppress_echo then call window_$get_one_unechoed (iocb_ptr, break_char, "1"b, code); else do; /* Put line editor breaks in effect. */ BREAKS_CHANGED = "1"b; SAVED_BREAKS = attach_data.breaks; attach_data.breaks = attach_data.line_editor_breaks; call window_$get_echoed_chars (iocb_ptr, number_to_read, read_buffer, number_returned, break_char, code); attach_data.breaks = SAVED_BREAKS; BREAKS_CHANGED = "0"b; end; end; call async_or_error (code); /* Process any echoed characters. */ if number_returned > 0 then do; LEI.merge_next_kill = "0"b; /* Add negotiated characters to input buffer. */ begin; dcl echoed_chars char (number_returned) defined (read_buffer) position (1); call insert_in_buffer (lei_ptr, echoed_chars, code); if code ^= 0 then call ring (); call add_to_window_image (echoed_chars, read_start_line, read_start_column); end; end; /* Check length, since a char(1) varying containing a space compares equal to "" */ if length (break_char) > 0 then do; LEI.repetition_count = 1; LEI.numarg_given = "0"b; call process_break (lei_ptr, break_char); if LEI.return_from_editor then do; if ^LEI.suppress_redisplay then do; call redisplay_input_line (lei_ptr); call get_to_next_line; /* should this always be done? We really need window_editor_utils_$redisplay_input_line ... sigh --- JR 5/3/84 */ end; return; end; end; call redisplay_input_line (lei_ptr); end; /* do while */ return; end read_input_line; /* The guts of the editor. This routine interprets editor requests. */ process_break: procedure (lei_ptr, break_char); dcl lei_ptr pointer parameter; dcl break_char char (1) varying parameter; dcl break char (1); dcl temp_char_varying char (1) varying; dcl code fixed bin (35); dcl (i, repeat_count) fixed bin; dcl numarg_action fixed bin; dcl editor_routine entry (pointer /* lei_ptr */, fixed bin (35) /* code */) variable; dcl 1 LEI aligned like line_editor_info based (lei_ptr); break = break_char; dispatch_table_ptr = attach_data.dispatch_table_ptr; LEI.key_sequence = break; /* Hack META characters. For now we will define META characters to simply look up the dispatch table hanging off the ESC key. If there is none, you lose. */ if (break > DEL) then do; /* Make sure that there is a META table */ if dispatch_table.key (27).type < 0 then dispatch_table_ptr = dispatch_table.key (27).next_table; else do; call window_$bell (iocb_ptr, code); call async_or_error (code); return; end; /* Turn off META bit. */ break = byte (rank (break) - 128); end; /* chase through prefix sequences to terminal character */ do while (dispatch_table.key (rank (break)).type < 0); dispatch_table_ptr = dispatch_table.key (rank (break)).next_table; call window_$get_one_unechoed (iocb_ptr, temp_char_varying, "1"b, code); call async_or_error (code); break = temp_char_varying; LEI.key_sequence = rtrim (LEI.key_sequence) || break; end; if dispatch_table.key (rank (break)).type ^= 0 then goto builtin_requests (dispatch_table.key (rank (break)).type); else do; editor_routine = dispatch_table.key (rank (break)).routine; numarg_action = dispatch_table.key (rank (break)).numarg_action; end; do_editor_request: repeat_count = 1; if numarg_action = REPEAT & LEI.numarg_given & LEI.repetition_count < 0 then do; code = error_table_$action_not_performed; goto editor_request_finish; end; if numarg_action = REPEAT & LEI.numarg_given then repeat_count = LEI.repetition_count; if numarg_action = REJECT & LEI.numarg_given then do; code = error_table_$action_not_performed; goto editor_request_finish; end; do i = 1 to repeat_count; LEI.old_merge_next_kill = LEI.merge_next_kill; LEI.merge_next_kill = "0"b; call editor_routine (lei_ptr, code); if code ^= 0 then goto editor_request_finish; if dispatch_table.key (rank (break)).type = 0 then do; /* Try to ensure consistent state */ if LEI.line_length < 0 then LEI.line_length = 0; if LEI.line_length > length (LEI.input_buffer) then LEI.line_length = length (LEI.input_buffer); if LEI.cursor_index < 1 then LEI.cursor_index = 1; if LEI.cursor_index > LEI.line_length + 1 then LEI.cursor_index = LEI.line_length + 1; end; end; /* do loop */ editor_request_finish: if code = error_table_$action_not_performed then call ring (); return; /* This label array defines the values of the type field of the dispatch table */ builtin_requests (1): editor_routine = forward_character; numarg_action = REPEAT; goto do_editor_request; builtin_requests (2): editor_routine = backward_character; numarg_action = REPEAT; goto do_editor_request; builtin_requests (3): editor_routine = forward_delete_character; numarg_action = REPEAT; goto do_editor_request; builtin_requests (4): editor_routine = backward_delete_character; numarg_action = REPEAT; goto do_editor_request; builtin_requests (5): editor_routine = move_to_end_of_line; numarg_action = IGNORE; goto do_editor_request; builtin_requests (6): editor_routine = move_to_beginning_of_line; numarg_action = IGNORE; goto do_editor_request; builtin_requests (7): editor_routine = kill_to_end_of_line; numarg_action = IGNORE; goto do_editor_request; builtin_requests (8): editor_routine = kill_to_beginning_of_line; numarg_action = IGNORE; goto do_editor_request; builtin_requests (9): editor_routine = forward_word; numarg_action = REPEAT; goto do_editor_request; builtin_requests (10): editor_routine = backward_word; numarg_action = REPEAT; goto do_editor_request; builtin_requests (11): editor_routine = forward_delete_word; numarg_action = REPEAT; goto do_editor_request; builtin_requests (12): editor_routine = backward_delete_word; numarg_action = REPEAT; goto do_editor_request; builtin_requests (13): editor_routine = quote_character; numarg_action = PASS; goto do_editor_request; builtin_requests (14): editor_routine = clear_window; numarg_action = IGNORE; goto do_editor_request; builtin_requests (15): editor_routine = twiddle_characters; numarg_action = IGNORE; goto do_editor_request; builtin_requests (16): editor_routine = display_editor_documentation; numarg_action = IGNORE; goto do_editor_request; builtin_requests (17): editor_routine = self_insert; numarg_action = REPEAT; goto do_editor_request; builtin_requests (18): editor_routine = yank_from_kill_ring; numarg_action = IGNORE; goto do_editor_request; builtin_requests (19): editor_routine = yank_previous_from_kill_ring; numarg_action = IGNORE; goto do_editor_request; builtin_requests (20): editor_routine = terminate_input_line; numarg_action = IGNORE; goto do_editor_request; builtin_requests (21): /* Unimplemented requests, etc. */ editor_routine = ring; numarg_action = IGNORE; goto do_editor_request; builtin_requests (22): editor_routine = process_input_escape; numarg_action = IGNORE; goto do_editor_request; builtin_requests (23): editor_routine = number_reader_0; numarg_action = PASS; goto do_editor_request; builtin_requests (24): editor_routine = number_reader_1; numarg_action = PASS; goto do_editor_request; builtin_requests (25): editor_routine = number_reader_2; numarg_action = PASS; goto do_editor_request; builtin_requests (26): editor_routine = number_reader_3; numarg_action = PASS; goto do_editor_request; builtin_requests (27): editor_routine = number_reader_4; numarg_action = PASS; goto do_editor_request; builtin_requests (28): editor_routine = number_reader_5; numarg_action = PASS; goto do_editor_request; builtin_requests (29): editor_routine = number_reader_6; numarg_action = PASS; goto do_editor_request; builtin_requests (30): editor_routine = number_reader_7; numarg_action = PASS; goto do_editor_request; builtin_requests (31): editor_routine = number_reader_8; numarg_action = PASS; goto do_editor_request; builtin_requests (32): editor_routine = number_reader_9; numarg_action = PASS; goto do_editor_request; builtin_requests (33): editor_routine = multiplier; numarg_action = PASS; goto do_editor_request; builtin_requests (34): editor_routine = lowercase_word; numarg_action = PASS; goto do_editor_request; builtin_requests (35): editor_routine = uppercase_word; numarg_action = PASS; goto do_editor_request; builtin_requests (36): editor_routine = initial_capital; numarg_action = PASS; goto do_editor_request; builtin_requests (37): editor_routine = twiddle_words; numarg_action = IGNORE; goto do_editor_request; builtin_requests (38): editor_routine = negative_number_reader; numarg_action = PASS; goto do_editor_request; end process_break; /* External entrypoints for user-defined editor routines. */ insert_text_: entry (a_lei_ptr, a_text, a_code); call setup_util_call; call insert_in_buffer (a_lei_ptr, a_text, a_code); return; delete_text_: entry (a_lei_ptr, a_count, a_code); call setup_util_call; call delete_from_buffer (a_lei_ptr, a_count, a_code); return; delete_text_save_: entry (a_lei_ptr, a_count, a_kill_direction, a_code); call setup_util_call; call delete_from_buffer_save (a_lei_ptr, a_count, a_kill_direction, a_code); return; move_forward_: entry (a_lei_ptr, a_count, a_code); a_code = 0; call setup_util_call; if (a_lei_ptr -> line_editor_info.cursor_index + a_count) > a_lei_ptr -> line_editor_info.line_length + 1 then a_code = error_table_$action_not_performed; else a_lei_ptr -> line_editor_info.cursor_index = a_lei_ptr -> line_editor_info.cursor_index + a_count; return; move_backward_: entry (a_lei_ptr, a_count, a_code); a_code = 0; call setup_util_call; if (a_lei_ptr -> line_editor_info.cursor_index - a_count) < 1 then a_code = error_table_$action_not_performed; else a_lei_ptr -> line_editor_info.cursor_index = a_lei_ptr -> line_editor_info.cursor_index - a_count; return; move_forward_word_: entry (a_lei_ptr, a_code); call setup_util_call; call forward_word (a_lei_ptr, a_code); return; move_backward_word_: entry (a_lei_ptr, a_code); call setup_util_call; call backward_word (a_lei_ptr, a_code); return; get_top_kill_ring_element_: entry (a_lei_ptr, a_text, a_code); call setup_util_call; a_text = killer.words; return; rotate_kill_ring_: entry (a_lei_ptr, a_code); call setup_util_call; call rotate_kill_ring (); util_call_return: return; /* Routine to setup data pointers for external routine utility entrypoints. Callers must have a_lei_ptr and a_code as parameters. */ setup_util_call: procedure; dcl error_table_$null_info_ptr fixed bin (35) ext static; dcl error_table_$unimplemented_version fixed bin (35) external static; if a_lei_ptr = null () then do; a_code = error_table_$null_info_ptr; goto util_call_return; end; if a_lei_ptr -> line_editor_info.version ^= line_editor_info_version_2 then do; a_code = error_table_$unimplemented_version; goto util_call_return; end; iocb_ptr = a_lei_ptr -> line_editor_info.iocb_ptr -> iocb.actual_iocb_ptr; attach_data_ptr = iocb_ptr -> iocb.attach_data_ptr; return; end setup_util_call; /* Utilities that actually implement the editor routines */ self_insert: /* this will work for more than one char! But is it the right thing??? */ procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl code fixed bin (35); code = 0; if LEI.key_sequence = "" /* spaces? */ then call insert_in_buffer (lei_ptr, " ", code); else call insert_in_buffer (lei_ptr, rtrim (LEI.key_sequence), code); end self_insert; backward_delete_character: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; if LEI.cursor_index > 1 then do; LEI.cursor_index = LEI.cursor_index - 1; call delete_from_buffer (lei_ptr, 1, code); end; else code = error_table_$action_not_performed; end backward_delete_character; kill_to_beginning_of_line: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl old_cursor fixed bin (21); code = 0; old_cursor = LEI.cursor_index; LEI.cursor_index = 1; call delete_from_buffer_save (lei_ptr, old_cursor - 1, BACKWARD_KILL, code); return; end kill_to_beginning_of_line; backward_character: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35) parameter; dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; if LEI.cursor_index > 1 then LEI.cursor_index = LEI.cursor_index - 1; end backward_character; forward_character: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35) parameter; dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; if LEI.cursor_index < (LEI.line_length + 1) then LEI.cursor_index = LEI.cursor_index + 1; end forward_character; move_to_beginning_of_line: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35) parameter; dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; LEI.cursor_index = 1; end move_to_beginning_of_line; move_to_end_of_line: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; LEI.cursor_index = LEI.line_length + 1; end move_to_end_of_line; forward_delete_character: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); code = 0; call delete_from_buffer (lei_ptr, 1, code); end forward_delete_character; kill_to_end_of_line: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; call delete_from_buffer_save (lei_ptr, LEI.line_length - LEI.cursor_index + 1, FORWARD_KILL, code); end kill_to_end_of_line; twiddle_characters: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl temp_char char (1); code = 0; if LEI.cursor_index > 2 then do; temp_char = substr (LEI.input_buffer, LEI.cursor_index - 2, 1); substr (LEI.input_buffer, LEI.cursor_index - 2, 1) = substr (LEI.input_buffer, LEI.cursor_index - 1, 1); substr (LEI.input_buffer, LEI.cursor_index - 1, 1) = temp_char; end; else code = error_table_$action_not_performed; end twiddle_characters; terminate_input_line: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; LEI.return_from_editor = "1"b; LEI.suppress_redisplay = "1"b; /* we will do redisplay ourselves, so the NL is hidden */ LEI.merge_next_kill = "0"b; LEI.cursor_index = LEI.line_length + 1; call redisplay_input_line (lei_ptr); /* to set cursor */ call insert_in_buffer (lei_ptr, NL, code); call get_to_next_line (); end terminate_input_line; clear_window: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); code = 0; call clear_window_image (); get_line_entry_line = 1; get_line_entry_column = 1; end clear_window; quote_character: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl temp_char_varying char (1) varying; dcl temp_index fixed bin; dcl repeat_count fixed bin; code = 0; call window_$get_one_unechoed (iocb_ptr, temp_char_varying, "1"b, code); call async_or_error (code); if LEI.numarg_given then repeat_count = LEI.repetition_count; else repeat_count = 1; do temp_index = 1 to repeat_count; call insert_in_buffer (lei_ptr, (temp_char_varying), code); end; end quote_character; yank_from_kill_ring: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; call insert_in_buffer (lei_ptr, (killer.words), code); LEI.merge_next_kill = "0"b; end yank_from_kill_ring; process_input_escape: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl input_char char (1) varying; dcl unprocessed_char char (1) varying; dcl count fixed bin (21); dcl escape_index fixed bin (21); dcl translation_idx fixed bin (21); dcl result fixed bin; code = 0; /* Remember where we started. */ escape_index = LEI.cursor_index; /* Echo the \ immediately. */ call insert_in_buffer (lei_ptr, (attach_data.input_escape_char), code); if code ^= 0 then return; call redisplay_input_line (lei_ptr); call window_$get_one_unechoed (iocb_ptr, input_char, "1"b, code); call async_or_error (code); /* Check for \nnn case. */ if (input_char >= "0") & (input_char <= "7") then do; result = fixed (input_char); /* calculate number */ call insert_in_buffer (lei_ptr, (input_char), code); if code ^= 0 then return; call redisplay_input_line (lei_ptr); unprocessed_char = ""; do count = 2 to 3 while (length (unprocessed_char) = 0); call window_$get_one_unechoed (iocb_ptr, input_char, "1"b, code); call async_or_error (code); if (input_char >= "0") & (input_char <= "7") then do; result = result * 8; result = result + fixed (input_char); call insert_in_buffer (lei_ptr, (input_char), code); if code ^= 0 then return; call redisplay_input_line (lei_ptr); end; /* got unwanted char, save it for later */ else unprocessed_char = input_char; end; /* Get rid of "\nnn" and insert the char. */ count = LEI.cursor_index - escape_index; LEI.cursor_index = escape_index; call delete_from_buffer (lei_ptr, count, code); if code ^= 0 then return; call insert_in_buffer (lei_ptr, byte (result), code); if code ^= 0 then return; /* See if recursive call is necessary. */ if length (unprocessed_char) > 0 then call process_break (lei_ptr, unprocessed_char); return; end; if input_char = BELL then do; call window_$bell (iocb_ptr, code); call async_or_error (code); /* flush the \ */ LEI.cursor_index = escape_index; call delete_from_buffer (lei_ptr, 1, code); return; end; if (input_char = attach_data.erase_char) | (input_char = attach_data.kill_char) | (input_char = attach_data.input_escape_char) then do; /* flush the \ */ LEI.cursor_index = escape_index; call delete_from_buffer (lei_ptr, 1, code); if code ^= 0 then return; /* add the char */ call insert_in_buffer (lei_ptr, (input_char), code); return; end; /* If there are input escape sequences defined, use them. */ if attach_data.special_ptr -> special_chars.input_escapes.len ^= 0 then do; translation_idx = index (attach_data.special_ptr -> special_chars.input_escapes.str, input_char); if translation_idx > 0 then do; /* flush \ */ LEI.cursor_index = escape_index; call delete_from_buffer (lei_ptr, 1, code); if code ^= 0 then return; call insert_in_buffer (lei_ptr, substr (attach_data.special_ptr -> special_chars.input_results.str, translation_idx, 1), code); return; end; end; /* Otherwise result is \ */ call insert_in_buffer (lei_ptr, (input_char), code); return; end process_input_escape; number_reader_0: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 0, code); return; end number_reader_0; number_reader_1: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 1, code); return; end number_reader_1; number_reader_2: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 2, code); return; end number_reader_2; number_reader_3: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 3, code); return; end number_reader_3; number_reader_4: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 4, code); return; end number_reader_4; number_reader_5: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 5, code); return; end number_reader_5; number_reader_6: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 6, code); return; end number_reader_6; number_reader_7: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 7, code); return; end number_reader_7; number_reader_8: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 8, code); return; end number_reader_8; number_reader_9: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); call number_reader_common (lei_ptr, 9, code); return; end number_reader_9; number_reader_common: procedure (lei_ptr, number, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); dcl number fixed binary; code = 0; if LEI.numarg_given then LEI.repetition_count = LEI.repetition_count * 10 + number; else LEI.repetition_count = number; call read_numbers_then_dispatch (lei_ptr, "0"b /* not multiplier */, "0"b /* accummulate digits */, code); return; end number_reader_common; multiplier: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; if LEI.numarg_given then LEI.repetition_count = LEI.repetition_count * 4; else LEI.repetition_count = 4; call read_numbers_then_dispatch (lei_ptr, "1"b /* multiplier */, "1"b /* don't accummulate digits */, code); return; end multiplier; negative_number_reader: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; LEI.repetition_count = -1; call read_numbers_then_dispatch (lei_ptr, "0"b /* not multiplier */, "1"b /* don't accumulate digits */, code); return; end negative_number_reader; read_numbers_then_dispatch: procedure (lei_ptr, multiplier_flag, replace_count_flag, code); dcl lei_ptr pointer parameter; dcl code fixed binary (35); dcl multiplier_flag bit (1); dcl replace_count_flag bit (1); /* replace LEI.repetition_count if we get a digit, instead of adding to it */ dcl next_char char (1) varying; dcl 1 LEI aligned like line_editor_info based (lei_ptr); LEI.numarg_given = "1"b; get_more: call window_$get_one_unechoed (iocb_ptr, next_char, "1"b, code); call async_or_error (code); if multiplier_flag & next_char = "-" then /* let the multiplier enter negative numeric args */ do; LEI.repetition_count = -4; replace_count_flag = "1"b; multiplier_flag = "0"b; goto get_more; end; if next_char >= "0" & next_char <= "9" then do; if replace_count_flag then do; LEI.repetition_count = fixed (next_char) * sign (LEI.repetition_count); replace_count_flag = "0"b; end; else if LEI.repetition_count = 0 then LEI.repetition_count = fixed (next_char); /* handle leading zero */ else LEI.repetition_count = LEI.repetition_count * 10 + fixed (next_char) * sign (LEI.repetition_count); goto get_more; end; else do; call process_break (lei_ptr, (next_char)); return; end; end read_numbers_then_dispatch; backward_word: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); code = 0; call move_backward_word (lei_ptr); end backward_word; forward_word: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); code = 0; call move_forward_word (lei_ptr); end forward_word; forward_delete_word: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl count fixed bin (21); dcl old_cursor fixed bin (21); code = 0; old_cursor = LEI.cursor_index; call move_forward_word (lei_ptr); count = LEI.cursor_index - old_cursor; LEI.cursor_index = old_cursor; call delete_from_buffer_save (lei_ptr, count, FORWARD_KILL, code); return; end forward_delete_word; backward_delete_word: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl count fixed bin (21); dcl old_cursor fixed bin (21); code = 0; old_cursor = LEI.cursor_index; call move_backward_word (lei_ptr); count = old_cursor - LEI.cursor_index; call delete_from_buffer_save (lei_ptr, count, BACKWARD_KILL, code); end backward_delete_word; yank_previous_from_kill_ring: procedure (lei_ptr, code); dcl lei_ptr pointer parameter; dcl code fixed bin (35); dcl 1 LEI aligned like line_editor_info based (lei_ptr); code = 0; /* Make sure that we don't subscript out of bounds */ if (LEI.cursor_index > length (killer.words)) /* Are we sitting after contents of top kill ring element? */ then if substr (LEI.input_buffer, LEI.cursor_index - length (killer.words), length (killer.words)) = killer.words then do; LEI.cursor_index = LEI.cursor_index - length (killer.words); call delete_from_buffer (lei_ptr, length (killer.words), code); if code ^= 0 then return; call rotate_kill_ring (); call insert_in_buffer (lei_ptr, (killer.words), code); return; end; code = error_table_$action_not_performed; return; end yank_previous_from_kill_ring; display_editor_documentation: procedure (lei_ptr, code); dcl lei_ptr parameter pointer; dcl code fixed bin; dcl ioa_ entry options (variable); /*** This needs to be clevered up about key bindings */ call ioa_ ( "^/^^A, ^^E, ^^F, ^^B, ^^D, DEL, ^a, ^^K, ^^Y, ^^L, ^^T, ESC-F, ESC-B,^/ESC-D, ESC-DEL, ESC-Y, ESC-C, ESC-L, ESC-U, ESC-T, ESC-?" , attach_data.kill_char); /* Now do the awful things necessary to incorporate the output from the ioa_ call into the screen image and redisplay the input line in the correct location. */ get_line_entry_line = attach_data.line; get_line_entry_column = attach_data.col; call initialize_window_image (); /* include stuff in redisplay */ return; end display_editor_documentation; lowercase_word: procedure (lei_ptr, code); dcl lei_ptr parameter pointer; dcl code fixed binary (35); dcl (start, end) fixed binary; dcl (i, repeat_count) fixed binary; dcl uppercase_flag bit (1); dcl 1 LEI like line_editor_info based (lei_ptr); uppercase_flag = "0"b; goto case_common; uppercase_word: entry (lei_ptr, code); uppercase_flag = "1"b; case_common: code = 0; repeat_count = 1; if LEI.numarg_given & LEI.repetition_count < 0 then do; /* no negative args for now */ call ring (); return; end; if LEI.numarg_given then repeat_count = LEI.repetition_count; do i = 1 to repeat_count; call get_current_word_info (lei_ptr, start, end); begin; dcl word char (end - start) defined (LEI.input_buffer) position (start); if uppercase_flag then word = translate (word, uppercase, lowercase); else word = translate (word, lowercase, uppercase); end; /* begin */ call move_forward_word (lei_ptr); /* get to end of current word */ call move_forward_word (lei_ptr); /* get to end of next word for the repeat case */ if LEI.cursor_index = end /* end of input buffer, the last forward_word did nothing */ then do; if LEI.numarg_given & i < repeat_count then call ring (); /* only ring if user gave a numaric arg which is too big */ return; end; end; /* do loop */ call move_backward_word (lei_ptr); /* undo the extra forward_word */ call move_backward_word (lei_ptr); /* must do twice */ call move_forward_word (lei_ptr); return; /* end uppercase_word; */ end lowercase_word; initial_capital: procedure (lei_ptr, code); dcl lei_ptr parameter pointer; dcl code fixed binary (35); dcl (start, end) fixed binary; dcl (i, repeat_count) fixed binary; dcl 1 LEI like line_editor_info based (lei_ptr); code = 0; repeat_count = 1; if LEI.numarg_given & LEI.repetition_count < 0 then do; /* no negative args for now */ call ring (); return; end; if LEI.numarg_given then repeat_count = LEI.repetition_count; LEI.numarg_given = "0"b; /* fool lowercase_word */ do i = 1 to repeat_count; call lowercase_word (lei_ptr, code); if code ^= 0 then return; call get_current_word_info (lei_ptr, start, end); begin; dcl first_letter char (1) defined (LEI.input_buffer) position (start); first_letter = translate (first_letter, uppercase, lowercase); end; /* begin */ call move_forward_word (lei_ptr); /* get to end of current word */ call move_forward_word (lei_ptr); /* get to end of next word for the repeat case */ if LEI.cursor_index = end /* end of input buffer, the last forward_word did nothing */ then do; if repeat_count > 1 & i < repeat_count /* we bashed LEI.numarg_given above */ then call ring (); /* only ring if user gave a numaric arg which is too big */ return; end; end; /* do loop */ call move_backward_word (lei_ptr); /* undo the extra forward_word */ call move_backward_word (lei_ptr); /* must do twice */ call move_forward_word (lei_ptr); return; end initial_capital; twiddle_words: procedure (lei_ptr, code); dcl lei_ptr parameter pointer; dcl code fixed binary (35); dcl (start, end) fixed binary; dcl (start2, end2) fixed binary; dcl 1 LEI like line_editor_info based (lei_ptr); code = 0; call get_current_word_info (lei_ptr, start, end); if start = 1 then do; /* we are in the first word on the line, let's try to twiddle the first two words (if there are two of them) */ call move_forward_word (lei_ptr); call move_forward_word (lei_ptr); call get_current_word_info (lei_ptr, start, end); end; begin; dcl word char (end - start); word = substr (LEI.input_buffer, LEI.cursor_index, end - start); call delete_from_buffer (lei_ptr, end - start, code); if code ^= 0 then return; call move_backward_word (lei_ptr); if code ^= 0 then return; start2 = LEI.cursor_index; call move_forward_word (lei_ptr); if code ^= 0 then return; end2 = LEI.cursor_index; begin; dcl word2 char (end2 - start2); word2 = substr (LEI.input_buffer, start2, end2 - start2); LEI.cursor_index = start; call insert_in_buffer (lei_ptr, rtrim (word2), code); if code ^= 0 then return; end; LEI.cursor_index = start2; call delete_from_buffer (lei_ptr, end2 - start2, code); if code ^= 0 then return; call insert_in_buffer (lei_ptr, rtrim (word), code); if code ^= 0 then return; call move_forward_word (lei_ptr); end; return; end twiddle_words; get_current_word_info: procedure (lei_ptr, start, end); /* return the start and end postions and the "current" word. Do something reasonable if we are in the middle of words */ /* leaves line_editor_info.cursor_index set to the start of the word */ dcl (start, end) fixed binary; dcl lei_ptr parameter pointer; dcl 1 LEI like line_editor_info based (lei_ptr); start = LEI.cursor_index; call move_forward_word (lei_ptr); end = LEI.cursor_index; call move_backward_word (lei_ptr); if LEI.cursor_index <= start then do; /* start is in the middle of the word */ start = LEI.cursor_index; call move_forward_word (lei_ptr); end = LEI.cursor_index; LEI.cursor_index = start; end; else do; /* we were at the end of a word, the foward word has screwed us */ call move_backward_word (lei_ptr); start = LEI.cursor_index; call move_forward_word (lei_ptr); end = LEI.cursor_index; LEI.cursor_index = start; end; end get_current_word_info; /* Routine to clear the internal window image. Called from ^L, etc. */ clear_window_image: procedure (); window_image = ""; WINDOW_LINE_USED = "0"b; return; end clear_window_image; /* Utilities for manipulating words within the buffer. */ move_forward_word: procedure (lei_ptr); dcl lei_ptr pointer parameter; dcl token_start_index fixed bin; dcl token_end_index fixed bin; dcl 1 LEI aligned like line_editor_info based (lei_ptr); begin; dcl buffer_chunk char (LEI.line_length - LEI.cursor_index + 1) defined (LEI.input_buffer) position (LEI.cursor_index); /* First skip to beginning of word. */ token_start_index = search (buffer_chunk, valid_token_characters); if token_start_index = 0 then return; /* No more words. */ /* Now skip over token itself. */ token_end_index = verify (substr (buffer_chunk, token_start_index), valid_token_characters); if token_end_index = 0 /* word at end of line */ then LEI.cursor_index = LEI.line_length + 1; else LEI.cursor_index = LEI.cursor_index + token_start_index + token_end_index - 2; return; end; end move_forward_word; move_backward_word: procedure (lei_ptr); dcl lei_ptr pointer parameter; dcl token_start_index fixed bin; dcl token_end_index fixed bin; dcl 1 LEI aligned like line_editor_info based (lei_ptr); begin; dcl buffer_chunk char (LEI.cursor_index - 1) defined (LEI.input_buffer) position (1); /* First skip to end of previous word. */ token_start_index = search (reverse (buffer_chunk), valid_token_characters); if token_start_index = 0 then return; /* No more words. */ /* Now skip over token itself. */ token_end_index = verify (substr (reverse (buffer_chunk), token_start_index), valid_token_characters); if token_end_index = 0 /* word at beginning of line */ then LEI.cursor_index = 1; else LEI.cursor_index = LEI.cursor_index - token_start_index - token_end_index + 2; return; end; end move_backward_word; /* Utility routines to manage the editor's input buffer. */ insert_in_buffer: procedure (lei_ptr, text, code); dcl lei_ptr pointer parameter; dcl text char (*) parameter; dcl code fixed bin (35) parameter; dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl copy_count fixed bin; code = 0; /* If there isn't enough room in the buffer for the entire string, don't insert any of it. */ if length (text) > (length (LEI.input_buffer) - LEI.line_length) then code = error_table_$action_not_performed; else do; /* Open up space for the text and insert it. */ copy_count = LEI.line_length - LEI.cursor_index + 1; /* must use copy builtin to avoid MLR screw. */ substr (LEI.input_buffer, LEI.cursor_index + length (text), copy_count) = copy (substr (LEI.input_buffer, LEI.cursor_index, copy_count), 1); substr (LEI.input_buffer, LEI.cursor_index, length (text)) = text; LEI.line_length = LEI.line_length + length (text); LEI.cursor_index = LEI.cursor_index + length (text); end; return; end insert_in_buffer; delete_from_buffer: procedure (lei_ptr, delete_count, code); dcl lei_ptr pointer parameter; dcl delete_count fixed bin (21) parameter; dcl kill_direction bit (1) aligned parameter; dcl code fixed bin (35) parameter; dcl 1 LEI aligned like line_editor_info based (lei_ptr); dcl save_on_kill_ring bit (1); dcl move_count fixed bin; save_on_kill_ring = "0"b; goto common_delete; delete_from_buffer_save: entry (lei_ptr, delete_count, kill_direction, code); save_on_kill_ring = "1"b; common_delete: code = 0; /* If there aren't enough caracters in the buffer, do nothing. */ if (delete_count + LEI.cursor_index - 1) > LEI.line_length then code = error_table_$action_not_performed; else do; if save_on_kill_ring then call add_to_kill_ring (lei_ptr, LEI.cursor_index, delete_count, kill_direction); move_count = LEI.line_length - LEI.cursor_index - delete_count + 1; substr (LEI.input_buffer, LEI.cursor_index, move_count) = substr (LEI.input_buffer, LEI.cursor_index + delete_count, move_count); LEI.line_length = LEI.line_length - delete_count; end; return; end delete_from_buffer; /* Routines for managing the window image and performing redsiplay. The basic idea is that most changes will be reflected through the regular redisplay process. However, some editor requests deal with the screen image instead of the editor buffer, so we need routines to modify the image directly. */ /* Routine to add to the window image text that has already been echoed to the screen by a call to window_$get_echoed_chars. */ add_to_window_image: procedure (text, line, column); dcl text char (*) parameter; dcl line fixed bin parameter; dcl column fixed bin parameter; substr (window_image (line), column, length (text)) = text; WINDOW_LINE_USED (line) = "1"b; return; end add_to_window_image; /* Main redisplay routine. Performs output conversions on all characters in the input buffer, and then splits up the converted string into lines as wide as the screen and writes them into the window image. We rely on window_display_ to perform redisplay optimizations. */ redisplay_input_line: procedure (lei_ptr); dcl lei_ptr ptr parameter; dcl converted_cursor fixed bin (21); dcl converted_length fixed bin (21); dcl last_character_line fixed bin; dcl last_character_column fixed bin; dcl cursor_line fixed bin; dcl cursor_column fixed bin; dcl line fixed bin; dcl window_width fixed bin; dcl processed fixed bin (21); dcl line_offset fixed bin; dcl input_buffer char (LEI.line_length) defined (LEI.input_buffer) position (1); dcl window_display_ entry (ptr, (*) char (*), fixed bin (35)); if attach_data.suppress_echo then do; redisplay_buffer = ""; converted_length = length (input_buffer); converted_cursor = LEI.cursor_index; end; else call perform_output_conversions (input_buffer, 1, redisplay_buffer, converted_length, LEI.cursor_index, converted_cursor); window_width = attach_data.current.columns; processed = 0; /* First clear old input redisplay. */ substr (window_image (get_line_entry_line), get_line_entry_column) = ""; WINDOW_LINE_USED (get_line_entry_line) = "0"b; do line = (get_line_entry_line + 1) to attach_data.current.rows, 1 to (get_line_entry_line - 1); if WINDOW_LINE_USED (line) then do; window_image (line) = ""; WINDOW_LINE_USED (line) = "0"b; end; end; /* Then fill in first line. */ line = get_line_entry_line; /* Take one window line or as much as there is. */ processed = min (converted_length, window_width - get_line_entry_column + 1); substr (window_image (line), get_line_entry_column) = substr (redisplay_buffer, 1, processed); WINDOW_LINE_USED (line) = "1"b; last_character_line = line; last_character_column = get_line_entry_column + processed - 1; /* Now loop through filling in entire screen lines. */ window_width = window_width - length (CONTINUATION_CHARS); do while ((converted_length - processed) > window_width); line = line + 1; if line > attach_data.current.rows then if attach_data.more_mode = MORE_MODE_SCROLL then do; call scroll_window_image; line = attach_data.current.rows; end; else line = 1; window_image (line) = CONTINUATION_CHARS || substr (redisplay_buffer, processed + 1, window_width); WINDOW_LINE_USED (line) = "1"b; processed = processed + window_width; last_character_line = line; last_character_column = attach_data.current.columns; end; /* Now finish up with last line. */ if (converted_length > processed) then do; line = line + 1; if line > attach_data.current.rows then if attach_data.more_mode = MORE_MODE_SCROLL then do; call scroll_window_image; line = attach_data.current.rows; end; else line = 1; window_image (line) = CONTINUATION_CHARS || substr (redisplay_buffer, processed + 1, converted_length - processed); WINDOW_LINE_USED (line) = "1"b; last_character_line = line; last_character_column = (converted_length - processed) + length (CONTINUATION_CHARS); end; call window_display_ (iocb_ptr, window_image, code); call async_or_error (code); if (LEI.cursor_index > LEI.line_length) then do; /* We know right where to put cursor. */ cursor_line = last_character_line; cursor_column = last_character_column + 1; end; else do; /* We need to calculate an arbitrary cursor position. */ /* fudge here to get phantom col to work right. */ line_offset = divide (converted_cursor + (get_line_entry_column - 1) - length (CONTINUATION_CHARS) - 1, window_width, 17, 0); line_offset = max (0, line_offset); cursor_line = get_line_entry_line + line_offset; /* Now see if we went over bottom window boundary. */ if cursor_line > attach_data.current.rows then cursor_line = cursor_line - attach_data.current.rows; /* Compute the cursor column, allowing for continuation chars. */ cursor_column = mod (converted_cursor + (get_line_entry_column - 1) + (line_offset * length (CONTINUATION_CHARS)), attach_data.current.columns); if cursor_column = 0 then cursor_column = attach_data.current.columns; end; call window_$position_cursor (iocb_ptr, cursor_line, cursor_column, code); call async_or_error (code); return; scroll_window_image: procedure; dcl line fixed bin; do line = 1 to (attach_data.current.rows - 1); window_image (line) = window_image (line + 1); WINDOW_LINE_USED (line) = WINDOW_LINE_USED (line + 1); end; call window_$scroll_region (iocb_ptr, 1, attach_data.current.rows, -1, code); call async_or_error (code); /* Update our entry line for redisplay. If the first line of input display scrolls off the top, who knows what to do? */ if (get_line_entry_line > 1) then get_line_entry_line = get_line_entry_line - 1; else get_line_entry_column = 1; /* have lost 1st line */ return; end scroll_window_image; end redisplay_input_line; /* Utility to perform actual output conversions. Called by input side to convert the entire input buffer. Any character in it must be ordinary or have been explicitly quoted to get there. Returns the index in the output string of the char that the cursor points at in the input string. */ perform_output_conversions: procedure (input_string, start_index, output_string, chars_returned, cursor_index, converted_cursor_index); dcl input_string char (*) parameter; dcl start_index fixed bin (21) parameter; dcl output_string char (*) parameter; dcl chars_returned fixed bin (21) parameter; dcl cursor_index fixed bin (21) parameter; dcl converted_cursor_index fixed bin (21) parameter; dcl char_index fixed bin (21); dcl char_type fixed bin; dcl start fixed bin (21); dcl chars_seen fixed bin (21); dcl converted_length fixed bin; converted_cursor_index = 0; output_string = ""; chars_returned = 0; start = start_index; do while (start <= length (input_string)); /* define a substring of input_string containing the chars that haven't been processed yet. */ begin; dcl new_input char (length (input_string) - start + 1) defined (input_string) position (start); call scan_for_interesting_char (new_input, 1, char_index, char_type); /* Find the index in the output string of the cursor specified in the input string. */ if char_index = 0 then chars_seen = length (input_string) + 1; else chars_seen = start + char_index - 1; /* Find out if cursor_index is in chunk we just processed */ if (converted_cursor_index = 0) & (cursor_index >= start) & (cursor_index <= chars_seen) then converted_cursor_index = chars_returned + cursor_index - start + 1; if char_index = 0 /* no more odd chars */ then do; substr (output_string, chars_returned + 1) = new_input; chars_returned = chars_returned + length (new_input); start = length (input_string) + 1; end; else do; substr (output_string, chars_returned + 1) = substr (new_input, 1, char_index - 1); chars_returned = chars_returned + char_index - 1; /* Make sure no wierd chars get through. */ if (char_type = OUTPUT_CONVERT_RRS) | (char_type = OUTPUT_CONVERT_BRS) then char_type = OUTPUT_CONVERT_OCTAL; /* Output convert the interesting char. */ substr (output_string, chars_returned + 1) = convert_char (substr (new_input, char_index, 1), char_type, chars_returned + 1, converted_length); chars_returned = chars_returned + converted_length; start = start + char_index; end; end; /* begin block */ end; /* do while */ /* The cursor_index should never be zero, even for a zero length input buffer. */ if (converted_cursor_index = 0) then converted_cursor_index = chars_returned + 1; return; end perform_output_conversions; scan_for_interesting_char: procedure (text, start_index, char_index, char_type); dcl text char (*) parameter; dcl start_index fixed bin (21) parameter; dcl char_index fixed bin (21) parameter; dcl char_type fixed bin parameter; dcl temp_char char (1); dcl find_char_$translate_first_in_table entry (char(*), char(512) aligned, fixed bin(21)) returns (char(1)); dcl defined_text char (length (text) - start_index + 1) defined (text) position (start_index); temp_char = find_char_$translate_first_in_table (defined_text, attach_data.conversion_tct_table, char_index); char_type = rank (temp_char); return; output_convert_one_character: entry (char) returns (fixed bin); dcl char char (1) parameter; temp_char = substr (attach_data.conversion_tct_table, rank (char) + 1, 1); return (rank (temp_char)); end scan_for_interesting_char; convert_char: procedure (char, char_type, current_hpos, converted_length) returns (char (32) varying); dcl char char (1) parameter; dcl char_type fixed bin parameter; dcl current_hpos fixed bin parameter; dcl converted_length fixed bin parameter; converted_length = 0; if char_type = OUTPUT_CONVERT_HT then do; converted_length = 10 - mod (current_hpos - 1, 10); return (substr (TEN_SPACES, 1, converted_length)); end; if (char_type = OUTPUT_CONVERT_OCTAL) | (char_type = OUTPUT_CONVERT_CR) | (char_type = OUTPUT_CONVERT_BS) then do; /* quickest, dirtiest octal converter we could think of */ convert_octal_rep: begin; dcl octal_rep char (4); dcl 1 decomp unaligned, 2 digit_1 fixed bin (3) unsigned, 2 digit_2 fixed bin (3) unsigned, 2 digit_3 fixed bin (3) unsigned; dcl digit_table (0:7) char (1) static options (constant) init ("0", "1", "2", "3", "4", "5", "6", "7"); if attach_data.flags.edited then return(""); /* punt if we are in edited mode */ unspec (decomp) = unspec (char); substr (octal_rep, 1, 1) = attach_data.input_escape_char; substr (octal_rep, 2, 1) = digit_table (decomp.digit_1); substr (octal_rep, 3, 1) = digit_table (decomp.digit_2); substr (octal_rep, 4, 1) = digit_table (decomp.digit_3); converted_length = 4; return (octal_rep); end; /* begin */ end; /* do */ if char_type = OUTPUT_CONVERT_ORDINARY then do; converted_length = 1; return (char); end; if (char_type = OUTPUT_CONVERT_RRS) then return ( convert_special_sequence (attach_data.special_ptr -> special_chars.red_ribbon_shift, converted_length) ); if (char_type = OUTPUT_CONVERT_BRS) then return ( convert_special_sequence (attach_data.special_ptr -> special_chars.black_ribbon_shift, converted_length)); if (char_type >= OUTPUT_CONVERT_FIRST_SPECIAL) /* assume that the special translations always consist of regular printing characters. */ then if ^attach_data.flags.edited then return ( convert_special_sequence (attach_data.special_ptr -> special_chars.not_edited_escapes (char_type - OUTPUT_CONVERT_FIRST_SPECIAL + 1), converted_length)); else return ( convert_special_sequence (attach_data.special_ptr -> special_chars.edited_escapes (char_type - OUTPUT_CONVERT_FIRST_SPECIAL + 1), converted_length)); /* Otherwise, assume octal coversion. */ goto convert_octal_rep; convert_special_sequence: procedure (c_chars_struc, special_length) returns (char (15) varying); dcl 1 c_chars_struc aligned like c_chars parameter; dcl special_length fixed bin; dcl special_string char (c_chars_struc.count) defined (c_chars_struc.chars) position (1); special_length = length (special_string); return (special_string); end convert_special_sequence; end convert_char; get_to_next_line: procedure; /* Used on put_chars side to get to next line. */ attach_data.lines_written_since_read = attach_data.lines_written_since_read + 1; if attach_data.line < attach_data.current.rows then do; call window_$position_cursor (iocb_ptr, attach_data.line + 1, 1, code); /* simple case */ call async_or_error (code); call clear_to_end_of_line; /* comes out neater this way */ end; else do; goto more_type (attach_data.more_mode); more_type (1): /* MORE_MODE_SCROLL */ call window_$scroll_region (iocb_ptr, 1, attach_data.current.rows, -1, code); if code = video_et_$capability_lacking /* this shouldn't happen, but just in case */ then goto more_type (MORE_MODE_WRAP); call async_or_error (code); call window_$position_cursor (iocb_ptr, attach_data.line, 1, code); call async_or_error (code); go to moved; more_type (2): /* MORE_MODE_CLEAR */ call window_$clear_window (iocb_ptr, code); call async_or_error (code); go to moved; more_type (3): /* MORE_MODE_WRAP */ more_type (4): /* MORE_MODE_FOLD */ call window_$position_cursor (iocb_ptr, 1, 1, code); call async_or_error (code); call clear_to_end_of_line; moved: end; end get_to_next_line; /* Routine to actually do output conversion on text and send it on to window_. */ put_out_chars: procedure (text); dcl text char (*) parameter; dcl text_ptr pointer; dcl line_left fixed bin; dcl ordinary_count fixed bin (21); dcl temp_count fixed bin (21); dcl interesting_char_index fixed bin (21); dcl interesting_char_type fixed bin; dcl interesting_char char (1); dcl char_rep char (32) varying; dcl char_temp char (32); dcl char_rep_length fixed bin; dcl (saved_line, saved_column) fixed bin; text_ptr = addr (text); PROCESSED_SO_FAR = 0; /* kept globally for async restart */ line_left = attach_data.current.columns - attach_data.col + 1; do while (PROCESSED_SO_FAR < length (text)); /* search for the first non-vanilla character */ call scan_for_interesting_char (text, PROCESSED_SO_FAR + 1, interesting_char_index, interesting_char_type); if interesting_char_index = 0 then ordinary_count = length (text) - PROCESSED_SO_FAR; else do; ordinary_count = (interesting_char_index - 1); interesting_char_index = interesting_char_index + PROCESSED_SO_FAR; end; /* Process ordinary characters. */ /* If this is the end of a line, rtrim the text. */ if (interesting_char_type = OUTPUT_CONVERT_NEWLINE) then do; temp_count = length (rtrim (substr (text, PROCESSED_SO_FAR + 1, ordinary_count))); call write_with_continuation (text_ptr, temp_count, line_left); end; else call write_with_continuation (text_ptr, ordinary_count, line_left); PROCESSED_SO_FAR = PROCESSED_SO_FAR + ordinary_count; text_ptr = addcharno (text_ptr, ordinary_count); /* now handle the special character, if any */ if interesting_char_index ^= 0 then do; PROCESSED_SO_FAR = PROCESSED_SO_FAR + 1; text_ptr = addcharno (text_ptr, 1); interesting_char = substr (text, interesting_char_index, 1); char_rep = convert_char (interesting_char, interesting_char_type, attach_data.current.columns - line_left + 1, char_rep_length); if (interesting_char_type = OUTPUT_CONVERT_NEWLINE) then do; call get_to_next_line; line_left = attach_data.current.columns; end; /* Eliminate CR from the output stream for now. */ else if (interesting_char_type = OUTPUT_CONVERT_CR) then ; /* Special case BELL to beep. */ else if (interesting_char = BELL) then call ring (); /* Handle FF in vertsp mode. */ else if ((interesting_char_type = OUTPUT_CONVERT_FF) | (interesting_char_type = OUTPUT_CONVERT_VT)) & attach_data.vertsp then do; /* What does vertsp mean in video? For now, cause a more break. */ if (attach_data.more_mode = MORE_MODE_SCROLL) | (attach_data.more_mode = MORE_MODE_FOLD) then do; call get_to_next_line (); attach_data.lines_written_since_read = attach_data.current.rows + 1; end; else do; /* WRAP or CLEAR */ call window_$clear_to_end_of_window (iocb_ptr, code); call async_or_error (code); call window_$position_cursor (iocb_ptr, attach_data.current.rows, 1, code); call async_or_error (code); end; end; /* Handle red/black shifts. */ else if (interesting_char_type = OUTPUT_CONVERT_RRS) | (interesting_char_type = OUTPUT_CONVERT_BRS) then if attach_data.red then do; saved_line = attach_data.line; saved_column = attach_data.col; call raw_write ((char_rep)); call window_$position_cursor (iocb_ptr, saved_line, saved_column, code); call async_or_error (code); end; else ; /* Assume that anything else has been handled by convert_char and can be printed. */ else do; char_temp = char_rep; call write_with_continuation (addr (char_temp), length (char_rep), line_left); end; end; /* if interesting chars */ end; /* main do loop */ write_with_continuation: procedure (text_ptr, text_length, line_left); dcl text_ptr pointer parameter; dcl text_length fixed bin (21) parameter; dcl line_left fixed bin parameter; dcl chars_left_to_write fixed bin; dcl start_idx fixed bin (21); dcl start_ptr pointer; start_idx = 1; start_ptr = text_ptr; /* Write out chunks as long as the screen is wide. */ do while ((text_length - start_idx + 1) > line_left); call write_string (start_ptr, line_left); call get_to_next_line; call write_string (addr (CONTINUATION_CHARS), length (CONTINUATION_CHARS)); start_idx = start_idx + line_left; start_ptr = addcharno (start_ptr, line_left); line_left = attach_data.current.columns - length (CONTINUATION_CHARS); end; /* Now write out the remaining short line. */ chars_left_to_write = text_length - start_idx + 1; call write_string (start_ptr, chars_left_to_write); line_left = line_left - chars_left_to_write; return; end write_with_continuation; write_string: procedure (text_ptr, text_length); dcl text_ptr pointer parameter; dcl text_length fixed bin parameter; dcl text char (text_length) based (text_ptr); call check_more (); call window_$overwrite_text (iocb_ptr, text, code); call async_or_error (code); return; end write_string; end put_out_chars; /* ***** Kill Ring Management ***** Contiguous killed text is saved in a single buffer. We try to look like Emacs. Killed buffers are linked in a ring. The top item on the ring is given by attach_data.top_killer. The ring rotates towards killer.next. A new item is added before the top, and the old top is the new second. Killers are either in the ring or on the free list (attach_data.army). If the last request was also a kill, we add the new killed stuff to the existing kill ring element. */ add_to_kill_ring: procedure (lei_ptr, start_idx, char_count, kill_direction); dcl lei_ptr pointer parameter; dcl start_idx fixed bin (21) parameter; dcl char_count fixed bin (21) parameter; dcl kill_direction bit (1) aligned parameter; dcl killer_count fixed bin; dcl current_killer pointer; dcl KILL_RING_SIZE fixed bin static options (constant) init (10); dcl text_to_add char (char_count) defined (LEI.input_buffer) position (start_idx); dcl 1 LEI like line_editor_info based (lei_ptr); current_killer = attach_data.top_killer; /* If what we are adding is already in the ring, and we are not merging this kill, punt. */ if ^LEI.old_merge_next_kill & (text_to_add = killer.words) then return; /* The size of the kill ring is managed here. The length should be kept somewhere so we don't have to count each time. */ current_killer = current_killer -> killer.next; do killer_count = 1 by 1 while (current_killer ^= attach_data.top_killer); current_killer = current_killer -> killer.next; end; if killer_count > KILL_RING_SIZE then do; current_killer = current_killer -> killer.prev; call free_killer (current_killer); end; /* now go on with the actual killing */ /* If we aren't merging this kill with another and the top kill ring element is not empty, allocate a new one. */ if ^LEI.old_merge_next_kill & (killer.words ^= "") then call insert_new_kill_ring_element (); LEI.merge_next_kill = "1"b; LEI.last_kill_direction = kill_direction; do while (length (text_to_add) + length (killer.words) > maxlength (killer.words)); call expand_kill_ring_element (); end; if kill_direction = FORWARD_KILL then killer.words = killer.words || text_to_add; else killer.words = text_to_add || killer.words; return; end add_to_kill_ring; rotate_kill_ring: procedure (); attach_data.top_killer = killer.next; return; end rotate_kill_ring; /* The following are utilities used by above kill ring routines. */ insert_new_kill_ring_element: procedure (); dcl k ptr; k = attach_data.top_killer; /* old top */ attach_data.top_killer = get_free_killer (); /* from free list */ if attach_data.top_killer = null () /* were none */ then attach_data.top_killer = alloc_killer (); killer.next = k; /* old top */ killer.prev = k -> killer.prev; k -> killer.prev = attach_data.top_killer; killer.prev -> killer.next = attach_data.top_killer; killer.words = ""; return; end insert_new_kill_ring_element; get_free_killer: procedure returns (ptr); declare t ptr; /* the free list (army) is only forward threaded through killer.next */ t = attach_data.army; /* first on free list */ if t ^= null () then attach_data.army = t -> killer.next; return (t); end get_free_killer; alloc_killer: procedure returns (pointer); dcl new pointer; killer_alloc_size = killer_initial_alloc_size; allocate killer in (attach_data_area) set (new); new -> killer.next, new -> killer.prev = null (); new -> killer.words = ""; return (new); end alloc_killer; free_killer: procedure (killer_ptr); declare killer_ptr pointer; /* adds a killer to the free list, unchaining it from the ring */ killer_ptr -> killer.prev -> killer.next = killer_ptr -> killer.next; killer_ptr -> killer.next -> killer.prev = killer_ptr -> killer.prev; killer_ptr -> killer.next = attach_data.army; attach_data.army = killer_ptr; return; end free_killer; expand_kill_ring_element: procedure; declare k ptr; killer_alloc_size = killer.max_size * 2; allocate killer in (attach_data_area) set (k); k -> killer.words = killer.words; if killer.next = addr (killer) /* self-ref */ then k -> killer.next = k; else do; k -> killer.next = killer.next; killer.next -> killer.prev = k; end; if killer.prev = addr (killer) then k -> killer.prev = k; else do; k -> killer.prev = killer.prev; killer.prev -> killer.next = k; end; free attach_data.top_killer -> killer in (attach_data_area); attach_data.top_killer = k; end expand_kill_ring_element; async_or_error: Error_Detector: procedure (code); declare code fixed bin (35); if code = 0 then return; if code = video_et_$window_status_pending then do; /* can only be async event or screen invalid. If screen invalid, we clear the window and signal to restart what we were doing. if just an async event, we need only signal */ /* now it can also be reconnection or ttp_change */ if attach_data.status.reconnection | attach_data.status.ttp_change then call resize_window(); /* this is the *right* way to deal with reconnection */ attach_data.status_pending = "0"b; if attach_data.status.screen_invalid then call window_$clear_window (iocb_ptr, (0)); /* who knows whats there ? */ string (attach_data.status) = ""b; go to ASYNC_EVENT; end; /* If we get window_out_of_bounds, assume that it is due to reconnecting to a video process on a terminal with a smaller screen. */ /* This is no longer true, and should not be called, but it is safer to leave the check in, and shouldn't do any harm */ else if code = video_et_$out_of_window_bounds then do; call resize_window(); goto ASYNC_EVENT; end; else if code ^= 0 then begin; declare sub_err_action bit(36) aligned; declare sub_err_ entry () options (variable); /* We only tolerate one blow-out per call, avoids looping printing these error messages */ if attach_data.debug | ERROR_COUNT > 0 then sub_err_action = ACTION_CANT_RESTART; else sub_err_action = ACTION_DEFAULT_RESTART; ERROR_COUNT = ERROR_COUNT + 1; call window_$clear_window (iocb_ptr, (0)); call sub_err_ (code, "window_io_iox_", sub_err_action, null (), (0), ""); go to ASYNC_EVENT; end; end async_or_error; RETURN: return; resize_window: proc(); dcl 1 auto_window_position_info aligned like window_position_info; dcl 1 auto_capabilities_info aligned like capabilities_info; /* Try to resize the window to fit on the screen. We may have been reconnected to a smaller terminal */ auto_capabilities_info.version = capabilities_info_version_1; call iox_$control (attach_data.target_iocb_ptr, "get_capabilities", addr (auto_capabilities_info), code); call async_or_error (code); /* Start out with the old values. Since we got an error, one of these values is wrong. */ auto_window_position_info.extent.width = attach_data.current.columns; auto_window_position_info.extent.height = attach_data.current.rows; auto_window_position_info.origin.line = attach_data.line_origin; auto_window_position_info.origin.column = attach_data.column_origin; auto_window_position_info.version = window_position_info_version_1; /* If the window is wider than the screen, knock off the rightmost columns. */ if attach_data.current.columns + attach_data.column_origin - 1 > auto_capabilities_info.screensize.columns then auto_window_position_info.extent.width = auto_capabilities_info.screensize.columns - attach_data.column_origin + 1; /* If the top of the window is within two lines of the bottom of the screen (or is off the bottom), make the window take over the entire screen. */ if attach_data.current.line_origin > (auto_capabilities_info.screensize.rows - 2) then auto_window_position_info.origin.line = 1; /* otherwise shorten the window if it runs off the bottom of the screen */ else if (attach_data.current.line_origin + attach_data.current.rows - 1) > auto_capabilities_info.screensize.rows then auto_window_position_info.extent.height = (auto_capabilities_info.screensize.rows - attach_data.line_origin + 1); call iox_$control (iocb_ptr, "set_window_info", addr (auto_window_position_info), code); call async_or_error (code); end resize_window; raw_write: procedure (t); dcl t char (*); dcl code fixed bin (35); /* Calling window_$write_raw_text sets the screen_invalid status bit and the status_pending bit, but no status code is returned. The next call to some other window_ entrypoint will return the status_pending code. The iox_ interface assumes that the user of rawo mode knows what he is doing and resets the status generated by write_raw_text calls. */ call window_$write_raw_text (iocb_ptr, t, code); call async_or_error (code); /* If there was no code, then any status remaining is a result of the raw output. Reset the status so the next non-raw window_ call won't error out. */ attach_data.status_pending = "0"b; attach_data.status.screen_invalid = "0"b; attach_data.cursor_valid = "1"b; return; end raw_write; clear_to_end_of_line: procedure; dcl code fixed bin (35); call window_$clear_to_end_of_line (iocb_ptr, code); call async_or_error (code); return; end clear_to_end_of_line; ring: procedure; declare code fixed bin (35); call window_$bell (iocb_ptr, code); call async_or_error (code); end ring; /* More processing routine. */ check_more: procedure; recheck_more: if ^attach_data.more_processing then return; if (attach_data.more_mode = MORE_MODE_SCROLL) | (attach_data.more_mode = MORE_MODE_FOLD) then if lines_written_since_read >= (attach_data.current.rows - 1) then ; else return; else if ^((attach_data.line = attach_data.current.rows) & (attach_data.col = 1)) then return; call perform_more_break (); perform_more_break: procedure; dcl continue_output bit (1) aligned; dcl prompt character (80) varying; dcl (yesses_string, noes_string) character (40) varying; dcl i fixed bin; dcl got_response bit (1) aligned; dcl response character (1); dcl r character (1); dcl break character (1) varying; dcl 1 more_data like more_info; dcl quit condition; dcl ioa_$rsnnl entry () options (variable); dcl continue_to_signal_ entry (fixed bin (35)); /* Check to see if the user has supplied his own more handler. */ if attach_data.more_handler_in_use then do; continue_output = "1"b; more_data.version = more_info_version; more_data.window_iocb_ptr = iocb_ptr; more_data.more_mode = attach_data.more_mode; more_data.more_prompt = attach_data.more_prompt; more_data.more_responses.n_yeses = attach_data.more_responses.n_yeses; more_data.more_responses.n_noes = attach_data.more_responses.n_noes; more_data.more_responses.more_yeses = attach_data.more_responses.more_yeses; more_data.more_responses.more_noes = attach_data.more_responses.more_noes; /* make sure that QUIT during more break will be seen */ on quit begin; attach_data.lines_written_since_read = 0; call get_to_next_line (); call continue_to_signal_ ((0)); end; call attach_data.more_handler (addr (more_data), continue_output, code); revert quit; if code = video_et_$window_status_pending then do; attach_data.status_pending = "0"b; string (attach_data.status) = ""b; go to recheck_more; end; call async_or_error (code); if continue_output then goto CONTINUE_OUTPUT; else goto ABORT_OUTPUT; end; /* No user supplied more handle, so do it ourselves. */ yesses_string = ""; do i = 1 to attach_data.n_yeses; yesses_string = yesses_string || flat_rep (substr (attach_data.more_yeses, i, 1)); yesses_string = yesses_string || " "; end; noes_string = ""; do i = 1 to attach_data.n_noes; noes_string = noes_string || flat_rep (substr (attach_data.more_noes, i, 1)); noes_string = noes_string || " "; end; call ioa_$rsnnl (attach_data.more_prompt, prompt, (0), yesses_string, noes_string); do while ("1"b); /* Make sure that QUIT during more break will get seen */ on quit begin; attach_data.lines_written_since_read = 0; call get_to_next_line; call continue_to_signal_ ((0)); end; /* What should be done if the more prompt is bigger than the window? For now we will just truncate it. */ if length (rtrim (prompt)) > attach_data.current.columns then prompt = substr (prompt, 1, attach_data.current.columns); call window_$write_sync_read (iocb_ptr, rtrim (prompt), (1), response, (0), break, code); revert quit; /* Already printed prompt once, don't again. */ prompt = ""; if code = video_et_$window_status_pending then do; /* something in this window went off */ attach_data.status_pending = "0"b; string (attach_data.status) = ""b; go to recheck_more; end; call async_or_error (code); if length (break) = 1 then r = break; else r = response; got_response = "1"b; verify_response: begin; dcl the_yeas character (attach_data.n_yeses) defined (attach_data.more_yeses) position (1); dcl the_nays character (attach_data.n_noes) defined (attach_data.more_noes) position (1); if index (the_yeas, r) > 0 then continue_output = "1"b; else if index (the_nays, r) > 0 then continue_output = "0"b; else do; got_response = "0"b; call ring; end; end verify_response; if got_response then if continue_output then goto CONTINUE_OUTPUT; else goto ABORT_OUTPUT; end; /* do while */ ABORT_OUTPUT: if attach_data.more_mode = MORE_MODE_SCROLL then do; call window_$position_cursor (iocb_ptr, attach_data.current.rows, 1, code); call async_or_error (code); call clear_to_end_of_line; end; else if attach_data.more_mode = MORE_MODE_FOLD then do; call window_$position_cursor (iocb_ptr, attach_data.cursor_position.line, 1, code); call async_or_error (code); call clear_to_end_of_line; end; else do; /* WRAP or CLEAR, so get to top of window. */ if attach_data.more_mode = MORE_MODE_WRAP then do; call window_$position_cursor (iocb_ptr, attach_data.current.rows, 1, code); call async_or_error (code); call clear_to_end_of_line; call window_$overwrite_text (iocb_ptr, "(output discarded)", code); call async_or_error (code); end; call get_to_next_line; end; attach_data.lines_written_since_read = 0; call window_$sync (iocb_ptr, code); call async_or_error (code); call abort_output (); /* does not return */ CONTINUE_OUTPUT: if (attach_data.more_mode = MORE_MODE_SCROLL) then do; call window_$position_cursor (iocb_ptr, attach_data.line, 1, code); call async_or_error (code); call clear_to_end_of_line; end; else if (attach_data.more_mode = MORE_MODE_FOLD) then do; call window_$position_cursor (iocb_ptr, attach_data.line, 1, code); call async_or_error (code); call clear_to_end_of_line; call window_$overwrite_text (iocb_ptr, "--continuing--", code); call async_or_error (code); call get_to_next_line; end; else if (attach_data.more_mode = MORE_MODE_WRAP) then do; call window_$position_cursor (iocb_ptr, attach_data.line, 1, code); call async_or_error (code); call clear_to_end_of_line; call window_$overwrite_text (iocb_ptr, "--continuing--", code); call async_or_error (code); call get_to_next_line; end; else call get_to_next_line; attach_data.lines_written_since_read = 0; return; flat_rep: procedure (c) returns (char (32) varying); dcl c character (1); if c = byte (bin ("015"b3)) then return ("RETURN"); if c < " " then return ("^" || byte (rank (c) + rank ("@"))); if c = " " then return ("SPACE"); if c = byte (bin ("177"b3)) then return ("DEL"); return (c); end flat_rep; end perform_more_break; end check_more; abort_output: procedure; attach_data.discard_output = "1"b; Code = 0; go to RETURN; end abort_output; reset_more_entry: entry (Iocb_ptr); iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr; attach_data_ptr = iocb_ptr -> iocb.attach_data_ptr; attach_data.discard_output = "0"b; return; put_chars: entry (Iocb_ptr, Buffer_ptr, Buffer_len, Code); iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr; attach_data_ptr = iocb_ptr -> iocb.attach_data_ptr; Code = 0; ERROR_COUNT = 0; PROCESSED_SO_FAR = 0; /* as soon as ASYNC_EVENT is set this must be valid. stack garbage won't do. */ if attach_data.discard_output then return; if attach_data.rawo then do; RESTART_PUT_RAW_CHARS: ASYNC_EVENT = RESTART_PUT_RAW_CHARS; call raw_write (Buffer); goto put_chars_return; end; ASYNC_EVENT = RESTART_PUT_CHARS; /* Cover our ass against funny (ha ha) cursor positions */ if attach_data.line > attach_data.current.rows /* IMPOSSIBLE */ then do; call window_$position_cursor (iocb_ptr, attach_data.current.rows, 1, code); call async_or_error (code); end; call clear_to_end_of_line; /* neater displays */ call put_out_chars (Buffer); put_chars_return: call window_$sync (iocb_ptr, (0)); return; RESTART_PUT_CHARS: begin; dcl reput_str character (length (Buffer) - PROCESSED_SO_FAR) defined (Buffer) position (PROCESSED_SO_FAR + 1); if length (reput_str) > 0 then call put_out_chars (reput_str); go to put_chars_return; end; get_chars: entry (Iocb_ptr, Buffer_ptr, Buffer_len, N_returned, Code); Code = 0; N_returned = 0; iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr; attach_data_ptr = iocb_ptr -> iocb.attach_data_ptr; attach_data.discard_output = "0"b; attach_data.lines_written_since_read = 0; if Buffer_len = 0 | Buffer_ptr = null () then return; /* Read all the characters the user has typed so far. */ do char_count = 1 by 1; call window_$get_one_unechoed_char (iocb_ptr, char_varying, "0"b /* don't block */, Code); if Code ^= 0 then return; /* No more characters. */ if length (char_varying) = 0 then do; N_returned = char_count - 1; return; end; substr (Buffer, char_count, 1) = char_varying; /* If we are supposed to echo, try echoing through put_chars. This is pretty weird, but gets output conversions done. */ if ^attach_data.suppress_echo then do; char_nonvarying = char_varying; call iox_$put_chars (iocb_ptr, addr (char_nonvarying), 1, Code); if Code ^= 0 then return; end; end; return; cl_pusher: procedure (cl_arg); declare 1 cl_arg aligned, 2 resetread bit (1) unaligned, 2 pad bit (35) unaligned; /* We want to call the usual cl_intermediary, but when it returns, we want to pretend something asynchronous has happened, which it has. */ call REAL_CL_INTERMEDIARY (cl_arg); go to ASYNC_EVENT; end cl_pusher; %page; %include window_io_attach_data_; %page; %include window_line_editor; %page; %include window_dcls; %page; %include window_control_info; %page; %include window_more_info; %page; %include tc_screen_image; %page; %include tty_convert; %page; %include iox_entries; %page; %include iocb; %page; %include sub_err_flags; end window_io_iox_;  wioctl_.pl1 05/10/89 1202.7rew 05/10/89 1200.0 831654 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-06-16,LJAdams), approve(87-06-16,MCR7584), audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055): Changed editing_chars_version_2 to editing_chars_version_3 which includes the redisplay character (for DSA only). editing_chars_version_2 will still be accepted. 2) change(87-07-10,LJAdams), approve(87-07-10,MCR7742), audit(87-07-23,Gilcrease), install(87-08-04,MR12.1-1055): Changed to accept either scroll or line_count as a valid value for mv.char_value. 3) change(88-02-08,Brunelle), approve(88-02-08,MCR7813), audit(88-10-12,Blair), install(88-10-17,MR12.2-1171): Change to use SPECIAL_VERSION_2 instead of SPECIAL_VERSION of special chars structure. Change set/get_special control orders to automatically handle old(3)/new(15) lengths of special_chars. 4) change(88-10-20,Brunelle), approve(88-10-20,PBF7813), audit(88-10-20,Farley), install(88-10-20,MR12.2-1175): Correct "ptr being referenced but never set" problem. Also altered method used to copy old-version special chars structures from/to new version to use a more efficient manner. 5) change(89-02-27,Lee), approve(89-03-14,MCR8075), audit(89-04-20,Flegel), install(89-05-10,MR12.3-1041): phx19510 (Video 91) - fixed to handle problem with setting of editing chars when the erase and kill characters are being interchanged. END HISTORY COMMENTS */ /* wioctl_ -- control orders and modes for window_io_ */ /* Benson I. Margulies, sometime in 1981 */ /* Modified 11 December 1981 by Chris Jones to add more_mode=fold */ /* Modified 15 December 1981 by Chris Jones to add set_editing_chars */ /* Modified 11 January 1982 by Chris Jones to clear break table entries on ^erkl and ^esc modes */ /* Modified 26 January 1982 by William York to implement user-settable more handlers. */ /* Modified 3 February 1982 by Chris Jones to fix set_window_info so cursor always lands in the window */ /* Modified 28 April 1982 by WMY to return the current more handler routine (if any) in a set_more_handler call. version 2 of more_handler_info. */ /* Modified 26 August 1982 by WMY to add the send_buffered_output order, and pass any unrecognized order on to tc_ level. */ /* Modified 20 September 1982 by WMY to remove the send_buffered_output control order, since window_$sync is a better mechanism. */ /* Modified 18 October 1982 by WMY to re-allocate the window image when the size of a window is changed via set_window_info. */ /* Modified October 1982 by WMY to add set_ and get_token_characters and set_ and get_more_prompt. */ /* Modified January 1983 by WMY to add io_call support. */ /* Modified February 1983 by WMY to add set_editor_key_bindings. */ /* Modified 8 May 1983 by WMY to add io_call support for set and get_window_status and set and get_token_characters. */ /* Modified 7 June 1983 by WMY to make set_window_info check the elements of the window_position_info structure for reasonable values and actually set the width of the window instead of ignoring the width specified by the caller. */ /* Modified 14 June 1983 by WMY to use version 2 line_editor_key_binding_info structure, and interpret a 0 width specification in a set_window_info order as a full-screen-width window. */ /* Modified 15 June 1983 by WMY to change set_editing_chars to use the set_editor_key_bindings order, and unbind the old editing chars. */ /* Modified 2 August 1983 by Jon A. Rochlis to make get_window_status zero attach_data.status, not just attach_data.status_pending, and to add io_call support for set_window_status */ /* Modified 6 August 1983 by JR to add io_call support for get_more_responses, get_more_prompt, and (set get)_editing_chars. Also to improve error reporting in io_call processing, and to elimitate duplicate error messages by zeroing code before returning if we report the error. Also to remove the special casing of the terminal_info control, since we pass anything unrecognized to tc_ anyway. */ /* Modified 7 August 1983 by JR to add get_more_handler and io_call support for it. */ /* Modified 7-8 August 1983 by JR for better io_call support for set_editor_key_bindings, added -builtin and -numarg control args */ /* Modified 2 September 1983 by JR for case insensitive comparisons of builtin requests and numarg actions for set_editor_key_bindings */ /* Modified 8 October 1983 by JR for partial screen width support. Made set_window_info set the new fields in tc_desk_info, and default column origin to 1 if we get passed 0 (it used to be a mbz). */ /* Modified December 1983 by JR to make get_capabilites set the various flags correctly for partial width windows, and to make get_window_info set window_position.origin.column */ /* Modified 23 December 1983 by JR to support the (set get)_output_conversion and (set get)_special control orders. Merry Christmas!! */ /* Modified 8 January 1983 by JR to explicitly do a get_capabilities to determine if more_mode=SCROLL rather than relying on attach_data.capabilities which is going away. */ /* Modified 1 February 1984 by JR to support the removal of window_io_video_ by adding the get_window_iocb_ptr for window_, and adding support for read_status here, since all roads lead to wioctl_ for control orders. */ /* Modified 29 February 1984 by Barmar to add get_editor_key_bindings control order, and make set_key_binding free dispatch tables that become garbage */ /* Modified 1 March 1984 by Barmar to change "goto error_return" into "call error_exit", and to upgrade set_editor_key_bindings to support the new set_editor_key_bindings info structure. */ /* Modified 9 March 1984 by Barmar - Fixed lots of invalid code, add io_call support for setting name, description, and info_path, implemented io_call get_editor_key_bindings */ /* Modified 22 March 1984 by Barmar - Added (set get)_audit_iocb_ptr control orders. */ /* Modified 28 March 1984 by JR to add support for window_iocb_ptr in tc_desk_info, and to add support to get_window_status for W_STATUS_TTP_CHANGE and W_STATUS_RECONNECTION. */ /* Modified 01 September 1984 by JR to add edited mode. */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ wioctl_: procedure; declare ( (Old_modes, New_modes, Order) character (*), Code fixed bin (35), Iocb_ptr pointer, Info_ptr pointer ) parameter; declare temp_ptr pointer; declare mode_string_$parse entry (character (*), pointer, pointer, fixed binary (35)); declare ioa_$rsnnl entry () options (variable); declare pathname_ entry (char (*), char (*)) returns (char (168)); declare requote_string_ entry (char (*)) returns (char (*)); declare window_io_iox_$reset_more_entry entry (pointer); declare target_iocbp pointer; declare modex fixed bin; declare force_mode bit (1) aligned; declare binding_index fixed bin; declare 1 auto_capabilities_info aligned like capabilities_info; declare 1 desk_info aligned like tc_desk_window_info; declare ( video_et_$bad_window_id, video_et_$overlapping_more_responses, video_et_$window_too_big, video_et_$no_more_handler_in_use, error_table_$bad_subr_arg, error_table_$bad_mode_value, error_table_$inconsistent, error_table_$null_info_ptr, error_table_$invalid_array_size ) external static fixed bin (35); declare error_table_$bad_mode fixed bin (35) ext static; declare error_table_$unimplemented_version fixed bin (35) ext static; declare (addr, bin, byte, clock, codeptr, copy, hbound, index, lbound, length, max, null, rank, rtrim, search, string, substr, translate, unspec) builtin; dcl cleanup condition; dcl SPACE char (1) static options (constant) init (" "); dcl DEL char (1) static options (constant) init (""); dcl WHITE_SPACE char (5) int static options (constant) initial /* CR, NL, HT, VT, FF */ (" "); /* special chars structures to support old/new versions */ dcl 1 special_chars_old aligned based, /* table of special character sequences */ 2 nl_seq aligned like c_chars_old, /* new-line sequence */ 2 cr_seq aligned like c_chars_old, /* carriage-return sequence */ 2 bs_seq aligned like c_chars_old, /* backspace sequence */ 2 tab_seq aligned like c_chars_old, /* horizontal tab sequence */ 2 vt_seq aligned like c_chars_old, /* vertical tab sequence */ 2 ff_seq aligned like c_chars_old, /* form-feed sequence */ 2 printer_on aligned like c_chars_old, /* printer-on sequence */ 2 printer_off aligned like c_chars_old, /* printer_off sequence */ 2 red_ribbon_shift aligned like c_chars_old, /* red ribbon shift sequence */ 2 black_ribbon_shift aligned like c_chars_old, /* black ribbon shift sequence */ 2 end_of_page aligned like c_chars_old, /* end-of-page warning sequence */ 2 escape_length fixed bin, /* number of escape sequences */ 2 not_edited_escapes (sc_escape_len refer (special_chars_old.escape_length)) like c_chars_old, /* use in ^edited mode */ 2 edited_escapes (sc_escape_len refer (special_chars_old.escape_length)) like c_chars_old, /* use in edited mode */ 2 input_escapes aligned, 3 len fixed bin (8) unaligned, /* length of string */ 3 str char (sc_input_escape_len refer (special_chars_old.input_escapes.len)) unaligned, /* escape sequence characters */ 2 input_results aligned, 3 pad bit (9) unaligned, /* so that strings will look the same */ 3 str char (sc_input_escape_len refer (special_chars_old.input_escapes.len)) unaligned; /* results of escape sequences */ dcl 1 c_chars_old based (c_chars_ptr) aligned, 2 count fixed bin (8) unaligned, 2 chars (3) char (1) unaligned; dcl 1 special_chars_struc_old aligned based, 2 version fixed bin, 2 default fixed bin, /* non-zero indicates use default */ 2 special_chars, /* same as level-1 above */ /* has to be spelled out instead of using like */ /* because of refer options */ 3 nl_seq aligned like c_chars_old, /* new-line sequence */ 3 cr_seq aligned like c_chars_old, /* carriage-return sequence */ 3 bs_seq aligned like c_chars_old, /* backspace sequence */ 3 tab_seq aligned like c_chars_old, /* horizontal tab sequence */ 3 vt_seq aligned like c_chars_old, /* vertical tab sequence */ 3 ff_seq aligned like c_chars_old, /* form-feed sequence */ 3 printer_on aligned like c_chars_old, /* printer-on sequence */ 3 printer_off aligned like c_chars_old, /* printer_off sequence */ 3 red_ribbon_shift aligned like c_chars_old, /* red ribbon shift sequence */ 3 black_ribbon_shift aligned like c_chars_old, /* black ribbon shift sequence */ 3 end_of_page aligned like c_chars_old, /* end-of-page warning sequence */ 3 escape_length fixed bin, /* number of escape sequences */ 3 not_edited_escapes (sc_escape_len refer (special_chars_struc_old.escape_length)) like c_chars_old, /* use in ^edited mode */ 3 edited_escapes (sc_escape_len refer (special_chars_struc_old.escape_length)) like c_chars_old, /* use in edited mode */ 3 input_escapes aligned, 4 len fixed bin (8) unaligned, /* length of string */ 4 str char (sc_input_escape_len refer (special_chars_struc_old.input_escapes.len)) unaligned, /* escape sequence characters */ 3 input_results aligned, 4 pad bit (9) unaligned, /* so that strings will look the same */ 4 str char (sc_input_escape_len refer (special_chars_struc_old.input_escapes.len)) unaligned; /* results of escape sequences */ %page; modes: entry (Iocb_ptr, New_modes, Old_modes, Code); call setup; Old_modes = ""; call ioa_$rsnnl ( "more_mode=^[scroll^;clear^;wrap^;fold^],^[^^^]more,ll=^d,pl=^d,^[^^^]vertsp,^[^^^]can,^[^^^]erkl,^[^^^]esc,^[^^^]rawo,^[^^^]red,^[^^^]ctl_char,^[^^^]edited", Old_modes, (0), attach_data.more_mode, ^attach_data.more_processing, attach_data.current.columns, attach_data.current.rows, ^attach_data.flags.vertsp, ^attach_data.flags.can, ^attach_data.flags.erkl, ^attach_data.flags.esc, ^attach_data.flags.rawo, ^attach_data.flags.red, ^attach_data.flags.ctl_char, ^attach_data.flags.edited); if New_modes = "" then return; call mode_string_$parse (New_modes, get_system_free_area_ (), mode_string_info_ptr, Code); if Code ^= 0 then return; force_mode = "0"b; do modex = 1 to hbound (mode_string_info.modes, 1); call set_mode (mode_string_info.modes (modex)); end; mode_error_return: free mode_string_info; return; /* This procedure analyzes a single mode */ set_mode: procedure (mv); dcl 1 mv aligned like mode_value; if mv.mode_name = "force" then force_mode = mode_value_boolean (); else if mv.mode_name = "more_mode" then do; if ^mv.char_valuep then goto BAD_TYPE; if mv.char_value = "scroll" | mv.char_value = "line_count" then do; auto_capabilities_info.version = capabilities_info_version_1; call iox_$control (Iocb_ptr, "get_capabilities", addr (auto_capabilities_info), Code); if Code ^= 0 then return; if ^auto_capabilities_info.scroll_region then go to BAD_VALUE; attach_data.more_mode = MORE_MODE_SCROLL; end; else if mv.char_value = "wrap" then attach_data.more_mode = MORE_MODE_WRAP; else if mv.char_value = "clear" then attach_data.more_mode = MORE_MODE_CLEAR; else if mv.char_value = "fold" then attach_data.more_mode = MORE_MODE_FOLD; else goto BAD_TYPE; end; /* more_mode */ else if mv.mode_name = "more" then attach_data.more_processing = mode_value_boolean (); else if mv.mode_name = "debug" then attach_data.debug = mode_value_boolean (); else if mv.mode_name = "ll" then if mv.numeric_value ^= attach_data.current.columns then go to BAD_VALUE; else ; /* read only, but accept truth */ else if mv.mode_name = "pl" then if mv.numeric_value ^= attach_data.current.rows then go to BAD_VALUE; else ; else if mv.mode_name = "vertsp" then attach_data.flags.vertsp = mode_value_boolean (); else if mv.mode_name = "can" then attach_data.can = mode_value_boolean (); /* These two require break tbl changes as well */ else if mv.mode_name = "erkl" then do; attach_data.erkl = mode_value_boolean (); call set_break_table (attach_data.erase_char, attach_data.erkl); call set_break_table (attach_data.kill_char, attach_data.erkl); end; /* erkl mode */ else if mv.mode_name = "esc" then do; attach_data.esc = mode_value_boolean (); call set_break_table (attach_data.input_escape_char, attach_data.esc); end; /* esc mode */ else if mv.mode_name = "rawo" then begin; declare saved_r bit (1); saved_r = attach_data.rawo; attach_data.rawo = mode_value_boolean (); if ^saved_r & attach_data.rawo & attach_data.cursor_valid then do; attach_data.row_at_rawo = attach_data.line; attach_data.col_at_rawo = attach_data.col; end; else if saved_r & ^attach_data.rawo then do; attach_data.line = attach_data.row_at_rawo; attach_data.col = attach_data.col_at_rawo; attach_data.cursor_valid = "1"b; end; end; else if mv.mode_name = "red" then attach_data.red = mode_value_boolean (); else if mv.mode_name = "ctl_char" then attach_data.ctl_char = mode_value_boolean (); else if mv.mode_name = "edited" then attach_data.edited = mode_value_boolean (); /* support modes we've never heard of */ else if ^force_mode then do; Code = error_table_$bad_mode; /* Old_modes = mv.mode_name; */ /* this should contain the invalid mode for good error messages */ /* if mv.char_valuep then Old_modes = rtrim(Old_modes) || "=" || mv.char_value; */ go to mode_error_return; end; return; /* check type and return mode value */ mode_value_boolean: procedure returns (bit (1) aligned); /* global mv */ if ^mv.boolean_valuep then goto BAD_TYPE; return (mv.boolean_value); mode_value_char: entry returns (char (32) varying); if ^mv.char_valuep then goto BAD_TYPE; return (rtrim (mv.char_value)); mode_value_numeric: entry returns (fixed bin (35)); if ^mv.numeric_valuep then goto BAD_TYPE; return (mv.numeric_value); end; BAD_TYPE: BAD_VALUE: Code = error_table_$bad_mode_value; goto mode_error_return; end set_mode; control: entry (Iocb_ptr, Order, Info_ptr, Code); call setup; if Order = "reset_more" then call window_io_iox_$reset_more_entry (Iocb_ptr); else if Order = "send_buffered_output" then call window_$sync (Iocb_ptr, Code); else if Order = "printer_off" then attach_data.suppress_echo = "1"b; else if Order = "printer_on" then attach_data.suppress_echo = "0"b; else if Order = "get_terminal_iocb_ptr" then Info_ptr = target_iocbp; /* This is really very un-iox-like */ else if Order = "get_window_iocb_ptr" then Info_ptr = Iocb_ptr -> actual_iocb_ptr; /* If terminal control can do it, then window_ can do it also ... */ else if Order = "get_capabilities" then do; call check_null (); call iox_$control (target_iocbp, Order, Info_ptr, Code); if Code ^= 0 then return; /* Now map the terminal capabilities into the window capabilities */ if Info_ptr -> capabilities_info.columns ^= attach_data.current.columns then do; /* Illegal operations for non full width windows */ Info_ptr -> capabilities_info.scroll_region = "0"b; Info_ptr -> capabilities_info.insert_chars = "1"b; /* we simulate these if they aren't available */ Info_ptr -> capabilities_info.insert_mode = "1"b; /* ? */ Info_ptr -> capabilities_info.delete_chars = "1"b; end; Info_ptr -> capabilities_info.columns = attach_data.current.columns; Info_ptr -> capabilities_info.rows = attach_data.current.rows; return; end; else if Order = "get_window_info" then do; call check_null (); window_position_info_ptr = Info_ptr; call require_version (window_position_info.version, window_position_info_version_1); window_position_info.height = attach_data.current.rows; window_position_info.width = attach_data.current.columns; window_position_info.origin.column = attach_data.column_origin; window_position_info.origin.line = attach_data.line_origin; end; else if Order = "set_window_info" then do; call check_null (); window_position_info_ptr = Info_ptr; call require_version (window_position_info.version, window_position_info_version_1); auto_capabilities_info.version = capabilities_info_version_1; call iox_$control (target_iocbp, "get_capabilities", addr (auto_capabilities_info), Code); if Code ^= 0 then return; /* Verify that the new window position and bounds are within the screen bounds */ /* tc_ will verify that start+length-1 is within bounds ... perhaps this should all be done in one place */ Code = video_et_$window_too_big; if (window_position_info.origin.line > auto_capabilities_info.screensize.rows) | (window_position_info.origin.line < 1) then return; if window_position_info.extent.height < 1 then return; if (window_position_info.origin.line + window_position_info.extent.height - 1) > auto_capabilities_info.screensize.rows then return; if window_position_info.origin.column = 0 then window_position_info.origin.column = 1; if window_position_info.origin.column < 1 | window_position_info.origin.column > auto_capabilities_info.screensize.columns then return; if window_position_info.extent.width > auto_capabilities_info.screensize.columns then return; if window_position_info.extent.width = 0 then window_position_info.extent.width = auto_capabilities_info.screensize.columns; Code = 0; desk_info.window_id = attach_data.window_id; desk_info.first_row = window_position_info.origin.line; desk_info.n_rows = window_position_info.extent.height; desk_info.first_column = window_position_info.origin.column; desk_info.n_columns = window_position_info.extent.width; call iox_$control (target_iocbp, "resize_window", addr (desk_info), Code); if Code = video_et_$bad_window_id then do; call iox_$control (target_iocbp, "check_out_window", addr (desk_info), (0)); desk_info.window_iocb_ptr = Iocb_ptr -> iocb.actual_iocb_ptr; call iox_$control (target_iocbp, "check_in_window", addr (desk_info), Code); if Code = 0 then attach_data.window_id = desk_info.window_id; end; if Code ^= 0 then return; /* Free the old-size window image. */ if attach_data.window_image_ptr ^= null () then free window_image in (attach_data_area); rearrange_window: begin; declare origin_change fixed bin; declare bottom_line_change fixed bin; declare old_origin fixed bin; declare old_bottom_line fixed bin; declare new_bottom_line fixed bin; declare saved_ignore_status bit (1) aligned; declare cleanup condition; saved_ignore_status = attach_data.ignore_status; on cleanup attach_data.ignore_status = saved_ignore_status; attach_data.ignore_status = "1"b; string (attach_data.status) = ""b; attach_data.status_pending = "0"b; origin_change = attach_data.current.line_origin - window_position_info.line; /* + if it went up, got new turf */ old_origin = attach_data.current.line_origin; new_bottom_line = window_position_info.line + window_position_info.height - 1; old_bottom_line = old_origin + attach_data.current.rows - 1; bottom_line_change = new_bottom_line - old_bottom_line; attach_data.current.rows = window_position_info.height; attach_data.line_origin = window_position_info.line; attach_data.current.columns = window_position_info.width; attach_data.column_origin = window_position_info.column; if ^(((attach_data.current.line_origin >= old_origin) /** **/ & (attach_data.current.line_origin <= new_bottom_line)) /* top is within old space */ | ((new_bottom_line >= old_origin) /** **/ & (new_bottom_line <= old_bottom_line))) /* no overlap */ then do; call window_$position_cursor (Iocb_ptr, (1), (1), (0)); call window_io_iox_$reset_more_entry (Iocb_ptr); end; else do; /* There is some overlap, clear the new turf */ if attach_data.line > attach_data.current.rows then call window_$position_cursor (Iocb_ptr, attach_data.current.rows, (1), (0)); else if origin_change > 0 then call window_$change_line (Iocb_ptr, attach_data.line + origin_change, (0)); /* same place on screen */ end; attach_data.ignore_status = saved_ignore_status; end rearrange_window; call ioa_$rsnnl ("window_io_ ^a -first_line ^i -n_lines ^i -first_column ^i -n_columns ^i", attach_data.attach_description, (0), attach_data.target_iocb_ptr -> iocb.name, attach_data.line_origin, attach_data.current.rows, attach_data.column_origin, attach_data.current.columns); attach_data.status_pending = "0"b; string (attach_data.status) = ""b; if attach_data.async_count > 0 then do; attach_data.status_pending = "1"b; attach_data.status.screen_invalid = "1"b; end; /* Now that all re-sizing is done, allocate new window image. */ allocate window_image in (attach_data_area); if ^(attach_data.more_mode = MORE_MODE_SCROLL) then return; auto_capabilities_info.version = capabilities_info_version_1; call iox_$control (Iocb_ptr, "get_capabilities", addr (auto_capabilities_info), Code); /* window capabilities */ if Code ^= 0 then return; /* at least we tried */ if ^auto_capabilities_info.scroll_region then attach_data.more_mode = MORE_MODE_WRAP; return; end; else if Order = "get_editing_chars" then do; call check_null (); editing_chars_ptr = Info_ptr; call require_version (editing_chars.version, editing_chars_version_3); editing_chars.erase = attach_data.erase_char; editing_chars.kill = attach_data.kill_char; end; else if Order = "set_editing_chars" then do; call check_null (); editing_chars_ptr = Info_ptr; call require_version (editing_chars.version, editing_chars_version_3); if index (WHITE_SPACE, editing_chars.erase) ^= 0 | index (WHITE_SPACE, editing_chars.kill) ^= 0 | editing_chars.erase = editing_chars.kill then Code = error_table_$inconsistent; else do; begin; dcl 1 lekbi aligned like line_editor_key_binding_info based (sekbi.key_binding_info_ptr); dcl 1 sekbi aligned like set_editor_key_bindings_info; sekbi.version = set_editor_key_bindings_info_version_1; sekbi.update = "1"b; sekbi.replace = "0"b; sekbi.mbz = (34)"0"b; sekbi.key_binding_info_ptr = null (); line_editor_binding_count = 4; line_editor_longest_sequence = 1; on cleanup begin; if sekbi.key_binding_info_ptr ^= null () then free lekbi in (attach_data_area); end; allocate lekbi in (attach_data_area); lekbi.version = line_editor_key_binding_info_version_3; /* We may end up setting either character or both */ lekbi.binding_count = 0; /* SPACE means don't change that character */ /* RL: phx19510 - handle case where both erase and kill are specified and */ /* possibly being interchanged */ if editing_chars.erase ^= SPACE & editing_chars.kill ^= SPACE then do; lekbi.binding_count = lekbi.binding_count + 4; /* First unbind the previous erase char, to SELF_INSERT if it is a printing graphic or UNDEFINED if it is not. */ if (attach_data.erase_char >= SPACE) & (attach_data.erase_char < DEL) then lekbi.bindings (lekbi.binding_count - 3).action = SELF_INSERT; else lekbi.bindings (lekbi.binding_count - 3).action = UNDEFINED; lekbi.bindings (lekbi.binding_count - 3).sequence = attach_data.erase_char; lekbi.bindings (lekbi.binding_count - 1).action = BACKWARD_DELETE_CHARACTER; lekbi.bindings (lekbi.binding_count - 1).sequence = editing_chars.erase; attach_data.erase_char = editing_chars.erase; if (attach_data.kill_char >= SPACE) & (attach_data.kill_char < DEL) then lekbi.bindings (lekbi.binding_count - 2).action = SELF_INSERT; else lekbi.bindings (lekbi.binding_count - 2).action = UNDEFINED; lekbi.bindings (lekbi.binding_count - 2).sequence = attach_data.kill_char; lekbi.bindings (lekbi.binding_count).action = KILL_TO_BEGINNING_OF_LINE; lekbi.bindings (lekbi.binding_count).sequence = editing_chars.kill; attach_data.kill_char = editing_chars.kill; end; else if editing_chars.erase ^= SPACE then do; lekbi.binding_count = lekbi.binding_count + 2; /* First unbind the previous erase char, to SELF_INSERT if it is a printing graphic or UNDEFINED if it is not. */ if (attach_data.erase_char >= SPACE) & (attach_data.erase_char < DEL) then lekbi.bindings (lekbi.binding_count - 1).action = SELF_INSERT; else lekbi.bindings (lekbi.binding_count - 1).action = UNDEFINED; lekbi.bindings (lekbi.binding_count - 1).sequence = attach_data.erase_char; lekbi.bindings (lekbi.binding_count).action = BACKWARD_DELETE_CHARACTER; lekbi.bindings (lekbi.binding_count).sequence = editing_chars.erase; attach_data.erase_char = editing_chars.erase; end; else if editing_chars.kill ^= SPACE then do; lekbi.binding_count = lekbi.binding_count + 2; /* First unbind the previous kill char, to SELF_INSERT if it is a printing graphic or UNDEFINED if it is not. */ if (attach_data.kill_char >= SPACE) & (attach_data.kill_char < DEL) then lekbi.bindings (lekbi.binding_count - 1).action = SELF_INSERT; else lekbi.bindings (lekbi.binding_count - 1).action = UNDEFINED; lekbi.bindings (lekbi.binding_count - 1).sequence = attach_data.kill_char; lekbi.bindings (lekbi.binding_count).action = KILL_TO_BEGINNING_OF_LINE; lekbi.bindings (lekbi.binding_count).sequence = editing_chars.kill; attach_data.kill_char = editing_chars.kill; end; /*** Use default strings for these */ lekbi.name (*), lekbi.description (*), lekbi.info_dir (*), lekbi.info_entry (*) = ""; call iox_$control (Iocb_ptr, "set_editor_key_bindings", addr (sekbi), Code); temp_ptr = sekbi.key_binding_info_ptr; sekbi.key_binding_info_ptr = null (); free temp_ptr -> lekbi; end; end; end; else if Order = "get_more_responses" then do; call check_null (); more_responses_info_ptr = Info_ptr; call require_version (more_responses_info.version, more_responses_info_version_1); more_responses_info.n_yeses = attach_data.n_yeses; more_responses_info.n_noes = attach_data.n_noes; more_responses_info.yeses = attach_data.more_yeses; more_responses_info.noes = attach_data.more_noes; end; else if Order = "set_more_responses" then do; call check_null (); more_responses_info_ptr = Info_ptr; call require_version (more_responses_info.version, more_responses_info_version_1); if search (substr (more_responses_info.yeses, 1, more_responses_info.n_yeses), substr (more_responses_info.noes, 1, more_responses_info.n_noes)) > 0 then Code = video_et_$overlapping_more_responses; else do; attach_data.n_yeses = more_responses_info.n_yeses; attach_data.n_noes = more_responses_info.n_noes; attach_data.more_yeses = more_responses_info.yeses; attach_data.more_noes = more_responses_info.noes; end; end; /* set_more_responses */ else if Order = "get_window_status" then do; /* destructive read */ call check_null (); window_status_info_ptr = Info_ptr; call require_version (window_status_info.version, window_status_version_1); string (window_status_info.status_string) = string (attach_data.status); string (attach_data.status) = "0"b; attach_data.status_pending = "0"b; return; end; else if Order = "set_window_status" /* Interrupt */ then do; /* return codes from now Until doomsday */ call check_null (); window_status_info_ptr = Info_ptr; call require_version (window_status_info.version, window_status_version_1); string (attach_data.status) = string (attach_data.status) | string (window_status_info.status_string); attach_data.status_pending = "1"b; end; else if Order = "start" then call iox_$control (target_iocbp, "start", null (), (0)); else if Order = "set_break_table" then do; call check_null (); break_table_ptr = Info_ptr; call require_version (break_table_info.version, break_table_info_version_1); attach_data.breaks = string (break_table_info.breaks); end; else if Order = "get_break_table" then do; call check_null (); break_table_ptr = Info_ptr; call require_version (break_table_info.version, break_table_info_version_1); string (break_table_info.breaks) = attach_data.breaks; end; else if Order = "set_more_handler" then do; call check_null (); more_handler_info_ptr = Info_ptr; call require_version (more_handler_info.version, more_handler_info_version_3); /* return the old entry value if there was one */ if attach_data.more_handler_in_use then do; more_handler_info.old_more_handler = attach_data.more_handler; more_handler_info.old_handler_valid = "1"b; end; else more_handler_info.old_handler_valid = "0"b; /* should the entry variable be verified in some way? */ attach_data.more_handler = more_handler_info.more_handler; attach_data.more_handler_in_use = "1"b; end; else if Order = "get_more_handler" then do; call check_null (); more_handler_info_ptr = Info_ptr; call require_version (more_handler_info.version, more_handler_info_version_3); if ^attach_data.more_handler_in_use then do; Code = video_et_$no_more_handler_in_use; return; end; more_handler_info.more_handler = attach_data.more_handler; more_handler_info.old_handler_valid = "0"b; return; end; else if Order = "reset_more_handler" then attach_data.more_handler_in_use = "0"b; else if Order = "set_token_characters" then do; call check_null (); token_characters_info_ptr = Info_ptr; call require_version_str (token_characters_info.version, token_characters_info_version_1); attach_data.token_characters = token_characters_info.token_characters; attach_data.token_character_count = token_characters_info.token_character_count; end; else if Order = "get_token_characters" then do; call check_null (); token_characters_info_ptr = Info_ptr; call require_version_str (token_characters_info.version, token_characters_info_version_1); token_characters_info.token_characters = attach_data.token_characters; token_characters_info.token_character_count = attach_data.token_character_count; end; else if Order = "set_more_prompt" then do; call check_null (); more_prompt_info_ptr = Info_ptr; call require_version_str (more_prompt_info.version, more_prompt_info_version_1); attach_data.more_prompt = more_prompt_info.more_prompt; end; else if Order = "get_more_prompt" then do; call check_null (); more_prompt_info_ptr = Info_ptr; call require_version_str (more_prompt_info.version, more_prompt_info_version_1); more_prompt_info.more_prompt = attach_data.more_prompt; end; else if Order = "set_editor_key_bindings" then do; call check_null (); set_editor_key_bindings_info_ptr = Info_ptr; dcl line_editor_key_binding_info_version_2 char (8) int static options (constant) init ("lekbi002"); /* archaic version */ if set_editor_key_bindings_info.version = line_editor_key_binding_info_version_2 | set_editor_key_bindings_info.version = line_editor_key_binding_info_version_3 then call update_key_bindings (set_editor_key_bindings_info_ptr); else if set_editor_key_bindings_info.version ^= set_editor_key_bindings_info_version_1 then call error_exit (error_table_$unimplemented_version); else if set_editor_key_bindings_info.replace = set_editor_key_bindings_info.update /* exactly one may be set */ then call error_exit (error_table_$bad_subr_arg); else if set_editor_key_bindings_info.update then call update_key_bindings (set_editor_key_bindings_info.key_binding_info_ptr); else /* if set_editor_key_bindings_info.replace */ do; temp_ptr = attach_data.dispatch_table_ptr; attach_data.dispatch_table_ptr = set_editor_key_bindings_info.key_binding_info_ptr; free temp_ptr -> dispatch_table in (attach_data_area); end; end; else if Order = "get_editor_key_bindings" then do; call check_null (); get_editor_key_bindings_info_ptr = Info_ptr; call require_version_str (get_editor_key_bindings_info.version, get_editor_key_bindings_info_version_1); call require_mbz (get_editor_key_bindings_info.flags.mbz); if get_editor_key_bindings_info.entire_state then call make_key_bindings_copy (get_editor_key_bindings_info.entire_state_ptr); else do; line_editor_key_binding_info_ptr = get_editor_key_bindings_info.key_binding_info_ptr; if line_editor_key_binding_info_ptr = null () then do; call error_exit (error_table_$null_info_ptr); end; call require_version_str (line_editor_key_binding_info.version, line_editor_key_binding_info_version_3); dcl bad_prefix condition; on bad_prefix /* Signaled if he asks for the binding of a sequence */ call error_exit (error_table_$bad_subr_arg); /* with an invalid prefix sequence */ do binding_index = 1 to line_editor_key_binding_info.binding_count; call get_key_binding (line_editor_key_binding_info.sequence (binding_index), line_editor_key_binding_info.action (binding_index), line_editor_key_binding_info.numarg_action (binding_index), line_editor_key_binding_info.editor_routine (binding_index), line_editor_key_binding_info.name (binding_index), line_editor_key_binding_info.description (binding_index), line_editor_key_binding_info.info_path (binding_index)); end; end; return; end; else if Order = "get_output_conversion" then do; dcl 1 cts aligned like cv_trans_struc based (cts_ptr); dcl cts_ptr ptr; call check_null (); cts_ptr = Info_ptr; if ^(cts.version = 1 | cts.version = CV_TRANS_VERSION) /* support both versions */ then do; Code = error_table_$unimplemented_version; return; end; begin; dcl index fixed bin; do index = 0 to CV_TRANS_SIZE (cts.version); cts.cv_trans.value (index) = attach_data.output_cv_ptr -> cv_trans.value (index); end; /* do */ end; /* begin */ end; else if Order = "set_output_conversion" then do; call check_null (); cts_ptr = Info_ptr; if ^(cts.version = 1 | cts.version = CV_TRANS_VERSION) /* support both versions */ then do; Code = error_table_$unimplemented_version; return; end; if cts.default = 1 then /* default to what we get from terminal control */ do; call iox_$control (target_iocbp, "get_output_conversion", cts_ptr, Code); if Code ^= 0 then return; end; attach_data.output_cv_ptr -> cv_trans.value (*) = OUTPUT_CONVERT_OCTAL; /* anything but garbage will do */ begin; dcl index fixed bin; do index = 0 to CV_TRANS_SIZE (cts.version); attach_data.output_cv_ptr -> cv_trans.value (index) = cts.cv_trans.value (index); end; /* do */ end; /* begin */ /* Set up tct table for quick conversion scan. */ begin; dcl cv_trans_idx fixed bin; dcl conversion_type fixed bin; /* Fill in first 128 entries in string from regular table. */ do cv_trans_idx = 0 to 127; substr (attach_data.conversion_tct_table, cv_trans_idx + 1, 1) = byte (attach_data.output_cv_ptr -> cv_trans.value (cv_trans_idx)); end; /* Now handle next 128, giving defaults if necessary. */ do cv_trans_idx = 128 to 255; conversion_type = attach_data.output_cv_ptr -> cv_trans.value (cv_trans_idx); if conversion_type = OUTPUT_CONVERT_ORDINARY /* bull */ then substr (attach_data.conversion_tct_table, cv_trans_idx + 1, 1) = byte (OUTPUT_CONVERT_OCTAL); else substr (attach_data.conversion_tct_table, cv_trans_idx + 1, 1) = byte (conversion_type); end; /* Now take care of things beyond limits of conversion table. */ substr (attach_data.conversion_tct_table, 257, 256) = copy (byte (OUTPUT_CONVERT_OCTAL), 256); end; /* begin */ end; else if Order = "get_special" then do; dcl 1 gsi aligned like get_special_info_struc based (Info_ptr); dcl gsi_area area based (gsi.area_ptr); dcl 1 gsi_old aligned based (Info_ptr), 2 area_ptr pointer, 2 table_ptr pointer; dcl gsi_area_old area based (gsi_old.area_ptr); call check_null (); sc_escape_len = attach_data.special_ptr -> special_chars.escape_length; sc_input_escape_len = attach_data.special_ptr -> special_chars.input_escapes.len; if gsi.version = SPECIAL_INFO_STRUCT_VERSION_1 then do; allocate special_chars_struc set (gsi.table_ptr) in (gsi_area); gsi.table_ptr -> special_chars_struc.version = SPECIAL_VERSION_2; addr (gsi.table_ptr -> special_chars_struc.special_chars) -> special_chars = attach_data.special_ptr -> special_chars; end; else do; allocate special_chars_struc_old set (gsi_old.table_ptr) in (gsi_area_old); gsi_old.table_ptr -> special_chars_struc_old.version = SPECIAL_VERSION; call copy_new_to_old_special_table; if Code ^= 0 then do; free gsi_old.table_ptr -> special_chars_struc_old; gsi_old.table_ptr = null; end; end; end; else if Order = "set_special" then do; dcl 1 scs aligned like special_chars_struc based (scs_ptr); dcl scs_ptr ptr; call check_null (); scs_ptr = Info_ptr; /* this used to be a call to require_version but since we need to allow two version numbers, it won't work any more. We will check it inline for now */ if scs.version ^= SPECIAL_VERSION & scs.version ^= SPECIAL_VERSION_2 & scs.version ^= editing_chars_version_2 then do; call error_exit (error_table_$unimplemented_version); end; on cleanup goto FREE_SCS; if scs.default = 1 then do; /* default to what we get from terminal control */ begin; dcl 1 auto_gsi like get_special_info_struc; auto_gsi.version = SPECIAL_INFO_STRUCT_VERSION_1; auto_gsi.area_ptr = get_system_free_area_ (); call iox_$control (target_iocbp, "get_special", addr (auto_gsi), Code); if Code ^= 0 then return; scs_ptr = auto_gsi.table_ptr; end; /* begin */ end; /* then do */ sc_escape_len = scs.special_chars.escape_length; sc_input_escape_len = scs.special_chars.input_escapes.len; allocate special_chars set (temp_ptr); if scs.version = SPECIAL_VERSION_2 then temp_ptr -> special_chars = addr (scs.special_chars) -> special_chars; else call copy_old_to_new_special_table; free attach_data.special_ptr -> special_chars; attach_data.special_ptr = temp_ptr; FREE_SCS: if scs_ptr ^= Info_ptr /* scs is what we got from terminal control, not what the user gave us */ then free scs; end; else if Order = "read_status" then call read_status (); else if (Order = "io_call") | (Order = "io_call_af") then call process_io_call (Iocb_ptr, Order, Info_ptr, Code); else if Order = "set_audit_iocb_ptr" then attach_data.auditor_iocb_ptr = Info_ptr; else if Order = "get_audit_iocb_ptr" then Info_ptr = attach_data.auditor_iocb_ptr; /* Unrecognized at window level, try passing on to tc_. */ else call iox_$control (target_iocbp, Order, Info_ptr, Code); return; update_key_bindings: proc (a_info_ptr); dcl a_info_ptr ptr parameter; line_editor_key_binding_info_ptr = a_info_ptr; if line_editor_key_binding_info.version = line_editor_key_binding_info_version_3 then do; /* Verify that all actions are within the allowed values */ do binding_index = 1 to line_editor_key_binding_info.binding_count; if length (line_editor_key_binding_info.sequence (binding_index)) = 0 then do; call error_exit (error_table_$bad_subr_arg); end; if (line_editor_key_binding_info.action (binding_index) < EXTERNAL_ROUTINE) | (line_editor_key_binding_info.action (binding_index) > HIGHEST_BUILTIN_ROUTINE_VALUE) then do; call error_exit (error_table_$bad_subr_arg); end; if (line_editor_key_binding_info.numarg_action (binding_index) < 0 | line_editor_key_binding_info.numarg_action (binding_index) > HIGHEST_NUMARG_ACTION_VALUE) & ^(line_editor_key_binding_info.action (binding_index) = EXTERNAL_ROUTINE) then do; call error_exit (error_table_$bad_subr_arg); end; end; /* set individual key bindings from structure */ do binding_index = 1 to line_editor_key_binding_info.binding_count; call set_key_binding (line_editor_key_binding_info.sequence (binding_index), line_editor_key_binding_info.action (binding_index), line_editor_key_binding_info.numarg_action (binding_index), line_editor_key_binding_info.editor_routine (binding_index), line_editor_key_binding_info.name (binding_index), line_editor_key_binding_info.description (binding_index), line_editor_key_binding_info.info_path (binding_index)); end; end; else if line_editor_key_binding_info.version = line_editor_key_binding_info_version_2 then do; dcl 1 v2lekbi aligned based (line_editor_key_binding_info_ptr), 2 version char (8), 2 binding_count fixed bin, 2 longest_sequence fixed bin, 2 bindings (line_editor_binding_count refer (v2lekbi.binding_count)), 3 sequence char (line_editor_longest_sequence refer (v2lekbi.longest_sequence)) varying, 3 action fixed bin, 3 numarg_action fixed binary, 3 editor_routine entry (pointer, fixed bin (35)); dcl 1 blank_info_path like line_editor_key_binding_info.info_path; do binding_index = 1 to v2lekbi.binding_count; if length (v2lekbi.sequence (binding_index)) = 0 then do; call error_exit (error_table_$bad_subr_arg); end; if (v2lekbi.action (binding_index) < EXTERNAL_ROUTINE) | (v2lekbi.action (binding_index) > HIGHEST_BUILTIN_ROUTINE_VALUE) then do; call error_exit (error_table_$bad_subr_arg); end; if (v2lekbi.numarg_action (binding_index) < 0 | v2lekbi.numarg_action (binding_index) > HIGHEST_NUMARG_ACTION_VALUE) & ^(v2lekbi.action (binding_index) = EXTERNAL_ROUTINE) then do; call error_exit (error_table_$bad_subr_arg); end; end; blank_info_path.info_dir, blank_info_path.info_entry = ""; /* set individual key bindings from structure */ do binding_index = 1 to v2lekbi.binding_count; call set_key_binding (v2lekbi.sequence (binding_index), v2lekbi.action (binding_index), v2lekbi.numarg_action (binding_index), v2lekbi.editor_routine (binding_index), "", "", blank_info_path); end; end; else call error_exit (error_table_$unimplemented_version); return; end update_key_bindings; set_key_binding: procedure (sequence, action, numarg_action, editor_routine, name, description, info_path); dcl sequence char (*) varying; dcl action fixed bin; dcl numarg_action fixed bin; dcl editor_routine entry (ptr, fixed bin (35)); dcl (name, description) char (*) varying aligned parameter; dcl 1 info_path like line_editor_key_binding_info.info_path parameter; dcl char char (1) aligned; dcl char_fix fixed bin (9); dcl char_index fixed bin; dcl old_ptr pointer; dcl new_ptr pointer; dcl window_io_iox_$free_dispatch_tables entry (ptr); dcl PREFIX fixed bin static options (constant) init (-1); char = substr (sequence, 1, 1); /* If we are setting a single self-insert character, make sure that it can be echo negotiated */ if (action = SELF_INSERT) & (length (sequence) = 1) & (char >= SPACE) & (char < DEL) then call set_break_table (char, "0"b); else call set_break_table (char, "1"b); old_ptr = attach_data.dispatch_table_ptr; /* loop through first characters setting up prefix tables. */ do char_index = 1 to length (sequence) - 1; char_fix = rank (substr (sequence, char_index, 1)); /* If char is not already a prefix, allocate new table. */ if old_ptr -> dispatch_table.key (char_fix).type >= 0 then do; allocate dispatch_table set (new_ptr); new_ptr -> dispatch_table.key (*).type = UNDEFINED; /* chain it in to current table */ old_ptr -> dispatch_table.key (char_fix).next_table = new_ptr; old_ptr -> dispatch_table.key (char_fix).type = PREFIX; end; old_ptr = old_ptr -> dispatch_table.key (char_fix).next_table; end; char_fix = rank (substr (sequence, length (sequence), 1)); /* If a prefix turns into a leaf, free the old dispatch table */ if old_ptr -> dispatch_table.key (char_fix).type = PREFIX then call window_io_iox_$free_dispatch_tables (old_ptr -> dispatch_table.key (char_fix).next_table); /* Set the specified dispatch table entry. */ old_ptr -> dispatch_table.key (char_fix).type = action; if action = EXTERNAL_ROUTINE then do; old_ptr -> dispatch_table.key (char_fix).routine = editor_routine; old_ptr -> dispatch_table.key (char_fix).numarg_action = numarg_action; end; old_ptr -> dispatch_table.key (char_fix).name = name; old_ptr -> dispatch_table.key (char_fix).description = description; old_ptr -> dispatch_table.key (char_fix).info_path = info_path; return; get_key_binding: entry (sequence, action, numarg_action, editor_routine, name, description, info_path); old_ptr = attach_data.dispatch_table_ptr; do char_index = 1 to length (sequence) - 1; char_fix = rank (substr (sequence, char_index, 1)); /* If char is not a prefix then complain */ if old_ptr -> dispatch_table.key (char_fix).type >= 0 then signal bad_prefix; old_ptr = old_ptr -> dispatch_table.key (char_fix).next_table; end; char_fix = rank (substr (sequence, length (sequence), 1)); action = old_ptr -> dispatch_table.key (char_fix).type; if action = EXTERNAL_ROUTINE then do; editor_routine = old_ptr -> dispatch_table.key (char_fix).routine; numarg_action = old_ptr -> dispatch_table.key (char_fix).numarg_action; end; if length (old_ptr -> dispatch_table.key (char_fix).name) = 0 then name = builtin_routine_names (max (action, lbound (builtin_routine_names, 1))); else name = old_ptr -> dispatch_table.key (char_fix).name; if length (old_ptr -> dispatch_table.key (char_fix).description) = 0 then description = builtin_descriptions (max (action, lbound (builtin_descriptions, 1))); else description = old_ptr -> dispatch_table.key (char_fix).description; if old_ptr -> dispatch_table.key (char_fix).info_entry = "" then do; if action = EXTERNAL_ROUTINE then do; info_path.info_entry = ""; info_path.info_dir = ""; end; else do; info_path.info_entry = BUILTIN_INFO_ENTRY; info_path.info_dir = BUILTIN_INFO_DIR; end; end; else info_path = old_ptr -> dispatch_table.key (char_fix).info_path; return; end set_key_binding; make_key_bindings_copy: procedure (new_ptr); dcl new_ptr ptr; /* (output) points to a copy of the dispatch table hierarchy */ call copy_dispatch_table (attach_data.dispatch_table_ptr, new_ptr); return; copy_dispatch_table: procedure (old_ptr, new_ptr); dcl (old_ptr, new_ptr) ptr; dcl key_num fixed bin; allocate dispatch_table in (attach_data_area) set (new_ptr); new_ptr -> dispatch_table = old_ptr -> dispatch_table; do key_num = lbound (old_ptr -> dispatch_table.key, 1) to hbound (old_ptr -> dispatch_table.key, 1); if old_ptr -> dispatch_table.key (key_num).type < 0 then call copy_dispatch_table (old_ptr -> dispatch_table.key (key_num).next_table, new_ptr -> dispatch_table.key (key_num).next_table); end; return; end copy_dispatch_table; end make_key_bindings_copy; process_io_call: procedure (io_call_iocb, io_call_order, io_call_infop, code); dcl io_call_iocb pointer parameter; dcl io_call_order char (*) parameter; dcl code fixed bin (35) parameter; %include io_call_info; dcl iocb_ptr pointer; dcl order char (32); dcl caller char (32); dcl called_as_af bit (1); dcl i fixed bin; dcl arg_index fixed bin; dcl entry_name char (65); /* 32 + 1 + 32 */ dcl 1 MHI aligned like more_handler_info; dcl 1 MRI aligned like more_responses_info; dcl 1 MPI aligned like more_prompt_info; dcl 1 TCI aligned like token_characters_info; dcl 1 WSI aligned like window_status_info; dcl 1 EC aligned like editing_chars; dcl error_table_$wrong_no_of_args fixed bin (35) external; dcl error_table_$undefined_order_request fixed bin (35) external; dcl error_table_$noarg fixed bin (35) external; dcl error_table_$bad_arg fixed bin (35) external; dcl error_table_$badopt fixed bin (35) external; dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry); code = 0; iocb_ptr = io_call_iocb -> iocb.actual_iocb_ptr; if io_call_order = "io_call" then called_as_af = "0"b; else do; called_as_af = "1"b; io_call_af_ret = ""; end; order = io_call_info.order_name; caller = io_call_info.caller_name; if order = "set_more_handler" then do; if io_call_info.nargs = 0 then do; call io_call_info.error (0, "", "usage: io_call control window_switch set_more_handler more_handler"); return; end; if io_call_info.nargs > 1 then do; call io_call_info . error (error_table_$wrong_no_of_args, caller, "Only one more handler name may be specified. ^a", order); return; end; MHI.version = more_handler_info_version_3; MHI.more_handler = cv_entry_ ((io_call_info.args (1)), codeptr (process_io_call), code); if code ^= 0 then do; call io_call_info . error (code, caller, "Could not covert ""^a"" to an entry value. ^a", io_call_info.args (1), order); code = 0; return; end; call iox_$control (iocb_ptr, order, addr (MHI), code); if code ^= 0 then call io_call_info.error (code, caller, "While setting more handler. ^a", order); code = 0; return; end; else if order = "get_more_handler" then do; call io_call_require_no_args (); MHI.version = more_handler_info_version_3; call iox_$control (iocb_ptr, order, addr (MHI), code); if code ^= 0 & code ^= video_et_$no_more_handler_in_use then do; call io_call_info.error (code, caller, "While getting more handler. ^a", order); code = 0; return; end; if code = video_et_$no_more_handler_in_use then do; if called_as_af then call ioa_$rsnnl ("NONE", io_call_af_ret, (0)); else call io_call_info.report ("No more handler in use."); code = 0; return; end; call entry_var_to_string (MHI.more_handler, entry_name, code); if code ^= 0 then do; call io_call_info.error (code, caller, "While getting name of more handler. ^a", order); code = 0; return; end; if called_as_af then call ioa_$rsnnl ("^a", io_call_af_ret, (0), rtrim (entry_name)); else call io_call_info.report ("More handler: ^a", rtrim (entry_name)); return; end; else if order = "set_more_responses" then do; if io_call_info.nargs = 0 then do; call io_call_info . error (0, "", "usage: io_call control window_switch set_more_responses yes_responses no_responses"); return; end; if io_call_info.nargs < 2 then do; call io_call_info . error (error_table_$wrong_no_of_args, caller, "Both yes and no responses must be specified. ^a", order); return; end; if io_call_info.nargs > 2 then do; call io_call_info . error (error_table_$wrong_no_of_args, caller, "Only one yes response string and one no response string may be specified. ^a", order); return; end; MRI.version = more_responses_info_version_1; MRI.n_yeses = length (io_call_info.args (1)); MRI.yeses = io_call_info.args (1); MRI.n_noes = length (io_call_info.args (2)); MRI.noes = io_call_info.args (2); /* rely on real control order to validate responses */ call iox_$control (iocb_ptr, order, addr (MRI), code); if code ^= 0 then call io_call_info.error (code, caller, "While setting more responses. ^a", order); code = 0; return; end; else if order = "get_more_responses" then do; call io_call_require_no_args (); MRI.version = more_responses_info_version_1; call iox_$control (iocb_ptr, order, addr (MRI), code); if code ^= 0 then do; call io_call_info.error (code, caller, "While getting more repsonses. ^a", order); code = 0; return; end; if called_as_af then call ioa_$rsnnl ("^a ^a", io_call_af_ret, (0), substr (MRI.yeses, 1, MRI.n_yeses), substr (MRI.noes, 1, MRI.n_noes)); else do; dcl (yeses, noes) char (255) varying init (""); do i = 1 to max (MRI.n_yeses, MRI.n_noes); if i <= MRI.n_yeses then yeses = yeses || flat_rep (substr (MRI.yeses, i, i + 1)) || " "; if i <= MRI.n_noes then noes = noes || flat_rep (substr (MRI.noes, i, i + 1)) || " "; end; /* do loop */ call io_call_info . report ("Yes Response^[s^]: ""^a"" No Response^[s^]: ""^a""", MRI.n_yeses > 1, yeses, MRI.n_noes > 1, noes); end; return; end; else if order = "set_more_prompt" then do; if io_call_info.nargs = 0 then do; call io_call_info.error (0, "", "usage: io_call control window_switch set_more_prompt prompt_string"); return; end; if io_call_info.nargs > 1 then do; call io_call_info . error (error_table_$wrong_no_of_args, caller, "Only one more prompt string may be specified. ^a", order); return; end; MPI.version = more_prompt_info_version_1; MPI.more_prompt = io_call_info.args (1); call iox_$control (iocb_ptr, order, addr (MPI), code); if code ^= 0 then call io_call_info.error (code, caller, "While setting more prompt. ^a", order); code = 0; return; end; else if order = "get_more_prompt" then do; call io_call_require_no_args (); MPI.version = more_prompt_info_version_1; call iox_$control (iocb_ptr, order, addr (MPI), code); if code ^= 0 then do; call io_call_info.error (code, caller, "While getting more prompt. ^a", order); code = 0; return; end; if called_as_af then call ioa_$rsnnl ("^a", io_call_af_ret, (0), MPI.more_prompt); else call io_call_info.report ("More prompt: ""^a""", MPI.more_prompt); return; end; else if order = "set_editor_key_bindings" then do; if io_call_info.nargs = 0 then do; binding_usage: call io_call_info . error (0, "", "usage: io_call control window_switch set_editor_key_bindings character_sequence1 {editor_routine1} {control_args_1} ... {character_sequenceN {editor_routineN} {control_argsN}}" ); return; end; /* Prepare to build args structure. */ /* Pass one, count number bindings and get max length, don't validate args at all */ line_editor_binding_count = 0; line_editor_longest_sequence = 0; call count_key_binding_args (1 /* arg_index */, line_editor_binding_count, line_editor_longest_sequence); if line_editor_binding_count = 0 | line_editor_longest_sequence = 0 then goto binding_usage; /* must not know what's going on */ allocate line_editor_key_binding_info set (line_editor_key_binding_info_ptr); on cleanup free line_editor_key_binding_info; line_editor_key_binding_info.version = line_editor_key_binding_info_version_3; /* Fill in the individual bindings. */ /* now check the control arg validity */ call process_key_bindings (1 /* arg_index */, 1 /* binding_index */); call iox_$control (iocb_ptr, order, line_editor_key_binding_info_ptr, code); revert cleanup; free line_editor_key_binding_info; if code ^= 0 then call io_call_info.error (code, caller, "While setting key bindings. ^a", order); code = 0; return; end; else if order = "get_editor_key_bindings" then do; if io_call_info.nargs ^= 1 then do; call io_call_info . error (0, "", "usage: io_call control window_switch get_editor_key_bindings character_sequence"); call error_exit (Code); end; begin; dcl 1 gekbi aligned like get_editor_key_bindings_info; dcl 1 lekbi aligned like line_editor_key_binding_info based (gekbi.key_binding_info_ptr); gekbi.version = get_editor_key_bindings_info_version_1; string (gekbi.flags) = ""b; gekbi.key_binding_info_ptr = null (); line_editor_binding_count = 1; line_editor_longest_sequence = length (io_call_info.args (1)); on cleanup begin; if gekbi.key_binding_info_ptr = null () then free line_editor_key_binding_info in (attach_data_area); end; allocate lekbi in (attach_data_area); lekbi.version = line_editor_key_binding_info_version_3; lekbi.sequence (1) = io_call_info.args (1); call iox_$control (iocb_ptr, order, addr (gekbi), code); if code ^= 0 then do; call io_call_info . error (code, caller, "Getting the binding of ^a. ^a", requote_string_ ((io_call_info.args (1))), order); return; end; dcl routine_pathname char (256); if lekbi.action (1) = EXTERNAL_ROUTINE then do; call entry_var_to_string (lekbi.editor_routine (1), routine_pathname, code); if code ^= 0 then return; end; /* Note, numarg actions for builtins are only defined in window_io_iox_, so we don't return them here. There should be a way to get at them. */ if called_as_af then do; /* it is easier to get right this way, rather than to have one really hairy ioa_$rsnnl ... */ if lekbi.action (1) = EXTERNAL_ROUTINE then call ioa_$rsnnl ("^a ^a -numarg_action ^a -name ^a -description ^a ^[-info_pathname ^a]", io_call_af_ret, (0), requote_string_ ((lekbi.sequence (1))), requote_string_ (rtrim (routine_pathname)), numarg_action_names (lekbi.numarg_action (1)), requote_string_ (rtrim (lekbi.name (1))), requote_string_ (rtrim (lekbi.description (1))), (lekbi.info_entry (1) ^= "") /* empty path? */, requote_string_ (rtrim (pathname_ (lekbi.info_dir (1), lekbi.info_entry (1))))); else if lekbi.action (1) > EXTERNAL_ROUTINE then /* a builtin */ call ioa_$rsnnl ("^a -builtin ^a -description ^a^[ -info_pathname ^a^]", io_call_af_ret, (0), lekbi.sequence (1), builtin_routine_names (lekbi.action (1)), requote_string_ (rtrim (lekbi.description (1))), (lekbi.info_entry (1) ^= "") /* empty path? */, requote_string_ (rtrim (pathname_ (lekbi.info_dir (1), lekbi.info_entry (1))))); else /* a prefix key, for sure */ call ioa_$rsnnl ("^a -name PREFIX -description ^a", io_call_af_ret, (0), requote_string_ ((lekbi.sequence (1))), requote_string_ (rtrim (lekbi.description (1)))); end; /* case for AF */ else call io_call_info . report ( "Sequence: ^a^/ ^[Num-arg action: ^a^/ Procedure: ^a^/ ^;^2s^]Name: ^a^/ Description: ^a^[^/ Info path: ^a^]", flat_rep_string (lekbi.sequence (1)), (lekbi.action (1) = EXTERNAL_ROUTINE), numarg_action_names (lekbi.numarg_action (1)), routine_pathname, lekbi.name (1), lekbi.description (1), (lekbi.info_entry (1) ^= "") /* no path supplied */, pathname_ (lekbi.info_dir (1), lekbi.info_entry (1))); revert cleanup; free lekbi in (attach_data_area); end; code = 0; return; end; else if order = "set_token_characters" then do; if io_call_info.nargs = 0 then do; call io_call_info . error (0, "", "usage: io_call control window_switch set_token_characters token_character_string") ; return; end; if io_call_info.nargs > 1 then do; call io_call_info . error (error_table_$wrong_no_of_args, caller, "Only one string of token characters may be specified. ^a", order); return; end; TCI.version = token_characters_info_version_1; TCI.token_character_count = length (io_call_info.args (1)); TCI.token_characters = io_call_info.args (1); call iox_$control (iocb_ptr, order, addr (TCI), code); if code ^= 0 then call io_call_info.error (code, caller, "While setting token characters. ^a", order); code = 0; return; end; else if order = "get_token_characters" then do; call io_call_require_no_args (); TCI.version = token_characters_info_version_1; call iox_$control (iocb_ptr, order, addr (TCI), code); if code ^= 0 then do; call io_call_info.error (code, caller, "While getting token characters. ^a", order); code = 0; return; end; if called_as_af then io_call_af_ret = substr (TCI.token_characters, 1, TCI.token_character_count); else call io_call_info.report ("^a", substr (TCI.token_characters, 1, TCI.token_character_count)); return; end; else if order = "get_window_status" then do; call io_call_require_no_args (); WSI.version = window_status_version_1; call iox_$control (iocb_ptr, order, addr (WSI), code); if code ^= 0 then do; call io_call_info.error (code, caller, "While getting window status. ^a", order); code = 0; return; end; if called_as_af then do; if (WSI.status_string = ""b) then io_call_af_ret = "NONE"; else call ioa_$rsnnl ("^[SCREEN_INVALID ^]^[ASYNC_CHANGE ^]^[TTP_CHANGE ^]^[RECONNECTION^]", io_call_af_ret, (0), (WSI.status_string & W_STATUS_SCREEN_INVALID), (WSI.status_string & W_STATUS_ASYNC_EVENT), (WSI.status_string & W_STATUS_TTP_CHANGE), (WSI.status_string & W_STATUS_RECONNECTION)); end; else call io_call_info . report ( "There was ^[no ^]^[screen_invalid ^]^[async_change ^]^[ttp_change ^]^[reconnection ^]status pending for the window.", (WSI.status_string = ""b), (WSI.status_string & W_STATUS_SCREEN_INVALID), (WSI.status_string & W_STATUS_ASYNC_EVENT), (WSI.status_string & W_STATUS_TTP_CHANGE), (WSI.status_string & W_STATUS_RECONNECTION)); return; end; else if order = "set_window_status" then do; if io_call_info.nargs = 0 then do; call io_call_info .error (0, "", "usage: io control window_switch set_window_status status_key_1 {status_key_2}"); return; end; WSI.version = window_status_version_1; do arg_index = 1 to io_call_info.nargs; if io_call_info.args (arg_index) = "screen_invalid" then WSI.status_string = WSI.status_string | W_STATUS_SCREEN_INVALID; else if io_call_info.args (arg_index) = "asynchronous_change" | io_call_info.args (arg_index) = "async_change" then WSI.status_string = WSI.status_string | W_STATUS_ASYNC_EVENT; else if io_call_info.args (arg_index) = "terminal_type_change" | io_call_info.args (arg_index) = "ttp_change" then WSI.status_string = WSI.status_string | W_STATUS_TTP_CHANGE; else if io_call_info.args (arg_index) = "reconnection" then WSI.status_string = WSI.status_string | W_STATUS_RECONNECTION; else do; call io_call_info . error (error_table_$bad_arg, caller, "Only screen_invalid or asynchronous_change is allowed, not ""^a."" ^a", io_call_info.args (arg_index), order); return; end; end; /* do loop */ call iox_$control (iocb_ptr, order, addr (WSI), code); return; end; /* this is a bit much for a pretty worthless control order (after all there is stty -edit), but if we're going to do it, let's do it right */ else if order = "set_editing_chars" then do; if io_call_info.nargs = 0 then do; call io_call_info .error (0, "", "usage: io_call control window_switch set_editing_chars erase_kill_characters"); return; end; if io_call_info.nargs > 1 then do; call io_call_info . error (error_table_$wrong_no_of_args, caller, "Only one set of editing characters may be specified. ^a", order); return; end; if length (io_call_info.args (1)) < 2 then do; call io_call_info . error (error_table_$bad_arg, caller, "Both erase and kill characters must be specified. ^a", order); return; end; if length (io_call_info.args (1)) > 3 then do; call io_call_info . error (error_table_$bad_arg, caller, "Only one erase character, one kill character and one redisplay character may be specified. ^a", order); return; end; EC.erase = substr (io_call_info.args (1), 1, 1); EC.kill = substr (io_call_info.args (1), 2, 1); if length (io_call_info.args (1)) = 3 then do; EC.version = editing_chars_version_3; EC.redisplay = substr (io_call_info.args (1), 3, 1); end; else do; EC.version = editing_chars_version_2; EC.redisplay = ""; end; call iox_$control (iocb_ptr, order, addr (EC), code); if code ^= 0 then call io_call_info.error (code, caller, "While setting editing characters. ^a", order); return; end; else if order = "get_editing_chars" then do; call io_call_require_no_args (); EC.version = editing_chars_version_3; call iox_$control (iocb_ptr, order, addr (EC), code); if code ^= 0 then return; if called_as_af then call ioa_$rsnnl ("^a^a^a", io_call_af_ret, (0), EC.erase, EC.kill, EC.redisplay); else call io_call_info . report ("Erase: ^a, Kill: ^a, Redisplay: ^a", flat_rep (EC.erase), flat_rep (EC.kill), flat_rep (EC.redisplay)); return; end; code = error_table_$undefined_order_request; return; io_call_require_no_args: procedure; if io_call_info.nargs ^= 0 then do; call io_call_info . error (error_table_$wrong_no_of_args, caller, "No arguments are allowed for the ^a order.", order); call error_exit (Code); end; end io_call_require_no_args; /* Count the number of args (and longest key sequence) for set_editor_key_bindings, so we can allocate the line_editor_key_binding_structure (refer extents). The only validity checking done here is to ensure that a reasonable number of arguments were given (i.e. we catch "\033 foo \034", here and complain about now editor routine for \034), but all other checking is done later. */ /* We get called once for each key binding to be set, thus we know that arg_index will always start pointing at the key sequence */ count_key_binding_args: procedure (arg_index, binding_count, longest_key_sequence); dcl arg_index fixed bin, binding_count fixed bin, longest_key_sequence fixed bin; dcl ctl_arg_flag bit (1); do while (arg_index <= io_call_info.nargs); if arg_index = io_call_info.nargs then do; if index (io_call_info.args (arg_index), "-") = 1 then return; call io_call_info . error (error_table_$noarg, caller, "Editor routine for character sequence ""^a"" must be specified.", io_call_info.args (arg_index)); call error_exit (Code); end; longest_key_sequence = max (length (io_call_info.args (arg_index)), longest_key_sequence); binding_count = binding_count + 1; arg_index = arg_index + 1; if index (io_call_info.args (arg_index), "-") ^= 1 then arg_index = arg_index + 1; /* skip over external routine name */ /* skip over any control args (-control_arg arg), -control_arg -control_arg will squeak by here but will be caught later */ if arg_index <= io_call_info.nargs then if index (io_call_info.args (arg_index), "-") = 1 then do; ctl_arg_flag = "1"b; do while (ctl_arg_flag); arg_index = arg_index + 2; if arg_index < io_call_info.nargs then ctl_arg_flag = (index (io_call_info.args (arg_index), "-") = 1); else ctl_arg_flag = "0"b; end; /* do while */ end; end; /* main do while loop */ return; end count_key_binding_args; /* fill in line_editor_key_binding_info */ process_key_bindings: procedure (arg_index, binding_index); dcl arg_index fixed bin; dcl binding_index fixed bin; dcl 1 flags aligned, 2 builtin_given unaligned bit (1), 2 external_given unaligned bit (1), 2 numarg_action_given unaligned bit (1); do while (arg_index <= io_call_info.nargs); unspec (flags) = ""b; /* copy the sequence directly from the command line */ line_editor_key_binding_info.sequence (binding_index) = io_call_info.args (arg_index); /*** Initialize the strings to blanks ***/ line_editor_key_binding_info.name, line_editor_key_binding_info.description, line_editor_key_binding_info.info_dir, line_editor_key_binding_info.info_entry = ""; arg_index = arg_index + 1; if index (io_call_info.args (arg_index), "-") ^= 1 then do; line_editor_key_binding_info.action (binding_index) = EXTERNAL_ROUTINE; /* convert the companion arg to an entry */ line_editor_key_binding_info.editor_routine (binding_index) = cv_entry_ ((io_call_info.args (arg_index)), codeptr (process_io_call), code); if code ^= 0 then do; call io_call_info . error (code, caller, "Could not convert ""^a"" to an entry value. ^a", io_call_info.args (arg_index), order); code = 0; call error_exit (Code); end; external_given = "1"b; builtin_given = "0"b; arg_index = arg_index + 1; /* fall through to check for control args for this external editor request */ end; if arg_index <= io_call_info.nargs then if index (io_call_info.args (arg_index), "-") = 1 then /* a control arg */ call process_control_args (arg_index, binding_index); if ^(builtin_given | external_given) then do; call io_call_info . error (error_table_$noarg, caller, "Editor routine for character sequence ""^a"" must be specified. ^a", line_editor_key_binding_info.sequence (binding_index), order); call error_exit (Code); end; if builtin_given & numarg_action_given then do; call io_call_info . error (error_table_$inconsistent, caller, "Numarg action may not be specified for builtin routines. ^a", order); call error_exit (Code); end; if ^numarg_action_given & external_given then line_editor_key_binding_info.numarg_action (binding_index) = PASS; binding_index = binding_index + 1; end; /* do while */ return; /* Process control args for set_editor_key_bindings. arg_index will be left set to the next non-control arg */ process_control_args: procedure (arg_index, binding_index); dcl arg_index fixed bin; dcl binding_index fixed bin; dcl builtin_index fixed bin; dcl numarg_index fixed bin; dcl arg char (arg_len) varying based (arg_ptr); dcl next_arg char (next_arg_len) varying based (next_arg_ptr); dcl (arg_len, next_arg_len) fixed bin (21); dcl (arg_ptr, next_arg_ptr) ptr; dcl found bit (1); dcl uppercase char (26) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl lowercase char (26) static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); do while (arg_index <= io_call_info.nargs); arg_ptr = addr (io_call_info.args (arg_index)); arg_len = length (io_call_info.args (arg_index)); if index (arg, "-") ^= 1 then return; /* done with control args for this key binding */ if ^(arg = "-builtin" | arg = "-external" | arg = "-numarg_action" | arg = "-name" | arg = "-description" | arg = "-info_pathname") then do; call io_call_info.error (error_table_$badopt, caller, "^a. ^a", arg, order); call error_exit (Code); end; if arg_index = io_call_info.nargs then do; call io_call_info .error (error_table_$noarg, caller, """^a"" requires an argument. ^a", arg, order); call error_exit (Code); end; next_arg_ptr = addr (io_call_info.args (arg_index + 1)); next_arg_len = length (io_call_info.args (arg_index + 1)); if arg = "-external" then do; line_editor_key_binding_info.action (binding_index) = EXTERNAL_ROUTINE; /* convert the companion arg to an entry */ line_editor_key_binding_info.editor_routine (binding_index) = cv_entry_ ((next_arg), codeptr (process_io_call), code); if code ^= 0 then do; call io_call_info . error (code, caller, "Could not convert ""^a"" to an entry value. ^a", next_arg, order); code = 0; call error_exit (Code); end; external_given = "1"b; builtin_given = "0"b; end; /* We assume that builtin names are all uppercase, and we uppercase the user supplied name before doing the comparision, so that everything is case insensitive. Same goes for numarg_action. */ if arg = "-builtin" then do; /* skip EXTERNAL_ROUTINE */ begin; dcl next_arg_uppercase char (next_arg_len); found = "0"b; next_arg_uppercase = translate (next_arg, uppercase, lowercase); do builtin_index = 1 to HIGHEST_BUILTIN_ROUTINE_VALUE while (^found); if builtin_routine_names (builtin_index) = next_arg_uppercase then found = "1"b; end; /* do while */ end; /* begin */ if ^found then do; call io_call_info . error (error_table_$bad_arg, caller, """^a"" is not a builtin editor function. ^a", next_arg, order); call error_exit (Code); end; line_editor_key_binding_info.action (binding_index) = builtin_index - 1; /* do loop adds one */ builtin_given = "1"b; external_given = "0"b; end; else if arg = "-numarg_action" then do; begin; dcl next_arg_uppercase char (next_arg_len); found = "0"b; next_arg_uppercase = translate (next_arg, uppercase, lowercase); do numarg_index = 0 to HIGHEST_NUMARG_ACTION_VALUE while (^found); if numarg_action_names (numarg_index) = next_arg_uppercase then found = "1"b; end; /* do while */ end; /* begin */ if ^found then do; call io_call_info . error (error_table_$bad_arg, caller, """^a"" is not a valid numarg action. ^a", next_arg, order); call error_exit (Code); end; line_editor_key_binding_info.numarg_action (binding_index) = numarg_index - 1; /* do loop adds one */ numarg_action_given = "1"b; end; else if arg = "-name" then line_editor_key_binding_info.name (binding_index) = next_arg; else if arg = "-description" then line_editor_key_binding_info.description (binding_index) = next_arg; else if arg = "-info_pathname" then do; call expand_pathname_$add_suffix ((next_arg), "info", line_editor_key_binding_info.info_dir (binding_index), line_editor_key_binding_info.info_entry (binding_index), code); if code ^= 0 then do; call io_call_info.error (code, caller, "The pathname ""^a"". ^a", next_arg, order); call error_exit (Code); end; end; arg_index = arg_index + 2; /* make sure we call by reference */ end; /* do while */ return; end process_control_args; end process_key_bindings; end process_io_call; require_version: proc (version_found, latest); dcl version_found fixed bin parameter; dcl latest fixed bin parameter; if version_found ^= latest & version_found ^= editing_chars_version_2 then do; call error_exit (error_table_$unimplemented_version); end; end require_version; require_version_str: proc (version_found, latest); dcl version_found char (8) aligned; dcl latest char (8); if version_found ^= latest then do; call error_exit (error_table_$unimplemented_version); end; end require_version_str; check_null: procedure; if Info_ptr = null () then do; call error_exit (error_table_$null_info_ptr); end; end check_null; require_mbz: proc (bit_string); dcl bit_string bit (*); if bit_string ^= ""b then do; call error_exit (error_table_$bad_subr_arg); end; end require_mbz; setup: procedure; attach_data_ptr = Iocb_ptr -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; Code = 0; target_iocbp = attach_data.target_iocb_ptr; end setup; always_breaks: procedure (c) returns (bit (1) aligned) reducible; dcl c char (1) aligned parameter; return (rank (c) <= 31 | c = byte (bin ("177"b3)) /* DEL */); end always_breaks; set_break_table: proc (c, flag); dcl c char (1) aligned; dcl flag bit (1) unaligned; if (rank (c) >= lbound (line_editor_breaks_array, 1)) & (rank (c) <= hbound (line_editor_breaks_array, 1)) then line_editor_breaks_array (rank (c)) = always_breaks (c) | flag; end set_break_table; /* Stolen from window_io_iox_ for get_more_responses, get_editing_chars, and now get_editor_keybindings */ flat_rep: procedure (c) returns (char (32) varying) reducible; dcl c character (1); if c = byte (bin ("015"b3)) then return ("RETURN"); if c = byte (bin ("033"b3)) then return ("ESC"); if c < " " then return ("^" || byte (rank (c) + rank ("@"))); if c = " " then return ("SPACE"); if c = byte (bin ("177"b3)) then return ("DEL"); return (c); end flat_rep; flat_rep_string: proc (P_string) returns (char (*)) reducible; dcl P_string char (*) varying; dcl char_idx fixed bin (21); if length (P_string) = 0 then return (""); /* prevent stringrange below */ begin; dcl flat_string char (7 * length (P_string)) varying init (""); do char_idx = 1 to length (P_string) - 1; flat_string = flat_string || flat_rep (substr (P_string, char_idx, 1)) || " "; end; flat_string = flat_string || flat_rep (substr (P_string, length (P_string), 1)); return ((flat_string)); end; end flat_rep_string; /* This is for get_more_handler and for get_editor_key_bindings. It takes an entry variable and turns it into a segname$entry string, leaving out the full pathname. JR 8/7/83 */ entry_var_to_string: procedure (routine, entry_string, code); dcl routine entry; dcl entry_string char (*); dcl code fixed bin (35); dcl seg_name char (32); /* only the entryname, not the directory */ dcl entry_point_name char (32); /* entry point within the segment */ dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl get_entry_name_ entry (ptr, char (*), fixed bin (18), char (8) aligned, fixed bin (35)); dcl 1 entry_variable aligned based, 2 code_ptr ptr, 2 env_ptr ptr; call hcs_$fs_get_path_name (addr (routine) -> entry_variable.code_ptr, "", (0), seg_name, code); if code ^= 0 then return; call get_entry_name_ (addr (routine) -> entry_variable.code_ptr, entry_point_name, (0), "", code); if code ^= 0 then return; entry_string = rtrim (seg_name) || "$" || rtrim (entry_point_name); return; end entry_var_to_string; /* This really doesn't belong here. It causes this module to have the knowledge of how to call tc_. It fit much better in window_io_video_. It also really doesn't work well from tc_ either, otherwise I would just pass the order through and deal with it there. Perhaps the read_status proc in tc_input should be an entry, and we (or tc_) could just call it. But for now ... -- JR 2/1/84 */ read_status: proc (); %include tc_operations_; /* ugh ... this shouldn't be here */ %include tty_read_status_info; dcl 1 rqrs aligned like request_read_status; /* let's pretend to be window_/window_io_video_ */ rqrs.sentinel = REQUEST_SENTINEL; rqrs.window_id = attach_data.window_id; rqrs.request_id = clock (); rqrs.operation = OP_READ_STATUS; rqrs.row = attach_data.current.line_origin; /* 1,1 is as good as any ... this prevents out_of_bounds faults way down at tc_ */ rqrs.col = attach_data.current.column_origin; /* note, these are terminal coords not window coords */ string (rqrs.flags) = ""b; call iox_$control (target_iocbp, "window_operation", addr (rqrs), Code); if Code ^= 0 then return; /* This should deal with window_status_pending, at least for the reconnection case (or until then the check_in window kludge), but not now. */ Info_ptr -> tty_read_status_info.event_channel = rqrs.event_channel; Info_ptr -> tty_read_status_info.input_pending = rqrs.returned_length > 0; return; end read_status; error_exit: proc (a_code); dcl a_code fixed bin (35) parameter; Code = a_code; go to error_return; end error_exit; error_return: return; %page; copy_new_to_old_special_table: proc; /* special procedure to copy a version 2 special chars structure (15 char sequences) to a version 1 special chars structure (3 char sequences). If any of the sequences are too long, it will return non-zero error code */ dcl i fixed bin; dcl old_max_length fixed bin; Code = 0; old_max_length = hbound (gsi_old.table_ptr -> special_chars_struc_old.nl_seq.chars, 1); if attach_data.special_ptr -> special_chars.nl_seq.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.nl_seq) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.nl_seq) -> c_chars_old; if attach_data.special_ptr -> special_chars.cr_seq.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.cr_seq) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.cr_seq) -> c_chars_old; if attach_data.special_ptr -> special_chars.bs_seq.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.bs_seq) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.bs_seq) -> c_chars_old; if attach_data.special_ptr -> special_chars.tab_seq.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.tab_seq) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.tab_seq) -> c_chars_old; if attach_data.special_ptr -> special_chars.vt_seq.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.vt_seq) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.vt_seq) -> c_chars_old; if attach_data.special_ptr -> special_chars.ff_seq.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.ff_seq) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.ff_seq) -> c_chars_old; if attach_data.special_ptr -> special_chars.printer_on.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.printer_on) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.printer_on) -> c_chars_old; if attach_data.special_ptr -> special_chars.printer_off.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.printer_off) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.printer_off) -> c_chars_old; if attach_data.special_ptr -> special_chars.red_ribbon_shift.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.red_ribbon_shift) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.red_ribbon_shift) -> c_chars_old; if attach_data.special_ptr -> special_chars.black_ribbon_shift.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.black_ribbon_shift) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.black_ribbon_shift) -> c_chars_old; if attach_data.special_ptr -> special_chars.end_of_page.count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.end_of_page) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.end_of_page) -> c_chars_old; gsi_old.table_ptr -> special_chars_struc_old.escape_length = attach_data.special_ptr -> special_chars.escape_length; do i = 1 to attach_data.special_ptr -> special_chars.escape_length; if attach_data.special_ptr -> special_chars.not_edited_escapes (i).count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.not_edited_escapes (i)) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.not_edited_escapes (i)) -> c_chars_old; if attach_data.special_ptr -> special_chars.edited_escapes (i).count > old_max_length then go to bad_special; addr (gsi_old.table_ptr -> special_chars_struc_old.edited_escapes (i)) -> c_chars_old = addr (attach_data.special_ptr -> special_chars.edited_escapes (i)) -> c_chars_old; end; gsi_old.table_ptr -> special_chars_struc_old.input_escapes = attach_data.special_ptr -> special_chars.input_escapes; gsi_old.table_ptr -> special_chars_struc_old.input_results = attach_data.special_ptr -> special_chars.input_results; return; bad_special: Code = error_table_$invalid_array_size; return; end copy_new_to_old_special_table; %page; copy_old_to_new_special_table: proc; /* special procedure to copy a version 1 special chars structure (3 char sequences) to a version 2 special chars structure (15 char sequences). */ dcl i fixed bin; addr (temp_ptr -> special_chars.nl_seq) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.nl_seq) -> c_chars_old; addr (temp_ptr -> special_chars.cr_seq) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.cr_seq) -> c_chars_old; addr (temp_ptr -> special_chars.bs_seq) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.bs_seq) -> c_chars_old; addr (temp_ptr -> special_chars.tab_seq) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.tab_seq) -> c_chars_old; addr (temp_ptr -> special_chars.vt_seq) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.vt_seq) -> c_chars_old; addr (temp_ptr -> special_chars.ff_seq) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.ff_seq) -> c_chars_old; addr (temp_ptr -> special_chars.printer_on) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.printer_on) -> c_chars_old; addr (temp_ptr -> special_chars.printer_off) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.printer_off) -> c_chars_old; addr (temp_ptr -> special_chars.red_ribbon_shift) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.red_ribbon_shift) -> c_chars_old; addr (temp_ptr -> special_chars.black_ribbon_shift) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.black_ribbon_shift) -> c_chars_old; addr (temp_ptr -> special_chars.end_of_page) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.end_of_page) -> c_chars_old; temp_ptr -> special_chars.escape_length = addr (scs.special_chars) -> special_chars_old.escape_length; do i = 1 to attach_data.special_ptr -> special_chars.escape_length; addr (temp_ptr -> special_chars.not_edited_escapes (i)) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.not_edited_escapes (i)) -> c_chars_old; addr (temp_ptr -> special_chars.edited_escapes (i)) -> c_chars_old = addr (addr (scs.special_chars) -> special_chars_old.edited_escapes (i)) -> c_chars_old; end; temp_ptr -> special_chars.input_escapes = addr (scs.special_chars) -> special_chars_struc_old.input_escapes; temp_ptr -> special_chars.input_results = addr (scs.special_chars) -> special_chars_struc_old.input_results; return; end copy_old_to_new_special_table; %page; %include window_io_attach_data_; %include window_control_info; %page; %include iocb; %page; %include tc_desk_info_; %page; %include tty_editing_chars; %page; %include tty_convert; %page; %include iox_dcls; %page; %include mode_string_info; %page; %include window_dcls; %page; %include terminal_type_data; %page; %include terminal_info; end wioctl_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved