



		    fast_hc_ipc.alm                 11/11/89  1109.0r w 11/11/89  0826.9       63027



" ***********************************************************
" *                                                         *
" * 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	fast_hc_ipc
"
"	Coded by B. Greenberg 10/11/78 for shared stack_0.
"	Stupid bug fixed by C. Hornig, December 1979.
"	Changed by E. Donner Jan 81 for new ipc
"	Truncation of stacks 1/82 BIM
"	Modified 1984-11-13 by E. Swenson to remove support for obsolete
"	  hcs_$sfblock entrypoint.
"
	include	stack_frame
	include	stack_header
"
"	Pseudo-frame in real PDS
"

	equ	ipcv.ap,0		Arg ptr to ring <n>
	equ	ipcv.retsw,1	Switch to return
	equ	ipcv.save_entry_ret,2 X6 save.
	equ	ipcv.truncated_stacks,3 Note for metering
	equ	ipcv.chan,4	Fast channel ID save.
	equ	ipcv.block_start_steps,6 sst$steps before block
	equ	ipcv.stk_temp,7    

"
"	Stack vars for call to PL/I IPC.
"
	tempd	argl(1)

	macro	erifnot
	t&1	&U.erifnot
	lda	&2
	sta	ap|4,*
	short_return
&U.erifnot:
	&end
	segdef	ipc_f_block,ipc_block,read_events


"
"
"	fast_hc_ipc$f_block (fast block call)
"
"	This entry returns only when a wakeup is received, either for a
"	fast channel or for a regular channel.  It also calls hc_ipc.
"	It returns information about which fast channel received a wakeup
"	and whether any messages were emptied from the ITT into the ECT.
"
"	dcl fast_hc_ipc$f_block entry (bit (36) aligned, bit (1) aligned);
"
"	call fast_hc_ipc$f_block (fast_channel_events, messages_allocated_in_ect);
"
"	where fast_channel_events indicates on which fast channels are
"	wakeups pending. The other bits in the string are untouched.(input/output)
"	and messages_allocated_in ect = "1"b if any messages were allocated
"	for validation ring (output)
"
"
ipc_f_block:
	getlp
	epplb	pds$ipc_vars
	lxl1	pds$validation_level
	lda	pds$events_pending
	ana	pds$event_masks-1,x1 test for events, this ring
	sta	lb|ipcv.retsw	store the need to return
	lda	pds$ring_events	see whats doing there
	als	-1,x1
	ana	=o400000,du	(messages from other ring)
	orsa	lb|ipcv.retsw
sfb_readevents_merge:
	stz	ap|4,*		assume don't call regular.
	sprpap	lb|ipcv.ap	save ap
	tsx6	common		go blocked or get messages
	lda	pds$events_pending	have called tc.
	ana	pds$event_masks-1,x1
	orsa	lb|ipcv.retsw	now have stuff for this ring.
	ersa	pds$events_pending	now turn off some fast events.
	lprpap	lb|ipcv.ap
	orsa	ap|2,*		store to guy's arg.
	tsx5	check_full_block	dredge out the old cruft
	lprpap	lb|ipcv.ap
	lda	=o400000,du
	sta	ap|4,*		tell caller to call regular.
short_return:
	short_return

"
"
"	ipc_block$fast_hc_ipc 
"
"	This entry goes blocked until the caller receives a wakeup.
"	It then calls hc_ipc.
"
"	dcl fast_hc_ipc$ipc_block entry ();
"
"	call fast_hc_ipc$ipc_block ();
"
"
ipc_block:
	getlp
	epplb	pds$ipc_vars
	stz	lb|ipcv.retsw
	lxl1	pds$validation_level
	tsx6	common
	lda	pds$events_pending
	ana	pds$event_masks-1,x1 check fast events
	orsa	lb|ipcv.retsw	set up to return, have fast evs.
	tsx5	check_full_block	get some events
	short_return


"
"
"	fast_hc_ipc$read_events
"
"	This entry is similiar to fast_hc_ipc$f_block except that
"	it does not go blocked but checks whether a wakeup has arrived.
"
"	dcl fast_hc_ipc$read_events entry (bit (36) aligned, bit (1) aligned);
"
"	call fast_hc_ipc$read_events (fast_channel_events, messages_allocated_in_ect);
"
"
read_events:
	getlp
	epplb	pds$ipc_vars
	stc1	lb|ipcv.retsw	want to return
	lxl1	pds$validation_level
	tra	sfb_readevents_merge join common code
	

common:	eppbp	fast_block_return
	sprpbp	pds$ipc_block_return
	stx6	lb|ipcv.save_entry_ret
	stz	lb|ipcv.truncated_stacks " presumed untouched
	stz	lb|ipcv.stk_temp         " records whether we blocked
	szn	lb|ipcv.retsw
	tnz	pxss$fast_ipc_get_event

" Here we have decided to have pxss block us.

	aos	lb|ipcv.stk_temp       " we blocked

" We truncate stacks if it would save us something

	szn	tc_data$stk_truncate
	tze	no_truncation	" disabled
	szn	tc_data$stk_truncate_always
	tnz	truncate
	szn	tc_data$post_purge_switch
	tnz	truncate		" always truncate if postpurge

	lda	sst$nused		" now many pages?
	als	18		" in units of s**-18
	cmpa	pds$avg_block_steps
	tpl	no_truncation	" stack pages probably will not be
				" evicted.
truncate:
	aos	lb|ipcv.truncated_stacks " note
	
	epbpsb	pds$stack_0_ptr,*
	push

	ldaq	argl_header
	staq	argl 

	call	truncate_stacks$truncate_stacks(argl)
	eppbp	sp|stack_frame.prev_sp,*
	even
	inhibit   on	<+ + + + + + + + + + + + + + + + + + + + + + + +>

	sprisp	sb|stack_header.stack_end_ptr 
	eppsp	bp|0		pop stack
	inhibit	off       <- - - - - - - - - - - - - - - - - - - - - - - ->

no_truncation:
	lda	sst$steps
	sta	lb|ipcv.block_start_steps " Save for averaging
	tra	pxss$fast_ipc_block       " all args in pds vars

"	PXSS returns with SB set to stack_0.

fast_block_return:
	getlp			" relies on SB
	epplb	pds$ipc_vars
	lxl1	pds$validation_level
	ldx6	lb|ipcv.save_entry_ret
	lxl2	lb|ipcv.truncated_stacks  " for offset
	szn	lb|ipcv.stk_temp	      " did we block?
	tze	0,x6		      " NO. return to caller of
				      " common at this point.
" If post_purge is on meters are not valuable
	ldq	sst$steps
	sbq	lb|ipcv.block_start_steps
	szn	tc_data$post_purge_switch
	tnz	truncate_meter_done

	cmpq	sst$nused		" should we have truncated?
	tnc	truncate_incorrect

" the layout in the sst is

"  stk_truncate_should_didnt
"  stk_truncate_should_did
"  stk_truncate_shouldnt_didnt
"  stk_truncate_shouldnt_did
"
" and x2 is 1 iff we truncated

	aos	sst$stk_truncate_should_didnt,x2
	tra	truncate_meter_done
truncate_incorrect:
	aos	sst$stk_truncate_shouldnt_didnt,x2
truncate_meter_done:

"
"  new_average = factor*new_value + (1-factor)*old_value
"
"
	qls	18		" in units of 2**-18
	mpy	tc_data$stk_trunc_avg_f1
	staq	lb|ipcv.block_start_steps " use stk_temp as well
	ldq	pds$avg_block_steps   " fb 35, 18
	mpy	tc_data$stk_trunc_avg_f2  " always 1-f1
	adaq	lb|ipcv.block_start_steps
	lrs	18		  " rescale to 2**-18
	stq	pds$avg_block_steps

	tra	0,x6		return 


check_full_block:
	epbpsb	pds$stack_0_ptr,*
	push
	ldaq	argl_header
	staq	argl
	call	hc_ipc$full_block(argl)
	eppbp	sp|stack_frame.prev_sp,*
	even
	inhibit	on
	sprisp	sb|stack_header.stack_end_ptr 
	eppsp	bp|0		pop stack
	inhibit	off
	lda	=o400000,du
	arl	-1,x1
	cana	pds$ring_events	anything for this ring?
	tze	retj		no, try it all again or return.
	ersa	pds$ring_events	turn off this message ...
	tra	0,5		set return switches, regular-callers, etc.
retj:	szn	lb|ipcv.retsw	Should we return or try more?
	tze	common		Loop, re_using x6.
	short_return

"
argl_header:
	zero	0,4
	zero	0,0


	end




		    hc_ipc.pl1                      11/11/89  1109.0rew 11/11/89  0826.9      160623



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/* format: style3 */
hc_ipc:
     procedure;

/* Rewritten by E Donner Jan 1981 for new ipc */
/* Modified 04/26/82 by S Krupp to print module name with all syserr msgs. */
/* Modified 10/03/83 by Jeffrey I. Schiller to fix bug with messages for
   bad rings. */
/* Modified 1984-11-21 by E. Swenson for IPC event channel validation. */
/* Modified 1985-01-25 by EJ Sharpe to use access_audit_ */


/****^  HISTORY COMMENTS:
  1) change(86-08-09,Kissel), approve(86-08-12,MCR7479),
     audit(86-10-20,Fawcett), install(86-11-03,MR12.0-1206):
     Changed to allow wakeups on fast channels by other than the creating
     process.  The changes to support async event channels are all handled in
     pxss$wakeup.
                                                   END HISTORY COMMENTS */


/*  entries  */

dcl	ipc_validate_$decode_event_channel_name
			entry (fixed bin (18), fixed bin (35), fixed bin (71), bit (3) aligned, fixed bin (15),
			fixed bin (3), bit (1) aligned, fixed bin (18), fixed bin (35));
dcl	ipc_validate_$encode_event_channel_name
			entry (fixed bin (18), fixed bin (35), bit (3) aligned, fixed bin (15), fixed bin (3),
			bit (1) aligned, fixed bin (18), fixed bin (71));
dcl	level$get		entry returns (fixed bin (3));
dcl	access_audit_$log_general
			entry options (variable);
dcl	pxss$free_itt	entry (bit (18) aligned);
dcl	pxss$wakeup	entry (bit (36) aligned, bit (72) aligned, fixed bin (71), fixed bin (35));
dcl	syserr		entry options (variable);
dcl	tc_util$get_ipc_operands
			entry (fixed bin (18), fixed bin (35));
dcl	tc_util$get_ipc_operands_priv
			entry (bit (36) aligned, fixed bin (18), fixed bin (35), fixed bin (35));
dcl	terminate_proc	entry (fixed bin (35));

/* internal static */
dcl	last_sender	bit (36) internal static init ("0"b);
						/* on of the few uses of internal static in ring zero */

/* Constants */

dcl	ME		char (32) initial ("hc_ipc") internal static options (constant);
dcl	OFF		bit (1) aligned internal static options (constant) init ("0"b);
dcl	(ON, YES)		bit (1) aligned internal static options (constant) init ("1"b);
dcl	QUITSTOP		char (8) internal static options (constant) init ("quitstop");

/* external static */
dcl	access_operations_$ipc_wakeup
			bit (36) aligned ext;
dcl	error_table_$ect_full
			fixed bin (35) ext;
dcl	error_table_$inconsistent_ect
			fixed bin (35) ext;
dcl	error_table_$invalid_channel
			fixed bin (35) ext;
dcl	error_table_$itt_overflow
			fixed bin (35) ext;
dcl	error_table_$process_stopped
			fixed bin (35) ext;
dcl	error_table_$process_unknown
			fixed bin (35) ext;
dcl	error_table_$special_channels_full
			fixed bin (35) ext;
dcl	error_table_$wakeup_denied
			fixed bin (35) ext;
dcl	error_table_$wrong_channel_ring
			fixed bin (35) ext;

dcl	pds$event_masks	(7) bit (36) aligned ext;
dcl	pds$events_pending	bit (36) aligned ext;
dcl	pds$itt_head	bit (18) aligned ext;
dcl	pds$process_group_id
			char (32) aligned ext;
dcl	pds$process_id	bit (36) aligned ext;
dcl	pds$ring_events	bit (36) aligned ext;	/* per ring indicator of messages copied from itt to ect */

dcl	pds$special_channels
			bit (36) aligned ext;
dcl	pds$stacks	(0:7) ext ptr;
dcl	tc_data$		fixed bin (17) ext;
dcl	tc_data$max_channels
			fixed bin (35) ext;


/* builtins */

dcl	addr		builtin;
dcl	index		builtin;
dcl	null		builtin;
dcl	ptr		builtin;
dcl	string		builtin;
dcl	substr		builtin;
dcl	unspec		builtin;

/* conditions */

dcl	area		condition;

/* Automatic */

dcl	channel_ring	fixed bin (3);
dcl	code		fixed bin (35);
dcl	ev_chn_flags	bit (3) aligned;
dcl	ev_chn_index	fixed bin (15);
dcl	ev_chn_ring	fixed bin (3);
dcl	ev_chn_type	bit (1) aligned;
dcl	ev_chn_unique_id	fixed bin (18);
dcl	event_channel_name_fb71
			fixed bin (71) automatic;
dcl	event_channel_message
			fixed bin (71);
dcl	fast_channel_id	fixed bin (18);
dcl	1 event_flags	aligned like audit_event_flags;
						/* for access_audit_ */
dcl	1 itt_dummy	like itt_entry aligned;	/* used to send self wakeup */
dcl	itt_relp		bit (18) aligned;
dcl	msg_ptr		ptr;			/* pointer to allocated itt msg entry in ECT */
dcl	r_offset		fixed bin (18);		/* IPC validation operand */
dcl	r_factor		fixed bin (35);		/* IPC validation operand */
dcl	target_process	bit (36) aligned;
dcl	same_process	bit (1) aligned;
dcl	pxss_status	fixed bin (35);
dcl	target_ring	fixed bin (3);		/* target ring of message */
dcl	val_ring		fixed bin (3);

/* based */

dcl	ect_area		area (ect_header.ect_area_size) based (ect_header.ect_areap);
%page;
ipc_wakeup:
     entry (a_target_process, a_event_channel, a_event_channel_message, a_code);

/**** This entry (target of the gate hcs_$wakeup) performs IPC signalling.
      Note that pxss$wakeup may also send an IPS "wkp_" signal if the event
      channel flags indicate that it is that type of event channel.
      It validates the supplied processid as well as the event channel
      name before calling pxss to process the wakeup. */

dcl	a_target_process	bit (36) aligned parameter;
dcl	a_event_channel	fixed bin (71) parameter;
dcl	a_event_channel_message
			fixed bin (71) parameter;
dcl	a_code		fixed bin (35) parameter;

/* wakeup can be called from all rings (1-7) in order to send an IPC
   signal to any currently-active process. It returns the following code:

   code = 0	Signalling correctly accomplished
   code = error_table_$process_stopped
		Signalling correctly done & target process was found to be stopped
   code = error_table_$invalid_channel
	          The specified event channel name was bad.
   code = error_table_$process_unknown
		Target process not found (either process-id wrong or process deactivated)
   code = error_table_$itt_overflow
		ITT overflow resulted, signalling aborted
   code = error_table_$wakeup_denied
		The access authorization of the target process
		is not greater than or equal to the access authorization
		of the sender process, so signalling is aborted.
*/

	code = 0;					/* reset returned code to zero */
	target_process = a_target_process;		/* copy args into stack */
	event_channel_name_fb71 = a_event_channel;	/* copy parameters */
	event_channel_message = a_event_channel_message;

	val_ring = level$get ();			/* save validation level */

	call tc_util$get_ipc_operands_priv (target_process, r_offset, r_factor, code);
	if code ^= 0
	then do;
		call syserr (LOG, "^a: Denied wakeup by ^a in ring ^d.  Invalid process id ^w.", ME,
		     pds$process_group_id, val_ring, target_process);
		goto WAKEUP_RETURNS;
	     end;

	call ipc_validate_$decode_event_channel_name (r_offset, r_factor, event_channel_name_fb71, ev_chn_flags,
	     ev_chn_index, ev_chn_ring, ev_chn_type, ev_chn_unique_id, code);
	if code ^= 0
	then do;
		call syserr (LOG, "^a: Denied wakeup by ^a in ring ^d to process ^w.  Invalid event channel ^24.3b",
		     ME, pds$process_group_id, val_ring, target_process, unspec (event_channel_name_fb71));
		goto WAKEUP_RETURNS;
	     end;

/* is wakeup being sent to self */
	same_process = (target_process = pds$process_id);

/* Determine if channel is a fast channel and do not allow */
/* sending wakeup to an inner ring */

	if ev_chn_type = FAST_CHANNEL_TYPE		/* it's a fast channel */
	then do;
		if ev_chn_ring < val_ring
		then do;
			code = error_table_$invalid_channel;
			call syserr (LOG,
			     "^a: Denied wakeup by ^a in ring ^d to process ^w.  Fast channel (^24.3b) not allowed.",
			     ME, pds$process_group_id, val_ring, target_process, unspec (event_channel_name_fb71));

			go to WAKEUP_RETURNS;
		     end;
	     end;

/* It's not a fast channel and sending self wakeup */
/* Special case - avoid calling pxss and allocate entry in ECT directly */

	else if (same_process = YES)
	then do;
		if ev_chn_ring = val_ring
		then do;
			unspec (itt_dummy) = "0"b;	/* set up replica of entry in ITT */
						/* fill in values */
			itt_dummy.sender, itt_dummy.target_id = target_process;
			itt_dummy.ring = val_ring;
			unspec (itt_dummy.channel_id) = unspec (event_channel_name_fb71);
			itt_dummy.message = event_channel_message;

			on area call ect_error_handler (error_table_$ect_full, target_ring);

			call dispatch_message (addr (itt_dummy), target_ring);
			if target_ring > 0
			then go to WAKEUP_RETURNS;	/* it should be done */
		     end;

	     end;

/* send wakeup to other process or send wakeup over fast channel */
/* call wakeup which does checks for overflow of ITT */

	code = 0;					/* Start clean. */

	call pxss$wakeup (target_process, unspec (event_channel_name_fb71), event_channel_message, pxss_status);

	if pxss_status = 0
	then code = error_table_$process_unknown;	/* target process unknown */

	else if pxss_status = 5
	then code = error_table_$process_stopped;	/* target process is quit */

	else if pxss_status = 100
	then do;
		string (event_flags) = ""b;
		call access_audit_$log_general (ME, val_ring, string (event_flags), access_operations_$ipc_wakeup, "",
		     0, null (), 0, "Target process (^w) authorization is lower", target_process);
		code = error_table_$wakeup_denied;
	     end;

	else if pxss_status = 200
	then do;					/* ITT overflow */
		code = error_table_$itt_overflow;
		if pds$process_id ^= last_sender
		then do;				/* filter useless msgs */
			last_sender = pds$process_id;
			call syserr (0, "^a: ITT overflow caused by ^a", ME, pds$process_group_id);
		     end;
	     end;

WAKEUP_RETURNS:
	a_code = code;
	return;

/*	BLOCK = procedure to receive IPC Signals */

full_block:
     entry;

	val_ring = level$get ();			/* get validation level */
	on area call ect_error_handler (error_table_$ect_full, target_ring);

	itte_ptr = addr (tc_data$);
	do itt_relp = pds$itt_head repeat (itte_ptr -> itt_entry.next_itt_relp) while (itt_relp);
						/* go through all ITT messages */
	     itte_ptr = ptr (itte_ptr, itt_relp);
	     call dispatch_message (itte_ptr, target_ring);

	end;

	call pxss$free_itt (pds$itt_head);		/* free all messages */

	return;

assign_channel:
     entry (a_channel_name, a_code);

dcl	a_channel_name	fixed bin (71);		/* name of channel assigned */

	code = 0;

	fast_channel_id = index (pds$special_channels, "0"b);
						/* get index of new channel */
	if (fast_channel_id > tc_data$max_channels) | (fast_channel_id = 0)
	then do;					/* channels exhausted */
		code = error_table_$special_channels_full;
		a_channel_name = 0;
		go to FAST_CHANNEL_RETURNS;
	     end;
	substr (pds$special_channels, fast_channel_id, 1) = ON;
						/* channel is asigned */
	val_ring = level$get ();
	substr (pds$event_masks (val_ring), fast_channel_id, 1) = ON;
						/* channel assigned to ring */
	substr (pds$events_pending, fast_channel_id, 1) = OFF;
						/* turn off any pending wakeups */

/**** Retrieve the values of R-Offset and R-Factor from the APTE.  These
      values are needed to encode the event channel name. */

	call tc_util$get_ipc_operands (r_offset, r_factor);

/* fill in channel name */

	call ipc_validate_$encode_event_channel_name (r_offset, r_factor, NORMAL_CHANNEL_FLAGS, (fast_channel_id),
	     val_ring, FAST_CHANNEL_TYPE, fast_channel_id, event_channel_name_fb71);

	unspec (a_channel_name) = unspec (event_channel_name_fb71);
	go to FAST_CHANNEL_RETURNS;

delete_channel:
     entry (a_channel_name, a_code);

	unspec (event_channel_name_fb71) = unspec (a_channel_name);
	code = 0;
	val_ring = level$get ();

/**** Retrieve the values of R-Offset and R-Factor from the APTE.  These
      values are needed to decode the event channel name. */

	call tc_util$get_ipc_operands (r_offset, r_factor);

	call ipc_validate_$decode_event_channel_name (r_offset, r_factor, event_channel_name_fb71, ev_chn_flags,
	     ev_chn_index, channel_ring, ev_chn_type, fast_channel_id, code);
	if code ^= 0
	then goto FAST_CHANNEL_RETURNS;

	if fast_channel_id ^= ev_chn_index
	then do;
		code = error_table_$invalid_channel;
		goto FAST_CHANNEL_RETURNS;
	     end;

	if val_ring > channel_ring
	then do;					/* access violation */
		code = error_table_$wrong_channel_ring;
		go to FAST_CHANNEL_RETURNS;
	     end;

	if ev_chn_type ^= FAST_CHANNEL_TYPE
	then do;
		code = error_table_$invalid_channel;
		goto FAST_CHANNEL_RETURNS;
	     end;

	if fast_channel_id > tc_data$max_channels | fast_channel_id <= 0
	then do;
		code = error_table_$invalid_channel;
		go to FAST_CHANNEL_RETURNS;
	     end;

	if (substr (pds$event_masks (channel_ring), fast_channel_id, 1) = OFF)
	then do;
		code = error_table_$invalid_channel;
		go to FAST_CHANNEL_RETURNS;
	     end;

/* deallocate channel in ring */
	substr (pds$event_masks (channel_ring), fast_channel_id, 1) = OFF;
	substr (pds$special_channels, fast_channel_id, 1) = OFF;
						/* deallocate channel */
FAST_CHANNEL_RETURNS:
	a_code = code;
	return;

dispatch_message:
     proc (a_itte_ptr, a_target_ring);

dcl	a_itte_ptr	ptr parameter;
dcl	a_target_ring	fixed bin (3) parameter;

/* following is the unthreading of the event queue and the dispatching
   of the event messages into their corresponding rings */

	a_target_ring = 0;

/* process is being destroyed */
	if unspec (a_itte_ptr -> itt_entry.channel_id) = unspec (QUITSTOP)
	then return;

/* pick up ring from channel name and check its validity */
	a_target_ring = addr (a_itte_ptr -> itt_entry.channel_id) -> event_channel_name.ring;
	if a_target_ring = 0
	then return;
	sb = pds$stacks (a_target_ring);
	if sb = null				/* sender could have put bad ring in name */
	then return;

/* pick up pointer to ect and ect area and check that all goes well */
	ect_ptr = sb -> stack_header.ect_ptr;

/* ect_ptr is null in rings that don't have an ECT (like inner rings that
haven't called ipc_$create_ev_chn). DONT KILL PROCESS BECAUSE OF THIS, just
ignore the event. Note that anyone can send an event message to an event
channel that specifies any old ring... The old code here used to terminate
the process on this condition thus allowing malicious users to trash 
any process */

	if ect_ptr = null
	then return;

	if ect_header.ect_areap = null
	then call ect_error_handler (error_table_$inconsistent_ect, a_target_ring);

	allocate itt_message in (ect_area) set (msg_ptr);
	ect_header.count (ITT_MESSAGE) = ect_header.count (ITT_MESSAGE) + 1;
	ect_header.count (TOTAL) = ect_header.count (TOTAL) + 1;
	unspec (msg_ptr -> itt_message) = "0"b;
	msg_ptr -> itt_message.type = ITT_MESSAGE;
	call thread_itt_message (ect_ptr, msg_ptr);

	msg_ptr -> itt_message.message_data = a_itte_ptr -> itt_entry, by name;

	substr (pds$ring_events, a_target_ring, 1) = ON;	/* record that messages copied into this ring's ect */
						/* may not be validation ring */

     end dispatch_message;

thread_itt_message:
     proc (a_ect_ptr, a_msgp);

dcl	a_ect_ptr		ptr parameter;
dcl	a_msgp		ptr parameter;

dcl	prev_ittp		ptr;

	prev_ittp = a_ect_ptr -> ect_header.lastp (ITT_MESSAGE);
	if prev_ittp = null
	then a_ect_ptr -> ect_header.firstp (ITT_MESSAGE) = a_msgp;
	else prev_ittp -> itt_message.next_itt_msgp = a_msgp;
	a_ect_ptr -> ect_header.lastp (ITT_MESSAGE) = a_msgp;
	a_msgp -> itt_message.next_itt_msgp = null;

     end thread_itt_message;

ect_error_handler:
     proc (a_code, a_ring);

dcl	a_code		fixed bin (35) parameter;
dcl	a_ring		fixed bin (3) parameter;

	call syserr (4, "^a: Unable to allocate in ring ^d ECT for ^a", ME, a_ring, pds$process_group_id);
	call terminate_proc (a_code);

     end ect_error_handler;

/* format: off */
%page; %include access_audit_eventflags;
%page; %include ect_structures;
%page; %include event_channel_name;
%page; %include itt_entry;
%page; %include stack_header;
%page; %include syserr_constants;
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   hc_ipc: ITT overflow caused by NAME.PROJ

   S:	$info

   T:	$run

   M:	When wakeups are sent from one process to another, or from a device
   like a tape drive to a process, the wakeups are stored temporarily in the 
   Interprocess Transmission Table (ITT). If wakeups are sent too fast,
   or if the receiving process never calls block to read its wakeups,
   the ITT may overflow. When the ITT is full, this message is printed
   for each lost wakeup. The message identifies the sender of the wakeup,
   who may be innocent of any error or wrongdoing.

   If a critical system function cannot send a wakeup, the system may crash.

   A:	If the ITT overflow is a transient condition, this message will stop
   coming out after a few minutes. If so, system operation may return to normal.
   If the message comes out repeatedly, the system will have to be crashed,
   since user terminal operation, daemon operations, and the message
   coordinator depend on wakeups.
   $recover


   Message:
   hc_ipc: Unable to allocate in ring RINGNO ECT for  NAME.PROJ

   S:     $log

   T:     $run

   M:     When a process recieves wakeups, they are copied from the
   Interprocess Transmission Table to an Event Channel Table (ECT).
   A process owns one ECT per ring.  If, for any reason, an entry
   for a wakeup cannot be allocated in a process' ECT, that
   process is terminated.

   A:     If the process is a daemon process, it must be reinitialized.
   If the process is the initializer process, the system will crash.

   END MESSAGE DOCUMENTATION */
/* format: on */

     end hc_ipc;




		    mcs_timer_daemon.pl1            11/11/89  1109.0rew 11/11/89  0826.9       11736



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
mcs_timer_daemon:
     procedure;

dcl  mcs_timer$poll entry returns (fixed bin (71));
dcl  pxss$block entry;
dcl  set_alarm_timer entry (fixed bin (71), fixed bin, fixed bin (71));
dcl  syserr entry options (variable);

dcl  next_time fixed bin (71);

dcl  any_other condition;

dcl  addr builtin;

/* * * * * * * * * * MCS_TIMER_DAEMON * * * * * * * * * * */

reinit:
	ttybp = addr (tty_buf$);
	on any_other
	     begin;
		call syserr (CRASH, "mcs_timer_daemon: Unexpected fault.");
		goto reinit;
	     end;

	do while ("1"b);
	     next_time = mcs_timer$poll ();
	     if next_time > 0 then call set_alarm_timer (next_time, 2, tty_buf.timer_ev_chn);
	     call pxss$block ();
	end;
%page;
%include tty_buf;
%include syserr_constants;

     end mcs_timer_daemon;




		    truncate_stacks.pl1             11/11/89  1109.0r w 11/11/89  0826.9       28845



/****^  ***********************************************************
        *                                                         *
        * 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 */

/* Truncate stacks past their end_ptr ; called from fast_hc_ipc */
/* BIM 1/82 */
/* Modified March 1982 by J. Bongiovanni, not to truncate stack_0 */
/* Modified May 1982 by J. Bongiovanni to check stack SDW before touching stack */
/* Modified November 1982 BIM to check the PTW for the stack header as well. */

truncate_stacks:
     procedure;


/* ASSUME --- no active stack history inside val level */


	declare pds$stacks		 (0:7) pointer ext;
	declare pc$truncate_count	 entry (pointer, fixed bin (18), fixed bin (18));
	declare lock$lock_ast	 entry;
	declare lock$unlock_ast	 entry;
	declare get_ptrs_$given_segno	 entry (fixed bin (18)) returns (pointer);
	declare ptw_util_$get_add_type entry (ptr, bit (4) unaligned);
	declare sdw_util_$dissect	 entry (ptr, ptr);

	declare pageno		 fixed bin (18);
	declare n_in_core		 fixed bin (18);
	declare stkx		 fixed bin;

	declare 1 stack_sdw_info	 aligned like sdw_info;

	declare dseg$		 (0:1023) fixed bin (71) aligned ext;
	declare sst$stk_pages_truncated
				 fixed bin (35) ext;
	declare sst$stk_pages_truncated_in_core
				 fixed bin (35) ext;

	declare (addr, baseno, bin, divide, null, rel, size)
				 builtin;


	call lock$lock_ast;

	do stkx = 1 to 7;
	     if pds$stacks (stkx) ^= null
	     then call DO (pds$stacks (stkx), "0"b);
	end;

	call lock$unlock_ast;
	return;

DO:
     procedure (segp, stack_0);

	declare segp		 pointer;
	declare stack_0		 bit (1) aligned;
	declare at		 bit (4);
	declare ptp		 pointer;

	call sdw_util_$dissect (addr (dseg$ (bin (baseno (segp)))), addr (stack_sdw_info));
	if stack_sdw_info.flags.faulted | ^stack_sdw_info.access.read
	then goto RETURN;
	astep = get_ptrs_$given_segno (bin (baseno (segp), 18));

	if astep = null
	then go to RETURN;

	ptp = addrel (astep, size (aste));
	call ptw_util_$get_add_type (ptp, at);
	if at ^= add_type.core
	then go to RETURN;

	if stack_sdw_info.size <= bin (rel (addr (segp -> stack_header.stack_end_ptr))) + 2
	then goto RETURN;

	pageno = divide (bin (rel (segp -> stack_header.stack_end_ptr)) + 1023, 1024, 19, 0);
	if stack_0
	then pageno = pageno + 1;

	sst$stk_pages_truncated = sst$stk_pages_truncated + bin (aste.csl, 9) - pageno + 1;
						/* pageno is 1-origin */

	call pc$truncate_count (astep, pageno, n_in_core);

	sst$stk_pages_truncated_in_core = sst$stk_pages_truncated_in_core + n_in_core;

RETURN:
     end DO;

%include add_type;
%include aste;
%include dir_entry;
%include sdw_info;
%include stack_header;

     end truncate_stacks;




		    try_to_unlock_lock.pl1          11/11/89  1109.0r w 11/11/89  0826.9       36666



/****^  ***********************************************************
        *                                                         *
        * 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. *
   *                                                    *
   *                                                    *
   ****************************************************** */

/* The following entry is called in order to allow non-hardcore procedures
   to unlock a lock if it was originally locked by a process that no longer
   exists. If  the process associated with the lock id in the lock no longer
   exists the lock is set to the lock id of the calling process.

   Originally coded by R. J. Feiertag on March 9, 1971
   Modified by P. M. Haber on June 15,1971
   Modified by R. J. Feiertag on November 3, 1971 to set a bad lock to caller lock id
   Modified by S.Webber June, 1973 to change locking strategy to use stacq function */

try_to_unlock_lock: proc (a_lock_ptr, a_code);

dcl  a_lock_ptr ptr,				/* pointer to lock that is to be unlocked */
     a_code fixed bin,				/* returned status code */
     lock_ptr ptr,					/* internal copy of lock pointer */
     entrysw fixed bin,				/* indicates which entry has been invoked */
     lock bit (36) aligned based (lock_ptr),		/* lock to be unlocked */
     test_lock bit (36) aligned,			/* copy to make sure lock id is not changed while search is on */
     i fixed bin;					/* misc. index */

dcl (addr, addrel) builtin;

dcl  tc_data$apt_entry_size ext fixed bin,		/* length of an APT entry */
     tc_data$apt_size ext fixed bin,			/* number of entries in APT */
     tc_data$apt ext,				/* the APT */
     pds$process_id ext bit (36) aligned,		/* this process's id */
     pds$apt_ptr ptr ext;				/* points to process's APT entry */

dcl  stacq entry (ptr, bit (36) aligned, bit (36) aligned) returns (bit (1) aligned);

%include apte;
/*  */
	lock_ptr = a_lock_ptr;			/* copy pointer to lock into ring 0 */
	entrysw = 0;				/* this is unlocking entry */
	goto check;				/* join common code */

/* The following entry is called in order to verify that a lock is locked by an existing
   process. No attempt is made to unlock the lock. The status codes returned are:

   1 - the lock was validly locked
   2 - the lock was not locked
   3 - the lock was not validly locked
   */

check_lock: entry (a_lock_ptr, a_code);

	lock_ptr = a_lock_ptr;			/* copy the lock pointer into ring 0 */
	entrysw = 1;				/* this is check only entry */

check:						/* common code */
	test_lock = lock;				/* make copy of lock id */
	if test_lock = ""b then do;			/* lock is not  locked */
	     a_code = 2;				/* return proper status code */
	     return;				/* we are done */
	end;
	aptep = addr (tc_data$apt);			/* get pointer to first APT entry */
	do i = 1 to tc_data$apt_size;			/* look at all APT entries */
	     if (aptep -> apte.lock_id = test_lock) &     /* we have found entry for this process, lock is valid */
	        (bin(aptep ->apte.flags.state,18) ^= 5)
	     then do;
		a_code = 1;			/* return proper code */
		return;				/* we are done */
	     end;
	     aptep = addrel (aptep, tc_data$apt_entry_size); /* goto next APT entry */
	end;
	if ^stacq (lock_ptr, test_lock, pds$apt_ptr -> apte.lock_id) then do;
	     a_code = 1;				/* if not the same as test_lock then lock is valid */
	     return;
	end;
	a_code = 3;				/* lock didn't change and is still bad ... the stacq set it to caller */
	return;

     end try_to_unlock_lock;




		    tty_index.pl1                   11/11/89  1109.0r w 11/11/89  0826.9      769464



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1983 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-02-01,RCoren), approve(), audit(), install():
     Modified to initialize the tty_access_class structure at the tty_attach
        entry.
     Modified December 1984 by Robert Coren to implement
        "(set get)_line_status_enabled" orders.
     Modified 84-12-04 by EJ Sharpe to remove protection_audit_ calls
     Modified November 1984 by Robert Coren to use tty_area_manager entries
        for allocating and freeing TCBs.
     Modified September 1984 by Robert Coren to turn off wtcb.dialing if
        dialout fails, and to zero pad fields in output_flow_control_info
        structure for set_terminal_data order.
     Modified February 1984 by Robert Coren to correct bug in access_class
        checking.
     Modified May 1983 by Robert Coren and E. N. Kittlitz for
        required_access_class.
     Modified November 1982 by Robert Coren to report wtcb.error_code.
     Modified November 1982 by Robert Coren to reset masked bit on "unmask"
        order.
     Modified June 1982 by Robert Coren to report MASKED state and to reset
        it on listen order.
     Modified June 1981 by Benson I. Margulies for error on duplicate
        attachments.
     Modified April 1981 by Robert Coren to handle dialup time
     Modified 81 January by Art Beattie to pass along 32 character phone
        numbers.
     Modified 4 December 1980 by Robert Coren to add copy_meters order
     Modified 3/6/80 by C. Hornig to pass 9-bit phone numbers
     Modified 4/10/79 by J. Stern to remove modes handling
     Modified 3/1/79 by J. Stern to add set_wakeup_table order
     Modified 10/11/78 by J. Stern for multiplexing changes
     Modified Aug 78 by J. Nicholls to implement ring 0 demuxing, some major
        changes involved
     Modified 5/17/78 by J. Stern to implement breakall mode
     Modified 4/18/78 by Robert Coren to implement blk_xfer mode and
        (set get)_framing chars orders and to fix bug that always rned off
        fulldpx with echoplex despite explicit user request
     Modified 2/6/78 by Robert Core
  2) change(86-04-23,Coren), approve(86-04-23,MCR7300),
     audit(86-05-19,Beattie), install(86-07-08,MR12.0-1089):
     To use version 2 mcs_echo_neg structure.
  3) change(86-06-19,Kissel), approve(86-07-30,MCR7475), audit(86-08-04,Coren),
     install(86-10-09,MR12.0-1181):
     Changed to support the new tty event message format declared in
     net_event_message.incl.pl1 which replaces tty_event_message.incl.pl1.
  4) change(86-09-26,Beattie), approve(86-09-22,MCR7542),
     audit(86-10-20,Brunelle), install(86-10-21,MR12.0-1190):
     Remove references to the 963 and 029 preaccess commands and remove support
     for ARDS, 202_ETX, 2741 and 1050 in system interfaces.
  5) change(87-03-10,LJAdams), approve(87-04-03,MCR7646),
     audit(87-05-06,Gilcrease), install(87-05-14,MR12.1-1029):
     Added support for ttd_version_3 which includes the protocol field.
  6) change(87-06-17,LJAdams), approve(87-06-17,MCR7584),
     audit(87-08-06,Gilcrease), install(87-08-06,MR12.1-1063):
     Changed editing_chars_version_2 to editing_chars_version_3.
  7) change(88-08-15,Parisek), approve(88-08-15,PBF7928),
     audit(88-08-15,Farley), install(88-08-16,MR12.2-1086):
     Make call to tty_write$locked for the "read_status" control order if tty
     is attached through the DSA UNCP multiplexer.  This will subsequently set
     the wtcb.turn flag ON so the tty will not remain in a blocked for output
     state.
  8) change(88-08-19,Parisek), approve(88-08-19,PBF7928),
     audit(88-08-19,Farley), install(88-08-22,MR12.2-1087):
     Correct bug in the is_parent_mpx procedure to return "0"b if parent
     multiplexer type does not match multiplexer type being checked.
  9) change(88-09-21,Brunelle), approve(88-09-21,MCR7813),
     audit(88-10-12,Blair), install(88-10-17,MR12.2-1171):
     Add code to support SPECIAL_VERSION_2 special tables in addition to
     SPECIAL_VERSION.  These are 15 & 3 char tables respectively.  Change
     set/get_special control orders to handle the old and new lengths properly.
 10) change(88-10-20,Brunelle), approve(88-10-20,PBF7813),
     audit(88-10-21,Farley), install(88-10-22,MR12.2-1181):
     Correct problem of returning invalid ptr to  structure (it was already
     freed).  Also improve copying of old/new versions of special chars tables.
                                                   END HISTORY COMMENTS */

%page;
/* format: style4,delnl,insnl,^ifthendo */
tty_index:
     proc (a_name, twx, state, ercode);			/* go get index from name, and sign onto tty */


dcl  a_name char (*);				/* tty name such as a.h102 */
dcl  a_wtcbp ptr;
dcl  a_tcbp ptr;
dcl  a_sw bit (1);
dcl  a_order char (*);				/* order name */
dcl  a_argptr ptr;					/* pointer to order data */
dcl  a_data_base_ptr ptr;				/* pointer returned of establishing wtcb */
dcl  a_event fixed bin (71);				/* event channel name */

dcl  twx fixed bin;					/* tty index (actually also device index ) */
dcl  state fixed bin;				/* tty state, 1 ignored, 2 listening, 5 dialed */
dcl  ercode fixed bin (35);				/* error code */
dcl  dflag fixed bin;				/* disposition flag */
dcl  nproc bit (36);				/* new proc process */
dcl  resetsw fixed;					/* abort code, 1 reset read, 2 reset write, 3 reset both */
dcl  name char (32);
dcl  event fixed bin (71);
dcl  order char (32);
dcl  argptr ptr;
dcl  special_ptr ptr;
dcl  esw fixed bin;
dcl  cleanup condition;
dcl  (i, j) fixed bin;
dcl  devx fixed bin (17);
dcl  (sw, rawom) bit (1) aligned;
dcl  rw_switch bit (2) aligned;			/* bit-string version of reset_read/write switch */
dcl  code fixed bin (35);
dcl  temp_ptr ptr;
dcl  table_type fixed bin;
dcl  locked bit (1) init ("0"b);
dcl  sus_count fixed bin;				/* automatic copy of output_suspend count */
dcl  res_count fixed bin;				/* likewise for resume */
dcl  uproc_attach_required_for_setup bit (1) init ("1"b);
dcl  uproc_required_for_setup bit (1) init ("1"b);
dcl  phone_data varying char (32);
dcl  aim_attributes_string char (32);
dcl  user_auth_string char (32);
dcl  echo_version_1 bit (1);
dcl  old_special_table_version bit (1);

	/*** REMOVE when Emacs, video and mowse are using version 2. ***/

dcl  1 new_waketab aligned like wakeup_table;
dcl  1 old_waketab aligned like wakeup_table;
dcl  1 sfc aligned like framing_chars;
dcl  1 auto_ifc aligned like input_flow_control_info;
dcl  1 auto_ofc aligned like output_flow_control_info;
dcl  1 l_tty_access_class aligned like tty_access_class;
dcl  1 auto_mode aligned,
       2 len fixed bin,
       2 str char (8);

dcl  ever_initialized bit (1) int static init ("0"b);	/* indicates whether init_channel ever called before */

dcl  (
     input_tr_type init (1),				/* input translation table type */
     output_tr_type init (2),				/* output translation table type */
     input_cv_type init (3),				/* input conversion table type */
     output_cv_type init (4),				/* output conversion table type */
     special_type init (5),				/* special chars table type */
     delay_type init (6)
     ) fixed bin int static options (constant);		/* delay table type */

dcl  max_special_size fixed bin int static options (constant) init (600);
						/* max special words table size in words */


dcl  IGNORE fixed bin int static options (constant) init (1);
dcl  LISTENING fixed bin int static options (constant) init (2);
dcl  DIALED_UP fixed bin int static options (constant) init (5);
dcl  MASKED_STATE fixed bin int static options (constant) init (-1);
dcl  NUL char (1) int static options (constant) init (""); /* NUL character (\000) */

dcl  white_space char (6) int static options (constant) initial
						/* BS, CR, NL, HT, VT, FF */
	("
	");

dcl  (
     error_table_$resource_attached,
     error_table_$io_no_permission,
     error_table_$unimplemented_version,
     error_table_$device_not_usable,
     error_table_$no_connection,
     error_table_$no_operation,
     error_table_$null_info_ptr,
     error_table_$invalid_state,
     error_table_$invalid_device,
     error_table_$smallarg,
     error_table_$action_not_performed,
     error_table_$buffer_big,
     error_table_$bigarg,
     error_table_$request_pending,
     error_table_$no_wired_structure,
     error_table_$inconsistent,
     error_table_$no_table,
     error_table_$notalloc,
     error_table_$no_line_status,
     error_table_$improper_data_format,
     error_table_$line_status_pending,
     error_table_$masked_channel,
     error_table_$invalid_delay_value,
     error_table_$undefined_order_request,
     error_table_$invalid_array_size
     ) ext fixed bin (35);
dcl  pds$processid ext static bit (36);
dcl  pds$process_group_id ext static char (32) aligned;
dcl  tc_data$initializer_id ext bit (36) aligned;

dcl  1 pds$access_authorization aligned like aim_template ext static;

dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  compare_tty_name_ entry (char (*), char (*)) returns (bit (1));
dcl  display_access_class_ entry (bit (72) aligned, char (32));
dcl  pxss$ring_0_wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin);
dcl  syserr entry options (variable);
dcl  tty_area_manager$allocate entry (fixed bin, ptr);
dcl  tty_area_manager$free entry (fixed bin, ptr);
dcl  tty_interrupt$set_static entry;
dcl  tty_lock$lock_channel entry (fixed bin, fixed bin (35));
dcl  tty_lock$unlock_channel entry (fixed bin);
dcl  tty_tables_mgr$add entry (ptr, fixed bin, fixed bin, bit (18), fixed bin (35));
dcl  tty_tables_mgr$delete entry (bit (18), fixed bin (35));
dcl  tty_modes entry (ptr, ptr, fixed bin (35));
dcl  tty_modes$mpx_only entry (ptr, ptr, fixed bin (35));
dcl  tty_write$locked entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35));

dcl  ll fixed bin (9) based (argptr);			/* for line length order */

dcl  new_line_type fixed bin based (argptr);		/* for set_line_type order */

dcl  1 info based (argptr) aligned,			/* tty information structure */
       2 id char (4) unaligned,			/* id of tty */
       2 baud_rate fixed bin (17) unal,			/* baud rate */
       2 line_type fixed bin (17) unal,			/* line type for line control */
       2 pad bit (36) unal,				/* fill */
       2 tw_type fixed;				/* type of tty (t300) */

dcl  arg_varying_char32 varying char (32) based (argptr);

dcl  1 rd_stat aligned based (argptr),			/* structure fo read_status call */
       2 ev_chan fixed bin (71),
       2 input_available bit (1);

dcl  1 wr_stat aligned based (argptr),			/* structure for write_status call */
       2 ev_chan fixed bin (71),
       2 output_pending bit (1);

dcl  bit72 bit (72) based;				/* for command data */
dcl  bit1 bit (1) based;

dcl  inid char (4) based;
dcl  based_arg fixed bin based;

dcl  1 editing_chars aligned based (argptr),
       2 version fixed bin,
       2 chars char (2) unaligned;

dcl  1 framing_chars aligned based (argptr),
       2 frame_begin char (1) unal,
       2 frame_end char (1) unal;

dcl  1 get_special_info aligned based (argptr),
       2 version char (8),
       2 area_ptr ptr,
       2 table_ptr ptr;

dcl  1 get_special_info_old aligned based (argptr),
       2 area_ptr ptr,
       2 table_ptr ptr;

dcl  two_chars char (2) based;
dcl  special_area area based;

dcl  tablerp (6) bit (18) unal based (trpp);		/* overlay for tcb.tables */
dcl  df_tablerp (6) bit (18) unal based (dftrpp);		/* overlay for tcb.default_tables */
dcl  new_tablerp (6) bit (18) unal;
dcl  new_tablep (6) ptr based (ntpp);			/* overlay for terminal_type_data.tables */
dcl  (trpp, dftrpp, ntpp) ptr;

dcl  (area, storage) condition;

dcl  (addr, abs, bit, clock, divide, fixed, length, low, max, min, null, ptr, rel, search, size, string, substr, unspec)
	builtin;
%page;

/* special chars structures to support old/new versions */
dcl  special_chars_old_ptr ptr;
dcl  1 special_chars_old aligned based (special_chars_old_ptr),
						/* 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;

	esw = 0;					/* this is index entry */
	ttybp = addr (tty_buf$);			/* get ptrs to tty_buf, tty_data */
	lctp = tty_buf.lct_ptr;			/* get system pointer to lct */
	name = a_name;
	twx, state = 0;				/* init to no information passing state */
	call get_devx (name);
	if ercode ^= 0
	then return;
	tty_access_class_ptr = addr (l_tty_access_class);
	unspec (tty_access_class) = ""b;
	go to attach;

tty_attach:
     entry (a_name, a_event, twx, state, ercode);		/* index + event */
	event = a_event;
	esw = 1;					/* attach entry */
	ttybp = addr (tty_buf$);			/* get ptrs to tty_buf, tty_data */
	lctp = tty_buf.lct_ptr;			/* get system pointer to lct */
	name = a_name;
	twx, state = 0;				/* init to no information passing state */
	call get_devx (name);
	if ercode ^= 0
	then return;
	tty_access_class_ptr = addr (l_tty_access_class);
	unspec (tty_access_class) = ""b;		/* in case the order doesn't do anything */
	call tty_order (devx, "get_required_access_class", tty_access_class_ptr, (0), ercode);
	if ercode ^= 0 & ercode ^= error_table_$undefined_order_request
	then return;

attach:
	on cleanup call cleaner;
	call tty_lock$lock_channel (devx, ercode);	/* lock the channel */
	if ercode ^= 0
	then return;
	locked = "1"b;

	lctep = addr (lct.lcte_array (devx));		/* get entry of interest */
	if lcte.channel_type ^= 0			/* has to be tty channel */
	then go to index_invalid;

	wtcbp = lcte.data_base_ptr;			/* pointer to perm per channel data */
	tcbp = wtcb.tcb_ptr;			/* get tcb pointer */
	if ^wtcb.tcb_initialized
	then call init_tcb;

	if wtcb.hproc = "0"b
	then do;					/* if up for grabs, let him have it */
	     if pds$processid ^= tc_data$initializer_id
	     then go to index_invalid;
	     wtcb.hproc = pds$processid;
	end;
	else if wtcb.hproc = pds$processid		/* if he is already boss */
	then ;					/* then he is ok */
	else if wtcb.flags.dialed			/* else if channel is dialed (has user) */
	then if wtcb.uproc = pds$processid		/* and this guy is the user */
	     then if (esw = 1) & tcb.uproc_attached	/* ATTACH & already called ATTACH */
						/* only allow one call to tty_attach */
		then do;
		     ercode = error_table_$resource_attached;
		     call tty_lock$unlock_channel (devx);
		     return;
		end;
		else do;				/* tty_index can be called as many times on a channel name as desired */
		     if ^tcb.uproc_attached
		     then do;			/* this is first attach */
			if tty_access_class.access_class_set
			then if ^aim_check_$equal (unspec (pds$access_authorization), tty_access_class.access_class)
			     then do;
				if ^pds$access_authorization.privileges.comm
				then do;		/* this shouldn't happen unless the process responsible
						   for channel assignments has failed or the user
						   process has reset comm privilege since the assignment */
				     call display_access_class_ (unspec (pds$access_authorization),
					user_auth_string);
				     call display_access_class_ (tty_access_class.access_class,
					aim_attributes_string);
				     call syserr (ANNOUNCE,
					"tty_attach: ^a (^a) attempted invalid attachment of ^a (^a)",
					pds$process_group_id, user_auth_string, name, aim_attributes_string);
				     go to index_invalid;
				end;		/* no AIM privilege */
			     end;			/* channel auth differs from process auth */
		     end;				/* first attach */
		end;				/* tty_index or first attach */
	     else go to index_invalid;		/* else he is not user, and cant do anything */
	else do;					/* else channel not dialed up, and not boss */
index_invalid:
	     ercode = error_table_$io_no_permission;	/* give him error code */
	     call tty_lock$unlock_channel (devx);	/* unlock channel now */
	     return;				/* thats all we let him do */
	end;
	if wtcb.flags.dialed			/* compute state */
	then state = DIALED_UP;			/* dialed up */
	else if wtcb.flags.masked			/* masked by FNP */
	then state = MASKED_STATE;
	else if wtcb.flags.listen
	then state = LISTENING;			/* listening for ring */
	else state = IGNORE;			/* ignoreing */

	ercode = 0;
	twx = devx;				/* return tty index */

	if wtcb.flags.dialed
	then do;					/* if dialed */
	     wtcb.uproc = pds$processid;		/* he is using process */
	     tcb.uproc_attached = "1"b;
	end;

	wtcb.qflag, wtcb.qenable = "0"b;		/* but he may not expect quits */
	wtcb.dialing, wtcb.dial_status_valid = ""b;	/* not dialing, no dial status */
	wtcb.dial_status_code = 0;
	if esw = 1
	then go to eret;				/* must also record event */
	call tty_lock$unlock_channel (devx);		/* unlock the channel */

	return;
%page;
tty_event:
     entry (twx, a_event, state, ercode);		/* to change tty events signaled */

	event = a_event;
	state = 0;

	on cleanup call cleaner;
	call setup (state);				/* set up normal variables and check access */
	if ercode ^= 0
	then return;

	if wtcb.flags.dialed
	then wtcb.uproc = pds$processid;		/* this guy gets to use it */

eret:
	wtcb.event = event;				/* copy as user event channel */
	if wtcb.hproc = pds$processid
	then					/* and if this guy is the boss */
	     wtcb.hevent = event;			/* copy as boss event too */

	call tty_lock$unlock_channel (devx);		/* unlock the channel */

	return;
%page;
tty_get_name:
     entry (twx, a_name, state, ercode);		/* to return channel name given devx */

	devx = twx;
	uproc_required_for_setup = "0"b;
	call setup (state);
	if ercode ^= 0
	then return;

	lcntp = lct.lcnt_ptr;
	a_name = lcnt.names (devx);
	call tty_lock$unlock_channel (devx);
	return;
%page;
init_channel:
     entry (twx, a_argptr, a_data_base_ptr, ercode);

	devx = twx;				/* move to internal */
	argptr = a_argptr;
	a_data_base_ptr = null;
	ercode = 0;

	if ^ever_initialized
	then do;
	     call tty_interrupt$set_static;		/* to copy error codes into wired internal static */
	     ever_initialized = "1"b;			/* so we don't do this again */
	end;

	call tty_space_man$get_space (size (wtcb), wtcbp);

	if wtcbp = null
	then do;					/* no room for it? */
	     ercode = error_table_$notalloc;
	     return;
	end;

	on area go to tcb_not_done;
	on storage go to tcb_not_done;
	call tty_area_manager$allocate (size (tcb), tcbp);
	revert area;
	revert storage;

	unspec (wtcb) = "0"b;			/* start in known state */
	wtcb.tcb_ptr = tcbp;			/* set the data base correctly */
	wtcb.devx = devx;
	unspec (tcb) = "0"b;			/* start this in known state also */
	call init_tcb;				/* start filling in the variables */
	a_data_base_ptr = wtcbp;			/* and the output arg */
	return;

tcb_not_done:
	ercode = error_table_$notalloc;		/* we had a problem */
	return;
%page;
terminate_channel:
     entry (a_data_base_ptr, ercode);

	ercode = 0;
	wtcbp = a_data_base_ptr;			/* get to internal */
	tcbp = wtcb.tcb_ptr;

	call init_tcb_tables;
	call tty_area_manager$free (size (tcb), tcbp);	/* clean out the tcb */

	call tty_space_man$free_space (size (wtcb), wtcbp);
						/* and get rid of wtcb */
	if wtcbp ^= null
	then do;					/* wtcb still around for some reason? */
	     ercode = error_table_$action_not_performed;
	     return;
	end;

	return;
%page;
tty_abort:
     entry (twx, resetsw, state, ercode);		/* to reset read or write buffers */

	state = 0;

	on cleanup call cleaner;
	call setup (state);				/* do setup */
	if ercode ^= 0
	then return;
	if wtcb.flags.dialed			/* if any buffers to reset */
	then do;
	     rw_switch = bit (fixed (resetsw, 2));	/* first bit is resetwrite, 2nd is -read */
	     if substr (rw_switch, 1, 1)		/* asking for resetwrite */
	     then do;
		if wtcb.write_first ^= 0
		then do;
		     call tty_space_man$free_chain (devx, OUTPUT, ptr (ttybp, wtcb.write_first));
		     wtcb.write_first, wtcb.write_last = 0;
		end;
		if wtcb.end_frame			/* if at end of page, reset */
		then do;
		     wtcb.actline = 0;
		     wtcb.end_frame = "0"b;
		end;

	     end;
	     if substr (rw_switch, 2, 1)		/* if read buffer to be reset */
	     then do;
		if wtcb.fblock ^= 0			/* if a chain there */
		then do;
		     call tty_space_man$free_chain (devx, INPUT, ptr (ttybp, wtcb.fblock));
		     wtcb.nramsgs = 0;
		     wtcb.fblock, wtcb.lblock = 0;	/* no more input chain */
		end;				/* tell the 355 not to send current input */
		wtcb.fchar = 0;
	     end;

	     call channel_manager$control (devx, "abort", addr (rw_switch), code);
	     if code ^= 0
	     then if code = error_table_$undefined_order_request
		then code = 0;
	     ercode = code;				/* and stop any current writes */
	end;

	call tty_lock$unlock_channel (devx);		/* unlock the channel */

	return;
%page;
tty_state:
     entry (twx, state, ercode);			/* go get state of tty */

	state = 0;

	on cleanup call cleaner;
	call setup (state);				/* get normal variables */
	call tty_lock$unlock_channel (devx);		/* unlock the channel */

	return;
%page;
tty_detach:
     entry (twx, dflag, state, ercode);			/* to detach tty */

dcl  pflag bit (1);					/* which entry switch */

	pflag = "0"b;				/* not new proc call */
	go to detcom;

new_proc:
     entry (twx, nproc, state, ercode);			/* to switch tty to new process */

	pflag = "1"b;

detcom:
	state = 0;
	on cleanup call cleaner;
	call setup (state);				/* set up */
	if ercode ^= 0
	then return;

	if pflag					/* if new process call */
	then do;
	     if wtcb.hproc = pds$processid		/* if initializer wants */
	     then do;
		wtcb.event = 0;			/* so as not to send wakeup on bogus event channel */
		wtcb.uproc = nproc;
		tcb.uproc_attached = "0"b;
	     end;
	     else go to illdet;			/* everybody to stay in assigned seat */
	end;
	else if dflag = 0				/* check disposition */
	then do;
	     if wtcb.flags.dialed			/* if a control block */
	     then do;
		if wtcb.hproc = pds$processid		/* .. and if this is the boss */
		then wtcb.uproc = "0"b;		/* place tty up for grabs */
		tcb.uproc_attached = "0"b;		/* always mark as detached */
	     end;
	end;
	else if wtcb.hproc = pds$processid		/* if boss process */
	then do;
	     wtcb.flags.listen = "0"b;		/* shut off channel */
	     call channel_manager$control (devx, "hangup", null, ercode);
	     wtcb.hproc = "0"b;			/* advertise tty looking for new boss */
	     state = IGNORE;
	end;
	else go to illdet;				/* some evil disposition and not boss */

	if wtcb.flags.dialed
	then wtcb.flags.wflag, wtcb.flags.rflag = "0"b;	/* force wakeups */

	call tty_lock$unlock_channel (devx);		/* unlock the channel */

	return;
%page;

tty_order:
     entry (twx, a_order, a_argptr, state, ercode);	/* to give tty orders */


	order = a_order;
	argptr = a_argptr;

	ttytp = addr (tty_tables$);

	on cleanup call cleaner;
	if order = "get_meters"			/* let anyone do this */
	then uproc_required_for_setup = "0"b;		/* it's initialized to "1"b */
	else if order = "get_required_access_class"
	then					/* let user do this before attach */
	     uproc_attach_required_for_setup = "0"b;

	call setup (state);				/* set up */
	if ercode ^= 0
	then return;

	if wtcb.masked				/* can't do most things to a masked channel */
	then if order ^= "unmask" & order ^= "get_meters" & order ^= "copy_meters"
	     then do;
		ercode = error_table_$masked_channel;
		go to unlock;
	     end;

	if order = "modes"
	then call tty_modes (wtcbp, argptr, ercode);

	else if order = "listen"			/* listen for dialup */
	then do;
	     call forward_order ();
	     wtcb.flags.listen = "1"b;
	     if wtcb.flags.dialed			/* get state */
	     then state = DIALED_UP;
	     else state = LISTENING;
	end;

	else if order = "copy_meters"
	then do;
	     if wtcb.hproc ^= pds$processid
	     then do;				/* only owner can do this */
		ercode = error_table_$io_no_permission;
		go to unlock;
	     end;

	     tcb.saved_meters = tcb.cumulative_meters;
	     tcb.time_dialed = clock ();
	     call forward_order ();
	end;

	else if order = "line_length"			/* set line length */
	then do;
	     if ^wtcb.flags.dialed			/* if data base exists */
	     then go to error;
	     tcb.colmax = ll;
	end;

	else if order = "terminal_info"
	then do;
	     terminal_info_ptr = argptr;
	     if terminal_info.version ^= terminal_info_version
	     then go to wrong_version;
	     if ^wtcb.flags.dialed
	     then terminal_info.id = "";
	     else terminal_info.id = tcb.id;
	     terminal_info.term_type = tcb.terminal_type;
	     terminal_info.line_type = wtcb.line_type;
	     terminal_info.baud_rate = wtcb.baud_rate;
	end;

	else if order = "info"			/* get baud rate, id and type */
	then do;
	     argptr -> info.baud_rate = wtcb.baud_rate;	/* fill in baud rate */
	     argptr -> info.line_type = wtcb.line_type;
	     if ^wtcb.flags.dialed			/* if data not there */
	     then do;
		argptr -> info.id = " ";		/* fake it */
		argptr -> info.tw_type = 0;
	     end;
	     else do;
		argptr -> info.id = tcb.id;		/* pull info from data base */
		argptr -> info.tw_type = tcb.old_type;
	     end;
	end;

	else if order = "quit_enable"			/* turn on quits? */
	then wtcb.qenable = "1"b;

	else if order = "quit_disable"		/* turn off quits? */
	then wtcb.qenable = "0"b;

	else if order = "start"			/* kick user? */
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;
	     unspec (net_event_message) = "0"b;
	     net_event_message.version = NET_EVENT_MESSAGE_VERSION_1;
	     net_event_message.network_type = MCS_NETWORK_TYPE;
	     net_event_message.handle = devx;
	     net_event_message.type = MCS_UNSPECIFIED_MSG;
	     call pxss$ring_0_wakeup (wtcb.uproc, wtcb.event, net_event_message_arg, 0);
						/* wakeup the user */
	end;
%page;
	else if order = "read_status"
	then do;					/* look to see if we have any */
	     if ^wtcb.flags.dialed
	     then go to error;

	     if wtcb.flags.line_status_present
	     then do;				/* must complain about unprocessed status */
		ercode = error_table_$line_status_pending;
		go to unlock;
	     end;

	     if wtcb.error_code ^= 0
	     then do;
		ercode = wtcb.error_code;
		wtcb.error_code = 0;
		go to unlock;
	     end;

	     if wtcb.input_available | wtcb.fblock ^= 0
	     then rd_stat.input_available = "1"b;
	     else do;
		rd_stat.input_available = "0"b;
		if ^wtcb.flags.rflag & (wtcb.prompt_len > 0 | is_parent_mpx (UNCP_MPX))
		then do;				/* UNCP needs this to turn line around */
		     rawom = tcb.rawom;
		     tcb.rawom = "1"b;		/* write prompt in rawo mode */
		     call tty_write$locked (devx, addr (wtcb.prompt), 0, (wtcb.prompt_len), 0, 0, code);
		     tcb.rawom = rawom;
		end;
		wtcb.flags.rflag = "1"b;
	     end;
	end;

	else if order = "write_status"
	then do;					/* check for pending output */
	     if ^wtcb.flags.dialed
	     then go to error;
	     if wtcb.flags.line_status_present
	     then do;				/* must complain about unprocessed status */
		ercode = error_table_$line_status_pending;
		go to unlock;
	     end;

	     if wtcb.error_code ^= 0
	     then do;
		ercode = wtcb.error_code;
		wtcb.error_code = 0;
		go to unlock;
	     end;

	     code = 0;
	     if wtcb.write_first ^= 0
	     then wr_stat.output_pending = "1"b;
	     else do;
		call channel_manager$control (devx, "write_status", argptr, code);
		if code ^= 0
		then if code = error_table_$undefined_order_request
						/* multiplexer is ignorant of this */
		     then do;
			code = 0;
			wr_stat.output_pending = "0"b;
		     end;
		ercode = code;
	     end;

	     if code = 0
	     then if wr_stat.output_pending
		then wtcb.flags.wflag = "1"b;		/* get wakeup when it is gone */
	end;


	else if order = "refuse_printer_off"
	then tcb.no_printer_off = "1"b;

	else if order = "accept_printer_off"
	then tcb.no_printer_off = "0"b;

	else if order = "printer_off"			/* turn printer off */
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;

	     if tcb.modes.echoplex
	     then call alter_mode ("echoplex", "0"b);	/* stop echoing to stop printing */
	     else call turn_printer_off (ercode);

	     if ercode = 0
	     then if tcb.modes.replay			/* don't want any replay while printing disabled */
		then call alter_mode ("replay", "0"b);
	end;

	else if order = "printer_on"			/* turn printer on */
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;

	     if tcb.modes.echoplex
	     then call alter_mode ("echoplex", "1"b);
	     else call turn_printer_on (ercode);

	     if ercode = 0
	     then if tcb.replay			/* must reactivate this mode */
		then call alter_mode ("replay", "1"b);
	end;

	else if order = "set_terminal_data"
	then do;
	     ttdp = argptr;				/* set ptr to terminal_type_data info structure */
	     if terminal_type_data.version > ttd_version_3 | terminal_type_data.version <= 0
	     then go to wrong_version;

	     new_tablerp (*) = (18)"1"b;		/* init new table rel ptrs */
	     ntpp = addr (terminal_type_data.tables);	/* set ptr to new_tablep array */
	     code = 0;
	     do table_type = 1 to 6 while (code = 0);	/* add the new tables */
		call add_table (table_type, new_tablep (table_type), new_tablerp (table_type), code);
	     end;

	     if code ^= 0				/* could not add all the new tables */
	     then do;				/* must delete any we did add */
		do table_type = 1 to 6 while (new_tablerp (table_type) ^= (18)"1"b);
		     if new_tablerp (table_type) ^= ""b /* a real table was added */
		     then call tty_tables_mgr$delete (new_tablerp (table_type), 0);
		end;
		ercode = code;			/* give user the bad news */
		go to unlock;
	     end;

	     trpp = addr (tcb.tables);		/* set ptr to tablerp array */
	     dftrpp = addr (tcb.default_tables);	/* set ptr to df_tablerp array */
	     do table_type = 1 to 6;			/* now assign the new tables in the tcb */
		if tablerp (table_type) ^= ""b	/* dispose of any previous tables */
		then call tty_tables_mgr$delete (tablerp (table_type), 0);
		if df_tablerp (table_type) ^= (18)"1"b & df_tablerp (table_type) ^= ""b
		then call tty_tables_mgr$delete (df_tablerp (table_type), 0);
		tablerp (table_type) = new_tablerp (table_type);
						/* set the current table */
		df_tablerp (table_type) = (18)"1"b;	/* default table is same as current table */
	     end;

	     if tcb.modes.echoplex | tcb.modes.echo_cr | tcb.modes.echo_lf
	     then call send_delay_table;

	     tcb.old_type = terminal_type_data.old_type;
	     tcb.terminal_type = terminal_type_data.name;
	     tcb.erase = terminal_type_data.erase;
	     tcb.kill = terminal_type_data.kill;

	     tcb.frame_begin = terminal_type_data.frame_begin;
	     tcb.frame_end = terminal_type_data.frame_end;
	     if tcb.frame_end ^= NUL
	     then do;				/* ship framing chars to FNP */
		sfc.frame_begin = tcb.frame_begin;
		sfc.frame_end = tcb.frame_end;
		call channel_manager$control (devx, "set_framing_chars", addr (sfc), ercode);
	     end;

	     if terminal_type_data.line_delimiter ^= low (1)
	     then wtcb.line_delimiter = terminal_type_data.line_delimiter;
	     sw = terminal_type_data.keyboard_locking;
	     if sw ^= tcb.keyboard_locking		/* change to keyboard locking */
	     then if sw & wtcb.line_type ^= LINE_ASCII
		then ;				/* invalid change, ignore it */
		else do;				/* make the change */
		     tcb.keyboard_locking = sw;
		     if ^(tcb.modes.full_duplex | tcb.modes.echoplex)
						/* keyboard locking possible */
		     then call channel_manager$control (devx, "lock", addr (sw), ercode);
						/* pass it on down */
		end;

	     if terminal_type_data.version >= ttd_version_2
						/* version 2 includes flow control */
	     then do;
		if terminal_type_data.input_resume ^= NUL
		then do;
		     tcb.input_resume_seq.count = 1;
		     substr (tcb.input_resume_seq.chars, 1, 1) = terminal_type_data.input_resume;
		     if terminal_type_data.input_suspend = NUL
		     then tcb.input_suspend_seq.count = 0;
		     else do;
			tcb.input_suspend_seq.count = 1;
			substr (tcb.input_suspend_seq.chars, 1, 1) = terminal_type_data.input_suspend;
		     end;

		     unspec (auto_ifc.suspend_seq) = unspec (tcb.input_suspend_seq);
		     unspec (auto_ifc.resume_seq) = unspec (tcb.input_resume_seq);
		     auto_ifc.timeout = terminal_type_data.input_timeout;
		     call channel_manager$control (devx, "input_flow_control_chars", addr (auto_ifc), ercode);
		end;

		else if tcb.input_resume_seq.count ^= 0 /* used to have one */
		then do;				/* must turn it off now */
		     tcb.input_suspend_seq.count = 0;
		     tcb.input_resume_seq.count = 0;
		     auto_ifc.suspend_seq.count = 0;
		     auto_ifc.resume_seq.count = 0;
		     call channel_manager$control (devx, "input_flow_control_chars", addr (auto_ifc), ercode);
		end;

		if terminal_type_data.output_resume_ack ^= NUL
		then do;
		     tcb.output_suspend_etb_seq.count = 1;
		     tcb.output_resume_ack_seq.count = 1;
		     substr (tcb.output_suspend_etb_seq.chars, 1, 1) = terminal_type_data.output_suspend_etb;
		     substr (tcb.output_resume_ack_seq.chars, 1, 1) = terminal_type_data.output_resume_ack;

		     unspec (auto_ofc.suspend_or_etb_seq) = unspec (tcb.output_suspend_etb_seq);
		     unspec (auto_ofc.resume_or_ack_seq) = unspec (tcb.output_resume_ack_seq);
		     tcb.block_acknowledge, auto_ofc.block_acknowledge = terminal_type_data.output_block_acknowledge;
		     auto_ofc.suspend_resume = ^terminal_type_data.output_block_acknowledge;
		     auto_ofc.mbz = ""b;
		     auto_ofc.buffer_size = terminal_type_data.output_buffer_size;
		     tcb.max_output_block = divide (terminal_type_data.output_buffer_size, 2, 18, 0);
		     call channel_manager$control (devx, "output_flow_control_chars", addr (auto_ofc), ercode);
		end;

		else if tcb.output_resume_ack_seq.count ^= 0 | tcb.max_output_block ^= 0
		then do;				/* something to turn off */
		     tcb.output_suspend_etb_seq.count = 0;
		     tcb.output_resume_ack_seq.count = 0;
		     tcb.max_output_block = 0;
		     tcb.block_acknowledge = "0"b;

		     if tcb.oflow			/* force it off */
		     then do;
			auto_mode.len = 6;
			auto_mode.str = "^oflow";
			call tty_modes (wtcbp, addr (auto_mode), (0));
		     end;

		     auto_ofc.block_acknowledge = "0"b;
		     auto_ofc.suspend_resume = "0"b;
		     auto_ofc.mbz = ""b;
		     auto_ofc.buffer_size = 0;
		     auto_ofc.suspend_or_etb_seq.count = 0;
		     auto_ofc.resume_or_ack_seq.count = 0;
		     call channel_manager$control (devx, "output_flow_control_chars", addr (auto_ofc), ercode);
		end;
	     end;
	end;

	else if order = "store_id"			/* store answerback id for later use */
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;
	     tcb.id = argptr -> inid;
	end;

	else if order = "wru"
	then if pds$processid = wtcb.hproc
	     then do;
		if ^wtcb.flags.dialed
		then go to error;

		if wtcb.flags.line_status_present
		then do;				/* must complain about unprocessed status */
		     ercode = error_table_$line_status_pending;
		     go to unlock;
		end;

		if wtcb.error_code ^= 0
		then do;
		     ercode = wtcb.error_code;
		     wtcb.error_code = 0;
		     go to unlock;
		end;

		call forward_order ();
		wtcb.flags.wru, wtcb.flags.rflag = "1"b;
	     end;
	     else go to error;

	else if order = "interrupt"
	then if wtcb.line_type = LINE_ASCII
	     then do;
		if ^wtcb.flags.dialed
		then go to error;

		if wtcb.flags.line_status_present
		then do;				/* must complain about unprocessed status */
		     ercode = error_table_$line_status_pending;
		     go to unlock;
		end;

		if wtcb.error_code ^= 0
		then do;
		     ercode = wtcb.error_code;
		     wtcb.error_code = 0;
		     go to unlock;
		end;

		call forward_order ();
	     end;
	     else go to error;

	else if order = "set_input_message_size"
	then do;
	     if ^wtcb.sync_line
	     then go to error;

	     if argptr -> based_arg > 2048
	     then do;				/* can't set message size > exhaust limit */
		ercode = error_table_$buffer_big;
		go to unlock;
	     end;

	     call forward_order ();
	     tcb.input_msg_size = argptr -> based_arg;
	end;

	else if order = "get_input_message_size"
	then do;
	     if ^wtcb.sync_line
	     then go to error;
	     argptr -> based_arg = tcb.input_msg_size;

	end;

	else if order = "start_xmit_hd"
	then do;
	     if wtcb.line_type ^= LINE_ARDS
	     then go to error;

	     call forward_order ();
	end;

	else if order = "stop_xmit_hd"
	then do;
	     if wtcb.line_type ^= LINE_ARDS
	     then go to error;

	     call forward_order ();
	end;

	else if order = "set_line_type"
	then do;
	     if argptr = null
	     then go to error;			/* you have tell us what */
	     if wtcb.flags.listen
	     then go to error;			/* it's too late to change line types */
	     if new_line_type <= 0 | new_line_type > max_line_type
						/* invalid line_type */
	     then go to error;
	     if new_line_type = LINE_1050 | new_line_type = LINE_2741 | new_line_type = LINE_ARDS
		| new_line_type = LINE_ETX		/* The 1050, 2741, ETX and ARDS line types are no longer valid. */
	     then go to error;

	     call forward_order ();
	     wtcb.line_type = new_line_type;
	     do i = 1 to n_sync_line_types while (new_line_type ^= sync_line_type (i));
	     end;
	     wtcb.sync_line = (i <= n_sync_line_types);
	end;

	else if order = "dial_out"
	then do;
	     if pds$processid ^= wtcb.hproc
	     then go to illdet;			/* wtcb must be owned by caller */
	     if argptr = null ()
	     then go to error;			/* you have to give me a phone number */
	     if wtcb.flags.dialed
	     then go to error;			/* can't dial out, line is already being used */
	     if wtcb.dialing
	     then go to error;			/* can't dial while dialing */

	     if wtcb.flags.line_status_present
	     then do;				/* must complain about unprocessed status */
		ercode = error_table_$line_status_pending;
		go to unlock;
	     end;

	     if wtcb.error_code ^= 0
	     then do;
		ercode = wtcb.error_code;
		wtcb.error_code = 0;
		go to unlock;
	     end;

	     phone_data = arg_varying_char32;

/* phone number looks ok */
	     wtcb.dialing = "1"b;			/* remember what we are doing */
	     wtcb.dial_status_valid = ""b;		/* no status yet */
	     wtcb.dial_status_code = 0;		/* zero code */
	     call channel_manager$control (devx, order, addr (phone_data), ercode);
	     if ercode ^= 0
	     then wtcb.dialing = "0"b;		/* multiplexer rejected it, so we're not really dialing */
						/* otherwise, status will be returned via interrupt when the dial_out completes */
						/* so we're all done */
	end;

	else if order = "dial_out_status"
	then do;					/* caller wants result of dial */
	     if ^wtcb.dialing
	     then goto error;			/* not dialing */
	     if wtcb.dial_status_valid
	     then do;				/* is there status yet? */
		if wtcb.dial_status_code = 0
		then ercode = 0;
		else if wtcb.dial_status_code = acu_no_power
		then ercode = error_table_$device_not_usable;
		else if wtcb.dial_status_code = acu_line_occupied
		then ercode = error_table_$invalid_state;
		else if wtcb.dial_status_code = acu_dial_failure
		then ercode = error_table_$no_connection;
		else if wtcb.dial_status_code = acu_no_good
		then ercode = error_table_$no_operation;
		else if wtcb.dial_status_code = terminal_rejected
		then ercode = error_table_$no_wired_structure;
		else ercode = wtcb.dial_status_code;
		wtcb.dial_status_valid = ""b;		/* can only get status once */
		wtcb.dialing = ""b;
		wtcb.dial_status_code = 0;
	     end;
	     else ercode = error_table_$request_pending;
	end;

	else if order = "line_status"
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;
	     if wtcb.flags.line_status_present
	     then do;				/* good call */
		argptr -> bit72 = wtcb.line_status;
		wtcb.line_status = "0"b;
		wtcb.flags.line_status_present = "0"b;
	     end;
	     else ercode = error_table_$no_line_status;	/* bad call */
	end;

	else if order = "line_control"
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;
	     if wtcb.flags.line_status_present
	     then do;				/* must complain about unprocessed status */
		ercode = error_table_$line_status_pending;
		go to unlock;
	     end;

	     if wtcb.error_code ^= 0
	     then do;
		ercode = wtcb.error_code;
		wtcb.error_code = 0;
		go to unlock;
	     end;

	     call forward_order ();
	end;

	else if order = "set_line_status_enabled"	/* control whether to report line_status */
	then do;
	     if argptr = null ()
	     then do;
		ercode = error_table_$null_info_ptr;
		go to unlock;
	     end;

	     wtcb.line_status_disabled = ^(argptr -> bit1);
	     if wtcb.line_status_disabled
	     then do;				/* if disabling it */
		wtcb.line_status_present = "0"b;	/* if there was one already, discard it */
		wtcb.line_status = ""b;
	     end;
	end;

	else if order = "get_line_status_enabled"	/* user wants to see if line_status is enabled */
	then do;
	     if argptr = null ()
	     then do;
		ercode = error_table_$null_info_ptr;
		go to unlock;
	     end;

	     argptr -> bit1 = ^wtcb.line_status_disabled;
	end;

	else if order = "unmask"
	then if pds$processid ^= wtcb.hproc
	     then do;
		code = error_table_$io_no_permission;
		go to unlock;
	     end;

	     else if wtcb.masked
	     then do;
		wtcb.masked = "0"b;
		state = IGNORE;			/* now it's just hung up */
	     end;
	     else ;				/* a nop if channel wasn't masked */

	else if order = "set_editing_chars"
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;
	     if editing_chars.version < 2 | editing_chars.version > 3
	     then go to wrong_version;

	     if search (editing_chars.chars, white_space) ^= 0
		| substr (editing_chars.chars, 1, 1) = substr (editing_chars.chars, 2, 1)
	     then ercode = error_table_$inconsistent;

	     else do;
		if substr (editing_chars.chars, 1, 1) ^= " "
		then tcb.erase = substr (editing_chars.chars, 1, 1);

		if substr (editing_chars.chars, 2, 1) ^= " "
		then tcb.kill = substr (editing_chars.chars, 2, 1);

	     end;
	end;

	else if order = "get_editing_chars"
	then if ^wtcb.flags.dialed
	     then go to error;
	     else do;
		if editing_chars.version < 2 | editing_chars.version > 3
		then go to wrong_version;
		editing_chars.chars = addr (tcb.special_input_chars) -> two_chars;
	     end;

	else if order = "set_framing_chars"
	then do;
	     if wtcb.sync_line
	     then go to error;

	     if (framing_chars.frame_end = NUL & framing_chars.frame_begin ^= NUL)
						/* can't have begin without end */
	     then ercode = error_table_$inconsistent;

	     else do;
		call forward_order ();
		tcb.frame_begin = framing_chars.frame_begin;
		tcb.frame_end = framing_chars.frame_end;

	     end;
	end;

	else if order = "input_flow_control_chars"
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;
	     if (argptr -> input_flow_control_info.resume_seq.count = 0
		& argptr -> input_flow_control_info.suspend_seq.count ^= 0)
		| (argptr -> input_flow_control_info.suspend_seq.count = 0
		& argptr -> input_flow_control_info.resume_seq.count ^= 0
		& ^argptr -> input_flow_control_info.timeout)
	     then ercode = error_table_$improper_data_format;
	     else do;
		tcb.input_suspend_seq = argptr -> input_flow_control_info.suspend_seq;
		tcb.input_resume_seq = argptr -> input_flow_control_info.resume_seq;
		call forward_order ();
	     end;
	end;

	else if order = "output_flow_control_chars"
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;
	     if argptr -> output_flow_control_info.suspend_resume & argptr -> output_flow_control_info.block_acknowledge
	     then go to bad_ofc;			/* must be one or the other */

	     sus_count = argptr -> output_flow_control_info.suspend_or_etb_seq.count;
	     res_count = argptr -> output_flow_control_info.resume_or_ack_seq.count;

	     if argptr -> output_flow_control_info.block_acknowledge
	     then if argptr -> output_flow_control_info.buffer_size = 0
		then if (tcb.max_output_block = 0 & (res_count + sus_count ^= 0))
						/* not already set */
			| (res_count = 0 & sus_count ^= 0) | (sus_count = 0 & res_count ^= 0)
						/* or not setting chars */
		     then go to bad_ofc;
		     else ;

		else tcb.max_output_block = divide (argptr -> output_flow_control_info.buffer_size, 2, 18, 0);
						/* set block size to half of buffer size */

	     else if (sus_count = 0 & res_count ^= 0) | (res_count = 0 & sus_count ^= 0)
		| (sus_count ^= 0 & sus_count = res_count
		& substr (argptr -> output_flow_control_info.suspend_or_etb_seq.chars, 1, sus_count)
		= substr (argptr -> output_flow_control_info.resume_or_ack_seq.chars, 1, res_count))
						/* suspend_resume, must specify chars, and they must be different */
	     then do;
bad_ofc:
		ercode = error_table_$improper_data_format;
		go to unlock;
	     end;
	     else tcb.max_output_block = 0;

	     if sus_count ^= 0 | (sus_count = 0 & res_count = 0 & argptr -> output_flow_control_info.buffer_size = 0)
						/* setting some sequence or turning it all off */
	     then do;
		tcb.output_suspend_etb_seq = argptr -> output_flow_control_info.suspend_or_etb_seq;
		tcb.output_resume_ack_seq = argptr -> output_flow_control_info.resume_or_ack_seq;
	     end;
	     tcb.block_acknowledge = argptr -> output_flow_control_info.block_acknowledge;

	     call forward_order ();
	end;

	else if order = "get_framing_chars"
	then do;
	     framing_chars.frame_begin = tcb.frame_begin;
	     framing_chars.frame_end = tcb.frame_end;
	end;

	else if order = "get_ifc_info"
	then do;
	     argptr -> input_flow_control_info.suspend_seq = tcb.input_suspend_seq;
	     argptr -> input_flow_control_info.resume_seq = tcb.input_resume_seq;
	end;

	else if order = "get_ofc_info"
	then do;
	     argptr -> output_flow_control_info.block_acknowledge = tcb.block_acknowledge;
	     argptr -> output_flow_control_info.suspend_resume =
		(^tcb.block_acknowledge) & (tcb.output_suspend_etb_seq.count ^= 0);
	     argptr -> output_flow_control_info.buffer_size = 2 * tcb.max_output_block;
	     argptr -> output_flow_control_info.suspend_or_etb_seq = tcb.output_suspend_etb_seq;
	     argptr -> output_flow_control_info.resume_or_ack_seq = tcb.output_resume_ack_seq;
	end;

	else if order = "set_delay"
	then do;
	     call replace_table (delay_type, ercode);
	     if ercode = 0 & (tcb.modes.echoplex | tcb.modes.echo_cr | tcb.modes.echo_lf)
	     then call send_delay_table;
	end;

	else if order = "set_input_conversion"
	then call replace_table (input_cv_type, ercode);

	else if order = "set_input_translation"
	then call replace_table (input_tr_type, ercode);

	else if order = "set_output_conversion"
	then call replace_table (output_cv_type, ercode);

	else if order = "set_output_translation"
	then call replace_table (output_tr_type, ercode);

	else if order = "set_special"
	then call replace_table (special_type, ercode);

	else if order = "set_echo_break_table"
	then do;
	     echo_neg_datap = argptr;

	     /*** Code to accept version 1 structure for compatibility ***/
	     /*** To be REMOVED when Emacs, video and mowse are using  ***/
	     /*** version 2.                                           ***/

	     echo_version_1 = "0"b;
	     if echo_neg_data.version = echo_neg_data_version_1
	     then echo_version_1 = "1"b;
	     else
/**** end compatibility code ****/
		if echo_neg_data.version ^= echo_neg_data_version_2
	     then go to wrong_version;

	     if wtcb.echdp = "000000"b3
	     then do;
		call tty_space_man$get_space (size (echo_data), echo_datap);
		if echo_datap ^= null ()
		then wtcb.echdp = rel (echo_datap);
	     end;
	     else echo_datap = ptr (ttybp, wtcb.echdp);
	     if echo_datap = null
	     then ercode = error_table_$notalloc;
	     else do;
		unspec (echo_data) = ""b;		/* For good luck */

		/*** Version 1 structure ***/
		/*** REMOVE when Emacs, video and mowse are using version 2. ***/

		if echo_version_1
		then do;
		     string (echo_data.break) = string (v1_echo_neg_data.break);
		     substr (string (echo_data.break), 129, 128) = (128)"1"b;
		     echo_data.rubout_trigger_chars = v1_echo_neg_data.rubout_trigger_chars;
		     echo_data.rubout_sequence_length = v1_echo_neg_data.rubout_sequence_length;
		     echo_data.rubout_sequence = v1_echo_neg_data.rubout_sequence;
		     echo_data.rubout_pad_count = v1_echo_neg_data.rubout_pad_count;
		     echo_data.buffer_rubouts = v1_echo_neg_data.buffer_rubouts;
		end;

		else do;

		     /*** END COMPATIBILITY CODE ****/

		     string (echo_data.break) = string (echo_neg_data.break);
		     echo_data.rubout_trigger_chars = echo_neg_data.rubout_trigger_chars;
		     echo_data.rubout_sequence_length = echo_neg_data.rubout_sequence_length;
		     echo_data.rubout_sequence = echo_neg_data.rubout_sequence;
		     echo_data.rubout_pad_count = echo_neg_data.rubout_pad_count;
		     echo_data.buffer_rubouts = echo_neg_data.buffer_rubouts;
		end;				/* of else clause for version 1 */
		/*** REMOVE when Emacs, video and mowse are using version 2. ***/

		call channel_manager$control (devx, "set_echnego_break_table", addr (echo_data.break), (0));
	     end;
	end;

	else if order = "get_delay"
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;			/* obviously can't get it */
	     if argptr -> delay_struc.version ^= DELAY_VERSION
	     then go to wrong_version;

	     if tcb.delayrp = ""b			/* no delays */
	     then unspec (argptr -> delay_struc.delay) = ""b;

	     else argptr -> delay_struc.delay = ptr (ttytp, tcb.delayrp) -> delay;
	end;

	else if order = "get_special"
	then do;
	     if ^wtcb.flags.dialed
	     then go to error;
	     if tcb.specialrp = ""b			/* no special chars table */
	     then do;
		ercode = error_table_$no_table;
		go to unlock;
	     end;

	     special_ptr = ptr (ttytp, tcb.specialrp);	/* prepare to allocate and copy table */
	     sc_escape_len = special_ptr -> special_chars.escape_length;
	     sc_input_escape_len = special_ptr -> special_chars.input_escapes.len;

	     if get_special_info.version = SPECIAL_INFO_STRUCT_VERSION_1
	     then old_special_table_version = "0"b;
	     else old_special_table_version = "1"b;

	     on area go to no_allocate;
	     on storage go to no_allocate;

	     if old_special_table_version
	     then allocate special_chars_struc_old in (get_special_info_old.area_ptr -> special_area) set (temp_ptr);
	     else allocate special_chars_struc in (get_special_info.area_ptr -> special_area) set (temp_ptr);

	     revert area;
	     revert storage;

	     if old_special_table_version
	     then do;
		get_special_info_old.table_ptr = temp_ptr;
		temp_ptr -> special_chars_struc_old.version = SPECIAL_VERSION;

/* call internal subroutine to transfer new table into old table.  If any of
   the sequences are too long, it will return non-zero error code */
		call copy_to_old_special_table;
		if ercode ^= 0
		then do;
		     free temp_ptr -> special_chars_struc_old in (get_special_info_old.area_ptr -> special_area);
		     get_special_info_old.table_ptr = null;
		     go to unlock;
		end;
	     end;
	     else do;
		get_special_info.table_ptr = temp_ptr;
		temp_ptr -> special_chars_struc.version = SPECIAL_VERSION_2;
		addr (temp_ptr -> special_chars_struc.special_chars) -> special_chars = special_ptr -> special_chars;
	     end;
	end;

	else if order = "get_input_conversion"
	then call get_table (tcb.input_tctrp);

	else if order = "get_input_translation"
	then call get_table (tcb.input_mvtrp);

	else if order = "get_output_conversion"
	then call get_table (tcb.output_tctrp);

	else if order = "get_output_translation"
	then call get_table (tcb.output_mvtrp);

	else if order = "get_echo_break_table"
	then do;
	     if wtcb.echdp = "000000"b3
	     then ercode = error_table_$no_table;
	     else do;
		echo_datap = ptr (ttybp, wtcb.echdp);
		echo_neg_datap = argptr;		/* User's stuff */

		/*** Accept version 1 structure for compatibility ***/
		/*** REMOVE when Emacs, video and mowse are using version 2. ***/

		if echo_neg_data.version = echo_neg_data_version_1
		then do;
		     string (v1_echo_neg_data.break) = substr (string (echo_data.break), 1, 128);
						/* Copy the bits */
		     v1_echo_neg_data.rubout_sequence = echo_data.rubout_sequence;
		     v1_echo_neg_data.rubout_sequence_length = echo_data.rubout_sequence_length;
		     v1_echo_neg_data.rubout_pad_count = echo_data.rubout_pad_count;
		     v1_echo_neg_data.buffer_rubouts = echo_data.buffer_rubouts;
		     v1_echo_neg_data.rubout_trigger_chars = echo_data.rubout_trigger_chars;
		end;

		else do;
		     /*** END OF COMPATIBILITY CODE ***/
		     if echo_neg_data.version ^= echo_neg_data_version_2
		     then go to wrong_version;
		     string (echo_neg_data.break) = string (echo_data.break);
						/* Copy the bits */
		     echo_neg_data.rubout_sequence = echo_data.rubout_sequence;
		     echo_neg_data.rubout_sequence_length = echo_data.rubout_sequence_length;
		     echo_neg_data.rubout_pad_count = echo_data.rubout_pad_count;
		     echo_neg_data.buffer_rubouts = echo_data.buffer_rubouts;
		     echo_neg_data.rubout_trigger_chars = echo_data.rubout_trigger_chars;
		end;				/* of else clause based on version */
		/*** REMOVE when Emacs, video and mowse are using version 2. ***/
	     end;
	end;

	else if order = "get_meters"
	then do;
	     tty_meterp = argptr -> get_comm_meters_info.subchan_ptr;
	     if tty_meterp ^= null ()
	     then do;
		if tty_channel_meters.version ^= TTY_CHANNEL_METERS_VERSION_1
		then go to wrong_version;
		tty_channel_meters.last_dialed_time = tcb.time_dialed;
		tty_channel_meters.baud_rate = wtcb.baud_rate;
		tty_channel_meters.user_process = wtcb.uproc;
		tty_channel_meters.breakall = tcb.modes.breakall;
		tty_channel_meters.echoplex = tcb.modes.echoplex;
		tty_channel_meters.current_meters = tcb.cumulative_meters;
		tty_channel_meters.saved_meters = tcb.saved_meters;
	     end;
	     call forward_order ();
	end;

	else if order = "set_wakeup_table"
	then do;
	     swt_infop = argptr;
	     if swt_info.version ^= swt_info_version_1
	     then go to wrong_version;
	     if tcb.modes.wake_tbl
	     then go to cant_do;

	     if wtcb.waketp = ""b			/* no current wakeup table */
	     then string (swt_info.old_table) = ""b;
	     else do;
		wakeup_tablep = ptr (ttybp, wtcb.waketp);
		old_waketab = wakeup_table;
		call untranslate_wakeup_table;
		swt_info.old_table = old_waketab;
	     end;

	     new_waketab = swt_info.new_table;
	     if string (new_waketab) = ""b		/* new table is empty */
	     then do;
		if wtcb.waketp ^= ""b
		then do;
		     call tty_space_man$free_space (size (new_waketab), ptr (ttybp, wtcb.waketp));
		     wtcb.waketp = ""b;
		end;
	     end;
	     else do;				/* new table is not empty */
		if wtcb.waketp = ""b
		then do;
		     call tty_space_man$get_space (size (new_waketab), wakeup_tablep);
		     if wakeup_tablep = null
		     then go to no_allocate;
		     wtcb.waketp = rel (wakeup_tablep);
		end;
		call translate_wakeup_table;
		wakeup_table = new_waketab;
	     end;
	end;

	else if order = "set_prompt"
	then do;
	     sp_infop = argptr;
	     if sp_info.version ^= sp_info_version_1
	     then go to wrong_version;

	     i = length (sp_info.message);
	     if i < 0
	     then do;
		ercode = error_table_$smallarg;
		go to unlock;
	     end;
	     if i > 3
	     then do;
		ercode = error_table_$bigarg;
		go to unlock;
	     end;

	     wtcb.prompt_len = i;
	     if i > 0
	     then substr (wtcb.prompt, 1, i) = substr (sp_info.message, 1, i);
	end;

	else if order = "set_required_access_class"
	then do;
	     if wtcb.hproc ^= pds$processid
	     then do;				/* only owner can do this */
		ercode = error_table_$io_no_permission;
		go to unlock;
	     end;
	     else call forward_order ();		/* we don't handle this, but multiplexer might */
	end;

	else do;					/* we didn't understand the order */
	     call channel_manager$control (devx, order, a_argptr, ercode);
						/* see if any muxes understand */
	     go to unlock;				/* if not ercode will be returned */
	end;

unlock:
	if ercode = error_table_$io_no_permission
	then state = 0;				/* keep user in the dark */
	call tty_lock$unlock_channel (devx);		/* unlock the channel */
	return;

error:
	ercode = error_table_$undefined_order_request;	/* order not understood */
	go to unlock;

cant_do:
	ercode = error_table_$action_not_performed;	/* here if order couldn't be carried out */
	go to unlock;


no_allocate:
	ercode = error_table_$notalloc;
	go to unlock;

wrong_version:
	ercode = error_table_$unimplemented_version;
	go to unlock;
%page;
/* external entry to initialize a tcb */

initialize_tcb:
     entry (a_wtcbp, a_tcbp);


	wtcbp = a_wtcbp;
	tcbp = a_tcbp;
	call init_tcb;
	return;



/* internal procedure to initialize a tcb */

init_tcb:
     proc;

dcl  save_breakall_enabled bit (1);			/* used so this switch doesnt change */

	call init_tcb_tables;

	tcb.terminal_type = "";
	tcb.special_input_chars.erase = "#";
	tcb.special_input_chars.kill = "@";
	tcb.old_type = 0;
	string (tcb.modes) = ""b;
	save_breakall_enabled = tcb.breakall_enabled;	/* dont let this be changed */
	string (tcb.flags) = ""b;
	tcb.breakall_enabled = save_breakall_enabled;	/* restore old value */
	tcb.frame_begin, tcb.frame_end = NUL;
	tcb.actshift = "00"b;
	tcb.id = "none";
	tcb.colmax = 50;
	tcb.linemax = 0;
	tcb.wrt_lchar = 0;
	tcb.max_output_block = 0;
	tcb.input_suspend_seq.count = 0;
	tcb.input_resume_seq.count = 0;
	tcb.output_suspend_etb_seq.count = 0;
	tcb.output_resume_ack_seq.count = 0;
	wtcb.tcb_initialized = "1"b;

	return;

     end init_tcb;

init_tcb_tables:
     proc;

	trpp = addr (tcb.tables);			/* set ptr to tablerp array */
	dftrpp = addr (tcb.default_tables);		/* set ptr to  df_tablerp array */
	do table_type = 1 to 6;			/* dispose of tables from previous user */
	     if tablerp (table_type) ^= ""b
	     then call tty_tables_mgr$delete (tablerp (table_type), 0);
	     tablerp (table_type) = ""b;
	     if df_tablerp (table_type) ^= (18)"1"b & df_tablerp (table_type) ^= ""b
	     then call tty_tables_mgr$delete (df_tablerp (table_type), 0);
	     df_tablerp (table_type) = (18)"1"b;
	end;
	return;

     end init_tcb_tables;
%page;
/* internal procedure to add and replace tables */
/* replace_table entry is used by the table setting orders */
/* add_table entry is used by the set_terminal_data order */

replace_table:
     proc (table_type, code);

dcl  table_type fixed bin;				/* table type number (Input) */
dcl  code fixed bin (35);				/* status code (Output) */
dcl  infop ptr;					/* ptr to info structure containing table (Input) */
dcl  add_tablerp bit (18);				/* offset of added table */

dcl  new_tablerp bit (18);
dcl  tablep ptr;
dcl  table_size fixed bin;
dcl  replace_sw bit (1) aligned;


	replace_sw = "1"b;
	if ^wtcb.flags.dialed
	then go to error;
	trpp = addr (tcb.tables);			/* set ptr to tablerp array */
	dftrpp = addr (tcb.default_tables);		/* set ptr to df_tablerp array */
	go to join;


add_table:
     entry (table_type, infop, add_tablerp, code);

	replace_sw = "0"b;
	argptr = infop;

join:
	if argptr = null				/* no info structure supplied */
	then tablep = null;				/* assume null table */
	else do;
	     if table_type = delay_type & argptr -> delay_struc.version ^= DELAY_VERSION
	     then do;
wrong_version:
		code = error_table_$unimplemented_version;
		return;
	     end;
	     else if table_type = special_type
		&
		^(argptr -> special_chars_struc.version = SPECIAL_VERSION
		| argptr -> special_chars_struc.version = SPECIAL_VERSION_2)
	     then go to wrong_version;
	     else if argptr -> cv_trans_struc.version > CV_TRANS_VERSION
	     then go to wrong_version;

	     if replace_sw & argptr -> delay_struc.default ^= 0
	     then do;				/* must set current table to default table */
		if df_tablerp (table_type) = (18)"1"b	/* current table is already same as default */
		then ;				/* nothing to do */
		else do;
		     if tablerp (table_type) ^= ""b	/* current table is allocated */
		     then call tty_tables_mgr$delete (tablerp (table_type), 0);
						/* delete it */
		     tablerp (table_type) = df_tablerp (table_type);
						/* change the current table */
		     df_tablerp (table_type) = (18)"1"b;/* indicate that default table is the same */
		end;
		return;
	     end;

	     tablep = addr (argptr -> delay_struc.delay); /* get ptr to new table */
	end;

	if tablep = null
	then new_tablerp = ""b;			/* new table is null */
	else do;					/* allocate the new table */
	     if table_type = special_type
	     then do;
		if argptr -> special_chars_struc.version = SPECIAL_VERSION_2
		then do;
		     old_special_table_version = "0"b;
		     sc_escape_len = tablep -> special_chars.escape_length;
		     sc_input_escape_len = tablep -> special_chars.input_escapes.len;
		end;
		else do;
		     old_special_table_version = "1"b;
		     sc_escape_len = tablep -> special_chars_old.escape_length;
		     sc_input_escape_len = tablep -> special_chars_old.input_escapes.len;
		end;

		if sc_escape_len < 0 | sc_input_escape_len < 0
		then do;
bad_data:
		     code = error_table_$improper_data_format;
		     return;
		end;

		begin;

/* copy of special_chars structure.  put here so begin block can allocate an
   area large enough to hold the new version ofthe data */
dcl  1 scs aligned,
       2 nl_seq aligned like c_chars,			/* new-line sequence */
       2 cr_seq aligned like c_chars,			/* carriage-return sequence */
       2 bs_seq aligned like c_chars,			/* backspace sequence */
       2 tab_seq aligned like c_chars,			/* horizontal tab sequence */
       2 vt_seq aligned like c_chars,			/* vertical tab sequence */
       2 ff_seq aligned like c_chars,			/* form-feed sequence */
       2 printer_on aligned like c_chars,		/* printer-on sequence */
       2 printer_off aligned like c_chars,		/* printer_off sequence */
       2 red_ribbon_shift aligned like c_chars,		/* red ribbon shift sequence */
       2 black_ribbon_shift aligned like c_chars,		/* black ribbon shift sequence */
       2 end_of_page aligned like c_chars,		/* end-of-page warning sequence */
       2 escape_length fixed bin,			/* number of escape sequences */
       2 not_edited_escapes (sc_escape_len) like c_chars,	/* use in ^edited mode */
       2 edited_escapes (sc_escape_len) like c_chars,	/* use in edited mode */
       2 input_escapes aligned,
         3 len fixed bin (8) unaligned,			/* length of string */
         3 str char (sc_input_escape_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) unaligned;	/* results of escape sequences */

		     table_size = size (scs);
		     if table_size > max_special_size	/* watch out for gluttons */
		     then do;
			code = error_table_$bigarg;
			return;
		     end;
		     if ^old_special_table_version
		     then addr (scs) -> special_chars = tablep -> special_chars;
		     else call copy_from_old_special_table (tablep, addr (scs));
		     tablep = addr (scs);
		     call tty_tables_mgr$add (tablep, table_size, table_type, new_tablerp, code);
		end;
	     end;
	     else do;
		if table_type = delay_type
		then table_size = size (tablep -> delay);
		else table_size = divide (CV_TRANS_SIZE (argptr -> cv_trans_struc.version) + 1, 4, 17, 0);

		call tty_tables_mgr$add (tablep, table_size, table_type, new_tablerp, code);
	     end;
	     if code ^= 0
	     then return;

	     if table_type = special_type
	     then do;				/* don't trust user, restore saved refer values */
		tablep = ptr (ttytp, new_tablerp);
		tablep -> special_chars.escape_length = sc_escape_len;
		tablep -> special_chars.input_escapes.len = sc_input_escape_len;
	     end;
	     else if table_type = delay_type
	     then do;
		call validate_delay_table (ptr (ttytp, new_tablerp), code);
		if code ^= 0
		then do;
		     call tty_tables_mgr$delete (new_tablerp, 0);
		     return;
		end;
	     end;
	end;

	if ^replace_sw
	then add_tablerp = new_tablerp;
	else do;					/* change the tcb table offsets */
	     if df_tablerp (table_type) = (18)"1"b	/* default table is same as current */
	     then df_tablerp (table_type) = tablerp (table_type);
						/* set default table before changing current table */
	     else if tablerp (table_type) ^= ""b	/* the current table is allocated */
	     then call tty_tables_mgr$delete (tablerp (table_type), 0);
						/* delete it */
	     tablerp (table_type) = new_tablerp;	/* set the new current table */
	end;
	return;


     end replace_table;
%page;
get_table:
     proc (tablerp);

/* internal procedure to copy contents of table currently in use for "get_" orders */

dcl  tablerp bit (18);
dcl  tablep ptr;

	if ^wtcb.flags.dialed
	then go to error;

	if tablerp = ""b				/* we'll have to tell him about this */
	then ercode = error_table_$no_table;

	else do;
	     tablep = ptr (ttytp, tablerp);
	     if argptr -> cv_trans_struc.version > CV_TRANS_VERSION
	     then ercode = error_table_$unimplemented_version;
	     else if argptr -> cv_trans_struc.version = CV_TRANS_VERSION
	     then argptr -> cv_trans_struc.cv_trans = tablep -> cv_trans;
	     else do i = 0 to CV_TRANS_SIZE (argptr -> cv_trans_struc.version);
		argptr -> cv_trans_struc.cv_trans.value (i) = tablep -> cv_trans.value (i);
	     end;
	end;
	return;

     end /* get_table */;
%page;
alter_mode:
     proc (mode_name, alter_sw);

dcl  mode_name char (*);
dcl  alter_sw bit (1);

dcl  1 modes_info aligned,
       2 len fixed bin,
       2 str char (20);


	if alter_sw
	then do;
	     modes_info.str = mode_name;
	     modes_info.len = length (mode_name);
	end;
	else do;
	     modes_info.str = "^" || mode_name;
	     modes_info.len = length (mode_name) + 1;
	end;

	call tty_modes$mpx_only (wtcbp, addr (modes_info), ercode);

	return;

     end;



forward_order:
     proc;					/* forwards a control order to the multiplexer */

	call channel_manager$control (devx, order, argptr, ercode);
	if ercode ^= 0				/* give up */
	then go to unlock;

     end;
%page;
/* internal proc to validate a delay table */

validate_delay_table:
     proc (dp, code);

dcl  dp ptr;
dcl  code fixed bin (35);

	if max (abs (dp -> delay.vert_nl), dp -> delay.const_tab, abs (dp -> delay.backspace)) <= 127
	then if dp -> delay.vt_ff <= 511
	     then if min (dp -> delay.const_tab, dp -> delay.vt_ff) >= 0
		then if max (dp -> delay.horz_nl, dp -> delay.var_tab) <= 1
		     then if min (dp -> delay.horz_nl, dp -> delay.var_tab) >= 0
			then do;
			     code = 0;
			     return;
			end;
	code = error_table_$invalid_delay_value;

	return;

     end validate_delay_table;


/* entry to send delay table (called by tty_modes) */

send_delays:
     entry (a_wtcbp);

	wtcbp = a_wtcbp;
	tcbp = wtcb.tcb_ptr;
	devx = wtcb.devx;
	ttytp = addr (tty_tables$);
	call send_delay_table;
	return;


/* internal proc to send delay tables for the channel to the fnp */

send_delay_table:
     proc;

dcl  code fixed bin (35);


dcl  fnp_delays (6) fixed bin (17) unal;
dcl  dp ptr;

	if tcb.delayrp = ""b			/* no delay table for this channel */
	then fnp_delays (*) = 0;			/* use default delays, i.e., all zero */
	else do;					/* fill in fnp delays from current delay table */
	     dp = ptr (ttytp, tcb.delayrp);		/* get ptr to delay table */
	     fnp_delays (1) = abs (dp -> delay.vert_nl);
	     fnp_delays (2) = fixed (dp -> delay.horz_nl * 512, 17);
	     fnp_delays (3) = dp -> delay.const_tab;
	     fnp_delays (4) = fixed (dp -> delay.var_tab * 512, 17);
	     fnp_delays (5) = abs (dp -> delay.backspace);
	     fnp_delays (6) = min (dp -> delay.vt_ff, 127);
	end;

	call channel_manager$control (devx, "set_delay", addr (fnp_delays), code);

     end send_delay_table;
%page;
/* entry to turn printer on or off (called by tty_modes) */

printer_on_off:
     entry (a_wtcbp, a_sw);

	wtcbp = a_wtcbp;
	tcbp = wtcb.tcb_ptr;
	devx = wtcb.devx;
	ttytp = addr (tty_tables$);
	if a_sw
	then call turn_printer_on (0);
	else call turn_printer_off (0);
	return;


/* internal proc to write printer_off sequence to terminal */

turn_printer_off:
     proc (code);

dcl  code fixed bin (35);

	if tcb.no_printer_off
	then do;
no_print_off:
	     code = error_table_$action_not_performed;
	     return;
	end;

	call channel_manager$control (devx, "printer_off", null, code);
	if code = 0
	then return;
	if code ^= error_table_$undefined_order_request
	then return;
	code = 0;

	if tcb.specialrp = ""b
	then go to no_print_off;
	special_ptr = ptr (ttytp, tcb.specialrp);	/* get pointer to special chars table */
	if special_ptr -> special_chars.printer_off.count = 0
	then go to no_print_off;			/* none, complain */
	rawom = tcb.modes.rawom;			/* save setting of rawom */
	tcb.modes.rawom = "1"b;			/* we shd be in rawo to do this */

	call tty_write$locked (devx, addr (special_ptr -> special_chars.printer_off.chars), 0,
	     (special_ptr -> special_chars.printer_off.count), i, (0), code);
	tcb.modes.rawom = rawom;			/* restore rawom setting */

	return;

     end turn_printer_off;




/* internal proc to write printer_on sequence to terminal */

turn_printer_on:
     proc (code);

dcl  code fixed bin (35);

	if tcb.no_printer_off
	then do;
no_print_on:
	     code = error_table_$action_not_performed;
	     return;
	end;

	call channel_manager$control (devx, "printer_on", null, code);
	if code = 0
	then return;
	if code ^= error_table_$undefined_order_request
	then return;
	code = 0;

	if tcb.specialrp = ""b
	then go to no_print_on;

	special_ptr = ptr (ttytp, tcb.specialrp);	/* get pointer to special chars table */
	if special_ptr -> special_chars.printer_on.count = 0
	then go to no_print_on;			/* none, complain */
	rawom = tcb.modes.rawom;			/* save setting of rawom */
	tcb.modes.rawom = "1"b;			/* we shd be in rawo to do this */

	call tty_write$locked (devx, addr (special_ptr -> special_chars.printer_on.chars), 0,
	     (special_ptr -> special_chars.printer_on.count), i, (0), code);
	tcb.modes.rawom = rawom;			/* reset rawom */

	return;

     end turn_printer_on;
%page;
setup:
     proc (state);

dcl  state fixed bin;
	devx = twx;				/* pull devx from user */
	ttybp = addr (tty_buf$);
	lctp = tty_buf.lct_ptr;
	if devx < 1 | devx > lct.max_no_lctes
	then do;
	     ercode = error_table_$invalid_device;
	     go to ret;				/* return error */
	end;

	call tty_lock$lock_channel (devx, ercode);	/* lock the channel */
	if ercode ^= 0
	then go to ret;
	locked = "1"b;

	lctep = addr (lct.lcte_array (devx));
	if lcte.channel_type ^= 0			/* not our cup of tea */
	then go to illdet;

	wtcbp = lcte.data_base_ptr;			/* pointer to perm info */
	tcbp = wtcb.tcb_ptr;			/* pickup pointer to tib */
	if ^wtcb.tcb_initialized
	then call init_tcb;

	if wtcb.dialed				/* compute state */
	then state = DIALED_UP;			/* dialed up */
	else if wtcb.masked				/* masked by FNP */
	then state = MASKED_STATE;
	else if wtcb.listen
	then state = LISTENING;			/* hungup but listening */
	else state = IGNORE;			/* made busy */

	ercode = 0;				/* clear error code */

	if wtcb.hproc = pds$processid			/* check access */
	then return;				/* hproc is always welcome */

	if wtcb.hproc = "0"b			/* if no one */
	then return;				/* then ok */


	if (wtcb.uproc = pds$processid & (tcb.uproc_attached | ^uproc_attach_required_for_setup))
	     | ^uproc_required_for_setup		/* if using process */
	then return;

	go to illdet;				/* return to main line at error point */
     end;

illdet:						/* illegal messing with channel */
	ercode = error_table_$io_no_permission;		/* else return error */
	call tty_lock$unlock_channel (devx);		/* unlock the channel */

ret:
	if ercode ^= 0
	then state = 0;				/* keep clean */
	return;
%page;
get_devx:
     proc (chan_name);

dcl  chan_name char (*);

	lcntp = lct.lcnt_ptr;			/* get pointer to the name table */
	do devx = 1 to lct.max_no_lctes while (lcnt.names (devx) ^= chan_name);
	end;
	if devx > lct.max_no_lctes
	then					/* not in name table, maybe it's old name? */
	     do devx = 1 to lct.max_no_lctes while (^compare_tty_name_ (chan_name, lcnt.names (devx)));
	end;

	if devx > lct.max_no_lctes			/* wasn't in that form either */
	then ercode = error_table_$invalid_device;	/* leave error code */
	else ercode = 0;
	return;					/* return to caller */

     end;


cleaner:
     proc;

	if locked
	then call tty_lock$unlock_channel (devx);

     end cleaner;
%page;
/* Subroutine to translate wakeup table from ASCII to terminal code */

translate_wakeup_table:
     proc;

dcl  1 temp_table aligned like wakeup_table;
dcl  (i, j) fixed bin;
dcl  p ptr;

	if tcb.input_mvtrp = ""b
	then return;
	string (temp_table) = ""b;
	p = ptr (ttytp, tcb.input_mvtrp);		/* get ptr to input translation table */
	do i = 0 to 127;
	     if new_waketab.wake_map (i)		/* this is a wakeup char */
	     then do j = 0 to 127;			/* find all terminal codes that translate into it */
		if p -> cv_trans.value (j) = i	/* found one */
		then temp_table.wake_map (j) = "1"b;
	     end;
	end;

	new_waketab = temp_table;
     end;



/* Subroutine to translate wakeup table from terminal code to ASCII */

untranslate_wakeup_table:
     proc;

dcl  1 temp_table aligned like wakeup_table;
dcl  i fixed bin;
dcl  p ptr;

	if tcb.input_mvtrp = ""b
	then return;
	string (temp_table) = ""b;
	p = ptr (ttytp, tcb.input_mvtrp);
	do i = 0 to 127;
	     if old_waketab.wake_map (i)		/* this is a wakeup char */
	     then do;
		j = p -> cv_trans.value (i);		/* get ASCII value */
		if j <= 127			/* don't trust table */
		then temp_table.wake_map (j) = "1"b;
	     end;
	end;

	old_waketab = temp_table;
     end;

%page;
is_parent_mpx:					/* Check match of channel's parent mpx type against input mpx type */
     proc (parent_mpx_type) returns (bit (1));

dcl  parent_mpx_type fixed bin;
dcl  temp_lctep ptr;

	if lcte.major_channel_devx ^= 0
	then do;
	     temp_lctep = addr (lct.lcte_array (lcte.major_channel_devx));
	     if temp_lctep -> lcte.channel_type = parent_mpx_type
	     then return ("1"b);
	end;
	else if lcte.channel_type = parent_mpx_type
	then return ("1"b);
	return ("0"b);
     end is_parent_mpx;
%page;
copy_to_old_special_table:
     proc;

/* Special procedure to copy a Version 2 special chars table (15 char
   sequences) to a Version 1 special chars table (3 char sequences).  It is
   broken out as a subroutine just to avoid cluttering up where it is called. */

	special_chars_old_ptr = addr (temp_ptr -> special_chars_struc_old.special_chars);

	if special_ptr -> special_chars.nl_seq.count > 3
	then do;
bad_special_size:
	     ercode = error_table_$invalid_array_size;
	     return;
	end;
	addr (special_chars_old.nl_seq) -> c_chars_old = addr (special_ptr -> special_chars.nl_seq) -> c_chars_old;

	if special_ptr -> special_chars.cr_seq.count > 3
	then go to bad_special_size;
	addr (special_chars_old.cr_seq) -> c_chars_old = addr (special_ptr -> special_chars.cr_seq) -> c_chars_old;

	if special_ptr -> special_chars.bs_seq.count > 3
	then go to bad_special_size;
	addr (special_chars_old.bs_seq) -> c_chars_old = addr (special_ptr -> special_chars.bs_seq) -> c_chars_old;

	if special_ptr -> special_chars.tab_seq.count > 3
	then go to bad_special_size;
	addr (special_chars_old.tab_seq) -> c_chars_old = addr (special_ptr -> special_chars.tab_seq) -> c_chars_old;

	if special_ptr -> special_chars.vt_seq.count > 3
	then go to bad_special_size;
	addr (special_chars_old.vt_seq) -> c_chars_old = addr (special_ptr -> special_chars.vt_seq) -> c_chars_old;

	if special_ptr -> special_chars.ff_seq.count > 3
	then go to bad_special_size;
	addr (special_chars_old.ff_seq) -> c_chars_old = addr (special_ptr -> special_chars.ff_seq) -> c_chars_old;

	if special_ptr -> special_chars.printer_on.count > 3
	then go to bad_special_size;
	addr (special_chars_old.printer_on) -> c_chars_old =
	     addr (special_ptr -> special_chars.printer_on) -> c_chars_old;

	if special_ptr -> special_chars.printer_off.count > 3
	then go to bad_special_size;
	addr (special_chars_old.printer_off) -> c_chars_old =
	     addr (special_ptr -> special_chars.printer_off) -> c_chars_old;

	if special_ptr -> special_chars.red_ribbon_shift.count > 3
	then go to bad_special_size;
	addr (special_chars_old.red_ribbon_shift) -> c_chars_old =
	     addr (special_ptr -> special_chars.red_ribbon_shift) -> c_chars_old;

	if special_ptr -> special_chars.black_ribbon_shift.count > 3
	then go to bad_special_size;
	addr (special_chars_old.black_ribbon_shift) -> c_chars_old =
	     addr (special_ptr -> special_chars.black_ribbon_shift) -> c_chars_old;

	if special_ptr -> special_chars.end_of_page.count > 3
	then go to bad_special_size;
	addr (special_chars_old.end_of_page) -> c_chars_old =
	     addr (special_ptr -> special_chars.end_of_page) -> c_chars_old;

	special_chars_old.escape_length = special_ptr -> special_chars.escape_length;

	do i = 1 to special_ptr -> special_chars.escape_length;
	     if special_ptr -> special_chars.not_edited_escapes (i).count > 3
		| special_ptr -> special_chars.edited_escapes (i).count > 3
	     then go to bad_special_size;
	     addr (special_chars_old.not_edited_escapes (i)) -> c_chars_old =
		addr (special_ptr -> special_chars.not_edited_escapes (i)) -> c_chars_old;

	     addr (special_chars_old.edited_escapes (i)) -> c_chars_old =
		addr (special_ptr -> special_chars.edited_escapes (i)) -> c_chars_old;
	end;

	special_chars_old.input_escapes.len = special_ptr -> special_chars.input_escapes.len;
	special_chars_old.input_escapes.str = special_ptr -> special_chars.input_escapes.str;

	special_chars_old.input_results.pad = special_ptr -> special_chars.input_results.pad;
	special_chars_old.input_results.str = special_ptr -> special_chars.input_results.str;

     end copy_to_old_special_table;
%page;
copy_from_old_special_table:
     proc (source_ptr, target_ptr);

/* Special procedure to copy a Version 1 special chars table (3 char sequences
   into a Version 2 special chars table (15 char sequences).  It is put here
   just to keep from cluttering up where it is called. */

dcl  target_ptr ptr;
dcl  source_ptr ptr;

	special_chars_old_ptr = source_ptr;
	addr (target_ptr -> special_chars.nl_seq) -> c_chars_old = addr (special_chars_old.nl_seq) -> c_chars_old;

	addr (target_ptr -> special_chars.cr_seq) -> c_chars_old = addr (special_chars_old.cr_seq) -> c_chars_old;

	addr (target_ptr -> special_chars.bs_seq) -> c_chars_old = addr (special_chars_old.bs_seq) -> c_chars_old;

	addr (target_ptr -> special_chars.tab_seq) -> c_chars_old = addr (special_chars_old.tab_seq) -> c_chars_old;

	addr (target_ptr -> special_chars.vt_seq) -> c_chars_old = addr (special_chars_old.vt_seq) -> c_chars_old;

	addr (target_ptr -> special_chars.ff_seq) -> c_chars_old = addr (special_chars_old.ff_seq) -> c_chars_old;

	addr (target_ptr -> special_chars.printer_on) -> c_chars_old =
	     addr (special_chars_old.printer_on) -> c_chars_old;

	addr (target_ptr -> special_chars.printer_off) -> c_chars_old =
	     addr (special_chars_old.printer_off) -> c_chars_old;

	addr (target_ptr -> special_chars.red_ribbon_shift) -> c_chars_old =
	     addr (special_chars_old.red_ribbon_shift) -> c_chars_old;

	addr (target_ptr -> special_chars.black_ribbon_shift) -> c_chars_old =
	     addr (special_chars_old.black_ribbon_shift) -> c_chars_old;

	addr (target_ptr -> special_chars.end_of_page) -> c_chars_old =
	     addr (special_chars_old.end_of_page) -> c_chars_old;

	target_ptr -> special_chars.escape_length = special_chars_old.escape_length;

	do i = 1 to special_chars_old.escape_length;
	     addr (target_ptr -> special_chars.not_edited_escapes (i)) -> c_chars_old =
		addr (special_chars_old.not_edited_escapes (i)) -> c_chars_old;
	     addr (target_ptr -> special_chars.edited_escapes (i)) -> c_chars_old =
		addr (special_chars_old.edited_escapes (i)) -> c_chars_old;
	end;

	target_ptr -> special_chars.input_escapes.len = special_chars_old.input_escapes.len;
	target_ptr -> special_chars.input_escapes.str = special_chars_old.input_escapes.str;

	target_ptr -> special_chars.input_results.pad = special_chars_old.input_results.pad;
	target_ptr -> special_chars.input_results.str = special_chars_old.input_results.str;

     end copy_from_old_special_table;

/* format: off */
%page; %include aim_template;
%page; %include tty_convert;
%page; %include tty_buf;
%page; %include wtcb;
%page; %include tcb;
%page; %include tty_buffer_block;
%page; %include lct;
%page; %include tty_tables;
%page; %include mailbox_ops;
%page; %include net_event_message;
%page; %include terminal_type_data;
dcl  ttd_version_2 fixed bin int static options (constant) init (2);
%page; %include terminal_info;
%page; %include tty_space_man_dcls;
%page; %include channel_manager_dcls;
%page; %include line_types;
%page; %include mcs_echo_neg;
%page; %include mcs_echo_neg_sys;
%page; %include set_wakeup_table_info;
%page; %include set_prompt_info;
%page; %include flow_control_info;
%page; %include get_comm_meters_info;
%page; %include tty_channel_meters;
%page; %include tty_access_class;
%page; %include syserr_constants;
%page; %include multiplexer_types;

/* format: on */
%page;
/* BEGIN MESSAGE DOCUMENTATION

   Message:
   tty_index: USER (ACCESS_CLASS) attempted invalid attachment of CHANNEL (ACCESS_CLASS)

   S:	$info

   T:	$run

   M:	A process of USER (with authorization ACCESS_CLASS) attempted to use
   a communications channel which does not correspond to the user's
   authorization and the user does not have the communications privilege
   enabled. The request was refused.  This may indicate a system error.

   A:	$inform_ssa

   END MESSAGE DOCUMENTATION */


     end;




		    tty_modes.pl1                   11/11/89  1109.0r w 11/11/89  0826.9      150975



/****^  ***********************************************************
        *                                                         *
        * 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: style4,delnl,insnl,^ifthendo */

tty_modes:
     proc (pm_wtcbp, pm_modes_infop, pm_code);

/* A procedure to handle modes changing and related trivia. */

/* Coded 4/9/79 by J. Stern */
/* Modified: 11 November 1980 by G. Palter to handle can_type and implement MCS suggestions #64 and #65 */
/* Modified: 16 November 1981 by G. Palter to fix bug in interaction of init and can_type modes */
/* Modified: 9/14/84 by John Mills to fix bug in enteraction of can_type and can modes */
/* Modified: 9/25/84 by Robert Coren to enforce the requirement that flow control
   characters must be set before the modes can be turned on, and to remove prefixnl from the list
   of modes turned on by "default" mode */


/****^  HISTORY COMMENTS:
  1) change(86-06-19,Kissel), approve(86-07-30,MCR7475), audit(86-08-04,Coren),
     install(86-10-09,MR12.0-1181):
     Changed to support the new tty event message format declared in
     net_event_message.incl.pl1 which replaces tty_event_message.incl.pl1.
                                                   END HISTORY COMMENTS */


/* Parameters */

dcl  pm_code fixed bin (35);				/* error code */
dcl  pm_modes_infop ptr;				/* ptr to modes_info structure */
dcl  pm_wtcbp ptr;					/* ptr to wtcb of channel to which modes change applies */


/* Automatic */

dcl  code fixed bin (35);
dcl  force_sw bit (1);
dcl  i fixed bin;
dcl  j fixed bin;
dcl  idx fixed bin;
dcl  lock_keyboard bit (1) aligned;
dcl  mclx fixed bin;
dcl  mode_name char (32) varying;
dcl  1 modes_change_list aligned like mcl;
dcl  modes_infop ptr;
dcl  modes_len fixed bin;
dcl  mpx_only_sw bit (1);
dcl  off_modes (36) bit (1);
dcl  on_modes (36) bit (1);
dcl  saved_force_sw bit (1);
dcl  saved_ll fixed bin;
dcl  saved_modes bit (36);
dcl  saved_mpx_modes char (192);
dcl  saved_pl fixed bin;
dcl  saved_can_type fixed bin;
dcl  send_delay_table_sw bit (1);
dcl  sw bit (1);
dcl  temp_modes char (576) varying;


/* Based */

dcl  1 modes_info aligned based (modes_infop),
       2 len fixed bin,
       2 str char (0 refer (modes_info.len));


/* Constants */

dcl  NUL char (1) int static options (constant) init ("");


/* External static */

dcl  error_table_$bad_mode fixed bin (35) ext;
dcl  error_table_$bigarg fixed bin (35) ext;
dcl  error_table_$improper_data_format fixed bin (35) ext;
dcl  error_table_$smallarg fixed bin (35) ext;


/* Builtins */

dcl  (addr, after, bin, hbound, index, lbound, length, ltrim, reverse, rtrim, string, substr, verify) builtin;


/* Entries */

dcl  pxss$ring_0_wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  tty_index$printer_on_off entry (ptr, bit (1));
dcl  tty_index$send_delays entry (ptr);

%include mcs_modes_change_list;

%include tty_mode_names;

%include tty_can_types;

%include wtcb;

%include tcb;

%include net_event_message;

%include channel_manager_dcls;

%include mcs_echo_neg_sys;

	mpx_only_sw = "0"b;
	go to join;


/* for this entry, modes are merely forwarded to the multiplexer
   no local action is taken and no old modes are returned
*/

mpx_only:
     entry (pm_wtcbp, pm_modes_infop, pm_code);

	mpx_only_sw = "1"b;

join:
	pm_code = 0;
	wtcbp = pm_wtcbp;
	tcbp = wtcb.tcb_ptr;
	modes_infop = pm_modes_infop;

	saved_modes = string (tcb.modes);		/* save current modes */
	saved_ll = tcb.colmax;
	saved_pl = tcb.linemax;
	saved_can_type = tcb.can_type;

/* initialize modes change list */

	mclp = addr (modes_change_list);
	mcl.version = mcl_version_2;
	mcl.n_entries = 0;
	mcl.line_len = -1;
	mcl.page_len = -1;
	mcl.can_type = -1;
	string (mcl.flags) = ""b;

/* parse the modes string */

	modes_len = length (rtrim (modes_info.str));
	if modes_len > 0
	then if substr (modes_info.str, modes_len, 1) = "."
	     then modes_len = modes_len - 1;

	if modes_len <= 0
	then do;
	     if mpx_only_sw
	     then return;
	     call get_mpx_modes;
	     go to build_old_modes;
	end;

	if index (substr (modes_info.str, 1, modes_len), ".") ^= 0
						/* imbedded period */
	     | index (substr (modes_info.str, 1, modes_len), " ") ^= 0
						/* imbedded space */
	then go to bad_format;

	force_sw = "0"b;
	mclx = 0;
	i = 1;
	do while (i <= modes_len);			/* scan modes string until reaching the end */
	     j = index (substr (modes_info.str, i), ",") - 1;
						/* find next mode boundary */
	     if j = -1				/* end of string */
	     then j = modes_len - (i - 1);
	     if j <= 0				/* skinny mode */
	     then go to bad_format;

	     if substr (modes_info.str, i, 1) = "^"	/* OFF indicator */
	     then do;
		i = i + 1;
		j = j - 1;
		if j <= 0
		then go to bad_format;
		sw = "0"b;
	     end;
	     else sw = "1"b;			/* if not OFF, then ON */

	     mode_name = substr (modes_info.str, i, j);
	     if j > length (mode_name)
	     then go to bad_mode;
	     if mode_name = "init"
	     then do;
		if ^sw
		then go to bad_mode;
		mcl.init = "1"b;
		mcl.line_len = 50;
		mcl.page_len = 0;
		mcl.can_type = CAN_TYPE_OVERSTRIKE;
	     end;
	     else if mode_name = "force"
	     then force_sw = sw;
	     else if mode_name = "default"
	     then do;
		if ^sw
		then go to bad_mode;
		saved_force_sw = force_sw;
		force_sw = "1"b;			/* force all default modes */
		do mode_name = "esc", "can", "erkl";	/* add default ON modes */
		     call add_mode_change;
		end;
		sw = "0"b;
		do mode_name = "rawi", "rawo", "breakall", "wake_tbl";
						/* add default OFF modes */
		     call add_mode_change;
		end;
		force_sw = saved_force_sw;
	     end;
	     else if substr (mode_name, 1, 2) = "ll"
	     then mcl.line_len = convert_len ();
	     else if substr (mode_name, 1, 2) = "pl"
	     then mcl.page_len = convert_len ();
	     else if length (mode_name) > 9		/* to ensure validity of substr */
		& (substr (mode_name, 1, 9) = "can_type=")
	     then do;
		if ^sw
		then go to bad_mode;
		mcl.can_type = -1;			/* about to get a new value */
		do idx = lbound (CAN_TYPE_NAMES, 1) to hbound (CAN_TYPE_NAMES, 1) while (mcl.can_type = -1);
		     if (mode_name = CAN_TYPE_NAMES (idx))
		     then mcl.can_type = idx;		/* found it */
		end;
		if (mcl.can_type = -1)
		then				/* don't recognize the user's canonicalization type */
		     go to bad_mode;
	     end;
	     else call add_mode_change;

	     i = i + j + 1;				/* skip to next mode */
	end;
	mcl.n_entries = mclx;			/* fill in mode change count */

/* let multiplexer check mode changes */

	call channel_manager$check_modes ((wtcb.devx), mclp, code);
	if code ^= 0
	then if code ^= error_table_$bad_mode		/* if bad_mode, look for more errors before returning */
	     then do;
		pm_code = code;
		return;
	     end;

/* find modes that we must change rather than multiplexer */

	send_delay_table_sw = "0"b;
	on_modes (*) = "0"b;
	off_modes (*) = "0"b;
	if mcl.init
	then off_modes (*) = "1"b;

	do mclx = 1 to mcl.n_entries;
	     mclep = addr (mcl.entries (mclx));
	     do i = 1 to n_modes while (modestr (i) ^= mcle.mode_name);
	     end;
	     if i <= n_modes			/* this is a standard mode */
	     then do;
		if MPX_MODES (i) & ^mcle.mpx_mode	/* need multiplexer help for this mode */
		then do;
		     if mcle.mode_switch ^= substr (saved_modes, i, 1)
						/* this is a real change */
		     then if ^mcle.force
			then go to mode_error;
		end;
		else do;

		     if substr (saved_modes, i, 1) = mcle.mode_switch & ^mpx_only_sw & ^mcl.init
						/* this is not a change */
		     then mcle.mpx_mode = "0"b;	/* so make sure multiplexer doesn't try to do it */

		     else if mcle.mode_switch
		     then do;			/* be careful when turning on certain modes */
			if mcle.mode_name = "echoplex" | mcle.mode_name = "crecho" | mcle.mode_name = "lfecho"
			then send_delay_table_sw = "1"b;
			else if mcle.mode_name = "blk_xfer"
			then do;
			     if tcb.frame_end = NUL
			     then go to mode_error;
			end;

			else if mcle.mode_name = "oflow"
			then do;			/* make sure characters have been set */
			     if tcb.output_suspend_etb_seq.count = 0 | tcb.output_resume_ack_seq.count = 0
			     then go to mode_error;
			end;

			else if mcle.mode_name = "iflow"
			then do;			/* as above */
			     if tcb.input_suspend_seq.count = 0 | tcb.input_resume_seq.count = 0
			     then go to mode_error;
			end;

			else if mcle.mode_name = "wake_tbl"
			then do;
			     if wtcb.waketp = ""b
			     then go to mode_error;
			end;
		     end;

		     on_modes (i) = mcle.mode_switch;
		     off_modes (i) = ^mcle.mode_switch;
		end;
	     end;
	     else if ^mcle.mpx_mode			/* nobody knows this mode */
	     then do;
		if ^mcle.force
		then do;
mode_error:
		     mcle.error = "1"b;
		     code = error_table_$bad_mode;
		end;
	     end;
	end;
	if code ^= 0
	then go to mcl_error;			/* take care of all accumulated mode errors */

/* now go change the modes */

	if ^mpx_only_sw
	then call get_mpx_modes;

	call channel_manager$set_modes ((wtcb.devx), mclp, code);
	if code ^= 0
	then do;
	     if code = error_table_$bad_mode
	     then go to mcl_error;
	     pm_code = code;
	     return;
	end;
	if mpx_only_sw
	then return;

	if send_delay_table_sw
	then call tty_index$send_delays (wtcbp);

	do j = 1 to n_modes;			/* we've checked the mode string, now implement it */
	     if on_modes (j)
	     then sw = "1"b;
	     else if off_modes (j)
	     then sw = "0"b;
	     else go to end_of_mode;
	     if substr (saved_modes, j, 1) = sw		/* no change to this mode */
	     then go to end_of_mode;

	     substr (string (tcb.modes), j, 1) = sw;
	     go to set_modes (j);

set_modes (13):					/* hndlquit */
	     wtcb.flags.hndlquit = sw;

set_modes (14):					/* full_duplex */
	     if tcb.keyboard_locking
	     then do;				/* turn keyboard locking on/off if appropriate */
		lock_keyboard = ^sw;		/* fulldpx ON => unlock keyboard and vice versa */
		call channel_manager$control ((wtcb.devx), "lock", addr (lock_keyboard), code);
	     end;
	     go to end_of_mode;

set_modes (15):					/* echoplex */
	     call tty_index$printer_on_off (wtcbp, ^sw);
	     go to end_of_mode;

set_modes (21):					/* breakall */
	     wtcb.flags.breakall = sw;
	     if sw = "0"b
	     then do;				/* Turn off echnego */
		wtcb.negotiating_echo = "0"b;
		if wtcb.echdp ^= "000000"b3
		then do;
		     echo_datap = ptr (wtcbp, wtcb.echdp);
		     echo_data.synchronized = "0"b;
		end;
	     end;
	     go to end_of_mode;

set_modes (22):					/* scroll */
	     wtcb.flags.scroll = sw;
	     go to end_of_mode;

set_modes (24):					/* wake_tbl */
	     wtcb.flags.wake_tbl = sw;
	     wtcb.allow_wakeup = "0"b;
	     if wtcb.rflag & (wtcb.fblock ^= 0)		/* waiting for wakeup and has input */
	     then do;				/* play it safe, send wakeup now */
		unspec (net_event_message) = "0"b;
		net_event_message.version = NET_EVENT_MESSAGE_VERSION_1;
		net_event_message.network_type = MCS_NETWORK_TYPE;
		net_event_message.handle = wtcb.devx;
		net_event_message.type = MCS_READ_MSG;
		call pxss$ring_0_wakeup (wtcb.uproc, wtcb.event, net_event_message_arg, code);
	     end;
	     go to end_of_mode;

set_modes (1):
set_modes (2):
set_modes (3):
set_modes (4):
set_modes (5):
set_modes (6):
set_modes (7):
set_modes (8):
set_modes (9):
set_modes (10):
set_modes (11):
set_modes (12):
set_modes (16):
set_modes (17):
set_modes (18):
set_modes (19):
set_modes (20):
set_modes (23):
set_modes (25):
set_modes (26):
set_modes (27):
set_modes (28):
set_modes (29):
end_of_mode:
	end;

	if mcl.line_len ^= -1
	then tcb.colmax = mcl.line_len;
	if mcl.page_len ^= -1
	then do;
	     tcb.linemax = mcl.page_len;
	     wtcb.count_lines = (mcl.page_len ^= 0);
	end;
	if mcl.can_type ^= -1
	then tcb.can_type = mcl.can_type;


/* build string of old modes to return */

build_old_modes:
	temp_modes = "";
	call append_ll (saved_ll);
	call append_pl (saved_pl);
	call append_can_type (saved_can_type);

	do i = 1 to n_modes;
	     call append_mode ((modestr (i)), substr (saved_modes, i, 1));
	end;

	if saved_mpx_modes ^= ""
	then temp_modes = temp_modes || "," || rtrim (saved_mpx_modes);
	temp_modes = temp_modes || ".";

	modes_info.str = temp_modes;
	if length (temp_modes) > modes_info.len
	then do;					/* doesn't fit: truncate to last complete mode */
	     idx = modes_info.len - index (reverse (modes_info.str), ",") + 1;
	     if (idx = modes_info.len + 1)
	     then modes_info.str = "";		/* not even the first mode fits */
	     else substr (modes_info.str, idx) = ".";	/* truncate mode string at last comma */
	     pm_code = error_table_$smallarg;
	end;

	return;



bad_format:
	pm_code = error_table_$improper_data_format;
	return;

bad_mode:
	pm_code = error_table_$bad_mode;
	if sw
	then modes_info.str = mode_name;
	else modes_info.str = "^" || mode_name;
	return;

mcl_error:
	pm_code = error_table_$bad_mode;
	temp_modes = "";
	if mcl.flags.ll_error
	then call append_ll (mcl.line_len);
	if mcl.flags.pl_error
	then call append_pl (mcl.page_len);
	if mcl.flags.can_type_error
	then call append_can_type (mcl.can_type);
	do i = 1 to mcl.n_entries;
	     mclep = addr (mcl.entries (i));
	     if mcle.error
	     then call append_mode (mcle.mode_name, mcle.mode_switch);
	end;
	modes_info.str = temp_modes;
	return;

error_exit:
	return;

/* subroutine to add an entry to the mode change list */

add_mode_change:
     proc;

dcl  i fixed bin;

/* avoid duplicate entries for the same mode */

	do i = 1 to mclx while (mcl.entries (i).mode_name ^= mode_name);
	end;
	if i > mclx				/* not a repeat */
	then do;
	     mclx = i;
	     if mclx > hbound (modes_change_list.entries, 1)
	     then do;
		pm_code = error_table_$bigarg;
		go to error_exit;
	     end;
	end;

	mclep = addr (mcl.entries (i));
	if mclx = i				/* first time for this mode */
	then do;
	     mcle.mode_name = mode_name;
	     string (mcle.flags) = ""b;
	end;
	mcle.mode_switch = sw;
	mcle.force = force_sw;

     end;



/* subroutine to get multiplexer modes */

get_mpx_modes:
     proc;

	call channel_manager$get_modes ((wtcb.devx), saved_mpx_modes, code);
	if code ^= 0
	then do;
	     pm_code = code;
	     go to error_exit;
	end;

     end;

/* subroutine to convert from chars to fixed bin */

convert_len:
     proc returns (fixed bin);

dcl  len fixed bin;
dcl  size condition;

	if ^sw
	then do;
	     if length (mode_name) > 2
	     then go to bad_mode;
	     return (0);
	end;

	if length (mode_name) < 3
	then go to bad_mode;
	if verify (substr (mode_name, 3), "0123456789") ^= 0
	then go to bad_mode;

	on size go to bad_mode;
	len = bin (substr (mode_name, 3), 17);
	revert size;
	if len ^= 0
	then if len < 5 | len > 255
	     then go to bad_mode;

	return (len);
     end;



/* subroutine to append mode to mode string */

append_mode:
     proc (name, switch);

dcl  name char (*);
dcl  switch bit (1);

	if length (temp_modes) > 0
	then temp_modes = temp_modes || ",";
	if ^switch
	then temp_modes = temp_modes || "^";
	temp_modes = temp_modes || rtrim (name);

	return;
     end;



/* subroutine to append can_type mode to mode string */

append_can_type:
     procedure (P_can_type);

dcl  P_can_type fixed binary parameter;

	if length (temp_modes) > 0
	then temp_modes = temp_modes || ",";

	if (P_can_type < lbound (CAN_TYPE_NAMES, 1)) | (P_can_type > hbound (CAN_TYPE_NAMES, 1))
	then temp_modes = temp_modes || rtrim (CAN_TYPE_NAMES (lbound (CAN_TYPE_NAMES, 1)));
	else temp_modes = temp_modes || rtrim (CAN_TYPE_NAMES (P_can_type));

	return;

     end append_can_type;

/* subroutine to append line length to mode string */

append_ll:
     proc (ll);

dcl  ll fixed bin;
dcl  pic999 picture "999";

	if length (temp_modes) > 0
	then temp_modes = temp_modes || ",";
	if ll = 0
	then temp_modes = temp_modes || "^ll";
	else do;
	     pic999 = ll;
	     temp_modes = temp_modes || "ll" || ltrim (pic999, "0");
	end;

     end;



/* subroutine to append page length to mode string */

append_pl:
     proc (pl);

dcl  pl fixed bin;
dcl  pic999 picture "999";

	if length (temp_modes) > 0
	then temp_modes = temp_modes || ",";
	if pl = 0
	then temp_modes = temp_modes || "^pl";
	else do;
	     pic999 = pl;
	     temp_modes = temp_modes || "pl" || ltrim (pic999, "0");
	end;
     end;


     end;




		    tty_overstrike_canon.pl1        11/11/89  1109.0r w 11/11/89  0826.9       79236



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */



/* Overstriking canonicalization (can_type=overstrike):  This procedure takes a line of ASCII characters as input, and
   replaces it with a canonical version of the same line.  It sorts characters by column position, and by ASCII value
   within column position, ensuring that kill and erase characters come out last in their respective column positions.
   NUL (\000) characters are discarded; columns overstruck with an erase character are likewise deleted */

/* Modified: 19 September 1980 by G. Palter as part of fix to MCS bug #203 */
/* Modified: 11 November 1980 by G. Palter to rename to tty_overstrike_canon */


tty_overstrike_canon:
     procedure (a_ptr, a_len, a_max_len, a_erase, a_kill, code);


	/* PARAMETERS */

dcl  a_ptr ptr;					/* pointer to string to be canonicalized */
dcl  a_len fixed bin;				/* current length of string (INPUT/OUTPUT) */
dcl  a_max_len fixed bin;				/* maximum allowable length of string */
dcl  a_erase char (1) aligned;			/* erase character */
dcl  a_kill char (1) aligned;				/* kill character */
dcl  code fixed bin (35);				/* status code (OUTPUT) */


	/* AUTOMATIC */

dcl  stringp ptr;					/* local copy of a_ptr */
dcl  stringl fixed bin;				/*   "     "   " a_len */
dcl  max_len fixed bin;				/*   "     "   " a_max_len */
dcl  erase_char char (1);				/*   "     "   " a_erase */
dcl  kill_char char (1);				/*   "     "   " a_kill */

dcl  start_col fixed bin;				/* left margin column no. */
dcl  current_col fixed bin;
dcl  next_col fixed bin;
dcl  char_x fixed bin;				/* index into character string */
dcl  last_x fixed bin;
dcl  col_x fixed bin;				/* index into column_array */

dcl  current_char char (1);
dcl  n_items fixed bin;
dcl  temp fixed bin;
dcl  i fixed bin;
dcl  end_of_tab fixed bin;				/* column position of next tab stop */

dcl 1 column_array (a_max_len) aligned,			/* temporary storage for sorting by column */
      2 column fixed bin (17) unal,
      2 flags unal,
        3 erase bit (1) unal,
        3 kill bit (1) unal,
        3 vertical bit (1) unal,			/* character involves vertical paper motion */
        3 pad bit (5) unal,
        3 not_tab bit (1) unal,			/* on for all characters EXCEPT horizontal tab */
      2 char char (1) unal;


	/* INTERNAL STATIC CONSTANTS */

dcl  nul_char char (1) int static aligned init ("");	/* NUL */
dcl  cr char (1) int static aligned init		/* carriage return */
		("");

dcl  bs char (1) int static aligned init ("");		/* backspace */
dcl  ht char (1) int static aligned init ("	");	/* horizontal tab */
dcl  nl char (1) int static aligned init ("
");
						/* newline */
dcl  vt char (1) int static aligned init			/* vertical tab */
		("");
dcl  ff char (1) int static aligned init		/* form-feed */
		("");
dcl  sp char (1) int static aligned init (" ");

dcl  HTSP character (2) static options (constant) initial ("	 "); /* horizontal tab and space */

dcl  biggest_num fixed bin int static aligned init (131071);


	/* BASED */

dcl  based_string char (stringl) based (stringp);
dcl  items (10) based (addr(column_array));		/* overlay for column_array used in sorting */


	/* EXTERNAL STATIC */

dcl  error_table_$long_record ext static aligned fixed bin (35);


	/* BUILTINS */

dcl  (addr, length, max, mod, rtrim, string, substr) builtin;

/**/
	start_col, current_col = 0;
	stringp = a_ptr;
	stringl = a_len;
	max_len = a_max_len;
	erase_char = a_erase;
	kill_char = a_kill;

	col_x = 1;

	do char_x = 1 to stringl;			/* examine all input characters */
	     string (column_array (col_x).flags) = "000000001"b; /* turn on not_tab, other flags off */
	     current_char = substr (stringp -> based_string, char_x, 1);

	     if current_char = cr			/* carriage return, just reset column */
	     then current_col = start_col;

	     else
	     if current_char = bs
	     then current_col = max (start_col, current_col - 1);	/* back up one for backspace */

	     else
	     if current_char = sp
	     then current_col = current_col + 1;

	     else
	     if current_char = nul_char
	     then;

	     /* other characters will be stored */

	     else do;
		if current_char = nl		/* newline */
		then do;
		     column_array (col_x).column = biggest_num; /* make sure it sorts to end */
		     column_array (col_x).vertical = "1"b;
		end;

		else
		if current_char = vt |
		   current_char = ff
		then do;
		     current_col,
		     start_col = start_col + 1000;
		     column_array (col_x).column = start_col - 1;
		     column_array (col_x).vertical = "1"b;
		end;

		else do;
		     column_array (col_x).column = current_col; /* graphic goes in next column */
		     if current_char = ht		/* horizontal tab */
		     then do;
			column_array (col_x).not_tab = "0"b;
			current_col = current_col + 10 - mod (current_col, 10); /* advance to next tab stop */
		     end;

		     else do;
			if current_char >= sp	/* if not control char */
			then current_col = current_col + 1; /* ordinary graphic, advances column by 1 */
			if current_char = erase_char
			then column_array (col_x).erase = "1"b;

			else if current_char = kill_char
			then column_array (col_x).kill = "1"b;
		     end;
		end;

		column_array (col_x).char = current_char;
		col_x = col_x + 1;
	     end;
	end;

	/* now sort */

	n_items = col_x - 1;			/* we incremented an extra time at the end */

	/* we will use dumb kind of sort, since columns will usually be mostly in order */

	do col_x = 1 to n_items - 1;
	     if items (col_x) > items (col_x+1)		/* out of order */
	     then do;
		temp = items (col_x+1);		/* save item we're moving */
		do i = col_x to 1 by -1 while (items (i) > temp); /* find its place */
		     items (i+1) = items (i);		/* move everyone else over */
		end;

		items (i+1) = temp;
	     end;
	end;

	/* now put characters back in string in right order */

	char_x = 1;
	current_col = 0;

	do col_x = 1 to n_items;
	     next_col = column_array (col_x).column;	/* place where next graphic goes */

	     do while (current_col < next_col);		/* insert spaces if needed */
		if column_array (col_x).vertical
		then do;
		     current_col = next_col;
		     char_x = length (rtrim (substr (based_string, 1, char_x-1), HTSP)) + 1;
		end;				/* remove trailing whitepsace from just completed line */

		else do;
		     call insert_char (sp);
		     current_col = current_col + 1;
		end;
	     end;

	     last_x = char_x;			/* place to back up to in case of erase */

	     if ^column_array (col_x).not_tab		/* horizontal tab */
	     then do;
		end_of_tab = current_col + 10 - mod (current_col, 10);
		if col_x < n_items			/* if there are characters after it */
		then if column_array (col_x+1).column >= end_of_tab /* and tab is not overwritten */
		     then do;
			call insert_char (ht);
			current_col = end_of_tab;
		     end;

		     /* otherwise next time around will insert spaces if needed */

	     end;

	     else do;				/* not tab */

		call insert_char ((column_array (col_x).char));

		do while (column_array (col_x+1).column = current_col & col_x < n_items);
		     col_x = col_x + 1;
		     if column_array (col_x).erase	/* column position is erased */
		     then char_x = last_x;		/* pretend it never happened */

		     else do;
			if column_array (col_x).char ^= substr (based_string, char_x-1, 1)
			then do;			/* don't store multiple instances of same graphic */
			     call insert_char (bs);
			     call insert_char ((column_array (col_x).char));
			end;
		     end;
		end;

		current_col = current_col + 1;	/* finished with that column position */
	     end;
	end;

	/* all done */

	a_len = char_x - 1;				/* we incremented after every insertion */
	code = 0;
	return;


blew_it:						/* we come here if we overflowed max_len */
	code = error_table_$long_record;
	return;
/**/
insert_char:	proc (a_char);

/* this procedure inserts a character into the final string and updates the index into the string */
/* it checks to make sure we don't overflow */

dcl  a_char char (1) aligned;

	if char_x > max_len
	then go to blew_it;

	substr (based_string, char_x, 1) = a_char;
	char_x = char_x + 1;
	return;

	end insert_char;

     end tty_overstrike_canon;




		    tty_read.pl1                    11/11/89  1109.0r w 11/11/89  0826.9      496008



/****^  ***********************************************************
        *                                                         *
        * 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(88-06-20,Berno), approve(88-07-13,MCR7928),
     audit(88-06-20,Parisek), install(88-07-19,MR12.2-1061):
     Removed reference to wtcb.prompt_len and "enter_receive" order call as
     part of the UNCP multiplexer (DSA gateway) implementation.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,^ifthendo */
tty_read:
     proc (twx, a_readp, a_offset, a_nelem, a_nelemt, state, ercode);
						/* to convert from read chain */

/* Read portion of the ring 0 ttydim
   Rewritten by Robert S. Coren, 2/12/76
   Modified 04/22/77 by J. Stern to introduce TCBs and WTCBs
   Modified 12/29/77 by Robert Coren to use tty_space_man
   Modified 05/05/78 by Robert Coren to add get_line entry
   Modified August 78 by J. Nicholls to use channel_manager$ to get data to process for multiplexer implementation
   Modified June 29 1979 by B. Greenberg for Multiplexer-Echo Negotiation.
   Modified 18 September 1980 by G. Palter to fix MCS bug #203
   Modified: 11 November 1980 by G. Palter to support can_type mode
   Modified February 1981 by Robert Coren to add read_with_mark entry
   Modified May 1981 by J. Bongiovanni for response time metering
   Modified May 1981 by Robert Coren to make sure fblock and lblock always consistent
   Modified 19 March 1982 by W. York to add tty_read_echoed entry as replacement
   for echo_negotiate_get_chars, and fix bug in mark handling in
   procedure get_more_data.
   Modified November 1982 by Robert Coren to return wtcb.error_code.
   Report on June 83 - modifications for the Datanet 7100.fd
   Date of the last modification 04/17/84 */

/* PARAMETERS */

dcl  twx fixed bin;					/* device index */
dcl  a_readp ptr;					/* pointer to caller's buffer */
dcl  a_offset fixed bin (24);				/* offset in buffer to start at */
dcl  a_buffer char (*);				/* caller's buffer (used by read_with_mark entry) */
dcl  a_nelem fixed bin (24);				/* maximum number of chars to return */
dcl  a_nelemt fixed bin (24);				/* actual number of characters returned */
						/* (OUTPUT) */
dcl  a_screen_left fixed bin;				/* Space left on line, negotiate entry */
dcl  a_echoed fixed bin (24);				/* Chars echoed by interrupt side */
						/* (OUTPUT) */
dcl  nl_found bit (1);				/* whether get_line found newline (OUTPUT) */
dcl  a_mark_index fixed bin (21);			/* index in returned string of "mark" (OUTPUT) */
dcl  state fixed bin;				/* current state of channel (OUTPUT) */
dcl  ercode fixed bin (35);				/* status code (OUTPUT) */


/* AUTOMATIC */

dcl  devx fixed bin;				/* local copy of twx */
dcl  output_ptr ptr;				/*  "      "   " readp */
dcl  offset fixed bin (24);				/*  "      "   " a_offset */
dcl  nelem fixed bin (24);				/*  "      "   " a_nelem */
dcl  nelemt fixed bin (24);				/*  "      "   " a_nelemt */
dcl  echoed fixed bin (24);				/*  "      "   " a_echoed */
dcl  screen_left fixed bin;				/*  "      "   " a_screen_left */

dcl  ttytp ptr;					/* pointer to tty_tables segment */
dcl  special_ptr ptr;
dcl  mvtp ptr;
dcl  tctp ptr;
dcl  get_line_entry bit (1);				/* "1"b if get_line entry called, otherwise "0"b */
dcl  negotiate_entry bit (1);				/* "1"b if negotiate entry called, otherwise "0"b */
dcl  obsolete_negotiate_entry bit (1);			/* "1"b if echo_negotaite_get_chars, otherwise tty_read_echoed */
dcl  mark_entry bit (1);				/* "1"b if read_with_mark entry called, otherwise "0"b */
dcl  break_found bit (1);
dcl  convert bit (1);				/* used to indicate copying from converted buffers */
dcl  throw_away bit (1);				/* indicates last char was hardware esc */
dcl  have_more_data bit (1) aligned;			/* lower level mux has another buffer chain he didnt give us this time */
dcl  unconverted_break bit (1);
dcl  no_break_anywhere bit (1);			/* no break anywhere in current input chain */
dcl  orig_output_ptr ptr;				/* first set value of output_ptr */
dcl  source_ptr ptr;
dcl  target_ptr ptr;
dcl  old_sourcep ptr;
dcl  old_targetp ptr;
dcl  source_len fixed bin;
dcl  target_len fixed bin;

dcl  new_blockp ptr;
dcl  data_ptr ptr;
dcl  new_block fixed bin (18);
dcl  room_left fixed bin;
dcl  first_char fixed bin;
dcl  old_fblock fixed bin (18);
dcl  last_block fixed bin (18);
dcl  new_tally fixed bin;
dcl  temp_buf char (60) aligned;			/* automatic copy of data from tty buffer */
dcl  orig_fchar fixed bin;
dcl  mark_index fixed bin;
dcl  pmark_index fixed bin;				/* mark index used for preconverted input */

dcl  time_spent fixed bin (71);
dcl  start_time fixed bin (71);			/* clock time at entry */
dcl  max_len fixed bin;
dcl  break char (1);				/* break character from device_defaults */
dcl  chars_in_buf fixed bin;
dcl  next_break fixed bin;

dcl  xr fixed bin;					/* used for result of index builtin */
dcl  can_called bit (1);				/* indicates whether canon_procedure called */
dcl  canon_procedure variable
	entry (pointer, fixed binary, fixed binary, character (1) aligned, character (1) aligned, fixed binary (35));
dcl  code fixed bin (35);

dcl  tempp ptr;

dcl  kill_char char (1) aligned;
dcl  erase_char char (1) aligned;
dcl  bx fixed bin;					/* used in verify of white space */
dcl  i fixed bin;					/* temporary work variable */
dcl  next_char char (1) aligned;
dcl  uncp_flag bit (1);				/* designate UNCP mpx */

dcl  1 octal aligned,
       2 pad bit (27) unal,
       2 result fixed bin (8) unal;			/* so arithmetic value can be easily addressed as char */

dcl  1 echo_start_data aligned,
       2 ctr fixed bin (35),
       2 screenleft fixed bin (35);

dcl  digit fixed bin;
dcl  rawcnt fixed bin;
dcl  old_rawcnt fixed bin;
dcl  raw_mode bit (1);

dcl  1 util aligned,				/* structure passed to tty_util_$tct */
						/* first 3 items in this structure are */
						/* also used as general automatic variables */
       2 stringp ptr,
       2 stringl fixed bin,
       2 ctally fixed bin,
       2 tablep ptr,
       2 indicator fixed bin,
       2 pad (3) fixed bin;				/* workspace for tty_util_ */

dcl  buffer_1 char (720) aligned;
dcl  buffer_2 char (720) aligned;

/* INTERNAL STATIC CONSTANTS */

dcl  crash fixed bin int static options (constant) init (1);/* for crashing system with syserr */
dcl  BSIZE fixed bin int static options (constant) init (16);
						/* word size for preconverted buffers */
dcl  BREAK_CHAR fixed bin int static options (constant) init (1);
dcl  ESCAPE_CHAR fixed bin int static options (constant) init (2);
dcl  THROW_AWAY fixed bin int static options (constant) init (3);
dcl  FORM_FEED fixed bin int static options (constant) init (4);
dcl  HARDWARE_CONTROL fixed bin int static options (constant) init (5);
dcl  DIALED_UP fixed bin int static options (constant) init (5);

/* various strange-looking character strings */

dcl  left_motion char (2) aligned int static options (constant) init ("");
						/* BS, CR */

dcl  right_motion char (2) aligned int static options (constant) init ("	 ");
						/* HT, SP */

dcl  vertical_motion char (2) aligned int static options (constant) init
						/* FF, VT */
	("");

dcl  all_white char (6) aligned int static options (constant) init
						/* NUL, BS, HT, NL, CR, SP */
	("	
 ");

dcl  nl char (1) aligned int static options (constant) init ("
");						/* NL */

dcl  bs char (1) aligned int static options (constant) init ("");
						/* BS */

dcl  nul_char char (1) aligned int static options (constant) init ("");
						/* NUL */

dcl  no_control_input (16) bit (1) int static options (constant) init ("0"b, (2) (1)"1"b, (13) (1)"0"b);

dcl  nocontrol (128) bit (9) int static options (constant)
	init ("000"b3, "000"b3, "000"b3, "000"b3, "000"b3, "000"b3, "000"b3, "000"b3, "010"b3, "011"b3, "012"b3,
	"013"b3, "014"b3, "015"b3, "000"b3, "000"b3, "000"b3, "000"b3, "000"b3, "000"b3, "000"b3, "000"b3, "000"b3,
	"000"b3, "000"b3, "000"b3, "000"b3, "033"b3, "000"b3, "000"b3, "000"b3, "000"b3, "040"b3, "041"b3, "042"b3,
	"043"b3, "044"b3, "045"b3, "046"b3, "047"b3, "050"b3, "051"b3, "052"b3, "053"b3, "054"b3, "055"b3, "056"b3,
	"057"b3, "060"b3, "061"b3, "062"b3, "063"b3, "064"b3, "065"b3, "066"b3, "067"b3, "070"b3, "071"b3, "072"b3,
	"073"b3, "074"b3, "075"b3, "076"b3, "077"b3, "100"b3, "101"b3, "102"b3, "103"b3, "104"b3, "105"b3, "106"b3,
	"107"b3, "110"b3, "111"b3, "112"b3, "113"b3, "114"b3, "115"b3, "116"b3, "117"b3, "120"b3, "121"b3, "122"b3,
	"123"b3, "124"b3, "125"b3, "126"b3, "127"b3, "130"b3, "131"b3, "132"b3, "133"b3, "134"b3, "135"b3, "136"b3,
	"137"b3, "140"b3, "141"b3, "142"b3, "143"b3, "144"b3, "145"b3, "146"b3, "147"b3, "150"b3, "151"b3, "152"b3,
	"153"b3, "154"b3, "155"b3, "156"b3, "157"b3, "160"b3, "161"b3, "162"b3, "163"b3, "164"b3, "165"b3, "166"b3,
	"167"b3, "170"b3, "171"b3, "172"b3, "173"b3, "174"b3, "175"b3, "176"b3, "000"b3);


/* ENTRIES */

dcl  meter_response_time entry (bit (36) aligned, fixed bin),
     syserr ext entry options (variable),
     tty_lock$lock_channel entry (fixed bin, fixed bin (35)),
     tty_lock$unlock_channel entry (fixed bin);

dcl  tty_index$initialize_tcb entry (ptr, ptr);
dcl  tty_util_$mvt entry (ptr);
dcl  tty_util_$tct entry (ptr);
dcl  tty_overstrike_canon
	entry (pointer, fixed binary, fixed binary, character (1) aligned, character (1) aligned, fixed binary (35));
dcl  tty_replace_canon
	entry (pointer, fixed binary, fixed binary, character (1) aligned, character (1) aligned, fixed binary (35));
dcl  tty_write$locked entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35));


/* EXTERNAL STATIC */

dcl  tty_tables$ ext static;
dcl  error_table_$invalid_write ext static fixed bin (35);
dcl  error_table_$badcall ext static fixed bin (35);
dcl  error_table_$improper_data_format ext static fixed bin (35);
dcl  error_table_$io_no_permission ext static fixed bin (35);
dcl  error_table_$invalid_device ext static fixed bin (35);
dcl  error_table_$line_status_pending ext static fixed bin (35);
dcl  error_table_$echnego_awaiting_stop_sync ext static fixed bin (35);
dcl  error_table_$no_table ext static fixed bin (35);
dcl  pds$processid ext static bit (36) aligned;


/* BASED */

dcl  based_buf char (60) based;
dcl  based_chars (0:10) char (1) unal based;
dcl  based_one_char char (1) unal based;
dcl  based_string char (stringl) based (stringp);
dcl  based_source char (source_len) based (old_sourcep);
dcl  based_target char (target_len) based (old_targetp);
dcl  table (0:127) fixed bin (8) unaligned based;


dcl  1 mvt_args aligned based (addr (util)),		/* overlay of util structure for tty_util_$mvt */
       2 stringptr ptr,
       2 stringlen fixed bin,
       2 pad fixed bin,
       2 tablep ptr,
       2 targetp ptr;

/* BUILTINS */

dcl  (addr, bin, clock, divide, fixed, index, length, min, null, ptr, rank, rel, reverse, search, substr, verify) builtin;

dcl  cleanup condition;				/*						*/
%include tty_convert;
/**/
%include tty_buf;

%include tty_buffer_block;

%include wtcb;

%include tcb;

%include tty_can_types;

%include lct;

%include tty_space_man_dcls;

%include channel_manager_dcls;

%include mcs_echo_neg_sys;

%include response_transitions;

%include multiplexer_types;
/**/
	get_line_entry = "0"b;			/* regular entry */
	negotiate_entry = "0"b;
	go to join;


tty_get_line:
     entry (twx, a_readp, a_offset, a_nelem, a_nelemt, nl_found, state, ercode);

	get_line_entry = "1"b;
	negotiate_entry = "0"b;
	go to join;

tty_read_with_mark:
     entry (twx, a_buffer, a_nelemt, a_mark_index, state, ercode);

	negotiate_entry, get_line_entry = "0"b;
	output_ptr = addr (a_buffer);
	nelem = length (a_buffer);
	mark_entry = "1"b;
	mark_index = 0;
	go to mark_join;


/* new entrpoint to return proper code in awaiting_stop_sync case */
tty_read_echoed:
     entry (twx, a_readp, a_offset, a_nelem, a_nelemt, a_echoed, a_screen_left, state, ercode);

	get_line_entry = "0"b;
	negotiate_entry = "1"b;
	obsolete_negotiate_entry = "0"b;
	screen_left = a_screen_left;
	echoed = 0;
	goto join;

/* obsolete entry left in to allow time for switchover */
echo_negotiate_get_chars:
     entry (twx, a_readp, a_offset, a_nelem, a_nelemt, a_echoed, a_screen_left, state, ercode);

	get_line_entry = "0"b;
	negotiate_entry = "1"b;
	obsolete_negotiate_entry = "1"b;
	screen_left = a_screen_left;
	echoed = 0;
	goto join;

join:
	mark_entry = "0"b;
	output_ptr = a_readp;
	nelem = a_nelem;
mark_join:
	start_time = clock ();
	ttybp = addr (tty_buf$);			/* get ptrs to tty_buf, tty_data */
	call meter_response_time (pds$processid, CALL_RING_0_TTY);

	devx = twx;				/* copy device index */
	lctp = tty_buf.lct_ptr;			/* init pointer to lct */
	if devx < 1 | devx > lct.max_no_lctes
	then do;
	     ercode = error_table_$invalid_device;
	     call clean_up;
	     return;
	end;

	uncp_flag = is_parent_mpx (UNCP_MPX);

	call tty_lock$lock_channel (devx, ercode);	/* lock the channel lock */
	if ercode ^= 0
	then do;
	     call clean_up;
	     return;
	end;

	on cleanup call tty_lock$unlock_channel (devx);
	lctep = addr (lct.lcte_array (devx));		/* get pointer to lcte of interest */
	if lcte.channel_type ^= 0			/* don't talk to strangers */
	then go to no_permission;
	wtcbp = lcte.data_base_ptr;			/* get pointers to control blocks */
	if ^wtcb.flags.dialed			/* if not dialed up */
	then do;
no_permission:
	     call tty_lock$unlock_channel (devx);	/* unlock channel lock */
	     ercode = error_table_$io_no_permission;
	     call clean_up;
	     return;
	end;
	state = DIALED_UP;

	tcbp = wtcb.tcb_ptr;
	if ^wtcb.tcb_initialized
	then call tty_index$initialize_tcb (wtcbp, tcbp);

	if wtcb.hproc ^= pds$processid		/* if not boss */
	then if (wtcb.uproc ^= pds$processid) | ^tcb.uproc_attached
						/* if not user */
	     then do;
		call tty_lock$unlock_channel (devx);	/* unlock channel lock */
		call clean_up;
		ercode = error_table_$io_no_permission;
		return;
	     end;

	if wtcb.flags.line_status_present
	then do;
	     call clean_up;
	     ercode = error_table_$line_status_pending;
	     call tty_lock$unlock_channel (devx);
	     return;
	end;

	if wtcb.error_code ^= 0
	then do;
	     ercode = wtcb.error_code;
	     wtcb.error_code = 0;
	     call tty_lock$unlock_channel (devx);
	     return;
	end;


/**/
	tcb.cumulative_meters.read_calls = tcb.cumulative_meters.read_calls + 1;
	tty_buf.read_calls = tty_buf.read_calls + 1;
	nelemt = 0;
	if negotiate_entry
	then do;
	     if wtcb.echdp = "000000"b3
	     then do;				/* Can't negotiate with no table! */
		ercode = error_table_$no_table;
		go to all_done;
	     end;
	     echo_datap = ptr (ttybp, wtcb.echdp);
	     if screen_left = 0			/* Force stop echo magic */
		& (wtcb.negotiating_echo | echo_data.awaiting_start_sync)
	     then do;

		echo_data.echo_start_pending_sndopt = "0"b;
		if ^echo_data.awaiting_stop_sync
		then do;
		     call channel_manager$control (devx, "stop_negotiated_echo", null (), code);
		     if code = 0
		     then echo_data.awaiting_stop_sync = "1"b;
		     else wtcb.negotiating_echo = "0"b;
		end;
		if echo_data.awaiting_stop_sync
		then do;
		     call tty_lock$unlock_channel (devx);
		     call clean_up;
		     a_echoed = 0;
		     ercode = error_table_$echnego_awaiting_stop_sync;

/* echo_negotiate_get_chars returns the wrong error code in this case
   and must continue to do so for compatability for at least one release,
   at which point the entry and this code can be flushed and everyone
   will have switched to using tty_read_echoed */
		     if obsolete_negotiate_entry
		     then ercode = error_table_$line_status_pending;

		     return;
		end;
	     end;
	end;
	if nelem = 0
	then do;
	     if ^negotiate_entry
	     then wtcb.negotiating_echo = "0"b;

/* Magic kludge to turn off echoing on ring-4 detected break conditions */
/* This is "clean" because all non-negotiating calls are supposed to turn it off. */

	     ercode = 0;
	     go to all_done;
	end;

	if ^mark_entry
	then offset = a_offset;
	else offset = 0;
	target_len = 0;
	rawcnt = 0;
	have_more_data = "0"b;
	if offset ^= 0
	then output_ptr = addr (output_ptr -> based_chars (offset));
	orig_output_ptr = output_ptr;			/* in case we need this later */

	if ^tcb.rawim
	then do;
	     if mark_entry				/* only supposed to be called in rawi */
	     then do;
		ercode = error_table_$badcall;
		go to all_done;
	     end;

	     ttytp = addr (tty_tables$);
	     if tcb.input_mvtrp = ""b
	     then mvtp = null;
	     else mvtp = ptr (ttytp, tcb.input_mvtrp);
	     if tcb.input_tctrp = ""b
	     then tctp = null;
	     else tctp = ptr (ttytp, tcb.input_tctrp);
	     if tcb.specialrp = ""b
	     then special_ptr = null;
	     else special_ptr = ptr (ttytp, tcb.specialrp);
	end;

	if wtcb.fblock = 0
	then do;					/* go get some data to process */
	     call get_more_data (blockp);		/* find more input_data */
	     if ercode ^= 0
	     then go to all_done;			/* if problem get out */
	end;
	else blockp = ptr (ttybp, wtcb.fblock);		/* get pointer to buffer left from last time */
						/*						*/
	if wtcb.fblock ^= 0
	then do;					/* yes, process it */
	     target_ptr = output_ptr;

	     if tcb.rawim				/* raw input mode */
	     then do;				/* just copy data */
		break_found = "0"b;			/* we'll need this if get_line called */
		do while (wtcb.fblock ^= 0 & nelemt < nelem & ^break_found);

		     source_ptr = addr (buffer.chars (wtcb.fchar));
		     ctally = min (buffer.tally - wtcb.fchar, nelem - nelemt);
		     if get_line_entry		/* want to stop at NL */
		     then do;
			next_break = index (substr (source_ptr -> based_buf, 1, ctally), wtcb.line_delimiter);
			if next_break ^= 0		/* there is one in this buffer */
			then do;
			     ctally = next_break;	/* stop at it */
			     break_found = "1"b;	/* and don't go around again */
			end;
		     end;

		     if mark_entry
		     then if buffer.mark
			then mark_index = target_len + 1;

		     call copy_chars;

		     nelemt = target_len;

		     if ctally < buffer.tally - wtcb.fchar
						/* if this is last buffer we're copying */
		     then do;
			wtcb.fchar = wtcb.fchar + ctally;
			buffer.mark = "0"b;		/* we've picked up the mark */
		     end;

		     else do;
			wtcb.fchar = 0;		/* not in the middle of a buffer now */
			new_block = buffer.next;

			call tty_space_man$free_buffer (devx, INPUT, blockp);
						/* free buffer just copied from */

			wtcb.fblock = new_block;	/* next buffer (if any) is now head of chain */
			blockp = ptr (ttybp, new_block);
			if (new_block = 0 & wtcb.input_available)
			then do;			/* see if more to do, finished with this chain */
			     call get_more_data (blockp);
						/* go try to get a buffer */
			     if ercode ^= 0
			     then go to all_done;	/* if problem get out */
			end;
		     end;
		end;

		rawcnt = nelemt;			/* that's how many we really picked up */
	     end;					/*						*/
	     else do;				/* not raw input */
		if tcb.erklm
		then do;				/* make local copies of erase and kill characters */
		     erase_char = tcb.erase;
		     kill_char = tcb.kill;
		end;
		else erase_char, kill_char = " ";	/* so canon_procedure won't see erases & kills */

		if (tcb.can_type = CAN_TYPE_OVERSTRIKE)
		then canon_procedure = tty_overstrike_canon;
		else if (tcb.can_type = CAN_TYPE_REPLACE)
		then canon_procedure = tty_replace_canon;
		else canon_procedure = tty_overstrike_canon;
						/* can't happen, but just in case */

		call pickup_preconverted;

		nelemt = target_len;		/* total returned so far */
		throw_away = "0"b;

/* CONVERSION STARTS HERE */
/* if there's any to do */

		if wtcb.fblock = 0
		then do;				/* finished with preconvertedand no none converted pending */
		     call get_more_data (blockp);	/* try to get a buffer */
		     if ercode ^= 0
		     then go to all_done;		/* if error get out */
		end;
		max_len = 1;			/* init so loop starts */
		do while ((^break_found | ^get_line_entry) & nelemt < nelem & wtcb.fblock ^= 0 & max_len > 0);
		     old_rawcnt = rawcnt;		/* in case we have to do retry */
		     break = wtcb.line_delimiter;	/* this is untranslated break, which we will search for */
		     output_ptr = target_ptr;		/* allows for possible already-converted chars */
		     max_len = length (buffer_1);
		     orig_fchar = wtcb.fchar;		/* so we can restore this */

/* come here if canon_procedure overflows */
retry:
		     if max_len > 0
		     then do;			/* only continue if we have something to do it into */
			target_ptr = addr (buffer_1);
			room_left = max_len;
			target_len = 0;
			last_block = 0;
			wtcb.fchar = orig_fchar;	/* in case we started over */
			call copy_loop;
			if ^break_found & get_line_entry & room_left > 0
			then do;			/* there's no break anywhere in chain */
			     no_break_anywhere = "1"b;
			     wtcb.fchar = orig_fchar; /* copy_loop might have changed this */
			     go to no_line;		/* get out of conversion loop */
			end;

			no_break_anywhere = "0"b;
			call translation;

/* ** CANONICALIZATION ** */

			can_called = "0"b;
			if tcb.canm
			then do;
			     call canonicalization;
			     if code ^= 0		/* overflowed the space */
			     then do;		/* have to start again */
				max_len = divide (2 * max_len, 3, 17, 0);
				if max_len > 0
				then do;
				     blockp = ptr (ttybp, wtcb.fblock);
				     rawcnt = old_rawcnt;
				     break_found = "0"b;
						/* start clean */
				     tty_buf.input_restart = tty_buf.input_restart + 1;
				     go to retry;
				end;
			     end;
			end;
		     end;

/* ** FREE BUFFERS NOW ** */

		     if last_block ^= 0		/* if there are any to free */
		     then do;			/* this was the first chance we had to release some buffer space in the buffer */
			tempp = ptr (ttybp, last_block);
						/* point to last one */
			tempp -> buffer.next = 0;	/* cut off chain here */
			call tty_space_man$free_chain (devx, INPUT, ptr (ttybp, wtcb.fblock));
			wtcb.fblock = fixed (rel (blockp), 17);
		     end;

		     if (wtcb.fblock = 0 & wtcb.input_available)
		     then do;			/* see if more to do, finished with this chain */
			call get_more_data (blockp);	/* get the buffer of interest */
			if ercode ^= 0
			then go to all_done;
			wtcb.fchar = 0;		/* we can update this now too */
		     end;				/* we'll get back to this buffer after we finish the rest of the present buffer we have */

/* set up for rest of conversion */

		     source_len = stringl;
		     stringp = source_ptr;
		     target_len = 0;

/* if tty_canon wasn't called, we have to eliminate NULs by hand */

		     if ^can_called & (^tcb.control | no_control_input (wtcb.line_type))
		     then call strip_nulls;

/* ** ERASE/KILL PROCESSING ** */

		     if tcb.erklm
		     then call process_erase_kill;

/* ** ESCAPE AND BREAK PROCESSING ** */

		     if tctp ^= null		/* can't do this without input conversion table */
		     then call process_escape_break;

		     if target_len ^= 0
		     then do;
			source_ptr = old_targetp;
			source_len = target_len;
		     end;

		     target_len = nelemt;		/* number of characters in caller's buffer so far */
		     target_ptr = output_ptr;		/* place to put the rest */
		     ctally = min (nelem - nelemt, source_len);
						/* copy as many more as we can hold */
		     if ctally > 0
		     then call copy_chars;

		     nelemt = nelemt + source_len;

/* if we have to convert any more, we will now go back to top and copy some more */

		end;

/* we've converted all we're going to convert. Do we have any */
/* that wouldn't fit in caller's buffer? */

		if nelemt > nelem
		then do;				/* yes */

		     source_len = nelemt - nelem;
		     if mark_entry
		     then if mark_index > nelem	/* we didn't get up to the mark */
			then pmark_index = mark_index - nelem;
			else pmark_index = 0;
		     call copy_to_preconverted;
		end;

		else if (get_line_entry & ^break_found) /* don't have a complete line */
		then do;
no_line:
		     if target_len > 0		/* if there's anything at all */
		     then do;			/* search through buffers to see if he'll get a break sooner or later */
			if wtcb.fblock = 0 | no_break_anywhere
			then unconverted_break = "0"b;/* we know there aren't any breaks */
			else if tcb.break_char_pending
			then unconverted_break = "1"b;/* we dont have to search */

			else do;			/* scan buffer to see what we can find */
			     blockp = ptr (ttybp, wtcb.fblock);
			     next_break = 0;	/* init the "while" variable */

			     break = wtcb.line_delimiter;
						/* make sure it is set, may have fallen through to here */
			     do while (next_break = 0);
				source_ptr = addr (buffer.chars (wtcb.fchar));
				next_break =
				     index (substr (source_ptr -> based_buf, 1, buffer.tally - wtcb.fchar), break)
				     ;		/* look for break in next buffers */
				if next_break ^= 0
				then unconverted_break = "1"b;
						/* we found one */
				else if buffer.next = 0
				then do;		/* nothing else to look at so give up */
				     unconverted_break = "0"b;
				     next_break = 1;/* to break out of loop */
				end;

				else blockp = ptr (ttybp, buffer.next);
			     end;
			end;

			if /* tree */ unconverted_break
			then tcb.break_char_pending = "1"b;

			else if ^no_break_anywhere
			     then do;
				source_ptr = orig_output_ptr;
						/* we will save everything the caller would have gotten */
				source_len = target_len;
						/* this is the total in the caller's buffer */
				call copy_to_preconverted;
				nelemt = 0;	/* he will get nothing till we know for sure */
			     end;
		     end;
		end;
	     end;					/* whether rawi or not */
	end;					/* whether a read chain or not */

/* we always end up here */
/* if no read chain or no space we will ask for wakeup since
   nelemt will be 0 */

	nelemt = min (nelemt, nelem);
	if nelemt = 0
	then do;
	     if negotiate_entry
	     then do;				/* OK, flip on echoing. */
		echo_data.horiz_room_left = screen_left;/* Indicate room left. */
		echo_data.chars_echoed = 0;		/* Didn't echo anything */
		if screen_left = 0
		then wtcb.negotiating_echo = "0"b;
		else if tty_buf.echo_neg_mux_inhibit
		then wtcb.negotiating_echo = "1"b;
		else if wtcb.write_first ^= 0
		then do;
		     wtcb.negotiating_echo = "1"b;
		     if echo_data.synchronized
		     then echo_data.echo_start_pending_sndopt = "1"b;
		end;				/* If output sits in ring 0, only ring 0 can append logically to it, not mux. */
		else if echo_data.synchronized
		then do;				/* mux _d_o_e_s echnego */
		     wtcb.negotiating_echo = "1"b;	/* Tell tty_interrupt to echo. */
		     echo_start_data.ctr = echo_data.sync_ctr;
						/* Tell MUX to echo, */
						/* Sending counters as part of protocol game. */
		     echo_start_data.screenleft = echo_data.horiz_room_left;
		     call channel_manager$control (devx, "start_negotiated_echo", addr (echo_start_data), code);
		     if code = 0
		     then ;
		     else if code = error_table_$invalid_write
		     then echo_data.echo_start_pending_sndopt = "1"b;

/* This little bit of obscurity means that the mux had output queued in r0, */
/* and tty_interrupt is to try sending this again when a SEND_OUTPUT */
/* indicates that this is no longer the case. */
		end;
		else do;				/* Not synchronized */
		     call channel_manager$control (devx, "init_echo_negotiation", null (), code);
		     if code = 0
		     then do;
			echo_data.awaiting_start_sync = "1"b;
			echo_data.mux_will_echnego = "1"b;
		     end;
		     else wtcb.negotiating_echo = "1"b; /* Ring zero will do it */
		end;
		if wtcb.negotiating_echo
		then tty_buf.echo_neg_entries = tty_buf.echo_neg_entries + 1;
	     end;
	     else do;				/* Regular call turns off */
		if wtcb.negotiating_echo
		then do;
		     wtcb.negotiating_echo = "0"b;	/* This really really should not happen -- should we cm$control (echoff) here */
		end;
	     end;

	     if (uncp_flag & ^wtcb.flags.rflag) |
		(^uncp_flag & ^wtcb.flags.rflag & wtcb.prompt_len > 0)

	     then do;
		raw_mode = tcb.rawom;
		tcb.rawom = "1"b;			/* write prompt in rawo mode */
		call tty_write$locked (devx, addr (wtcb.prompt), 0, (wtcb.prompt_len), 0, 0, code);
		tcb.rawom = raw_mode;
	     end;

	     wtcb.flags.rflag = "1"b;			/* we want a wakeup */
	     tty_buf.readblocked = tty_buf.readblocked + 1;
						/* blocked again */
	     if ^uncp_flag then do;
		if ^wtcb.flags.wru			/* if not reading answerback */
		     then if wtcb.receive_mode_device	/* must we tell multiplexer to turn line around? */
		     then call channel_manager$control (devx, "enter_receive", null, ercode);
						/* yes, do it */
		else ;

		else wtcb.flags.wru = "0"b;		/* won't be reading answerback again */
	     end;
	end;

	else do;
	     wtcb.flags.rflag, wtcb.flags.wru = "0"b;
	     wtcb.negotiating_echo = "0"b;
	     if negotiate_entry
	     then do;				/* Return echoed count. */
		echoed = min (nelem, echo_data.chars_echoed);
		echo_data.chars_echoed = echo_data.chars_echoed - echoed;
	     end;
	     tcb.cumulative_meters.read_chars = tcb.cumulative_meters.read_chars + nelemt;
	     tty_buf.ninchars = tty_buf.ninchars + nelemt;/* count input chars */
	     tty_buf.nrawread = tty_buf.nrawread + rawcnt;/* count raw chars input */

	     if (tcb.modes.scroll & (tcb.linemax > 0))
	     then wtcb.actline = 0;			/* scroll by resetting the line count */
						/* that is if we care about the line count in the first place */

	end;

	ercode = 0;
	if get_line_entry
	then nl_found = break_found;			/* report this to caller */
all_done:
	if wtcb.fblock = 0
	then do;
	     wtcb.lblock = 0;
	     wtcb.flags.allow_wakeup = "0"b;
	end;

	if ercode ^= 0
	then do;
	     call clean_up;				/* don't give him anything extra */
	     wtcb.negotiating_echo = "0"b;
	end;
	time_spent = clock () - start_time;
	tcb.cumulative_meters.read_time = tcb.cumulative_meters.read_time + time_spent;
	tty_buf.read_time = tty_buf.read_time + time_spent;
	call tty_lock$unlock_channel (devx);		/* unlock channel lock */
	a_nelemt = nelemt;
	if nelemt > 0
	then call meter_response_time (pds$processid, RETURN_RING_0_TTY);
	if negotiate_entry
	then a_echoed = echoed;
	if mark_entry
	then if mark_index <= nelemt
	     then a_mark_index = mark_index;
	     else a_mark_index = 0;
	return;					/*						*/

/* ** INTERNAL PROCEDURES ** */

copy_chars:
     proc;

/* this procedure copies ctally characters from source_ptr to target_ptr. It updates both pointers */
/* and increments target_len by ctally */

dcl  tally_chars char (ctally) based;

	target_ptr -> tally_chars = source_ptr -> tally_chars;

	source_ptr = addr (source_ptr -> based_chars (ctally));
	target_ptr = addr (target_ptr -> based_chars (ctally));
	target_len = target_len + ctally;

	return;

     end /* copy_chars */;

clean_up:
     proc;

/*
   This procedure is to insure that the user does not get returned
   any values that might convey any information to hime that he should not have
*/

	nelemt, a_nelemt = 0;
	nl_found = "0"b;
	state = 0;
	return;

     end clean_up;


get_more_data:
     proc (new_blockp);

/* this proc calls channel_manager$read to get more buffers of data and set the buffer pointer (blockp)
   and the the first block (wtcb.fblock) if it si not already set.  Both are set to null values if no data is pending */

dcl  new_blockp ptr;
dcl  prev_blockp ptr;
dcl  orig_blockp ptr;

	if wtcb.input_available
	then do;					/* If there is input, go get it. */
	     call channel_manager$read (devx, blockp, have_more_data, ercode);
						/* get the buffer of interest */
	     if ercode ^= 0
	     then nelemt = 0;			/* reset to zero */
	     wtcb.input_available = have_more_data;
	end;
	else blockp = null;				/* else nothing there or physical channel and he puts everything he has into fblock on interrupt */

	if blockp ^= null
	then do;
	     if wtcb.fblock = 0			/* if there's not a pending chain */
	     then wtcb.fblock = fixed (rel (blockp), 17, 0);
						/* break pointer back into an offset */
	     else do;				/* attach new stuff to existing chain */
		prev_blockp = ptr (ttybp, wtcb.lblock);
		prev_blockp -> buffer.next = fixed (rel (blockp), 17, 0);
	     end;

	     orig_blockp = blockp;

	     do while (buffer.next ^= 0);		/* find end of chain to set wtcb.lblock */
		blockp = ptr (blockp, buffer.next);
	     end;

	     wtcb.lblock = bin (rel (blockp), 17);
	     blockp = orig_blockp;

	     if wtcb.mark_set
	     then do;
		buffer.mark = "1"b;			/* set mark in first block */
		wtcb.mark_set = "0"b;
	     end;
	end;
	new_blockp = blockp;
	return;
     end;						/* get_more_data */

/**/
insert_char:
     proc (i_char);

/* this procedure inserts one character at target_ptr, and increments target_ptr and target_len by one character */

dcl  i_char char (1) aligned;

	target_ptr -> based_one_char = i_char;
	target_ptr = addr (target_ptr -> based_chars (1));
	target_len = target_len + 1;
	return;

     end /* insert_char */;				/*						*/
skip:
     proc (to_skip);

/* this procedure discards a specified number of characters from stringp */

dcl  to_skip fixed bin;

	stringp = addr (stringp -> based_chars (to_skip));/* skip over character */
	if source_len = stringl			/* if it's first character in the string */
	then source_len = source_len - to_skip;		/* then make sure it doesn't get picked up */
	stringl = stringl - to_skip;

	return;

     end /* skip */;

escaped:
     proc returns (bit (1) aligned);

/* this procedure returns "1"b if the character at index xr in the string based on stringp */
/* is preceded by a non-overstruck escape character; otherwise it returns "0"b */

	if ^tcb.escm
	then return ("0"b);

	if xr <= 1				/* no preceding character */
	then return ("0"b);

	if tctp = null				/* no conversion table so no escapes */
	then return ("0"b);

	if tctp -> table (rank (substr (based_string, xr - 1, 1))) ^= 2
						/* not preceded by an escape */
	then return ("0"b);

	if xr = 2					/* escape can't be overstruck, it's first char */
	then return ("1"b);

	if substr (based_string, xr - 2, 1) = bs	/* escape is overstruck */
	then return ("0"b);

	else return ("1"b);

     end /* escaped */;				/*						*/
char_value:
     proc (a_char) returns (fixed bin);

/* this procedure returns the numeric equivalent of an ASCII character if the character is 0 to 7; */
/* otherwise it returns -1 */

dcl  a_char char (1) aligned;
dcl  numeric fixed bin;

	numeric = rank (a_char);
	if numeric >= 48				/* i.e., "0" */
	     & numeric <= 55			/* i.e., "7" */
	then return (numeric - 48);

	else return (-1);

     end /* char_value */;

copy_to_preconverted:
     proc;

/* This procedure copies source_len characters from source_ptr to buffers marked "preconverted" */

dcl  mark_next_buffer bit (1);

	tty_buf.preconverted = tty_buf.preconverted + source_len;

	old_fblock = wtcb.fblock;

/* we will copy extra ones into tty_buf "converted" buffers */

	call tty_space_man$get_buffer (devx, BSIZE, INPUT, new_blockp);
	if new_blockp = null
	then go to no_space;

	wtcb.fblock = bin (bin (rel (new_blockp), 18), 17);

	target_len = 0;
	mark_next_buffer = "0"b;

	do while (source_len > 0);
	     blockp = new_blockp;
	     buffer.converted = "1"b;

	     ctally = min (source_len, bsizec);
	     if mark_entry
	     then do;
		if /* tree */ mark_next_buffer	/* we broke previous buffer at mark */
		then do;
		     buffer.mark = "1"b;
		     mark_next_buffer = "0"b;
		end;

		else if pmark_index > 0
		     then if pmark_index = target_len + 1
						/* it's exactly here */
			then do;
			     buffer.mark = "1"b;
			     pmark_index = 0;	/* we've done it now */
			end;
			else if pmark_index <= target_len + ctally
						/* it's due to be in this buffer */
			     then do;
				ctally = pmark_index - target_len - 1;
						/* break so mark will be at start of next buffer */
				mark_next_buffer = "1"b;
						/* and remember to do it */
				pmark_index = 0;	/* taken care of now */
			     end;
	     end;

	     buffer.tally = ctally;
	     target_ptr = addr (buffer.chars (0));
	     call copy_chars;

	     source_len = source_len - ctally;
	     if source_len > 0			/* more to do? */
	     then do;

/* get another buffer */

		call tty_space_man$get_buffer (devx, BSIZE, INPUT, new_blockp);
		if new_blockp = null
		then do;
no_space:
		     call syserr (crash, "tty_read: No buffers available for preconverted input.");
		     return;
		end;

		buffer.next = bin (bin (rel (new_blockp), 18), 17);
						/* set forward pointer in previous block */
	     end;
	end;

/* done filling "converted" buffers */

	buffer.next = old_fblock;			/* set forward pointer in last one */
	if break_found
	then buffer.break, tcb.flags.break_char_pending = "1"b;
						/* had we found a break earlier? */
	break_found = "0"b;				/* we're not sending the NL to the caller or else we wouldn't be here */

	if old_fblock = 0
	then wtcb.lblock = fixed (rel (blockp), 17);

	return;

     end /* copy_to_preconverted */;

pickup_preconverted:
     proc;

/* check for already-converted input left over from last call and use it up first */

	break_found = "0"b;
	convert = buffer.converted;

	do while (wtcb.fblock ^= 0 & convert);		/* scan chain of converted buffers */
	     data_ptr, source_ptr = addr (buffer.chars (0));
	     ctally = min (buffer.tally, nelem - target_len);
	     call copy_chars;

	     if ctally < buffer.tally			/* didn't take whole buffer, no room left for the rest */
	     then do;
		new_tally = buffer.tally - ctally;
		buffer.tally = new_tally;

/* copy remaining characters to beginning of buffer */

		substr (temp_buf, 1, new_tally) = substr (data_ptr -> based_buf, ctally + 1, new_tally);
		substr (data_ptr -> based_buf, 1, new_tally) = substr (temp_buf, 1, new_tally);

		convert = "0"b;			/* so we'll stop copying */
		tcb.flags.break_char_pending = "0"b;	/* if end clear any pending flag will reset later if called for */
	     end;

	     else do;				/* copied whole buffer */
		break_found = buffer.break;
		new_block = buffer.next;

		call tty_space_man$free_buffer (devx, INPUT, blockp);
						/* free the buffer just copied from */
		wtcb.fblock = new_block;

		if wtcb.fblock ^= 0			/* there's more */
		then do;
		     blockp = ptr (ttybp, wtcb.fblock);
		     if break_found | target_len >= nelem
						/* have we got enough? */
		     then convert = "0"b;		/* yes, no more copying */
		     else convert = buffer.converted;
		end;
		else wtcb.lblock = 0;		/* just to be safe */

		if break_found
		then tcb.flags.break_char_pending = "0"b;
						/* assume this is the one we flaged */
	     end;
	end;					/* end of copy-converted loop */

	return;

     end pickup_preconverted;

copy_loop:
     proc;

/*
   This procedure copies data from the available input buffer and places
   it into an internal working buffer
*/

dcl  new_blockp ptr;
dcl  orig_blockp ptr;

	first_char = wtcb.fchar;			/* keep in automatic for convenience */
	if ^get_line_entry
	then break_found = "0"b;			/* so we're not fooled by preconverted break */
	do while (^break_found & rel (blockp) ^= "0"b & room_left > 0);
	     chars_in_buf = buffer.tally - first_char;
	     source_ptr = addr (buffer.chars (first_char));

	     ctally = index (substr (source_ptr -> based_buf, 1, chars_in_buf), break);
	     if ctally = 0
	     then ctally = chars_in_buf;
	     else break_found = "1"b;

	     if ctally > room_left			/* there has to be room internally */
	     then ctally = room_left;

	     call copy_chars;			/* get the data */

	     room_left = room_left - ctally;
	     rawcnt = rawcnt + ctally;

	     if ctally < chars_in_buf			/* we reached some limit */
	     then first_char = first_char + ctally;	/* this buffer will be around later */
	     else do;
		last_block = fixed (rel (blockp), 17);
		first_char = 0;			/* next buffer begins at beginning */
		blockp = ptr (ttybp, buffer.next);
	     end;

	     if rel (blockp) = "0"b			/* if we reached end */
	     then if ^break_found			/* without finding break */
		then if wtcb.input_available		/* but lower level has more data */
		     then do;			/* get it now */
			orig_blockp = blockp;
			call get_more_data (new_blockp);
			if ercode ^= 0
			then go to all_done;
			if new_blockp ^= null	/* if there really was some */
			then blockp = new_blockp;
			else blockp = orig_blockp;	/* get_more_data probably changed it */
		     end;
	end;

	wtcb.fchar = first_char;			/* update this now */

	return;

     end copy_loop;					/*						*/
translation:
     proc;

/*
   This procedure sets up the necessary variables and then calls the move and translate
   operation
*/

	source_ptr = addr (buffer_1);
	target_ptr = addr (buffer_2);

	if throw_away
	then do;					/* remove first character */
	     source_ptr = addr (source_ptr -> based_chars (1));
	     target_len = target_len - 1;
	     throw_away = "0"b;
	end;

	stringl = target_len;			/* the number of chars in buffer_1 now */
	stringp = source_ptr;

	if mvtp ^= null
	then do;
	     mvt_args.tablep = mvtp;
	     mvt_args.targetp = target_ptr;

	     call tty_util_$mvt (addr (util));		/* this does the translation */

	     source_ptr = addr (buffer_2);
	     target_ptr = addr (buffer_1);
	     stringp = source_ptr;
	end;

	if ^tcb.control				/* get rid of invisible characters if appropriate */
	then if ^no_control_input (wtcb.line_type)	/* and necessary */
	     then do;
		mvt_args.tablep = addr (nocontrol);
		mvt_args.targetp = target_ptr;

		call tty_util_$mvt (addr (util));

		stringp = target_ptr;		/* switch buffers back */
		target_ptr = source_ptr;
		source_ptr = stringp;
	     end;

	return;

     end translation;

canonicalization:
     proc;

/*
   This procedure sets up the necessary variables then calls the cannonicalizer
*/
/* search for cr and bs */

	code = 0;
	xr = 1;					/* to make sure we do loop at least once */
	do while (xr = 1);

	     xr = search (based_string, left_motion);

	     if xr = 1				/* at left margin, skip over it */
	     then do;
		stringp = addr (stringp -> based_chars (1));
		stringl = stringl - 1;
	     end;

	     else if search (based_string, vertical_motion) ^= 0
	     then go to MUST_CALL_CANONICALIZE;		/* FF or HT in string: must call canonicalize routine to
						   insure that whitespace before the HT or FF is stripped */

	     else if xr ^= 0			/* we found one somewhere else */
	     then do;				/* find out if at end */

		if (tcb.can_type ^= CAN_TYPE_REPLACE) & (verify (substr (based_string, xr), all_white) = 0)
						/* rest of string white: not significant unless
						   can_type=replace where trailing whitespace can replace
						   prior characters on the line */
		then do;
		     if substr (based_string, stringl, 1) = nl
		     then do;			/* copy newline if any */
			substr (based_string, xr, 1) = nl;
			stringl = xr;
		     end;

		     else stringl = xr - 1;

		     source_ptr = stringp;		/* so we won't get leading bs/cr back */
		end;

		else do;				/* left motion in middle, must call tty_canon */
MUST_CALL_CANONICALIZE:
		     if stringp ^= source_ptr		/* did we skip over leading bs/cr? */
		     then do;			/* copy so tty_canon can use whole buffer */
			target_ptr -> based_string = stringp -> based_string;
			data_ptr = target_ptr;
			target_ptr = source_ptr;
			source_ptr = data_ptr;
		     end;

		     can_called = "1"b;
		     call canon_procedure (source_ptr, stringl, length (buffer_1), erase_char, kill_char, code);
		end;
	     end;

	     else source_ptr = stringp;		/* update for possible skipped leading left motion */
	end;

	return;

     end canonicalization;				/* end of canonicalization */

strip_nulls:
     proc;

/*
   This procedure eliminates nulls from an input buffer.  It is used if tty_cannon
   was not called earlier for some reason or another
*/
	old_sourcep = source_ptr;
	old_targetp = target_ptr;

	xr = index (based_string, nul_char);

	do while (xr ^= 0 & stringl > 0);
	     if xr = 1				/* NUL at beginning of string */
	     then do;
		stringl = stringl - 1;
		source_len = source_len - 1;
	     end;

	     else do;
		ctally = xr - 1;			/* copy characters from before NUL */
		call copy_chars;
		stringl = stringl - xr;
	     end;

	     if stringl > 0
	     then do;				/* search remainder for further nulls */
		source_ptr, stringp = addr (stringp -> based_chars (xr));
		xr = index (based_string, nul_char);
	     end;

	end;

	if target_len > 0				/* if we moved any at all */
	then do;
	     if stringl > 0				/* any more that we didn't move? */
	     then do;
		ctally = stringl;
		call copy_chars;			/* move 'em */
	     end;
	     source_len = target_len;			/* source for next pass */
	     source_ptr = old_targetp;		/* switch buffers */
	     target_ptr = old_sourcep;
	end;

	stringp = source_ptr;

	return;

     end strip_nulls;

process_erase_kill:
     proc;

/*
   This procedure does the erase and kill processing by killing all characters
   to the left of the kill character, and erasing the character (or specified
   number of characters) to the left of the erase character.
*/
	old_sourcep = source_ptr;
	old_targetp = target_ptr;
	stringl = source_len;

/* kill first */

	xr = 0;

	do while (xr < stringl);

/* search from the right, only last kill is interesting */

	     xr = stringl - index (reverse (based_string), kill_char);

	     if xr < stringl			/* found one */
	     then do;
		xr = xr + 1;			/* makes xr actual index of kill */

		if ^escaped ()			/* it's a real kill */
		then do;
		     source_ptr, stringp = addr (stringp -> based_chars (xr));
						/* point to char after kill */
		     source_len = source_len - xr;
		     xr = stringl;			/* so as not to index again */
		end;

		else do;				/* it was escaped, we must scan rest of string */
		     stringl = xr - 2;
		     xr = 0;
		end;
	     end;
	end;					/* finished with kills */


/**/
/* now erase */

	stringl = source_len;
	target_len = 0;
	xr = 1;

	do while (xr ^= 0 & stringl > 0);
	     xr = index (based_string, erase_char);	/* look for first erase */

	     if xr = 1				/* first char */
	     then do;
		if target_len ^= 0			/* if not first char in whole string */
		then do;				/* we have to erase some already copied chars */
		     bx = verify (reverse (based_target), right_motion);
						/* skip white space */
		     if bx = 0			/* all white */
		     then do;
			target_ptr = old_targetp;	/* wipe it all out */
			target_len = 0;
		     end;

		     else do;
			if bx ^= 1		/* there's some white space */
			then ctally = bx - 1;	/* we'll erase it all */
						/* no white, check for overstrikes */
			else do ctally = 1 to target_len - 2 by 2
				while (substr (based_target, target_len - ctally, 1) = bs);
			end;

			target_len = target_len - ctally;
			target_ptr = addr (old_targetp -> based_chars (target_len));
		     end;
		end;

		if target_len <= 0			/* we erased whole target string */
		then source_len = stringl - 1;
	     end;

/* not first char, see if it's escaped */

	     else if xr ^= 0
	     then do;
		if escaped ()
		then ctally = xr;			/* copy everything */

		else do;
		     bx = verify (reverse (substr (based_string, 1, xr - 1)), right_motion);

		     if bx = 0			/* all white */
		     then ctally = 0;		/* copy nothing */

		     else if bx ^= 1		/* some white */
		     then ctally = xr - bx;		/* which will not be copied */
		     else do ctally = xr - 2 to 2 by -2 while (substr (based_string, ctally, 1) = bs);
		     end;

		end;
		if ctally > 0
		then call copy_chars;
		else source_len = source_len - xr;
	     end;

	     if xr > 0				/* if we're going around again */
	     then do;
		source_ptr, stringp = addr (stringp -> based_chars (xr));
						/* point past erase */
		stringl = stringl - xr;
	     end;
	end;					/* end of erase search */

	if target_len > 0				/* if we moved any */
	then do;
	     if stringl > 0				/* if there are any more */
	     then do;
		ctally = stringl;
		call copy_chars;
	     end;

	     source_len = target_len;
	     source_ptr = old_targetp;
	     target_ptr = old_sourcep;		/* switch buffers */
	end;

	return;

     end process_erase_kill;				/* end of erase-kill phase */

process_escape_break:
     proc;

/*
   This procedure processes a break character if it was proceded by an escape character
   in which case, it is not counted as a real break character
*/
	old_targetp = target_ptr;
	target_len = 0;
	break_found = "0"b;
	stringp = source_ptr;
	stringl = source_len;
	util.tablep = tctp;

	do while (stringl > 0);

/* scan for interesting char */

	     call tty_util_$tct (addr (util));

	     if util.indicator = 0 & stringl = 0 & target_len = 0
						/* never no nothing */
	     then ;

	     else do;				/* there's work to do */
		if ctally > 0			/* copy uninteresting characters */
		then do;
		     old_sourcep = source_ptr;
		     call copy_chars;
		end;

		if indicator = BREAK_CHAR		/* break char */
		then call process_break_char;

		else if indicator = ESCAPE_CHAR	/* escape char */
		then do;
		     if ^tcb.escm			/* we're not escaping */
			| stringl <= 1		/* there's nothing after it */
		     then call insert_and_update;
		     else call process_escape_char;
		end;


		else if indicator = THROW_AWAY	/* throw away */
		then call skip (1);

		else if indicator = FORM_FEED		/* form feed */
		then do;
		     if tcb.linemax > 0		/* using page length */
		     then call skip (1);		/* so throw form feed away */

		     else call insert_and_update;
		end;

		else if indicator = HARDWARE_CONTROL	/* hardware control sequence */
		then if ^tcb.modes.control		/* no control chars wanted */
		     then do;
			call skip (2);		/* skip this and following char */
			if stringl < 0		/* there wasn't another one */
			then throw_away = "1"b;	/* we'll throw away first if we go around again */
		     end;
		     else call insert_and_update;

		else if indicator ^= 0		/* what else could it be? */
		then do;
		     nelemt = 0;			/* nothing for you, chief */
		     ercode = error_table_$improper_data_format;
		     go to all_done;
		end;

		source_ptr = stringp;
	     end;
	end;

	return;

     end process_escape_break;			/* of tct loop */

process_break_char:
     proc;

/*
   This procedure processes the actual break character and manipulates the white space as necessary
*/
	break_found = "1"b;				/* it can't be escaped or we'd have found the escape */

	if tcb.canm
	then if ctally > 0				/* scan back for preceding white space */
	     then do;
		bx = verify (reverse (substr (based_source, 1, ctally)), right_motion) - 1;

		if bx < 0				/* all white */
		then bx = ctally;

		if bx > 0				/* any white */
		then do;
		     target_len = target_len - bx;
		     target_ptr = addr (old_targetp -> based_chars (target_len));
		end;
	     end;

/* target_ptr shows where to put nl now in any case */

	call insert_and_update;

	return;

     end process_break_char;

process_escape_char:
     proc;

/* This procedure does the processing of a character if it is proceded by
   an escape character
*/
	if ctally > 0				/* check for overstruck escape */
	then do;
	     i = -1;				/* necessary to make compiler accept next statement */
	     if stringp -> based_chars (i) = bs
	     then do;
		call insert_and_update;
		return;
	     end;
	end;

	next_char = stringp -> based_chars (1);
	if next_char = bs
	then do;
	     call insert_and_update;
	     return;
	end;

	if stringl > 2				/* check for following character overstruck */
	then if stringp -> based_chars (2) = bs
	     then do;
		call insert_and_update;
		return;
	     end;

	if tctp -> table (rank (next_char)) = 2 |	/* next char is escape */
	     next_char = tcb.erase | next_char = tcb.kill
	then do;

	     stringp = addr (stringp -> based_chars (1)); /* skip over escape */
	     stringl = stringl - 1;
	     call insert_and_update;			/* put in following char as is */
	     return;
	end;

/**/
/* check for octal escape */

	digit = char_value (next_char);
	if digit >= 0
	then do;					/* we have octal digit(s) */

	     octal.result = 0;
	     stringp = addr (stringp -> based_chars (1)); /* look at next */

	     do i = 1 to 3 while (digit >= 0);
		octal.result = 8 * octal.result + digit;

		if stringl > i & i < 3
		then do;
		     digit = char_value ((stringp -> based_chars (i)));
		     if digit >= 0			/* next char is digit, see if it's overstruck */
		     then if stringl > i + 1
			then if stringp -> based_chars (i + 1) = bs
			     then digit = -1;
		end;

		else digit = -1;			/* no more chars, or we already have 3 */
	     end;

	     call insert_char ((addr (octal.result) -> based_one_char));
	     stringp = addr (stringp -> based_chars (i - 1));
						/* skip over octal digits */
	     stringl = stringl - i;
	end;

/**/
/* see if it's escaped newline (with possible intervening white space) */

	else if verify (substr (based_string, 2, stringl - 2), right_motion) = 0
		& substr (based_string, stringl, 1) = nl
	then do;
	     if stringl = source_len			/* first thing in the string? */
	     then source_len = 0;			/* then nothing */
	     stringl = 0;				/* we've reached end */
	end;

	else do;					/* look up next_char in input escape table */
	     if special_ptr = null			/* no table means no escapes */
	     then call insert_and_update;
	     else if special_ptr -> special_chars.input_escapes.len = 0
	     then call insert_and_update;

	     else do;
		xr = index (special_ptr -> special_chars.input_escapes.str, next_char);
		if xr ^= 0			/* it's there */
		then do;
		     call insert_char ((substr (special_ptr -> special_chars.input_results.str, xr, 1)));
		     stringp = addr (stringp -> based_chars (2));
						/* point past escape sequence */
		     stringl = stringl - 2;
		end;

		else call insert_and_update;
	     end;
	end;

	return;

     end process_escape_char;				/* of escape character */

insert_and_update:
     proc;

/*
   This procdure passes insert_char a character pointed to by stringp
   to be inserted, then it updates the string pointer and the
   string length
*/

	call insert_char ((stringp -> based_one_char));
	stringp = addr (stringp -> based_chars (1));
	stringl = stringl - 1;

	return;

     end insert_and_update;


is_parent_mpx:					/* Check match of channel's parent mpx type against input mpx type */
     proc (parent_mpx_type) returns (bit (1));

dcl parent_mpx_type fixed bin;
dcl temp_lctep ptr;
     
	lctep = addr (lct.lcte_array (devx));
	if lcte.major_channel_devx ^= 0 then do;
	     temp_lctep = addr (lct.lcte_array (lcte.major_channel_devx));
	     if temp_lctep->lcte.channel_type = parent_mpx_type then return ("1"b);
	end;
	else if lcte.channel_type = parent_mpx_type then return ("1"b);
	return ("0"b);
     end is_parent_mpx;

     end /* tty_read */;




		    tty_replace_canon.pl1           11/11/89  1109.0r w 11/11/89  0826.9       78156



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


/* Replacement canonicalization (can_type=replace):  Assuming that overstriking is destructive, space (SP) is destructive,
   and horizontal tab (HT) is not destructive, this procedure accepts a line of ASCII characters as input and replaces it
   with the canonical representation of that line.  Characters are sorted by column position; NUL (\000) characters are
   discarded; when characters are overstruck, only the last character in the column is preserved */

/* Created:  18 September 1980 by G. Palter */
/* Modified: 11 November 1980 by G. Palter to rename to tty_replace_canon and accept additional parameters */
/* Modified: 14 February 1984 by Robert Coren to preserve invisible control characters */

tty_replace_canon:
     procedure (P_line_ptr, P_line_lth, P_line_max_lth, P_erase_character, P_kill_character, P_code);


/* Parameters */

dcl  P_line_ptr pointer parameter;			/* -> string to be processed and output area */
dcl  P_line_lth fixed binary parameter;			/* current length of string (Input/Output) */
dcl  P_line_max_lth fixed binary parameter;		/* maximum size of the string */
dcl  P_erase_character character (1) aligned parameter;	/* current erase character or SP if none */
dcl  P_kill_character character (1) aligned parameter;	/* current kill character or SP if none */
dcl  P_code fixed binary (35) parameter;		/* status code (Output) */


/* Local copies of parameters */

dcl  line_ptr pointer;
dcl (line_lth, line_max_lth) fixed binary;
dcl  code fixed binary (35);


/* Remaining declarations */

dcl  line character (line_max_lth) unaligned based (line_ptr);

dcl 1 char_array (P_line_max_lth) aligned,		/* characters to be sorted by column */
    2 column fixed binary (18) unaligned unsigned,
    2 flags unaligned,
      3 vertical bit (1) unaligned,			/* ON => character has vertical paper motion */
      3 pad bit (6) unaligned,
      3 not_control bit (1) unaligned,			/* ON => character is not "invisible" control character */
      3 not_tab bit (1) unaligned,			/* ON => character isn't horizontal tab */
    2 char character (1) unaligned;			/* the character itself */

dcl  complete_item (1) bit (36) aligned based (addr (char_array));
dcl 1 partial_item (1) aligned based (addr (char_array)),
    2 sorted bit (27) unaligned,
    2 unsorted bit (9) unaligned;

dcl  temp_item bit (36) aligned;
dcl 1 partial_temp aligned based (addr (temp_item)),
    2 sorted bit (27) unaligned,
    2 unsorted bit (9) unaligned;

dcl (start_column, current_column, next_column, end_of_tab) fixed binary;
dcl (char_idx, array_idx, idx) fixed binary;

dcl  the_char character (1) aligned;

dcl  n_characters fixed binary;			/* # of characters possibly in output */

dcl (NUL		initial (""),			/* NUL */
     CR		initial (""),						/* carriage return */
     BS		initial (""),			/* backspace */
     HT		initial ("	"),		/* horizontal tab */
     NL		initial ("
"),						/* newline */
     VT		initial				/* vertical tab */
		 (""),
     FF		initial				/* form feed */
		 (""),
     SP		initial (" "))			/* space */
	character (1) aligned static options (constant);

dcl  HTSP  character (2) static options (constant) initial ("	 ");

dcl  MAX_COLUMN fixed binary (18) static options (constant) initial (262143);

dcl  error_table_$long_record fixed binary (35) external;

dcl (addr, length, max, mod, rtrim, string, substr) builtin;
%page;
	start_column, current_column = 0;

	line_ptr = P_line_ptr;
	line_lth = P_line_lth;
	line_max_lth = P_line_max_lth;

	P_code, code = 0;


/* Classify each input character and determine which column it appears in on the screen */

	array_idx = 1;

	do char_idx = 1 to line_lth;

	     string (char_array(array_idx).flags) = "003"b3;   /* turn on flags.not_tab and flags.not_control */
	     the_char = substr (line, char_idx, 1);

	     if (the_char = CR) then			/* carriage return: reset to start of line */
		current_column = start_column;

	     else if (the_char = BS) then		/* backspace: move back one column -- replacement later */
		current_column = max (start_column, (current_column - 1));

	     else if (the_char = NUL) then;		/* throw away NULs */

	     else do;				/* anything else: put into array */
		if (the_char = NL)			/* newline: insure it is last in output */
		     then do;
			char_array(array_idx).column = MAX_COLUMN;
			char_array(array_idx).vertical = "1"b;
		     end;

		else if (the_char = VT) | (the_char = FF)
		     then do;			/* these characters start a new "line" */
			current_column, start_column = start_column + 1000;
			char_array(array_idx).column = start_column - 1;
			char_array(array_idx).vertical = "1"b;
		     end;

		else do;				/* ordinary character */
		     char_array(array_idx).column = current_column;  /* into next column */
		     if (the_char = HT)
			then do;			/* horizontal tab: compute next tab stop */
			     char_array(array_idx).not_tab = "0"b;
			     current_column = current_column + 10 - mod (current_column, 10);
			end;
		     else if (the_char >= SP) then	/* advances to next position */
			current_column = current_column + 1;

		     else char_array(array_idx).not_control = "0"b;
		end;

		char_array(array_idx).char = the_char;
		array_idx = array_idx + 1;
	     end;
	end;

	n_characters = array_idx - 1;			/* incremented by one too many */


/* Sort characters according to column */

	do array_idx = 1 to n_characters - 1;
	     if partial_item(array_idx).sorted > partial_item(array_idx+1).sorted then do;
		temp_item = complete_item (array_idx+1);
		do idx = array_idx to 1 by -1 while (partial_item(idx).sorted > partial_temp.sorted);
		     complete_item (idx+1) = complete_item (idx);
		end;
		complete_item (idx+1) = temp_item;
	     end;
	end;


/* Place characters into output string, replacing overstruck sequences with the last character typed into the column */

	char_idx = 1;
	current_column = 0;

	do array_idx = 1 to n_characters;

	     next_column = char_array(array_idx).column;	/* where this graphic belongs */

	     do while (current_column < next_column);	/* insert spaces as needed */
		if char_array(array_idx).vertical
		then do;
		     current_column = next_column;	/* moves to next line: don't add uneeded spaces */
		     char_idx = length (rtrim (substr (line, 1, char_idx-1), HTSP)) + 1;
		end;				/* stip trailing whitespace already present */
		else do;
		     call insert_character (SP);
		     current_column = current_column + 1;
		end;
	     end;

	     if ^char_array(array_idx).not_tab
	     then do;				/* horizontal tab */
		end_of_tab = current_column + 10 - mod (current_column, 10);
		if array_idx < n_characters then
		     if char_array(array_idx+1).column >= end_of_tab then do;
			call insert_character (HT);   /* chars after HT don't overwrite it */
			current_column = end_of_tab;
		     end;
	     end;

	     /* if HT is overwritten, next character will cause spaces to be inserted by above loop */

	     else do;				/* not HT */
		call insert_character ((char_array(array_idx).char));
						/* put it into string */
		do while ((array_idx < n_characters) & (char_array(array_idx+1).column = current_column));
		     if ^char_array (array_idx).not_control then
			char_idx = char_idx + 1;	/* don't overwrite control characters */
		     array_idx = array_idx + 1;	/* process overstrikes by replacing previous character */
		     substr (line, char_idx-1, 1) = char_array(array_idx).char;
		end;
		current_column = current_column + 1;
	     end;
	end;

	P_line_lth = char_idx - 1;			/* set output length */

RETURN_TO_CALLER:
	P_code = code;
	return;
%page;
/* Insert the given character into the output string */

insert_character:
	procedure (p_character);

dcl  p_character character (1) aligned parameter;

	     if char_idx > line_max_lth then do;	/* overflowed */
		code = error_table_$long_record;
		go to RETURN_TO_CALLER;
	     end;

	     substr (line, char_idx, 1) = p_character;
	     char_idx = char_idx + 1;

	     return;

	end insert_character;

     end tty_replace_canon;




		    tty_tables_mgr.pl1              11/11/89  1109.0r w 11/11/89  0826.9       66600



/****^  ***********************************************************
        *                                                         *
        * 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.      *
        *                                                         *
        *********************************************************** */


tty_tables_mgr: proc;

/* A program to manage the addition and deletion of tables
   to and from the tty_tables segment.  This segment must be
   locked before performing modifications.
*/

/* Coded by J. Stern 3/14/77 */


/* parameters */

dcl  a_new_table_ptr ptr;				/* ptr to table to be added (Input) */
dcl  a_new_table_size fixed bin;			/* size (in chars) of table to be added (Input) */
dcl  a_type fixed bin;				/* type of table to be added (Input) */
dcl  a_table_rel bit (18);				/* rel ptr to stored table (Output) (Input) */
dcl  a_code fixed bin;				/* standard error code (Output) */


/* automatic */

dcl  new_table_ptr ptr;
dcl  new_table_size fixed bin;
dcl  type fixed bin;
dcl (next_tdp, prev_tdp) ptr;
dcl (td_rel, next_td_rel, prev_td_rel) bit (18);
dcl  code fixed bin (35);
dcl  saved_count fixed bin;
dcl  saved_ref_count fixed bin;
dcl  changing_threads bit (1) aligned;


/* based */

dcl  new_table (new_table_size) bit (36) aligned based (new_table_ptr);


/* conditions */

dcl (cleanup, area) condition;


/* static */

dcl (error_table_$bad_index,
     error_table_$no_table,
     error_table_$notalloc) fixed bin (35) ext static;
dcl  pds$processid bit (36) aligned ext static;
dcl  crash_system fixed bin int static options (constant) init (1);


/* builtins */

dcl (addr, null, ptr, rel, bin, bit, unspec) builtin;


/* entries */

dcl  lock$lock_fast entry (ptr);
dcl  lock$unlock_fast entry (ptr);
dcl  syserr entry options (variable);

%include tty_tables;

add:	entry (a_new_table_ptr, a_new_table_size, a_type, a_table_rel, a_code);

	ttytp = addr (tty_tables$);
	new_table_ptr = a_new_table_ptr;
	new_table_size = a_new_table_size;
	type = a_type;
	code = 0;

	if type < 1 | type > 6
	then do;
	     call syserr ((crash_system), "tty_tables_mgr$add:  Invalid table type.  ^d", type);
	     a_code = error_table_$bad_index;
	     return;
	end;

	tdp = null;
	changing_threads = "0"b;
	saved_count = tty_tables_hdr.count (type);
	on cleanup begin;
	     if changing_threads
	     then do;
		call unthread_td;
		tty_tables_hdr.count (type) = saved_count;
	     end;
	     else if tdp ^= null
	     then call free_td;
	     if tty_tables_hdr.lock = pds$processid
	     then call lock$unlock_fast (ttytp);
	end;
	call lock$lock_fast (ttytp);

	on area begin;
	     code = error_table_$notalloc;
	     go to add_unlock;
	end;

	table_alloc_len = new_table_size * 36;
	allocate table_descriptor in (table_area) set (tdp);
	revert area;

	td_rel = rel (tdp);
	addr (table_descriptor.table_contents) -> new_table = new_table;

	prev_td_rel = ""b;
	prev_tdp = null;
	do next_td_rel = tty_tables_hdr.first_table (type) repeat next_tdp -> table_descriptor.next_table
		while (next_td_rel ^= ""b);
	     next_tdp = ptr (ttytp, next_td_rel);
	     if table_descriptor.table_contents < next_tdp -> table_descriptor.table_contents
	     then go to insert_td;
	     if table_descriptor.table_contents = next_tdp -> table_descriptor.table_contents
	     then if table_descriptor.len = next_tdp -> table_descriptor.len
		then do;
		     call free_td;
		     next_tdp -> table_descriptor.ref_count = next_tdp -> table_descriptor.ref_count + 1;
		     tdp = next_tdp;
		     go to add_unlock;
		end;
		else if table_descriptor.len < next_tdp -> table_descriptor.len
		then go to insert_td;

	     prev_td_rel = next_td_rel;
	     prev_tdp = next_tdp;
	end;
	next_tdp = null;

insert_td: table_descriptor.pattern = (18) "10"b;
	table_descriptor.type = type;
	table_descriptor.next_table = next_td_rel;
	table_descriptor.prev_table = prev_td_rel;
	table_descriptor.ref_count = 1;

	changing_threads = "1"b;
	call thread_td;

	tty_tables_hdr.count (type) = tty_tables_hdr.count (type) + 1;
add_unlock: call lock$unlock_fast (ttytp);
	revert cleanup;
	a_code = code;
	if code = 0
	then a_table_rel = rel (addr (table_descriptor.table_contents));
	return;

delete:	entry (a_table_rel, a_code);

	ttytp = addr (tty_tables$);
	td_rel = bit (bin (bin (a_table_rel, 18) -6, 18), 18); /* table desc offset = table offset - 6 */
	tdp = ptr (ttytp, td_rel);
	type = table_descriptor.type;

	if table_descriptor.pattern ^= (18) "10"b
	then do;
	     call syserr ((crash_system), "tty_tables_mgr$delete:  Invalid table offset.  ^6o", bin (td_rel, 18));
	     a_code = error_table_$no_table;
	     return;
	end;
	changing_threads = "0"b;
	saved_ref_count = table_descriptor.ref_count;
	saved_count = tty_tables_hdr.count (type);
	on cleanup begin;
	     if tdp = null				/* if table already freed */
	     then tty_tables_hdr.count (type) = saved_count -1;
	     else do;
		if changing_threads
		then call thread_td;
		table_descriptor.ref_count = saved_ref_count;
	     end;
	     if tty_tables_hdr.lock = pds$processid
	     then call lock$unlock_fast (ttytp);
	end;
	call lock$lock_fast (ttytp);

	table_descriptor.ref_count = table_descriptor.ref_count -1;
	if table_descriptor.ref_count > 0
	then go to del_unlock;

	prev_td_rel = table_descriptor.prev_table;
	if prev_td_rel = ""b
	then prev_tdp = null;
	else prev_tdp = ptr (ttytp, prev_td_rel);
	next_td_rel = table_descriptor.next_table;
	if next_td_rel = ""b
	then next_tdp = null;
	else next_tdp = ptr (ttytp, next_td_rel);

	changing_threads = "1"b;
	call unthread_td;
	tty_tables_hdr.count (type) = tty_tables_hdr.count (type) -1;
del_unlock: call lock$unlock_fast (ttytp);
	revert cleanup;
	a_code = 0;
	return;

unthread_td: proc;					/* unthreads and deallocates a table descriptor */

	     if prev_tdp = null
	     then tty_tables_hdr.first_table (type) = next_td_rel;
	     else prev_tdp -> table_descriptor.next_table = next_td_rel;
	     if next_tdp = null
	     then;
	     else next_tdp -> table_descriptor.prev_table = prev_td_rel;


free_td:	     entry;				/* deallocates a table descriptor */

	     free table_descriptor in (table_area);
	     tdp = null;

	end unthread_td;




thread_td: proc;					/* threads in a table descriptor */

	     if prev_tdp = null
	     then tty_tables_hdr.first_table (type) = td_rel;
	     else prev_tdp -> table_descriptor.next_table = td_rel;
	     if next_tdp = null
	     then;
	     else next_tdp -> table_descriptor.prev_table = td_rel;

	end thread_td;

/* BEGIN MESSAGE DOCUMENTATION

   Message:
   tty_tables_mgr$add:  Invalid table type.  N

   S:  $crash

   T:  $run

   M:  An attempt to add a table to the tty_tables segment has
   failed due to an invalid table type of N.

   A:  $inform


   Message:
   tty_tables_mgr$delete:  Invalid table offset.  N

   S:  $crash

   T:  $run

   M:  An attempt to delete a table from the tty_tables segment
   has failed due to an invalid table offset of N.

   A:  $inform

   END MESSAGE DOCUMENTATION */




     end tty_tables_mgr;




		    tty_util_.alm                   11/11/89  1109.0r w 11/11/89  0826.9       83502



" ***********************************************************
" *                                                         *
" * 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 	tty_util_

" " " " " " " " " " " " " " " " " " " " " " " " "
"
"	Utilities for the tty DIM.
"
"	These routines perform certain scanning and editing
"	functions for the tty DIM which are faster and
"	easier to do in ALM.
"
"	Coded 10/15/75 by Mike Grady
"	6/9/81 RE Mullen: find_char to scan <= 128 chars, rather than <= 2000

"
" " " " " " " " " " " " " " " " " " " " " " " " "

	segdef	find_char
	segdef	mvt
	segdef	scm
	segdef	illegal_char
	segdef	tct

"	symbols for storage in callers automatic storage

	equ	stringp,0
	equ	stringl,2
	equ	tally,3
	equ	tablep,4
	equ	bit,4
	equ	match,5
	equ	indicator,6
	equ	targetp,6

"	some temporary storage also in callers stack frame

	equ	w1,8
	equ	w2,9

" 
" " " " " " " " " " " " " " " " " " " " " " " " "
"
"	find_char finds the next interesting char for the
"	caller. It looks first for high bits (> 177) and
"	then for double blanks, and finally for chars in
"	a tct table.
"
"	Input:
"	   stringp - pointer to string to scan
"	   stringl - length of string
"	   tablep - pointer to table to use for tct
"
"	Output:
"	   tally - number of uninteresting chars
"	   indicator - number which indicates char found
"		3 for white space
"		7 for escape char
"		value from tct otherwise
"
" " " " " " " " " " " " " " " " " " " " " " " " "

find_char:
	epp1	pr0|2,*		get ptr to block of storage in
	epp1	pr1|0,*		callers stack
	epp2	pr1|stringp,*	load ptr to string
	ldq	pr1|stringl	load string length
	cmpq	128,dl		use min(stringl,128) to be quick
	tmi	2,ic		all set

	ldq	128,dl
	stz	pr1|tally		zero tally

	tsx2	find_high_bits	look for interesting bits
	tra	look_for_blanks	none, continue

	ldq	pr1|w1		get result
	tze	have_high_bit	first char - done

look_for_blanks:
	scd	(pr,rl),(du)	look for two blanks
	desc9a	pr2|0,ql
	aci	"  "
	arg	pr1|w2		store result here

	ttn	no_double_blanks	none in string

	lda	pr1|w2		get length up to double blanks
	ora	=o400000,du	set high order bit as flag
	sta	pr1|w1		save as count
	ldq	pr1|w2		reduce stringl again

no_double_blanks:
	epp3	pr1|tablep,*	load table pointer
	tct	(pr,rl)		look into tct table for interesting chars
	desc9a	pr2|0,ql
	arg	pr3|0
	arg	pr1|w2

	ttf	tct_hit		we got hit in tct, process

	lda	3,dl		get indicator value
	szn	pr1|w1		any high bits or double blanks?
	tze	return_full_string	no, return the whole thing
	tmi	2,ic		double blanks found
have_high_bit:
	lda	7,dl		get indicator for \nnn type

	sta	pr1|indicator	return it to caller
	lxl0	pr1|w1		get count
	sxl0	pr1|tally
	tra	tct_done		done

tct_hit:
	lda	pr1|w2		get char value hit on
	arl	27		shift down
	sta	pr1|indicator	return to caller
	cmpa	5,dl		one of the special types?
	tpl	return_normal	nope

	lxl0	pr1|w2		get the count
	tze	return_normal	hit on first char in string
	sblx0	1,du		decrement the count to point a prev char
	cmpc	(pr,x0),(),fill(0)
	desc9a	pr2|0,1		look for blank
	desc9a	blank,1

	tnz	return_normal	not blank, all ok

	lda	3,dl		get blank indicator
	sta	pr1|indicator	return to caller
	sxl0	pr1|tally		set tally to blank locn
	tra	tct_done		done

return_normal:
	lxl0	pr1|w2		get the count from the tct
	sxl0	pr1|tally		return to caller
	tra	tct_done		done

return_full_string:
	stq	pr1|tally		use whole thing
	stz	pr1|indicator	set indicator

tct_done:
	ldq	pr1|tally		get tally
	lda	pr1|indicator	load the indicator
	tze	tct_nbump		zero, no bump
	cmpa	3,dl		is it blank?
	tze	tct_nbump		yes, done
	cmpa	7,dl		is it escape char type?
	tze	tct_nbump		yes, done
	adq	1,dl		bump input char count
tct_nbump:
	a9bd	pr2|0,ql		bump ptr
	spri2	pr1|stringp

	stq	pr1|w1		store for subtract
	lda	pr1|stringl	get stringl
	sba	pr1|w1		decrement
	sta	pr1|stringl	reset stringl

	short_return

blank:	aci	" "

" 
" " " " " " " " " " " " " " " " " " " " " " " " "
"
"	this routine does an mvt to translate chars.
"
"	Input:
"	   stringp - points to input string
"	   stringl - length of string
"	   tablep - pointer to translate table
"
"	Output:
"	   targetp - pointer to output string
"
" " " " " " " " " " " " " " " " " " " " " " " " "
mvt:	epp1	pr0|2,*		get ptr to arg ptr
	epp1	pr1|0,*		get ptr to callers block
	epp2	pr1|stringp,*	get ptr to the string
	ldq	pr1|stringl	load length of string
	epp3	pr1|tablep,*	load ptr to mvt table
	epp5	pr1|targetp,*	get ptr to target string

	mvt	(pr,rl),(pr,rl),fill(0) do the mvt
	desc9a	pr2|0,ql
	desc9a	pr5|0,ql
	arg	pr3|0

	short_return		that was easy


" 
" " " " " " " " " " " " " " " " " " " " " " " " "
"
"	routine to scan for high bits in chars and return ptr to
"	matched char.
"
"	Input:
"	   stringp - points to string
"	   stringl - length
"	   bit - bit pattern looked for
"
"	Output:
"	   tally - number of chars to char with bit
"	   match - "1"b if bit matched
"
" " " " " " " " " " " " " " " " " " " " " " " " "

scm:	epp1	pr0|2,*		get ptr to arg ptr
	epp1	pr1|0,*		get ptr to arg block
	epp2	pr1|stringp,*	get ptr to string
	ldq	pr1|stringl	get string length
	stz	pr1|match		indicate initial failure

	lda	pr1|bit		look at the bit we want
	ana	=o400000,du	use it to select scm
	tnz	scm4		on, we want highest bit

	scm	(pr,rl),(pr),mask(577) off, we must want bit 8
	desc9a	pr2|0,ql
	arg	pr1|bit
	arg	pr1|tally
	tra	scm_ck		look at results

scm4:	scm	(pr,rl),(pr),mask(377) scan string for 9th bit
	desc9a	pr2|0,ql
	arg	pr1|bit
	arg	pr1|tally		result

scm_ck:	ttn	scm_done		no hits

	lda	=o400000,du	get flag bit
	sta	pr1|match		indicate success
scm_done:
	sbq	pr1|tally		reduce stringl
	stq	pr1|stringl	return to caller
	ldq	pr1|tally		fetch tally word
	a9bd	pr2|0,ql		bump stringp
	spri2	pr1|stringp	store for caller

	short_return

" 
" " " " " " " " " " " " " " " " " " " " " " " " "
"
"	routine to look for any char with bit 8 or 9 on.
"
"	Input:
"	   stringp - points to string
"	   stringl - length
"
"	Output:
"	   tally - number of chars up to bad one
"	   match - if bad one found "1"b
"
" " " " " " " " " " " " " " " " " " " " " " " " "

illegal_char:
	epp1	pr0|2,*		get ptr to ptr to block
	epp1	pr1|0,*		get ptr to block
	epp2	pr1|stringp,*	get ptr to string
	ldq	pr1|stringl	get length

	stz	pr1|match		zero return bit
	stq	pr1|tally		set max tally

	tsx2	find_high_bits	see if any high bits on
	tra	no_illegal_chars	none, continue

	lxl0	pr1|w1		get the result
	sxl0	pr1|tally		return
	lda	=o400000,du	get match bit
	sta	pr1|match
no_illegal_chars:
	sbq	pr1|tally		reduce stringl
	stq	pr1|stringl	return to caller
	ldq	pr1|tally		fetch tally word
	a9bd	pr2|0,ql		bump stringp
	spri2	pr1|stringp	store for caller

	short_return
" 
" " " " " " " " " " " " " " " " " " " " " " " " "
"
"	routine to do input tct function, similar to
"	find_char, but does only tct function
"
" " " " " " " " " " " " " " " " " " " " " " " " "

tct:	epp1	pr0|2,*		get ptr to arg ptr
	epp1	pr1|0,*		get ptr to arg block
	epp2	pr1|stringp,*	get ptr to string
	ldq	pr1|stringl	get string length
	stz	pr1|tally		zero the tally word

	epp3	pr1|tablep,*	get ptr to table
	tct	(pr,rl)		do the tct
	desc9a	pr2|0,ql
	arg	pr3|0
	arg	pr1|w2		result goes here

	ttn	tct_nohit		no good chars

	lda	pr1|w2		get the indicator value
	arl	27		shift down
	sta	pr1|indicator

	lxl0	pr1|w2		get the tally
	sxl0	pr1|tally
	ldq	pr1|tally		load tally for ptr update
	tra	tct_ptr_inc

tct_nohit:
	stq	pr1|tally		return whole string
	stz	pr1|indicator	no indicator

tct_ptr_inc:
	a9bd	pr2|0,ql
	spri2	pr1|stringp	return ptr
	lda	pr1|stringl	get string length
	sba	pr1|tally		reduce amount processed
	sta	pr1|stringl
	short_return
" 
" " " " " " " " " " " " " " " " " " " " " " " " "
"
"	internal proc to find high bits.
"	return+1 -> none found
"	return+2 -> high bit found
"
" " " " " " " " " " " " " " " " " " " " " " " " "

find_high_bits:
	scm	(pr,rl),(du),mask(377) look for chars with bit9 on
	desc9a	pr2|0,ql
	vfd	o9/400,27/0
	arg	pr1|w1		result here

	ttn	scm_other_bit	not this one try bit8

	szn	pr1|w1		did we hit on first char?
	tze	found_first_bit	yes, return

	scm	(pr,rl),(du),mask(577) look for bit8 on
	desc9a	pr2|0,ql
	vfd	o9/200,27/0
	arg	pr1|w2		save result

	ttn	check_which_bit	not bit8, must be bit9
	tra	found_other_bit

scm_other_bit:
	scm	(pr,rl),(du),mask(577) look for bit8 on
	desc9a	pr2|0,ql
	vfd	o9/200,27/0
	arg	pr1|w2		save result

	ttn	no_high_bits	good, neither bit8 or 9 was on

found_other_bit:
	szn	pr1|w2		did we hit first char?
	tnz	check_which_bit	no, find which one

	stz	pr1|w1		indicate offset of zero in w1
	tra	found_first_bit	return info

check_which_bit:
	lda	pr1|w2		get second count
	cmpa	pr1|w1		compare with first
	tpl	2,ic		more, use w1

	sta	pr1|w1		less use w2 as length
found_first_bit:
	tra	1,2		return

no_high_bits:
	stz	pr1|w1		reset the high bits indicator
	tra	0,2		return

	end




		    tty_write.pl1                   08/16/90  1225.9rew 08/16/90  1222.6      604683



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * 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(88-06-20,Berno), approve(88-07-13,MCR7928),
     audit(88-06-20,Parisek), install(88-07-19,MR12.2-1061):
     Modified code for implementing the UNCP multiplexer (DSA gateway)
     interface implementation.
  2) change(88-09-28,Brunelle), approve(88-01-26,MCR7813),
     audit(88-10-12,Blair), install(88-10-17,MR12.2-1171):
     Upgrade to TTT_version 4 with c_chars structure changing from 3 to 15
     chars.
  3) change(90-06-26,Schroth), approve(90-07-09,MCR8183),
     audit(90-07-31,WAAnderson), install(90-08-16,MR12.4-1024):
     Changed to ensure that the caller does not block indefinitely when output
     is subdivided and yields no real output (whitespace or edited out), to
     properly set current line counter upon FF or VT, and to free allocated
     buffer chains on crawlout.
                                                   END HISTORY COMMENTS */

/* format: style4,delnl,insnl,^ifthendo */
tty_write:
     proc (twx, a_readp, a_offset, a_nelem, a_nelemt, a_state, ercode);
						/* tty output conversion */


/* 	Date Last Modified and Reason

   Rewritten 11/3/75 by Robert S. Coren
   Modified 04/22/77 by J. Stern to introduce TCBs and WTCBs
   Modified July 78 by J. Nicholls to use channel_manager to write data out, to allow for implementation of multiplexing
   Modified fall of 1979 by Robert Coren to allocate automatic buffers in begin block
   Modified fall of 1979 by Robert Coren for output flow control
   Modified December 1979 by C. Hornig to fix bug in automatic stack frame allocation
   Modified December 1979 by Robert Coren to fix various bugs
   Call metering added October 1980 by Robert Coren
   White-space bug fixed November 1980 by Robert Coren
   write_set_mark entry added February 1981 by Robert Coren
   Modified March 1981 by Robert Coren to fix bugs with null end-of-page string
   Modified June 1981 by Robert Coren to add write_whole_string entry and keep global call count
   Modified June 1982 by Robert Coren to return MASKED state if appropriate
   Modified November 1982 by Robert Coren to return wtcb.error_code
   Modified October 1983 by E. N. Kittlitz for write_whole_string check longest_possible, not use a_offset
   Modified December 1983 by Robert Coren to set buffer tally before copying user data in case of crawlout
   Report on June 1983 - modifications for the Datanet 7100.f.d.
   Report on April 1984 - modifications for the 10.2 f.d.
   Date of the last modification - 17/04/84  
*/

/* PARAMETERS */

dcl  twx fixed bin;					/* device index */
dcl  a_readp ptr;					/* pointer to user's data */
dcl  a_offset fixed bin (21);				/* character to offset to add to readp */
dcl  a_nelem fixed bin (21);				/* number of characters supplied */
dcl  a_string char (*);				/* string to output (for write_set_mark entry) */
dcl  a_mark_flag bit (1);				/* whether to set a mark (write_whole_string entry) */
dcl  a_nelemt fixed bin (21);				/* number of characters shipped (OUTPUT) */
dcl  a_state fixed bin;				/* current state of channel (OUTPUT) */
dcl  ercode fixed bin (35);				/* status code (OUTPUT) */


/* AUTOMATIC */

dcl  state fixed bin;
dcl  devx fixed bin;				/* local copy of device index */
dcl  readp ptr;					/* local copy of a_readp */
dcl  offset fixed bin (21);				/* local copy of a_offset */
dcl  nelem fixed bin (21);				/* local copy of a_nelem */
dcl  nelemt fixed bin (21);				/* local copy of a_nelemt */

dcl  locked_entry bit (1);
dcl  forcesw bit (1);
dcl  mark_entry bit (1);
dcl  whole_string bit (1);

dcl  ttytp ptr;					/* pointer to tty_tables segment */
dcl  tctp ptr;					/* pointer to TCT table */
dcl  mvtp ptr;					/* pointer to translation table */
dcl  special_ptr ptr;				/* pointer to special chars table */
dcl  delay_ptr ptr;					/* pointer to delay table */
dcl  max_space fixed bin;				/* maximum number of words this guy can have */
dcl  max_chars fixed bin;				/* maximun number of character of output */
dcl  max_chars_in_buf fixed bin;			/* number of characters in maximum-size buffer */
dcl  input_ptr ptr;					/* pointer to user-supplied data */
dcl  final_outp ptr;				/* pointer to where output is to be taken from */
dcl  output_length fixed bin (21);			/* length of actual output in chars */

dcl  source_ptr ptr;
dcl  source_len fixed bin;
dcl  target_ptr ptr;
dcl  target_len fixed bin;

dcl  cap_source_ptr ptr;
dcl  cap_target_ptr ptr;
dcl  cap_tab_ptr ptr;
dcl  scanned_len fixed bin;

dcl  time_spent fixed bin (71);
dcl  start_time fixed bin (71);			/* clock time at entry */
dcl  chars_moved bit (1);
dcl  white_sw bit (1);
dcl  line_count fixed bin;				/* number of lines on page so far */
dcl  col fixed bin;					/* current column position */
dcl  wcol fixed bin;				/* column position after addition of white space */
dcl  oldcol fixed bin;
dcl  old_tally fixed bin;
dcl  seqp ptr;					/* pointer to output sequence */
dcl  i fixed bin;
dcl  xor bit (18);					/* used in switching buffer pointers */
dcl  shift bit (2);
dcl  new_char_count fixed bin;
dcl  old_head fixed bin (18);				/* old value of wtcb.write_first */
dcl  old_tail fixed bin (18);				/* old value of wtcb.write_last */
dcl  old_end_frame bit (1);				/* old value of wtcb.end_frame */
dcl  break_length fixed bin;				/* no. of characters before end-of-page */
dcl  break_flag bit (1) aligned;			/* indicates presence of end_of_page */
dcl  null_for_eop bit (1);				/* indicates sending NUL character to force end-of-page */
dcl  n_delays fixed bin;
dcl  back_chars fixed bin;				/* no. of characters required for backward carriage motion */
dcl  forward_chars fixed bin;				/* no. of characters required for forward carriage motion */
dcl  horiz float bin;
dcl  vert fixed bin;
dcl  ll fixed bin;					/* number of output characters on current line */
dcl  escape_index fixed bin;				/* index of output escape sequence */

dcl  headp ptr;
dcl  send bit (1);
dcl  new_head fixed bin;
dcl  n_pages fixed bin;
dcl  lastp ptr;

dcl  bufp ptr;
dcl  prevp ptr;
dcl  buf_size fixed bin;
dcl  orig_buf_size fixed bin;
dcl  reached_needed bit (1);
dcl  new_buffer_count fixed bin;
dcl  first_buffer bit (1);
dcl  old_lastp ptr;
dcl  words_needed fixed bin;
dcl  new_bufp ptr;
dcl  new_buf fixed bin;
dcl  chars_in_buf fixed bin;
dcl  lchar fixed bin;
dcl  old_char_count fixed bin;
dcl  nchars fixed bin;
dcl  cur_space fixed bin;
dcl  cur_chain_len fixed bin;
dcl  end_chain bit (1);
dcl  uncp_flag bit (1);				/* designate UNCP mpx */

dcl  1 util aligned,				/* structure passed to tty_util_ subroutines */
       2 stringp ptr,
       2 stringl fixed bin,
       2 ctally fixed bin,
       2 tablep ptr,				/* pointer to translation table */
       2 indicator fixed bin,				/* returned by tty_util_$find_char */
       2 pad (3) fixed bin;				/* workspace used by tty_util_ */

dcl  1 illegal_char_args aligned,
       2 ic_stringp ptr,
       2 ic_stringl fixed bin,
       2 ic_tally fixed bin,
       2 pad fixed bin,
       2 found_flag bit (1) aligned,
       2 pad2 (4) fixed bin;

dcl  auto_buf_len fixed bin;				/* internal buffer length */
dcl  allocated_buffers bit(1);			/* on if buffers have been obtained */

/* INTERNAL STATIC */

dcl  NOT_INTERESTING fixed bin int static options (constant) init (0);
dcl  NEW_LINE fixed bin int static options (constant) init (1);
dcl  CARRIAGE_RETURN fixed bin int static options (constant) init (2);
dcl  TAB_MULTIPLE_SPACE fixed bin int static options (constant) init (3);
dcl  BACK_SPACE fixed bin int static options (constant) init (4);
dcl  VERTICAL_TAB fixed bin int static options (constant) init (5);
dcl  FORM_FEED fixed bin int static options (constant) init (6);
dcl  OCTAL_ESCAPE fixed bin int static options (constant) init (7);
dcl  RED_SHIFT fixed bin int static options (constant) init (8);
dcl  BLACK_SHIFT fixed bin int static options (constant) init (9);
dcl  INSERT_NO_COUNT fixed bin int static options (constant) init (10);
dcl  INSERT_NO_COUNT_2 fixed bin int static options (constant) init (11);
dcl  SKIP fixed bin int static options (constant) init (12);
dcl  SPECIAL_ESCAPE fixed bin int static options (constant) init (16);

dcl  HUNG_UP fixed bin int static options (constant) init (1);
dcl  LISTENING fixed bin int static options (constant) init (2);
dcl  DIALED_UP fixed bin int static options (constant) init (5);
dcl  MASKED_STATE fixed bin int static options (constant) init (-1);

dcl  max_chain_len fixed bin int static init (16) options (constant);
dcl  reduction_factor float bin int static init (0.8) options (constant);
						/* for allowing for growth of user's string */
dcl  ascii_escape_octal bit (9) int static options (constant) init ("033"b3);
dcl  ascii_escape_char char (1) based (addr (ascii_escape_octal));
dcl  escape_char char (1) int static init ("\") options (constant);
dcl  backspace char (1) int static init ("") options (constant);
						/* backspace */
dcl  space char (1) int static init (" ") options (constant);
dcl  tab char (1) int static init ("	") options (constant);
						/* horizontal tab */
dcl  carriage_return char (1) int static init ("") /* carriage return */ options (constant);
dcl  nl char (1) int static options (constant) init ("
");						/* line feed */

dcl  num_array (0:7) char (1) int static options (constant) init ("0", "1", "2", "3", "4", "5", "6", "7");
						/* for octal escapes */
dcl  eop_sentinel_octal fixed bin (9) unsigned int static init (011111111b) options (constant);
						/* i.e., 377(8) */
dcl  eop_sentinel char (1);
dcl  cont_char char (1) int static init ("c") options (constant);
dcl  shifter (16) bit (1) int static options (constant) init ("0"b, (2) (1)"1"b, (13) (1)"0"b);
dcl  delay_char fixed bin int static options (constant) init (0);
dcl  upper_shift fixed bin int static options (constant) init (28);
						/* i.e., 34(8) */
dcl  lower_shift fixed bin int static options (constant) init (31);
						/* i.e., 37(8) */

dcl  lower_to_caps_edited (128) bit (9) int static options (constant)
	init ("000"b3, "001"b3, "002"b3, "003"b3, "004"b3, "005"b3, "006"b3, "007"b3, "010"b3, "011"b3, "012"b3,
	"013"b3, "014"b3, "015"b3, "016"b3, "017"b3, "020"b3, "021"b3, "022"b3, "023"b3, "024"b3, "025"b3, "026"b3,
	"027"b3, "030"b3, "031"b3, "032"b3, "033"b3, "034"b3, "035"b3, "036"b3, "037"b3, "040"b3, "041"b3, "042"b3,
	"043"b3, "044"b3, "045"b3, "046"b3, "047"b3, "050"b3, "051"b3, "052"b3, "053"b3, "054"b3, "055"b3, "056"b3,
	"057"b3, "060"b3, "061"b3, "062"b3, "063"b3, "064"b3, "065"b3, "066"b3, "067"b3, "070"b3, "071"b3, "072"b3,
	"073"b3, "074"b3, "075"b3, "076"b3, "077"b3, "100"b3, "101"b3, "102"b3, "103"b3, "104"b3, "105"b3, "106"b3,
	"107"b3, "110"b3, "111"b3, "112"b3, "113"b3, "114"b3, "115"b3, "116"b3, "117"b3, "120"b3, "121"b3, "122"b3,
	"123"b3, "124"b3, "125"b3, "126"b3, "127"b3, "130"b3, "131"b3, "132"b3, "133"b3, "134"b3, "135"b3, "136"b3,
	"137"b3, "140"b3, "101"b3, "102"b3, "103"b3, "104"b3, "105"b3, "106"b3, "107"b3, "110"b3, "111"b3, "112"b3,
	"113"b3, "114"b3, "115"b3, "116"b3, "117"b3, "120"b3, "121"b3, "122"b3, "123"b3, "124"b3, "125"b3, "126"b3,
	"127"b3, "130"b3, "131"b3, "132"b3, "173"b3, "174"b3, "175"b3, "176"b3, "177"b3);

dcl  lower_to_caps_nonedited (128) bit (9) int static options (constant)
	init ("000"b3, "001"b3, "002"b3, "003"b3, "004"b3, "005"b3, "006"b3, "007"b3, "010"b3, "011"b3, "012"b3,
	"013"b3, "014"b3, "015"b3, "016"b3, "017"b3, "020"b3, "021"b3, "022"b3, "023"b3, "024"b3, "025"b3, "026"b3,
	"027"b3, "030"b3, "031"b3, "032"b3, "033"b3, "034"b3, "035"b3, "036"b3, "037"b3, "040"b3, "041"b3, "042"b3,
	"043"b3, "044"b3, "045"b3, "046"b3, "047"b3, "050"b3, "051"b3, "052"b3, "053"b3, "054"b3, "055"b3, "056"b3,
	"057"b3, "060"b3, "061"b3, "062"b3, "063"b3, "064"b3, "065"b3, "066"b3, "067"b3, "070"b3, "071"b3, "072"b3,
	"073"b3, "074"b3, "075"b3, "076"b3, "077"b3, "100"b3, "501"b3, "502"b3, "503"b3, "504"b3, "505"b3, "506"b3,
	"507"b3, "510"b3, "511"b3, "512"b3, "513"b3, "514"b3, "515"b3, "516"b3, "517"b3, "520"b3, "521"b3, "522"b3,
	"523"b3, "524"b3, "525"b3, "526"b3, "527"b3, "530"b3, "531"b3, "532"b3, "133"b3, "134"b3, "135"b3, "136"b3,
	"137"b3, "140"b3, "101"b3, "102"b3, "103"b3, "104"b3, "105"b3, "106"b3, "107"b3, "110"b3, "111"b3, "112"b3,
	"113"b3, "114"b3, "115"b3, "116"b3, "117"b3, "120"b3, "121"b3, "122"b3, "123"b3, "124"b3, "125"b3, "126"b3,
	"127"b3, "130"b3, "131"b3, "132"b3, "173"b3, "174"b3, "175"b3, "176"b3, "177"b3);

/* The following declaration is hopefully temporary until prefix characters are encoded in conversion tables */

dcl  prefix char (1) int static init (">") options (constant);
						/* = 076 = 2741 prefix character */

declare LONGEST_POSSIBLE_STRING fixed bin init (8128) int static options (constant);

/* ENTRIES */

dcl  pxss$ring_0_wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  tty_lock$lock_channel entry (fixed bin, fixed bin (35)),
     tty_lock$unlock_channel entry (fixed bin);

dcl  tty_index$initialize_tcb entry (ptr, ptr);
dcl  tty_util_$mvt entry (ptr);
dcl  tty_util_$scm entry (ptr);
dcl  tty_util_$find_char entry (ptr);
dcl  tty_util_$illegal_char entry (ptr);


/* BASED */

dcl  1 mvt_args aligned based (addr (util)),		/* overlay of tty_util_ structure used for mvt entry */
       2 stringptr ptr,
       2 stringlen fixed bin,
       2 pad fixed bin,
       2 tablep ptr,
       2 targetp ptr;

dcl  1 scm_args aligned based (addr (util)),		/* overlay of util structure used for scm entry */
       2 stringptr ptr,
       2 stringlen fixed bin,
       2 scm_tally fixed bin,
       2 search_mask bit (2) aligned,
       2 found_flag bit (1) aligned;

dcl  based_onechar char (1) based;
dcl  based_chars (0:1) char (1) based unal;		/* used for bumping string pointers */

dcl  output_chars char (output_length) based;
dcl  tally_chars char (ctally) based;
dcl  chars_to_copy char (nchars) based;

dcl  1 seq based aligned like c_chars;				/* template of special chars sequence */

/* EXTERNAL STATIC */

dcl  tty_tables$ ext static;
dcl  error_table_$improper_data_format fixed bin (35) ext static;
dcl  error_table_$invalid_device fixed bin (35) ext static;
dcl  error_table_$io_no_permission fixed bin (35) ext static;
dcl  error_table_$line_status_pending fixed bin (35) ext static;
dcl  error_table_$noalloc fixed bin (35) ext static;
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$bigarg fixed bin (35) ext static;
dcl  pds$processid bit (36) ext static;


dcl  (addr, bin, bool, byte, clock, divide, fixed, float, hbound, index, length, max,
     min, mod, null, ptr, rank, rel, reverse, string, substr, unspec) builtin;

dcl  cleanup condition;

%include tty_convert;

%include tty_buf;

%include tty_buffer_block;
%include wtcb;

%include tcb;

%include lct;

%include tty_space_man_dcls;

%include channel_manager_dcls;
%include multiplexer_types;
%include net_event_message;

	locked_entry = "0"b;
	forcesw = "0"b;				/* normal call, check buffer limit */
	go to join;

/* privileged entry to bypass buffer limit check - thru hphcs_ - used by answering service */

tty_write_force:
     entry (twx, a_readp, a_offset, a_nelem, a_nelemt, a_state, ercode);

	locked_entry = "0"b;
	go to force_join;


/* entry used to write whole output string or nothing, and optionally set a mark */

tty_write_whole_string:
     entry (twx, a_string, a_mark_flag, a_nelemt, a_state, ercode);

	locked_entry, forcesw = "0"b;
	mark_entry = a_mark_flag;
	whole_string = "1"b;
	go to set_nelem;


/* entry used when sending prompts and questions to distinguish between type-ahead and response */

tty_write_set_mark:
     entry (twx, a_string, a_nelemt, a_state, ercode);

	whole_string, locked_entry, forcesw = "0"b;
	mark_entry = "1"b;
set_nelem:
	nelem = length (a_string);
	offset = 0;
	readp = addr (a_string);
	go to mark_join;



/* special internally-known entry which is called with channel already locked */

locked:
     entry (twx, a_readp, a_offset, a_nelem, a_nelemt, a_state, ercode);

	locked_entry = "1"b;			/* mark it as this entry so we don't lock/unlock */

force_join:
	forcesw = "1"b;

join:
	nelem = a_nelem;
	readp = a_readp;
	whole_string, mark_entry = "0"b;
	offset = a_offset;

mark_join:
	start_time = clock ();
	nelemt = 0;
	a_nelemt = 0;
	a_state = 0;
	ercode = 0;
	ttybp = addr (tty_buf$);			/* get ptrs to tty_buf, tty_data */

	devx = twx;				/* copy device index */
	lctp = tty_buf.lct_ptr;			/* init pointer to lct */
	if devx < 1 | devx > lct.max_no_lctes
	then do;
	     ercode = error_table_$invalid_device;
	     return;
	end;

	uncp_flag = is_parent_mpx (UNCP_MPX);

	if ^locked_entry
	then do;
	     call tty_lock$lock_channel (devx, ercode);	/* lock the channel lock */
	     if ercode ^= 0
	     then return;
	end;

	allocated_buffers = "0"b;
	on cleanup
	begin;
	     if allocated_buffers
	     then do;
		allocated_buffers = "0"b;		/* don't try again */
		call free_buffers;
	     end;
	     if ^locked_entry
	     then call tty_lock$unlock_channel (devx);
	end;					/* cleanup block */

	lctep = addr (lct.lcte_array (devx));		/* get entry of interest */
	if lcte.channel_type ^= TTY_MPX		/* not our type */
	then do;
no_permission:
	     ercode = error_table_$io_no_permission;
	     go to unlock;
	end;

	wtcbp = lcte.data_base_ptr;			/* get pointers to control blocks */
	tcbp = wtcb.tcb_ptr;			/* get tcb pointer */
	if ^wtcb.tcb_initialized
	then call tty_index$initialize_tcb (wtcbp, tcbp);

	if pds$processid ^= wtcb.hproc
	then if (pds$processid ^= wtcb.uproc) | ^tcb.uproc_attached
	     then go to no_permission;

	if wtcb.flags.dialed
	then state = DIALED_UP;
	else if wtcb.flags.listen
	then state = LISTENING;
	else if wtcb.flags.masked
	then state = MASKED_STATE;
	else state = HUNG_UP;

	if state ^= DIALED_UP
	then do;
	     if pds$processid = wtcb.hproc
	     then a_state = state;
	     go to no_permission;
	end;

	a_state = state;

	if wtcb.flags.line_status_present
	then do;
	     ercode = error_table_$line_status_pending;
	     go to unlock;
	end;

	if wtcb.error_code ^= 0
	then do;
	     ercode = wtcb.error_code;
	     wtcb.error_code = 0;
	     go to unlock;
	end;

	if nelem < 0
	then do;
	     ercode = error_table_$bad_arg;
	     go to unlock;
	end;
						/* Added for the Datanet 7100. */
	if uncp_flag then do;
	     if readp = addr (wtcb.prompt)
		then do;
		wtcb.send_turn = "1"b;
		if nelem = 0
		     then do;
		     if wtcb.write_last ^= 0
			then do;
			blockp = ptr (ttybp, wtcb.write_last);
			buffer.turn = "1"b;
			wtcb.send_turn = "0"b;
		     end;
		end;
	     end;
	end;

	ercode = 0;
	if nelem = 0
	then go to all_done;

	eop_sentinel = byte (eop_sentinel_octal);

	if ^tcb.modes.rawom				/* if we're interested in conversion */
	then do;
	     ttytp = addr (tty_tables$);
	     if tcb.output_tctrp = ""b
	     then tctp = null;
	     else tctp = ptr (ttytp, tcb.output_tctrp);
	     if tcb.output_mvtrp = ""b
	     then mvtp = null;
	     else mvtp = ptr (ttytp, tcb.output_mvtrp);
	     if tcb.specialrp = ""b
	     then special_ptr = null;
	     else special_ptr = ptr (ttytp, tcb.specialrp);
	     if tcb.delayrp = ""b
	     then delay_ptr = null;
	     else delay_ptr = ptr (ttytp, tcb.delayrp);
	end;

/**/
/* calculate number of buffers line is allowed to have */

	if forcesw
	then max_space = tty_buf.bleft - 32;		/* force entry can have as many as it needs */
	else do;
	     cur_space = 0;
	     cur_chain_len = 0;
	     if wtcb.write_first ^= 0
	     then do;
		blockp = ptr (ttybp, wtcb.write_first);
		end_chain = "0"b;
		do while (^end_chain);
		     cur_space = cur_space + 16 * (buffer.size_code + 1);
		     cur_chain_len = cur_chain_len + 1;
		     if buffer.next = 0
		     then end_chain = "1"b;
		     else blockp = ptr (ttybp, buffer.next);
		end;
	     end;
	     max_space =
		min (divide (tty_buf.bleft, output_bpart, 17, 0) - cur_space,
		(max_chain_len - cur_chain_len) * (wtcb.max_buf_size - 1));
	end;

	max_chars_in_buf = 4 * (wtcb.max_buf_size - 1) - wtcb.buffer_pad;

	if max_space <= 0
	then 
NO_SPACE_WRITE_NOTHING:
	do;
	     nelemt = 0;
	     go to nothing_written;
	end;					/* otherwise only certain fraction can be allocated */

	max_chars = min (4 * max_space, LONGEST_POSSIBLE_STRING);	/* don't overflow tty_buf or the stack */

/* Determine good sizes for internal automatic buffers for the duration of this call */
/* max_chars takes account of all policy limitations */

	auto_buf_len = min (max_chars, 512 + 2 * nelem);	/* leave lots of leeway */
	max_chars = auto_buf_len;
	if whole_string & nelem > max_chars		/* can't possibly take all of this */
	then do;
	     if nelem <= LONGEST_POSSIBLE_STRING
	     then go to NO_SPACE_WRITE_NOTHING;
	     ercode = error_table_$bigarg;
	     go to unlock;
	end;

	begin;					/* giant begin block */

dcl  buffer_1 char (auto_buf_len) aligned;		/* first internal workspace buffer */
dcl  buffer_2 char (auto_buf_len) aligned;		/* second internal workspace buffer */

	     input_ptr = readp;
	     input_ptr = addr (input_ptr -> based_chars (offset));

	     nelemt = -1;				/* to indicate first time around */

restart:						/* come here if we have to start over */
	     if tcb.modes.rawom			/* raw output, simple */
	     then do;
		final_outp = input_ptr;		/* copy straight from user's data */
		if nelemt < 0			/* i.e. not restart */
		then nelemt = min (nelem, max_chars);
		output_length = nelemt;
	     end;

	     else do;				/* else we must massage the input */
		if nelemt < 0			/* if not already set */
		then nelemt = min (nelem, fixed (reduction_factor * max_chars));

		line_count = wtcb.actline;
		col = wtcb.actcol;
		wcol = wtcb.white_col;

		final_outp, source_ptr = input_ptr;	/* to begin with */
		source_len = nelemt;
		target_ptr = addr (buffer_1);
		target_len = 0;

		if tcb.modes.upper_case
		then call convert_to_upper_case;	/* translate lower-case to caps? */

/* ** FORMATTING ** */

		if tctp ^= null			/* must have output conversion table */
		     & special_ptr ^= null		/* and special chars table too */
		then do;
		     target_len = 0;		/* initially */
		     chars_moved = "0"b;
		     white_sw = (wcol ^= col);	/* depends on whether there's white space left from last call */

		     final_outp = target_ptr;		/* where we expect stuff to end up */

		     if tcb.linemax > 0
		     then do;
			if line_count >= tcb.linemax	/* did input cause EOP condition ? */
			then do;			/* yes, write eop sequence now */
			     seqp = addr (special_ptr -> special_chars.end_of_page);
			     if seqp -> seq.count > 0	/* must have something to write */
			     then do;
				call insert_sequence ("0"b);
				call insert_char (eop_sentinel);
				line_count = 0;
			     end;
			end;
		     end;

		     util.tablep = tctp;		/* formatting table */
		     util.stringp = source_ptr;
		     util.stringl = source_len;

		     do while (util.stringl > 0);	/* main formatting loop */

			oldcol = col;
			call tty_util_$find_char (addr (util));
						/* find next interesting character */

			call move_formated_chars;

			if ^white_sw
			then wcol = col;		/* so next white-space calculation will be right */

		     end;				/* end of formatting loop */

		     if white_sw			/* take care of trailing white space */
		     then if nelemt = nelem		/* if output really ends in white space */
			then call insert_white;
			else if target_len = 0	/* only white? */
			     then call insert_white;	/* expand it */

		end;

		else target_len = source_len;		/* no conversion performed */

		if mvtp ^= null
		then call translation;		/* translation required */

		output_length = target_len;
	     end;					/* end of all conversion phases */

/* ****ALLOCATE BUFFERS AND PASS OUTPUT ON*** */

	     new_char_count, new_buffer_count = 0;

	     if output_length > 0			/* assuming there's anything left after conversion */
	     then do;
		first_buffer = "1"b;
		old_end_frame = wtcb.end_frame;

		if wtcb.write_last = 0
		then do;
		     send = "1"b;			/* there's nothing ahead of it, so we'll send it on */
		     old_head, old_tail = 0;
		end;

		else do;				/* save information about old chain */
		     lastp, old_lastp = ptr (ttybp, wtcb.write_last);
		     send = "0"b;			/* we'll just hang on to this */
		     old_head = wtcb.write_first;
		     old_tail = wtcb.write_last;
		end;

		n_pages = 0;
		headp = null;
		new_head = 0;
		allocated_buffers = "1"b;		/* crawlout can now safely free them */

		do while (output_length > 0);		/* copy for as long as necessary */
		     n_pages = n_pages + 1;

		     if tcb.modes.rawom		/* if raw mode don't check for end of page */
		     then go to no_break;

		     break_length = index (final_outp -> output_chars, eop_sentinel) - 1;
						/* look for page break */
		     if break_length < 0
		     then do;
no_break:
			break_flag = "0"b;		/* no end-of-page markers */
			break_length = output_length;
		     end;

		     else do;
			break_flag = "1"b;
			if break_length = 0
			then do;			/* eop sentinel was first thing */
			     final_outp -> based_chars (0) = byte (delay_char);
						/* send out a NUL because we have to send something to alert lower level */
			     break_length = 1;
			     null_for_eop = "1"b;
			end;
			else null_for_eop = "0"b;
		     end;

		     if tcb.block_acknowledge & tcb.oflow & tcb.max_output_block > 0
						/* new buffer at every end-of-block */
		     then break_length = min (break_length, tcb.max_output_block);

		     output_length = output_length - break_length;

		     do while (break_length > 0);

/* do we have a buffer with room in it? */

			if wtcb.write_last = 0
			then go to get_new_buf;
			if lastp -> buffer.tally < max_chars_in_buf & ^lastp -> buffer.flags.end_of_page
			     & ^(tcb.block_acknowledge & tcb.oflow & tcb.max_output_block > 0)
			then do;
			     lchar = lastp -> buffer.tally;

/* make new buffer as big as appropriate */

			     buf_size, orig_buf_size = 16 * (lastp -> buffer.size_code + 1);
			     reached_needed = "0"b;	/* assume not yet reached appropriate size */
			     do while (^reached_needed);
				chars_in_buf = 4 * (buf_size - 1) - wtcb.buffer_pad;
				if lchar + break_length <= chars_in_buf
						/* room in this buffer for rest of output */
				     | chars_in_buf = max_chars_in_buf
						/* or we've already reached maximum allowable size */
				then reached_needed = "1"b;
				else buf_size = buf_size + 16;
						/* try next size */
			     end;

			     if buf_size ^= orig_buf_size
						/* if we need a new size */
			     then do;		/* get new buffer, and copy contents of old one */
				call tty_space_man$get_buffer (devx, buf_size, OUTPUT, new_bufp);
				if new_bufp ^= null /* only do this if we could get it, of course */
				then do;
				     nchars = lastp -> buffer.tally;
				     source_ptr = addr (lastp -> buffer.chars (0));
				     target_ptr = addr (new_bufp -> buffer.chars (0));
				     target_ptr -> chars_to_copy = source_ptr -> chars_to_copy;
				     new_bufp -> buffer.tally = lastp -> buffer.tally;
				     wtcb.write_last = bin (rel (new_bufp), 18);
						/* this will now be end of chain */

						/* Add for the Datanet 7100. */
				     if uncp_flag then new_bufp -> buffer.turn = lastp -> buffer.turn;
						/* copy turn flag into new buffer */

/* thread new buffer onto end of chain in place of old one */

				     prevp = ptr (ttybp, wtcb.write_first);
						/* start at head */
				     if prevp = lastp
						/* is it tail also? */
				     then wtcb.write_first = wtcb.write_last;
						/* that's simple */
				     else do;	/* else we'll scan the chain */
					do prevp = prevp repeat ptr (ttybp, prevp -> buffer.next)
					     while (prevp -> buffer.next ^= bin (rel (lastp), 18)
					     & prevp -> buffer.next ^= 0);
					end;
					prevp -> buffer.next = wtcb.write_last;
						/* found the next-to-last one */
				     end;

				     call tty_space_man$free_buffer (devx, OUTPUT, lastp);
						/* give the old one back */
				     lastp = new_bufp;

				     if first_buffer
				     then do;
					old_lastp = lastp;
					old_tail = wtcb.write_last;
					if wtcb.write_first = wtcb.write_last
					then old_head = wtcb.write_first;
				     end;
				end;

				else chars_in_buf = 4 * (orig_buf_size - 1) - wtcb.buffer_pad;
						/* couldn't get bigger buffer, use original size */
			     end;

			     bufp = addr (lastp -> buffer.chars (lchar));
			     old_char_count = lastp -> buffer.tally;
			     nchars = min (break_length, chars_in_buf - lchar);
			end;

			else do;			/* no, we'll have to get one */
get_new_buf:
			     words_needed =
				max (16,
				min (wtcb.max_buf_size,
				16 * divide (break_length + wtcb.buffer_pad + 67, 64, 17, 0)));
			     call tty_space_man$get_buffer (devx, words_needed, OUTPUT, new_bufp);
			     if new_bufp = null	/* couldn't get the space */
			     then go to free_and_try_again;
			     new_buf = bin (rel (new_bufp), 18);
			     chars_in_buf = 4 * (words_needed - 1) - wtcb.buffer_pad;

			     if first_buffer
			     then do;
				new_head = new_buf;
				first_buffer = "0"b;
			     end;

			     new_buffer_count = new_buffer_count + 1;
			     lchar = 0;
			     if wtcb.write_last ^= 0	/* chain already abuilding */
			     then lastp -> buffer.next = new_buf;
			     else wtcb.write_first = new_buf;

			     wtcb.write_last = new_buf;
						/* in any case */
			     lastp = new_bufp;
			     string (lastp -> buffer.flags) = "0"b;

			     old_char_count = 0;
			     bufp = addr (lastp -> buffer.chars (0));
			     nchars = min (break_length, chars_in_buf);
			end;

			lastp -> buffer.tally = old_char_count + nchars;
			lastp -> buffer.flags.break = "0"b;
						/* not at end of user data */
			bufp -> chars_to_copy = final_outp -> chars_to_copy;
						/* put characters in buffer */
			final_outp = addr (final_outp -> based_chars (nchars));
			new_char_count = new_char_count + nchars;
			break_length = break_length - nchars;

						/* Add for the Datanet 7100. */
			if uncp_flag then do;
			     if break_length = 0
				then do;
				lastp -> buffer.turn = wtcb.send_turn;
				wtcb.send_turn = "0"b;
			     end;
			end;
		     end;


		     if break_flag			/* did we stop because of end-of-page? */
		     then do;
			lastp -> buffer.flags.end_of_page = "1"b;
			if ^null_for_eop		/* if we haven't laready skipped over sentinel */
			then do;
			     final_outp = addr (final_outp -> based_chars (1));
						/* skip over sentinel */
			     output_length = output_length - 1;
			end;
		     end;

		     if tcb.block_acknowledge & tcb.oflow & tcb.max_output_block > 0
		     then do;			/* insert end_of_block char */
			if lastp -> buffer.tally < chars_in_buf
						/* it'll fit in last buffer */
			then do;
			     lastp -> buffer.chars (lastp -> buffer.tally) =
				substr (tcb.output_suspend_etb_seq.chars, 1, 1);
			     lastp -> buffer.tally = lastp -> buffer.tally + 1;
			end;

			else do;			/* unfortunately, we have to allocate a whole buffer for this char */
			     call tty_space_man$get_buffer (devx, 16, OUTPUT, new_bufp);
			     if new_bufp = null
			     then go to free_and_try_again;
			     string (new_bufp -> buffer.flags) = "0"b;
			     new_bufp -> buffer.tally = 1;
			     new_bufp -> buffer.chars (0) = substr (tcb.output_suspend_etb_seq.chars, 1, 1);
			     wtcb.write_last, lastp -> buffer.next = bin (rel (new_bufp), 18);
			     lastp = new_bufp;
			end;
		     end;
		end;				/* end of buffer-allocation loop */

		if nelem = nelemt
		then do;
		     lastp -> buffer.flags.break = "1"b;/* end of user data */
		     lastp -> buffer.flags.mark = mark_entry;
		end;

		if send & wtcb.send_output		/* if this is first new output, we'll pass it on */
		then do;
		     if n_pages > 1
		     then do;			/* peel off first page if there's more than one */
			blockp = ptr (ttybp, wtcb.write_first);

			do while (^buffer.end_of_page & buffer.next ^= 0);
						/* find last buffer of page */
			     blockp = ptr (ttybp, buffer.next);
			end;

			lastp = blockp;		/* this is it */
		     end;

		     else lastp = ptr (ttybp, wtcb.write_last);
						/* if only 1 page, last buffer is last buffer of page */
		     if mark_entry
		     then wtcb.mark_set = lastp -> buffer.mark;
						/* we're sending the mark now */
		     new_head = lastp -> buffer.next;	/* this will be the head of the remaining chain (if any) */
		     headp = ptr (ttybp, wtcb.write_first);
		     wtcb.write_first = lastp -> buffer.next;
						/* update wtcb pointers now (we'll restore them if necessary) */
		     if wtcb.write_first = 0
		     then wtcb.write_last = 0;	/* ensure consistency always */
		     lastp -> buffer.next = 0;	/* break the chain at page end */
		     wtcb.end_frame = lastp -> buffer.end_of_page;

		     call channel_manager$write (devx, headp, ercode);
		     if ercode = error_table_$noalloc
		     then do;
			nelemt = 0;		/* this means they couldn't take it at all */
			call free_buffers;
			go to nothing_written;
		     end;
		     else do;
			if ercode ^= 0
			then do;
			     call free_buffers;	/* get rid of anything we've got left (it's unwritable) */
			     if wtcb.write_first ^= 0 /* and I mean ANYTHING */
			     then do;
				call tty_space_man$free_chain (devx, OUTPUT, ptr (ttybp, wtcb.write_first));
				wtcb.write_first, wtcb.write_last = 0;
				wtcb.mark_set = "0"b;
						/* all bets are off */
			     end;
			end;

			else if headp ^= null
			then do;			/* didn't take it all */
			     wtcb.write_first = bin (rel (headp));
			     blockp = headp;
			     do while (buffer.next ^= 0);
						/* find end of returned chain */
				blockp = ptr (ttybp, buffer.next);
			     end;

			     buffer.next = new_head;	/* hook it back on */
			     if wtcb.write_last = 0	/* sent all we had */
			     then wtcb.write_last = bin (rel (blockp));
						/* this is now end of the chain */

			     if mark_entry
			     then wtcb.mark_set = "0"b;
						/* override any previously-set mark */
			end;
			wtcb.send_output = "0"b;	/* no more till he asks for it */
		     end;
		end;
	     end;

	     if ^tcb.modes.rawom
	     then do;				/* only if messed around with it */
		wtcb.actcol = col;
		wtcb.actline = line_count;
		wtcb.white_col = wcol;
	     end;

	     if nelemt < nelem
	     then do;				/* we couldn't get them all out this time */
		i = (nelem - nelemt);		/* approximate num of chars left to output */
		if tty_buf.minbuf = 0 | tty_buf.minbuf > i
		then tty_buf.minbuf = i;		/* if new minimum, set it */

		tty_buf.totbuf = tty_buf.totbuf + i;	/* set blocked-for-write meters  */
		tty_buf.nblocked = tty_buf.nblocked + 1;

		/*** If we did not consume all of our caller's output but
		generated no output, ensure that the process sees a wakeup
		so that the rest of the output will be handled. */
		
		if wtcb.send_output			/* nothing in progress */
		then do;
		     unspec (net_event_message) = "0"b;
		     net_event_message.version = NET_EVENT_MESSAGE_VERSION_1;
		     net_event_message.network_type = MCS_NETWORK_TYPE;
		     net_event_message.handle = devx;
		     net_event_message.type = MCS_WRITE_MSG;
		     call pxss$ring_0_wakeup (wtcb.uproc, wtcb.event, net_event_message_arg, (0));
		     wtcb.wflag = "0"b;
		end;
		else wtcb.flags.wflag = "1"b;		/* so wakeup will happen when write completes */
	     end;

	     tcb.cumulative_meters.write_chars = tcb.cumulative_meters.write_chars + nelemt;
	     tcb.cumulative_meters.write_calls = tcb.cumulative_meters.write_calls + 1;
	     tty_buf.write_calls = tty_buf.write_calls + 1;
	     tty_buf.noutchars = tty_buf.noutchars + nelemt;
						/* keep count of output chars per type */
	     tty_buf.nrawwrite = tty_buf.nrawwrite + new_char_count;
	     go to all_done;

free_and_try_again:					/* here if we or next level couldn't allocate buffers */
	     call free_buffers;
	     tty_buf.output_buffer_overflow = tty_buf.output_buffer_overflow + 1;
try_again:					/* here if we overflowed internal buffer space */
	     if whole_string			/* mustn't subdivide caller's string */
	     then do;
		nelemt = 0;
		go to nothing_written;
	     end;

	     tty_buf.output_restart = tty_buf.output_restart + 1;

	     nelemt = divide (nelemt, 2, 18, 0);	/* cut in half to try again */
	     if nelemt > 0				/* does that leave us anything to process? */
	     then go to restart;
	     else go to nothing_written;



/* *** ERROR BRANCH FOR FAULTY TABLE VALUES *** */

table_error:
	     ercode = error_table_$improper_data_format;
	     go to unlock;

/* ***********INTERNAL PROCEDURES********* */

copy_chars:
     proc;

/* This procedure copies ctally characters form source_ptr to target_ptr */

	target_len = target_len + ctally;
	if target_len > max_chars			/* check for overflow */
	then go to try_again;

	target_ptr -> tally_chars = source_ptr -> tally_chars;

	source_ptr = addr (source_ptr -> based_chars (ctally));
						/* bump pointers */
	target_ptr = addr (target_ptr -> based_chars (ctally));
	return;

     end /* copy_chars */;

insert_char:
     proc (one_char);

/* This procedure places a single character in the output string */

dcl  one_char char (1);

	target_len = target_len + 1;
	if target_len > max_chars			/* mustn't overflow buffer space */
	then go to try_again;

	target_ptr -> based_onechar = one_char;
	target_ptr = addr (target_ptr -> based_chars (1));
	return;

     end /* insert_char */;

insert_delays:
     proc (ndelays);

/* This procedure inserts a specified number of delay characters into the output */

dcl  ndelays fixed bin;
dcl  i fixed bin;

	if ndelays <= 0
	then return;				/* nothing to do */

	target_len = target_len + ndelays;
	if target_len > max_chars			/* red warning */
	then go to try_again;			/* tough */

	do i = 0 to ndelays - 1;			/* remember based_chars starts at 0 */
	     target_ptr -> based_chars (i) = byte (delay_char);
	end;

	target_ptr = addr (target_ptr -> based_chars (ndelays));
						/* bump pointer */
	return;

     end /* insert_delays */;

insert_sequence:
     proc (a_col_sw);

/* This procedure inserts the character sequence pointed to by seqp */
/* col_sw tells whether or not to check for overflowing line-length */

dcl  a_col_sw bit (1) aligned;
dcl  col_sw bit (1) aligned;
dcl  i fixed bin;
dcl  auto_len fixed bin;

	col_sw = a_col_sw;
	c_chars_ptr = seqp;				/* make compiler happy */
	auto_len = seqp -> seq.count;			/* copy sequence length into automatic */
	if auto_len = 0
	then return;				/* no sequence */

	if auto_len < 0 | auto_len > hbound (c_chars.chars, 1)/* probably not a real sequence */
	then go to table_error;

	target_len = target_len + auto_len;
	if target_len > max_chars
	then go to try_again;

	if seqp -> seq.chars (1) = ascii_escape_char
	then col_sw = "0"b;				/* if escape sequence, best not to mess with the columns */
	do i = 1 to auto_len;
	     if col_sw				/* do we care about column position? */
	     then do;				/* yes */
		if seqp -> seq.chars (i) = backspace	/* back up with delays in this case */
		then do;
		     col = max (0, col - 1);
		     if delay_ptr ^= null
		     then call insert_delays (delay_ptr -> delay.backspace);
		end;

		else if rank (seqp -> seq.chars (i)) < 32
		then ;				/* if so, then probably doesn't move carriage */
						/* adding 0 is just as good as + 1 when we don't know what
						   the chars really do to the terminal */

		else do;
		     if ((tcb.colmax > 0) & (col >= tcb.colmax))
		     then call insert_nl ("1"b);
		     col = col + 1;
		end;
	     end;

	     target_ptr -> based_onechar = seqp -> seq.chars (i);
	     target_ptr = addr (target_ptr -> based_chars (1));
						/* bump pointer */
	end;

	return;

     end /* insert_sequence */;

insert_white:
     proc;

/* this procedure puts white space into the output string */

	if wcol ^= col				/* make sure we're not already where we belong */
	then do;
	     if tcb.colmax > 0
	     then do while (wcol > tcb.colmax);		/* put in any necessary new-lines */
		call insert_nl ("1"b);
		oldcol = 2;
		wcol = wcol - tcb.colmax + 2;
	     end;

	     if wcol < col				/* we're going to have to back up */
	     then if wcol = 0			/* that one's easy */
		then call insert_cr;		/* just put in carriage return */

		else if special_ptr -> special_chars.cr_seq.count > 0
		then do;				/* figure out which way to back up */
		     back_chars = col - wcol;		/* that's how many backspaces it would take */
		     if back_chars <= 6		/* in this case don't bother calculating other */
		     then forward_chars = back_chars;	/* to make sure test will fail */
		     else if tcb.modes.tabm
		     then forward_chars = divide (wcol, 10, 17, 0) + mod (wcol, 10) + 1;
						/* tabs + spaces + cr */
		     else forward_chars = wcol + 1;	/* spaces + cr */

		     if back_chars - forward_chars > 6 | special_ptr -> special_chars.bs_seq.count = 0
						/* no backspace available */
		     then call insert_cr;		/* thereby setting col to 0, we'll do forward later */
		     else call insert_bs (back_chars);	/* put in necessary number of backspaces */
		end;

		else call insert_bs (col - wcol);

	     if wcol > col				/* we have to go forward */
	     then do;
		if tcb.modes.tabm			/* might we use tabs? */
		then do;
		     do while (wcol - col > 10);	/* tabs are relevant */
			call insert_tab;		/* will update col */
		     end;

		     if mod (wcol, 10) <= mod (col, 10) /* room for another tab */
		     then call insert_tab;
		end;

		do col = col by 1 while (col < wcol);
		     call insert_char (space);	/* put in spaces as required */
		end;
	     end;
	end;

	oldcol = wcol;
	white_sw = "0"b;				/* we've done it now */
	return;

     end /* insert_white */;

insert_nl:
     proc (esc_sw);

/* This procedure inserts new-line sequences in the output string */
/* esc_sw indicates whether a "\c" sequence should be added */

dcl  esc_sw bit (1) aligned;
dcl  delay_before bit (1) aligned;
dcl  eop_sw bit (1) aligned;
dcl  eop_seqp ptr;
dcl  seqp ptr;
dcl  based_target_chars char (target_len) based;

	eop_sw = "0"b;
	eop_seqp = null;

	if tcb.linemax > 0
	then do;
	     line_count = line_count + 1;
	     eop_sw = (line_count >= tcb.linemax);
	     if eop_sw
	     then do;
		eop_seqp = addr (special_ptr -> special_chars.end_of_page);
		if eop_seqp -> seq.count = 0		/* null end-of-page sequence */
		then eop_seqp = null;
		line_count = 0;
	     end;
	end;

	if eop_sw & (eop_seqp = null)			/* omit end-of-page marker and put sentinel before newline */
	then do;
	     if target_len = 0			/* don't let sentinel be first thing in output */
	     then call insert_char (byte (delay_char));	/* so insert a NUL */
	     call insert_char (eop_sentinel);
	end;

	else do;
	     seqp = addr (special_ptr -> special_chars.nl_seq);
						/* this is the sequence we will use */

	     if delay_ptr ^= null			/* delays needed */
	     then do;
		horiz = delay_ptr -> delay.horz_nl;
		vert = delay_ptr -> delay.vert_nl;

		if vert < 0			/* special */
		then do;				/* means minimum line length */
		     ll = index (reverse (final_outp -> based_target_chars), nl) - 1;
						/* find latest nl */
		     if ll < 0
		     then ll = target_len;
		     n_delays = max (0, -vert - ll);

		     delay_before = "1"b;		/* put delays before sequence */
		end;

		else do;				/* normal delays */
		     delay_before = "0"b;		/* delays after nl */
		     n_delays = vert + fixed (float (col) * horiz, 17, 0);
		end;
	     end;

	     else n_delays = 0;

	     if delay_before			/* do it now */
	     then if n_delays > 0			/* if at all */
		then call insert_delays (n_delays);

	     call insert_sequence_internal;		/* put in the sequence */

	     if ^delay_before
	     then if n_delays > 0
		then call insert_delays (n_delays);

	     if eop_sw
	     then do;
		seqp = eop_seqp;
		call insert_sequence_internal;	/* put in end-of-page warning */
		call insert_char (eop_sentinel);	/* put in sentinel for copying phase */
	     end;
	end;

	if esc_sw					/* was this nl because of line overflow? */
	then do;
	     call insert_char (escape_char);
	     call insert_char (cont_char);
	     col = 2;
	end;

	else col = 0;

	return;

insert_sequence_internal:
	proc;

/* this is an internal procedure in insert_nl because if insert_nl calls */
/* insert_sequence both procedures become non-quick
   because insert_sequence has the potential to call insert_nl, thus they
   would be recursive and by definition recursion is reason for being non-quick
*/

dcl  i fixed bin;
dcl  auto_len fixed bin;

	     c_chars_ptr = seqp;			/* make compiler happy */
	     auto_len = seqp -> seq.count;		/* copy sequence length into automatic */
	     if auto_len = 0
	     then return;				/* no sequence */

	     if auto_len < 0 | auto_len > hbound (c_chars.chars, 1)	/* probably not a real sequence */
	     then go to table_error;

	     target_len = target_len + auto_len;
	     if target_len > max_chars
	     then go to try_again;

	     do i = 1 to auto_len;
		target_ptr -> based_chars (i - 1) = seqp -> seq.chars (i);
	     end;

	     target_ptr = addr (target_ptr -> based_chars (auto_len));
						/* bump pointer */
	     return;

	end /* insert_sequence_internal */;

     end /* insert_nl */;

insert_cr:
     proc;

/* This procedure inserts a carriage return */

	if col = 0
	then return;				/* no need */

	seqp = addr (special_ptr -> special_chars.cr_seq);
	if seqp -> seq.count = 0
	then call insert_bs (col);			/* if cr not implemented, use backspaces */

	else do;
	     call insert_sequence ("0"b);
	     if delay_ptr ^= null
	     then if delay_ptr -> delay.horz_nl ^= 0
		then call insert_delays (
			max (delay_ptr -> delay.horz_nl * col + max (0, delay_ptr -> delay.vert_nl), 1));

	     col = 0;
	end;

	return;

     end /* insert_cr */;

insert_bs:
     proc (how_many);

/* This procedure inserts a specified number of backspaces in the output string */

dcl  how_many fixed bin;
dcl  count fixed bin;
dcl  i fixed bin;
dcl  bs_char char (1);
dcl  new_col fixed bin;

	count = min (how_many, col);
	if count <= 0
	then return;

	seqp = addr (special_ptr -> special_chars.bs_seq);
	if seqp -> seq.count = 0			/* no backspace for this terminal */
	then do;
	     new_col = col - count;
	     seqp = addr (special_ptr -> special_chars.cr_seq);
						/* do carriage return, then forward space */
	     if seqp -> seq.count = 0
	     then return;				/* nothing to do here */
	     call insert_sequence ("0"b);
	     if delay_ptr ^= null
	     then if delay_ptr -> delay.horz_nl ^= 0
		then if delay_ptr -> delay.vert_nl >= 0
		     then call insert_delays (max (fixed (delay_ptr -> delay.horz_nl * float (col), 17, 0), 1));

	     col = 0;
	     if new_col = 0
	     then return;				/* all done */

	     if tcb.modes.tabm			/* use tabs if appropriate */
	     then do;
		do while (new_col - col >= 10);
		     call insert_tab;
		end;

		if mod (new_col, 10) < mod (col, 10)	/* room for another */
		then call insert_tab;
	     end;

	     do col = col by 1 while (col < new_col);
		call insert_char (space);		/* fill it up with spaces */
	     end;

	     return;
	end;

	if seqp -> seq.count > 1			/* not simply backspace */
	then do i = 1 to count;
	     call insert_sequence ("0"b);		/* we will have to handle the column position our self */
	     col = max (0, col - 1);			/* and we will do it here for a back space */
	end;

	else do;					/* backspace itself, deal with delays */
	     if delay_ptr = null
	     then n_delays = 0;
	     else n_delays = delay_ptr -> delay.backspace;

	     bs_char = seqp -> seq.chars (1);

	     if n_delays > 0			/* normal delay timing */
	     then do i = 1 to count;
		call insert_delays (n_delays);
		call insert_char (bs_char);
	     end;

	     else do;
		if n_delays < 0			/* this means timing for overstrike */
		then if -n_delays > count		/* so multiple backspaces can count instead of delays */
		     then call insert_delays (-n_delays - count);

		target_len = target_len + count;
		if target_len > max_chars		/* we will blow the buffer */
		then go to try_again;

		do i = 1 to count;
		     target_ptr -> based_chars (i - 1) = bs_char;
		end;

		target_ptr = addr (target_ptr -> based_chars (count));
	     end;

	     col = col - count;			/* we backed up */
	end;

	return;

     end /* insert_bs */;

insert_tab:
     proc;

/* this procedure inserts a horizontal tab */

dcl  i fixed bin;
dcl  count fixed bin;

	count = 10 - mod (col, 10);

	if count = 1				/* no point putting in tab for one space */
	then call insert_char (space);

	else do;
	     if tcb.modes.tabm & special_ptr -> special_chars.tab_seq.count > 0
						/* tabs are real */
	     then do;
		call insert_char (tab);
		if delay_ptr ^= null
		then do;
		     n_delays =
			delay_ptr -> delay.const_tab + fixed (delay_ptr -> delay.var_tab * float (count), 17, 0);
		     if n_delays > 0
		     then call insert_delays (n_delays);
		end;
	     end;

	     else do;				/* must simulate with spaces */
		target_len = target_len + count;
		if target_len > max_chars
		then go to try_again;		/* we can't let this happen */

		do i = 1 to count;
		     target_ptr -> based_chars (i - 1) = space;
		end;

		target_ptr = addr (target_ptr -> based_chars (count));
	     end;
	end;

	col = col + count;
	return;

     end /* insert_tab */;

translation:
     proc;

/* This procedure does a character translation of the output buffer using a move and translate operation */

	source_ptr, util.stringp = final_outp;		/* we'll start picking up where final stuff was left */

	if final_outp = addr (buffer_1)		/* use the buffer not already occupied */
	then target_ptr = addr (buffer_2);
	else target_ptr = addr (buffer_1);

	util.stringl = target_len;
	util.tablep = mvtp;
	mvt_args.targetp = target_ptr;
	call tty_util_$mvt (addr (util));		/* do the translation itself */

	final_outp = target_ptr;			/* now */

	if shifter (wtcb.line_type)			/* do we have to put in case shifts? */
	then do;
	     source_ptr, util.stringp = target_ptr;	/* we'll have to move again, probably */
	     xor = bool (rel (addr (buffer_1)), rel (addr (buffer_2)), "0110"b);
						/* use to switch buffers */
	     target_ptr, final_outp = ptr (target_ptr, bool (xor, rel (target_ptr), "0110"b));

	     shift = "01"b;				/* new write chain starts in lower also */

	     scm_args.search_mask = bool (shift, "11"b, "0110"b);
						/* look for opposite shift */
	     call tty_util_$scm (addr (util));

	     if ^scm_args.found_flag			/* no shift changes at all */
	     then final_outp = source_ptr;		/* we won't move anything */
	     else do;
		target_len = 0;
		if ctally > 0			/* move characters to left of found shift */
		then call copy_chars;

		do while (scm_args.found_flag);
		     if ctally = 0
		     then call insert_shift;
		     else do;
			i = -1;			/* necessary to fool compiler */
			if target_ptr -> based_chars (i) ^= prefix
			then call insert_shift;

			else do;			/* previous char was prefix, mustn't shift */
			     call insert_char (source_ptr -> based_chars (0));
						/* put unshifted char in */
			     stringp, source_ptr = addr (source_ptr -> based_chars (1));
						/* skip over it */
			     stringl = stringl - 1;
			end;
		     end;

		     call tty_util_$scm (addr (util));
		     if ctally > 0
		     then call copy_chars;		/* move any we scanned over */
		end;

		if shift = "10"b			/* if we ended up in upper */
		then call insert_char (byte (lower_shift));
						/* change to lower */
		tcb.actshift = "01"b;
	     end;
	end;

	return;

     end translation;				/* end of translation phase */

insert_shift:
     proc;

/*  This procedure inserts the proper shift character into the stream for an IBM 2741 like shift device */

	if shift = "01"b				/* we were in lower case */
	then call insert_char (byte (upper_shift));	/* put in upper shift */
	else call insert_char (byte (lower_shift));	/* or lower, as the case may be */

	scm_args.search_mask = shift;			/* switch to look for other shift */
	shift = bool (shift, "11"b, "0110"b);

	return;

     end insert_shift;

convert_to_upper_case:
     proc;

/*
   This procedure takes a string from buffer 1 and sets up the necessary variables
   and the translates the stream into uper case characters in buffer 2 using the
   move and translate operation.  The characters may either be edited
   or not. (i.e. true upper case has an escape before it or not)
*/


	target_ptr = addr (buffer_2);
	chars_moved = "0"b;

	if tcb.modes.edited
	then cap_tab_ptr = addr (lower_to_caps_edited);
	else cap_tab_ptr = addr (lower_to_caps_nonedited);

/* we'll have to be careful to step over characters greater than 177 */

	cap_source_ptr, ic_stringp = source_ptr;
	cap_target_ptr = addr (buffer_1);
	ic_stringl = source_len;
	illegal_char_args.found_flag = "1"b;		/* so "while" will work at least once */
	scanned_len = 0;

	do while (illegal_char_args.found_flag & ic_stringl > 0);
	     call tty_util_$illegal_char (addr (illegal_char_args));
						/* look for funny character */

/* now just scan the string up to the character found (if any) */

	     if illegal_char_args.ic_tally > 0		/* if there's a string to scan */
	     then do;
		util.stringp = cap_source_ptr;
		util.stringl = ic_tally;
		util.tablep = cap_tab_ptr;

		mvt_args.targetp = cap_target_ptr;
		call tty_util_$mvt (addr (util));

		if ^tcb.modes.edited
		then do;				/* in ^edited mode, must insert escapes */
		     source_ptr, util.stringp = cap_target_ptr;
		     scm_args.search_mask = "10"b;	/* look for chars with high-order bit on */
		     scm_args.found_flag = "1"b;	/* so "while" will work right */

		     do while (scm_args.found_flag);
			call tty_util_$scm (addr (util));
			if scm_args.found_flag	/* found a capital */
			then do;
			     if ^chars_moved	/* first time we've had to move any */
			     then do;
				ctally = ctally + scanned_len;
						/* take the ones we skipped before */
				source_ptr = addr (buffer_1);
						/* have to pick up all chars so far */
			     end;

			     if ctally > 0
			     then call copy_chars;	/* copy all chars left of it */
			     call insert_char (escape_char);

			     source_len = source_len + 1;
						/* we've added a character to be scanned */
			     chars_moved = "1"b;
			     unspec (util.stringp -> based_onechar) =
				unspec (util.stringp -> based_onechar) & "011111111"b;
						/* turn off high-order bit */
			end;

			else if chars_moved		/* we didn't find one, did we move any chars? */
			then call copy_chars;	/* move the rest */

		     end;
		end;				/* through looking for caps */
	     end;

	     if illegal_char_args.found_flag
	     then do;				/* if we've had to stop for high-order bits at all */

		if chars_moved			/* we've had to copy for escapes */
		then call insert_char (cap_source_ptr -> based_chars (ic_tally));
						/* copy untouched funny char */

		else cap_target_ptr -> based_chars (ic_tally) = cap_source_ptr -> based_chars (ic_tally);

		scanned_len = scanned_len + ic_tally + 1;

/* adjust pointers to start looking after it */

		ic_stringp, cap_source_ptr = addr (cap_source_ptr -> based_chars (ic_tally + 1));
		cap_target_ptr = addr (cap_target_ptr -> based_chars (ic_tally + 1));
		ic_stringl = ic_stringl - 1;
	     end;
	end;

	if chars_moved				/* have to adjust some pointers */
	then do;
	     source_ptr = addr (buffer_2);		/* chars are in buffer_2 now */
	     target_ptr = addr (buffer_1);
	end;
	else source_ptr = addr (buffer_1);		/* make sure this gets set */

	return;

     end convert_to_upper_case;

move_formated_chars:
     proc;

/*
   This procedure is called to move chars to a different
   buffer when some reformating is necessary due to the encountering of some
   special characters in the present buffer
*/


	chars_moved = "1"b;				/* we'll have to do some moving */

	if ctally > 0				/* we have some uninteresting ones to pick up */
	then do;
	     if white_sw
	     then call insert_white;			/* pick up any outstanding white space */
	     col = col + ctally;
	     if tcb.dont_count_next			/* first char doesn't count */
	     then do;
		col = col - 1;
		tcb.dont_count_next = "0"b;
	     end;
	     if ((tcb.colmax > 0) & (col > tcb.colmax))
	     then call wrap_lines;
	     else do;				/* wrap_lines would this for us */
		call copy_chars;
		wcol = col;
	     end;
	end;

	else if tcb.dont_count_next			/* we're supposed to swallow first char whole */
	then do;
	     ctally = 1;				/* get it */
	     call copy_chars;

	     if indicator = 3 | indicator = 7		/* we're still pointing at it */
	     then do;
		stringp = addr (stringp -> based_chars (1));
						/* bump pointer */
		stringl = stringl - 1;		/* decrement length */
	     end;

	     indicator = NOT_INTERESTING;		/* don't do anything else about this char */
	end;

/* now examine indicator */

	if indicator = NOT_INTERESTING		/* no interesting characters */
	then if white_sw
	     then call insert_white;			/* add white space if necessary */
	     else ;				/* otherwise go around again */

	else if indicator = NEW_LINE			/* new-line */
	then do;
	     white_sw = "0"b;			/* throw away any outstanding white space */
	     call insert_nl ("0"b);			/* put the nl in */
	end;

	else if indicator = CARRIAGE_RETURN		/* carriage return */
	then do;
	     white_sw = "1"b;			/* we'll process this later as white space */
	     wcol = 0;				/* taking us to column zero */
	end;

	else if indicator = TAB_MULTIPLE_SPACE		/* tab or multiple blanks */
	then call scan_white ("0"b);

	else if indicator = BACK_SPACE		/* backspace */
	then do;
	     wcol = max (0, wcol - 1);		/* back up the "white" column */
	     call scan_white ("1"b);

	end;

	else if indicator = VERTICAL_TAB | indicator = FORM_FEED
						/* vertical tab or form-feed */
	then if tcb.modes.vertsp			/* if we're processing such */
	     then do;
		if indicator = VERTICAL_TAB		/* vertical tab */
		then do;
		     if tcb.linemax > 0		/* if we're counting lines */
		     then do;
			line_count = line_count + 10 - mod (line_count, 10);
						/* next vt stop */
			if line_count >= tcb.linemax	/* over to new page */
			then do;
			     seqp = addr (special_ptr -> special_chars.end_of_page);
			     call insert_sequence ("0"b);
						/* mark end-of-page if necessary */
			     call insert_char (eop_sentinel);
			     line_count = 0;
			end;
		     end;
		     seqp = addr (special_ptr -> special_chars.vt_seq);
		end;

		else do;				/* else it is a form feed */
		     if tcb.linemax > 0
		     then do;			/* if we care about page length */
			seqp = addr (special_ptr -> special_chars.end_of_page);
			call insert_sequence ("0"b);
			call insert_char (eop_sentinel);
		     end;
		     line_count = 0;
		     seqp = addr (special_ptr -> special_chars.ff_seq);
		end;

		call insert_sequence ("0"b);
		if delay_ptr ^= null
		then call insert_delays (delay_ptr -> delay.vt_ff);

		col = 0;				/* implied new-line always */
		white_sw = "0"b;
	     end;

	     else if ^tcb.modes.edited		/* we'll have to escape it */
	     then do;
		i = -1;				/* so compiler won't complain */
		stringp = addr (stringp -> based_chars (i));
						/* back up by one */
		stringl = stringl + 1;
		call octal_escape;
	     end;
	     else ;

	else if indicator = OCTAL_ESCAPE		/* octal escape */
	then call octal_escape;

	else if indicator = RED_SHIFT | indicator = BLACK_SHIFT
						/* ribbon shift */
	then if tcb.modes.redm			/* if this is interesting */
	     then do;
		if white_sw
		then call insert_white;		/* if video terminal this is noticable */
		if indicator = RED_SHIFT
		then seqp = addr (special_ptr -> special_chars.red_ribbon_shift);
		else seqp = addr (special_ptr -> special_chars.black_ribbon_shift);

		call insert_sequence ("0"b);
	     end;
	     else ;

	else if indicator = INSERT_NO_COUNT		/* insert without counting column position */
	then do;
	     if white_sw
	     then call insert_white;
	     ctally = 1;
	     call copy_chars;
	end;

	else if indicator = INSERT_NO_COUNT_2		/* neither this char nor next one affects column position */
	then do;
	     if white_sw
	     then call insert_white;
	     ctally = min (stringl + 1, 2);		/* copy this one and next (if present) */
	     call copy_chars;

	     if ctally = 2				/* get them both */
	     then do;
		stringp = addr (stringp -> based_chars (1));
						/* bump past escaped char */
		stringl = stringl - 1;
	     end;

	     else tcb.dont_count_next = "1"b;		/* wasn't a next one, catch it next time */
	end;

	else if indicator = SKIP			/* ignore this one entirely */
	then ;

	else if indicator > SPECIAL_ESCAPE
	then do;					/* special escape sequence */
	     escape_index = indicator - 16;
	     if escape_index > special_ptr -> special_chars.escape_length
						/* not a good index */
	     then go to table_error;

	     if white_sw
	     then call insert_white;
	     if tcb.modes.edited
	     then seqp = addr (special_ptr -> special_chars.edited_escapes (escape_index));
	     else seqp = addr (special_ptr -> special_chars.not_edited_escapes (escape_index));

	     call insert_sequence ("1"b);
	end;

	else go to table_error;			/* invalid indicator */

	if stringl > 0				/* if we're going around again */
	then source_ptr = stringp;			/* update source pointer */

	return;

     end move_formated_chars;

wrap_lines:
     proc;

/*
   This procedure is called when the output line exceeds the maximum number
   of columns we think the device has
*/

	if tcb.colmax < 1
	then return;				/* we should not have come here */
	do while (col > tcb.colmax);			/* did we go over end of line? */
	     old_tally = ctally;
	     ctally = max (0, tcb.colmax - oldcol);	/* move first chunk */
	     if ctally > 0
	     then call copy_chars;
	     call insert_nl ("1"b);			/* insert new-line and continuation marker */

	     ctally = old_tally - ctally;
	     oldcol = 2;
	     col = col + ctally;
	end;

	if ctally > 0				/* any more chars to copy? */
	then call copy_chars;			/* do it */
	wcol = col;				/* further white space will start here */

	return;

     end wrap_lines;


scan_white:
     proc (advanced);

/*
   This procedure is called when it is necessary to deside what to do with characters
   that only move the carriage's column position.  It then updates the appropriate
   pointers or white space counters
*/

dcl  advanced bit (1) parameter;			/* indicates whether pointer has been advanced over first white character */
dcl  done bit (1);
dcl  first_time bit (1);

	done = "0"b;
	first_time = "1"b;
	white_sw = "1"b;
	do while (util.stringl > 0 & ^done);
	     if stringp -> based_onechar = backspace
	     then wcol = max (0, wcol - 1);

	     else if stringp -> based_onechar = space
	     then wcol = wcol + 1;

	     else if stringp -> based_onechar = tab
	     then wcol = wcol + 10 - mod (wcol, 10);	/* to next tab stop */

	     else if stringp -> based_onechar = carriage_return
	     then wcol = 0;

	     else done = "1"b;

	     if ^done | (first_time & ^advanced)	/* in case first character wasn't really whitespace */
	     then do;				/* we want to advance pointer anyway */
		stringp = addr (stringp -> based_chars (1));
						/* bump stringp by one char */
		stringl = stringl - 1;
		first_time = "0"b;
	     end;
	end;
	return;

     end scan_white;

octal_escape:
     proc;

/*
   This procedure is called when a character is encountered that is meaningless
   to the device, so it is printed in the form of escapeXXX (i.e. \014)
*/
	if ^tcb.modes.edited
	then do;
	     if white_sw
	     then call insert_white;			/* insert any outstanding white space */
	     if ((tcb.colmax > 0) & (col >= tcb.colmax))	/* in case we went off end of line */
	     then call insert_nl ("1"b);

	     call insert_char (escape_char);		/* put escape in */
	     col = col + 1;

	     do i = 1 to 9 by 3;
		if ((tcb.colmax > 0) & (col >= tcb.colmax))
						/* if we go off end of line */
		then call insert_nl ("1"b);		/* put in nl and continuation marker */

		call insert_char (num_array (fixed (substr (unspec (stringp -> based_onechar), i, 3), 3)));
		col = col + 1;
	     end;
	end;

	stringp = addr (stringp -> based_chars (1));	/* bump over escaped character */
	stringl = stringl - 1;
     end octal_escape;

	end /* giant begin block */;

all_done:
	a_nelemt = nelemt;				/* return number of chars processed */

						/* Add for the Datanet 7100. */
	if uncp_flag then do;
	     if wtcb.send_turn
		then do;
		if ^wtcb.flags.wru			/* if not reading answerback  */
		     then if wtcb.receive_mode_device	/* must we tell multiplexer to turn line around? */
		     then do;
			call channel_manager$control (devx, "enter_receive", null, ercode);
						/* yes, do it */
			wtcb.send_turn = "0"b;
		     end;
		     else ;
		     else wtcb.flags.wru = "0"b;	/* won't be reading answerback again */
	     end;
	end;

unlock:
	time_spent = clock () - start_time;
	tcb.cumulative_meters.write_time = tcb.cumulative_meters.write_time + time_spent;
	tty_buf.write_time = tty_buf.write_time + time_spent;
	if ^locked_entry
	then call tty_lock$unlock_channel (devx);	/* unlock channel lock if necessary */

	return;

nothing_written:
	if wtcb.send_output
	then call tty_space_man$needs_space (devx);	/* make sure space happens anyway */
	else wtcb.wflag = "1"b;
	ercode = 0;
	go to all_done;				/* exit */

free_buffers:
     proc;

/* procedure to free any buffers we allocated but can't use */

	if headp ^= null				/* we'd peeled off a page */
	then do;					/* Add for the Datanet 7100. */
	     if uncp_flag then wtcb.send_turn = lastp -> buffer.turn;
	     call tty_space_man$free_chain (devx, OUTPUT, headp);
	end;
	if new_head ^= 0
	then call tty_space_man$free_chain (devx, OUTPUT, ptr (ttybp, new_head));

	wtcb.end_frame = old_end_frame;
	wtcb.write_first = old_head;			/* back to how we were when we came in */
	wtcb.write_last = old_tail;
	if wtcb.write_last ^= 0
	then ptr (ttybp, wtcb.write_last) -> buffer.next = 0;

	return;
     end /* free_buffers */;


is_parent_mpx:					/* Check for match of channel's parent mpx type and input mpx type */
     proc (parent_mpx_type) returns (bit (1));

dcl parent_mpx_type fixed bin;
dcl temp_lctep ptr;
     
	lctep = addr (lct.lcte_array (devx));
	if lcte.major_channel_devx ^= 0 then do;
	     temp_lctep = addr (lct.lcte_array (lcte.major_channel_devx));
	     if temp_lctep->lcte.channel_type = parent_mpx_type then return ("1"b);
	end;
	else if lcte.channel_type = parent_mpx_type then return ("1"b);
	return ("0"b);
     end is_parent_mpx;

     end /* tty_write */;




		    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
