



		    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 \<char> */
	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
