



		    convert_string_.pl1             10/17/88  1109.1rew 10/17/88  1032.3      177678



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

convert_string_: proc;

/* Created by wholesale modification of tty_read 1/78 by D. Vinograd */
/* Modified by D. Vinograd, 11/78, to avoid calling canonicalize_ unless really necessary. */


/****^  HISTORY COMMENTS:
  1) change(88-01-26,Brunelle), approve(88-01-26,MCR7813),
     audit(88-10-05,Blair), install(88-10-17,MR12.2-1171):
     Upgraded to handle special char sequences of 15 instead of 3 chars
     (c_chars).
                                                   END HISTORY COMMENTS */


/* PARAMETERS */

dcl  input_string char (*) var;
dcl  output_string char (*) var;
dcl  specp ptr;
dcl  seqp ptr;
dcl  mvtp ptr;
dcl  tctp ptr;
dcl  code fixed bin (35);

/* AUTOMATIC */

dcl  kill_char char (1);
dcl  erase_char char (1);
dcl  entry fixed bin;
dcl  escape_index fixed bin;
dcl  buffer_1 char (720) aligned;
dcl  buffer_2 char (720) aligned;
dcl  digit fixed bin;
dcl  break_found bit (1);
dcl  chars_moved bit (1);
dcl  source_ptr ptr;
dcl  target_ptr ptr;
dcl  old_sourcep ptr;
dcl  old_targetp ptr;
dcl  source_len fixed bin;
dcl  ret_len fixed bin;
dcl  target_len fixed bin;
dcl  xr fixed bin;					/* used for result of index builtin */
dcl  bx fixed bin;					/* used in verify of white space */
dcl  i fixed bin;					/* temporary work variable */
dcl  next_char char (1) aligned;

dcl 1 seq based (seqp) aligned like c_chars;		/* template of special chars sequence */

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 util aligned,					/* structure passed to convert_string_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 convert_string_util_ */

/* INTERNAL STATIC CONSTANTS */

dcl  backspace char (1) int static init ("") options (constant); /* backspace */
dcl  space char (1) static init (" ");
dcl  tab char (1) static init ("	");
dcl  cr char (1) static init ("");
dcl  input fixed bin static init (1);
dcl  output fixed bin static init (2);

/* various strange-looking character strings */

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


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

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



dcl  based_onechar char (1) based;

/* ENTRIES */

dcl  convert_string_util_$find_char entry (ptr);
dcl  canonicalize_ entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35));
dcl  convert_string_util_$tct entry (ptr);
dcl  convert_string_util_$mvt entry (ptr);

/* EXTERNAL STATIC */

dcl  error_table_$improper_data_format ext static fixed bin (35);


/* BASED */

dcl  based_chars (0:10) char (1) unal based;
dcl  based_one_char char (1) unal based;
dcl  based_string char (util.stringl) based (util.stringp);
dcl  based_ret char (source_len) based (source_ptr);
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  based_fb8 fixed bin (8) unal based;

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


/* BUILTINS */

dcl (addr, index, null, substr, verify, length, reverse) builtin;

%include remote_ttt_info;
%include prt_info;
%include prt_conv_info;
%include tty_convert;

input:	entry (input_string, rttp, output_string, code);

	entry = input;
	mvtp = remote_ttt_info.input_mvtp;
	tctp = remote_ttt_info.input_tctp;
	goto common;

output:	entry (input_string, rttp, output_string, code);

	entry = output;
	mvtp = remote_ttt_info.output_mvtp;
	tctp = remote_ttt_info.output_tctp;
common:
	specp = remote_ttt_info.specp;
	erase_char = remote_ttt_info.erase_char;
	kill_char = remote_ttt_info.kill_char;
	buffer_1 = input_string;
	buffer_2 = "";
	source_ptr = addr (buffer_1);
	target_ptr = addr (buffer_2);
	source_len = length (input_string);		/* the number of chars in buffer_1 now */
	util.stringp = source_ptr;

	if entry = output then do;
	     if remote_ttt_info.escape_output then
		call escape_output;
	     if remote_ttt_info.translate_output then
		call translate;
	end;
	else do;
	     if remote_ttt_info.translate_input then
		call translate;
	     if remote_ttt_info.escape_input then
		call escape_input;
	     if remote_ttt_info.erase_input then
		call erase;
	     if remote_ttt_info.canonicalize_input &
	     index (based_ret, cr || tab || backspace) ^= 0 then
		call canonicalize_ (source_ptr, source_len, source_ptr, source_len, code);
	end;

	ret_len = source_len;
	output_string = based_ret;
finish:
	return;
table_error:
	code = error_table_$improper_data_format;
	goto finish;

translate: proc;
	     if mvtp ^= null
	     then do;
		mvt_args.stringp = source_ptr;
		mvt_args.stringl = source_len;
		mvt_args.tablep = mvtp;
		mvt_args.targetp = target_ptr;

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

		source_ptr = mvt_args.targetp;
		target_ptr = mvt_args.stringp;
		target_len = source_len;
	     end;
	end translate;

erase:	proc;
						/* ** ERASE/KILL PROCESSING ** */
	     old_sourcep = source_ptr;
	     old_targetp = target_ptr;
	     if entry = output then do;
		util.ctally = 0;
		target_len = 0;
		util.stringl = source_len ;
		util.stringp = source_ptr;
	     end;
	     else do;
		util.stringl = source_len;
		util.stringp = source_ptr;
	     end;
						/* kill first */
	     xr = 0;
	     do while (xr < util.stringl);
						/* search from the right, only last kill is interesting */
		xr = util.stringl - index (reverse (based_string), kill_char);
		if xr < util.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,
			     util.stringp = addr (util.stringp -> based_chars (xr)); /* point to char after kill */
			source_len = source_len - xr;
			xr = util.stringl;		/* so as not to index again */
		     end;
		     else do;			/* it was escaped, we must scan rest of string */
			util.stringl = xr - 2;
			xr = 0;
		     end;
		end;
	     end;					/* finished with kills */
						/* now erase */
	     util.stringl = source_len;
	     target_len = 0;
	     xr = 1;
	     do while (xr ^= 0 & util.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 util.ctally = bx - 1; /* we'll erase it all */
						/* no white, check for overstrikes */
			     else do util.ctally = 1 to target_len - 2 by 2
				     while (substr (based_target, target_len-util.ctally, 1) = bs);
			     end;
			     target_len = target_len - util.ctally;
			     target_ptr = addr (old_targetp -> based_chars (target_len));
			end;
		     end;
		     if target_len <= 0		/* we erased whole target string */
		     then source_len = util.stringl - 1;
		end;
						/* not first char, see if it's escaped */
		else
		if xr ^= 0
		then do;
		     if escaped ()
		     then util.ctally = xr;		/* copy everything */
		     else do;
			bx = verify (reverse (substr (based_string, 1, xr-1)), right_motion);
			if bx = 0			/* all white */
			then util.ctally = 0;	/* copy nothing */
			else if bx ^= 1		/* some white */
			then util.ctally = xr - bx;	/* which will not be copied */
			else do util.ctally = xr - 2 to 2 by -2
				while (substr (based_string, util.ctally, 1) = bs);
			end;
		     end;
		     if util.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,
			util.stringp = addr (util.stringp -> based_chars (xr)); /* point past erase */
		     util.stringl = util.stringl - xr;
		end;
	     end;					/* end of erase search */
	     if target_len > 0			/* if we moved any */
	     then do;
		if util.stringl > 0			/* if there are any more */
		then do;
		     util.ctally = util.stringl;
		     call copy_chars;
		end;
		source_len = target_len ;
		source_ptr = old_targetp;
		target_ptr = old_sourcep;		/* switch buffers */
	     end;
	end erase;

escape_output: proc;
	     if tctp ^= null			/* must have output conversion table */
	     & specp ^= null			/* and special chars table too */
	     then do;
		old_targetp = target_ptr;
		old_sourcep = source_ptr;
		chars_moved = "0"b;
		util.tablep = tctp;
		target_len = 0;			/* initially */
		util.ctally = 0;
		util.stringp = source_ptr;
		util.stringl = source_len ;
		do while (util.stringl > 0);		/* main formatting loop */
		     call convert_string_util_$find_char (addr (util)); /* find next interesting character */
		     if util.indicator = 0 & util.stringl = 0 & ^chars_moved then; /* nothing found */
		     else do;
			chars_moved = "1"b;		/* we'll have to do some moving */
			if util.ctally > 0		/* we have some uninteresting ones to pick up */
			then
			     call copy_chars;	/* do it */
						/* now examine indicator */
			if util.indicator = 0	/* no interesting characters */
			then;			/* otherwise go around again */
			else if util.indicator = 3	/* tab or multiple blank */
			then do;
			     util.ctally = 1;
			     do while (util.stringl > 0
				     & (util.stringp -> based_onechar = space | util.stringp -> based_onechar = tab));
				call copy_chars;
				util.stringl = util.stringl - 1;
				util.stringp = addr (util.stringp -> based_chars (1));
			     end;
			end;
			else if util.indicator > 16 then do; /* special escape sequence */
			     escape_index = util.indicator - 16;
			     if escape_index > specp -> special_chars.escape_length /* not a good index */
			     then goto table_error;
			     if remote_ttt_info.edited then
				seqp = addr (specp -> special_chars.edited_escapes (escape_index));
			     else seqp = addr (specp -> special_chars.not_edited_escapes (escape_index));
			     call insert_sequence ;

			end;
			else goto table_error;
			if util.stringl > 0		/* if we're going around again */
			then source_ptr = util.stringp; /* update source pointer */
		     end;
		end;
		if target_len ^= 0
		then do;
		     source_ptr = old_targetp;
		     source_len = target_len ;
		     target_ptr = old_sourcep;
		end;
	     end;
	     return;
	end escape_output;

escape_input: proc;
						/* ** ESCAPE AND BREAK PROCESSING ** */
	     if tctp ^= null			/* can't do this without input conversion table */
	     then do;
		old_targetp = target_ptr;
		target_len = 0;
		break_found = "0"b;
		util.stringp = source_ptr;
		util.stringl = source_len;
		util.tablep = tctp;
		do while (util.stringl > 0);
		     call convert_string_util_$tct (addr (util)); /* scan string */
		     if util.indicator = 0 & util.stringl = 0 & target_len = 0 /* never no nothing */
		     then;
		     else do;			/* there's work to do */
			if util.ctally > 0		/* copy uninteresting characters */
			then do;
			     old_sourcep = source_ptr;
			     call copy_chars;
			end;
			if util.indicator = 0
			then;
			else
			if util.indicator = 1	/* break char */
			then do;
			     break_found = "1"b;	/* it can't be escaped or we'd have found the escape */
			     if util.ctally > 0	/* scan back for preceding white space */
			     then do;
				bx = verify (reverse (substr (based_source, 1, util.ctally)), right_motion) - 1;
				if bx < 0		/* all white */
				then bx = util.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 */
			     go to insert_and_update;
			end;
			else
			if util.indicator = 2	/* escape char */
			then do;
			     if util.stringl <= 1	/* there's nothing after it */
			     then go to insert_and_update;
			     if util.ctally > 0	/* check for overstruck escape */
			     then do;
				i = -1;		/* necessary to make compiler accept next statement */
				if util.stringp -> based_chars (i) = bs
				then go to insert_and_update;
			     end;
			     next_char = util.stringp -> based_chars (1);
			     if next_char = bs
			     then go to insert_and_update;
			     if util.stringl > 2	/* check for following character overstruck */
			     then if util.stringp -> based_chars (2) = bs
				then go to insert_and_update;
			     if tctp -> table (addr (next_char) -> based_fb8) = 2 | /* next char is escape */
			     next_char = erase_char |
			     next_char = kill_char
			     then do;
				util.stringp = addr (util.stringp -> based_chars (1)); /* skip over escape */
				util.stringl = util.stringl - 1;
				go to insert_and_update; /* put in following char as is */
			     end;
						/* check for octal escape */
			     digit = char_value (next_char);
			     if digit >= 0
			     then do;		/* we have octal digit(s) */
				octal.result = 0;
				util.stringp = addr (util.stringp -> based_chars (1)); /* look at next */
				do i = 1 to 3 while (digit >= 0);
				     octal.result = 8*octal.result + digit;
				     if util.stringl > i & i < 3
				     then do;
					digit = char_value ((util.stringp -> based_chars (i)));
					if digit >= 0 /* next char is digit, see if it's overstruck */
					then if util.stringl > i + 1
					     then if util.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));
				util.stringp = addr (util.stringp -> based_chars (i-1)); /* skip over octal digits */
				util.stringl = util.stringl - i;
			     end;
						/* check for escaped nl with white space */
			     else
			     if verify (substr (based_string, 2, util.stringl-2), right_motion) = 0
			     & substr (based_string, util.stringl, 1) = nl
			     then do;
				if util.stringl = source_len /* first thing in the string? */
				then source_len = 0; /* then nothing */
				util.stringl = 0;	/* we've reached end */
			     end;
			     else do;		/* look up next_char in input escape table */
				if specp = null	/* no table means no escapes */
				| specp -> special_chars.input_escapes.len = 0
				then go to insert_and_update;
				xr = index (specp -> special_chars.input_escapes.str, next_char);
				if xr ^= 0	/* it's there */
				then do;
				     call insert_char ((substr (specp -> special_chars.input_results.str,
					xr, 1)));
				     util.stringp = addr (util.stringp -> based_chars (2)); /* move ptr */
				     util.stringl = util.stringl - 2;
				end;
				else go to insert_and_update;
			     end;
			end;			/* of escape character */
			else
			if util.indicator = 3	/* throw away */
			then call skip (1);
			else
			if util.indicator = 4	/* form feed */
			then do;
insert_and_update:
			     call insert_char ((util.stringp -> based_one_char));
			     util.stringp = addr (util.stringp -> based_chars (1));
			     util.stringl = util.stringl - 1;
			end;
			else
			if util.indicator = 5	/* hardware control sequence */
			then ;
			else goto table_error;	/* what else could it be? */
			source_ptr = util.stringp;
		     end;
		end;				/* of tct loop */
		if target_len ^= 0
		then do;
		     source_ptr = old_targetp;
		     source_len = target_len;
		end;
	     end;
	end escape_input;

/* ** INTERNAL PROCEDURES ** */
copy_chars: proc;

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

dcl  tally_chars char (util.ctally) based;

	     target_ptr -> tally_chars = source_ptr -> tally_chars;

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

	     return;

	end copy_chars;

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) ;

	     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 util.stringp */

dcl  to_skip fixed bin;

	     util.stringp = addr (util.stringp -> based_chars (to_skip)); /* skip over character */
	     if source_len = util.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 */
	     util.stringl = util.stringl - to_skip;
	end skip;

escaped:	proc returns (bit (1) aligned);

/* this procedure returns "1"b if the character at index xr in the string based on util.stringp */
/* is preceded by a non-overstruck escape character; otherwise it returns "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 (addr (substr (based_string, xr-1, 1)) -> based_fb8) ^= 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 = addr (a_char) -> based_fb8;
	     if numeric >= 48			/* i.e., "0" */
	     & numeric <= 55			/* i.e., "7" */
	     then return (numeric - 48);

	     else return (-1);

	end char_value;
insert_sequence: proc ;

/* This procedure inserts the character sequence pointed to by seqp */

dcl  i fixed bin;

	     if seq.count = 0
	     then return;				/* no sequence */

	     if seq.count < 0 | seq.count > hbound (seq.chars, 1)	/* probably not a real sequence */
	     then go to table_error;

	     target_len = target_len + seq.count;

	     do i = 1 to seq.count;
		target_ptr -> based_onechar = seqp -> seq.chars (i);
		target_ptr = addr (target_ptr -> based_chars (1)); /* bump pointer */
	     end;

	     return;

	end insert_sequence ;
     end convert_string_;




		    convert_string_util_.alm        11/15/82  1900.8rew 11/15/82  1535.0       81864



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

	name 	convert_string_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
"
" " " " " " " " " " " " " " " " " " " " " " " " "

	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	2000,dl		use min(stringl,2000) to be quick
	tmi	2,ic		all set

	ldq	2000,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




		    get_ttt_info_.pl1               10/17/88  1109.1r w 10/17/88  1034.1       24129



/****^  ***********************************************************
        *                                                         *
        * 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(87-03-17,LJAdams), approve(87-04-03,MCR7646),
     audit(87-05-05,Gilcrease), install(87-05-14,MR12.1-1030):
     Changed ttd_version to ttd_version_3.
                                                   END HISTORY COMMENTS */


get_ttt_info_: proc (rttp, code);

dcl  code fixed bin (35);

dcl 1 local_terminal_type_data like terminal_type_data;

dcl  ttt_info_$terminal_data entry (char (*) aligned, fixed bin, fixed bin, ptr, fixed bin (35));
dcl  (addr, null) builtin;


%include remote_ttt_info;
%include prt_conv_info;
%include prt_info;
%include tty_convert;
%include terminal_type_data;

	ttdp = addr (local_terminal_type_data);
	terminal_type_data.version = ttd_version_3;
	call ttt_info_$terminal_data (remote_ttt_info.terminal_type, -1, 300, ttdp, code);
	if code ^= 0 then return;

	if terminal_type_data.input_tr_ptr ^= null then
	     remote_ttt_info.input_mvtp = addr (terminal_type_data.input_tr_ptr -> cv_trans_struc.cv_trans);
	if terminal_type_data.output_tr_ptr ^= null then
	     remote_ttt_info.output_mvtp = addr (terminal_type_data.output_tr_ptr -> cv_trans_struc.cv_trans);
	if terminal_type_data.input_cv_ptr ^= null then
	     remote_ttt_info.input_tctp = addr (terminal_type_data.input_cv_ptr -> cv_trans_struc.cv_trans);
	if terminal_type_data.output_cv_ptr ^= null then
	     remote_ttt_info.output_tctp = addr (terminal_type_data.output_cv_ptr -> cv_trans_struc.cv_trans);
	if terminal_type_data.input_cv_ptr ^= null then
	     remote_ttt_info.input_tctp = addr (terminal_type_data.input_cv_ptr -> cv_trans_struc.cv_trans);
	if terminal_type_data.special_ptr ^= null then
	     remote_ttt_info.specp = addr (terminal_type_data.special_ptr -> special_chars_struc.special_chars);
	remote_ttt_info.specp = addr (terminal_type_data.special_ptr -> special_chars_struc.special_chars);
	remote_ttt_info.erase_char = terminal_type_data.erase;
	remote_ttt_info.kill_char = terminal_type_data.kill;


	return;
     end get_ttt_info_;




		    iodd_hblp_banner_pages_.pl1     11/14/88  1106.2rew 11/14/88  1100.1      387135



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-07-25,Brunelle), approve(88-07-25,MCR7911),
     audit(88-10-25,Wallman), install(88-11-08,MR12.2-1199):
     Created
  2) change(88-11-03,Brunelle), approve(88-11-03,MCR7911),
     audit(88-11-08,Wallman), install(88-11-08,MR12.2-1199):
     Removed code to put box around charges on tail sheet.
  3) change(88-11-14,Brunelle), approve(88-11-14,PBF7911),
     audit(88-11-14,Wallman), install(88-11-14,MR12.2-1212):
     Handle null ptr to ordata if printing separator only and output the
     separator only message in the aim display area.
                                                   END HISTORY COMMENTS */

/* format: style4 */


/* head and tail sheet programs for the Honeywell Bull model 80 laser printers
   liberally taken from head_sheet_ and tail_sheet_ */

iodd_hblp_banner_pages_: proc;

/* no entry here */
	return;

/* Parameters */

dcl  a_code fixed bin (35) parameter;			/* Return error code */
dcl  a_message char (*) parameter;
dcl  a_ordatap ptr parameter;				/* ptr to output_request_data */
dcl  a_prt_ctl_ptr pointer parameter;			/* pointer to prt_ctl */
dcl  a_switch pointer parameter;			/* IOCB ptr for same */

/* External Procedures & Variables */

dcl  bigletter_$five entry (char (*), entry);
dcl  date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35));
dcl  ioa_$rsnnl entry options (variable);
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$modes entry (pointer, char (*), char (*), fixed bin (35));
dcl  iox_$put_chars entry (pointer, pointer, fixed bin (21), fixed bin (35));
dcl  system_info_$installation_id entry (char (*) aligned);
dcl  system_info_$max_rs_number entry (fixed bin);
dcl  system_info_$rs_name entry (fixed bin, char (*), fixed bin (35));

/* Builtins */

dcl  (addr, after, before, byte, divide, hbound, length, ltrim, max, null, reverse, rtrim, string, substr) builtin;

/* Internal Static */

dcl  CR char (1) defined CR_NL_FF position (1);
dcl  CR_NL char (2) defined CR_NL_FF position (1);
dcl  FF char (1) defined CR_NL_FF position (3);

/* The following line is defined with CR NL FF */
dcl  CR_NL_FF char (3) int static options (constant) init ("
");

dcl  HEAD fixed bin int static options (constant) init (1);
dcl  SEPARATOR fixed bin int static options (constant) init (3);
dcl  TAIL fixed bin int static options (constant) init (2);
dcl  copy_offset fixed bin int static;			/* where to put the copy number data for copy 2, 3,... */
dcl  installation char (32) aligned int static;		/* Local installation ID */
dcl  last_request_no fixed bin int static;		/* request number of the last request */
dcl  max_rs_number fixed bin int static init (-1);	/* maximum rate structure number */
dcl  rs_names (-1:9) char (32) static int init ((11) ("tail_sheet_ uninitialized"));
dcl  sysdir char (168) int static init (">daemon_dir_dir>io_daemon_dir");
dcl  templates_ptr ptr int static init (null);
dcl  time_format char (64) internal static options (constant) init ("^dn, ^dm ^mn ^9999yc, ^Hd:^MH ^za");

dcl  TOP_RQT_LINE fixed bin internal static options (constant) init (1);
dcl  BOTTOM_RQT_LINE fixed bin internal static options (constant) init (2);
dcl  TOP_SHORT_PATH fixed bin internal static options (constant) init (3);
dcl  BOTTOM_SHORT_PATH fixed bin internal static options (constant) init (4);
dcl  TOP_LONG_PATH fixed bin internal static options (constant) init (5);
dcl  BOTTOM_LONG_PATH fixed bin internal static options (constant) init (6);
dcl  ACCESS_CLASS fixed bin internal static options (constant) init (7);
dcl  BIG_ACCESS_CLASS fixed bin internal static options (constant) init (8);
dcl  HS_DATE_INSTALLATION fixed bin internal static options (constant) init (9);
dcl  HS_BIG_DESTINATION fixed bin internal static options (constant) init (10);
dcl  HS_BIG_HEADER fixed bin internal static options (constant) init (11);
dcl  HS_HEAD_DESTINATION fixed bin internal static options (constant) init (12);
dcl  HS_LANDSCAPE_DEST fixed bin internal static options (constant) init (13);
dcl  HS_LANDSCAPE_HEAD fixed bin internal static options (constant) init (14);

dcl  TS_TIME_REQUESTED fixed bin internal static options (constant) init (15);
dcl  TS_TIME_OUTPUT fixed bin internal static options (constant) init (16);
dcl  TS_OUTPUT_MODE fixed bin internal static options (constant) init (17);
dcl  TS_FORMS_CONTROL fixed bin internal static options (constant) init (18);
dcl  TS_RQT_QUEUE fixed bin internal static options (constant) init (19);
dcl  TS_HEAD_DESTINATION fixed bin internal static options (constant) init (20);
dcl  TS_PAGE_CHARGE fixed bin internal static options (constant) init (21);
dcl  TS_LINE_CHARGE fixed bin internal static options (constant) init (22);
dcl  TS_CHARGE_TO fixed bin internal static options (constant) init (23);
dcl  TS_RATE_STRUCTURE fixed bin internal static options (constant) init (24);

/* Automatic */

dcl  (i, j, n) fixed bin;				/* misc indices */
dcl  advert_bc fixed bin (24);			/* bitcount of advertising page */
dcl  advert_ptr ptr;				/* ptr to advertising page */
dcl  buffer char (buffer_length) based (buffer_ptr);	/* current output buffer */
dcl  buffer_length fixed bin (21) based (buffer_length_ptr);/* length of output buffer */
dcl  buffer_ptr ptr;				/* ptr to current output buffer */
dcl  buffer_length_ptr ptr;				/* ptr to current length of output buffer */
dcl  calc_page_charge float bin;			/* temporary storage for  page charge */
dcl  calc_line_charge float bin;			/* temporary storage for line charge */
dcl  dest char (64) aligned;				/* temp destination string */
dcl  head char (64) aligned;
dcl  iocbp pointer;					/* ptr to IOCB to output on */
dcl  line_75_chars char (75);
dcl  line_90_chars char (90);
dcl  message char (200) var;				/* internal copy of message to output */
dcl  real_page_count fixed bin;			/* Actual page count taking -no_separator into account. */
dcl  real_line_count fixed bin;			/* Actual line count taking -no_separator into account. */
dcl  temp char (280) aligned;				/* temp copy of message */
dcl  xcode fixed bin (35);

/* Based */

dcl  1 templates based (templates_ptr),
       2 head_sheet,
         3 lngth fixed bin (21),
         3 strng char (4096),
       2 tail_sheet,
         3 lngth fixed bin (21),
         3 strng char (4096),
       2 access_class,
         3 lngth fixed bin (21),
         3 strng char (1024),
       2 current_head_sheet,
         3 lngth fixed bin (21),
         3 strng char (8192),
       2 current_tail_sheet,
         3 lngth fixed bin (21),
         3 strng char (8192),
       2 position (24),
         3 horizontal fixed bin (17) unaligned,
         3 vertical fixed bin (17) unaligned;
%page;
/* output the front banner page for the output request.

   the head_sheet_ entrypoint has not been reproduced here since it was an old
   entrypoint used in the ios_ days */

print_head_sheet: entry (a_switch, a_prt_ctl_ptr, a_ordatap, a_code);

	iocbp = a_switch;

	a_code = 0;				/* no errors yet */
	ordatap = a_ordatap;			/* locate data about the output request */
	dmp = ordata.dpmp;				/* get ptr to dprint_msg */

	call create_head_sheet;
	if a_code ^= 0 then return;

	call print_the_banner_page (HEAD);

	return;
%page;
/* output the back banner page for the output request.

   the tail_sheet_ entrypoint has not been reproduced here since it was an old
   entrypoint used in the ios_ days */

print_tail_sheet: entry (a_switch, a_prt_ctl_ptr, a_ordatap, a_code);

	iocbp = a_switch;

	a_code = 0;				/* no errors yet */
	ordatap = a_ordatap;			/* locate data about the output request */
	dmp = ordata.dpmp;				/* get ptr to dprint_msg */

	call create_tail_sheet;
	if a_code ^= 0 then return;

	call print_the_banner_page (TAIL);

	return;
%page;
/* output a separator page.

   the separator entrypoint has not been reproduced here since it was an old
   entrypoint used in the ios_ days. */

print_separator: entry (a_switch, a_prt_ctl_ptr, a_message, a_code);

	iocbp = a_switch;

	ordatap = null;				/* this is not a real request for head_sheet */
	message = ltrim (rtrim (a_message));		/* copy and clean the message */
	a_code = 0;

	call create_head_sheet;			/* build a dummy head sheet page */
	if a_code ^= 0 then return;

	last_request_no = -1;			/* mark last head sheet as destroyed */
	copy_offset = 0;

/* if the message is real, center it using small bigletters */

	if message ^= "" then do;
	     temp = ltrim (rtrim (message));		/* strip leading & trailing spaces */
	     i = length (temp);			/* real message length */
	     head = "";				/* clear the heading */

/* Switch to 12 pitch and 8 LPI to make bigletters more readable. */
	     Select_font.body = 2;
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);
	     Set_vmi.body = byte (7);
	     call output_string (string (Set_vmi));

	     Absolute_vertical_position.body = templates.position (BIG_ACCESS_CLASS).vertical;
	     call output_string (string (Absolute_vertical_position));

	     substr (head, max (1, divide (13 - i, 2, 17) + 1)) = substr (temp, 1, 13);
	     call bigletter_$five (substr (head, 1, 13), output_bigletters);
						/* write the big message */
	end;

/* add control chars to make the head sheet print */
	call output_string (CR);
	call output_string (FF);

	call print_the_banner_page (SEPARATOR);

	return;
%page;

/* tail_save.pl1 for the tail_sheet_ code goes here */

%page;
/* ------- INIT ENTRY ------- */

init: entry ();

	last_request_no = 0;
	return;


/* ------- SET CTL ENTRY ------- */

set_ctl: entry (a_prt_ctl_ptr, a_code);

/* This entry is used to get data on how the head sheet is to be aligned and
   how banner bars are to be printed */

/* we ignore since it has no meaning for us */

	a_code = 0;

	return;


/* ------- TEST ENTRY ------- */

test: entry (a_sys_dir);

/* define new directory to locate the advertising page in */

dcl  a_sys_dir char (*);

	sysdir = a_sys_dir;				/* for testing the new notice mechanism */
	return;
%page;

build_templates: proc;

/* this internal proc will create the buffer and set all the internal static
   values.  It will create the head and tail sheet templates based on an
   8.5 X 11 inch paper specification.

   There are a lot of numeric literal values here being plugged into many
   escape strings.  These escape strings are for the Honeywell Bull Model 80
   laser printer and are documented in the
   . PRU7260/7261/7262 Printer Programming Handbook
   . Order number HK12 */

	a_code = 0;				/* start clean */

	if templates_ptr = null then do;		/* initialize buffer seg in process dir */
	     call hcs_$make_seg ("", "banner_pages_.template", "", 01010b, templates_ptr, a_code);
	     if templates_ptr = null then
		return;				/* if it didn't work, return code to caller */
	end;
	call hcs_$truncate_seg (templates_ptr, 0, a_code);
	if a_code ^= 0 then
	     return;

	call system_info_$installation_id (installation);

	buffer_ptr = addr (templates.head_sheet.strng);
	buffer_length_ptr = addr (templates.head_sheet.lngth);
	buffer_length = 0;

/* Both the head sheet and tail sheet have much in common, so we first
   generate the common part. */

/* initialize printer to known state */
	call output_string (Soft_reset);

/* Select Courier 10 font. */
	Select_font.body = 1;
	call output_string (string (Select_font));

/* Set page orientation to portrait. */
	Set_page_orientation.body = 1;		/* Portrait */
	call output_string (string (Set_page_orientation));

/* Set the left and right margins. */
	Set_left_margin.body = 42;
	call output_string (string (Set_left_margin));

	Set_right_margin.body = 942;
	call output_string (string (Set_right_margin));

/* Draw border box.  The border box is 18/720 inches in width and slightly
   inside the page limits. */
	Draw_box.left_edge = 180;
	Draw_box.top_edge = 0;
	Draw_box.right_edge = 5526;
	Draw_box.bottom_edge = 7542;
	Draw_box.line_width = 18;
	call output_string (string (Draw_box));

/* Draw necessary horizontal lines.  Each line is 18/720 inches thick and
   begins just inside the left edge of the border box.  All lines are the same
   length, ending at the inside of the right edge of the border box.  The only
   difference in the lines is where they are drawn relative to the top limit. */
	Draw_line.left_edge = 198;			/* same for all lines */
	Draw_line.right_edge = 5508;			/* same for all lines */
	Draw_line.bottom_edge = 18;			/* same for all lines */

	Draw_line.top_edge = 320;			/* line 1 */
	call output_string (string (Draw_line));

	Draw_line.top_edge = 640;			/* line 2 */
	call output_string (string (Draw_line));

	Draw_line.top_edge = 2364;			/* line 5 */
	call output_string (string (Draw_line));

	Draw_line.top_edge = 2684;			/* line 6 */
	call output_string (string (Draw_line));

	Draw_line.top_edge = 6902;			/* line 7 */
	call output_string (string (Draw_line));

	Draw_line.top_edge = 7222;			/* line 8 */
	call output_string (string (Draw_line));

/* This is the end of the common head/tail sheet template.
   Copy what's done to the tail sheet string. */

	templates.tail_sheet.lngth = buffer_length;

	templates.tail_sheet.strng = buffer;

/* Add on the normal head sheet specific stuff. */

	Draw_line.left_edge = 198;			/* same for all lines */
	Draw_line.right_edge = 5508;			/* same for all lines */
	Draw_line.bottom_edge = 18;			/* same for all lines */

	Draw_line.top_edge = 1342;			/* line 3 */
	call output_string (string (Draw_line));

	Draw_line.top_edge = 1662;			/* line 4 */
	call output_string (string (Draw_line));

	Assign_font.body.font_number = 5;
	Assign_font.body.orientation = 2;
	Assign_font.body.font_name = "LETTER GOTHIC 15";

	call output_string (string (Assign_font.header));
	call output_string (rtrim (string (Assign_font.body)));
	call output_string (string (Assign_font.trailer));

/* Generate normal tail sheet specific parts. */

/****	buffer_ptr = addr (templates.tail_sheet.strng);
      buffer_length_ptr = addr (templates.tail_sheet.lngth);

      Draw_box.left_edge = 430;
      Draw_box.top_edge = 773;
      Draw_box.right_edge = 4864;
      Draw_box.bottom_edge = 1440;
      Draw_box.line_width = 9;
      call output_string (string (Draw_box)); ****/

/* Now generate access class specific stuff. */

	buffer_ptr = addr (templates.access_class.strng);
	buffer_length_ptr = addr (templates.access_class.lngth);
	buffer_length = 0;

	Draw_line.left_edge = 198;			/* same for all lines */
	Draw_line.right_edge = 5508;			/* same for all lines */
	Draw_line.bottom_edge = 18;			/* same for all lines */

	Draw_line.top_edge = 3386;
	call output_string (string (Draw_line));

	Draw_line.top_edge = 3706;
	call output_string (string (Draw_line));

/* Finally, store the horizontal and vertical positions for the various text
   lines used in the head and tail sheets. */

	templates.position (*).horizontal = 0;
	templates.position (*).vertical = 0;

	templates.position (TOP_RQT_LINE).vertical = 14;

	templates.position (BOTTOM_RQT_LINE).vertical = 494;

	templates.position (TOP_SHORT_PATH).vertical = 35;

	templates.position (BOTTOM_SHORT_PATH).vertical = 474;

	templates.position (TOP_LONG_PATH).vertical = 32;

	templates.position (BOTTOM_LONG_PATH).vertical = 470;

	templates.position (ACCESS_CLASS).vertical = 239;

	templates.position (BIG_ACCESS_CLASS).vertical = 193;

	templates.position (HS_BIG_DESTINATION).vertical = 57;
	templates.position (HS_HEAD_DESTINATION).vertical = 103;

	templates.position (HS_DATE_INSTALLATION).vertical = 171;

	templates.position (HS_BIG_HEADER).vertical = 125;

	templates.position (HS_LANDSCAPE_DEST).vertical,
	     templates.position (HS_LANDSCAPE_HEAD).vertical = 8;

	templates.position (HS_LANDSCAPE_HEAD).horizontal = 1260;

	templates.position (TS_TIME_REQUESTED).horizontal = 120;
	templates.position (TS_TIME_REQUESTED).vertical = 62;

	templates.position (TS_TIME_OUTPUT).horizontal = 120;
	templates.position (TS_TIME_OUTPUT).vertical = 70;

	templates.position (TS_OUTPUT_MODE).horizontal = 120;
	templates.position (TS_OUTPUT_MODE).vertical = 86;

	templates.position (TS_FORMS_CONTROL).horizontal = 120;
	templates.position (TS_FORMS_CONTROL).vertical = 94;

	templates.position (TS_RQT_QUEUE).horizontal = 120;
	templates.position (TS_RQT_QUEUE).vertical = 150;

	templates.position (TS_PAGE_CHARGE).horizontal = 120;
	templates.position (TS_PAGE_CHARGE).vertical = 110;

	templates.position (TS_LINE_CHARGE).horizontal = 120;
	templates.position (TS_LINE_CHARGE).vertical = 118;

	templates.position (TS_CHARGE_TO).horizontal = 120;
	templates.position (TS_CHARGE_TO).vertical = 126;

	templates.position (TS_RATE_STRUCTURE).horizontal = 120;
	templates.position (TS_RATE_STRUCTURE).vertical = 134;


	templates.position (TS_HEAD_DESTINATION).vertical = 171;

	templates.current_head_sheet.strng, templates.current_tail_sheet.strng = "";
	templates.current_head_sheet.lngth, templates.current_tail_sheet.lngth = 0;

/* if we've never done it before, get all the rate_structure names.
   For RS numbers > max_rs_number, system_info_ will return a name
   of the form " INVALID_RS_n". */

	if max_rs_number < 0 then do;
	     call system_info_$max_rs_number (max_rs_number);
	     do i = 0 to hbound (rs_names (i), 1);
		call system_info_$rs_name (i, rs_names (i), (0));
	     end;
	end;

	return;

     end build_templates;
%page;
create_head_sheet: proc;

/* this is a special-purpose routine to generate the head sheet for the
   Honeywell Bull laser printer */

dcl  copies_string char (22) aligned;			/* temp string where we build "Copy X of Y" */
dcl  copies_string_len fixed bin;			/* length of copies_string */
dcl  request_number char (20);			/* space for the 1st header line */
dcl  request_number_len fixed bin;			/* length of valid chars in request_number */

	if templates_ptr = null then do;
	     call build_templates;
	     if a_code ^= 0 then return;
	end;

/* copy in the common portion of the head sheet into the buffer */
	buffer_ptr = addr (templates.current_head_sheet.strng);
	buffer_length_ptr = addr (templates.current_head_sheet.lngth);

	buffer_length = templates.head_sheet.lngth;
	buffer = templates.head_sheet.strng;

/* get out of no output request data to process */
	if ordatap = null then return;

/* if we need to display the access class, add the access class specific strings */

	if ordata.access_class_string ^= "" then do;
	     i = buffer_length;
	     buffer_length = buffer_length + templates.access_class.lngth;
	     substr (buffer, i + 1) = substr (templates.access_class.strng, 1, templates.access_class.lngth);
	end;

/* Build the line with the request number, requestor, and optional copies. */

	line_75_chars = "";
	call ioa_$rsnnl ("^d", request_number, request_number_len, ordata.request_no);
	substr (line_75_chars, 1, request_number_len) = substr (request_number, 1, request_number_len);
	substr (line_75_chars, length (line_75_chars) - request_number_len + 1) = substr (request_number, 1, request_number_len);

	substr (line_75_chars, request_number_len + 5, 32) = ordata.requestor;

	if ordata.copies > 1
	then do;
	     if ordata.no_separator
	     then call ioa_$rsnnl ("^d copies", copies_string, copies_string_len, ordata.copies);
	     else call ioa_$rsnnl ("copy ^d of ^d", copies_string, copies_string_len, ordata.copy_no, ordata.copies);
	     substr (line_75_chars, length (line_75_chars) - copies_string_len - request_number_len - 3, copies_string_len) = substr (copies_string, 1, copies_string_len);
	end;

	Absolute_vertical_position.body = templates.position (TOP_RQT_LINE).vertical;
	call output_string (string (Absolute_vertical_position));
	call output_string (CR);
	call output_string (line_75_chars);

	Absolute_vertical_position.body = templates.position (BOTTOM_RQT_LINE).vertical;
	call output_string (string (Absolute_vertical_position));
	call output_string (CR);
	call output_string (line_75_chars);

/* Output the full pathname.  If the pathname is longer than can be displayed
   on a single 10-pitch line (>75 characters), then switch to 12-pitch.  If the
   pathname is longer than can be displayed on a single 12-pitch line (>90
   characters), then display the pathname on two lines.
*/

	if length (rtrim (ordata.full_path)) > length (line_75_chars)
	then do;					/* switch to 12 pitch */
	     Select_font.body = 2;			/* Elite 12 font */
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);	/* 12 pitch */
	     if length (rtrim (ordata.full_path)) > length (line_90_chars)
	     then do;				/* 2-line pathname */
		Set_vmi.body = byte (7);		/* 8 LPI */
		call output_string (string (Set_vmi));

		Absolute_vertical_position.body = templates.position (TOP_LONG_PATH).vertical;
		call output_string (string (Absolute_vertical_position));
		call output_string (CR);
		call output_string (substr (ordata.full_path, 1, length (line_90_chars)));
		call output_string (CR_NL);
		call output_string (rtrim (substr (ordata.full_path, length (line_90_chars) + 1)));

		Absolute_vertical_position.body = templates.position (BOTTOM_LONG_PATH).vertical;
		call output_string (string (Absolute_vertical_position));
		call output_string (CR);
		call output_string (substr (ordata.full_path, 1, length (line_90_chars)));
		call output_string (CR_NL);
		call output_string (rtrim (substr (ordata.full_path, length (line_90_chars) + 1)));
	     end;
	     else do;				/* 1-line pathname */
		Absolute_vertical_position.body = templates.position (TOP_SHORT_PATH).vertical;
		call output_string (string (Absolute_vertical_position));
		call output_string (CR);
		call output_string (string (Begin_auto_center_mode));
		call output_string (rtrim (ordata.full_path));
		call output_string (string (End_auto_center_mode));

		Absolute_vertical_position.body = templates.position (BOTTOM_SHORT_PATH).vertical;
		call output_string (string (Absolute_vertical_position));
		call output_string (CR);
		call output_string (string (Begin_auto_center_mode));
		call output_string (rtrim (ordata.full_path));
		call output_string (string (End_auto_center_mode));
	     end;

	     Select_font.body = 1;			/* Courier 10 */
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);	/* 10 pitch */
	end;
	else do;					/* 1-line pathname, 10 pitch */
	     Absolute_vertical_position.body = templates.position (TOP_SHORT_PATH).vertical;
	     call output_string (string (Absolute_vertical_position));
	     call output_string (CR);
	     call output_string (string (Begin_auto_center_mode));
	     call output_string (rtrim (ordata.full_path));
	     call output_string (string (End_auto_center_mode));

	     Absolute_vertical_position.body = templates.position (BOTTOM_SHORT_PATH).vertical;
	     call output_string (string (Absolute_vertical_position));
	     call output_string (CR);
	     call output_string (string (Begin_auto_center_mode));
	     call output_string (rtrim (ordata.full_path));
	     call output_string (string (End_auto_center_mode));
	end;

/* Build the date/time string and installation identifier. */

	line_75_chars = date_time_$format (time_format, ordata.time_start_request, "system_zone", "system_lang");
	substr (line_75_chars, length (line_75_chars) - length (rtrim (installation)) + 1) = rtrim (installation);

	Absolute_vertical_position.body = templates.position (HS_DATE_INSTALLATION).vertical;
	call output_string (string (Absolute_vertical_position));
	call output_string (CR);
	call output_string (line_75_chars);

/* Print destination and header in shadowed big letters. */

	if dprint_msg.destination = ""
	then dest = before (after (ordata.requestor, "."), ".");
	else dest = dprint_msg.destination;

	if dprint_msg.heading = ""
	then head = before (ordata.requestor, ".");
	else if substr (dprint_msg.heading, 1, 5) = " for "
	then head = substr (dprint_msg.heading, 6);
	else head = dprint_msg.heading;

/* Switch to 12 pitch and 8 LPI to make bigletters more readable. */

	Select_font.body = 2;
	call output_string (string (Select_font));
	call output_string (Set_default_hmi);
	Set_vmi.body = byte (7);
	call output_string (string (Set_vmi));

	Absolute_vertical_position.body = templates.position (HS_BIG_DESTINATION).vertical;
	call output_string (string (Absolute_vertical_position));
	call bigletter_$five (rtrim (substr (dest, 1, 13)), output_bigletters);

	Absolute_vertical_position.body = templates.position (HS_BIG_HEADER).vertical;
	call output_string (string (Absolute_vertical_position));
	call bigletter_$five (rtrim (substr (head, 1, 13)), output_bigletters);

	if ordata.access_class_string ^= "" then do;
	     Absolute_vertical_position.body = templates.position (BIG_ACCESS_CLASS).vertical;
	     call output_string (string (Absolute_vertical_position));
	     call bigletter_$five (rtrim (substr (ordata.access_class_string, 1, 13)), output_bigletters);
	end;

	Absolute_vertical_position.body = templates.position (HS_HEAD_DESTINATION).vertical;
	call output_string (string (Absolute_vertical_position));

	if length (rtrim (head)) + length (rtrim (dest)) + 2 > length (line_75_chars)
	then do;
	     line_90_chars = dest;
	     substr (line_90_chars, length (line_90_chars) - length (rtrim (head)) + 1) = rtrim (head);
	     call output_string (CR);
	     call output_string (line_90_chars);
	end;
	else do;
	     line_75_chars = dest;
	     substr (line_75_chars, length (line_75_chars) - length (rtrim (head)) + 1) = rtrim (head);
	     Select_font.body = 1;
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);
	     Set_vmi.body = byte (9);
	     call output_string (string (Set_vmi));
	     call output_string (CR);
	     call output_string (line_75_chars);
	end;

	if ordata.access_class_string = ""
	then ;
	else do;
	     Select_font.body = 1;
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);
	     Set_vmi.body = byte (9);
	     call output_string (string (Set_vmi));
	     Absolute_vertical_position.body = templates.position (ACCESS_CLASS).vertical;
	     call output_string (string (Absolute_vertical_position));
	     call output_string (CR);
	     call output_string (string (Begin_auto_center_mode));
	     call output_string (rtrim (ordata.access_class_string));
	     call output_string (string (End_auto_center_mode));
	end;

/* Now switch to landscape orientation and print the destination/header. */

	Set_page_orientation.body = 2;
	call output_string (string (Set_page_orientation));

	Select_font.body = 5;
	call output_string (string (Select_font));

/*	call output_string (Begin_proportional_mode); */

	Absolute_horizontal_position.body = templates.position (HS_LANDSCAPE_DEST).horizontal;
	call output_string (string (Absolute_horizontal_position));

	Absolute_vertical_position.body = templates.position (HS_LANDSCAPE_DEST).vertical;
	call output_string (string (Absolute_vertical_position));

	call output_string (rtrim (dest));

	Absolute_horizontal_position.body = templates.position (HS_LANDSCAPE_HEAD).horizontal;
	call output_string (string (Absolute_horizontal_position));

	call output_string (Begin_backward_print_mode);

	call output_string (reverse (rtrim (head)));

	call output_string (End_backward_print_mode);

/* 	call output_string (End_proportional_mode); */

/* add control strings so printer notice will print out in a reasonable manner */
	Set_page_orientation.body = 1;
	call output_string (string (Set_page_orientation));

	Select_font.body = 1;
	call output_string (string (Select_font));

	call output_string (CR);
	call output_string (FF);

	return;

     end create_head_sheet;
%page;
create_tail_sheet: proc;

/* this is a special-purpose routine to generate the tail sheet for the
   Honeywell Bull laser printer */

dcl  copies_string char (22) aligned;			/* temp string where we build "Copy X of Y" */
dcl  copies_string_len fixed bin;			/* length of copies_string */
dcl  request_number char (20);			/* space for the 1st header line */
dcl  request_number_len fixed bin;			/* length of valid chars in request_number */

	if templates_ptr = null then do;
	     call build_templates;
	     if a_code ^= 0 then return;
	end;

/* copy in the common portion of the tail sheet into the buffer */
	buffer_ptr = addr (templates.current_tail_sheet.strng);
	buffer_length_ptr = addr (templates.current_tail_sheet.lngth);

	buffer_length = templates.tail_sheet.lngth;
	buffer = templates.tail_sheet.strng;

/* if we need to display the access class, add the access class specific strings */

	if ordata.access_class_string ^= "" then do;
	     i = buffer_length;
	     buffer_length = buffer_length + templates.access_class.lngth;
	     substr (buffer, i) = substr (templates.access_class.strng, 1, templates.access_class.lngth);
	end;

/* Build the line with the request number, requestor, and optional copies. */

	line_75_chars = "";
	call ioa_$rsnnl ("^d", request_number, request_number_len, ordata.request_no);
	substr (line_75_chars, 1, request_number_len) = substr (request_number, 1, request_number_len);
	substr (line_75_chars, length (line_75_chars) - request_number_len + 1) = substr (request_number, 1, request_number_len);

	substr (line_75_chars, request_number_len + 5, 32) = ordata.requestor;

	if ordata.copies > 1 then do;
	     if ordata.no_separator then
		call ioa_$rsnnl ("^d copies", copies_string, copies_string_len, ordata.copies);
	     else call ioa_$rsnnl ("copy ^d of ^d", copies_string, copies_string_len, ordata.copy_no, ordata.copies);
	     substr (line_75_chars, length (line_75_chars) - copies_string_len - request_number_len - 3, copies_string_len) = substr (copies_string, 1, copies_string_len);
	end;

	Absolute_vertical_position.body = templates.position (TOP_RQT_LINE).vertical;
	call output_string (string (Absolute_vertical_position));
	call output_string (CR);
	call output_string (line_75_chars);

	Absolute_vertical_position.body = templates.position (BOTTOM_RQT_LINE).vertical;
	call output_string (string (Absolute_vertical_position));
	call output_string (CR);
	call output_string (line_75_chars);

/* Output the full pathname.  If the pathname is longer than can be displayed
   on a single 10-pitch line (>75 characters), then switch to 12-pitch.  If
   the pathname is longer than can be displayed on a single 12-pitch line (>90
   characters), then display the pathname on two lines. */

	if length (rtrim (ordata.full_path)) > length (line_75_chars) then do; /* switch to 12 pitch */
	     Select_font.body = 2;			/* Elite 12 font */
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);	/* 12 pitch */
	     if length (rtrim (ordata.full_path)) > length (line_90_chars) then do; /* 2-line pathname */
		Set_vmi.body = byte (7);		/* 8 LPI */
		call output_string (string (Set_vmi));

		Absolute_vertical_position.body = templates.position (TOP_LONG_PATH).vertical;
		call output_string (string (Absolute_vertical_position));
		call output_string (CR);
		call output_string (substr (ordata.full_path, 1, length (line_90_chars)));
		call output_string (CR_NL);
		call output_string (rtrim (substr (ordata.full_path, length (line_90_chars) + 1)));

		Absolute_vertical_position.body = templates.position (BOTTOM_LONG_PATH).vertical;
		call output_string (string (Absolute_vertical_position));
		call output_string (CR);
		call output_string (substr (ordata.full_path, 1, length (line_90_chars)));
		call output_string (CR_NL);
		call output_string (rtrim (substr (ordata.full_path, length (line_90_chars) + 1)));
	     end;
	     else do;				/* 1-line pathname */
		Absolute_vertical_position.body = templates.position (TOP_SHORT_PATH).vertical;
		call output_string (string (Absolute_vertical_position));
		call output_string (CR);
		call output_string (string (Begin_auto_center_mode));
		call output_string (rtrim (ordata.full_path));
		call output_string (string (End_auto_center_mode));

		Absolute_vertical_position.body = templates.position (BOTTOM_SHORT_PATH).vertical;
		call output_string (string (Absolute_vertical_position));
		call output_string (CR);
		call output_string (string (Begin_auto_center_mode));
		call output_string (rtrim (ordata.full_path));
		call output_string (string (End_auto_center_mode));
	     end;

	     Select_font.body = 1;			/* Courier 10 */
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);	/* 10 pitch */
	end;
	else do;					/* 1-line pathname, 10 pitch */
	     Absolute_vertical_position.body = templates.position (TOP_SHORT_PATH).vertical;
	     call output_string (string (Absolute_vertical_position));
	     call output_string (CR);
	     call output_string (string (Begin_auto_center_mode));
	     call output_string (rtrim (ordata.full_path));
	     call output_string (string (End_auto_center_mode));

	     Absolute_vertical_position.body = templates.position (BOTTOM_SHORT_PATH).vertical;
	     call output_string (string (Absolute_vertical_position));
	     call output_string (CR);
	     call output_string (string (Begin_auto_center_mode));
	     call output_string (rtrim (ordata.full_path));
	     call output_string (string (End_auto_center_mode));
	end;

	line_75_chars = "Requested:     " || rtrim (date_time_$format (time_format, dprint_msg.msg_time, "system_zone", "system_lang"));
	call output_position_and_string (TS_TIME_REQUESTED, rtrim (line_75_chars));

	line_75_chars = "Output:        " || rtrim (date_time_$format (time_format, ordata.time_start_request, "system_zone", "system_lang"));
	call output_position_and_string (TS_TIME_OUTPUT, rtrim (line_75_chars));

	if ordata.output_mode ^= "" then do;
	     call output_position_and_string (TS_OUTPUT_MODE, "Output mode:   " || rtrim (ordata.output_mode));
	end;

	if dprint_msg.version < dprint_msg_version_5 then do;
	     if dprint_msg.forms ^= "" then
		call output_position_and_string (TS_FORMS_CONTROL, "Forms control: " || rtrim (dprint_msg.forms));
	end;
	else if dprint_msg.forms_name_lth > 0 then
	     call output_position_and_string (TS_FORMS_CONTROL, "Forms control: " || dprint_msg.forms_name);

	call ioa_$rsnnl ("^a queue ^d^12x^a", temp, j, ordata.request_type, ordata.queue, ordata.device_name);
	call output_position_and_string (TS_RQT_QUEUE, rtrim (temp));

	if ordata.no_separator then
	     real_page_count = ordata.page_count * ordata.copies;
	else real_page_count = ordata.page_count;

	if ordata.charge > 0e0 then			/* calculate the page charge */
	     calc_page_charge = real_page_count * ordata.price_per_n_pages / ordata.n_pages_for_price;
	else calc_page_charge = 0e0;
	call ioa_$rsnnl ("^d pages^[ at $^.2f per ^d pages ^52t^10.2f^;^3s^]",
	     line_75_chars, n, real_page_count, (calc_page_charge > 0e0),
	     ordata.price_per_n_pages, ordata.n_pages_for_price, calc_page_charge);
	call output_position_and_string (TS_PAGE_CHARGE, rtrim (line_75_chars));

	if ordata.no_separator then
	     real_line_count = ordata.line_count * ordata.copies;
	else real_line_count = ordata.line_count;

	if ordata.charge > 0e0 then
	     calc_line_charge = real_line_count * ordata.price_per_n_lines / ordata.n_lines_for_price;
	else calc_line_charge = 0e0;
	call ioa_$rsnnl ("^d lines^[ at $^.2f per ^d lines ^52t^10.2f^;^3s^]",
	     line_75_chars, n, real_line_count, (calc_line_charge > 0e0),
	     ordata.price_per_n_lines, ordata.n_lines_for_price, calc_line_charge);
	call output_position_and_string (TS_LINE_CHARGE, rtrim (line_75_chars));

	call ioa_$rsnnl ("Charge to ^32a^52t^10.2f",
	     line_75_chars, n, ordata.requestor, ordata.charge);
	call output_position_and_string (TS_CHARGE_TO, rtrim (line_75_chars));

	if max_rs_number > 0 | ^ordata.no_accounting then do;
	     call ioa_$rsnnl (" Rate structure ^[unknown, ^a used^;^a^].",
		line_75_chars, n, ordata.rs_unavailable, rs_names ((ordata.rs_number)));
	     call output_position_and_string (TS_RATE_STRUCTURE, rtrim (line_75_chars));
	end;

	if ordata.access_class_string ^= "" then do;
	     Absolute_vertical_position.body = templates.position (ACCESS_CLASS).vertical;
	     call output_string (string (Absolute_vertical_position));
	     call output_string (CR);
	     call output_string (string (Begin_auto_center_mode));
	     call output_string (rtrim (ordata.access_class_string));
	     call output_string (string (End_auto_center_mode));

	     Select_font.body = 2;
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);
	     Set_vmi.body = byte (7);
	     call output_string (string (Set_vmi));

	     Absolute_vertical_position.body = templates.position (BIG_ACCESS_CLASS).vertical;
	     call output_string (string (Absolute_vertical_position));
	     call bigletter_$five (rtrim (substr (ordata.access_class_string, 1, 13)), output_bigletters);
	end;

	Absolute_vertical_position.body = templates.position (TS_HEAD_DESTINATION).vertical;
	call output_string (string (Absolute_vertical_position));

	if dprint_msg.destination = "" then
	     dest = before (after (ordata.requestor, "."), ".");
	else dest = dprint_msg.destination;

	if dprint_msg.heading = "" then
	     head = before (ordata.requestor, ".");
	else if substr (dprint_msg.heading, 1, 5) = " for " then
	     head = substr (dprint_msg.heading, 6);
	else head = dprint_msg.heading;

	if length (rtrim (head)) + length (rtrim (dest)) + 2 > length (line_75_chars) then do;
	     Select_font.body = 2;
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);
	     Set_vmi.body = byte (7);
	     call output_string (string (Set_vmi));

	     line_90_chars = dest;
	     substr (line_90_chars, length (line_90_chars) - length (rtrim (head)) + 1) = rtrim (head);
	     call output_string (CR);
	     call output_string (line_90_chars);
	end;
	else do;
	     Select_font.body = 1;
	     call output_string (string (Select_font));
	     call output_string (Set_default_hmi);
	     Set_vmi.body = byte (9);
	     call output_string (string (Set_vmi));

	     line_75_chars = dest;
	     substr (line_75_chars, length (line_75_chars) - length (rtrim (head)) + 1) = rtrim (head);
	     call output_string (CR);
	     call output_string (line_75_chars);
	end;

	call output_string (CR);
	call output_string (FF);

	return;

     end create_tail_sheet;
%page;
output_bigletters: proc (strp, lth);

/* this is routine bigletter_ calls with the expanded line */

dcl  strp ptr;
dcl  lth fixed bin;
dcl  bcs char (lth) based (strp);
dcl  i fixed bin;
dcl  temp char (204) aligned;

	temp = bcs;				/* copy to a clean string */
	i = length (rtrim (temp));			/* see how long it actually is */

/* we must manually insert CR & NL characters on each line.  Also, we surround
   the bigletter_ string with printer commands to make the asterisks appear in
   shadow mode to make them stand out a little more */

	call output_string (CR);
	call output_string (Begin_shadow_mode);
	call output_string (substr (temp, 1, i));
	call output_string (End_bold_and_shadow_mode);
	call output_string (CR_NL);

	return;

     end output_bigletters;

output_position_and_string: proc (position_index, string_to_output);

dcl  position_index fixed bin;
dcl  string_to_output char (*);

	Absolute_horizontal_position.body = templates.position (position_index).horizontal;
	Absolute_vertical_position.body = templates.position (position_index).vertical;
	call output_string (string (Absolute_horizontal_position));
	call output_string (string (Absolute_vertical_position));

	call output_string (string_to_output);

     end output_position_and_string;


output_string: proc (cs);

/* routine to copy the string it was passed into the current output buffer
   defined by buffer_ptr and buffer_length */

dcl  cs char (*) parameter;
dcl  start_char fixed bin;
dcl  num_chars fixed bin;

	start_char = buffer_length + 1;
	num_chars = length (cs);
	buffer_length = buffer_length + num_chars;

	substr (buffer, start_char, num_chars) = cs;

	return;

     end output_string;
%page;
print_the_banner_page: proc (which_page);

/* output the desired banner page */

dcl  which_page fixed bin;				/* 1 = head sheet
						   2 = tailsheet
                                                               3 = separator */

	if which_page = HEAD | which_page = SEPARATOR then do; /* use head sheet buffer */
	     buffer_ptr = addr (templates.current_head_sheet.strng);
	     buffer_length_ptr = addr (templates.current_head_sheet.lngth);
	end;
	else do;					/* use tail sheet buffer */
	     buffer_ptr = addr (templates.current_tail_sheet.strng);
	     buffer_length_ptr = addr (templates.current_tail_sheet.lngth);
	end;

/* The laser printer's banner pages requires rawo mode and no prt_conv_
   intervention.

   Also, we must reenable print mode if a head sheet, since tail sheet code
   disables it when it's through outputing the tail sheet.  This trick
   prevents any blank pages between the tail sheet of one request and the head
   sheet of the next. */

	if which_page = HEAD | which_page = SEPARATOR then
	     call iox_$modes (iocbp, "print", "", xcode); /* enable printing */
	call iox_$put_chars (iocbp, buffer_ptr, 0, xcode);
	call iox_$modes (iocbp, "rawo", "", xcode);
	call iox_$control (iocbp, "prt_conv_off", null (), xcode);
	call iox_$put_chars (iocbp, buffer_ptr, buffer_length, a_code);
	call iox_$control (iocbp, "prt_conv_on", null (), xcode);
	call iox_$modes (iocbp, "^rawo", "", xcode);
	if which_page = TAIL then do;			/* if tail sheet page */
	     call iox_$modes (iocbp, "^print", "", xcode);/* disenable printing */
	     return;				/* that all for tail sheet */
	end;
	if a_code ^= 0 then
	     return;

/* see if there is an printer notice page, if so print it if we are outputting the head sheet */
	if which_page = SEPARATOR then return;

	call hcs_$initiate_count (sysdir, "printer_notice", "", advert_bc, 0, advert_ptr, xcode);
	if advert_ptr ^= null then
	     if advert_bc > 0 then do;
		call iox_$modes (iocbp, "default", (""), a_code);
		call iox_$put_chars (iocbp, advert_ptr, divide (advert_bc, 9, 21, 0), a_code);
		call hcs_$terminate_noname (advert_ptr, xcode);
	     end;

	a_code = 0;

	return;
     end print_the_banner_page;
%page; %include dprint_msg;
%page; %include output_request_data;
%page; %include prt_ctl;
%page; %include queue_msg_hdr;
%page; %include iodd_hblp_commands;

     end iodd_hblp_banner_pages_;




		    iodd_hblp_support_.pl1          12/05/88  1245.9rew 12/05/88  1244.4      303363



/****^  ********************************************
        *                                          *
        * Copyright, (C) Honeywell Bull Inc., 1988 *
        *                                          *
        ******************************************** */


/****^  HISTORY COMMENTS:
  1) change(88-06-07,Brunelle), approve(88-06-07,MCR7911),
     audit(88-10-25,Wallman), install(88-10-28,MR12.2-1199):
     Created.
  2) change(88-11-14,Brunelle), approve(88-11-14,PBF7911),
     audit(88-11-14,Wallman), install(88-11-14,MR12.2-1212):
     Correct problem of going into raw output mode for bold faced chars and
     never returning to normal mode.  Also drop the top line on each page
     enough so the page is centered vertically.
  3) change(88-12-05,Brunelle), approve(88-12-05,MECR0005),
     audit(88-12-05,Wallman), install(88-12-05,MR12.2-1219):
     Correct first page of document not being properly aligned at top of page.
                                                   END HISTORY COMMENTS */

/* format: style4 */

iodd_hblp_support_: proc;
	return;					/* no entry here */

/* this module contains the following utility subroutines for the
   Honeywell Bull Model 80 laser printer:

   complete_attach - This completes the attachment for the initial iox_$attach
   call.

   open - iox_$open replacement for remote_printer_,

   control - iox_$control replacement for remote_printer_,

   modes - iox_$modes replacement for remote_printer_,

   put_chars - iox_$put_chars replacement for remote_printer_.

*/

/* Arguments */

dcl  a_code fixed bin (35) parameter;			/* error code */
dcl  a_data_chars fixed bin (21) parameter;		/* # of chars to output */
dcl  a_data_ptr ptr parameter;			/* ptr to data to output */
dcl  a_iocbp ptr parameter;				/* iocb ptr to process on */
dcl  a_mode fixed bin parameter;			/* open mode */
dcl  a_new_modes char (*) parameter;			/* new modes to assign */
dcl  a_old_modes char (*) parameter;			/* current modes */
dcl  a_order char (*) parameter;			/* control order to process */
dcl  a_orderp ptr parameter;				/* options control order info ptr */
dcl  a_sw bit (1) parameter;				/* com_err_ switch for attach */

/* External Procedures and Variables */

dcl  continue_to_signal_ entry (fixed bin (35));
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$bad_mode fixed bin (35) ext static;
dcl  error_table_$not_attached fixed bin (35) ext static;
dcl  error_table_$not_closed fixed bin (35) ext static;
dcl  error_table_$not_open fixed bin (35) ext static;
dcl  error_table_$request_pending fixed bin (35) ext static;
dcl  error_table_$timeout fixed bin (35) ext static;
dcl  get_system_free_area_ entry () returns (ptr);
dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$propagate entry (ptr);
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  prt_conv_ entry (ptr, fixed bin (21), ptr, fixed bin (21), ptr);
dcl  remote_driver_$problem_notification entry (char (*));
dcl  remote_printer_$remote_printer_position external entry;
dcl  remote_printer_$remote_printer_close external entry;
dcl  remote_printer_control_ entry (ptr, char (*), ptr, fixed bin (35));
dcl  remote_printer_modes_ entry (ptr, char (*), char (*), fixed bin (35));
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  timed_io_$get_chars entry (ptr, fixed bin (71), ptr, fixed bin (21), fixed bin (21), fixed bin (35));

dcl  (addr, copy, currentsize, divide, index, length, mod, null, rtrim, string, substr, unspec) builtin;

dcl  any_other condition;

/* Internal Static */

dcl  VT_or_FF char (2) int static options (constant) init ("");
dcl  CR char (1) int static options (constant) init ("");
dcl  FF char (1) defined VT_or_FF position (2);
dcl  NL char (1) int static options (constant) init ("
");
dcl  last_char_was_ff bit (1) internal static init ("1"b);
dcl  my_area area based (my_area_ptr);
dcl  my_area_ptr ptr int static init (null);
dcl  printer_device char (32) int static options (constant) init ("printer");
dcl  prt_conv_on bit (1) int static init ("1"b);		/* ON if should call prt_conv_ */

/* save data for label processing if needed */
dcl  1 labels int static,
       2 delta_lines fixed bin,			/* number of lines needed for labels */
       2 need_initial_ff bit (1) init ("1"b),
       2 have_labels bit (1) init ("0"b),		/* ON if we have top and/or bottom labels */
       2 have_top_label bit (1) init ("0"b),		/* ON if we have a top label */
       2 have_bottom_label bit (1) init ("0"b);		/* ON if we have a bottom label */

/* Automatic */

dcl  charp ptr;					/* ptr to chars to output */
dcl  code fixed bin (35);				/* error code */
dcl  cur_page fixed bin (24);
dcl  ec fixed bin (35);				/* internal error code */
dcl  get_printer_status bit (1);
dcl  i fixed bin;
dcl  ignore fixed bin (35);
dcl  iocbp ptr;					/* copy of iocb ptr */
dcl  mask bit (36) aligned;				/* for setting ips mask */
dcl  old_modes char (512);
dcl  open_mode fixed bin;				/* copy of opening mode */
dcl  order char (32);				/* copy of order to process */
dcl  output_string char (record_len) based (prt_conv_outp);
dcl  prt_conv_outp ptr;
dcl  record_len fixed bin (21);
dcl  remaining_chars fixed bin (21);			/* # of chars left to process in this put_chars call */
dcl  runout_mode bit (1);				/* set ON if check_printer_status
						   is called for "runout" control order */
dcl  send_raw bit (1);
dcl  temp_line char (1024) varying;
dcl  top_line_drop_count fixed bin;
dcl  total_chars fixed bin (24);			/* # of chars requested by put_chars */

dcl  osdata_ptr ptr;
dcl  osdata_line_count fixed bin;
dcl  osdata_line_size fixed bin;
dcl  osdata_temp_ptr ptr;
dcl  1 osdata based (osdata_ptr),
       2 max_line_count fixed bin,			/* max # overstruck lines */
       2 line_count fixed bin,			/* # overstruck lines */
       2 line_size fixed bin,				/* # chars in each line */
       2 bolding (osdata_line_size refer (osdata.line_size)) bit (1) unaligned,
       2 line (
	  osdata_line_count refer (osdata.max_line_count),
	  osdata_line_size refer (osdata.line_size))
	  char (1) unaligned;
%page;

/* entrypoint to complete the processing for the iox_$attach call in
   remote_printer_.  This starts propagating any special processing required
   for the new device.  In our case, it merely causes the open entry in the
   IOCB to point to our open entry. */

complete_attach: entry (a_iocbp, a_code);

/* copy input args */
	iocbp = a_iocbp;				/* ptr to iocb to alter */
	a_code = 0;

	if my_area_ptr = null then
	     my_area_ptr = get_system_free_area_ ();

/* mask & alter the IOCB */
	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);
	iocbp -> iocb.open = hblp_open;
	call iox_$propagate (iocbp);
	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

/* place init_iocbp does a non-local goto to get out through if not attached */
return_now:
	return;
%page;

/* replacement for iox_$open in remote_printer_ */

/* this entrypoint is identical to that in remote_printer_ EXCEPT

   . it opens it's output switch for input/output where remote_printer_ only
   opens for output.

   . it uses our control, modes and put_chars entrypoints.
*/

hblp_open: entry (a_iocbp, a_mode, a_sw, a_code);

	call init_iocbp ("0"b);

	open_mode = a_mode;
	if ^((open_mode = Stream_output) | (open_mode = Stream_input_output)) then do;
	     a_code = error_table_$bad_mode;
	     return;
	end;

/* We will attempt to open the stream for sequential I/O first.  If that fails
   we will then go for stream I/O.  In either case we will make note of what
   worked in ad.record_io. */
	call iox_$open (ad.terminal_iocbp, Sequential_input_output, "0"b, a_code);
	if a_code = 0 then do;
	     ad.record_io = "1"b;			/* we have record interface approval */
	     call hcs_$make_ptr (null, "remote_conv_", "printer", ad.cv_proc, a_code);
	     if a_code ^= 0 then
		return;
	end;
	else do;
	     ad.record_io = "0"b;			/* we have stream interface only */
	     call iox_$open (ad.terminal_iocbp, Stream_input_output, "0"b, a_code);
	     if a_code ^= 0 then
		return;
	     call hcs_$make_ptr (null, ad.terminal || "conv_", "printer", ad.cv_proc, a_code);
	     if a_code ^= 0 then
		return;
	end;

	ad.open_description = rtrim (iox_modes (open_mode));
	ad.static_overstrike_data_ptr = null;
	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

/* These are system entries */
	iocbp -> iocb.put_chars = hblp_put_chars;
	iocbp -> iocb.control = hblp_control;
	iocbp -> iocb.modes = hblp_modes;

/* these are my entries */
	iocbp -> iocb.position = remote_printer_$remote_printer_position;
	iocbp -> iocb.close = remote_printer_$remote_printer_close;
	iocbp -> iocb.open_descrip_ptr = addr (ad.open_description);

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;
%page;

/* replacement for iox_$control in remote_printer_ */

/* this entrypoint is used so we can pre/post process some of the control orders */

hblp_control: entry (a_iocbp, a_order, a_orderp, a_code);

	if debug then call debug_display (1);
	call init_iocbp ("1"b);

	orderp = a_orderp;
	order = a_order;
	code = 0;

	if order = "io_call" then do;			/* set up for command call */
	     if a_orderp = null then do;
		code = error_table_$bad_arg;
		go to control_return;
	     end;
	     order = orderp -> io_call_info.order_name;
	     orderp = null;
	end;

/* remember to ignore or call prt_conv_ when processing data */
	else if order = "prt_conv_on" | order = "prt_conv_off" then do;
	     prt_conv_on = (order = "prt_conv_on");
	     go to control_return;
	end;

/* make sure printer has printed everything sent to it */
	else if order = "runout" then do;
	     runout_mode = "1"b;
	     call check_printer_status;
	end;

/* issued by do_prt_request_ only to get to bottom of current page, 1 line
   past where bottom label would be printed on the page.  If we are not
   outputting labels, fake out prt_conv_ so it thinks it is there, otherwise
   pass the control order on only if we have a bottom label to output. */
	else if order = "end_of_page" then do;
	     if ^labels.have_bottom_label then do;
		pci.line = pci.phys_page_length - 2;
		go to control_return;
	     end;
	end;

/* issued by do_prt_request_ to get to the proper page before starting to
   display.  fake out prt_conv_ by eating the orders here
   else if order = "inside_page" | order = "outside_page" then do;
   go to control_return;
   end;
*/

/* process here so we can handle sheets_per_page properly and return a 0 error
   code if all goes well */
	else if order = "paper_info" then do;		/* Set new physical paper characteristics. */
	     if paper_info.lines_per_inch ^= 6 & paper_info.lines_per_inch ^= 8 then do;
bad_arg:		code = error_table_$bad_arg;
		go to control_return;
	     end;
	     if paper_info.phys_page_length < 10 | paper_info.phys_page_length > 127 then
		go to bad_arg;
	     if paper_info.phys_line_length < 10 | paper_info.phys_line_length > 255 then
		go to bad_arg;

	     pci.phys_page_length = paper_info.phys_page_length;
	     pci.phys_line_length = paper_info.phys_line_length;
	     pci.lpi = paper_info.lines_per_inch;

/* This is the equivalent of call to prtdim_changemode$remote_printer_modes_
   passing in a null new modes.  It insures the consistency of prt_conv_info
   structure.  It was moved here so we can special case the sheets_per_page
   data */

	     pci.rmarg = pci.phys_line_length;
	     pci.lmarg = 0;

	     if pci.overflow_off then do;
		pci.top_label_length,		/* "noskip" and page labels are inconsistent */
		     pci.bot_label_length = 0;
		pci.page_length = pci.phys_page_length; /* max number of lines on each page */
		pci.sheets_per_page = 1;		/* one sheet per page in noskip mode */
	     end;

/* "^noskip" mode, compute module 10 lines perpage & physical sheets of paper per page */
	     else do;
		pci.page_length = pci.phys_page_length - mod (pci.phys_page_length, 10);
		pci.sheets_per_page =
		     divide (pci.page_length - 1 + pci.phys_page_length, pci.phys_page_length, 17, 0);
	     end;

	     go to control_return;
	end;

/* let the prtdim control order processor have at the control order.  If it
   returns an error code, it probabily couldn't handle it.  In that case we
   will pass it to the next I/O module following us which may be able to
   handle it. */
	call remote_printer_control_ (iocbp, order, orderp, code);
	if code ^= 0 then do;			/* if not done or partially completed, pass it on */
	     call iox_$control (ad.terminal_iocbp, order, orderp, ec);
	     if ec = 0 then
		code = 0;				/* let the code from remote_printer_control prevail */
	end;

/* we will post-process the following control orders to allow for any special
   processing required for the laser printer */

/* We will reset pci.page_length to physical page length modulo 10 */
	if order = "reset" then do;
	     unspec (labels) = "0"b;			/* reset our page labels data */
	     last_char_was_ff = "1"b;			/* we will always start on fresh page */
	     prt_conv_on = "1"b;			/* we will always handle conversion ourselves */
	     pci.page_length = pci.phys_page_length - mod (pci.phys_page_length, 10);
	     if ad.static_overstrike_data_ptr ^= null then do;
		free ad.static_overstrike_data_ptr -> osdata;
		ad.static_overstrike_data_ptr = null;
	     end;
	end;

/* set up our internal control orders to handle prt_conv_'s label processing */
	else if order = "page_labels" then do;
	     unspec (labels) = "0"b;			/* reset our page labels data */
	     if pci.top_label_length ^= 0 then do;
		labels.delta_lines = labels.delta_lines + 2;
		labels.have_labels = "1"b;
		labels.have_top_label = "1"b;
		labels.need_initial_ff = "1"b;
	     end;
	     if pci.bot_label_length ^= 0 then do;
		labels.delta_lines = labels.delta_lines + 2;
		labels.have_labels = "1"b;
		labels.have_bottom_label = "1"b;
		labels.need_initial_ff = "1"b;
	     end;
	     if pci.page_length + labels.delta_lines > pci.phys_page_length then
		pci.page_length = pci.phys_page_length - labels.delta_lines;
	end;

control_return:
	a_code = code;

	return;
%page;

/* replacement for iox_$modes in remote_printer_ */

hblp_modes: entry (a_iocbp, a_new_modes, a_old_modes, a_code);

	if debug then call debug_display (2);
	call init_iocbp ("1"b);
	code = 0;

	call remote_printer_modes_ (iocbp, a_new_modes, a_old_modes, a_code);

/* the following is copied from prtdim_changemode.pl1.  It is put here so we
   can recompute the sheets_per_page field properly */
	if ^pci.overflow_off then do;			/* "^noskip" mode */
	     pci.sheets_per_page =
		divide (pci.page_length - 1 + pci.phys_page_length, pci.phys_page_length, 17, 0);
	end;

	if a_new_modes = "default" then do;
	     call iox_$modes (ad.terminal_iocbp, a_new_modes, "", ignore);
	end;
	else if index (a_new_modes, "non_edited") ^= 0 then do;
	     i = index (a_new_modes, "non_edited");
	     if i = 1 then
		call iox_$modes (ad.terminal_iocbp, "non_edited", "", ignore);
	     else if substr (a_new_modes, i - 1, 1) = "^" then
		call iox_$modes (ad.terminal_iocbp, "default", "", ignore);
	     else call iox_$modes (ad.terminal_iocbp, "non_edited", "", ignore);
	end;
	else if index (a_new_modes, "rawo") ^= 0 then do;
	     i = index (a_new_modes, "rawo");
	     if i = 1 then
		call iox_$modes (ad.terminal_iocbp, "rawo", "", ignore);
	     else if substr (a_new_modes, i - 1, 1) = "^" then
		call iox_$modes (ad.terminal_iocbp, "^rawo", "", ignore);
	     else call iox_$modes (ad.terminal_iocbp, "rawo", "", ignore);
	end;

	return;
%page;

/* replacement for iox_$put_chars in remote_printer_ */

hblp_put_chars: entry (a_iocbp, a_data_ptr, a_data_chars, a_code);

dcl  (col_no, line_no) fixed bin;

	if debug then call debug_display (3);
	call init_iocbp ("1"b);
	code = 0;

	if a_data_chars < 0 | a_data_chars > sys_info$max_seg_size * 4 then do;
	     a_code = error_table_$bad_arg;
	     return;
	end;

	total_chars, remaining_chars = a_data_chars;	/* remaining_chars is decremented as data is sent */
	charp = a_data_ptr;				/* charp is bumped by prt_conv_ as data is sent */

	call iox_$control (ad.terminal_iocbp, "select_device", addr (printer_device), code);
	if code ^= 0 then
	     go to put_chars_ret;

/* allocate the terminal_io_record */
	terminal_io_record_element_size = 9;		/* character data */
	terminal_io_record_n_elements = 3 * ad.phys_line_length; /* enough room for 1 printing character and 2 non-printing
						   characters per column (eg: DC1-u X) */

/* get copy of terminal io record that we will send out */
	allocate terminal_io_record in (my_area) set (terminal_io_record_ptr);

	unspec (terminal_io_record) = "0"b;		/* clear everything */
	terminal_io_record.version = terminal_io_record_version_1;
	terminal_io_record.device_type = ad.device_type;
	terminal_io_record.element_size = terminal_io_record_element_size;
	terminal_io_record.n_elements = terminal_io_record_n_elements;

	if ad.record_io then
	     prt_conv_outp = terminal_io_record_ptr;	/* full record for record interface */
	else prt_conv_outp = addr (terminal_io_record.data); /* use the string portion for stream interface */

	send_raw = "0"b;
	get_printer_status = "0"b;
	osdata_ptr = ad.static_overstrike_data_ptr;
	top_line_drop_count = (pci.phys_page_length - pci.page_length - labels.delta_lines) / 2;
%page;
	do while (remaining_chars > 0 | pci.slew_residue > 0);
						/* so keep trying while there is anything to slew */
	     cur_page = pci.page_count;		/* save the page number */

/* if prt_conv_on switch is ON, use prt_conv_ to parse each line and determine
   when page breaks occur. */
	     if prt_conv_on then do;
		call prt_conv_ (charp, remaining_chars, prt_conv_outp, record_len, pcip);
		if debug then call debug_display (4);

/* see if any overstriking is required for this line */
		if (substr (output_string, record_len, 1) = CR
		     | pci.level > 0
		     | pci.slew_residue < 0)
		     | osdata_ptr ^= null then do;
		     call process_overstrike_string;
		end;
		else send_raw = "0"b;		/* no special processing on this line */
	     end;

/* if prt_conv_on switch is OFF, just pass all characters on.  We will ignore
   any form feeds because they might be binary data instead of a true form feed. */
	     else do;
		prt_conv_outp = charp;
		record_len = remaining_chars;
		remaining_chars = remaining_chars - record_len;
	     end;

/* if we are not printing, just ignore any of the output code */
	     if ad.noprint then
		go to skip_line_print;

/* if we are not running in prt_conv_on mode (raw output), just output the line */
	     if ^prt_conv_on then
		go to send_line_out;

/* skip this line if 2nd sucesssive Form Feed */
	     if output_string = FF then do;		/* have line just containing FF */
		if last_char_was_ff then		/* already ejected one page */
		     go to skip_line_print;		/* so ignore the line */
		last_char_was_ff = "1"b;		/* remember this FF */
	     end;
	     else do;				/* have data */
		last_char_was_ff = (substr (output_string, record_len, 1) = FF); /* remember if this line ends in FF */
	     end;

/* we just found a form feed.  If we are in labels mode, it is
   1) the one just following the top label if top labels are being used.
   .  We have to replace it with a new line.  If this is the first label being
   .  generated, we issue a form feed to get us to the next page then display
   .  the top label.  For all subsequent labels, we just replace the form feed
   .  with a new line since prt_conv_ will space us to the next page properly.
   2) The one just following the bottom label if top labels are not being used.
   .  In this case, we will do nothing.
   If we are not in labels mode, it follows the last line on the previous page
   so adjust the top line down so it is centered vertically on the page */

	     if last_char_was_ff then do;
		if labels.have_labels then do;
		     if labels.have_top_label then do;
			if labels.need_initial_ff then do;
			     labels.need_initial_ff = "0"b;
			     temp_line = FF;
			end;
			else temp_line = "";
			temp_line = temp_line || substr (output_string, 1, record_len - 1);
			temp_line = temp_line || NL;
			temp_line = temp_line || NL;
			record_len = length (temp_line);
			output_string = temp_line;
			if debug then call debug_display (5);
		     end;
		end;
		else do;
		     if top_line_drop_count > 0 then do;
			temp_line = output_string;
			temp_line = temp_line || copy (NL, top_line_drop_count);
			record_len = length (temp_line);
			output_string = temp_line;
		     end;
		end;
	     end;

/* see if the slew residue denotes there are multiple new lines to follow this
   one.  If not zero, add the extra new lines to this record so that only one
   call is made to iox_$put_chars instead of one for each slew residue count. */
	     if pci.slew_residue > 0 then do;
		i = terminal_io_record.n_elements - record_len; /* determine # chars left in record */
		if pci.slew_residue < i then
		     i = pci.slew_residue;
		temp_line = output_string;
		temp_line = temp_line || copy (NL, i);
		record_len = length (temp_line);
		output_string = temp_line;
		pci.slew_residue = pci.slew_residue - i;
	     end;

/* output the data line itself */
send_line_out:
	     if ad.record_io then do;
		call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr,
		     4 * currentsize (terminal_io_record), code);
	     end;
	     else do;				/* stream output */
		if send_raw then
		     call iox_$modes (ad.terminal_iocbp, "rawo", old_modes, ignore);
		call iox_$put_chars (ad.terminal_iocbp, prt_conv_outp, record_len, code);
		if send_raw then
		     call iox_$modes (ad.terminal_iocbp, "^rawo", "", ignore);
	     end;
	     if code ^= 0 then
		go to put_chars_ret;		/* trouble */

skip_line_print:

/* compute lines and pages based on function of bytes if running in rawo mode */
	     if ^prt_conv_on then do;
		pci.line = 0;
		pci.line_count = pci.line_count + total_chars / 60;
		pci.page_count = pci.page_count + total_chars / 3600;
	     end;

	     if cur_page ^= ad.page_count then do;	/* did we turn another page? */
		ad.stop_counter = ad.stop_counter + 1;	/* bump the page stop counter */
		if ad.single_page | (ad.stop_every ^= 0 & ad.stop_counter >= ad.stop_every) then do;
		     ad.stop_counter = 0;
		     code = error_table_$request_pending;
						/* say we were not done yet */
		     go to put_chars_ret;		/* exit the loop and return to caller */
		end;
	     end;
prt_conv_loop_end:
	end;

put_chars_ret:

	if terminal_io_record_ptr ^= null then do;
	     free terminal_io_record_ptr -> terminal_io_record in (my_area);
	end;

	ad.static_overstrike_data_ptr = osdata_ptr;

	ad.chars_printed = ad.chars_printed + total_chars - remaining_chars;
						/* record our progress */

	a_code = code;
	return;
%page;
process_overstrike_string: proc;

/* this routine will do the following:

   1. If there is no current overstrike data, it will save the current string
   and let it be output as is.

   2. If there is current overstrike data, compare each character in the new
   string for matches with all other text outputted for this line.  If there
   are matches it will add a 'Begin_bold" before the characters and follow
   them with an 'End_bold' command.  It will use this new line as the output
   line.

   3. If the current line ends in a line feed, it will release the overstrike
   structure */

dcl  Begin_bold char (2) int static options (constant)	/* ESC O */
	init ("O");
dcl  End_bold char (2) int static options (constant)	/* ESC & */
	init ("&");

dcl  tmp_line char (osdata.line_size) based;
dcl  bold_on bit (1);

/* If we have no current overstrike data available, allocate a buffer for 5
   lines.  If we already have more than 5 lines of data allocate a larger
   buffer and add the new line to it */

	if osdata_ptr = null then do;
	     osdata_line_count = 5;
	     osdata_line_size = terminal_io_record.n_elements;
	     allocate osdata in (my_area);
	     osdata.line_count = 0;
	     osdata.line (*, *) = "";
	     osdata.bolding (*) = "0"b;
	end;
	else if osdata.line_count + 1 > osdata.max_line_count then do;
	     osdata_line_count = osdata.max_line_count + 5;
	     osdata_line_size = osdata.line_size;
	     allocate osdata in (my_area) set (osdata_temp_ptr);
	     osdata_temp_ptr -> osdata.line_count = osdata.line_count;
	     osdata_temp_ptr -> osdata.bolding (*) = "0"b;
	     osdata_temp_ptr -> osdata.line (*, *) = "";
	     do i = 1 to osdata.line_count;
		addr (osdata_temp_ptr -> osdata.line (i, 1)) -> tmp_line =
		     addr (osdata.line (i, 1)) -> tmp_line;
	     end;
	     free osdata;
	     osdata_ptr = osdata_temp_ptr;
	end;
	osdata.line_count = osdata.line_count + 1;
	addr (osdata.line (osdata.line_count, 1)) -> tmp_line = output_string;
	send_raw = "0"b;				/* assume no special chars in output line */

/* if this is the first line then just let that line print as is */
	if osdata.line_count = 1 then
	     return;

/* Now process the new data line.  Check each column position outputted so far
   for duplicate chars in this line and turn on the bolding bit if found */
	osdata.bolding (*) = "0"b;			/* no bolding yet */
	do col_no = 1 to record_len;
	     do line_no = 1 to osdata.line_count - 1 while (^osdata.bolding (col_no));
		if osdata.line (osdata.line_count, col_no) ^= " " then do;
		     if osdata.line (osdata.line_count, col_no) = osdata.line (line_no, col_no) then do;
			osdata.bolding (col_no) = "1"b;
		     end;
		end;
	     end;
	end;

/* Now see if any bolding bits were turned on.  If so we have to build a new
   output line putting the Begin/End_bold command sequences around each set of
   characters to be bolded; otherwise just return */
	if index (string (osdata.bolding), "1"b) = 0 then
	     go to process_overstrike_return;

	temp_line = "";
	bold_on = "0"b;
	do col_no = 1 to record_len;
	     if ^osdata.bolding (col_no) then do;
		if bold_on then do;
		     send_raw = "1"b;
		     bold_on = "0"b;
		     temp_line = temp_line || End_bold;
		end;
	     end;
	     else do;
		if ^bold_on then do;
		     send_raw = "1"b;
		     bold_on = "1"b;
		     temp_line = temp_line || Begin_bold;
		end;
	     end;
	     temp_line = temp_line || osdata.line (osdata.line_count, col_no);
	end;
	if bold_on then do;
	     send_raw = "1"b;
	     bold_on = "0"b;
	     temp_line = temp_line || End_bold;
	end;

/* replace the output line with the new one with bolding characters inserted */
	record_len = length (temp_line);
	output_string = temp_line;

/* if this line is last one of an overstrike set, get rid of the overstrike
   data structure */
process_overstrike_return:
	if substr (output_string, record_len, 1) = NL then do;
	     free osdata;
	     osdata_ptr = null;
	     if send_raw then do;
		record_len = record_len + 1;
		substr (output_string, record_len, 1) = CR;
	     end;
	end;
     end process_overstrike_string;
%page;

check_printer_status: proc;

/* this routine will make sure
   1. the printer is still talking to the user.
   2. it is still in an error free condition (has paper & toner, all covers closed)
   3. It has printed everything sent to it. (no data waiting) */

dcl  status_requests char (6) unaligned;

dcl  STX char (1) int static options (constant) init ("");
dcl  PAGE_TIMEOUT fixed bin (71) int static init (15000000);/* 15 seconds */
dcl  PROBLEM_TIMEOUT fixed bin (71) int static init (300000000); /* 5 minutes */

dcl  chars_read fixed bin (21);
dcl  input_buffer char (256);
dcl  stx_loc fixed bin;
dcl  timeout_to_use fixed bin (71);

dcl  1 status_byte_1 unaligned,
       2 pad1 bit (1),
       2 parity bit (1),
       2 test_in_progress bit (1),
       2 no_data bit (1),
       2 cover_open bit (1),
       2 auto_lf bit (1),
       2 no_paper bit (1),
       2 hmi bit (1),
       2 no_toner bit (1);

dcl  1 status_byte_3 unaligned,
       2 pad1 bit (1) unaligned,
       2 parity bit (1) unaligned,
       2 always_zero bit (5) unaligned,
       2 exit_paper_jam bit (1) unaligned,
       2 feed_paper_jam bit (1) unaligned;

	get_printer_status = "0"b;			/* be nice to caller */
	if ("1"b) then return;			/* ignore for now */
	status_requests = Request_status_byte_1 || Request_status_byte_3;
						/* make sure modes are such that we can communicate properly */
	call iox_$modes (ad.terminal_iocbp, "breakall,rawo,rawi", old_modes, ec);
	timeout_to_use = PAGE_TIMEOUT;		/* allow 15 seconds for it to respond */

request_status_again:				/* request the status */
	call iox_$put_chars (ad.terminal_iocbp, addr (status_requests), length (status_requests), ec);

/* wait for status return from the printer. */
read_status_again:
	call timed_io_$get_chars (ad.terminal_iocbp, timeout_to_use, addr (input_buffer),
	     length (input_buffer), chars_read, ec);

/* if the get_chars times out, it's because the communications stopped.
   It might be that comm is gone or the printer itself may have a problem.
   Warn someone about the problem. then wait to see if the have corrected */
	if ec ^= 0 then do;
	     if ec = error_table_$timeout then do;
		call remote_driver_$problem_notification ("The printer is not responding.");
		timeout_to_use = PROBLEM_TIMEOUT;	/* wait for 5 minutes before complaining again */
		go to read_status_again;
	     end;
	end;

/* got a response from the printer, look for the STX which starts the message */
	stx_loc = index (input_buffer, STX);
	if stx_loc = 0 then				/* not there */
	     goto read_status_again;			/* must be more to read */

/* Now that we have start of message, isolate the status byte and check it */
	unspec (status_byte_1) = unspec (substr (input_buffer, stx_loc + 1, 1));
	unspec (status_byte_3) = unspec (substr (input_buffer, stx_loc + 3, 1));

	if status_byte_1.cover_open then do;
	     call remote_driver_$problem_notification ("The printer has a cover open.");
	     go to request_status_again;
	end;

	if status_byte_1.no_paper then do;
	     call remote_driver_$problem_notification ("The printer is out of paper.");
	     go to request_status_again;
	end;

	if status_byte_3.feed_paper_jam then do;
	     call remote_driver_$problem_notification ("The printer has a feed paper jam.");
	     go to request_status_again;
	end;

	if status_byte_3.exit_paper_jam then do;
	     call remote_driver_$problem_notification ("The printer has a exit paper jam.");
	     go to request_status_again;
	end;

	if ^status_byte_1.no_data then		/* still has some data in it */
	     go to request_status_again;

/* reset modes back to the way they were when we started */
	call iox_$modes (ad.terminal_iocbp, old_modes, "", ec);

     end check_printer_status;
%page;

/* subroutines */

/* This proc handles faults that occur while masked */

handler: procedure ();

dcl  ignore fixed bin (35);				/* dummy error code */

	if mask then
	     call hcs_$reset_ips_mask (mask, mask);

	mask = ""b;

	call continue_to_signal_ (ignore);

	return;

     end handler;


init_iocbp: proc (check_for_open);

/* set up all required variables from the iocb */

dcl  check_for_open bit (1);				/* if ON,  check for iocb being open */
						/* if OFF, check for iocb being closed */

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	if adp = null then do;
	     a_code = error_table_$not_attached;
	     go to return_now;
	end;
	if ^check_for_open then do;
	     if iocbp -> iocb.open_descrip_ptr ^= null then do;
		a_code = error_table_$not_closed;
		go to return_now;
	     end;
	end;
	else do;
	     if iocbp -> iocb.open_descrip_ptr = null then do;
		a_code = error_table_$not_open;
		go to return_now;
	     end;
	end;

	pcip = addr (ad.remote_pci);
	a_code = 0;

     end init_iocbp;
%page;
dcl  debug bit (1) int static init ("0"b);
dcl  ioa_ entry () options (variable);

dbgn: entry;
	debug = "1"b;
	goto dbg_report;

dbgf: entry;
	debug = "0"b;
	goto dbg_report;

dbgs: entry;
dbg_report:
	call ioa_ ("Debug is ^[ON^;OFF^]", debug);
	return;

debug_display: proc (which_display);

dcl  which_display fixed bin;

	if which_display = 1 then
	     call ioa_ ("hblp_control - order = ^a", a_order);
	else if which_display = 2 then
	     call ioa_ ("hblp_modes - new_modes = ^a", a_new_modes);
	else if which_display = 3 then
	     call ioa_ ("hblp_put_chars - string length = ^d", a_data_chars);
	else if which_display = 4 then
	     call ioa_ ("^5d ^5d ^5d ^5d ^5d ^5d ^5d     ^[NL^]^[FF^]^[CR^]     ^a",
		pci.page_count, pci.line_count, pci.line, pci.func,
		pci.level, pci.slew_residue, record_len - 1,
		(substr (output_string, record_len, 1) = NL),
		(substr (output_string, record_len, 1) = FF),
		(substr (output_string, record_len, 1) = CR),
		substr (output_string, 1, record_len - 1));
	else if which_display = 5 then
	     call ioa_ ("print_the_line changing FF to NL & outputting FF");

     end debug_display;
%page; %include io_call_info;
%page; %include iocb;
%page; %include iod_tables_hdr;
%page; %include iodd_hblp_commands;
%page; %include iox_modes;
%page; %include mode_string_info;
%page; %include prt_conv_info;
%page; %include prt_info;
%page; %include prt_order_info;
%page; %include q_group_tab;
%page; %include remote_attach_data;
%page; %include terminal_io_record;

     end iodd_hblp_support_;




		    remote_conv_.alm                11/15/82  1900.8rew 11/15/82  1535.0       45225



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************

" remote_conv_:  Conversion routine for producing "standard" terminal I/O records for output to an RJE station or a remote
"   host system by an I/O daemon (driven by either remote_driver_ or workstation_sim_driver_).  See the prt_conv_ module
"   for a description of the manner in which this routine is utilized.

" Created:  December 1979 by G. Palter

	name	remote_conv_

	segdef	printer			" output destined for a line printer
	segdef	punch			" output destined for a card punch (to be obsolete soon)
	segdef	teleprinter		" output destined for the RJE station's operator's console


" Transfer vectors for the three types of output devices -- printer, punch, and teleprinter

printer:	tra	send_setup_printer		" initialize new printer output record
	tra	send_characters		" output some characters into the record
	tra	send_slew_pattern		" slew (skip) to specified VFU pattern
	tra	send_slew_count		" slew (skip) specified number of lines

punch:	tra	send_setup_punch		" initialize new punch output record
	tra	send_characters
	tra	pr7|0			" for punch:  meaningless to slew to pattern
"					" for punch:  meaningless to slew by count
	lda	0,du			" set residue count to claim entire skip done
	tra	pr7|0

teleprinter:
	tra	send_setup_teleprinter	" initialize new teleprinter output record
	tra	send_characters		" output some characters into the record
	tra	send_slew_pattern		" slew (skip) to specified VFU pattern
	tra	send_slew_count		" slew (skip) specified number of lines


	tempd	tior_ptr			" -> the record's header
	tempd	saved_pr4
	tempd	saved_pr5
" 
	include terminal_io_record
" 
" Initialize an output record

send_setup_printer:
	ldq	tior_printer_device,dl	" need to set device type in record header
	tra	send_setup_common

send_setup_punch:
	ldq	tior_punch_device,dl
	tra	send_setup_common

send_setup_teleprinter:
	ldq	tior_teleprinter_device,dl
"	tra	send_setup_common


send_setup_common:
	spri3	tior_ptr			" save pointer to start of output record

	stq	pr3|tior.device_type	" save device type from above

	ldq	tior_version_1,dl		" fill in rest of header with "default" settings
	stq	pr3|tior.version

	ldq	slew_single_line		" set to slew by 1 line
	stq	pr3|tior.slew_control

	stz	pr3|tior.flags		" not binary

	ldq	9,dl			" element size is 9 (characters)
	stq	pr3|tior.element_size

	stz	pr3|tior.n_elements		" no data yet

	ldq	4*tior.data,dl		" move pointer past header (to this offset)
	a9bd	pr3|0,ql

	tra	pr7|0			" setup completed


slew_single_line:				" constant to slew 1 line
	vfd	18/tior_slew_by_count,18/1
" 
" Place data (with possible leading whitespace) into the record

send_characters:
	spri4	saved_pr4			" need a pointer to record header
	epp4	tior_ptr,*

	eaq	0,2			" whitespace count into QU
	tmoz	no_whitespace		" ... none needed
	qrl	18			" ... put it into QL (sigh)

	mlr	(),(pr,rl),fill(040)	" insert requested # of spaces
	desc9a	*,0
	desc9a	pr3|0,ql

	a9bd	pr3|0,ql			" ... update output pointer
	asq	pr4|tior.n_elements		" ... update record length in buffer header

no_whitespace:
	lrl	72-18			" put count of characters into QL (sigh)

	mlr	(pr,rl),(pr,rl)		" move the data
	desc9a	pr2|0,ql
	desc9a	pr3|0,ql

	a9bd	pr2|0,ql			" ... update input pointer
	a9bd	pr3|0,ql			" ... update output pointer
	asq	pr4|tior.n_elements		" ... update record length in buffer header

	eax2	0			" be sure X2 is zero (all spaces done)

	epp4	saved_pr4,*
	tra	pr7|0			" all done
" 
" Slew to specified pattern

send_slew_pattern:
	spri4	saved_pr4			" once again -- need pointer to record header
	epp4	tior_ptr,*

	spri5	saved_pr5			" used for RPT instruction
	epp5	slew_pattern_table

	eax7	0			" initialize for search

	rpt	n_slew_patterns,2,tze	" search for the pattern
	cmpa	pr5|0,7

	ldq	pr5|-1,7			" pickup the proper slew control word
	stq	pr4|tior.slew_control	" ... and put it into the record

	epp4	saved_pr4,*
	epp5	saved_pr5,*
	tra	pr7|0			" return


" Slew N lines (in A)

send_slew_count:
	spri4	saved_pr4
	epp4	tior_ptr,*

	ora	slew_N_lines		" put in slew by count opcode
	sta	pr4|tior.slew_control

	lda	0,du			" clear the A (took all lines)

	epp4	saved_pr4,*
	tra	pr7|0


" Constants

	equ	n_slew_patterns,3		" NOTE:  must be changed whenever following table is modified

slew_pattern_table:
	vfd	o36/0			" slew to top of page
	vfd	18/tior_slew_to_top_of_page,18/0
	vfd	o36/13			" slew to top of inside page
	vfd	18/tior_slew_to_inside_page,18/0
	vfd	o36/11			" slew to top of outside page
	vfd	18/tior_slew_to_outside_page,18/0

slew_N_lines:
	vfd	18/tior_slew_by_count,18/0

	end




		    remote_driver_.pl1              11/01/88  1243.7rew 11/01/88  1237.7      878697



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

/* format: style4 */

/* format: off */

/* Standard remote device driver control module for the I/O daemon. */

/* Adapted from g115_driver_ by David Vinograd - March 1977 */
/* Modified by J. C. Whitmore, 4/78, for new dprint_msg format and Daemon upgrade */
/* Modified by J. C. Whitmore, 8/78, to defer requests over phys ll and for auto defer time init */
/* Modified by J. C. Whitmore, 10/78, to extend the number of RJE stations */
/* Modified by J. C. Whitmore, 3/79, for minor bug fixes */
/* Modified by C. Hornig, 6/79, for multiple minor devices of the same generic type */
/* Modified by J. C. Whitmore, 10/79, for binary punching and commands sep_cards, punch, pun_control */
/* Modified: 2 April 1981 by G. Palter correct a bug which causes use of "logout", "new_device", etc. requests during the
      processing of a request to cause a null pointer fault by iox_ followed by flushing the remaining requests
      in the queue */
/* Modified: October 1981 by C. Hornig to support attach_type 3 (dial_id) */
/* Modified: 9 November 1981 by G. Palter to use read_password_ to get the station password if it is omitted from the
      station command */
/* Modified: 17 November 1981 by G. Palter to not consider inability to set hangup_proc as fatal */
/* Modified: 11 December 1981 by G. Palter to support auto_go and force_ctl_char for printer minor devices */
/* Modified: November 1983 by C. Marker Added support for force_nsep */
/* Modified: January 1984 by C. Marker  Added probe as a legal command in test mode. */
/* Modified 1984-08-17 by E. Swenson for Version 2 PNTs. */
/* Modified 14 Feb 1984 by Jim Homan for logout_on_hangup */
/* Modified: February 23, 1985 by C. Marker to use version 5 message segments */


/****^  HISTORY COMMENTS:
  1) change(84-02-14,Homan), approve(87-04-06,MCR7656),
     audit(87-06-13,Beattie), install(87-08-06,MR12.1-1068):
     Submit logout_on_hangup changes for installation.
  2) change(87-05-01,Gilcrease), approve(87-05-14,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Update to version 4 dprint_msg.
  3) change(88-02-18,Brunelle), approve(88-06-28,MCR7911),
     audit(88-10-26,Parisek):
     Add support for single/continuous paper type.
  4) change(88-08-29,Farley), approve(88-06-28,MCR7911),
     audit(88-10-26,Parisek):
     Updated for version 5 dprint_msg.
  5) change(88-10-31,Brunelle), approve(88-10-31,MCR7911),
     audit(88-11-01,Wallman):
     Correct problem of requiring a model name if single sheet mode defined.
                                                   END HISTORY COMMENTS */


/* format: on */

remote_driver_:
     procedure ();

	return;					/* this is not a legal entry */

/* Parameters */

dcl  a_argp ptr parameter;
dcl  a_source fixed bin parameter;			/* 1 = master console, 2 = slave */
dcl  a_state fixed bin parameter;			/* 0 = not quite ready to handle a request */
						/* 1 = drivers are ready */
						/* 2 = command entered after a quit */
dcl  a_stream char (*) parameter;
dcl  a_banner_type fixed bin parameter;			/* type of banner to be written  */
						/* 1 = heading banner            */
						/* 2 = tail banner               */
						/* 3 = error message             */
dcl  a_data_ptr ptr parameter;			/* pointer to output request data or  */
						/* to char(256) varying string error msg */
dcl  a_code fixed bin (35) parameter;			/* error code */

/* Automatic */

dcl  age fixed bin;
dcl  arg_string char (32);
dcl  argp ptr;
dcl  attach_desc char (256) var;
dcl  banner_type fixed bin;
dcl  code fixed bin (35);
dcl  control bit (36) aligned;
dcl  date_string char (24);
dcl  device_type char (32);
dcl  digit char (1);
dcl  element_size fixed bin;
dcl  err_msg char (200);
dcl  format_code fixed bin;
dcl  header_card2 char (80);
dcl  (i, idx) fixed bin;				/* general index variable */
dcl  ignore_code fixed bin (35);			/* error code to be ignored */
dcl  input_line char (80);
dcl  len fixed bin;
dcl  iocbp ptr;
dcl  major_args char (major_args_length) based (major_args_ptr);
dcl  major_args_length fixed bin int static;
dcl  major_args_name char (256) varying;
dcl  major_comm_module char (32) var;
dcl  major_desc char (256) var;
dcl  major_terminal_module char (32) var;
dcl  major_tty char (32) var;
dcl  minor_args char (minor_args_length) based (minor_args_ptr);
dcl  minor_args_length fixed bin int static;
dcl  minor_args_name char (256) varying;
dcl  model char (32) var;
dcl  my_area area based (my_area_ptr);			/* area to allocate in */
dcl  nchar fixed bin;
dcl  need_station bit (1);
dcl  new_ll fixed bin;				/* temp for the new phys line length */
dcl  new_lpi fixed bin;				/* and for the new lines per inch value */
dcl  new_pl fixed bin;				/* temp for setting the phys page length */
dcl  not bit (1);
dcl  omode char (256);
dcl  opr_msg char (160);				/* message to tell operator we are ready, etc. */
dcl  p ptr;
dcl  p2 ptr;
dcl  pos fixed bin;
dcl  pool_dir char (168);				/* dirname for the card pool root */
dcl  printer_count fixed bin;				/* number of printer minor devices (during init) */
dcl  punch_count fixed bin;				/* number of punch minor devices (during init) */
dcl  ready_device bit (1) aligned;			/* ON => there's at least one minor device that's ready */
dcl  req_string char (12);				/* place for the request number as characters */
dcl  rqt_string char (168) var;
dcl  save_code fixed bin (35);
dcl  source fixed bin;
dcl  state fixed bin;
dcl  station char (32);
dcl  station_password char (8);
dcl  status bit (72) aligned;				/* status code for old ios_ calls */
dcl  stream char (32) aligned;
dcl  temp_password char (8);
dcl  1 term_info aligned like terminal_info;
dcl  tries fixed bin;
dcl  value fixed bin;


dcl  st_code fixed bin (35) based;			/* first word of the ios_ status */
%page;

dcl  1 form_info aligned,				/* data from the form paging dim */
       2 page_length fixed bin,
       2 line_length fixed bin,
       2 line_no fixed bin,
       2 carriage_position fixed bin,
       2 aligned bit (1) unal,			/* tells if the dim considers the forms aligned */
       2 pad bit (35) unal;

dcl  1 hangup_info aligned,				/* structure used to set hangup_info proc */
       2 entry entry,
       2 data_ptr ptr,
       2 priority fixed bin;

dcl  1 read_info aligned,
       2 read_ev_chan fixed bin (71),
       2 input_ready bit (1) unal;

dcl  1 ev_chan_list aligned based,
       2 number fixed bin,
       2 channel (12) fixed bin (71);


dcl  1 cmd_list int static aligned,			/* iodd_parse_$command structure for request command level */
       2 max fixed bin init (5),			/* allow command and four args max */
       2 number_tokens_found fixed bin,
       2 cmd char (64) var,				/* the command part of the line */
       2 arg (4) char (64) var;			/* the arguments */

/* Based Variables */

dcl  sys_dir char (168) based;

dcl  1 arg_list aligned based (argp),			/* iodd_parse_$command structure */
       2 max_tokens fixed bin,			/* space allocated, do not change */
       2 n_tokens fixed bin,				/* number of tokens from command line (including cmd) */
       2 command char (64) var,			/* the first token is the command */
       2 arg (n_tokens - 1) char (64) var;		/* the other tokens are args to the command */

dcl  pun_ctl_ptr ptr;

dcl  1 pun_ctl based (pun_ctl_ptr),			/* punch control structure */
       2 sep_cards fixed bin,				/* 0 = none, 1 = standard: what type of separators to punch */
       2 modes,
         3 auto_punch bit (1) unal;			/* FALSE if we should come to request command level */
%page;

/* External Entries */

dcl  add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible;
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  debug entry ();
dcl  do_prt_request_ entry (ptr, ptr, fixed bin (35));
dcl  do_prt_request_$error_during_request entry (char (*));
dcl  do_prt_request_$single_copy entry ();
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_system_free_area_ entry () returns (ptr);
dcl  initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
dcl  ioa_$rsnnl entry options (variable);
dcl  iodd_command_processor_ entry (fixed bin, fixed bin, char (*) aligned, fixed bin (35));
dcl  iodd_get_cmd_ entry (ptr, fixed bin, fixed bin, bit (36) aligned, char (*), fixed bin, fixed bin (35));
dcl  iodd_hangup_$iodd_hangup_ entry;
dcl  iodd_listen_ entry (ptr);
dcl  iodd_msg_ entry options (variable);
dcl  iodd_parse_$args entry (char (*) var, char (*)) returns (char (256) var);
dcl  ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned);
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  iox_$look_iocb entry (char (*) aligned, ptr, fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  output_request_ entry (char (*), fixed bin, ptr, entry, fixed bin (35));
dcl  output_request_$error_during_request entry (char (*));
dcl  output_request_$set_single_copy entry ();
dcl  iod_info_$evaluate_forms_info entry (ptr, ptr, ptr, fixed bin (35));
dcl  iodd_parse_$command entry (char (*) aligned, ptr, fixed bin (35));
dcl  message_facility_$send_message_access_class entry (char (*), char (*), char (*), ptr, bit (72) aligned, fixed bin (35));
dcl  pool_manager_$clean_pool entry (char (*), fixed bin, fixed bin, fixed bin (35));
dcl  pool_manager_$init entry (char (*), fixed bin, bit (36) aligned, fixed bin (35));
dcl  probe entry ();
dcl  read_cards_ entry (char (*), ptr, char (*), bit (1) aligned, fixed bin (35));
dcl  read_cards_$set_rqt entry (char (*), char (*), fixed bin (35));
dcl  read_cards_$set_station entry (char (*), fixed bin (35));
dcl  read_password_$switch entry (ptr, ptr, char (*), char (*), fixed bin (35));
dcl  scramble_ entry (char (8)) returns (char (8));
dcl  set_iod_val entry (char (*), char (*));
dcl  (system_privilege_$ipc_priv_off,
     system_privilege_$ipc_priv_on,
     system_privilege_$ring1_priv_off,
     system_privilege_$ring1_priv_on) entry (fixed bin (35));
dcl  timer_manager_$alarm_wakeup entry (fixed bin(71), bit(2), fixed bin(71));
dcl  timer_manager_$sleep entry (fixed bin (71), bit (2));
dcl  validate_card_input_$station entry (char (*), char (*), char (*), fixed bin (35));
dcl  write_control_form_ entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35));
dcl  write_sample_form_ entry (char (*) aligned, char (*) aligned, fixed bin (35));
dcl  write_sample_prt_banner_ entry (char (*), ptr, ptr, fixed bin (35));
%page;

/* Constants */

dcl  FALSE bit (1) int static options (constant) init ("0"b);
dcl  TRUE bit (1) int static options (constant) init ("1"b);
dcl  NL char (1) int static options (constant) init ("
");						/* the new-line character */

dcl  FF char (1) int static options (constant) init ("");						/* the form feed character */

dcl  STATION_PW_PROMPT char (23) static options (constant) init ("Enter station password:");
dcl  both fixed bin int static options (constant) init (0); /* master and slave for iodd_msg_ */
dcl  default_form_wait_time fixed bin int static options (constant) init (5);
dcl  error fixed bin int static options (constant) init (2);
dcl  error_message fixed bin int static options (constant) init (3);
dcl  head_banner fixed bin int static options (constant) init (1);
dcl  initial_print_rate fixed bin int static options (constant) init (3000); /* bits per second to the printer */
dcl  initial_punch_rate fixed bin int static options (constant) init (500); /* same for the punch */
dcl  line_length_default fixed bin int static options (constant) init (132);
dcl  line_length_max fixed bin int static options (constant) init (200);
dcl  line_length_min fixed bin int static options (constant) init (10);
dcl  log fixed bin int static options (constant) init (0);
dcl  lpi_default fixed bin int static options (constant) init (6);
dcl  lpi_max fixed bin int static options (constant) init (8);
dcl  lpi_min fixed bin int static options (constant) init (6);
dcl  master fixed bin int static options (constant) init (1);
dcl  minimum_quota fixed bin int static options (constant) init (10);
dcl  myname char (15) int static init ("remote_driver_") options (constant);
dcl  none fixed bin int static options (constant) init (0);
dcl  normal fixed bin int static options (constant) init (1);
dcl  page_length_default fixed bin int static options (constant) init (66);
dcl  page_length_max fixed bin int static options (constant) init (127);
dcl  page_length_min fixed bin int static options (constant) init (10);
dcl  pause_time_default fixed bin int static options (constant) init (10);
dcl  pause_time_max fixed bin int static options (constant) init (30);
dcl  printer_mode fixed bin int static options (constant) init (1);
dcl  printer_request fixed bin int static options (constant) init (1);
dcl  punch_raw_mode fixed bin int static options (constant) init (4);
dcl  punch_request fixed bin int static options (constant) init (2);
dcl  punch_rmcc_mode fixed bin int static options (constant) init (3);
dcl  request_command_level_state fixed bin int static options (constant) init (3);
dcl  runout_spacing_max fixed bin int static options (constant) init (60);
dcl  separator char (80) int static options (constant) init ((80)"<");
dcl  slave fixed bin int static options (constant) init (2);
dcl  slave_login_tries fixed bin int static options (constant) init (10);
dcl  space char (1) int static options (constant) init (" ");
dcl  standard fixed bin int static options (constant) init (1);
dcl  tail_banner fixed bin int static options (constant) init (2);
dcl  wakeup_time_default fixed bin int static options (constant) init (30);
dcl  zero fixed bin int static options (constant) init (0);
dcl  zero_code fixed bin int static options (constant) init (0);

/* Internal Static   */

dcl  alarm_channel fixed bin (71) int static;		/* channel used for time out checks */
dcl  ctl_msg_sent bit (1) int static init (FALSE);	/* flag set when msg sent ok */
dcl  default_printer pointer init (null ()) int static;	/* default printer driver_status pointer for commands */
dcl  default_punch pointer init (null ()) int static;	/* default punch driver_status pointer for commands */
dcl  hangup_proc_defined bit (1) int static;		/* TRUE if the device hangup proc has been set */
dcl  major_args_ptr ptr int static init (null);
dcl  minor_args_ptr ptr int static init (null);
dcl  my_area_ptr ptr int static init (null);
dcl  prt_rqt char (32) int static;
dcl  pun_rqt char (32) int static;
dcl  reader_attached bit (1) int static;		/* TRUE if the read cards command can be used */
dcl  save_request_label label int static;		/* for transfer on save command at request cmd level */
dcl  sys_priv bit (1) int static init ("1"b);		/* ON means user can set privs */
dcl  teleprinter_iocbp pointer init (null ()) int static;
dcl  terminal (2) char (32) int static;
dcl  time fixed bin (71) int static init (10);

dcl  1 ctl_wait_list int static aligned,		/* ipc wait list for the form terminal */
       2 number fixed bin,
       2 channel fixed bin (71);

dcl  1 event_info int static aligned,			/* info returned from ipc_$block */
       2 chan fixed bin (71),
       2 message fixed bin (71),
       2 sender bit (36),
       2 origin fixed bin,
       2 wait_list_index fixed bin;
%page;

dcl  1 card_info aligned int static like card_stream_info;	/* card input stream data */

dcl  1 smi aligned int static like send_mail_info;

/* Builtins */

dcl  (addr, after, before, char, character, clock, convert, copy, divide, index, length, ltrim, max, mod, null, rtrim, string, substr) builtin;

/* Conditions */

dcl  (any_other, card_command_level, cleanup, conversion,
     daemon_logout, daemon_new_device, daemon_slave_logout,
     linkage_error, no_coord, re_init, size) condition;

/*	EXTERNAL STATIC -- ERROR TABLE ENTRIES     */

dcl  error_table_$action_not_performed fixed bin (35) ext static;
dcl  error_table_$fatal_error fixed bin (35) ext static;
dcl  error_table_$io_no_permission fixed bin (35) ext static;
dcl  error_table_$ionmat fixed bin (35) ext static;
dcl  error_table_$no_operation fixed bin (35) ext static;
dcl  error_table_$noarg fixed bin (35) ext static;
dcl  error_table_$no_forms_table_defined fixed bin (35) ext static;
dcl  error_table_$not_closed fixed bin (35) ext static;
dcl  error_table_$not_detached fixed bin (35) ext static;
dcl  error_table_$undefined_order_request fixed bin (35) ext static;
dcl  iox_$error_output ext ptr;
%page;

/* This entrypoint is used to initialize the driver for the major and any
   minor devices defined. It is called from iodd_. */
init: entry (a_argp);

	on daemon_logout call drop_device;
	on daemon_slave_logout go to logout_slave;
	on daemon_new_device call drop_device;
	on no_coord call drop_device;

	stat_p = a_argp;				/* put the arg into static for easy reference */
	list_ptr = iodd_static.driver_list_ptr;		/* find list of driver status segs */
	text_strings_ptr = iodd_static.text_strings_ptr;	/* get ptr to i/o daemon table text area */

	if iodd_static.attach_type = ATTACH_TYPE_IOM then do; /* this driver expects a tty channel */
	     call iodd_msg_ (error, master, error_table_$fatal_error, myname,
		"The remote driver cannot attach to the IOM.");
	     return;				/* quit now */
	end;

	do i = 1 to iodd_static.assigned_devices;	/* initialize pointers for cleanup handler */
	     driver_ptr_list.stat_segp (i) -> driver_status.dev_out_iocbp = null ();
	     driver_ptr_list.stat_segp (i) -> driver_status.dev_ctl_ptr = null ();
	end;
	teleprinter_iocbp = null;

	iodd_static.dev_io_stream, iodd_static.dev_in_stream = "Undefined_stream!";
						/* we don't use these in this proc */

	on cleanup call detach_device;

/* this is the Type I station case
   "line:  variable;" from iod_tables */
	if iodd_static.attach_type = ATTACH_TYPE_VARIABLE_LINE then do;
	     ltep = addr (iodd_static.ltp -> line_tab.entries (iodd_static.line_tab_idx));

	     major_terminal_module, major_comm_module, major_tty = "";
	     call ioa_$rsnnl (return_string (lte.att_desc), major_desc, len, lte.chan_id);

	     teleprinter_iocbp = iodd_static.slave_in;	/* copy the iocbp set by iodd_ */

	     station = iodd_static.major_device;	/* these are the same for this case */

	     do i = 1 to iodd_static.assigned_devices;
		p = driver_ptr_list.stat_segp (i);
		p -> driver_status.attached = TRUE;	/* all will be used now */
	     end;
	     hangup_proc_defined = TRUE;		/* this was set by iodd_ for this type */
	end;
	else do;					/* this is the Type II station case */

	     hangup_proc_defined = FALSE;		/* be sure we set the hangup proc */

/* see if user wants major args to be found in a segment */
	     major_args_ptr = add_char_offset_ (addr (text_strings.chars), iodd_static.major_args.first_char - 1);
	     major_args_length = iodd_static.major_args.total_chars;
	     major_args_name = iodd_parse_$args ("indirect=", major_args);
	     if major_args_name ^= "" then do;		/* yes, grab that segment */
		call initiate_the_file (major_args_name, major_args_ptr, major_args_length, "major_args", code);
		if code ^= 0 then
		     go to clean_out;
	     end;
	     major_terminal_module, iodd_static.device_dim = iodd_parse_$args ("terminal=", major_args);

	     major_comm_module = iodd_parse_$args ("comm=", major_args);

	     major_tty = rtrim (iodd_static.attach_name);

	     model = iodd_parse_$args ("model=", major_args);

/* start building the attach description */
	     if iodd_static.attach_type = ATTACH_TYPE_DIAL then
		major_desc = "-tty ** -dial_id " || major_tty;
	     else major_desc = "-tty " || major_tty;

	     if major_terminal_module ^= "" then
		major_desc = major_desc || " -terminal " || major_terminal_module;

	     if major_comm_module ^= "" then
		major_desc = major_desc || " -comm " || major_comm_module;

	     major_desc = major_desc || space || iodd_parse_$args ("desc=", major_args);

	     call iodd_msg_ (normal, master, zero_code, "", "Attaching terminal.");

	     if iodd_parse_$args ("logout_on_hangup=", major_args) = "yes" then
		iodd_static.logout_on_hangup = TRUE;

	     if iodd_parse_$args ("slave=", major_args) = "yes" then do; /* is device also the slave? */

		iodd_static.slave_output = get_switch_name ("teleprinter");
		iodd_static.slave_input = iodd_static.slave_output;
						/* make them the same */

		attach_desc = "remote_teleprinter_ " || major_desc;
						/* build the real attach description */

		opr_msg = "ATTACH";
		call iox_$attach_ioname ((iodd_static.slave_output), teleprinter_iocbp, (attach_desc), code);
		if code ^= 0 & code ^= error_table_$ionmat & code ^= error_table_$not_detached then
		     go to tp_err;

		opr_msg = "OPEN";
		call iox_$open (teleprinter_iocbp, Stream_input_output, ""b, code);
		if code ^= 0 & code ^= error_table_$not_closed then do;
tp_err:
		     call iodd_msg_ (error, master, code, myname, "Unable to ""^a"" teleprinter for ^a.", opr_msg,
			iodd_static.attach_name);
		     call iodd_msg_ (normal, master, zero_code, "", "Attach description: ^a", attach_desc);
		     go to clean_out;
		end;

		call set_hangup_proc (teleprinter_iocbp);
						/* this will work or abort directly */

		call iox_$put_chars (teleprinter_iocbp, addr (FF), 1, ignore_code);

		p2 = addr (status);			/* set pointer so we can reference first word */
		call ios_$attach ("broadcast_errors", "broadcast_", (iodd_static.slave_output), "", status);
		if p2 -> st_code = 0 then		/* only switch error_output if this works */
		     call iox_$attach_ptr (iox_$error_output, "syn_ broadcast_errors", null, ignore_code);

		call iox_$control (teleprinter_iocbp, "read_status", addr (read_info), code);
		if code ^= 0 then do;		/* this is fatal...can't accept input. */
		     call iodd_msg_ (error, master, code, myname,
			"Fatal error.  Unable to order read_status for teleprinter.");
		     go to clean_out;
		end;

		iodd_static.chan_list_ptr -> ev_chan_list.channel (slave) = read_info.read_ev_chan;

		iodd_static.slave_ev_chan = read_info.read_ev_chan;

		iodd_static.slave_out = teleprinter_iocbp;
						/* set the slave iocbp ptrs */
		iodd_static.slave_in = teleprinter_iocbp;
		iodd_static.slave.active = TRUE;	/* slave terminal is now defined */
	     end;

/*	if a ctl terminal was defined, let it remain and inherit its slave status from iodd_ unless */
/*	it was changed above by slave= yes in the args */

	     if iodd_static.ctl_term.attached then do;
		ctl_wait_list.number = 1;
		ctl_wait_list.channel = iodd_static.ctl_ev_chan;
		alarm_channel = iodd_static.ctl_ev_chan;
		call iox_$modes (iodd_static.slave_in, "^hndlquit", omode, ignore_code);
						/* we reset read on quit */
	     end;
	     else do;
		ctl_wait_list.number = 0;		/* otherwise clear to avoid errors */
		ctl_wait_list.channel = 0;
		alarm_channel = 0;
	     end;


	     if iodd_static.slave.active then do;	/* set up switches for slave control */
		iodd_static.slave.accept_input = TRUE;
		iodd_static.slave.allow_quits = TRUE;
		iodd_static.slave.print_errors = TRUE;
		if iodd_static.slave_output = iodd_static.ctl_output then
		     iodd_static.slave.log_msg = FALSE; /* kill double messages */
		else iodd_static.slave.log_msg = TRUE;	/* send log msg to slave if not ctl terminal */
	     end;
	     else do;
		iodd_static.slave.accept_input = FALSE;
		iodd_static.slave.allow_quits = FALSE;
		iodd_static.slave.print_errors = FALSE;
		iodd_static.slave.log_msg = FALSE;
	     end;

	     call iox_$look_iocb (iodd_static.slave_output, iodd_static.slave_out, code);
	     if code ^= 0 then do;
		if iodd_static.slave.active then
		     call iodd_msg_ (error, master, code, myname, "Slave functions terminated.");
		iodd_static.slave.active = FALSE;	/* cannot be active */
		iodd_static.slave.print_errors = FALSE;
		iodd_static.slave.allow_quits = FALSE;
		iodd_static.slave.accept_input = FALSE;
	     end;

/* get iocbp for station password */
	     call iox_$look_iocb (iodd_static.slave_input, iodd_static.slave_in, code);
	     if code ^= 0 then do;			/* no one home? */
		if iodd_static.slave.active then
		     call iodd_msg_ (normal, master, code, myname, "Slave input terminated.");
		iodd_static.slave.accept_input = FALSE; /* like we said */
	     end;

/* find the device station so we can determine which minor devices to use */

	     station = iodd_parse_$args ("station=", major_args); /* station in major will over-ride */
	     if station ^= "" then do;		/* got one, all minor devices will be used */
		do i = 1 to iodd_static.assigned_devices;
		     p = driver_ptr_list.stat_segp (i); /* get ptr to driver status seg */
		     p -> driver_status.attached = TRUE;/* mark it as attached */
		end;
		need_station = FALSE;		/* we don't need to look for station */
	     end;
	     else do;
		need_station = TRUE;		/* look to the device for the station */
		if ^(iodd_static.slave.active & iodd_static.slave.accept_input) then do;
		     call iodd_msg_ (error, master, error_table_$fatal_error, myname,
			"No slave device to request operator input from.");
		     go to clean_out;
		end;
		call iodd_msg_ (normal, master, zero_code, "", "Requesting station identifier.");
	     end;

	     opr_msg = "Enter station command:" || NL;	/* ready to ask for device station */
	     do tries = 1 to 10 while (need_station);	/* try up to 10 times before giving up */
		call iox_$put_chars (iodd_static.slave_out, addr (opr_msg), length (rtrim (opr_msg)), code);
		if code ^= 0 then do;
try_to_recover:
		     call iodd_msg_ (error, master, code, myname,
			"Trouble initializing device.  Starting reinitialization.");
		     call drop_device;
		     iodd_static.re_init_in_progress = TRUE;
		     go to iodd_static.re_init_label;
		end;

		call iox_$control (iodd_static.slave_out, "runout", null, ignore_code);

		input_line = "";			/* clear any junk */
		call iox_$get_line (iodd_static.slave_in, addr (input_line), length (input_line), nchar, code);
		if code ^= 0 then
		     go to try_to_recover;

		station = before (iodd_parse_$args ("station", input_line), " ");
						/* see if it is a good command */
		station_password = rtrim (ltrim (after (iodd_parse_$args ("station", input_line), " ")));

		if station ^= "" then do;		/* if defined, check it out */
		     if station_password = "" then	/* ... left off password: ask for it */
			call read_password_$switch (iodd_static.slave_out, iodd_static.slave_in, STATION_PW_PROMPT,
			     station_password, ignore_code);
		     if station_password = "*" then	/* ... user really wants a blank password */
			station_password = "";

		     if station_password ^= "" then do;
			temp_password = station_password;
			station_password = scramble_ (temp_password);
			temp_password = "";
		     end;

		     call validate_card_input_$station (station, station_password, err_msg, code);
		     if code ^= 0 then do;
			call iodd_msg_ (normal, both, zero_code, "***", "^a: ^a", err_msg, station);
			go to enter_again;		/* ask the question once more */
		     end;
		     else do i = 1 to iodd_static.assigned_devices; /* look at each minor device */
			p = driver_ptr_list.stat_segp (i); /* get ptr to driver status seg */

/* see if user wants minor args to be found in a segment */
			minor_args_name = iodd_parse_$args ("indirect=", return_string (p -> driver_status.minor_args));
			if minor_args_name ^= "" then do; /* yes, grab that segment */
			     call initiate_the_file (minor_args_name, minor_args_ptr, minor_args_length,
				"minor_args", code);
			     if code ^= 0 then
				go to clean_out;
			end;
			else do;
						/* locate minor args for this minor device */
						/* in the i/o daemon tables text area */
			     minor_args_ptr = add_char_offset_ (addr (text_strings.chars), p -> driver_status.minor_args.first_char - 1);
			     minor_args_length = p -> driver_status.minor_args.total_chars;
			end;
			if station = iodd_parse_$args ("station=", minor_args) then do; /* match? */
			     need_station = FALSE;	/* we found a good one */
			     p -> driver_status.attached = TRUE; /* mark it as attached */
			end;
			else p -> driver_status.attached = FALSE; /* this one is invalid */
		     end;

		     if need_station then do;		/* indicate an error to the operator */
			err_msg = "No minor device for station: " || station;
			call iodd_msg_ (normal, both, zero_code, "***", err_msg);
		     end;
		end;
		else do;				/* no valid "STATION" command card */
		     call iodd_msg_ (normal, both, zero_code, "***", "No station command given.");
		end;
enter_again:
	     end;

	     if tries > slave_login_tries then
		go to logout_slave;			/* after 10 times, give up */

	     call iodd_msg_ (log, master, zero_code, "", "Driver initializing for station: ^a", station);

	end;

/* This is where the two attach types are again handled the same */

	terminal (master) = "user_output";		/* master terminal output stream for read_cards command */
	terminal (slave) = iodd_static.slave_output;

/* For each minor device marked as attached, find the type of device it is */

	prt_rqt = "printer";			/* default the request type names to standard */
	pun_rqt = "punch";
	reader_attached = FALSE;			/* reader not available yet */
	default_printer = null ();			/* no driver status seg for printer yet */
	default_punch = null ();			/* or for the punch */
	printer_count, punch_count = 0;		/* but count them as they are found */
	rqt_string = "";				/* no request types defined for this station yet */

	term_info.version = terminal_info_version;	/* set version number once for all possible calls */
	term_info.baud_rate = 0;			/* initialize to no-op just in case */

	iodd_static.current_devices = 0;		/* haven't found any good ones yet */
	ready_device = FALSE;			/* none of them are ready yet either */

	do i = 1 to iodd_static.assigned_devices;
	     p = driver_ptr_list.stat_segp (i);
	     p -> driver_status.ready = FALSE;		/* printer devices will honor auto_go */
	     p -> driver_status.generic_type = "";	/* not defined yet */
	     p -> driver_status.form_wait_time = default_form_wait_time; /* default wait time per ctl msg */
	     p -> driver_status.bit_rate_est = 0;	/* no output rate defined yet */
	     p -> driver_status.defer_time_limit = 0;	/* make operator specify */
	     p -> driver_status.dev_out_stream = "null_stream";

/* locate minor args for this minor device in the i/o daemon tables text area */
	     minor_args_ptr = add_char_offset_ (addr (text_strings.chars), p -> driver_status.minor_args.first_char - 1);
	     minor_args_length = p -> driver_status.minor_args.total_chars;

/* see if user wants minor args to be found in a segment */
	     minor_args_name = iodd_parse_$args ("indirect=", minor_args);
	     if minor_args_name ^= "" then do;		/* yes, grab that segment */
		call initiate_the_file (minor_args_name, minor_args_ptr, minor_args_length, "minor_args", code);
		if code ^= 0 then
		     go to clean_out;
	     end;
	     device_type = iodd_parse_$args ("dev=", minor_args);
						/* copy for easy reference */
	     if device_type = "printer" then do;	/* check if defined */
		if p -> driver_status.attached then do; /* only use the attached one */
		     if iodd_static.paper_type = PAPER_TYPE_SINGLE then do;
			if model = "" then
			     model = iodd_parse_$args ("model=", minor_args);
			if model ^= "" then
			     major_desc = major_desc || space || "-model " || model;
		     end;
		     call iodd_msg_ (normal, both, zero_code, "", "^/Initializing printer device: ^a",
			p -> driver_status.device_id);
		     printer_count = printer_count + 1;
		     p -> driver_status.generic_type = "printer";
						/* only printer functions can be done */
		     call minor_attach ("printer");
		     if printer_count = 1 then
			default_printer = p;
		     prt_rqt = p -> driver_status.req_type_label;
						/* get the request type */
		     if index (prt_rqt, ".") > 0 then
			prt_rqt = before (prt_rqt, ".");
						/* strip off device class */

		     call set_iod_val ("request_type", rtrim (prt_rqt));
		     if index (rqt_string, rtrim (prt_rqt)) = 0 then
			rqt_string = rqt_string || " " || rtrim (prt_rqt);
		     p -> driver_status.elem_size = BITS_PER_CHAR;
		     p -> driver_status.message_type = printer_request;
						/* expected dprint message type */

		     call iox_$control (p -> driver_status.dev_out_iocbp, "terminal_info", addr (term_info), code);
		     if code = 0 then
			p -> driver_status.bit_rate_est = term_info.baud_rate;
		     else p -> driver_status.bit_rate_est = initial_print_rate;
						/* set starting estimate */

		     allocate prt_ctl set (p -> driver_status.dev_ctl_ptr);
		     call get_prt_rqti_data (p);	/* find the request type info data for printer */
		     call iox_$control (p -> driver_status.dev_out_iocbp, "channel_stops",
			addr (prt_ctl.channel_stops), code);
		     if code ^= 0 then do;
			call iodd_msg_ (normal, both, code, myname, "Bad channel_stops order to printer.");
			go to logout_slave;
		     end;
		     call set_paper_info (slave, code);
		     if code ^= 0 then
			go to logout_slave;		/* proc gave the message */
		end;
	     end;
	     else if device_type = "punch" then do;
		if p -> driver_status.attached then do; /* only use the attached one */
		     call iodd_msg_ (normal, both, zero_code, "", "^/Initializing punch device: ^a",
			p -> driver_status.device_id);
		     punch_count = punch_count + 1;
		     p -> driver_status.generic_type = "punch";
						/* only punch functions for this one */

		     call minor_attach ("punch");
		     if punch_count = 1 then
			default_punch = p;		/* record the default status seg ptr */
		     pun_rqt = p -> driver_status.req_type_label;
						/* get the request type */
		     if index (pun_rqt, ".") > 0 then
			pun_rqt = before (pun_rqt, ".");
						/* strip off device class */

		     call set_iod_val ("pun_rqt", rtrim (pun_rqt));
		     if index (rqt_string, rtrim (pun_rqt)) = 0 then
			rqt_string = rqt_string || " " || rtrim (pun_rqt);
		     p -> driver_status.elem_size = BITS_PER_CHAR; /* in this driver, this is just a place holder */
		     p -> driver_status.message_type = punch_request;
						/* type of dprint msg expected */

		     call iox_$control (p -> driver_status.dev_out_iocbp, "terminal_info", addr (term_info), code);
		     if code = 0 then
			p -> driver_status.bit_rate_est = term_info.baud_rate;
		     else p -> driver_status.bit_rate_est = initial_punch_rate;

		     allocate pun_ctl set (p -> driver_status.dev_ctl_ptr);
		     pun_ctl_ptr = p -> driver_status.dev_ctl_ptr;
		     pun_ctl.sep_cards = standard;	/* set the default control parms */
		     pun_ctl.auto_punch = FALSE;	/* make the operator switch to autopunch if desired */
		     if p -> driver_status.rqti_ptr ^= null then
			call iodd_msg_ (normal, master, zero_code, myname, "This driver cannot decode a punch rqti seg.");
		end;
	     end;
	     else if device_type = "reader" then do;	/* this is only a dummy minor device used */
						/* to get the attach desc for the reader */
		if p -> driver_status.attached then do; /* only use the attached one */

		     p -> driver_status.attached = FALSE; /* it is never attached as far as */
						/* the coordinator is concerned */
		     if reader_attached then do;
			call iodd_msg_ (normal, master, zero_code, myname,
			     "Multiple reader devices specified.  Device ^a ignored.",
			     p -> driver_status.device_id);
		     end;
		     else do;
			call iodd_msg_ (normal, both, zero_code, "", "^/Initializing reader device: ^a",
			     p -> driver_status.device_id);
			p -> driver_status.generic_type = "card_rdr";
			call minor_attach ("reader");
			reader_attached = TRUE;	/* tell the read_cards command it can work */

			card_info.n_streams = 1;	/* remote_driver only supports one format */
			card_info.format (1) = "rmcc";/* and that's like MCC */
			card_info.control_stream, card_info.name (1) = p -> driver_status.dev_out_stream;
						/* use the same stream for data */
			card_info.el_size (1) = BITS_PER_CHAR; /* input is in characters of 9 bits each */
		     end;
		end;
	     end;
	     else do;				/* someone slipped in a zinger */
		call iodd_msg_ (normal, master, zero_code, myname, "Invalid ""dev="" arg ""^a"" for minor device ^a.",
		     device_type, p -> driver_status.device_id);
		p -> driver_status.attached = FALSE;	/* can't be attached in this case */
	     end;
	end;

	if iodd_static.current_devices = 0 then do;	/* trouble */
	     err_msg = "No minor devices found with ""dev="" arg which is known to this driver.";
	     call iodd_msg_ (error, master, zero_code, myname, err_msg);
	     code = 0;
	     go to logout_slave;			/* drop this one */
	end;

	if printer_count > 1 then do;
	     default_printer = null;			/* no default if more than one */
	     prt_rqt = "printer";
	     call set_iod_val ("request_type", rtrim (prt_rqt));
	end;
	if punch_count > 1 then do;
	     default_punch = null;			/* no default if more than one */
	     pun_rqt = "punch";
	     call set_iod_val ("pun_rqt", rtrim (pun_rqt));
	end;

	call set_iod_val ("rqt_string", (rqt_string));
	call set_iod_val ("station_id", rtrim (station));

	iodd_static.admin_ec_name = rtrim (station) || "_admin.ec";
	call read_cards_$set_station (station, ignore_code);
	call read_cards_$set_rqt (prt_rqt, pun_rqt, ignore_code); /* pass default rqt's to card input proc */

	iodd_static.form_type = iodd_parse_$args ("form_type=", major_args);
						/* set form type */
	if iodd_static.form_type = "" then
	     iodd_static.form_type = "std_ctl_msg";	/* if not found... */

	iodd_static.slave_hold = ^ready_device;		/* issue a "go" if at least one device is ^ready */

	smi.version = -1;				/* init to known state */

	call date_time_ (clock (), date_string);	/* get set for ready message */
	call iodd_msg_ (normal, both, zero_code, "", "^/^a driver on channel ^a ready at ^16a^/", iodd_static.major_device,
	     iodd_static.attach_name, date_string);

	call iodd_listen_ (stat_p);


/*  This is only for error recovery during initialization.  The listener will never return here. */
clean_out:
	call drop_device;
	if iodd_static.attach_type = ATTACH_TYPE_VARIABLE_LINE then do; /* new style, detach and wait for dialup */
	     iodd_static.re_init_in_progress = TRUE;
	     go to iodd_static.re_init_label;
	end;

	return;

logout_slave:					/* logout the slave device but not the process */
	iodd_static.re_init_in_progress = TRUE;		/* we do this by re-initializing the driver */

	call date_time_ (clock (), date_string);	/* get set for message */
	iodd_static.slave.log_msg = TRUE;		/* send to log and slave */
	call iodd_msg_ (log, both, zero_code, "", "Logout for station: ^a at ^a", station, date_string);

	if iodd_static.slave_out ^= null () then do;
	     call iox_$control (iodd_static.slave_out, "runout", null, ignore_code);
	     call iox_$control (iodd_static.slave_out, "end_write_mode", null, ignore_code);
	end;

	call drop_device;

	call iodd_msg_ (normal, master, zero_code, "", "Driver starting re-initialization.");

	go to iodd_static.re_init_label;		/* this will do everything */





drop_device: procedure ();

dcl  send_hangup bit (1);

/* internal proc to issue a hangup to the device before detaching */

	send_hangup = TRUE;				/* tell close_and_detach proc to send hangup */
	go to device_common;

detach_device: entry ();
	send_hangup = FALSE;			/* no send hangup */

device_common:
	if iodd_static.ctl_term.attached then
	     if iodd_static.ctl_output ^= iodd_static.slave_output then
		iodd_static.slave.active = FALSE;	/* if ctl term is slave, leave it to iodd_ */
	     else ;
	else iodd_static.slave.active = FALSE;		/* if no ctl terminal, no slave is left */
	call close_and_detach (teleprinter_iocbp, send_hangup);

	list_ptr = iodd_static.driver_list_ptr;
	do i = 1 to iodd_static.assigned_devices;
	     p = driver_ptr_list.stat_segp (i);
	     call close_and_detach (p -> driver_status.dev_out_iocbp, send_hangup);
	     if p -> driver_status.dev_ctl_ptr ^= null then
		free p -> driver_status.dev_ctl_ptr -> prt_ctl;
						/* free the prt_ctl or pun_ctl structures */
						/* Lucky free dosn't care about the structure name */
	end;

	call continue_to_signal_ (ignore_code);		/* in case this is called from a handler */

	return;

     end drop_device;
%page;

request:
     entry;

/*  This entry is called by iodd_listen_ when a request has been received from
   the coordinator for either of the logical drivers servicing the remote device.
   Here we just check to be sure that we can understand the request format and the requested
   print or punch data format.  Then the request is passed on to the proc which can handle
   that type of request.
*/

/* for cleanup handler */
	evaluate_forms_info_input_ptr,
	     evaluate_forms_info_output_ptr = null;

	p = iodd_static.driver_ptr;			/* find the current driver */
	p2 = addr (p -> driver_status.descriptor);	/* find the request descriptor */
	dmp = addr (p -> driver_status.message);	/* get ptr to message */

	if dmp -> queue_msg_hdr.hdr_version ^= queue_msg_hdr_version_1 then do; /* trouble */
	     call iodd_msg_ (log, both, zero_code, "", "Invalid message header.  Cannot read request ^d.^d.",
		p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q);
	     p2 -> request_descriptor.keep_in_queue = TRUE;
						/* save for conversion later */
	     go to be_nice;
	end;
	if dmp -> queue_msg_hdr.message_type ^= p -> driver_status.message_type then do;
	     call iodd_msg_ (log, both, zero_code, "",	/* log the error */
		"Incorrect message type.^/Request ^d.^d for ^a (segment ^a) not processed.",
		p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q,
		p2 -> request_descriptor.mseg_message_info_copy.sender_id,
		dmp -> queue_msg_hdr.ename);
	     p2 -> request_descriptor.cancelled = TRUE;	/* we don't want this one again */
be_nice:
	     p2 -> request_descriptor.dont_delete = TRUE; /* save the user's data */
	     p2 -> request_descriptor.finished = TRUE;	/* mark it done */
	     return;				/* it wasn't for us after all */
	end;
	if dprint_msg.version ^= dprint_msg_version_3	/* Previous version */
	     & dprint_msg.version ^= dprint_msg_version_4 /* Previous version */
	     & dprint_msg.version ^= dprint_msg_version_5 /* Current version */
	then do;					/* other trouble? */
	     call iodd_msg_ (log, both, zero_code, "",
		"Wrong message version found.^/Request ^d.^d for ^a (segment ^a) not processed",
		p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q,
		p2 -> request_descriptor.mseg_message_info_copy.sender_id,
		dmp -> queue_msg_hdr.ename);
	     p2 -> request_descriptor.keep_in_queue = TRUE;
	     go to be_nice;
	end;
	if dprint_msg.version < dprint_msg_version_4 then /* Disallow -line_nbrs before version 4 */
	     dprint_msg.control.line_nbrs = FALSE;
	format_code = dprint_msg.output_module;		/* get the user defined format */

	if format_code = printer_mode then do;		/* if printer, check line length */
	     prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* find the control info for this printer */
	     call evaluate_forms_options (code);	/* validate forms data */
	     if code ^= 0 then do;
		call iodd_msg_ (log, both, zero_code, "",
		     "Request ^d.^d for ^a (segment ^a) deferred.^/Forms evaluation error '^a'",
		     p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q,
		     p2 -> request_descriptor.mseg_message_info_copy.sender_id,
		     dmp -> queue_msg_hdr.ename,
		     evaluate_forms_info_output.error_string);
		p2 -> request_descriptor.keep_in_queue = TRUE; /* defer it */
		if evaluate_forms_info_output_ptr ^= null then
		     free evaluate_forms_info_output;
		go to be_nice;
	     end;

/* adjust prt_ctl accordingly */
	     if dprint_msg.line_lth > prt_ctl.phys_line_length then do; /* platten wide enough */
		call iodd_msg_ (log, both, zero_code, "",
		     "Request ^d.^d for ^a (segment ^a) deferred.^/Requires a device with line length of ^d.",
		     p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q,
		     p2 -> request_descriptor.mseg_message_info_copy.sender_id,
		     dmp -> queue_msg_hdr.ename, dprint_msg.line_lth);
		p2 -> request_descriptor.keep_in_queue = TRUE;
						/* defer it */
		go to be_nice;
	     end;
	end;
	else if format_code = punch_raw_mode then do;	/* for binary output */
	     element_size = 1;			/* treat as 1 bit at a time */
	end;
	else if format_code = punch_rmcc_mode then do;	/* for character output */
	     element_size = BITS_PER_CHAR;		/* for output_request_ */
	end;
	else do;					/* be sure it is defined */
	     call iodd_msg_ (log, both, zero_code, "",
		"Undefined output module in user request.^/Request ^d.^d for ^a (segment ^a) not processed",
		p2 -> request_descriptor.seq_id, p2 -> request_descriptor.q,
		p2 -> request_descriptor.mseg_message_info_copy.sender_id,
		dmp -> queue_msg_hdr.ename);
	     p2 -> request_descriptor.cancelled = TRUE;	/* we don't want this one again */
	     go to be_nice;
	end;

	iodd_static.quit_during_request = FALSE;	/* start clean */
	ctl_msg_sent = FALSE;			/* initialize to no msg yet */
	save_request_label = save_return;		/* init for non-local transfer on save command */

	on cleanup begin;
	     if p ^= null () then			/* this one should never be null, but ... */
		if p -> driver_status.dev_out_iocbp ^= null () then
		     call iox_$control (p -> driver_status.dev_out_iocbp, "end_write_mode", null, ignore_code);

	     if evaluate_forms_info_input_ptr ^= null then
		free evaluate_forms_info_input;
	     if evaluate_forms_info_output_ptr ^= null then
		free evaluate_forms_info_output;
	end;					/* let the I/O Module send an EOF if needed */

	if dprint_msg.message_type = printer_request then do;
	     call do_prt_request_ (p -> driver_status.dev_out_iocbp, stat_p, code);
	     if evaluate_forms_info_output_ptr ^= null then
		free evaluate_forms_info_output;
						/* this one is for the printer only */
	end;
	else do;
	     call output_request_ ((p -> driver_status.dev_out_stream), element_size, stat_p, print_banner, code);
	end;
	if code ^= 0 then do;
	     iodd_static.slave_hold = TRUE;		/* on errors go to command level for guidance */
	     if code = error_table_$io_no_permission then do; /* in case of hangup... */
		call iodd_msg_ (error, master, code, myname,
		     "Device in inconsistent state or hungup.  Must re-initialize.");
		signal re_init;
	     end;
	end;
save_return:					/* return point for save command at request cmd level */
	call iox_$control (p -> driver_status.dev_out_iocbp, "end_write_mode", null, code);
	if code = 0 then do;			/* we were able to release the line */
	     call timer_manager_$sleep (time, RELATIVE_SECONDS); /* sleep a few seconds */
						/* so remote device can send if needed */
	end;
	else if code = error_table_$undefined_order_request then do; /* this is ok also */
	     if iodd_static.test_entry then		/* be able to set a reasonable pace */
		if time > 1 then			/* simulate device */
		     call timer_manager_$sleep (time, RELATIVE_SECONDS);
	end;
	else do;					/* this is a real error */
	     call iodd_msg_ (error, master, code, myname, "From ""end_write_mode"" control");
	     iodd_static.slave_hold = TRUE;
	end;

	if iodd_static.slave.active then		/* flush any messages */
	     call iox_$control (iodd_static.slave_out, "runout", null, ignore_code);

	return;
%page;

/* This entrypoint is used to output the head/tail banner cards for a punch
   request.  It is referenced in the call to output_request_. */

print_banner: entry (a_stream, a_banner_type, a_data_ptr, a_code);

	stream = a_stream;
	banner_type = a_banner_type;
	ordatap = a_data_ptr;
	a_code, code = 0;

	p = iodd_static.driver_ptr;			/* save driver_ptr in short name variable */
	p2 = addr (p -> driver_status.descriptor);	/* get descriptor ptr just in case */
	dmp = addr (p -> driver_status.message);	/* get message ptr */
	iocbp = p -> driver_status.dev_out_iocbp;	/* get iocbp for control and writes */

	if dprint_msg.message_type ^= punch_request then do; /* this proc is for dpunch type message banner */
	     code = error_table_$action_not_performed;	/* return an error */
	     go to banner_ret;
	end;

	pun_ctl_ptr = p -> driver_status.dev_ctl_ptr;	/* get ready for using pun_ctl structure */

	if banner_type = head_banner then do;		/* this is for the header */
	     iodd_static.quit_during_request = FALSE;	/* start watching now */
	     if iodd_static.ctl_term.attached then do;	/* are we to inform the ctl terminal? */
		call write_control_form_ (iodd_static.form_type, iodd_static.ctl_output, ordatap, code);
		if code ^= 0 then do;
		     if code ^= error_table_$action_not_performed then do; /* this is normal */
			call iodd_msg_ (error, master, code, myname, "Writing message to control terminal.");
			iodd_static.slave_hold = TRUE;/* go back to command level when done */
		     end;
		     ctl_msg_sent = FALSE;		/* don't wait now */
		     code = 0;			/* we handled it */
		end;
		else ctl_msg_sent = TRUE;		/* all set */
		if ctl_wait_list.number = 1 then
		     call set_wait_timer;
	     end;
	     else ctl_msg_sent = FALSE;

	     format_code = dprint_msg.output_module;	/* get the punch format code */
	     if format_code = punch_raw_mode then
		arg_string = "raw";			/* set name for messages */
	     else arg_string = "rmcc";		/* this is the default */

	     if ^pun_ctl.auto_punch then do;		/* are we to come to command level */

		on conversion
		     begin;
		     call iodd_msg_ (normal, source, zero_code, "", "Argument conversion error.  Try again.");
		     go to ask;
		end;

		on size
		     begin;
		     call iodd_msg_ (normal, source, zero_code, "", "Argument numerical size error.  Try again.");
		     go to ask;
		end;

/* set to wait for input, no prompt master for command and to prompt slave for input */
		control = "101"b;

		call iodd_msg_ (log, slave, zero_code, "", "  Deck punch format:  ^a.", arg_string);

ask:
		call iodd_get_cmd_ (addr (input_line), length (input_line), len, control, "request", source, code);
		if code ^= 0 then do;		/* this is bad news */
		     iodd_static.slave_hold = TRUE;	/* go back to command level */
		     go to banner_ret;
		end;

		call iodd_parse_$command (substr (input_line, 1, len), addr (cmd_list), code);
		if code ^= 0 then do;
		     if code = error_table_$noarg then
			go to ask;
		     call iodd_msg_ (normal, source, code, myname, "Unable to parse command line.");
		     go to ask;
		end;

		if cmd_list.cmd = "help" then do;	/* check which command was given */
		     call iodd_msg_ (normal, source, zero_code, "", "Standard driver commands may be used, plus:^/");
		     call iodd_msg_ (normal, source, zero_code, "", "   copy N         -set the current copy number to N");
		     call iodd_msg_ (normal, source, zero_code, "", "   req_status     -get the copy and request numbers");
		     call iodd_msg_ (normal, source, zero_code, "", "   punch          -start data transfer");
		     go to ask;
		end;

		if cmd_list.cmd = "copy" then do;
		     if cmd_list.number_tokens_found ^= 2 then do; /* we must have 2 args which includes the N part */

bad_copy_arg:
			call iodd_msg_ (normal, source, zero_code, "",
			     "Invalid or missing argument.  Use copy N to set current copy number.");
			go to ask;
		     end;

		     value = convert (value, cmd_list.arg (1));
						/* convert char to fixed bin */
		     if value < 1 | value > ordata.copies then
			go to bad_copy_arg;

		     ordata.copy_no = value;		/* passed checks, so set the new current copy number */
		     go to ask;			/* see what is next */
		end;

		if cmd_list.cmd = "req_status" | cmd_list.cmd = "reqstatus" then do;
		     call iodd_msg_ (normal, source, zero_code, "",
			"Request ^d:  ^a^/^3xCurrent copy no:  ^d of ^d     Punch format: ^a", ordata.request_no,
			ordata.full_path, ordata.copy_no, ordata.copies, arg_string);
		     go to ask;
		end;

		if cmd_list.cmd = "debug" & iodd_static.test_entry & source = master then do;
		     call iodd_msg_ (normal, master, zero_code, "", "Calling debug");
		     call debug ();
		     go to ask;
		end;
		if (cmd_list.cmd = "probe" | cmd_list.cmd = "pb")
		     & iodd_static.test_entry
		     & source = master then do;
		     call iodd_msg_ (normal, master, zero_code, "", "Calling probe");
		     call probe ();
		     go to ask;
		end;

		if cmd_list.cmd ^= "punch" then do;	/* all but the punch command go to std cp */
		     call iodd_command_processor_ (source, request_command_level_state, substr (input_line, 1, len), code);
		     if code = 1 | code = 2 then do;	/* wants to go or start */
			if code = 2 & cmd_list.cmd = "save" then
			     go to save_request_label;
			call iodd_msg_ (normal, source, zero_code, "", "Invalid command.  Try again. - ^a", cmd_list.cmd);
		     end;
		     go to ask;
		end;
	     end;

	     call iox_$control (iocbp, "reset", null, code);
						/* clear modes and counts for all requests */
	     if code ^= 0 then
		go to banner_ret;


	     if dprint_msg.output_module = punch_raw_mode then do; /* binary punch request */
		call iox_$control (iocbp, "binary_punch", null, code);
						/* set binary mode */
		if code ^= 0 then do;		/* OOPS, drop this request */
		     call iodd_msg_ (normal, slave, zero_code, myname, "Unable to set binary punch mode");
		end;
		go to banner_ret;
	     end;
	     else if pun_ctl.sep_cards = standard then do;/* separator cards are for character punching only */
		req_string = ltrim (char (ordata.request_no));
						/* get number as characters */
		header_card2 = "";			/* clear the second header card */
		pos = 1;				/* where the next output char position is */

		do idx = 1 to length (rtrim (req_string));
						/* once for each digit */
		     digit = substr (req_string, idx, 1);
						/* pick it up */
		     substr (header_card2, pos, 5) = copy (digit, 5);
						/* repeat it 5 times */
		     pos = pos + 7;			/* bump the counter, leaving 2 spaces */
		end;

		substr (header_card2, pos + 5) = ordata.requestor;
						/* add on the requestor name */

		call iox_$put_chars (iocbp, addr (separator), length (separator), code);
		if code ^= 0 then
		     go to banner_ret;
		call iox_$put_chars (iocbp, addr (header_card2), length (header_card2), code);
		if code ^= 0 then
		     go to banner_ret;
		call iox_$put_chars (iocbp, addr (separator), length (separator), code);
		if code ^= 0 then
		     go to banner_ret;
		call iox_$control (iocbp, "runout", null, code);
		if code ^= 0 then
		     go to banner_ret;
		call iox_$control (iocbp, "reset", null, code);
	     end;
	end;
	else if banner_type = tail_banner then do;	/* time for the tail banner */
	     if pun_ctl.sep_cards = standard & dprint_msg.output_module ^= punch_raw_mode then do;
		do i = 1 to 2;
		     call iox_$put_chars (iocbp, addr (separator), length (separator), code);
		     if code ^= 0 then
			go to banner_ret;
		end;
	     end;

	     if ctl_wait_list.number = 1 then
		call wait_for_ctl_finish;
	end;
	else if banner_type = error_message then do;	/* this is for an error message */
						/* when we can punch in binary, we can write flip cards here */
	end;

/* 	all other banners are undefined. */

	else code = error_table_$action_not_performed;


banner_ret:
	a_code = code;
	if code ^= 0 then
	     p2 -> request_descriptor.keep_in_queue = TRUE;
						/* defer the request */
	return;
%page;

/* This is the command processor for special commands recognized by the remote
   driver.  Any unrecognized commands will be passed back to the general
   I/O daemon command processor for execution. */
command: entry (a_source, a_state, a_argp, a_code);

	argp = a_argp;				/* define the arg_list structure which contains "command" */
	source = a_source;
	state = a_state;
	terminal (2) = iodd_static.slave_output;	/* in case it has changed */

	on conversion
	     begin;				/* handler for conversion errors */
	     call iodd_msg_ (normal, source, zero_code, "", "Argument conversion error. Try again.");
	     go to cmd_error;
	end;

	save_code = a_code;				/* save the called value */
	a_code, code = 0;				/* say we handled it for now */

	if command = "help" then do;
	     call iodd_msg_ (normal, source, zero_code, "", "^/** Commands for the remote driver **^/");
	     call iodd_msg_ (normal, source, zero_code, "", "banner_bars [<minor_device>] [single | double | none]");
	     call iodd_msg_ (normal, source, zero_code, "", "banner_type [<minor_device>] [standard | brief | none]");
	     call iodd_msg_ (normal, source, zero_code, "", "clean_pool  <days allowed to remain>");
	     call iodd_msg_ (normal, source, zero_code, "",
		"paper_info [<minor_device>] [-ll <line_len>] [-pl <paper_len>] [-lpi <6 or 8>]");
	     call iodd_msg_ (normal, source, zero_code, "", "pause_time [<delay_time_between_requests>]");
	     call iodd_msg_ (normal, source, zero_code, "",
		"prt_control [<minor_device>] [^]KEY ... (KEYs: force_nep, force_esc, force_ctl_char, force_nsep, autoprint)"
		);
	     call iodd_msg_ (normal, source, zero_code, "", "pun_control [<minor_device>] [^]autopunch)");
	     call iodd_msg_ (normal, source, zero_code, "", "read_cards");
	     call iodd_msg_ (normal, source, zero_code, "", "runout_spacing  <number_of_lines>");
	     call iodd_msg_ (normal, source, zero_code, "", "sample_hs [<minor_device>]");
	     call iodd_msg_ (normal, source, zero_code, "", "sample_form");
	     call iodd_msg_ (normal, source, zero_code, "", "sep_cards [<minor_device>] [standard | none]");
	     call iodd_msg_ (normal, source, zero_code, "", "single");
	     go to end_cmd;
	end;
	if command = "ctl_term" | command = "ctlterm" then do; /* this was passed on by iodd_command_processor_ */
						/* to have us set the default form type */
	     iodd_static.form_type = "std_ctl_msg";	/* this is our default */
	     do i = 1 to iodd_static.assigned_devices;
		p = driver_ptr_list.stat_segp (i);	/* get ptr to driver status seg */
		p -> driver_status.form_wait_time = default_form_wait_time; /* set the default wait time */
	     end;
	     go to end_cmd;
	end;

	if command = "banner_bars" | command = "bannerbars" then do;
	     if arg_list.n_tokens > 2 then do;
		p = find_driver_status_seg_ptr (arg_list.arg (1));
						/* get driver status ptr for minor device given */
		i = 2;				/* arg 2 is the value argument */
	     end;
	     else do;				/* one arg - could be value for default or ... */
						/* could be minor device name with no value */
		p = default_printer;		/* try for the default printer */
		i = 1;				/* assume first arg is the value */
	     end;
	     value = -1;				/* no value defined yet */
	     if arg_list.n_tokens > 1 then do;		/* allow for no args at all */
		if arg_list.arg (i) = "-print" then
		     value = -1;
		else if arg_list.arg (i) = "double" then
		     value = NORMAL_BANNER_BARS;
		else if arg_list.arg (i) = "single" then
		     value = SINGLE_BANNER_BARS;
		else if arg_list.arg (i) = "none" then
		     value = NO_BANNER_BARS;
		else p = find_driver_status_seg_ptr (arg_list.arg (i));
	     end;

	     if p = null () then do;
no_printer:
		if arg_list.n_tokens = 1 then
		     opr_msg = "not specified.";
		else opr_msg = "not found: " || arg_list.arg (i);
		call iodd_msg_ (normal, source, zero_code, "", "Printer minor device ^a", opr_msg);
		go to cmd_error;
	     end;
	     if p -> driver_status.generic_type ^= "printer" then do; /* printer functions are only for printers */
not_a_printer:
		call iodd_msg_ (normal, source, zero_code, "", "Minor device ""^a"" is not a printer.",
		     p -> driver_status.device_id);
		go to cmd_error;
	     end;

	     prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control structure pointer */

	     if value = -1 then do;
		if prt_ctl.banner_bars = NORMAL_BANNER_BARS then
		     opr_msg = "double";
		else if prt_ctl.banner_bars = SINGLE_BANNER_BARS then
		     opr_msg = "single";
		else if prt_ctl.banner_bars = NO_BANNER_BARS then
		     opr_msg = "none";
		else opr_msg = "Undefined value";
		call iodd_msg_ (normal, source, zero_code, "", "Current value is:  ^a", opr_msg);
	     end;

	     else prt_ctl.banner_bars = value;

	     go to end_cmd;
	end;

	if command = "pause_time" | command = "pausetime" then do;
	     if arg_list.n_tokens > 1 then do;
		value = convert (value, arg_list.arg (1));
		if value < zero | value > pause_time_max then do;
		     call iodd_msg_ (normal, source, zero_code, "", "pause_time range: ^d to ^d seconds ", zero, pause_time_max);
		     go to cmd_error;
		end;
		time = value;
		go to end_cmd;
	     end;
	     else do;
		time = pause_time_default;		/* return to the default */
		go to end_cmd;
	     end;
	end;

	if command = "runout_spacing" | command = "runoutspacing" then do;
	     if arg_list.n_tokens > 1 then do;
		value = convert (value, arg_list.arg (1));
		if value < zero | value > runout_spacing_max then do; /* legal range? */
		     call iodd_msg_ (normal, source, zero_code, "", "runout_spacing range is ^d to ^d lines.",
			zero, runout_spacing_max);
		     go to cmd_error;
		end;
		call iox_$control (teleprinter_iocbp, "runout_spacing", addr (value), code);
		if code ^= 0 then do;
		     call iodd_msg_ (normal, source, zero_code, "", "Unable to set runout spacing for remote device.");
		     go to cmd_error;
		end;
		go to end_cmd;
	     end;
	     else do;
		call iodd_msg_ (normal, source, zero_code, "", "The runout_spacing command must have an argument");
		go to cmd_error;
	     end;
	end;

	if command = "paper_info" | command = "paperinfo" then do;
	     if arg_list.n_tokens > 1 then
		p = find_driver_status_seg_ptr (arg_list.arg (1));
						/* see if first arg matches a minor device */
	     else p = null;
	     if mod (arg_list.n_tokens, 2) = 0 then	/* odd number of args to cmd, first must be minor device */
		i = 2;				/* control args start  with arg 2 */
	     else do;				/* even number of args, wants default or made typing error */
		if p ^= null then do;		/* valid minor device name. operator typing error? */
		     if arg_list.arg (2) ^= "-print" then do; /* allow this exception */
			call iodd_msg_ (normal, source, zero_code, myname,
			     "Incorrect number of arguments.  Pairs of arguments follow minor device.");
			go to cmd_error;
		     end;
		     i = 2;			/* for the next arg test */
		end;
		else do;
		     p = default_printer;
		     i = 1;
		end;
	     end;
	     if p = null () then
		go to no_printer;
	     if p -> driver_status.generic_type ^= "printer" then
		go to not_a_printer;		/* only allow printers */
	     prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control pointer for this driver */

/* not enough args to change data, so print it */
	     if i >= arg_list.n_tokens | arg_list.arg (i) = "-print" then do;
		call iodd_msg_ (normal, source, zero_code, "",
		     "Physical paper width:  ^d characters.^/Physical paper length:  ^d lines at ^d lines per inch.",
		     prt_ctl.phys_line_length, prt_ctl.phys_page_length, prt_ctl.lines_per_inch);
		go to end_cmd;
	     end;

	     new_ll = prt_ctl.phys_line_length;
	     new_pl = prt_ctl.phys_page_length;
	     new_lpi = prt_ctl.lines_per_inch;

	     do i = i to n_tokens - 1 by 2;		/* check the arg pairs */
		if arg_list.arg (i) = "-ll" then
		     new_ll = convert (new_ll, arg_list.arg (i + 1));
		else if arg_list.arg (i) = "-pl" then
		     new_pl = convert (new_pl, arg_list.arg (i + 1));
		else if arg_list.arg (i) = "-lpi" then
		     new_lpi = convert (new_lpi, arg_list.arg (i + 1));
		else do;				/* bad control arg */
		     call iodd_msg_ (normal, source, zero_code, "", "Invalid control argument:  ^a", arg_list.arg (i));
		     go to cmd_error;
		end;
	     end;
	     if new_ll < line_length_min | new_ll > line_length_max then do; /* check the range */
		call iodd_msg_ (normal, source, zero_code, "", "Line length range is ^d to ^d.",
		     line_length_min, line_length_max);
		go to cmd_error;
	     end;

	     if ^(new_lpi = lpi_min | new_lpi = lpi_max) then do;
		call iodd_msg_ (normal, source, zero_code, "", "Lines per inch must be ^d or ^d.",
		     lpi_min, lpi_max);
		go to cmd_error;
	     end;
	     if new_pl < page_length_min then do;
		call iodd_msg_ (normal, source, zero_code, "", "Minimum paper length is ^d lines.",
		     page_length_min);
		go to cmd_error;
	     end;
	     if new_pl > page_length_max then do;
		call iodd_msg_ (normal, source, zero_code, "", "Maximum paper length is ^d lines.",
		     page_length_max);
		go to cmd_error;
	     end;

	     prt_ctl.phys_line_length = new_ll;
	     prt_ctl.phys_page_length = new_pl;
	     prt_ctl.lines_per_inch = new_lpi;

	     call iodd_msg_ (normal, source, zero_code, "", "Changing to:  ll ^d, pl ^d at ^d lines per inch.",
		prt_ctl.phys_line_length, prt_ctl.phys_page_length, prt_ctl.lines_per_inch);

	     call set_paper_info (source, code);
	     if code ^= 0 then
		go to cmd_error;

	     go to end_cmd;
	end;

	if command = "prt_control" | command = "prtcontrol" then do;
	     if arg_list.n_tokens > 1 then
		p = find_driver_status_seg_ptr (arg_list.arg (1));
						/* see if first arg matches a minor device */
	     else p = null;
	     if p ^= null then			/* first arg was a valid minor device name */
		i = 2;				/* value args start  with arg 2 */
	     else do;				/* wants default or made typing error */
		p = default_printer;		/* try for the default printer device */
		i = 1;				/* arg one starts the value */
	     end;
	     if p = null () then
		go to no_printer;
	     if p -> driver_status.generic_type ^= "printer" then
		go to not_a_printer;		/* only allow printers */
	     prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control pointer for this driver */

	     if arg_list.n_tokens <= i | arg_list.arg (i) = "-print" then do;
		call iodd_msg_ (normal, source, zero_code, "",
		     "Current values are:  ^[^^^]force_nep, ^[^^^]force_esc, ^[^^^]force_ctl_char, ^[^^^]force_nsep, ^[^^^]auto_print",
		     ^prt_ctl.force_nep, ^prt_ctl.force_esc, ^prt_ctl.force_ctl_char, ^prt_ctl.force_nsep,
		     prt_ctl.no_auto_print);
		go to end_cmd;
	     end;
	     do i = i to n_tokens - 1;		/* look at each argument */
		not = (substr (arg_list.arg (i), 1, 1) = "^");
						/* was first char a "^" */
		if not then
		     arg_string = substr (arg_list.arg (i), 2);
		else arg_string = arg_list.arg (i);
		if arg_string = "force_nep" | arg_string = "forcenep" then
		     prt_ctl.force_nep = ^not;
		else if arg_string = "force_esc" | arg_string = "forceesc" then
		     prt_ctl.force_esc = ^not;
		else if arg_string = "force_ctl_char" | arg_string = "forcectlchar" then
		     prt_ctl.force_ctl_char = ^not;
		else if arg_string = "auto_print" | arg_string = "autoprint" then
		     prt_ctl.no_auto_print = not;
		else if arg_string = "force_nsep" | arg_string = "forcensep" then
		     prt_ctl.force_nsep = ^not;
		else call iodd_msg_ (normal, source, zero_code, "", "Undefined argument: ^a", arg_list.arg (i));
	     end;
	     go to end_cmd;
	end;

	if command = "banner_type" | command = "bannertype" then do;
	     if arg_list.n_tokens > 2 then do;
		p = find_driver_status_seg_ptr (arg_list.arg (1));
						/* get driver status ptr for minor device given */
		i = 2;				/* arg 2 is the value argument */
	     end;
	     else do;				/* one arg - could be value for default or ... */
						/* could be minor device name with no value */
		p = default_printer;		/* try for the default printer */
		i = 1;				/* assume first arg is the value */
	     end;
	     value = -1;				/* no value defined yet */
	     if arg_list.n_tokens > 1 then do;		/* allow for no args at all */
		if arg_list.arg (i) = "-print" then
		     value = -1;
		else if arg_list.arg (i) = "none" then
		     value = NO_BANNERS;
		else if arg_list.arg (i) = "standard" then
		     value = NORMAL_BANNERS;
		else if arg_list.arg (i) = "brief" then
		     value = BRIEF_BANNERS;
		else p = find_driver_status_seg_ptr (arg_list.arg (i));
	     end;

	     if p = null () then
		go to no_printer;
	     if p -> driver_status.generic_type ^= "printer" then
		go to not_a_printer;		/* only allow printers */
	     prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control structure pointer */

	     if value = -1 then do;			/* print the current value */
		if prt_ctl.banner_type = NO_BANNERS then
		     opr_msg = "none";
		else if prt_ctl.banner_type = NORMAL_BANNERS then
		     opr_msg = "standard";
		else if prt_ctl.banner_type = BRIEF_BANNERS then
		     opr_msg = "brief";
		else opr_msg = "Undefined value";
		call iodd_msg_ (normal, source, zero_code, "", "Current value is:  ^a", opr_msg);
	     end;

	     else prt_ctl.banner_type = value;

	     go to end_cmd;
	end;

	if command = "sample_hs" | command = "samplehs" then do;
	     i = arg_list.n_tokens - 1;		/* define this in case of error */
	     if arg_list.n_tokens = 1 then
		p = default_printer;
	     else p = find_driver_status_seg_ptr (arg_list.arg (1));
	     if p = null () then
		go to no_printer;
	     if p -> driver_status.generic_type ^= "printer" then
		go to not_a_printer;		/* only allow printers */
	     prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;

	     call iox_$control (p -> driver_status.dev_out_iocbp, "reset", null, ignore_code);
						/* clear everything */
	     call iox_$control (p -> driver_status.dev_out_iocbp, "inside_page", null, ignore_code);

	     call write_sample_prt_banner_ ("head_sheet", p -> driver_status.dev_out_iocbp, prt_ctl_ptr, ignore_code);

	     call iox_$control (p -> driver_status.dev_out_iocbp, "end_of_page", null, ignore_code);
	     call iox_$control (p -> driver_status.dev_out_iocbp, "runout", null, ignore_code);
						/* be sure it prints */
	     call iox_$control (p -> driver_status.dev_out_iocbp, "end_write_mode", null, ignore_code);
	     call timer_manager_$sleep (time, RELATIVE_SECONDS);

	     go to end_cmd;
	end;

	if command = "single" then do;		/* single space FF and VT for current request */
	     if iodd_static.request_in_progress then do;
		p = iodd_static.driver_ptr -> driver_status.dev_out_iocbp;
		call iox_$modes (p, "single", omode, ignore_code);
						/* set single mode */
		dmp = addr (iodd_static.driver_ptr -> driver_status.message);
		if dprint_msg.message_type = printer_request then
		     call do_prt_request_$single_copy ();
						/* avoid same problem if another copy requested */
		else call output_request_$set_single_copy ();
	     end;
	     else call iodd_msg_ (normal, source, zero_code, "", "No current request.");
	     go to end_cmd;
	end;

	if command = "pun_control" | command = "puncontrol" then do;
	     if arg_list.n_tokens > 1 then
		p = find_driver_status_seg_ptr (arg_list.arg (1));
						/* see if first arg matches a minor device */
	     else p = null;
	     if p ^= null then			/* first arg was a valid minor device name */
		i = 2;				/* value args start  with arg 2 */
	     else do;				/* wants default or made typing error */
		p = default_punch;			/* try for the default punch device */
		i = 1;				/* arg one starts the value */
	     end;
	     if p = null () then do;
no_punch:
		if arg_list.n_tokens = 1 then
		     opr_msg = "not specified.";
		else opr_msg = "not found: " || arg_list.arg (i);
		call iodd_msg_ (normal, source, zero_code, "", "Punch minor device ^a", opr_msg);
		go to cmd_error;
	     end;
	     if p -> driver_status.generic_type ^= "punch" then do; /* punch functions are only for punches */
not_a_punch:
		call iodd_msg_ (normal, source, zero_code, "", "Minor device ""^a"" is not a punch.",
		     p -> driver_status.device_id);
		go to cmd_error;
	     end;

	     pun_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control pointer for this driver */

	     if arg_list.n_tokens <= i | arg_list.arg (i) = "-print" then do;
		call iodd_msg_ (normal, source, zero_code, "", "Current value is:  ^[^^^]auto_punch", ^pun_ctl.auto_punch);
		go to end_cmd;
	     end;
	     do i = i to n_tokens - 1;		/* look at each argument */
		not = (substr (arg_list.arg (i), 1, 1) = "^");
						/* was first char a "^" */
		if not then
		     arg_string = substr (arg_list.arg (i), 2);
		else arg_string = arg_list.arg (i);
		if arg_string = "auto_punch" | arg_string = "autopunch" then
		     pun_ctl.auto_punch = ^not;
		else call iodd_msg_ (normal, source, zero_code, "", "Undefined argument: ^a", arg_list.arg (i));
	     end;
	     go to end_cmd;
	end;

	if command = "sep_cards" | command = "sepcards" then do;
	     if arg_list.n_tokens > 2 then do;
		p = find_driver_status_seg_ptr (arg_list.arg (1));
						/* get driver status ptr for minor device given */
		i = 2;				/* arg 2 is the value argument */
	     end;
	     else do;				/* one arg - could be value for default or ... */
						/* could be minor device name with no value */
		p = default_punch;			/* try for the default punch */
		i = 1;				/* assume first arg is the value */
	     end;
	     value = -1;				/* no value defined yet */
	     if arg_list.n_tokens > 1 then do;		/* allow for no args at all */
		if arg_list.arg (i) = "-print" then
		     value = -1;
		else if arg_list.arg (i) = "none" then
		     value = none;
		else if arg_list.arg (i) = "standard" then
		     value = standard;
		else p = find_driver_status_seg_ptr (arg_list.arg (i));
	     end;

	     if p = null () then
		go to no_punch;
	     if p -> driver_status.generic_type ^= "punch" then
		go to not_a_punch;			/* only allow punches */
	     pun_ctl_ptr = p -> driver_status.dev_ctl_ptr;/* get the control structure pointer */

	     if value = -1 then do;			/* print the current value */
		if pun_ctl.sep_cards = none then
		     opr_msg = "none";
		else if pun_ctl.sep_cards = standard then
		     opr_msg = "standard";
		else opr_msg = "Undefined value";
		call iodd_msg_ (normal, source, zero_code, "", "Current value is:  ^a", opr_msg);
	     end;

	     else pun_ctl.sep_cards = value;

	     go to end_cmd;
	end;

	if command = "read_cards" | command = "readcards" then do;
	     if reader_attached then do;
		if iodd_static.test_entry then	/* use a dummy pool root under pool_dir for test */
		     pool_dir = rtrim (iodd_static.sys_dir_ptr -> sys_dir) || ">card_pool";
						/* the test pool root */
		else pool_dir = "System_Card_Pool";	/* otherwise use the one coded in */

		call pool_manager_$init (pool_dir, minimum_quota, "1000"b, code);
						/* use 10 pages of quota initially */
						/* and set s *.*.* on initial acl of access class pool */
		if code ^= 0 then do;		/* oops! */
		     call iodd_msg_ (normal, source, code, myname, "Unable to initialize card pool.");
		     go to cmd_error;
		end;
		call iodd_msg_ (normal, source, zero_code, "", "Card input started.");
		if source = slave then
		     call iox_$control (iodd_static.slave_out, "runout", null, ignore_code);

		on card_command_level go to abort_read; /* grab control after record quota overflow */

		call read_cards_ (pool_dir, addr (card_info), terminal (source), (iodd_static.test_entry), code);
		if code ^= 0 then do;
		     call iodd_msg_ (normal, source, code, myname, "Check card deck format.");
		     go to cmd_error;
		end;
		go to end_cmd;

abort_read:
		call iodd_msg_ (normal, source, zero_code, "", "Use the ""clean_pool"" command and retry card input.");
		go to cmd_error;
	     end;
	     else do;
		call iodd_msg_ (normal, source, zero_code, "", "The card reader is not attached.");
		go to end_cmd;
	     end;
	end;

	if command = "sample_form" | command = "sampleform" then do;
	     if iodd_static.ctl_term.attached then do;	/* be sure there is a place to write */
		if iodd_static.forms then do;		/* are we simulating FF? */
		     call iox_$control (iodd_static.slave_out, "form_status", addr (form_info), code);
		     if code ^= 0 then do;		/* OOPS.... */
			iodd_static.forms = FALSE;
			iodd_static.slave_hold = TRUE;/* this is a problem for master terminal */
			call iodd_msg_ (error, both, code, myname,
			     "Bad form_status order call.  Form feed simulation terminated.");
			go to cmd_error;
		     end;
		     if ^form_info.aligned then
			call iox_$control (iodd_static.slave_out, "form_aligned", null, ignore_code);
						/* this will work */
		end;
		call write_sample_form_ (iodd_static.form_type, (iodd_static.ctl_output), code);
		if code ^= 0 then
		     if code ^= error_table_$action_not_performed then
			call iodd_msg_ (normal, source, code, myname, "Error writing form.");
		     else call iodd_msg_ (normal, source, zero_code, "", "No form type has been set.");
		go to end_cmd;
	     end;
	     call iodd_msg_ (normal, source, zero_code, "", "Control terminal is not attached.");
	     go to end_cmd;
	end;

	if command = "clean_pool" | command = "cleanpool" then do; /* garbage collect the card pool */
	     if source = slave then do;
		call iodd_msg_ (normal, source, zero_code, "", "The clean_pool command is restricted to the master terminal.")
		     ;
		go to cmd_error;
	     end;
	     if arg_list.n_tokens < 2 then do;		/* we must have an age arg */
		call iodd_msg_ (normal, source, zero_code, "", "Argument missing: days allowed to remain in the pool.");
		go to cmd_error;
	     end;
	     age = convert (age, arg_list.arg (1));	/* convert to binary */
	     if age < 1 then do;			/* be sure the value is right */
		call iodd_msg_ (normal, source, zero_code, "", "Invalid argument: ^a", arg_list.arg (1));
		go to cmd_error;
	     end;
	     if iodd_static.test_entry then		/* use a dummy pool root under sys_dir for test */
		pool_dir = rtrim (iodd_static.sys_dir_ptr -> sys_dir) || ">card_pool";
						/* this is the test pool root */
	     else pool_dir = "System_Card_Pool";	/* otherwise use the one coded in */
	     call pool_manager_$clean_pool (pool_dir, age, minimum_quota, code);
						/* let pool_manager_ do the work */
	     if code ^= 0 then
		call iodd_msg_ (normal, source, code, myname, "Unable to clean the card pool.");
	     go to end_cmd;
	end;

/*   When control passes here, the command is unknown.  So just return and let iodd_command_processor_ handle it. */

	a_code = save_code;
	return;

end_cmd:
	a_code = code;				/* pass back any defined errors */
	return;

cmd_error:
	a_code = error_table_$action_not_performed;	/* cause a resetread */
	return;
%page;

/* default error handler for the remote driver */
default_handler: entry (condition_info_ptr);

dcl  condition char (32);				/* fixed string for the call */

	condition = condition_info.condition_name;	/* this will indent funny */

	if iodd_static.request_in_progress then do;
	     dmp = addr (iodd_static.driver_ptr -> driver_status.message);
	     if dprint_msg.message_type = printer_request then /* had to know who to call */
		call do_prt_request_$error_during_request (condition);
	     else call output_request_$error_during_request (condition);
						/* take it away */
	end;
	return;					/* output_request_ should not return, but.... */
%page;
problem_notification: entry (msg_to_send);

/* this entry sends an express message to the user (if allowed) explaining the
   problem with the device.  If the user didn't get the message, try to send to
   an admin mailbox so someone can see there is a problem.  We don't care if 
   either of the recipients don't get the message.  We tried. */

dcl  msg_to_send char (*);

dcl  (user, project) char (32);
dcl  mbx_dirname char (168);
dcl  mbx_entname char (32);
dcl  mbx_access_class bit (72) aligned;

/* locate info on current request */
	driver_status_ptr = iodd_static.driver_ptr;
	mseg_message_info_ptr = addr (driver_status.descriptor);

/* if we are allowed to notify the user of the problem, then isolate the user
   name and project from the ID in the request and build the path to the user's
   mailbox */
	user = iodd_parse_$args ("notify_owner=", major_args);
	if user = "yes" then do;
	     user = before (mseg_message_info.sender_id, ".");
	     project = after (mseg_message_info.sender_id, ".");
	     project = before (project, ".");
	     mbx_dirname = ">udd>" || rtrim (project) || ">" || user;
	     mbx_entname = rtrim (user) || ".mbx";
	     mbx_access_class = mseg_message_info.sender_authorization;
	     call send_the_message;
	     if code = 0 then return;			/* got through OK */
	end;

/* if we got here, either the user isn't supposed to received the problem
   message or we tried to send it and the user would't receive the message.  In
   either case, we will see if there is an admin mailbox defined.  If there is,
   we will send the message there. */

	mbx_dirname = iodd_parse_$args ("admin_mbx=", major_args);
	if mbx_dirname = "" then return;		/* no admin address defined, forget it */

	call expand_pathname_$add_suffix (mbx_dirname, "mbx", mbx_dirname, mbx_entname, code);
	if code ^= 0 then return;

	mbx_access_class = mseg_message_info.sender_authorization;
	call send_the_message;

	return;

/* end problem_notification; */


send_the_message: proc;

/* internal entry used to send out the problem notification message */

dcl  (ipc_ind, r1_ind) fixed bin (35);

	if smi.version = -1 then do;			/* 1st call, must init */
	     smi.version = send_mail_info_version_2;
	     smi.wakeup = TRUE;
	     smi.mbz1 = ""b;
	     smi.always_add = FALSE;
	     smi.never_add = FALSE;
	     smi.notify = FALSE;
	     smi.acknowledge = FALSE;
	     smi.mbz = ""b;
	end;
	smi.sent_from = driver_status.dev_name_label;

	ipc_ind, r1_ind = -1;			/* set to non-zero to test call */

	if ^sys_priv then				/* tried once & failed */
	     go to send_it;				/* so don't bother to try again */

/* see if we can get our privileges turned on */
	on linkage_error begin;
	     sys_priv = "0"b;			/* stop trying if fail */
	     go to revert_handler;			/* send the message if possible */
	end;

	on any_other begin;
	     if r1_ind = 0 then
		call system_privilege_$ring1_priv_off (r1_ind);
	     if ipc_ind = 0 then
		call system_privilege_$ipc_priv_off (ipc_ind);
	     r1_ind, ipc_ind = -1;
	     call continue_to_signal_ (ignore_code);
	end;

	call system_privilege_$ring1_priv_on (r1_ind);

	call system_privilege_$ipc_priv_on (ipc_ind);

revert_handler:
	revert linkage_error;

send_it:	call message_facility_$send_message_access_class (mbx_dirname, mbx_entname,
	     msg_to_send, addr (smi), mbx_access_class, code);

	if r1_ind = 0 then
	     call system_privilege_$ring1_priv_off (r1_ind);

	if ipc_ind = 0 then
	     call system_privilege_$ipc_priv_off (ipc_ind);

     end send_the_message;
%page;

set_wait_timer:
     procedure ();

	call ipc_$drain_chn (ctl_wait_list.channel, code);
	if code ^= 0 then do;			/* avoid futher trouble, but not fatal */
	     ctl_wait_list.channel = 0;		/* stop trying */
	     ctl_wait_list.number = 0;
	     iodd_static.slave_hold = TRUE;		/* go back to command level for guidance */
	     ctl_msg_sent = FALSE;			/* and don't block */
	     call iodd_msg_ (error, master, zero_code, myname, "Bad call to ipc_$drain_chn.  Form synchronization terminated.");
	end;
	if ctl_msg_sent then
	     call timer_manager_$alarm_wakeup (p -> driver_status.form_wait_time, RELATIVE_SECONDS, alarm_channel);
	return;

     end set_wait_timer;



wait_for_ctl_finish:
     procedure ();

	if iodd_static.quit_during_request then do;	/* wakeup was lost */
	     ctl_msg_sent = FALSE;			/* cancel the flag */
	     return;
	end;
	if ctl_msg_sent then do;			/* avoid premature block on non-event */
	     ctl_msg_sent = FALSE;			/* ready for the next one */
	     call ipc_$block (addr (ctl_wait_list), addr (event_info), ignore_code);
						/* wait for form to finish */
	end;
	return;

     end wait_for_ctl_finish;



close_and_detach:
     procedure (a_iocbp, send_hangup);

dcl  a_iocbp ptr;
dcl  send_hangup bit (1);

	if a_iocbp = null then
	     return;

	if send_hangup then
	     call iox_$control (a_iocbp, "hangup", null, ignore_code);

	call iox_$close (a_iocbp, ignore_code);
	call iox_$detach_iocb (a_iocbp, ignore_code);

	a_iocbp = null;

	return;

     end close_and_detach;
%page;

minor_attach:
     procedure (Device);

declare  Device char (*) parameter;
declare  desc char (256) varying;
declare  mode fixed bin;
declare  device_io_module char (32) var;

	desc = major_desc || space || iodd_parse_$args ("desc=", minor_args);

	if Device = "printer" then
	     device_io_module = "remote_printer_";
	else if Device = "punch" then
	     device_io_module = "remote_punch_";
	else if Device = "reader" then
	     device_io_module = "remote_input_";

	attach_desc = device_io_module || " " || desc;
	p -> driver_status.dev_out_stream = get_switch_name (Device);

	call iox_$attach_ioname ((p -> driver_status.dev_out_stream), p -> driver_status.dev_out_iocbp, (attach_desc),
	     code);
	if code ^= 0 & code ^= error_table_$not_detached & code ^= error_table_$ionmat then
	     go to attach_error;

	if Device = "reader" then
	     mode = Stream_input;
	else mode = Stream_output;

	call iox_$open (p -> driver_status.dev_out_iocbp, mode, ""b, code);
	if code ^= 0 & code ^= error_table_$not_closed then do;
attach_error:
	     call iodd_msg_ (error, master, code, myname, "Attaching minor device:  ^a^/Attach desc:  ^a.",
		p -> driver_status.device_id, attach_desc);
	     go to clean_out;
	end;

	iodd_static.current_devices = iodd_static.current_devices + 1;

	if ^hangup_proc_defined then
	     call set_hangup_proc (p -> driver_status.dev_out_iocbp);

     end minor_attach;



get_switch_name:
     procedure (Device) returns (character (32));

declare  index fixed bin internal static init (0);
declare  Device char (*);

	index = index + 1;
	if index > 999 then
	     index = 1;				/* keep it reasonable */
	return (Device || "_" || ltrim (character (index)));

     end get_switch_name;
%page;

find_driver_status_seg_ptr:
     procedure (minor_device_name) returns (pointer);

dcl  minor_device_name varying character (*) aligned parameter;
dcl  i fixed bin;
dcl  stat_segp ptr;

	list_ptr = iodd_static.driver_list_ptr;		/* make reference easier to read */
	do i = 1 to driver_ptr_list.number;
	     stat_segp = driver_ptr_list.stat_segp (i);	/* get next driver status seg ptr */
	     if minor_device_name = stat_segp -> driver_status.device_id then
						/* look for minor name match */
		return (stat_segp);
	end;

	return (null ());				/* no minor device found with the requested name */

     end find_driver_status_seg_ptr;



set_hangup_proc:
     procedure (iocbp);

dcl  iocbp ptr;

/* this internal proc will set the device hangup procedure for the specified switch */

	hangup_info.entry = iodd_hangup_$iodd_hangup_;
	hangup_info.data_ptr = stat_p;
	hangup_info.priority = 1;
	call iox_$control (iocbp, "hangup_proc", addr (hangup_info), code);
	if code ^= 0 then
	     call iodd_msg_ (error, master, code, myname,
		"Warning: Could not establish handler for hangups from the device.");

	hangup_proc_defined = TRUE;			/* once is enuf */

	return;

     end set_hangup_proc;
%page;

set_paper_info:
     procedure (source, code);

dcl  code fixed bin (35);
dcl  source fixed bin;

	code = 0;

	call iox_$control (p -> driver_status.dev_out_iocbp, "paper_info", addr (prt_ctl.paper_info), code);
	if code ^= 0 then
	     if code = error_table_$no_operation then do; /* if dim couldn't, tell the operator */

		call iodd_msg_ (normal, source, zero_code, "",
		     "^/Mount VFU tape for ^d lines per page.^/Set printer for ^d lines/inch.",
		     prt_ctl.phys_page_length, prt_ctl.lines_per_inch);

		code = 0;				/* this is really ok */
	     end;
	     else do;
		call iodd_msg_ (normal, both, code, myname, "Unable to perform paper_info order.");
						/* a real error */
	     end;

	return;

     end set_paper_info;
%page;

get_prt_rqti_data:
     procedure (p);

dcl  p pointer;

/* internal procedure to get paper info and channel stops data from the rqt info segment
   or to establish some defaults if one is not being used */

	prt_ctl_ptr = p -> driver_status.dev_ctl_ptr;
	string (prt_ctl.flags) = ""b;

	if p -> driver_status.rqti_ptr ^= null then do;	/* if there is an rqti seg, use it */

	     prt_rqtip = p -> driver_status.rqti_ptr;	/* make the based references cleaner */
	     if prt_rqti.header.header_version ^= rqti_header_version_1 then do;
		call iodd_msg_ (error, both, error_table_$fatal_error, myname,
		     "prt rqt info header version ^d found (expected ^d)", prt_rqti.header.header_version,
		     rqti_header_version_1);
		go to clean_out;
	     end;

	     prt_ctl.meter = prt_rqti.header.meter;	/* do we take meter data? */
	     ready_device = ready_device | prt_rqti.header.auto_go;
	     p -> driver_status.ready = prt_rqti.header.auto_go;
						/* set the initial hold state as requested */
	     iodd_static.wakeup_time = max (wakeup_time_default, prt_rqti.header.driver_wait_time);
						/* seconds to wait for a request */
	     if prt_rqti.header.type_code = 0 then
		go to set_defaults;			/* this is only a header */
	     else if prt_rqti.header.type_code ^= 1 then do;
		call iodd_msg_ (error, both, error_table_$fatal_error, myname, "Wrong rqt info seg type for printer.")
		     ;
		go to clean_out;
	     end;

	     if prt_rqti.version ^= prt_rqti_version_1 then do; /* see if it is the right version */
		call iodd_msg_ (error, both, error_table_$fatal_error, myname,
		     "Wrong version of prt_rqti. Found ^d (expected ^d)", prt_rqti.version, prt_rqti_version_1);
		go to clean_out;
	     end;

	     if prt_rqti.opr_msg ^= "" then
		call iodd_msg_ (normal, both, zero_code, "", "^/^a", prt_rqti.opr_msg);
						/* give operator instructions */

	     prt_ctl.phys_page_length = prt_rqti.paper_length;
						/* get paper data for prtdim */
	     prt_ctl.phys_line_length = prt_rqti.paper_width;
	     prt_ctl.lines_per_inch = prt_rqti.lines_per_inch;

	     prt_ctl.channel_stops = prt_rqti.channel_stops;
						/* get VFU stops for printer */

	     prt_ctl.banner_type = prt_rqti.banner_type;	/* copy control info to writable storage */
	     prt_ctl.force_nep = prt_rqti.force_nep;
	     prt_ctl.force_esc = prt_rqti.force_esc;
	     prt_ctl.force_ctl_char = prt_rqti.force_ctl_char;
	     prt_ctl.no_auto_print = prt_rqti.no_auto_print;
	     prt_ctl.force_nsep = prt_rqti.force_nsep;
	     prt_ctl.banner_bars = prt_rqti.banner_bars;
	     prt_ctl.banner_indent = prt_rqti.banner_indent;
	     prt_ctl.banner_line = prt_rqti.banner_line;
	end;
	else do;					/* no rqti seg, so set some defaults */
	     prt_ctl.meter = FALSE;			/* no meters */
	     iodd_static.slave_hold = TRUE;		/* be sure to ask for a start command */
	     iodd_static.wakeup_time = wakeup_time_default; /* check every 30 seconds */
set_defaults:					/* set up the default paper data */
	     prt_ctl.phys_page_length = page_length_default; /* 11 inch paper at 6 lpi is 66 lines */
	     prt_ctl.phys_line_length = line_length_default; /* standard remote platten is 132 chars */
	     prt_ctl.lines_per_inch = lpi_default;	/* normal for good readibility */

	     string (prt_ctl.channel_stops) = FALSE;	/* no slew stops are defined */

	     prt_ctl.force_nep = FALSE;		/* let user have his way */
	     prt_ctl.force_esc = FALSE;
	     prt_ctl.force_ctl_char = FALSE;
	     prt_ctl.no_auto_print = FALSE;		/* print without requesting operator attn */
	     prt_ctl.force_nsep = FALSE;		/* print inner head and tail sheets for multiple copies */
	     prt_ctl.banner_type = NORMAL_BANNERS;	/* use normal head/tail sheets */
	     prt_ctl.banner_bars = NORMAL_BANNER_BARS;	/* means nothing for now */
	     prt_ctl.banner_indent = 0;		/* again */
	     prt_ctl.banner_line = 1;			/* again */
	end;


	return;

     end get_prt_rqti_data;
%page;

initiate_the_file:
     proc (pathname_string, args_ptr, args_length, message, code);

dcl  pathname_string char (256) varying;
dcl  args_ptr ptr;
dcl  args_length fixed bin;
dcl  message char (*);
dcl  code fixed bin (35);

dcl  dirname char (168);
dcl  entname char (32);
dcl  compname char (32);
dcl  args_bc fixed bin (24);

	call expand_pathname_$component ((pathname_string), dirname, entname, compname, code);
	if code ^= 0 then
	     return;
	call initiate_file_$component (dirname, entname, compname, R_ACCESS, args_ptr, args_bc, code);
	if code ^= 0 then
	     return;
	args_length = divide (args_bc + 8, 9, 17, 0);

     end initiate_the_file;

return_string: proc (target) returns (char (*));

/* routine to return a string from the i/o daemon tables text strings area */

dcl  1 target unaligned like text_offset;

	if target.total_chars = 0 then
	     return ("");
	else return (substr (text_strings.chars, target.first_char, target.total_chars));
     end return_string;
%page;
evaluate_forms_options: proc (error_code);

/* this subroutine will evaluate the forms option supplied by the user and the
   defaults defined for the request type and/or device.
*/

dcl  error_code fixed bin (35);

/* set to global ptrs to main groups in io daemon tables we will need */
	idtp = iodd_static.idtp;			/* device tables */
	mdtp = iodd_static.mdtp;			/* minor device tables */
	qgtp = iodd_static.qgtp;			/* request_type tables */
	dctp = iodd_static.dev_class_ptr;		/* device_class tables */
	text_strings_ptr = iodd_static.text_strings_ptr;	/* common text strings */

/* now set up ptrs to specific request type and device entries for this request */
	idtep = addr (iod_device_tab.entries (p -> driver_status.maj_index)); /* major device entry */
	mdtep = addr (minor_device_tab.entries (p -> driver_status.dev_index)); /* minor device entry */
	dctep = addr (dev_class_tab.entries (p -> driver_status.dev_class_index)); /* device_class entry */
	qgtep = addr (q_group_tab.entries (dcte.qgte_index)); /* request_type */

	if my_area_ptr = null then
	     my_area_ptr = get_system_free_area_ ();

/* set up the structure to pass in */
	if dprint_msg.version < dprint_msg_version_5 then
	     system_input_forms_string_length = length (rtrim (dprint_msg.forms));
	else system_input_forms_string_length = dprint_msg.forms_name_lth;
	evaluate_forms_info_input_ptr,
	     evaluate_forms_info_output_ptr = null;

	on cleanup begin;
	     if evaluate_forms_info_input_ptr ^= null then
		free evaluate_forms_info_input;
	     if evaluate_forms_info_output_ptr ^= null then
		free evaluate_forms_info_output;
	end;

	allocate evaluate_forms_info_input in (my_area);

	evaluate_forms_info_input.version = EVALUATE_FORMS_INFO_INPUT_VERSION_1;
	evaluate_forms_info_input.ithp = iodd_static.ithp;
	evaluate_forms_info_input.qgtep = qgtep;
	evaluate_forms_info_input.idtep = idtep;
	evaluate_forms_info_input.mdtep = mdtep;
	if dprint_msg.version < dprint_msg_version_5 then
	     evaluate_forms_info_input.forms_string = rtrim (dprint_msg.forms);
	else evaluate_forms_info_input.forms_string = dprint_msg.forms_name;
	evaluate_forms_info_input.area_ptr = my_area_ptr;

/* call common routine which does all forms validation */
	call iod_info_$evaluate_forms_info (p -> driver_status.rqti_ptr,
	     evaluate_forms_info_input_ptr, evaluate_forms_info_output_ptr,
	     error_code);
	if error_code = 0 | error_code = error_table_$no_forms_table_defined then do;
	     prt_ctl.phys_line_length = evaluate_forms_info_output.chars_per_line;
	     prt_ctl.phys_page_length = evaluate_forms_info_output.lines_per_page;
	     prt_ctl.lines_per_inch = evaluate_forms_info_output.lines_per_inch;
	     p -> driver_status.forms_validation_ptr = evaluate_forms_info_output_ptr;
	     error_code = 0;
	end;

	free evaluate_forms_info_input;

     end evaluate_forms_options;
%page; %include access_mode_values;
%page; %include card_stream_info;
%page; %include condition_info;
%page; %include device_class;
%page; %include dprint_msg;
%page; %include driver_ptr_list;
%page; %include driver_status;
%page; %include iod_constants;
%page; %include iod_device_tab;
%page; %include iod_tables_hdr;
%page; %include iod_line_tab;
%page; %include iodd_static;
%page; %include iox_modes;
%page; %include mseg_message_info;
%page; %include output_request_data;
%page; %include prt_ctl;
%page; %include prt_order_info;
%page; %include prt_rqti;
%page; %include q_group_tab;
%page; %include queue_msg_hdr;
%page; %include request_descriptor;
%page; %include send_mail_info;
%page; %include terminal_info;
%page; %include system_constants;
%page; %include system_forms_info;
%page; %include timer_manager_constants;

     end remote_driver_;




		    remote_input_.pl1               11/15/82  1900.8rew 11/15/82  1523.6      201051



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


remote_input_: proc;

/* remote_input_: An I/O module for receiving character records from a remote host. */

/* Coded March 1980 by J. C. Whitmore, modeled after the remote_reader_ IO Module */


/* Parameters */

dcl  a_iocbp ptr parameter;
dcl  a_option (*) char (*) var parameter;		/* Options for attach */
dcl  a_sw bit (1) parameter;				/* com_err_ switch for attach */
dcl  a_code fixed bin (35) parameter;
dcl  a_mode fixed bin parameter;			/* The open mode */
dcl  a_buf_ptr ptr parameter;
dcl  a_buf_chars fixed bin (21) parameter;
dcl  a_data_chars fixed bin (21) parameter;
dcl  a_pos_type fixed bin parameter;
dcl  a_pos_value fixed bin (21) parameter;
dcl  a_order char (*) parameter;
dcl  a_infop ptr parameter;
dcl  a_old_modes char (*) parameter;
dcl  a_new_modes char (*) parameter;

/* AUTOMATIC VARIABLES */

dcl  com_err_sw bit (1);				/* Set if com_err_ sould be called on attach error */
dcl  dummy char (32) var;
dcl  total_chars fixed bin (21);			/* number of chars in a record */
dcl  code fixed bin (35);
dcl  iocbp ptr;
dcl  temp_iocbp ptr;
dcl  slew_string char (128) var;
dcl  mask bit (36) aligned;				/* For setting ips mask */
dcl  device_opt char (32) var;
dcl  idx fixed bin;
dcl  record_len fixed bin;
dcl  max_record_size fixed bin;
dcl  open_mode fixed bin;
dcl  order char (32);
dcl  infop ptr;
dcl  terminal_switch_name char (32) var;
dcl  terminal_attach_options char (256) var;
dcl  my_options char (64) var;
dcl  terminal_attach_desc char (256) var;

/* Constants */

dcl  remote_device_name char (13) int static options (constant) init ("remote_input_");
dcl  space char (1) int static options (constant) init (" ");
dcl  ESC_c char (2) int static options (constant) init ("c");
dcl  ETX char (1) int static options (constant) init ("");
dcl  CR char (1) int static options (constant) init ("");
dcl  NL char (1) int static options (constant) init ("
");
dcl  FF char (1) int static options (constant) init ("");

/* Internal Static and Based variables */

dcl  areap ptr int static init (null);
dcl  attach_count int static init (0) fixed bin;
dcl  static_comerr_sw bit (1) int static init ("0"b);

dcl  my_area area (262144) based (areap);
dcl  char_string char (1024) based;

/* External stuff */

dcl  ioa_ entry options (variable);
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  iox_$propagate entry (ptr);
dcl  com_err_ entry options (variable);
dcl  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35));
dcl  iox_$get_chars entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  iox_$read_record entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$err_no_operation entry;

dcl (addr, bin, hbound, min, null, length, substr, rtrim, ltrim, char, size, unspec, copy, empty) builtin;

dcl  error_table_$bad_mode fixed bin (35) ext;
dcl  error_table_$bad_arg fixed bin (35) ext;
dcl  error_table_$eof_record ext fixed bin (35);
dcl  error_table_$not_detached ext fixed bin (35);
dcl  error_table_$not_attached ext fixed bin (35);
dcl  error_table_$not_open ext fixed bin (35);
dcl  error_table_$not_closed ext fixed bin (35);
dcl  error_table_$wrong_no_of_args ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$bad_conversion ext fixed bin (35);
dcl  error_table_$unimplemented_version ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);
dcl  error_table_$data_loss ext fixed bin (35);

dcl (any_other, cleanup, conversion) condition;


dcl  adp ptr;					/* pointer to the attach data structure */

dcl 1 ad aligned based (adp),
    2 fixed,
      3 device_type fixed bin,			/* type code for terminal_io_record */
      3 rec_length fixed bin,				/* max data length of input record */
      3 record_count fixed bin (35),			/* total records read since last reset control order */
      3 fixed_pad fixed bin,
    2 ptrs,
      3 terminal_iocbp ptr,				/* pointer to the iocbp of the next dim level */
    2 bits,
      3 record_io bit (1) unal,			/* TRUE - if terminal io module uses record interface */
      3 bit_pad bit (35) unal,
    2 chars,
      3 terminal char (32) var,			/* name of the terminal io module */
      3 attach_desc char (256) var,			/* our attach description */
      3 open_description char (24) var;			/* our open description */


dcl 1 count_structure aligned based,			/* structure used for the get_count control order */
    2 line fixed bin,				/* most fields are pads, because this structure */
    2 page_len fixed bin,				/* is based on the printer defined structure */
    2 lmarg fixed bin,				/* shown in prt_order_info.incl.pl1 */
    2 rmarg fixed bin,
    2 records fixed bin (35),				/* this is the normal line count field */
    2 page_count fixed bin;


%include iocb;

%include iox_modes;

%include terminal_io_record;

remote_reader_attach:				/* compatibility */
remote_input_attach: entry (a_iocbp, a_option, a_sw, a_code);

	iocbp = a_iocbp;
	com_err_sw = a_sw | static_comerr_sw;		/* if either one is set ... */
	code, a_code = 0;

	adp = null;
	if iocbp -> iocb.attach_descrip_ptr ^= null then do;
	     code = error_table_$not_detached;
	     call abort_attach (code, "Switch name: ^a", iocbp -> iocb.name);
	end;

	if hbound (a_option, 1) < 1 then do;		/* Must be at least one */
	     code = error_table_$wrong_no_of_args;
	     call abort_attach (code, "Bad attach description.", "");
	end;

	if areap = null then do;
	     call get_temp_segment_ (remote_device_name, areap, code); /* Temp segment for attach data */
	     if code ^= 0 then call abort_attach (code, "Unable to allocate temp segment.", "");
	     areap -> my_area = empty ();		/* initialize our private area */
	end;

	on cleanup call clean_up;

	allocate ad in (my_area) set (adp);

/* Initialize Attach Data Structure variables */

	ad.bits = "0"b;
	ad.ptrs = null;
	ad.chars = "";
	ad.rec_length = -1;				/* mark this as not specified */
	ad.record_count = 0;


/* Process options */

	terminal_attach_options = "";
	my_options = "";
	terminal_attach_desc = "";
	device_opt = "reader";			/* default to reader if no -device is given */

	do idx = 1 to hbound (a_option, 1);
	     if a_option (idx) = "-terminal" then do;
		ad.terminal = get_arg (idx);
		my_options = my_options || " -terminal " || ad.terminal;
	     end;
	     else if a_option (idx) = "-device" then device_opt = get_arg (idx); /* we specify this one */
	     else if a_option (idx) = "-runout_spacing" | a_option (idx) = "-runsp" then do; /* skip this and next arg */
		dummy = get_arg (idx);
		my_options = my_options || " -runsp " || dummy;
	     end;
	     else if a_option (idx) = "-physical_page_length" | a_option (idx) = "-ppl" then do; /* skip this too */
		dummy = get_arg (idx);
		my_options = my_options || " -ppl " || dummy;
	     end;
	     else if a_option (idx) = "-record_len" then do; /* redefine the max record length */
		ad.rec_length = cv_dec_arg (idx);
		my_options = my_options || " -record_len " || a_option (idx);
	     end;
	     else terminal_attach_options = terminal_attach_options || space || a_option (idx);
	end;

	if ad.terminal = "" then do;
	     code = error_table_$noarg;
	     call abort_attach (code, "No terminal IO module specified.", "");
	end;

	if device_opt = "" then do;			/* caller didn't specify */
	     code = error_table_$noarg;
	     call abort_attach (code, "Missing argument to -device option.", "");
	end;
	else if device_opt = "printer_in" then do;
	     ad.device_type = PRINTER_DEVICE;
	     device_opt = "printer";			/* this is for the attachment to the terminal */
	end;
	else if device_opt = "punch_in" then do;
	     ad.device_type = PUNCH_DEVICE;
	     device_opt = "punch";			/* again for the attach description to the terminal */
	end;
	else if device_opt = "reader" then do;
	     ad.device_type = READER_DEVICE;
	end;
	else do;					/* not recognized */
	     code = error_table_$badopt;
	     call abort_attach (code, "Invalid -device option: ^a", (device_opt));
	end;

	if ad.rec_length = -1 then do;		/* not specified - set default max record size */
	     if ad.device_type = READER_DEVICE then ad.rec_length = 160;
	     else ad.rec_length = 1024;		/* lots of room for print lines/files */
	end;

	if ad.device_type = READER_DEVICE then do;	/* range check the record length */
	     if ad.rec_length < 80 | ad.rec_length > 160 then do; /* OOPS - not reasonable */
		code = error_table_$bad_arg;
		call abort_attach (code, "Value for -record_len option out of range.", "");
	     end;
	end;
	else do;
	     if ad.rec_length < 10 | ad.rec_length > 1024 then do;
		code = error_table_$bad_arg;
		call abort_attach (code, "Value for -record_len option out of range.", "");
	     end;
	end;

/* Attach through terminal dim */

	attach_count = attach_count + 1;		/* new attach name tag number each time */
	if attach_count > 999 then attach_count = 1;
	terminal_switch_name = remote_device_name || ltrim (char (attach_count)); /* make the  switch name */

	terminal_attach_options = ltrim (terminal_attach_options) || " -device " || device_opt;
	terminal_attach_desc = ad.terminal || space || terminal_attach_options;
	ad.attach_desc = remote_device_name || my_options || space || terminal_attach_options;

	call iox_$attach_ioname ((terminal_switch_name), temp_iocbp, (terminal_attach_desc), code);
	if code ^= 0 then call abort_attach (code, "Unable to attach to terminal: ^a", (ad.terminal));

	ad.terminal_iocbp = temp_iocbp;

/* Now mask and complete the iocb */

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc);
	iocbp -> iocb.attach_data_ptr = adp;
	iocbp -> iocb.open = remote_input_open;
	iocbp -> iocb.detach_iocb = remote_input_detach;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

attach_return:

	return;

remote_input_detach: entry (a_iocbp, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr ^= null then do;
	     a_code = error_table_$not_closed;
	     return;
	end;

	call clean_up;

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.attach_descrip_ptr = null;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

remote_input_open: entry (a_iocbp, a_mode, a_sw, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr ^= null then do;
	     a_code = error_table_$not_closed;
	     return;
	end;

	open_mode = a_mode;
	if ^(open_mode = Stream_input | open_mode = Stream_input_output) then do;
	     a_code = error_table_$bad_mode;
	     return;
	end;

	ad.open_description = rtrim (iox_modes (open_mode));

	call iox_$open (ad.terminal_iocbp, Sequential_input, "0"b, a_code); /* try for the record interface */
	if a_code = 0 then do;			/* well we made it, records approved */
	     ad.record_io = "1"b;			/* record the fact */
	end;
	else do;					/* Ok, so we try for the stream interface */
	     ad.record_io = "0"b;
	     call iox_$open (ad.terminal_iocbp, Stream_input, "0"b, a_code);
	     if a_code ^= 0 then return;		/* Oh, well */
	end;

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.get_chars = remote_input_get_chars;
	iocbp -> iocb.get_line = remote_input_get_chars;
	iocbp -> iocb.position = remote_input_position;
	iocbp -> iocb.control = remote_input_control;
	iocbp -> iocb.modes = remote_input_modes;
	iocbp -> iocb.close = remote_input_close;
	iocbp -> iocb.open_descrip_ptr = addr (ad.open_description);

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

remote_input_close: entry (a_iocbp, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	call iox_$close (ad.terminal_iocbp, a_code);	/* try to close the terminal switch too */
	if a_code = error_table_$not_open | a_code = error_table_$not_attached then code = 0;
						/* make it easy to re-synch attachments */

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.open_descrip_ptr = null;
	iocbp -> iocb.open = remote_input_open;
	iocbp -> iocb.detach_iocb = remote_input_detach;
	iocbp -> iocb.control = iox_$err_no_operation;
	iocbp -> iocb.modes = iox_$err_no_operation;
	iocbp -> iocb.position = iox_$err_no_operation;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

remote_input_get_chars: entry (a_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	a_data_chars, a_code, code = 0;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	max_record_size = ad.rec_length;		/* put into automatic for this call */

	terminal_io_record_ptr = null;		/* for the cleanup handler */
	terminal_io_record_element_size = 9;		/* always character data */
	terminal_io_record_n_elements = max_record_size;	/* set the max record size allowed */

	on cleanup begin;
	     if terminal_io_record_ptr ^= null then
		free terminal_io_record_ptr -> terminal_io_record in (my_area);
	end;

	call alloc_tio_rec;				/* allocate and initialize terminal_io_record */

	terminal_io_record.n_elements = max_record_size;	/* set to the max size for the read call */

/* Read the next record from the terminal IO Module */

	if ad.record_io then do;
	     call iox_$read_record (ad.terminal_iocbp, terminal_io_record_ptr, 4 * size (terminal_io_record),
		record_len, code);
	     if code ^= 0 then go to get_chars_ret;	/* accept EOF from the terminal as well */
	     if terminal_io_record.version ^= terminal_io_record_version_1 then do;
		code = error_table_$unimplemented_version;
		go to get_chars_ret;
	     end;

	     if ad.device_type ^= READER_DEVICE then do;	/* no slews for the reader */
		if terminal_io_record.slew_type = SLEW_BY_COUNT then do;
		     if terminal_io_record.slew_count = 0 then
			slew_string = CR;		/* this is the overprint case */
		     else slew_string = copy (NL, terminal_io_record.slew_count);
		end;
		else if terminal_io_record.slew_type = SLEW_TO_CHANNEL then do;
		     slew_string = ESC_c || ltrim (char (terminal_io_record.slew_count)) || ETX;
		end;
		else do;				/* TOIP = TOOP = TOP for seg text */
		     slew_string = FF;		/* so just add one FF char */
		end;
	     end;
	     else do;				/* for the reader, check for ++EOF cards */
		if terminal_io_record_data_chars = "++EOF" | terminal_io_record_data_chars = "++eof" then do;
		     code = error_table_$eof_record;
		     go to get_chars_ret;
		end;
		slew_string = "";			/* no additional slew chars will be added */
	     end;
	end;
	else do;
	     call iox_$get_chars (ad.terminal_iocbp, addr (terminal_io_record.data), max_record_size, record_len, code);
	     if code ^= 0 then go to get_chars_ret;	/* accept EOF from the terminal as well */
	     terminal_io_record.n_elements = record_len;	/* make a legal varying string */

/*	For stream input, all slew chars must be in the stream already */

	     if ad.device_type = READER_DEVICE then do;	/* look for EOF cards from reader */
		if terminal_io_record_data_chars = "++EOF" | terminal_io_record_data_chars = "++eof" then do;
		     code = error_table_$eof_record;
		     go to get_chars_ret;
		end;
	     end;
	     slew_string = "";			/* all slews must be in the stream */
	end;

/*	at this point, we must have a record of the form:  <text chars><slew chars> */

	total_chars = terminal_io_record.n_elements + length (slew_string); /* get the updated count */
	if total_chars > a_buf_chars then
	     code = error_table_$data_loss;		/* tell caller we truncated the record */

	a_data_chars = min (a_buf_chars, total_chars);
	if terminal_io_record.preslew then
	     substr (a_buf_ptr -> char_string, 1, a_data_chars) = slew_string || terminal_io_record_data_chars;
	else substr (a_buf_ptr -> char_string, 1, a_data_chars) = terminal_io_record_data_chars || slew_string;
	ad.record_count = ad.record_count + 1;		/* increment the total read */

get_chars_ret:

	free terminal_io_record_ptr -> terminal_io_record in (my_area);
	revert cleanup;

	a_code = code;

	return;

remote_input_control: entry (a_iocbp, a_order, a_infop, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	infop = a_infop;
	order = a_order;
	a_code = 0;

	if order = "reset" then do;			/* go to a known clean state */
	     ad.record_count = 0;			/* we just clear the count of records read */
	     go to pass_on;				/* and then give it to the terminal IO Module */
	end;
	else if order = "get_count" then do;		/* this is for us alone */
	     if infop ^= null then infop -> count_structure.records = ad.record_count; /* give back the count */
	     else a_code = error_table_$bad_arg;
	end;
	else do;
pass_on:	     call iox_$control (ad.terminal_iocbp, order, infop, a_code);
	end;

	return;

remote_input_modes: entry (a_iocbp, a_new_modes, a_old_modes, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	a_code = 0;

	call iox_$modes (ad.terminal_iocbp, a_new_modes, a_old_modes, a_code);

	return;

remote_input_position: entry (a_iocbp, a_pos_type, a_pos_value, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	a_code = 0;

	call iox_$position (ad.terminal_iocbp, a_pos_type, a_pos_value, a_code);

	return;




flip_com_err_sw: entry;

	static_comerr_sw = ^static_comerr_sw;		/* flip the bit */

	call ioa_ ("The INPUT com err sw is now: ^[on^;off^]", static_comerr_sw);

	return;


get_arg:	proc (idx) returns (char (*));

dcl  idx fixed bin;

	     idx = idx + 1;
	     if idx > hbound (a_option, 1) then do;
		code = error_table_$noarg;
		call abort_attach (code, "No argument after ^a.", (a_option (idx - 1)));
	     end;

	     return (a_option (idx));

	end get_arg;



cv_dec_arg: proc (idx) returns (fixed bin);

dcl  idx fixed bin;

	     idx = idx + 1;				/* advance the index of the major loop */
	     if idx > hbound (a_option, 1) then do;
		code = error_table_$noarg;
		call abort_attach (code, "No argument after ^a.", (a_option (idx - 1)));
	     end;

	     on conversion go to bad_dec_arg;

	     return (bin (a_option (idx)));
bad_dec_arg:
	     code = error_table_$bad_conversion;
	     call abort_attach (code, "Invalid decimal number. ^a", (a_option (idx)));

	end cv_dec_arg;


abort_attach: proc (code, str1, str2);

dcl  code fixed bin (35);
dcl (str1, str2) char (*) aligned;

/* This proc handles attach errors */

	     if com_err_sw then call com_err_ (code, remote_device_name, str1, str2);

	     a_code = code;				/* copy back the error, MUST be non-zero */

	     call clean_up;

	     go to attach_return;			/* finish the abort by non-local return */

	end abort_attach;




alloc_tio_rec: proc;

	     allocate terminal_io_record in (my_area) set (terminal_io_record_ptr);

	     unspec (terminal_io_record) = "0"b;	/* clear everything */

	     terminal_io_record.version = terminal_io_record_version_1; /* our view of the record structure */
	     terminal_io_record.device_type = ad.device_type;
	     terminal_io_record.element_size = terminal_io_record_element_size; /* set by our caller */

	     return;

	end alloc_tio_rec;


clean_up:	proc;

dcl  ignore fixed bin (35);

	     if adp ^= null then do;
		if ad.terminal_iocbp ^= null then call iox_$detach_iocb (ad.terminal_iocbp, ignore);
		free adp -> ad in (my_area);
		adp = null;
	     end;

	     iocbp -> iocb.attach_descrip_ptr = null;	/* be sure iox_ knows */
	     iocbp -> iocb.attach_data_ptr = null;
	     iocbp -> iocb.open = iox_$err_no_operation;

	     return;

	end clean_up;





handler:	proc;

dcl  ignore fixed bin (35);

/* This proc handles faults that occur while masked */

	     if mask then
		call hcs_$reset_ips_mask (mask, mask);

	     mask = ""b;

	     call continue_to_signal_ (ignore);

	     return;

	end handler;

     end remote_input_;




		    remote_printer_.pl1             11/09/88  1302.9rew 11/09/88  1302.1      226521



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

/* format: style4 */

/* format: off */

/* remote_printer_: An I/O module for communicating with a remote printer or its equivilent */

/* Created:  March 1977 by David Vinograd */
/* Modified: May 1978 by David Vinograd to clean up and interface to user TTFs */
/* Modified: November 1978 by J. C. Whitmore to make all attach options for remote_xxx_ dims consistent */
/* Modified: March 1980 by J. C. Whitmore to use the terminal_io_record interface to the terminal IO module */
/* Modified: 13 December 1981 by G. Palter to not use illegal PL/I and provide sufficient extra space for prt_conv_ to
      output control sequences */

/****^  HISTORY COMMENTS:
  1) change(88-06-07,Brunelle), approve(88-06-07,MCR7911),
     audit(88-10-24,Farley), install(88-11-08,MR12.2-1205):
     Add support for model name argument on attach.  This includes calling a
     module based on the model name to setup for any special processing
     required.  Also add support to disable prt_conv_ processing and
     recognize rawo modes and pass them to tty_ module.
                                                   END HISTORY COMMENTS */

/* format: on */

remote_printer_: procedure ();

/* Parameters */

dcl  a_code fixed bin (35) parameter;			/* error code */
dcl  a_data_chars fixed bin (21) parameter;		/* number of chars to be input/output */
dcl  a_data_ptr ptr parameter;			/* ptr to chars to be input/output */
dcl  a_infop ptr parameter;				/* info ptr to control order */
dcl  a_iocbp ptr parameter;				/* iocb ptr */
dcl  a_mode fixed bin parameter;			/* The open mode */
dcl  a_new_modes char (*) parameter;			/* new modes to assign */
dcl  a_old_modes char (*) parameter;			/* current modes */
dcl  a_option (*) char (*) var parameter;		/* options for attach */
dcl  a_order char (*) parameter;			/* order to be executed */
dcl  a_pos_type fixed bin parameter;			/* iox_$position positioning type */
dcl  a_pos_value fixed bin (21) parameter;		/* iox_$position positioning count */
dcl  a_sw bit (1) parameter;				/* com_err_ switch for attach */

/* Automatic */

dcl  attach_entry entry (ptr, fixed bin (35)) variable;	/* special model entry to call to complete attachment */
dcl  attach_entry_name char (64);			/* module name for special model attachment */
dcl  charp ptr;					/* ptr to next char for output in put_chars entrypoint */
dcl  code fixed bin (35);				/* general error code */
dcl  com_err_sw bit (1);				/* Set if com_err_ should be called on attach error */
dcl  cur_page fixed bin (24);				/* current page number being output as returned by prt_conv_ */
dcl  device_opt char (32) var;
dcl  dummy char (32) var;				/* type of device for attachment */
dcl  ec fixed bin (35);				/* secondary error code */
dcl  i fixed bin (21);				/* misc counter */
dcl  idx fixed bin;					/* attachment argument index */
dcl  ignore fixed bin (35);				/* dummy error code */
dcl  infop ptr;					/* internal copy of control order info pointer */
dcl  iocbp ptr;					/* internal copy of iocb ptr */
dcl  mask bit (36) aligned;				/* for setting ips mask */
dcl  my_options char (256) var;			/* some of the attachment options */
dcl  open_mode fixed bin;				/* copy of user supplied input mode */
dcl  order char (32);				/* copy of user supplied order */
dcl  prt_conv_outp ptr;				/* where prt_conv_ is to put processed data */
dcl  record_len fixed bin (21);			/* length of prt_conv_ processed record */
dcl  remaining_chars fixed bin (21);			/* number of chars left for prt_conv_ to process */
dcl  temp_iocbp ptr;				/* temporary IOCB prt */
dcl  terminal_attach_desc char (256) var;
dcl  terminal_attach_options char (256) var;
dcl  terminal_switch_name char (32) var;
dcl  total_chars fixed bin (24);			/* number of chars requested for put_chars */

/* Internal Static */

dcl  attach_count fixed bin int static init (0);
dcl  my_area_ptr ptr int static init (null);
dcl  my_area area based (my_area_ptr);
dcl  prt_conv_on bit (1) internal static init ("1"b);
dcl  static_comerr_sw bit (1) int static init ("0"b);

/* Constants */

dcl  printer_device char (32) int static options (constant) init ("printer");
dcl  remote_device_name char (15) int static options (constant) init ("remote_printer_");
dcl  space char (1) static init (" ") int options (constant);

/* External Procedures & Variables */

dcl  com_err_ entry options (variable);
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);
dcl  error_table_$bad_arg ext fixed bin (35);
dcl  error_table_$bad_conversion fixed bin (35) ext;
dcl  error_table_$bad_mode ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$not_attached ext fixed bin (35);
dcl  error_table_$not_closed ext fixed bin (35);
dcl  error_table_$not_detached ext fixed bin (35);
dcl  error_table_$not_open ext fixed bin (35);
dcl  error_table_$request_pending ext fixed bin (35);
dcl  error_table_$wrong_no_of_args ext fixed bin (35);
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  ioa_ entry options (variable);
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$err_no_operation entry;
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35));
dcl  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$propagate entry (ptr);
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  prt_conv_ entry (ptr, fixed bin (21), ptr, fixed bin (21), ptr);
dcl  remote_printer_control_ entry (ptr, char (*), ptr, fixed bin (35));
dcl  remote_printer_modes_ entry (ptr, char (*), char (*), fixed bin (35));
dcl  sys_info$max_seg_size fixed bin ext;

/* Conditions and Builtins */

dcl  (conversion, cleanup, any_other) condition;

dcl  (addr, bin, char, currentsize, hbound, index, ltrim, null, rtrim, substr, unspec) builtin;
%page;

remote_printer_attach:
     entry (a_iocbp, a_option, a_sw, a_code);

	iocbp = a_iocbp;
	com_err_sw = a_sw | static_comerr_sw;		/* report errors if either is on */
	code, a_code = 0;

	if my_area_ptr = null then
	     my_area_ptr = get_system_free_area_ ();

	adp = null;
	if iocbp -> iocb.attach_descrip_ptr ^= null then do;
	     code = error_table_$not_detached;
	     call abort_attach (code, "Switch name: ^a", iocbp -> iocb.name);
	end;

	if hbound (a_option, 1) < 1 then do;		/* Must be at least one */
	     code = error_table_$wrong_no_of_args;
	     call abort_attach (code, "Bad attach description.", "");
	end;

	on cleanup call clean_up;

	allocate ad in (my_area) set (adp);		/* make space for the attach data structure */

/* Initialize the Attach Data Structure variables */

	ad.bits = "0"b;
	ad.fixed = 0;
	ad.ptrs = null;
	ad.chars = "";
	unspec (ad.remote_pci) = "0"b;
	unspec (ad.info) = "0"b;
	ad.device_type = PRINTER_DEVICE;		/* default for terminal_io_record structure */
	ad.sheets_per_page = 1;
	ad.phys_line_length = 132;			/* this will normally get reset by a paper_info control order */
	ad.phys_page_length = 66;
	ad.lpi = 6;
	ad.line = 1;
	ad.cv_proc = null;				/* not defined until the open operation */

/* Process options */

	terminal_attach_options = "";
	my_options = "";
	terminal_attach_desc = "";
	device_opt = "printer";			/* our default device option */

	do idx = 1 to hbound (a_option, 1);
	     if a_option (idx) = "-physical_line_length" | a_option (idx) = "-pll" then do;
		ad.phys_line_length = cv_dec_arg (idx);
		terminal_attach_options = terminal_attach_options || " -pll " || a_option (idx);
	     end;
	     else if a_option (idx) = "-physical_page_length" | a_option (idx) = "-ppl" then do;
		ad.phys_page_length = cv_dec_arg (idx);
		my_options = my_options || " -ppl " || a_option (idx);
	     end;
	     else if a_option (idx) = "-horizontal_tab" | a_option (idx) = "-htab" then do;
		ad.ht = "1"b;
		terminal_attach_options = terminal_attach_options || space || a_option (idx);
	     end;
	     else if a_option (idx) = "-runout_spacing" | a_option (idx) = "-runsp" then do; /* grab this and next arg */
		dummy = get_arg (idx);		/* don't pass on but say we got it */
		my_options = my_options || " -runsp " || dummy;
	     end;
	     else if a_option (idx) = "-terminal" then do;
		ad.terminal = get_arg (idx);
		my_options = my_options || " -terminal " || ad.terminal;
	     end;
	     else if a_option (idx) = "-device" then
		device_opt = get_arg (idx);		/* check out this option */
	     else if a_option (idx) = "-model" then do;
		ad.chars.model = get_arg (idx);
	     end;
	     else terminal_attach_options = terminal_attach_options || space || a_option (idx);
	end;

	if ad.terminal = "" then do;
	     code = error_table_$noarg;
	     call abort_attach (code, "No terminal IO Module specified.", "");
	end;

	if ad.phys_line_length < 1 | ad.phys_line_length > 512 then do;
	     code = error_table_$bad_arg;
	     call abort_attach (code, "Invalid line length specified.", "");
	end;

	if ad.phys_page_length < 10 | ad.phys_page_length > 128 then do;
	     code = error_table_$bad_arg;
	     call abort_attach (code, "Invalid page length specified.", "");
	end;

	if device_opt ^= "printer" then do;		/* was it changed? */
	     code = error_table_$bad_arg;
	     call abort_attach (code, "Invalid -device option: ", (device_opt));
	end;

/* Attach through terminal dim */

	attach_count = attach_count + 1;		/* new attach name tag number each time */
	if attach_count > 999 then
	     attach_count = 1;
	terminal_switch_name = remote_device_name || ltrim (char (attach_count));
						/* make the  switch name */

	terminal_attach_options = ltrim (terminal_attach_options) || " -device " || device_opt;
	terminal_attach_desc = ad.terminal || space || terminal_attach_options;
	ad.attach_desc = remote_device_name || my_options || space || terminal_attach_options;

	call iox_$attach_ioname ((terminal_switch_name), temp_iocbp, (terminal_attach_desc), code);
	if code ^= 0 then
	     call abort_attach (code, "Unable to attach to terminal ", "");

	ad.terminal_iocbp = temp_iocbp;

/* Now mask and complete the iocb */

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);
	iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc);
	iocbp -> iocb.attach_data_ptr = adp;
	iocbp -> iocb.open = remote_printer_open;
	iocbp -> iocb.detach_iocb = remote_printer_detach;
	call iox_$propagate (iocbp);
	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

/* if a model is defined, special processing might be required for some of
   them.  See if there is a special processing module to complete the
   attachment.  If there is, call it and let it fiddle with the iocb */

	if ad.chars.model ^= "" then do;
	     attach_entry_name = "iodd_" || rtrim (ad.chars.model) || "_support_$complete_attach";
	     attach_entry = cv_entry_ (attach_entry_name, null, code);
	     if code ^= 0 then
		call abort_attach (code, "Unable to locate ^a.", (attach_entry_name));
	     call attach_entry (iocbp, code);
	     if code ^= 0 then
		call abort_attach (code, "Calling ^a.", (attach_entry_name));
	end;

	call remote_printer_control_ (iocbp, "reset", null, code);
	if code ^= 0 then
	     call abort_attach (code, "Unable to reset printer data", "");

attach_return:
	return;
%page;

remote_printer_detach:
     entry (a_iocbp, a_code);

	iocbp = a_iocbp;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr ^= null then do;
	     a_code = error_table_$not_closed;
	     return;
	end;

	call clean_up;

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.attach_descrip_ptr = null;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;
%page;

remote_printer_open:
     entry (a_iocbp, a_mode, a_sw, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr ^= null then do;
	     a_code = error_table_$not_closed;
	     return;
	end;

	open_mode = a_mode;
	if ^((open_mode = Stream_output) | (open_mode = Stream_input_output)) then do;
	     a_code = error_table_$bad_mode;
	     return;
	end;

	call iox_$open (ad.terminal_iocbp, Sequential_output, "0"b, a_code);
						/* try for record output */
	if a_code = 0 then do;
	     ad.record_io = "1"b;			/* we have record interface approval */
	     call hcs_$make_ptr (null, "remote_conv_", "printer", ad.cv_proc, a_code);
	     if a_code ^= 0 then
		return;
	end;
	else do;
	     ad.record_io = "0"b;			/* try for stream interface */
	     call iox_$open (ad.terminal_iocbp, Stream_output, "0"b, a_code);
	     if a_code ^= 0 then
		return;
	     call hcs_$make_ptr (null, ad.terminal || "conv_", "printer", ad.cv_proc, a_code);
	     if a_code ^= 0 then
		return;
	end;

	ad.open_description = rtrim (iox_modes (open_mode));
	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.put_chars = remote_printer_put_chars;
	iocbp -> iocb.control = remote_printer_control;
	iocbp -> iocb.modes = remote_printer_modes;
	iocbp -> iocb.position = remote_printer_position;
	iocbp -> iocb.close = remote_printer_close;
	iocbp -> iocb.open_descrip_ptr = addr (ad.open_description);

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;
%page;

remote_printer_close:
     entry (a_iocbp, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	call iox_$close (ad.terminal_iocbp, a_code);
	if a_code = error_table_$not_open | a_code = error_table_$not_attached then
	     a_code = 0;

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.open_descrip_ptr = null;
	iocbp -> iocb.open = remote_printer_open;
	iocbp -> iocb.detach_iocb = remote_printer_detach;
	iocbp -> iocb.control = iox_$err_no_operation;
	iocbp -> iocb.position = iox_$err_no_operation;
	iocbp -> iocb.modes = iox_$err_no_operation;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;
%page;

remote_printer_put_chars:
     entry (a_iocbp, a_data_ptr, a_data_chars, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	if a_data_chars < 0 | a_data_chars > sys_info$max_seg_size * 4 then do;
	     a_code = error_table_$bad_arg;
	     return;
	end;

	total_chars, remaining_chars = a_data_chars;	/* remaining_chars is decremented as data is sent */
	charp = a_data_ptr;				/* charp is bumped by prt_conv_ as data is sent */

	terminal_io_record_ptr = null ();		/* for the cleanup handler */

	call iox_$control (ad.terminal_iocbp, "select_device", addr (printer_device), code);
						/* HACK FOR THE ibm2780_ TERMINAL DIM */
	if code ^= 0 then
	     go to put_chars_ret;

	pcip = addr (ad.remote_pci);			/* ready for the prt_conv_ hack.  We must force a write of
						   all trailing NL chars, even though they have already been
						   accounted for in the remaining chars. */

	terminal_io_record_element_size = 9;		/* always character data */
	terminal_io_record_n_elements = 3 * ad.phys_line_length;
						/* enough room for 1 printing character and 2 non-printing
						   characters per column (eg: DC1-u X) */

	on cleanup
	     begin;
	     if terminal_io_record_ptr ^= null () then
		free terminal_io_record_ptr -> terminal_io_record in (my_area);
	end;

	call alloc_tio_rec;				/* allocate and initialize the terminal_io_record */

	if ad.record_io then
	     prt_conv_outp = terminal_io_record_ptr;	/* full record for record interface */
	else prt_conv_outp = addr (terminal_io_record.data);
						/* use the string for stream interface */

	do while (remaining_chars > 0 | pci.slew_residue > 0);
						/* so keep trying while there is anything to slew */
	     cur_page = pci.page_count;		/* save the page number */

/* ********************************************************************
   *  Call prt_conv_ or not, depending on the value of the static	*
   *  switch prt_conv_on.					*
   ******************************************************************** */

	     if prt_conv_on then
		call prt_conv_ (charp, remaining_chars, prt_conv_outp, record_len, pcip);
	     else do;
		prt_conv_outp = charp;
		record_len = remaining_chars;
		remaining_chars = 0;
	     end;

	     if ^ad.noprint then do;			/* if actually printing, send to the terminal */
		if ad.record_io & prt_conv_on then do;
		     call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr,
			4 * currentsize (terminal_io_record), code);
		end;
		else do;				/* stream output */
		     call iox_$put_chars (ad.terminal_iocbp, prt_conv_outp, record_len, code);
		end;
		if code ^= 0 then
		     go to put_chars_ret;		/* trouble */
	     end;

	     if cur_page ^= ad.page_count then do;	/* did we turn another page? */
		ad.stop_counter = ad.stop_counter + 1;	/* bump the page stop counter */
		if ad.single_page | (ad.stop_every ^= 0 & ad.stop_counter >= ad.stop_every) then do;
		     ad.stop_counter = 0;
		     code = error_table_$request_pending;
						/* say we were not done yet */
		     go to put_chars_ret;		/* exit the loop and return to caller */
		end;
	     end;
	end;

put_chars_ret:
	if terminal_io_record_ptr ^= null () then
	     free terminal_io_record_ptr -> terminal_io_record in (my_area);

	ad.chars_printed = ad.chars_printed + total_chars - remaining_chars;
						/* record our progress */

	a_code = code;

	return;
%page;

remote_printer_control:
     entry (a_iocbp, a_order, a_infop, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	infop = a_infop;
	order = a_order;
	code, a_code = 0;

	if order = "io_call" then do;
	     if a_infop = null then do;
		a_code = error_table_$bad_arg;
		return;
	     end;
	     order = infop -> io_call_info.order_name;
	     infop = null;
	end;

/* check for prt_conv_on/prt_conv_off orders and handle them
   directly without calling remote_printer_control_. */

	if order = "prt_conv_on" | order = "prt_conv_off" then do;
	     prt_conv_on = order = "prt_conv_on";
	     return;
	end;

	call remote_printer_control_ (iocbp, order, infop, code);
	if code ^= 0 then do;			/* if not done or partially completed, pass it on */
	     call iox_$control (ad.terminal_iocbp, order, infop, ec);
	     if ec = 0 then
		code = 0;				/* let the code from remote_printer_control preveil */
	end;

	if order = "reset" then do;
	     call iox_$control (ad.terminal_iocbp, order, infop, ignore);
	     prt_conv_on = "1"b;
	end;
	a_code = code;

	return;
%page;

remote_printer_modes:
     entry (a_iocbp, a_new_modes, a_old_modes, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	code, a_code = 0;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	call remote_printer_modes_ (iocbp, a_new_modes, a_old_modes, a_code);

	if a_new_modes = "default" then do;
	     call iox_$modes (ad.terminal_iocbp, a_new_modes, "", ignore);
	end;
	else if index (a_new_modes, "non_edited") ^= 0 then do;
	     i = index (a_new_modes, "non_edited");
	     if i = 1 then
		call iox_$modes (ad.terminal_iocbp, "non_edited", "", ignore);
	     else if substr (a_new_modes, i - 1, 1) = "^" then
		call iox_$modes (ad.terminal_iocbp, "default", "", ignore);
	     else call iox_$modes (ad.terminal_iocbp, "non_edited", "", ignore);
	end;
	else if index (a_new_modes, "rawo") ^= 0 then do;
	     i = index (a_new_modes, "rawo");
	     if i = 1 then
		call iox_$modes (ad.terminal_iocbp, "rawo", "", ignore);
	     else if substr (a_new_modes, i - 1, 1) = "^" then
		call iox_$modes (ad.terminal_iocbp, "^rawo", "", ignore);
	     else call iox_$modes (ad.terminal_iocbp, "rawo", "", ignore);
	end;

	return;
%page;

remote_printer_position:
     entry (a_iocbp, a_pos_type, a_pos_value, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	code, a_code = 0;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

	call iox_$position (ad.terminal_iocbp, a_pos_type, a_pos_value, a_code);

	return;






flip_com_err_sw:
     entry;

	static_comerr_sw = ^static_comerr_sw;		/* flip the bit */

	call ioa_ ("The printer com err sw is now: ^[on^;off^]", static_comerr_sw);

	return;
%page;

get_arg:
     procedure (idx) returns (character (*));

dcl  idx fixed bin;

	idx = idx + 1;				/* advance the arg index of the main loop */
	if idx > hbound (a_option, 1) then do;
	     code = error_table_$noarg;
	     call abort_attach (code, "No argument after ^a.", (a_option (idx - 1)));
	end;

	return (a_option (idx));

     end get_arg;



cv_dec_arg:
     procedure (idx) returns (fixed binary);

dcl  idx fixed bin;

	idx = idx + 1;				/* advance the arg index of the main loop */
	if idx > hbound (a_option, 1) then do;
	     code = error_table_$noarg;
	     call abort_attach (code, "No argument after ^a.", (a_option (idx - 1)));
	end;

	on conversion go to bad_dec_arg;

	return (bin (a_option (idx)));

bad_dec_arg:
	code = error_table_$bad_conversion;
	call abort_attach (code, "Invalid decimal number. ^a", (a_option (idx)));

     end cv_dec_arg;



abort_attach:
     procedure (code, str1, str2);

dcl  code fixed bin (35);
dcl  (str1, str2) char (*) aligned;

/* This proc handles attach errors */

	if com_err_sw then
	     call com_err_ (code, remote_device_name, str1, str2);

	a_code = code;

	call clean_up;

	go to attach_return;			/* abort the attach by non-local go to */

     end abort_attach;
%page;

alloc_tio_rec:
     procedure ();

	allocate terminal_io_record in (my_area) set (terminal_io_record_ptr);

	unspec (terminal_io_record) = "0"b;		/* clear everything */

	terminal_io_record.version = terminal_io_record_version_1;
						/* our view of the record structure */
	terminal_io_record.device_type = ad.device_type;
	terminal_io_record.element_size = terminal_io_record_element_size;
						/* set by our caller */

	return;

     end alloc_tio_rec;



clean_up:
     procedure ();

/* this is for any form of abort during attachment */

	if adp ^= null then do;
	     if ad.terminal_iocbp ^= null then
		call iox_$detach_iocb (ad.terminal_iocbp, ignore);
	     free adp -> ad in (my_area);
	     adp = null;
	end;

	iocbp -> iocb.attach_descrip_ptr = null;	/* be sure iox_ knows */
	iocbp -> iocb.attach_data_ptr = null;
	iocbp -> iocb.open = iox_$err_no_operation;

	return;

     end clean_up;


handler:
     procedure ();

dcl  ignore fixed bin (35);

/* This proc handles faults that occur while masked */

	if mask then
	     call hcs_$reset_ips_mask (mask, mask);

	mask = ""b;

	call continue_to_signal_ (ignore);

	return;

     end handler;
%page; %include io_call_info;
%page; %include iocb;
%page; %include iox_modes;
%page; %include prt_conv_info;
%page; %include prt_info;
%page; %include remote_attach_data;
%page; %include terminal_io_record;

     end remote_printer_;




		    remote_punch_.pl1               01/19/88  1428.9rew 01/19/88  1330.0      261630



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

remote_punch_: proc;

/* remote_punch_: An I/O module for communicating with a remote punch or its equivilent. */

/* Coded March 1977 by David Vinograd */
/* Modified for user TTFs and cleaned up May 1978 by D. Vinograd */
/* Modified by J. C. Whitmore, 11/78, to make the attach options consistent among all remote_xxx_ dims */
/* Modified by J. C. Whitmore, 10/79, to support binary_punch mode (control order) */
/* Modified by J. C. Whitmore,  2/80, to do full record IO to terminal dim */


/****^  HISTORY COMMENTS:
  1) change(87-11-23,Beattie), approve(87-12-21,MCR7821),
     audit(88-01-13,Brunelle), install(88-01-19,MR12.2-1014):
     Prevent splitting of card images that span component boundaries
     of MSFs. (phx21014)
                                                   END HISTORY COMMENTS */


/* format: style4 */

/* Parameters */

dcl  a_iocbp ptr parameter;
dcl  a_option (*) char (*) var parameter;		/* Options for attach */
dcl  a_sw bit (1) parameter;				/* com_err_ switch for attach */
dcl  a_code fixed bin (35) parameter;
dcl  a_mode fixed bin parameter;			/* The open mode */
dcl  a_data_ptr ptr parameter;
dcl  a_data_count fixed bin (24) parameter;
dcl  a_pos_type fixed bin parameter;
dcl  a_pos_value fixed bin (24) parameter;
dcl  a_order char (*) parameter;
dcl  a_infop ptr parameter;
dcl  old_modes char (*) parameter;
dcl  new_modes char (*) parameter;

/* Attach entry point */

remote_punch_attach: entry (a_iocbp, a_option, a_sw, a_code);

	iocbp = a_iocbp;
	com_err_sw = a_sw | static_com_err_sw;
	code, a_code = 0;

	adp = null;
	if iocbp -> iocb.attach_descrip_ptr ^= null then do;
	     code = error_table_$not_detached;
	     call abort_attach (code, "Switch name: ^a", iocbp -> iocb.name);
	end;

	if areap = null then do;			/* first time called, make attach area */
	     call get_temp_segment_ (remote_device_name, areap, code); /* Temp segment for attach data area */
	     if code ^= 0 then call abort_attach (code, "Unable to allocate temp segment.", "");
	     areap -> my_area = empty ();		/* initialize the area */
	end;

	on cleanup call clean_up_handler;		/* be sure to free attach data on abort */

	allocate ad in (my_area) set (adp);		/* create the attach data for this switch */

/* Initialize attach data variables */

	ad.bits = "0"b;
	ad.fixed = 0;
	ad.ptrs = null;
	ad.chars = "";
	ad.edited = "1"b;				/* always default to the edited mode */
	ad.stream_output = "1"b;			/* use the stream interface until records are fully defined */
	ad.card_ll = 80;				/* default number of columns per card */
	ad.device_type = PUNCH_DEVICE;		/* default to output to a punch device */

/* Process attach options */

	if hbound (a_option, 1) < 1 then do;		/* Must be at least one */
	     code = error_table_$wrong_no_of_args;
	     call abort_attach (code, "Bad attach description.", "");
	end;

	terminal_attach_options = "";
	my_options = "";
	terminal_attach_desc = "";
	terminal_attach_name = "";

	device_type = "";				/* mark as no -device option given */

	on conversion begin;
	     code = error_table_$bad_arg;
	     call abort_attach (code, "Attach option conversion error.", "");
	end;

	do idx = 1 to hbound (a_option, 1);
	     if a_option (idx) = "-runout_spacing" | a_option (idx) = "-runsp" then do; /* skip it and next option */
		dummy = get_arg (idx);
		my_options = my_options || " -runsp " || dummy;
	     end;
	     else if a_option (idx) = "-htab" | a_option (idx) = "-horizontal_tab" then do;
		ad.htab = "1"b;			/* allow tabs to be sent to remote */
		my_options = my_options || " -htab";
	     end;
	     else if a_option (idx) = "-non_edited" then do;
		ad.edited = "0"b;			/* allow ctl chars to be sent to remote */
		my_options = my_options || " -non_edited";
	     end;
	     else if a_option (idx) = "-card_ll" then do;
		dummy = get_arg (idx);
		my_options = my_options || " -card_ll " || dummy;
		ad.card_ll = convert (ad.card_ll, dummy); /* get it into fixed bin form */
	     end;
	     else if a_option (idx) = "-physical_page_length" | a_option (idx) = "-ppl" then do; /* absorb this too */
		dummy = get_arg (idx);
		my_options = my_options || " -ppl " || dummy;
	     end;
	     else if a_option (idx) = "-device" then do;
		device_type = get_arg (idx);		/* record this */
		my_options = my_options || " -device " || rtrim (device_type);
	     end;
	     else if a_option (idx) = "-terminal" then
		ad.terminal = get_arg (idx);
	     else terminal_attach_options = terminal_attach_options || space || a_option (idx);
	end;

/* Attach through terminal dim */

	if ad.terminal = "" then do;			/* must specify the next level */
	     code = error_table_$badopt;
	     call abort_attach (code, "Missing option -terminal.", "");
	end;

	if device_type = "" then device_type = "punch";	/* choose the default if not specified */
	else do;					/* otherwise check it out more ... */
	     if device_type = "reader_simulator" then do;
		device_type = "reader";		/* we are to simulate the reader of a workstation */
		ad.device_type = READER_DEVICE;
	     end;
	     else if device_type ^= "punch" then do;	/* the only other one we will accept */
		code = error_table_$bad_arg;
		call abort_attach (code, "Invalid -device option: ^a", (device_type));
	     end;
	end;

	if ad.card_ll < 1 | ad.card_ll > 160 then do;	/* validate the line length */
	     code = error_table_$bad_arg;
	     call abort_attach (code, "Invalid card line length", "");
	end;

	attach_count = attach_count + 1;		/* new attach name each time */
	if attach_count > 999 then attach_count = 1;
	terminal_attach_name = remote_device_name || ltrim (character (attach_count));

	ad.attach_desc = remote_device_name || " -terminal " || ad.terminal ||
	     terminal_attach_options || my_options;
	terminal_attach_desc = ad.terminal || terminal_attach_options || " -device " || rtrim (device_type);

	call iox_$attach_ioname ((terminal_attach_name), ad.terminal_iocbp, (terminal_attach_desc), code);
	if code ^= 0 then call abort_attach (code, "Unable to attach to terminal ", "");

/* Now mask and complete the iocb */

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc);
	iocbp -> iocb.open_descrip_ptr = null;
	iocbp -> iocb.attach_data_ptr = adp;
	iocbp -> iocb.open = remote_punch_open;
	iocbp -> iocb.detach_iocb = remote_punch_detach;

	call iox_$propagate (iocbp);

	revert cleanup;				/* we are now comitted; require a detach */

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

attach_return:

	a_code = code;

	return;

/* Detach entry point */

remote_punch_detach: entry (a_iocbp, a_code);

	iocbp = a_iocbp;
	a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr ^= null then do;
	     a_code = error_table_$not_closed;
	     return;
	end;

/*	First, kill the switch defination known by iox_ */

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.attach_descrip_ptr = null;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

/*	Now kill the terminal IO switch.  If this fails, there isn't anything we can do about it.  */
/*	So, ignore any errors ... we tried at least. */

	call iox_$detach_iocb (ad.terminal_iocbp, ignore);

	if ad.stat_term_rec_ptr ^= null then do;
	     free ad.stat_term_rec_ptr -> terminal_io_record in (my_area);
	     ad.stat_term_rec_ptr = null;
	end;

	free adp -> ad in (my_area);

	adp = null;

	return;

/* Open entry point */

remote_punch_open: entry (a_iocbp, a_mode, a_sw, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr ^= null then do;
	     a_code = error_table_$not_closed;
	     return;
	end;

	open_mode = a_mode;
	if ^((open_mode = Stream_output) | (open_mode = Stream_input_output)) then do;
	     a_code = error_table_$bad_mode;
	     return;
	end;

	call iox_$open (ad.terminal_iocbp, Sequential_output, "0"b, a_code); /* try for record interface first */
	if a_code = 0 then ad.stream_output = "0"b;	/* we have it, so use it */
	else do;
	     ad.stream_output = "1"b;			/* this is all that's left if it works */
	     call iox_$open (ad.terminal_iocbp, Stream_output, "0"b, a_code);
	     if a_code ^= 0 then return;		/* too bad, abort the open */
	end;

	ad.open_description = rtrim (iox_modes (open_mode));

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.put_chars = write_elements;
	iocbp -> iocb.get_chars = iox_$err_no_operation;
	iocbp -> iocb.get_line = iox_$err_no_operation;
	iocbp -> iocb.control = remote_punch_control;
	iocbp -> iocb.modes = remote_punch_modes;
	iocbp -> iocb.position = remote_punch_position;
	iocbp -> iocb.close = remote_punch_close;
	iocbp -> iocb.open_descrip_ptr = addr (ad.open_description);

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	return;

/* Close entry point */

remote_punch_close: entry (a_iocbp, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do;
	     a_code = error_table_$not_open;
	     return;
	end;

/*	Try to close the terminal IO switch.  If it fails, there isn't anything we can do about it. */
/*	So just ignore the error code.  Our switch will be closed successfully. */

	call iox_$close (ad.terminal_iocbp, ignore);

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.open_descrip_ptr = null;
	iocbp -> iocb.open = remote_punch_open;
	iocbp -> iocb.detach_iocb = remote_punch_detach;
	iocbp -> iocb.control = iox_$err_no_operation;
	iocbp -> iocb.position = iox_$err_no_operation;
	iocbp -> iocb.modes = iox_$err_no_operation;
	iocbp -> iocb.put_chars = iox_$err_no_operation;
	iocbp -> iocb.get_chars = iox_$err_no_operation;
	iocbp -> iocb.get_line = iox_$err_no_operation;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	return;

/* Put_chars entry point */

write_elements: entry (a_iocbp, a_data_ptr, a_data_count, a_code);

/* This entry takes data defined by the data ptr and the data length count as stream input and breaks
   the data into card image records for the terminal IO module.  Both character and binary card images
   are supported by remote_punch_.  This module can be called for each component of an MSF and card
   images will not be broken.  The "runout" control order flushes the last card if present in the
   output buffer. */

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if ad.binary then max_size = BITS_PER_SEGMENT;	/* max bit count */
	else max_size = CHARS_PER_SEGMENT;		/* max char count */

	if a_data_count < 0 | a_data_count > max_size then do;
	     a_code = error_table_$bad_arg;
	     return;
	end;

	call iox_$control (ad.terminal_iocbp, "select_device", addr (punch_device), code);
	if code ^= 0 then go to put_chars_ret;

	remaining_count = a_data_count;		/* This is decremented as data is sent */
	wp = a_data_ptr;				/* set local pointer to callers workspace */
	in_pos = 1;				/* start with the first input element */

	if ad.binary then do;			/* for binary punch output */
	     if ad.stat_term_rec_ptr = null then do;	/* if we haven't already done this */
		terminal_io_record_element_size = 1;	/* setup for allocation of output record */
		terminal_io_record_n_elements = 960;	/* max record length of 960 bits in binary mode */
		call allocate_tio_rec;		/* make an output record block */
		terminal_io_record.binary = "1"b;	/* mark this as a binary record */
	     end;
	     else terminal_io_record_ptr = ad.stat_term_rec_ptr;

	     do while (remaining_count > 0);

		if ad.rec_len > 0 then do;		/* there is data here from last call */
		     data_len = min (960 - ad.rec_len, remaining_count);
		     substr (terminal_io_record_data_bits, ad.rec_len + 1) = substr (wp -> bit_string, in_pos, data_len);
		     ad.rec_len = ad.rec_len + data_len;
		     if ad.rec_len < 960 then go to put_chars_ret;
		     call send_binary;
		     in_pos = in_pos + data_len;
		     remaining_count = remaining_count - data_len;
		end;				/* data here from last call */

		else do;
		     ad.rec_len = min (960, remaining_count); /* records are 1 to 960 bits long */
		     terminal_io_record_data_bits = substr (wp -> bit_string, in_pos, ad.rec_len);
						/* define the record and pad with zeros */
		     if ad.rec_len < 960 then go to put_chars_ret;
						/* there may be mor in a later call */

		     call send_binary;
		     in_pos = in_pos + ad.rec_len;	/* bump the workspace index */
		     remaining_count = remaining_count - ad.rec_len; /* and decrement the remainder count */
		end;				/* no data in buffer from previous call */
	     end;					/* while data to send */
	end;					/* if binary to send */

	else do;					/* for character output */
	     if ad.stat_term_rec_ptr = null then do;	/* done only once per file */
		terminal_io_record_element_size = 9;	/* 9 bits per character in the record */
		terminal_io_record_n_elements = ad.card_ll; /* max record size */
		call allocate_tio_rec;		/* make an output record block */
		residue = 0;			/* space residue from HT processing */
		ad.tab_idx = 1;			/* virtual carriage position for tab calc */
	     end;
	     else terminal_io_record_ptr = ad.stat_term_rec_ptr;

	     if ad.out_pos > 1 then go to next_char;	/* we already have some data in output record */

	     do while (remaining_count > 0);
		terminal_io_record.n_elements = ad.card_ll; /* reset to max length each time */
		terminal_io_record_data_chars = "";	/* clear the card image, we need spaces for tab padding */
		ad.out_pos = 1;			/* build card image starting in col 1 */
		if residue > 0 then do;
		     ad.out_pos = ad.out_pos + residue; /* move over extra spaces */
		     residue = 0;			/* reset the space residue */
		end;


next_char:	if remaining_count <= 0 then go to put_chars_ret;
						/* if done with input due to editing, just stop */
						/* may get more */
		char = substr (wp -> char_string, in_pos, 1); /* pickup next character */

		in_pos = in_pos + 1;		/* bump the index */
		remaining_count = remaining_count - 1;	/* and decrement the remainder */

		if rank (char) < rank (" ") then do;	/* look for control chars */
		     if char = CR | char = NL | char = VT | char = FF then do; /* card terminators */
			ad.tab_idx = 1;		/* reset the virtual carriage */
			go to send;		/* send off the card */
		     end;
		     if char = HT then do;		/* for tabs, put out spaces, let terminal compress */
			if ^ad.htab then do;	/* if not sending the tab char, pad it out */
			     tab_stop = divide (ad.tab_idx + 9, 10, 0) * 10 + 1; /* 11, 21, 31,  ... */
			     count = tab_stop - ad.tab_idx; /* spaces we are to move */
			     ad.tab_idx = tab_stop;	/* move the virtual carriage to new stop */
			     if ad.out_pos + count > ad.card_ll then do; /* fold spaces? */
				residue = (ad.out_pos - 1) + count - ad.card_ll; /* save the extra for later */
				go to send;	/* and send off this card image */
			     end;
			     ad.out_pos = ad.out_pos + count; /* just step over spaces already there */
			     go to next_char;	/* and go on to the next character */
			end;
		     end;
		     else if ad.edited then go to next_char;
						/* edit out back space and ctl chars not handled */
		end;				/* if control character */
		else if rank (char) > rank ("~") then go to next_char; /* drop all above 176 octal */

		substr (terminal_io_record_data_chars, ad.out_pos, 1) = char; /* put the char into the output record */

		ad.out_pos = ad.out_pos + 1;		/* that position is used up */
		ad.tab_idx = ad.tab_idx + 1;		/* also move the virtual carriage */
		if ad.out_pos <= ad.card_ll then go to next_char; /* fill up the card through col ad.card_ll */
		else if remaining_count > 0 then do;	/* check for terminating char if more input */
		     char = substr (wp -> char_string, in_pos, 1); /* get the next char */
		     if char = CR | char = NL | char = VT | char = FF then do;
			remaining_count = remaining_count - 1; /* skip over the terminator */
			in_pos = in_pos + 1;
		     end;
		end;
send:
		call send_chars;
	     end;					/* start a new card image */
	end;					/* character output */

put_chars_ret:
	a_code = code;

	return;

/* Control entry point */

remote_punch_control: entry (a_iocbp, a_order, a_infop, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     code = error_table_$not_attached;
	     return;
	end;

	infop = a_infop;
	order = a_order;
	code, a_code = 0;

	if order = "reset" then do;
	     ad.records_sent = 0;			/* reset the accounting data */
	     ad.binary = "0"b;			/* back to the default of character output */
	     ad.rec_len, ad.out_pos = 0;		/* forget any held output */
	     if ad.stat_term_rec_ptr ^= null then do;
		free ad.stat_term_rec_ptr -> terminal_io_record in (my_area);
		ad.stat_term_rec_ptr = null;
	     end;
	     go to pass_it_on;			/* let it go to the terminal also */
	end;
	else if order = "binary_punch" then do;
						/* cannot allow ad.binary to change during an IO */
	     if ad.binary & ad.rec_len > 0 then go to noop_error;
	     else if ad.out_pos > 1 then go to noop_error;

	     call iox_$control (ad.terminal_iocbp, order, infop, code); /* see if terminal can do it */
	     if code = 0 then ad.binary = "1"b;		/* set binary mode only if terminal agrees on binary */
	     else ad.binary = "0"b;			/* otherwise, keep character mode */
	end;
	else if order = "get_count" then do;		/* give the accounting data */
	     if infop ^= null then do;
		infop -> counts.line_count = ad.records_sent; /* use the line count as card count */
		infop -> counts.page_count = 0;	/* not valid data for a punch */
	     end;
	     else

noop_error:
		code = error_table_$no_operation;
	end;
	else if order = "runout" then do;
	     if ad.binary & ad.rec_len > 0 then call send_binary;
	     else if ad.out_pos > 1 then call send_chars;
	     if ad.stat_term_rec_ptr ^= null then do;
		free ad.stat_term_rec_ptr -> terminal_io_record in (my_area);
		ad.stat_term_rec_ptr = null;
	     end;
	     go to pass_it_on;
	end;
	else do;
pass_it_on:
	     call iox_$control (ad.terminal_iocbp, order, infop, code);
	end;

	a_code = code;

	return;

/* Modes entry point */

remote_punch_modes: entry (a_iocbp, new_modes, old_modes, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	a_code = 0;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	call iox_$modes (ad.terminal_iocbp, new_modes, old_modes, a_code);

	return;

/* Position entry point */

remote_punch_position: entry (a_iocbp, a_pos_type, a_pos_value, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	a_code = 0;

	call iox_$position (ad.terminal_iocbp, a_pos_type, a_pos_value, a_code);

	return;





flip_com_err_sw: entry;				/* entry to flip the com_err_sw */


	static_com_err_sw = ^static_com_err_sw;		/* that's it */

	return;

get_arg: proc (idx) returns (char (*));

dcl  idx fixed bin;

	idx = idx + 1;				/* advance the option index to the option arg */
	if idx > hbound (a_option, 1) then do;		/* check the range */
	     code = error_table_$noarg;
	     call abort_attach (code, "No argument after ^a.", (a_option (idx - 1)));
	end;
	return (a_option (idx));

     end get_arg;




abort_attach: proc (code, str1, str2);

dcl  (str1, str2) char (*) aligned;
dcl  code fixed bin (35);

/* This proc handles attach errors */

	if com_err_sw then call com_err_ (code, remote_device_name, str1, str2);

	call clean_up_handler;

	go to attach_return;

     end abort_attach;

clean_up_handler: proc;

	if adp ^= null then do;
	     if ad.terminal_iocbp ^= null then call iox_$detach_iocb (ad.terminal_iocbp, ignore);
	     free adp -> ad in (my_area);
	     if ad.stat_term_rec_ptr ^= null then do;
		free ad.stat_term_rec_ptr -> terminal_io_record in (my_area);
		ad.stat_term_rec_ptr = null;
	     end;
	     adp = null;
	end;

	return;

     end clean_up_handler;


handler: proc;

/* This proc handles faults that occur while masked */

	if mask then call hcs_$reset_ips_mask (mask, mask);

	mask = "0"b;

	call continue_to_signal_ (ignore);

	return;

     end handler;



allocate_tio_rec: proc;

	allocate terminal_io_record in (my_area) set (ad.stat_term_rec_ptr);
	terminal_io_record_ptr = ad.stat_term_rec_ptr;

	unspec (terminal_io_record) = "0"b;		/* clear any garbage */

	terminal_io_record.version = terminal_io_record_version_1; /* announce our view of the record structure */
	terminal_io_record.device_type = ad.device_type;	/* inform the terminal dim if we are a reader or punch */
	terminal_io_record.element_size = terminal_io_record_element_size; /* set by our caller */
	terminal_io_record.n_elements = terminal_io_record_n_elements;

	return;

     end allocate_tio_rec;

send_binary: proc;

	terminal_io_record.n_elements = ad.rec_len;	/* set the data record size */

	if ad.stream_output then			/* for the stream interface to the terminal */
	     call iox_$put_chars (ad.terminal_iocbp, addr (terminal_io_record.bits), ad.rec_len, code);
	else do;
	     call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr,
		4 * currentsize (terminal_io_record), code);
	end;
	if code ^= 0 then go to put_chars_ret;

	ad.records_sent = ad.records_sent + 1;		/* account for all records we send */
	ad.rec_len = 0;				/* not holding any data */

     end send_binary;




send_chars: proc;

	terminal_io_record.n_elements = ad.out_pos - 1;	/* define the final length of this record */
	if ad.stream_output then
	     call iox_$put_chars (ad.terminal_iocbp, addr (terminal_io_record.bits), ad.out_pos - 1, code);
	else call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr,
		4 * currentsize (terminal_io_record), code);
	if code ^= 0 then go to put_chars_ret;
	ad.records_sent = ad.records_sent + 1;		/* for the accounting, only count successful writes */
	ad.out_pos = 1;				/* start in column 1 */

     end send_chars;

/* Automatic */

dcl  code fixed bin (35);
dcl  com_err_sw bit (1);				/* Set if com_err_ sould be called on attach error */
dcl  count fixed bin;				/* number of spaces to move to tab stop */
dcl  device_type char (32);				/* temp for value of the -device att opt */
dcl  dummy char (32) var;
dcl  idx fixed bin;					/* index variable for do loops */
dcl  ignore fixed bin (35);
dcl  in_pos fixed bin (24);				/* index of next element in callers data */
dcl  infop ptr;
dcl  iocbp ptr;
dcl  mask bit (36) aligned;				/* For setting ips mask */
dcl  max_size fixed bin (24); dcl char char (1);		/* test char for editing output */
dcl  my_options char (64) var;			/* this should be small */
dcl  open_mode fixed bin;
dcl  order char (32);
dcl  data_len fixed bin;				/* length of data to fill out current output record */
dcl  remaining_count fixed bin (24);			/* number of data elements to be punched */
dcl  residue fixed bin;				/* spaces to be added to next card image */
dcl  tab_stop fixed bin;				/* next tab stop for tab calculations */
dcl  terminal_attach_desc char (256) var;
dcl  terminal_attach_name char (32) var;
dcl  terminal_attach_options char (256) var;
dcl  wp ptr;					/* input data workspace pointer */

/* Internal Static	*/

dcl  attach_count fixed bin int static init (0);
dcl  areap ptr int static init (null);
dcl  static_com_err_sw bit (1) int static init ("0"b);	/* for testing attach options */

/* Based variables */

dcl  my_area area (WORDS_PER_SEGMENT) based (areap);

dcl  bit_string bit (BITS_PER_SEGMENT) based;		/* input data for binary punching */
dcl  char_string char (CHARS_PER_SEGMENT) based;		/* input data for character punching */

/* Constants */

dcl  remote_device_name char (13) int static options (constant) init ("remote_punch_");
dcl  punch_device char (32) int static options (constant) init ("punch");
dcl  space char (1) static init (" ") int options (constant);
dcl  HT char (1) int static options (constant) init ("	");
dcl  NL char (1) int static options (constant) init ("
");
dcl  CR char (1) int static options (constant) init ("");
dcl  VT char (1) int static options (constant) init ("");
dcl  FF char (1) int static options (constant) init ("");

/* External stuff */

dcl  continue_to_signal_ entry (fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  com_err_ entry options (variable);
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$propagate entry (ptr);
dcl  iox_$position entry (ptr, fixed bin, fixed bin (24), fixed bin (35));
dcl  iox_$err_no_operation entry;

dcl  error_table_$bad_arg ext fixed bin (35);
dcl  error_table_$bad_mode ext fixed bin (35);
dcl  error_table_$not_attached ext fixed bin (35);
dcl  error_table_$not_open ext fixed bin (35);
dcl  error_table_$not_closed ext fixed bin (35);
dcl  error_table_$not_detached ext fixed bin (35);
dcl  error_table_$wrong_no_of_args ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);
dcl  error_table_$no_operation ext fixed bin (35);


/* Conditions and Builtins */

dcl  (addr, character, convert, currentsize, divide, empty, hbound, ltrim, min, null, rank, rtrim, substr, unspec) builtin;

dcl  (any_other, cleanup, conversion) condition;

dcl  adp ptr;

dcl  1 ad aligned based (adp),
       2 fixed,
         3 device_type fixed bin,			/* one of the codes defined in terminal_io_record.incl.pl1 */
         3 records_sent fixed bin,			/* for accounting, card images sent */
         3 card_ll fixed bin,				/* number of columns per card starting in col 1 */
         3 out_pos fixed bin,				/* next available output buffer element index */
         3 rec_len fixed bin,				/* length of bits in record */
         3 tab_idx fixed bin,				/* virtual carriage position for tab calculations */
       2 bits,
         3 binary bit (1) unal,			/* TRUE when in binary punch mode */
         3 edited bit (1) unal,			/* TRUE when character editing is to be done */
         3 htab bit (1) unal,				/* TRUE when HT chars are allowed to be sent */
         3 stream_output bit (1) unal,			/* TRUE if stream interface to terminal is needed */
       2 ptrs,
         3 terminal_iocbp ptr,			/* iocbp for terminal dim of this attachment */
         3 stat_term_rec_ptr ptr,			/* pointer to data record */
       2 chars,
         3 terminal char (32) var,			/* name of the terminal dim */
         3 attach_desc char (256) var,			/* attach description of this attachment */
         3 open_description char (24) var;		/* open desc for this attachment */

dcl  1 counts aligned based (infop),			/* accounting data for caller */
       2 line fixed bin,				/* for printers */
       2 page_len fixed bin,				/*     "        */
       2 lmarg fixed bin,				/*     "         */
       2 rmarg fixed bin,				/*     "        */
       2 line_count fixed bin,			/* this is the relavent information */
       2 page_count fixed bin;			/* this could be used, set to zero */

%include terminal_io_record;

%include iocb;

%include iox_modes;

%include system_constants;

     end remote_punch_;




		    remote_teleprinter_.pl1         10/28/88  1405.8r w 10/28/88  1257.9      249399



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1988                *
        *                                                         *
        * 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 */

/* format: off */

/* remote_teleprinter_: An I/O module for communicating with the operator console function of a remote device. */

/* Created:  March 1977 by David Vinograd */
/* Modified: May 1978 by David Vinograd for user TTFs */
/* Modified: November 1978 by J. C. Whitmore to make the attach options consistent among all remote_xxx_ dims */
/* Modified: March 1979 by J. C. Whitmore to initialize so get_line function returns a NL char and cleanup returned modes */
/* Modified: March 1980 by J. C. Whitmore to use the terminal_io_record interface to the terminal IO module */
/* Modified: 13 December 1981 by G. Palter to not use illegal PL/I and provide sufficient extra space for prt_conv_ to
      output control sequences */


/****^  HISTORY COMMENTS:
  1) change(87-05-10,Gilcrease), approve(87-05-13,MCR7686),
     audit(88-02-01,Farley), install(88-02-02,MR12.2-1019):
     Corrected pl1 warning about terminal_io_record_data_chars_varying_max_len
     being referenced, but never set.
                                                   END HISTORY COMMENTS */


/* format: on */


remote_teleprinter_:
     procedure ();


/* Parameters */

dcl  a_iocbp ptr parameter;
dcl  a_option (*) char (*) var parameter;		/* Options for attach */
dcl  a_sw bit (1) parameter;				/* com_err_ switch for attach */
dcl  a_code fixed bin (35) parameter;
dcl  a_mode fixed bin parameter;			/* The open mode */
dcl  a_buf_ptr ptr parameter;
dcl  a_data_ptr ptr parameter;
dcl  a_buf_chars fixed bin (21) parameter;
dcl  a_data_chars fixed bin (21) parameter;
dcl  a_pos_type fixed bin parameter;
dcl  a_pos_value fixed bin (21) parameter;
dcl  a_order char (*) parameter;
dcl  a_infop ptr parameter;
dcl  a_old_modes char (*) parameter;
dcl  a_new_modes char (*) parameter;


/* Automatic */

dcl  (prt_modes, card_modes) char (160);
dcl  last_char char (1);
dcl  last_pos fixed bin;

dcl  com_err_sw bit (1);				/* Set if com_err_ sould be called on attach error */
dcl  charp ptr;
dcl  device_opt char (32) var;
dcl  ignore fixed bin (35);
dcl  (code, ec, prt_code, card_code) fixed bin (35);
dcl  iocbp ptr;
dcl  arg char (32);
dcl  argp ptr;
dcl  mask bit (36) aligned;				/* For setting ips mask */
dcl  i fixed bin (21);
dcl  idx fixed bin;
dcl  open_mode fixed bin;
dcl  remaining_chars fixed bin (21);
dcl  data_chars fixed bin (21);
dcl  order char (32);
dcl  prt_conv_outp ptr;				/* pointer to output workspace for prt_conv_ */
dcl  record_len fixed bin;
dcl  infop ptr;
dcl  temp_iocbp ptr;
dcl  runout_spacing_cnt fixed bin;
dcl  terminal_switch_name char (32) var;
dcl  my_options char (256) var;
dcl  terminal_attach_options char (256) var;
dcl  terminal_attach_desc char (256) var;
dcl  nl_string char (32);				/* temp string of nl chars */


/* Based */

dcl  char_string char (1024) based;
dcl  info_fixed fixed bin based;
dcl  my_area area based (get_system_free_area_ ());


/* Internal Static */

dcl  put_chars_since_last_runout bit (1) static init ("1"b);
dcl  attach_count fixed bin int static init (0);
dcl  static_comerr_sw bit (1) int static init ("0"b);


/* Constants */

dcl  remote_device_name char (19) int static options (constant) init ("remote_teleprinter_");
dcl  teleprinter char (32) int static init ("teleprinter") options (constant);
dcl  space char (1) static init (" ") int options (constant);
dcl  Card_Util_Char_Max fixed bin int static init (2000) options (constant);
dcl  NL char (1) static init ("
") int static options (constant);


/* External stuff */

dcl  ioa_ entry options (variable);
dcl  com_err_ entry options (variable);
dcl  card_util_$modes entry (char (*), bit (36) aligned, char (*), fixed bin (35));
dcl  card_util_$translate entry (bit (36) aligned, char (*) var);
dcl  get_system_free_area_ entry () returns (pointer);
dcl  hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl  prt_conv_ entry (ptr, fixed bin (21), ptr, fixed bin, ptr);
dcl  remote_printer_modes_ entry (ptr, char (*), char (*), fixed bin (35));
dcl  remote_printer_control_ entry (ptr, char (*), ptr, fixed bin (35));
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  iox_$propagate entry (ptr);
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35));
dcl  iox_$get_chars entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  iox_$read_record entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$err_no_operation entry;

dcl  sys_info$max_seg_size fixed bin ext;

dcl  error_table_$bad_conversion fixed bin (35) ext;
dcl  error_table_$eof_record ext fixed bin (35);
dcl  error_table_$bad_arg ext fixed bin (35);
dcl  error_table_$bad_mode ext fixed bin (35);
dcl  error_table_$not_detached ext fixed bin (35);
dcl  error_table_$not_attached ext fixed bin (35);
dcl  error_table_$not_open ext fixed bin (35);
dcl  error_table_$not_closed ext fixed bin (35);
dcl  error_table_$data_loss ext fixed bin (35);
dcl  error_table_$wrong_no_of_args ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$unimplemented_version ext fixed bin (35);


/* Conditions and Builtins */

dcl  (conversion, any_other, cleanup) condition;

dcl  (addr, bin, hbound, length, min, max, copy, null, substr, ltrim, rtrim, convert, unspec, index, char, currentsize,
     size) builtin;

/**/

remote_teleprinter_attach:
     entry (a_iocbp, a_option, a_sw, a_code);

	iocbp = a_iocbp;
	com_err_sw = a_sw | static_comerr_sw;		/* report errors if either is on */
	code, a_code = 0;

	adp = null;
	if iocbp -> iocb.attach_descrip_ptr ^= null
	then do;
	     code = error_table_$not_detached;
	     call abort_attach (code, "Switch name: ^a", iocbp -> iocb.name);
	end;

	if hbound (a_option, 1) < 1
	then do;					/* Must be at least one */
	     code = error_table_$wrong_no_of_args;
	     call abort_attach (code, "Bad attach description.", "");
	end;

	on cleanup call clean_up;			/* if we abort, be sure to clean up */

	allocate ad in (my_area) set (adp);		/* create the attach data structure for this attachment */

/* Initialize the Attach Data Structure variables */

	ad.bits = "0"b;
	ad.fixed = 0;
	ad.ptrs = null;
	ad.chars = "";
	unspec (ad.remote_pci) = "0"b;
	ad.device_type = TELEPRINTER_DEVICE;		/* for the terminal_io_record structure */
	ad.sheets_per_page = 1;
	ad.phys_line_length = 80;
	ad.phys_page_length = 66;
	ad.lpi = 6;
	ad.line = 1;
	ad.cv_proc = null;				/* co-routine is undefined until switch is opened */

	call card_util_$modes ("lower_case,trim,add_nl.", ad.input_modes, "", code);
	if code ^= 0
	then call abort_attach (code, "Unable to set initial modes.", "");

/* Process options */

	my_options = "";
	terminal_attach_options = "";
	terminal_attach_desc = "";
	device_opt = "teleprinter";			/* this is our default */

	do idx = 1 to hbound (a_option, 1);
	     if a_option (idx) = "-physical_line_length" | a_option (idx) = "-pll"
	     then do;
		ad.phys_line_length = cv_dec_arg (idx);
		terminal_attach_options = terminal_attach_options || " -pll " || a_option (idx);
	     end;
	     else if a_option (idx) = "-physical_page_length" | a_option (idx) = "-ppl"
	     then do;
		ad.phys_page_length = cv_dec_arg (idx);
		my_options = my_options || " -ppl " || a_option (idx);
	     end;
	     else if a_option (idx) = "-device"
	     then device_opt = get_arg (idx);		/* we specify this */
	     else if a_option (idx) = "-horizontal_tab" | a_option (idx) = "-htab"
	     then do;
		ad.ht = "1"b;
		terminal_attach_options = terminal_attach_options || " -htab";
	     end;
	     else if a_option (idx) = "-runout_spacing" | a_option (idx) = "-runsp"
	     then do;
		ad.runout_spacing = max (0, min (cv_dec_arg (idx), 32));
						/* set the value within the range */
		my_options = my_options || " -runsp " || a_option (idx);
	     end;
	     else if a_option (idx) = "-terminal"
	     then do;
		ad.terminal = get_arg (idx);
		my_options = my_options || " -terminal " || ad.terminal;
	     end;
	     else terminal_attach_options = terminal_attach_options || space || a_option (idx);
	end;

/* Check out the options we were given */

	if ad.terminal = ""
	then do;
	     code = error_table_$bad_arg;
	     call abort_attach (code, "No terminal IO module specified.", "");
	end;

	if ad.phys_line_length < 1 | ad.phys_line_length > 256
	then do;
	     code = error_table_$bad_arg;
	     call abort_attach (code, "Invalid line length specified.", "");
	end;

	if ad.phys_page_length < 10 | ad.phys_page_length > 128
	then do;
	     code = error_table_$bad_arg;
	     call abort_attach (code, "Invalid page length specified.", "");
	end;

	if device_opt ^= "teleprinter"
	then do;					/* was it changed? */
	     code = error_table_$bad_arg;
	     call abort_attach (code, "Invalid -device option: ^a", (device_opt));
	end;

/* Attach through terminal dim */

	attach_count = attach_count + 1;		/* new attach name tag number each time */
	if attach_count > 999
	then attach_count = 1;
	terminal_switch_name = remote_device_name || ltrim (char (attach_count));
						/* make the  switch name */

	terminal_attach_options = ltrim (terminal_attach_options) || " -device " || device_opt;
	terminal_attach_desc = ad.terminal || space || terminal_attach_options;
	ad.attach_desc = remote_device_name || my_options || space || terminal_attach_options;

	call iox_$attach_ioname ((terminal_switch_name), temp_iocbp, (terminal_attach_desc), code);
	if code ^= 0
	then call abort_attach (code, "Unable to attach to terminal ", "");

	ad.terminal_iocbp = temp_iocbp;

/* Now mask and complete the iocb */

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc);
	iocbp -> iocb.attach_data_ptr = adp;
	iocbp -> iocb.open = remote_teleprinter_open;
	iocbp -> iocb.detach_iocb = remote_teleprinter_detach;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	call remote_printer_control_ (iocbp, "reset", null, code);
	if code ^= 0
	then call abort_attach (code, "Unable to reset printer data", "");

	call remote_printer_modes_ (iocbp, "noskip.", "", code);
	if code ^= 0
	then call abort_attach (code, "Unable to set default modes", "");

attach_return:
	return;

/**/

remote_teleprinter_detach:
     entry (a_iocbp, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null
	then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr ^= null
	then do;
	     code = error_table_$not_closed;
	     return;
	end;

	call clean_up;				/* detach terminal, free attach data, clear the iocb */

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

/**/

remote_teleprinter_open:
     entry (a_iocbp, a_mode, a_sw, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null
	then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr ^= null
	then do;
	     code = error_table_$not_closed;
	     return;
	end;

	open_mode = a_mode;
	if open_mode ^= Stream_input_output
	then do;
	     a_code = error_table_$bad_mode;
	     return;
	end;

	call iox_$open (ad.terminal_iocbp, Sequential_input_output, "0"b, a_code);
	if a_code = 0
	then do;
	     ad.record_io = "1"b;			/* we have record interface approval */
	     call hcs_$make_ptr (null, "remote_conv_", "teleprinter", ad.cv_proc, a_code);
	     if a_code ^= 0
	     then return;
	end;
	else do;
	     ad.record_io = "0"b;			/* try for stream interface */
	     call iox_$open (ad.terminal_iocbp, Stream_input_output, "0"b, a_code);
	     if a_code ^= 0
	     then return;
	     call hcs_$make_ptr (null, ad.terminal || "conv_", "teleprinter", ad.cv_proc, a_code);
	     if a_code ^= 0
	     then return;
	end;

	ad.open_description = rtrim (iox_modes (open_mode));
	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.get_chars = remote_teleprinter_get_chars;
	iocbp -> iocb.get_line = remote_teleprinter_get_chars;
	iocbp -> iocb.put_chars = remote_teleprinter_put_chars;
	iocbp -> iocb.control = remote_teleprinter_control;
	iocbp -> iocb.modes = remote_teleprinter_modes;
	iocbp -> iocb.position = remote_teleprinter_position;
	iocbp -> iocb.close = remote_teleprinter_close;
	iocbp -> iocb.open_descrip_ptr = addr (ad.open_description);

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

/**/

remote_teleprinter_close:
     entry (a_iocbp, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null
	then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null
	then do;
	     code = error_table_$not_open;
	     return;
	end;

	call iox_$close (ad.terminal_iocbp, a_code);
	if a_code = error_table_$not_open | a_code = error_table_$not_attached
	then a_code = 0;				/* make it easy to re-synch the attachments */

	mask = "0"b;

	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.open_descrip_ptr = null;
	iocbp -> iocb.open = remote_teleprinter_open;
	iocbp -> iocb.detach_iocb = remote_teleprinter_detach;
	iocbp -> iocb.control = iox_$err_no_operation;
	iocbp -> iocb.position = iox_$err_no_operation;
	iocbp -> iocb.modes = iox_$err_no_operation;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;

/**/

remote_teleprinter_put_chars:
     entry (a_iocbp, a_data_ptr, a_data_chars, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null
	then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null
	then do;
	     code = error_table_$not_open;
	     return;
	end;

	if a_data_chars < 0 | a_data_chars > sys_info$max_seg_size * 4
	then do;
	     a_code = error_table_$bad_arg;
	     return;
	end;

	terminal_io_record_ptr = null ();		/* for the cleanup handler */

	call iox_$control (ad.terminal_iocbp, "select_device", addr (teleprinter), code);
						/* HACK FOR THE ibm2780_ TERMINAL */
	if code ^= 0
	then goto put_chars_ret;

	put_chars_since_last_runout = "1"b;
	pcip = addr (ad.remote_pci);			/* get ptr to pci structure */
	remaining_chars = a_data_chars;		/* This is decremented as data is sent */
	charp = a_data_ptr;

	terminal_io_record_element_size = 9;		/* always character data */
	terminal_io_record_n_elements = 3 * ad.phys_line_length;
						/* enough room for 1 printing character and 2 non-printing
						   characters per column (eg: DC1-u X) */

	on cleanup
	     begin;
		if terminal_io_record_ptr ^= null ()
		then free terminal_io_record_ptr -> terminal_io_record in (my_area);
	     end;

	call alloc_tio_rec;				/* allocate and initialize the terminal_io_record */

	if ad.record_io
	then prt_conv_outp = terminal_io_record_ptr;	/* full record for record interface */
	else prt_conv_outp = addr (terminal_io_record.data);
						/* use the string for stream interface */

	do while (remaining_chars > 0 | pci.slew_residue > 0);
						/* runout chars and trailing NLs */
	     pci.line = 1;				/* fool prt_conv_ and say this is always line one */
						/* we are assuming noskip mode and want to suppress */
						/* the FF used to align each physical page */

	     call prt_conv_ (charp, remaining_chars, prt_conv_outp, record_len, pcip);

	     if ad.record_io
	     then do;
		call iox_$write_record (ad.terminal_iocbp, terminal_io_record_ptr,
		     4 * currentsize (terminal_io_record), code);
	     end;
	     else do;				/* stream output */
		call iox_$put_chars (ad.terminal_iocbp, prt_conv_outp, record_len, code);
	     end;

	     if code ^= 0
	     then goto put_chars_ret;
	end;

	call iox_$control (ad.terminal_iocbp, "runout", null, code);
						/* make the terminal IO Module ship the message */

put_chars_ret:
	if terminal_io_record_ptr ^= null ()
	then free terminal_io_record_ptr -> terminal_io_record in (my_area);

	a_code = code;

	return;

/**/

/* Get_chars  and  Get_line entry points */

remote_teleprinter_get_chars:
     entry (a_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null
	then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null
	then do;
	     code = error_table_$not_open;
	     return;
	end;

	a_data_chars = 0;				/* clear the return values */
	code, a_code = 0;

	terminal_io_record_ptr = null;		/* for the cleanup handler */
	terminal_io_record_element_size = 9;		/* always character data */
	terminal_io_record_n_elements = a_buf_chars;	/* allow for max buffer size */

	on cleanup
	     begin;
		if terminal_io_record_ptr ^= null
		then free terminal_io_record_ptr -> terminal_io_record in (my_area);
	     end;

	call alloc_tio_rec;				/* allocate and initialize terminal_io_record */

	if ad.record_io
	then do;
	     call iox_$read_record (ad.terminal_iocbp, terminal_io_record_ptr, 4 * size (terminal_io_record),
		record_len, code);
	     if code = error_table_$eof_record
	     then code = 0;
	     if code ^= 0
	     then go to get_chars_ret;
	     if terminal_io_record.version ^= terminal_io_record_version_1
	     then do;
		code = error_table_$unimplemented_version;
		go to get_chars_ret;
	     end;

/*	assume that the data string doesn't have any slew specified (ignore any that was sent) */

	end;
	else do;
	     call iox_$get_chars (ad.terminal_iocbp, addr (terminal_io_record.data), (a_buf_chars), record_len, code);
	     if code = error_table_$eof_record
	     then code = 0;
	     if code ^= 0
	     then go to get_chars_ret;
	     terminal_io_record.n_elements = record_len;	/* make a legal varying string */
	end;

/*	at this point, we must have a record of the form:  <text chars><slew chars> */
/*	where the slew chars are missing - hopefully - for the teleprinter */

/*	use card_util_ to do escape processing and adding NL if desired */

	terminal_io_record_data_chars_varying_max_len = Card_Util_Char_Max;
	call card_util_$translate (ad.input_modes, terminal_io_record_data_chars_varying);
						/* can only shorten the string */


	data_chars = terminal_io_record.n_elements;	/* get the updated count */
	if data_chars > a_buf_chars
	then code = error_table_$data_loss;		/* tell caller we truncated the record */

	a_data_chars = min (a_buf_chars, data_chars);
	substr (a_buf_ptr -> char_string, 1, a_data_chars) = substr (terminal_io_record_data_chars, 1, a_data_chars);

get_chars_ret:
	free terminal_io_record_ptr -> terminal_io_record in (my_area);
	revert cleanup;

	a_code = code;

	return;

/**/

remote_teleprinter_control:
     entry (a_iocbp, a_order, a_infop, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null
	then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null
	then do;
	     code = error_table_$not_open;
	     return;
	end;

	infop = a_infop;
	order = a_order;
	code, ec, a_code = 0;

	if order = "runout_spacing"
	then do;
	     if infop = null
	     then do;
		code = error_table_$bad_arg;
		go to control_ret;
	     end;
	     ad.runout_spacing = max (0, min (infop -> info_fixed, 32));
	end;
	else if order = "end_write_mode"
	then go to do_control;			/* CHECK THIS OUT */
	else if order = "runout"
	then do;
	     if ^put_chars_since_last_runout
	     then return;				/* ignore multiple runouts per switch */
	     put_chars_since_last_runout = "0"b;
	     if ad.runout_spacing = 0
	     then go to do_control;			/* for another common case */
	     nl_string = copy (NL, ad.runout_spacing);	/* get the right number of new lines */

	     call iox_$put_chars (iocbp, addr (nl_string), ad.runout_spacing, ignore);
						/* let the normal entry do the work */
	     goto do_control;
	end;
	else if order = "io_call"
	then call remote_teleprinter_io_call;
	else do;
	     call remote_printer_control_ (iocbp, order, infop, ec);
	     if ec ^= 0
	     then do;
do_control:
		call iox_$control (ad.terminal_iocbp, order, infop, code);
		if code ^= 0 & ec ^= 0
		then code = ec;			/* use first code if this fails */
	     end;
	     if order = "reset"
	     then call iox_$control (ad.terminal_iocbp, order, null, 0);
	end;

control_ret:
	a_code = code;

	return;

/**/

remote_teleprinter_modes:
     entry (a_iocbp, a_new_modes, a_old_modes, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	code, a_code = 0;

	if adp = null
	then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null
	then do;
	     code = error_table_$not_open;
	     return;
	end;

	prt_modes, card_modes = "";			/* get ready to pickup old modes */

	call remote_printer_modes_ (iocbp, a_new_modes, prt_modes, prt_code);

	call card_util_$modes (a_new_modes, ad.input_modes, card_modes, card_code);

	if prt_code = 0 | card_code = 0
	then a_code = 0;				/* say OK if one was good */
	else a_code = prt_code;

	if a_new_modes = "default"
	then do;
	     call iox_$modes (ad.terminal_iocbp, a_new_modes, "", 0);
	end;
	else if index (a_new_modes, "non_edited") ^= 0
	then do;
	     i = index (a_new_modes, "non_edited");
	     if i = 1
	     then call iox_$modes (ad.terminal_iocbp, "non_edited", "", 0);
	     else if substr (a_new_modes, i - 1, 1) = "^"
	     then call iox_$modes (ad.terminal_iocbp, "default", "", 0);
	     else call iox_$modes (ad.terminal_iocbp, "non_edited", "", 0);
	end;

	last_pos = length (rtrim (prt_modes));		/* check last char so we give a good mode string */
	last_char = substr (prt_modes, last_pos, 1);
	if last_char = "," | last_char = "."
	then last_pos = last_pos - 1;			/* we'll put it back */

	a_old_modes = rtrim (substr (prt_modes, 1, last_pos) || "," || card_modes);
						/* put it all together */

	return;

/**/

remote_teleprinter_position:
     entry (a_iocbp, a_pos_type, a_pos_value, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	code, a_code = 0;

	if adp = null
	then do;
	     a_code = error_table_$not_attached;
	     return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null
	then do;
	     code = error_table_$not_open;
	     return;
	end;

	call iox_$position (ad.terminal_iocbp, a_pos_type, a_pos_value, a_code);

	return;




flip_com_err_sw:
     entry ();

	static_comerr_sw = ^static_comerr_sw;		/* flip the bit */

	call ioa_ ("The teleprinter com err sw is now: ^[on^;off^]", static_comerr_sw);

	return;

/**/

get_arg:
     procedure (idx) returns (character (*));

dcl  idx fixed bin;

	idx = idx + 1;				/* advance the index of the major loop */
	if idx > hbound (a_option, 1)
	then do;
	     code = error_table_$noarg;
	     call abort_attach (code, "No argument after ^a.", (a_option (idx - 1)));
	end;

	return (a_option (idx));

     end get_arg;



cv_dec_arg:
     procedure (idx) returns (fixed binary);

dcl  idx fixed bin;

	idx = idx + 1;				/* advance the index of the major loop */
	if idx > hbound (a_option, 1)
	then do;
	     code = error_table_$noarg;
	     call abort_attach (code, "No argument after ^a.", (a_option (idx - 1)));
	end;

	on conversion go to bad_dec_arg;

	return (bin (a_option (idx)));
bad_dec_arg:
	code = error_table_$bad_conversion;
	call abort_attach (code, "Invalid decimal number. ^a", (a_option (idx)));

     end cv_dec_arg;



abort_attach:
     procedure (code, str1, str2);

dcl  code fixed bin (35);
dcl  (str1, str2) char (*) aligned;

/* This proc handles attach errors */

	if com_err_sw
	then call com_err_ (code, remote_device_name, str1, str2);

	a_code = code;				/* we were called because code ^= 0 */

	call clean_up;

	go to attach_return;			/* do a direct non-local return */

     end abort_attach;

/**/

alloc_tio_rec:
     procedure ();

	allocate terminal_io_record in (my_area) set (terminal_io_record_ptr);

	unspec (terminal_io_record) = "0"b;		/* clear everything */

	terminal_io_record.version = terminal_io_record_version_1;
						/* our view of the record structure */
	terminal_io_record.device_type = ad.device_type;
	terminal_io_record.element_size = terminal_io_record_element_size;
						/* set by our caller */

	return;

     end alloc_tio_rec;



clean_up:
     procedure ();

/* this is for any form of abort during attachment */

	if adp ^= null
	then do;
	     if ad.terminal_iocbp ^= null
	     then call iox_$detach_iocb (ad.terminal_iocbp, ignore);
	     free adp -> ad in (my_area);
	     adp = null;
	end;

	iocbp -> iocb.attach_descrip_ptr = null;	/* be sure iox_ knows */
	iocbp -> iocb.attach_data_ptr = null;
	iocbp -> iocb.open = iox_$err_no_operation;


	return;

     end clean_up;


handler:
     procedure ();

/* This proc handles faults that occur while masked */

	if mask
	then					/* were we saving any mask bits? */
	     call hcs_$reset_ips_mask (mask, mask);

	mask = ""b;

	call continue_to_signal_ (ignore);

	return;

     end handler;

/**/

/* Handles the io_call orders by mapping them into control order calls to this dim */

remote_teleprinter_io_call:
     procedure ();

	if infop = null
	then do;
	     code = error_table_$bad_arg;
	     return;
	end;

	io_call_infop = infop;
	order = io_call_info.order_name;
	if io_call_info.nargs > 0
	then do;
	     arg = io_call_info.args (1);
	     argp = addr (arg);
	end;
	else argp = null;
	if order = "runout_spacing"
	then do;
	     on conversion goto io_call_err;
	     runout_spacing_cnt = convert (runout_spacing_cnt, io_call_info.args (1));
	     call iox_$control (iocbp, order, addr (runout_spacing_cnt), code);
	end;
	else call iox_$control (iocbp, order, argp, code);
	return;
io_call_err:
	code = error_table_$bad_conversion;
	return;

     end remote_teleprinter_io_call;

/**/

%include remote_attach_data;
%page;
%include prt_conv_info;
%page;
%include prt_info;
%page;
%include iocb;
%page;
%include iox_modes;
%page;
%include io_call_info;
%page;
%include terminal_io_record;

     end remote_teleprinter_;




		    tty_printer_.pl1                11/15/82  1900.8rew 11/15/82  1523.5      248238



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


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


/* tty_printer_: An I/O module for communicating with tty_ or syn_ from any remote_XXX_ I/O module */

/* Coded 4/79 by J. C. Whitmore */
/* Modified October 1981 by C. Hornig to not call dial_manager_. */

/* Parameters */

dcl  a_iocbp ptr;
dcl  a_option (*) char (*) var;			/* Options for attach */
dcl  a_sw bit (1);					/* com_err_ switch for attach */
dcl  a_code fixed bin (35);
dcl  a_mode fixed bin;				/* The open mode */
dcl  a_buf_ptr ptr;
dcl  a_data_ptr ptr;
dcl  a_buf_chars fixed bin (21);
dcl  a_data_chars fixed bin (21);
dcl  a_pos_type fixed bin;
dcl  a_pos_value fixed bin (21);
dcl  a_order char (*);
dcl  a_infop ptr;
dcl  a_new_modes char (*);
dcl  a_old_modes char (*);

/* Automatic */

dcl  com_err_sw bit (1);				/* Set if com_err_ sould be called on attach error */
dcl  attach_tag picture "99";
dcl  code fixed bin (35);
dcl  iocbp ptr;
dcl  mask bit (36) aligned;				/* For setting ips mask */
dcl  i fixed bin (21);
dcl  open_mode fixed bin;
dcl  modes char (64);				/* for setting initial modes or "reset" control */
dcl  old_modes char (256);
dcl  order char (32);
dcl  infop ptr;
dcl  temp_ptr ptr;					/* for the repeat loop chain search */
dcl  term_type char (32);
dcl  my_attach_options char (256) var;
dcl  next_attach_options char (256) var;
dcl  next_attach_desc char (256) var;
dcl  next_module char (32) var;
dcl  target_device char (32) var;

/* Internal static */

dcl  attach_count fixed bin init (0) int static;
dcl  first_dibp ptr int static init (null);		/* pointer to first device info block in chain */
dcl  last_dibp ptr int static init (null);		/* pointer to the tail of the info block chain */
dcl  areap ptr int static init (null);			/* pointer to our area segment */
dcl  static_com_err_sw bit (1) int static init ("0"b);	/* for testing only */

/* Based variables */

dcl  my_area area (262144) based (areap);

dcl  info_fixed fixed bin based (infop);		/* fixed bin control argument */


/* Constants */

dcl  my_device_name char (12) int static options (constant) init ("tty_printer_");
dcl  space char (1) static int init (" ") options (constant);

dcl  error_table_$bad_conversion fixed bin (35) ext;
dcl  error_table_$no_operation fixed bin (35) ext;
dcl  error_table_$bad_mode ext fixed bin (35);
dcl  error_table_$not_detached ext fixed bin (35);
dcl  error_table_$not_attached ext fixed bin (35);
dcl  error_table_$not_open ext fixed bin (35);
dcl  error_table_$not_closed ext fixed bin (35);
dcl  error_table_$wrong_no_of_args ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);


/* External stuff */

dcl  (
     ioa_,
     ioa_$rsnnl
     ) entry options (variable);
dcl  com_err_ entry options (variable);
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  convert_ipc_code_ entry (fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$err_no_operation entry;
dcl  iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (36), fixed bin (35));
dcl  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
dcl  iox_$propagate entry (ptr);
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));



/* External Variables */

dcl  tty_printer_conv_$send_vt fixed bin ext;
dcl  tty_printer_conv_$send_ht fixed bin ext;


/* Internal PL/I Stuff */

dcl  (addr, bin, codeptr, hbound, null, rtrim, empty, unspec, max, fixed) builtin;

dcl  conversion condition;
dcl  any_other condition;
dcl  cleanup condition;
%page;
dcl  adp ptr;					/* local copy of pointer to attach data */

dcl  1 ad aligned based (adp),
       2 fixed,
         3 phys_line_length fixed bin,
       2 bits unal,
         3 ht bit (1),				/* on if caller wants to send tabs */
         3 vt bit (1),				/* on if caller wants to send VT chars */
       2 ptrs,
         3 dibp ptr,				/* device info block pointer for this attachment */
         3 iocbp ptr,				/* for easy debugging, ptr back to our iocb */
       2 chars,
         3 device_type char (32),			/* device type using this switch (e.g. printer, teleprinter) */
         3 term_type char (32),			/* the -ttp option for this attachment */
         3 attach_desc char (256) var,			/* how this switch was attached */
         3 open_description char (24) var;		/* and how it was opened */


dcl  dibp ptr;					/* pointer to device info block */

dcl  1 dib aligned based (dibp),			/* device info block for per target device data */
       2 term_type,					/* info for the set_term_type control order */
         3 version fixed bin,				/* version if this structure (=1) */
         3 name char (32) unal,			/* terminal type name */
         3 flags,
	 4 initial_string bit (1) unal,		/* TRUE - if initial string should be sent (tab set) */
	 4 modes bit (1) unal,			/* TRUE - if default initial modes are to be set */
	 4 ignore_line_type bit (1) unal,		/* always FALSE for us, we want the cross check */
	 4 MBZ bit (33) unal,			/* Must Be Zero */
       2 device char (32),				/* name of the target device or switch */
       2 module char (32),				/* name of the next IO module */
       2 output_switch char (32) unaligned,		/* what we are attached to (sw name) */
       2 next_iocbp ptr,				/* iocb ptr for output_switch */
       2 fwd_ptr ptr,				/* forward pointer in chain of info blocks */
       2 back_ptr ptr,				/* backwards pointer to previous block */
       2 wait_list,					/* list for ipc_$block, must start on even word */
         3 n_chan fixed bin,				/* number of channels in list (Must Be 1) */
         3 wait_pad fixed bin,
         3 channel fixed bin (71),			/* IPC channel to get wakeup */
       2 flags,
         3 attached bit (1) unal,			/* device is ready to be opened */
         3 open bit (1) unal,				/* device is ready to do I/O */
       2 n_attached fixed bin,			/* number of switches attached to this device */
       2 max_line_length fixed bin;			/* the longest phys_line_length requested */

dcl  1 event_info aligned like event_wait_info;

dcl  1 write_info aligned,
       2 channel fixed bin (71),
       2 write_pending bit (1);
%page;
/* Attach entry point */

tty_printer_attach:
     entry (a_iocbp, a_option, a_sw, a_code);

	iocbp = a_iocbp;
	com_err_sw = a_sw;
	code, a_code = 0;

	adp, dibp = null;				/* these will be checked by abort_attach */

	if iocbp -> iocb.attach_descrip_ptr ^= null then do;
	     code = error_table_$not_detached;
	     call abort_attach ("^a", iocbp -> iocb.name);
	     end;

	if areap = null then do;			/* make an area once per process */
	     call get_temp_segment_ (my_device_name, areap, code);
	     if code ^= 0 then call abort_attach ("Unable to allocate temp segment.", "");
	     my_area = empty ();			/* initialize the area */
	     end;

	on cleanup call clean_up;			/* save the area, please */

	allocate ad in (my_area) set (adp);		/* make an attach data structure allocation */

/* Initialize variables */

	ad.bits = "0"b;
	ad.ptrs = null;
	ad.chars = "";
	ad.phys_line_length = 0;
	ad.iocbp = iocbp;				/* so we can find the IOCB for debugging */

	next_attach_desc, next_attach_options = "";
	target_device, next_module, term_type = "";
	my_attach_options = "";

/* Are there enough attach options specified? */

	if hbound (a_option, 1) < 4 then do;		/* Must be at least -tty XX and -comm YY */
	     code = error_table_$wrong_no_of_args;
	     call abort_attach ("Bad attach description.", "");
	     end;
%page;
/* Process options */

	do i = 1 to hbound (a_option, 1);
	     if a_option (i) ^= "-comm" then my_attach_options = my_attach_options || space || a_option (i);
	     if /* case */ a_option (i) = "-terminal_type" | a_option (i) = "-ttp" then do;
		term_type = get_arg ();
		end;
	     else if a_option (i) = "-physical_line_length" | a_option (i) = "-pll"
	     then ad.phys_line_length = cv_dec_arg ();
	     else if a_option (i) = "-horizontal_tab" | a_option (i) = "-htab" then ad.ht = "1"b;
	     else if a_option (i) = "-vtab" then ad.vt = "1"b;
	     else if a_option (i) = "-device" then ad.device_type = get_arg ();
	     else if a_option (i) = "-auto_call"
	     then next_attach_options = next_attach_options || " -destination " || get_arg ();
	     else if a_option (i) = "-tty" then target_device = get_arg ();
	     else if a_option (i) = "-comm" then do;
		i = i + 1;
		if i > hbound (a_option, 1) then goto no_arg;
		next_module = a_option (i);
		end;
	     else next_attach_options = next_attach_options || space || a_option (i);
	end;

	if target_device = "" then do;
	     code = error_table_$badopt;
	     call abort_attach ("No ""-tty"" option given.", "");
	     end;

	if next_module = "" then do;
	     code = error_table_$badopt;
	     call abort_attach ("No ""-comm"" option given.", "");
	     end;

/* find a device info block for the target device */

	do temp_ptr = first_dibp repeat (temp_ptr -> dib.fwd_ptr) while (temp_ptr ^= null & dibp = null);
	     if temp_ptr -> dib.device = target_device
	     then					/* previously defined? */
		dibp = temp_ptr;
	end;

	if dibp = null then do;			/* first for this device */
	     call make_dib (dibp);			/* create a device info block for the target device */
	     dib.device = target_device;
	     dib.module = next_module;
	     dib.term_type.name = term_type;		/* ready to give set_term_type control */
	     dib.term_type.initial_string = "1"b;	/* send the initial tab string if it exists */
	     dib.term_type.modes = "1"b;		/* we always want the default modes set */
	     end;

	ad.dibp = dibp;				/* point this back to its device info block */
	ad.term_type = term_type;			/* record the -ttp option */

/* Before attaching, finish the attach data by checking for default values of optional attach options */

	if ad.device_type = "" then ad.device_type = "teleprinter";
						/* the default */

	if ad.phys_line_length = 0
	then					/* if not given */
	     if ad.device_type = "printer"
	     then ad.phys_line_length = 136;
	     else ad.phys_line_length = 118;		/* for a terminet */

	ad.attach_desc = my_device_name || space || next_module || space || my_attach_options;

/* If we need to attach, attach through next_module to target_device (which may be a switch) */

	if ^dib.attached then do;			/* just once per target device */
	     attach_count = attach_count + 1;
	     attach_tag = attach_count;
	     dib.output_switch = my_device_name || attach_tag;
						/* make up a new switch name for the next level */
	     next_attach_desc = next_module || space || target_device || space || next_attach_options;

	     call iox_$attach_name (dib.output_switch, dib.next_iocbp, (next_attach_desc), codeptr (tty_printer_attach),
		code);
	     if code ^= 0 then call abort_attach ("Unable to attach to target device/switch", "");

	     dib.attached = "1"b;			/* we have a new attachment */
	     dib.open = "0"b;			/* don't forget to open it */
	     end;

/* Set up the target device modes via the next IO module */

	if ^dib.open then do;			/* if not open, do it */
	     call iox_$open (dib.next_iocbp, Stream_input_output, "0"b, code);
	     if code ^= 0
	     then					/* OOPS */
		if code ^= error_table_$not_closed
		then				/* if open, let it go */
		     call abort_attach ("Unable to open target device stream.", "");

	     if dib.term_type.name ^= "" then do;	/* set the terminal type if specified */
		call iox_$control (dib.next_iocbp, "set_term_type", addr (dib.term_type), code);
		if code ^= 0 then call abort_attach ("Unable to set terminal type.", "");
		end;

	     call iox_$control (dib.next_iocbp, "quit_enable", null, (0));

	     call iox_$control (dib.next_iocbp, "write_status", addr (write_info), code);
	     if code = 0 then do;			/* if OK, set up wait list for runout control */
		dib.n_chan = 1;
		dib.channel = write_info.channel;
		end;
	     else do;				/* can't block for output completion */
		code = 0;				/* this is OK */
		dib.wait_list = 0;			/* clear the list */
		end;

	     tty_printer_conv_$send_ht = fixed (ad.ht);
	     tty_printer_conv_$send_vt = fixed (ad.vt);

	     dib.open = "1"b;
	     end;

	dib.max_line_length = max (dib.max_line_length, ad.phys_line_length);

	call ioa_$rsnnl ("^^edited^[,vertsp^],ll^d^[,tabs^]", modes, i, ad.vt, dib.max_line_length, ad.ht);

	old_modes = "";
	call iox_$modes (dib.next_iocbp, modes, old_modes, code);
						/* don't abort now, just try the set up */
	if code ^= 0 & (com_err_sw | static_com_err_sw)
	then call com_err_ (code, my_device_name, "Modes error: ^a  From: ^a", rtrim (modes), rtrim (old_modes));

/* Mask and complete the iocb */

	mask = "0"b;
	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_desc);
	iocbp -> iocb.attach_data_ptr = adp;
	iocbp -> iocb.open = tty_printer_open;
	iocbp -> iocb.detach_iocb = tty_printer_detach;

	dib.n_attached = dib.n_attached + 1;		/* bump the number of switches to this device */

	call iox_$propagate (iocbp);

	revert cleanup;				/* it is good from here on */

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;





attach_return:
	return;
no_arg:
	code = error_table_$noarg;
	call abort_attach ("No argument after ^a.", (a_option (i - 1)));
%page;
/* Detach entry point */

tty_printer_detach:
     entry (a_iocbp, a_code);

	iocbp = a_iocbp;
	a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if iocbp -> iocb.open_descrip_ptr ^= null then do;/* not closed? */
	     a_code = error_table_$not_closed;
	     return;
	     end;

	if adp ^= null then do;
	     dibp = ad.dibp;			/* find the device info block */
	     dib.n_attached = dib.n_attached - 1;	/* this one is gone! */
	     if dib.n_attached < 1 then do;		/* when the last, take the block and attachment too */
		if dib.next_iocbp ^= null then do;
		     call iox_$close (dib.next_iocbp, (0));
						/* force the issue */
		     call iox_$detach_iocb (dib.next_iocbp, (0));
		     end;
		call delete_dib (dibp);
		end;
	     iocbp -> iocb.attach_data_ptr = null;	/* this is about to become invalid */
	     free adp -> ad in (my_area);		/* drop the attach data structure for sure */
	     end;

	mask = "0"b;
	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.attach_descrip_ptr = null;
	iocbp -> iocb.open = iox_$err_no_operation;	/* remaining invalid functions */
	iocbp -> iocb.close = iox_$err_no_operation;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;
%page;
/* Open entry point */

tty_printer_open:
     entry (a_iocbp, a_mode, a_sw, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	a_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if iocbp -> iocb.open_descrip_ptr ^= null then do;/* already open? */
	     a_code = error_table_$not_closed;
	     return;
	     end;

	if adp = null then do;			/* must be valid */
	     a_code = error_table_$not_attached;
	     return;
	     end;

	open_mode = a_mode;
	if ^((open_mode = Stream_input) | (open_mode = Stream_output) | (open_mode = Stream_input_output)) then do;
bad_mode:
	     a_code = error_table_$bad_mode;
	     return;
	     end;

	ad.open_description = rtrim (iox_modes (open_mode));

	mask = "0"b;
	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	if ((open_mode = Stream_input) | (open_mode = Stream_input_output)) then do;
	     iocbp -> iocb.get_chars = tty_printer_get_chars;
	     iocbp -> iocb.get_line = tty_printer_get_line;
	     end;

	if ((open_mode = Stream_output) | (open_mode = Stream_input_output)) then do;
	     iocbp -> iocb.put_chars = tty_printer_put_chars;
	     end;

	iocbp -> iocb.control = tty_printer_control;
	iocbp -> iocb.position = tty_printer_position;
	iocbp -> iocb.modes = tty_printer_modes;
	iocbp -> iocb.close = tty_printer_close;
	iocbp -> iocb.detach_iocb = tty_printer_detach;
	iocbp -> iocb.open_descrip_ptr = addr (ad.open_description);

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;
%page;
/* Close entry point */

tty_printer_close:
     entry (a_iocbp, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	a_code = 0;

	if iocbp -> iocb.open_descrip_ptr = null then do; /* already closed? */
	     a_code = error_table_$not_open;
	     return;
	     end;

	mask = "0"b;
	on any_other call handler;

	call hcs_$set_ips_mask ("0"b, mask);

	iocbp -> iocb.open_descrip_ptr = null;
	iocbp -> iocb.open = tty_printer_open;
	iocbp -> iocb.detach_iocb = tty_printer_detach;
	iocbp -> iocb.control = iox_$err_no_operation;
	iocbp -> iocb.position = iox_$err_no_operation;
	iocbp -> iocb.modes = iox_$err_no_operation;
	iocbp -> iocb.put_chars = iox_$err_no_operation;
	iocbp -> iocb.get_chars = iox_$err_no_operation;
	iocbp -> iocb.get_line = iox_$err_no_operation;

	call iox_$propagate (iocbp);

	call hcs_$reset_ips_mask (mask, mask);

	revert any_other;

	return;
%page;
/* Put_chars entry point */

tty_printer_put_chars:
     entry (a_iocbp, a_data_ptr, a_data_chars, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;			/* must be valid */
	     a_code = error_table_$not_attached;
	     return;
	     end;

	if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */
	     a_code = error_table_$not_open;
	     return;
	     end;

	a_code = 0;
	dibp = ad.dibp;				/* find the device info block */

	call iox_$put_chars (dib.next_iocbp, a_data_ptr, a_data_chars, a_code);

	return;
%page;
/* Get_chars entry point */

tty_printer_get_chars:
     entry (a_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;			/* must be valid */
	     a_code = error_table_$not_attached;
	     return;
	     end;

	if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */
	     a_code = error_table_$not_open;
	     return;
	     end;

	a_code = 0;
	dibp = ad.dibp;				/* find the device info block */

	call iox_$get_chars (dib.next_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code);

	return;






/* Get_line entry point */

tty_printer_get_line:
     entry (a_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;			/* must be valid */
	     a_code = error_table_$not_attached;
	     return;
	     end;

	if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */
	     a_code = error_table_$not_open;
	     return;
	     end;

	a_code = 0;
	dibp = ad.dibp;				/* find the device info block */

	call iox_$get_line (dib.next_iocbp, a_buf_ptr, a_buf_chars, a_data_chars, a_code);

	return;
%page;
/* Control entry point */

tty_printer_control:
     entry (a_iocbp, a_order, a_infop, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;			/* must be valid */
	     a_code = error_table_$not_attached;
	     return;
	     end;

	if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */
	     a_code = error_table_$not_open;
	     return;
	     end;

	code, a_code = 0;
	dibp = ad.dibp;

	infop = a_infop;
	order = a_order;

	if order = "io_call" then do;			/* we can use a simple mapping for this */
	     io_call_infop = infop;
	     order = io_call_info.order_name;
	     infop = null;				/* can't have an info ptr with io_call */
	     end;

	if /* case */ order = "select_device" then do;
	     if ad.term_type ^= dib.term_type.name then do;
		dib.term_type.name = ad.term_type;	/* establish the other terminal type */
		if dib.term_type.name ^= ""
		then				/* set the terminal type if specified */
		     call iox_$control (dib.next_iocbp, "set_term_type", addr (dib.term_type), code);
		end;

	     tty_printer_conv_$send_ht = fixed (ad.ht);
	     tty_printer_conv_$send_vt = fixed (ad.vt);

	     call ioa_$rsnnl ("^^edited^[,vertsp^],ll^d^[,tabs^]", modes, i, ad.vt, dib.max_line_length, ad.ht);
	     call iox_$modes (dib.next_iocbp, modes, old_modes, (0));
						/* don't abort now, just try the set up */
	     end;
	else if order = "runout" then do;		/* here we wait for the output to complete */
	     if dib.n_chan = 0 then return;		/* in case we can't block */
	     write_info.write_pending = "0"b;		/* clear the flag */

	     call iox_$control (dib.next_iocbp, "write_status", addr (write_info), code);
	     if write_info.write_pending then do;

		call ipc_$block (addr (dib.wait_list), addr (event_info), code);
		if code ^= 0 then call convert_ipc_code_ (code);
		end;
	     end;
	else if order = "hangup" & dib.module = "syn_" then do;
						/* trap this order here */
						/* so we don't hangup user_i/o */
	     end;
	else if order = "reset" then do;
	     call ioa_$rsnnl ("^^edited^[,vertsp^],ll^d^[,tabs^]", modes, i, ad.vt, dib.max_line_length, ad.ht);
	     call iox_$modes (dib.next_iocbp, modes, old_modes, (0));
						/* don't abort now, just try the set up */
	     end;
	else if order = "get_error_count" then do;
	     if infop = null then go to no_op;		/* not for io_call or a bad ptr */
	     infop -> info_fixed = 0;			/* return a count of zero for now */
	     end;
	else do;
	     call iox_$control (dib.next_iocbp, a_order, a_infop, code);
	     end;

	a_code = code;
	return;

no_op:
	a_code = error_table_$no_operation;		/* it couldn't be done as called */
	return;
%page;
/* Position entry point */

tty_printer_position:
     entry (a_iocbp, a_pos_type, a_pos_value, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;			/* must be valid */
	     a_code = error_table_$not_attached;
	     return;
	     end;

	if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */
	     a_code = error_table_$not_open;
	     return;
	     end;

	a_code = 0;
	dibp = ad.dibp;				/* find the device info block */

	call iox_$position (dib.next_iocbp, a_pos_type, a_pos_value, a_code);

	return;
%page;
tty_printer_modes:
     entry (a_iocbp, a_new_modes, a_old_modes, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if adp = null then do;			/* must be valid */
	     a_code = error_table_$not_attached;
	     return;
	     end;

	if iocbp -> iocb.open_descrip_ptr = null then do; /* is it open? */
	     a_code = error_table_$not_open;
	     return;
	     end;

	a_code = 0;
	dibp = ad.dibp;				/* find the device info block */

	call iox_$modes (dib.next_iocbp, a_new_modes, a_old_modes, a_code);

	return;
%page;
cv_dec_arg:
     proc returns (fixed bin);

/* This proc picks up the next arg in the attach option array and returns it as fixed bin */

	i = i + 1;				/* Advance to next arg */
	if i > hbound (a_option, 1) then goto no_arg;
	my_attach_options = my_attach_options || space || a_option (i);
	on conversion go to bad_dec_arg;
	return (bin ((a_option (i))));
bad_dec_arg:
	code = error_table_$bad_conversion;
	call abort_attach ("Invalid decimal number. ^a", ((a_option (i))));

     end cv_dec_arg;





get_arg:
     proc returns (char (*) var);

/* This proc picks up the next arg in the attach option array and returns it as a character string */

	i = i + 1;
	if i > hbound (a_option, 1) then goto no_arg;
	my_attach_options = my_attach_options || space || a_option (i);
	return ((a_option (i)));

     end get_arg;
%page;
make_dib:
     proc (new_dibp);

dcl  new_dibp ptr;					/* pointer to new info block in chain (output) */


	allocate dib in (my_area) set (new_dibp);
	unspec (new_dibp -> dib) = "0"b;		/* set it all to zero */
	new_dibp -> dib.fwd_ptr = null;		/* chain ends here */
	new_dibp -> dib.device = "";			/* for string compares */
	new_dibp -> dib.module = "";
	new_dibp -> dib.output_switch = "";
	new_dibp -> dib.back_ptr = last_dibp;		/* if the first, this is null */
	new_dibp -> dib.next_iocbp = null;
	new_dibp -> dib.term_type.version = 1;		/* be sure we give the right version */
	new_dibp -> dib.term_type.name = "";		/* not defined yet */

	if first_dibp = null
	then first_dibp = new_dibp;			/* set the head of the chain */
	else last_dibp -> dib.fwd_ptr = new_dibp;	/* otherwise, link it into the list */
	last_dibp = new_dibp;			/* record the new end of of the chain */

     end make_dib;





delete_dib:
     proc (dibp);

dcl  dibp ptr;					/* pointer to the info block to be deleted */


	if dibp -> dib.back_ptr = null
	then					/* it was the head of the chain */
	     first_dibp = dibp -> dib.fwd_ptr;
	else dibp -> dib.back_ptr -> dib.fwd_ptr = dibp -> dib.fwd_ptr;
						/* move our fwd ptr to previous block */

	if dibp -> dib.fwd_ptr = null
	then					/* if the tail of the chain */
	     last_dibp = dibp -> dib.back_ptr;
	else dibp -> dib.fwd_ptr -> dib.back_ptr = dibp -> dib.back_ptr;
						/* move our back ptr to next block */

	free dibp -> dib in (my_area);
	dibp = null;

	return;

     end delete_dib;
%page;
abort_attach:
     proc (str1, str2);
dcl  (str1, str2) char (*) aligned;

/* This proc handles attach errors */

	if com_err_sw | static_com_err_sw then call com_err_ (code, my_device_name, str1, str2);
	a_code = code;

	call clean_up;				/* free things up */

	go to attach_return;

     end abort_attach;


clean_up:
     procedure;

/* clean up procedure for cleanup condition and abort_attach,  kills the attempted attachment */

	if adp ^= null then free adp -> ad in (my_area);

	if dibp ^= null
	then if dib.n_attached < 1 then do;
		if dib.next_iocbp ^= null then do;
		     call iox_$close (dib.next_iocbp, (0));
						/* just in case */
		     call iox_$detach_iocb (dib.next_iocbp, (0));
		     end;

		call delete_dib (dibp);		/* drop it */
		end;

	iocbp -> iocb.attach_descrip_ptr = null;
	iocbp -> iocb.attach_data_ptr = null;

	return;

     end clean_up;


handler:
     procedure;

/* This proc handles faults that occur while masked */

	if mask then call hcs_$reset_ips_mask (mask, mask);
	mask = "0"b;

	call continue_to_signal_ (code);
	return;

     end handler;
%page;
flip_com_err_sw:
     entry;

/* this entry is for testing so the state of the static com_err_sw can be changed */

	static_com_err_sw = ^static_com_err_sw;

	call ioa_ ("The static switch is now ^[on^;off^].", static_com_err_sw);

	return;
%page;
%include iocb;
%include iox_modes;
%include io_call_info;
%include event_wait_info;

     end tty_printer_;




		    tty_printer_conv_.alm           02/02/88  1702.2r w 02/02/88  1538.3       52155



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************


" tty_printer_conv_ - co-routine for prt_conv_ to be used
" from the remote_teleprinter_ and remote_printer_
" IO modules when attaching through the tty_printer_ IO module.
"
"	coded 4/79 by J. C. Whitmore (with print_conv_ and ibm2780_conv_ as guides)
"

	include	stack_header

	include	prt_conv_info

	name	tty_printer_conv_

	segdef	tty_printer_conv_
	segdef	teleprinter
	segdef	printer

	even
	tempd	saved_lp
	temp	char,VTstop,residue,last_print,a_reg,temp1,temp2

tty_printer_conv_:
teleprinter:
printer:
	tra	print_send_init
	tra	print_send_chars
	tra	print_send_slew_pattern
	tra	print_send_slew_count

" 
" Entry called at beginning of conversion

print_send_init:
	stz	last_print	no print positions used yet
	ldq	lb|pci.line	get current line or end of slew
	sbq	lb|pci.slew_residue	calc actual line for this call
	sbq	1,dl		.. cause VT stops are at 11 ...
	div	10,dl		compute starting VT stop
	stq	VTstop		save tab stop of current line
	sta	residue		save number of lines from current tab stop
	tra	sb|0		return

" 

print_send_chars:
"
" Here we are to write out the number of chars given in "au" after
" putting out the number of white spaces shown in X2.
" We are starting from the char position defined by last_print
"
	eax2	0,2		set indicators from X2
	tmoz	nospace		if no white space, skip following

	sta	a_reg		save the printable char count
	sprilp	saved_lp		save the current lp
	epaq	*		get our seg no in au
	epbplp	sp|0		find the stack base
	lprplp	lp|stack_header.lot_ptr,*au	get static ptr in lp
	ldq	lp|send_ht	see if we can send HT chars
	tmoz	no_ht		if not just use space chars

	ldq	last_print	look for current HT stop
	div	10,dl		get starting HT stop in ql
	stq	temp1		save this
	sta	temp2		save positions after stop
	eaq	0,2		get space count in Q
	qrs	18		move to ql
	adq	last_print	get target position
	div	10,dl		get total tabs to target
	sbq	temp1		convert to relative tabs
"				spaces beyond last tab are in al
	tze	no_ht		if none, just use spaces

	mlr	(),(pr,rl),fill(011)
	desc9a	*,0		move nothing...
	desc9a	bb|0,ql		but fill with "ql" tabs
	a9bd	bb|0,ql		move output pointer past the tabs

	eax2	0,al		put the remaining space count back in x2
	lda	10,dl
	sba	temp2		get spaces for first tab
	sta	temp2		and save it
	sbq	1,dl		take first tab from count
	mpy	10,dl		get spaces for other tabs
	adq	temp2		get total spaces
	asq	last_print	update the last position used

no_ht:	lda	a_reg		restore the original A register
	epp4	saved_lp,*	restore the lp
	mlr	(),(pr,rl),fill(040)  insert blanks into output
	desc9a	*,0		..
	desc9a	bb|0,x2		..

	a9bd	bb|0,2		step output pointer over blanks
	eaq	0,2		get the space count
	qrs	18		..into ql
	asq	last_print	and update the last position used
	eax2	0		set white space count back to zero

nospace:	mlr	(pr,rl),(pr,rl)	copy characters into output
	desc9a	bp|0,au		..
	desc9a	bb|0,au		..

	a9bd	bp|0,au		step input and output pointers
	a9bd	bb|0,au		..

	ars	18		move char count to al
	asa	last_print	and update the position count
	als	18		restore it, just in case
	tra	sb|0		return to caller

" 

print_send_slew_pattern:
"
" The A contains the pattern to search for 000 -> FF, 013 -> TOIP, 011 -> TOOP.
" But, for tty_printer_conv_ we can only assume the device supports a FF and no
" other patterns.  So, always give a form feed for this entry.
"
	lda	ffchar
	sta	char

stslew:	mlr	(pr),(pr)		move the slew char in "char" to output string
	desc9a	char,1		..
	desc9a	bb|0,1		..
	ldq	1,dl
	a9bd	bb|0,ql		move output pointer past the slew char
	tra	sb|0		return to caller


nlchar:	vfd	o9/012
crchar:	vfd	o9/015
vtchar:	vfd	o9/013
ffchar:	vfd	o9/014
" 
print_send_slew_count:
"
" When called at this entry, the count of the number of lines to slew
" is in the A register (al).  If the target device can accept VT chars
" to get to the target line, we will try to send them instead of
" writting out the slew count as NL chars.
"
	cmpa	1,dl		try to optomize for CR and NL alone
	tmoz	no_vt

	sta	a_reg		save the slew count for later
	sprilp	saved_lp		save the current lp
	epaq	*		get our seg no in au
	epbplp	sp|0		find the stack base
	lprplp	lp|stack_header.lot_ptr,*au	get static ptr in lp
	ldq	lp|send_vt	see if we can send VT chars at all
	tmoz	send_nl		if not send NL chars

	ldq	lb|pci.line	pickup target of slew
	sbq	1,dl		correct for tabs at 11, 21,...
	div	10,dl		get total VT stops in ql
	sbq	VTstop		reduce the total VT count by current VTstop
	tze	send_nl		if not passing a stop, send new_lines

	ldq	vtchar		put out one VT char for this call
	stq	char		save where stslew can find it
	ldq	10,dl		max lines per stop to ql
	sbq	residue		compute number of lines slewed by VT
	stq	temp1		..
	epp4	saved_lp,*
	lda	a_reg		restore the original slew count
	sba	temp1		reduce the slew count by lines slewed
	tra	stslew		let common code do the work

send_nl:	epp4	saved_lp,*	restore the lp
	lda	a_reg
no_vt:	ldq	crchar
	sba	1,dl		one at a time
	tmi	2,ic
	ldq	nlchar
	stq	char
	tra	stslew
"
" EXTERNAL VARIABLES - to be set by the IO module to control
" which slew characters can be put into the output string.
"
	use internal_static
	join	/link/internal_static

	segdef	send_vt
	segdef	send_ht


send_vt:
	even
	vfd	o36/0		if zero, don't output VT chars

send_ht:

	vfd	o36/0		if zero, don't output HT chars



	end




		    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
