


		    PNOTICE_rje.alm                 04/02/85  1516.9r w 04/02/85  1516.8        2853


	dec	1			"version 1 structure
	dec	1			"no. of pnotices
	dec	3			"no. of STIs
	dec	100			"lgth of all pnotices + no. of pnotices
          acc       "Copyright (c) 1972 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"C1RJEM0B0000"
	aci	"C2RJEM0B0000"
	aci	"C3RJEM0B0000"
	end
   



		    ibm2780_.pl1                    08/08/90  1040.5rew 08/08/90  1038.5      227745


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


/****^  HISTORY COMMENTS:
  1) change(90-06-13,Vu), approve(90-06-13,MCR8178), audit(90-07-13,Bubric),
     install(90-08-08,MR12.4-1023):
     ibm2780_ gets "size" condition after 99 attaches.
                                                   END HISTORY COMMENTS */


/* ibm2780_: An I/O module for communicating with an IBM 2780 or its equivilent. */

/* Coded March 1977 by David Vinograd */

ibm2780_: proc;

/* 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  charp ptr;
dcl  attach_tag picture "99";
dcl  input_chars fixed bin;				/* number of characters to transmitted */
dcl  num_chars_rec fixed bin;				/* number of characters recieved */
dcl  code fixed bin (35);
dcl  iocbp ptr;
dcl  mask bit (36) aligned;				/* For setting ips mask */
dcl  i fixed bin (21);
dcl  j fixed bin;
dcl  k fixed bin;
dcl  open_mode fixed bin;
dcl  device char (32);
dcl  remaining_chars fixed bin (21);
dcl  data_chars fixed bin (21);
dcl  order char (32);
dcl  infop ptr;
dcl  prefix char (2) var;
dcl  input char (400) var;
dcl  output char (400) var;
dcl  ctl_string char (256) var;
dcl  card_image char (80) var;
dcl  comm_attach_name char (32) var;
dcl  terminal_attach_options char (256) var;
dcl  comm_attach_options char (256) var;
dcl  comm_attach_desc char (256) var;
dcl  comm char (32) var;
dcl  tty char (32) var;
dcl  dummy_arg char (32);
dcl  carriage_ctl_string char (8) ;
dcl  slew_ctl_string char (6) ;
dcl  temp_iocbp ptr;
dcl  char_mode_set bit (1);
dcl  multi_record_cnt fixed bin;
dcl  trans_mode_set bit (1);

dcl 1 send_nontransparent aligned,
    2 len fixed bin,
    2 char_string char (256);

dcl 1 local_bsc_modes like set_bsc_modes aligned;

dcl 1 set_bsc_modes aligned based (infop),
    2 transparent bit (1) unal,
    2 char_mode bit (1) unal,
    2 pad bit (34) unal;

/* Internal static */

/* ..... the next six variables should be per comm attachment rather than int static */

dcl  last_select char (32) int static;			/* last device selected */
dcl  comm_iocbp ptr int static init (null);
dcl  quit_mode bit (1) int static init ("0"b);
dcl  EM char (1) int static init ("");
dcl  attach_count fixed bin init (0) int static;
dcl  comm_open bit (1) int static init ("0"b);


dcl  default_carriage_ctl_table (4) char (4) aligned static init ("/", "/", "S", "T");
dcl  carriage_ctl_table (4) char (4) aligned static init ((4) (4)" ");
dcl  default_slew_ctl_table (6) char (4) aligned static init ("    ", "A", "   ",
     "A", "   	", "A");
dcl  slew_ctl_table (6) char (4) aligned static init ((6) (4)" ");
dcl  printer_select char (2) int static init ("/");
dcl  punch_select char (2) int static init ("4");

/* Constants */

dcl  terminal_device_name char (8) int static options (constant) init ("ibm2780_");
dcl  space char (1) static int init (" ") options (constant);
dcl  carriage_control_char fixed bin int static init (1) options (constant);

/* External stuff */

dcl  convert_string_$input entry (char (*) var, ptr, char (*) var, fixed bin (35));
dcl  convert_string_$output entry (char (*) var, ptr, char (*) var, fixed bin (35));
dcl  get_ttt_info_ entry (ptr, fixed bin (35));
dcl  continue_to_signal_ entry (fixed bin (35));
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  release_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  iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
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_$get_chars entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35));
dcl  iox_$put_chars 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 (addr, addrel, bin, char, convert, copy, hbound, length, ltrim) builtin;
dcl (min, mod, null, rtrim, substr) builtin;

dcl  ibm2780_conv_$slew_ctl_table_ptr ptr ext;
dcl  ibm2780_conv_$carriage_ctl_table_ptr ptr ext;
dcl  sys_info$max_seg_size fixed bin ext;
dcl  error_table_$bad_conversion fixed bin (35) ext;
dcl  error_table_$bisync_bid_fail ext fixed bin (35);
dcl  error_table_$no_operation fixed bin (35) ext;
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_$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  conversion condition;
dcl  cleanup condition;
dcl  quit condition;
dcl  any_other condition;

dcl  info_fixed fixed bin based (infop);
dcl  info_string char (32) based (infop);
dcl  char_string char (80) based (charp);

%include ibm2780_data;
%include remote_ttt_info;
%include iocb;
%include iox_modes;
%include io_call_info;

/* Attach entry point */

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

	iocbp = a_iocbp;
	com_err_sw = a_sw;
	code, a_code = 0;

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

	call get_temp_segment_ (terminal_device_name, adp, code); /* Temp segment for attach data */
	if code ^= 0 then call abort_attach ("Unable to allocate temp segment.", "");

/* Initialize IOCB variables */

	ad.bits = "0"b;
	ad.fixed = 0;
	ad.ptrs = null;
	ad.chars = "";
	ad.printer_select = printer_select;
	ad.punch_select = punch_select;
	ad.char_mode = ebcdic;
	ad.record_len = 80;
	ad.phys_line_length = 80;

	ad.kill_char = "@";
	ad.erase_char = "#";
	ad.ttt_ptrs = null;
	ad.ttt_bits = "1"b;

	if comm_iocbp = null then do;
	     carriage_ctl_table (*) = default_carriage_ctl_table (*);
	     ibm2780_conv_$carriage_ctl_table_ptr = addr (carriage_ctl_table);
	     slew_ctl_table (*) = default_slew_ctl_table (*);
	     ibm2780_conv_$slew_ctl_table_ptr = addr (slew_ctl_table);
	end;

/* Process options */

	if hbound (a_option, 1) < 1 then do;		/* Must be at least one */
	     code = error_table_$wrong_no_of_args;
	     call abort_attach ("Bad attach description.", "");
	end;
	trans_mode_set, char_mode_set = "0"b;
	comm_attach_desc, comm_attach_options = "";
	tty, comm = "";
	terminal_attach_options = "";
	comm_attach_name = "";
	do i = 1 to hbound (a_option, 1);
	     if a_option (i) = "-size" then do;
		code = error_table_$badopt;
		call abort_attach ("bad option", ((a_option (i))));
	     end;
	     if a_option (i) ^= "-comm" then
		terminal_attach_options = terminal_attach_options || space || a_option (i);
	     if a_option (i) = "-transparent" then do;
		ad.transparent = "1"b;
		trans_mode_set = "1"b;
		comm_attach_options = comm_attach_options || space || a_option (i);
	     end;
	     else if a_option (i) = "-terminal_type" | a_option (i) = "-ttp" then do;
		ad.terminal_type = get_arg ();
		call get_ttt_info_ (addr (ad.remote_ttt_info), code);
		if code ^= 0 then call abort_attach ("Unable to set terminal type tables", "");
	     end;
	     else if a_option (i) = "-carriage_ctl" then do;
		carriage_ctl_string = get_arg ();
		do j = 1 to 4;
		     carriage_ctl_table (j) = substr (carriage_ctl_string, (j * 2) - 1, 2);
		end;
	     end;
	     else if a_option (i) = "-slew_ctl" then do;
		slew_ctl_string = get_arg ();
		do j = 1 to 3;
		     slew_ctl_table (j*2) = substr (slew_ctl_string, (j * 2) -1, 2);
		end;
	     end;
	     else if a_option (i) = "-nontransparent" then do;
		trans_mode_set = "1"b;
		ad.transparent = "0"b;
		comm_attach_options = comm_attach_options || space || a_option (i);
	     end;
	     else if a_option (i) = "-ascii" then do;
		char_mode_set = "1"b;
		ad.char_mode = ascii;
		comm_attach_options = comm_attach_options || space || a_option (i);
	     end;
	     else if a_option (i) = "-ebcdic" then do;
		char_mode_set = "1"b;
		ad.char_mode = ebcdic;
		comm_attach_options = comm_attach_options || space || a_option (i);
	     end;
	     else if a_option (i) = "-multi_record" then ad.multi_record = "1"b;
	     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) = "-multi_point" then
		ad.terminal_id = get_arg ();
	     else if a_option (i) = "-printer_select" then
		ad.printer_select = get_arg ();
	     else if a_option (i) = "-punch_select" then
		ad.punch_select = get_arg ();
	     else if a_option (i) = "-device" then dummy_arg = get_arg (); /* skip this one, but record we got it */
	     else if a_option (i) = "-tty" then
		tty = get_arg ();
	     else if a_option (i) = "-comm" then do;
		i = i + 1;
		if i > hbound (a_option, 1) then goto no_arg;
		comm = a_option (i);
	     end;
	     else comm_attach_options = comm_attach_options || space || a_option (i);
	end;

	if tty = "" then do;
	     code = error_table_$badopt;
	     call abort_attach ("No ""-tty"" option given.", "");
	end;

	if comm = "" then do;
	     code = error_table_$badopt;
	     call abort_attach ("No ""-comm"" option given.", "");
	end;

/* cross check attach descriptions */

	if ^char_mode_set then comm_attach_options = comm_attach_options || " -ebcdic";
	if ^trans_mode_set then comm_attach_options = comm_attach_options || " -nontransparent";

	if ad.multi_record then do;
	     ad.record_len = 400;
	     comm_attach_options = comm_attach_options || " -size 400 -multi_record 7";
	end;
	else comm_attach_options = comm_attach_options || " -size 80";

	if ad.char_mode = ascii & ad.transparent then do;
	     code = error_table_$badopt;
	     call abort_attach ("Unsupported attachment mode", "");
	end;

/* Compare attach description with on-line description of device */

	call check_attach_description;
	if code ^= 0 then call abort_attach ("Attach  mismatch on  option ^a", ((a_option (i))));

/* Attach through comm dim */

	/* use attach_count as comm_tag, use at least two digits */
	if attach_count < 100 then do;
	     attach_tag = attach_count;
	     comm_attach_name = terminal_device_name || attach_tag;
	  end;
	else comm_attach_name = terminal_device_name || ltrim(char(attach_count));
	attach_count = attach_count + 1;
	last_select = "";
	comm_attach_desc = comm || space || tty || space || comm_attach_options;
	if comm_iocbp = null then do;
	     call iox_$attach_ioname ((comm_attach_name), temp_iocbp, (comm_attach_desc), code);
	     if code ^= 0 then call abort_attach ("Unable to attach to comm channel", "");
	     comm_iocbp = temp_iocbp;
	end;

	ad.attach_desc = terminal_device_name || space || comm || space || terminal_attach_options;

/* 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 = ibm2780_open;
	iocbp -> iocb.detach_iocb = ibm2780_detach;
	call iox_$propagate (iocbp);
	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)));


/* Detach entry point */

ibm2780_detach: entry (a_iocbp, a_code);

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

	if comm_iocbp ^= null then do;
	     call iox_$detach_iocb (comm_iocbp, a_code);
	     comm_iocbp = null;
	end;

	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;

	call release_temp_segment_ (terminal_device_name, adp, (0));
	return;

/* Open entry point */

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

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

	if ^comm_open & comm_iocbp ^= null then do;
	     call iox_$open (comm_iocbp, a_mode, "0"b, a_code);
	     if a_code ^= 0 then return;
	     comm_open = "1"b;
	end;

	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 = ibm2780_get_chars;
	end;
	if ((open_mode = Stream_output) | (open_mode = Stream_input_output)) then do;
	     iocbp -> iocb.put_chars = ibm2780_put_chars;
	end;
	iocbp -> iocb.control = ibm2780_control;
	iocbp -> iocb.position = ibm2780_position;
	iocbp -> iocb.modes = ibm2780_modes;
	iocbp -> iocb.close = ibm2780_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;

/* Close entry point */

ibm2780_close: entry (a_iocbp, a_code);

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

	if comm_iocbp ^= null then do;
	     call iox_$close (comm_iocbp, a_code);
	     comm_open = "0"b;
	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 = ibm2780_open;
	iocbp -> iocb.detach_iocb = ibm2780_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;

/* Put_chars entry point */

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

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	code, a_code = 0;
	if comm_iocbp = null then do;
	     a_code = error_table_$no_operation;
	     return;
	end;
	adp = iocbp -> iocb.attach_data_ptr;

	if a_data_chars < 0 | a_data_chars > sys_info$max_seg_size * 4 then do;
	     a_code = error_table_$bad_arg;
	     return;
	end;
	remaining_chars = a_data_chars;		/* This is decremented as data is sent */
	charp = a_data_ptr;
	do while (remaining_chars > 0);
	     call put_string;
	     if code ^= 0 then goto put_chars_ret;
	end;
put_chars_ret:
	a_code = code;
	return;

/* Get_chars entry point */

ibm2780_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;
	code, a_code = 0;
	if comm_iocbp = null then do;
	     a_code = error_table_$no_operation;
	     return;
	end;
	a_data_chars, data_chars = 0;
	remaining_chars = a_buf_chars;
	charp = a_buf_ptr;

	call get_string;
get_chars_ret:
	a_code = code;
	a_data_chars = data_chars;
	return;

/* Control entry point */

ibm2780_control: entry (a_iocbp, a_order, a_infop, a_code);

	iocbp = a_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	infop = a_infop;
	order = a_order;
	code, a_code = 0;
	if comm_iocbp = null then goto nop;
	if order = "set_bsc_modes" then do;
	     ad.transparent = set_bsc_modes.transparent;
	     if set_bsc_modes.char_mode then ad.char_mode = ebcdic;
	     else ad.char_mode = ascii;
	     call iox_$control (comm_iocbp, order, infop, code);
	     if code ^= 0 then goto control_ret;
	     if ad.multi_record then multi_record_cnt = 7;
	     else multi_record_cnt = 1;
	     if ad.multi_record then
		call iox_$control (comm_iocbp, "set_multi_record_mode", addr (multi_record_cnt), code);
	end;
	else if order = "select_device" then do;
	     if info_string = last_select then go to control_ret; /* already there */
	     last_select = info_string;
	     if info_string = teleprinter then
		ad.device_type = printer;
	     else if info_string = printer | info_string = punch then
		ad.device_type = info_string;
	     else do;
nop:		code = error_table_$no_operation;
		goto control_ret;
	     end;
	     call select_device;
	     if ad.device_type = printer then call init_printer;
	end;
	else if order = "set_multi_record_mode" then do;
	     ad.multi_record = "1"b;
	     if info_fixed > 7 | info_fixed < 1 then do;
		code = error_table_$no_operation;
		goto control_ret;
	     end;
	     goto do_control;
	end;
	else if order = "io_call" then call ibm2780_io_call;
	else if order = "reset" then ad.edited = "1"b;
	else
do_control:
	call iox_$control (comm_iocbp, order, infop, code);
control_ret:
	a_code = code;
	return;

/* Position entry point */

ibm2780_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 comm_iocbp = null then do;
	     a_code = error_table_$no_operation;
	     return;
	end;
	call iox_$position (comm_iocbp, a_pos_type, a_pos_value, a_code);
	return;

ibm2780_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 a_new_modes = "non_edited" then
	     ad.edited = "0"b;
	else if a_new_modes = "default" then
	     ad.edited = "1"b;
	else code = error_table_$bad_mode;
	return;

check_attach_description: proc;

/* This proc compares the input attach description  with the one on line and returns an error
   if there is a mismatch. */

	end check_attach_description;

cv_dec_arg: proc returns (fixed bin);

	     i = i + 1;				/* Advance to next arg */
	     if i > hbound (a_option, 1) then goto no_arg;
	     terminal_attach_options = terminal_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 option array */
	     i = i + 1;
	     if i > hbound (a_option, 1) then goto no_arg;
	     terminal_attach_options = terminal_attach_options || space || a_option (i);
	     return ((a_option (i)));

	end get_arg;


abort_attach: proc (str1, str2);
dcl (str1, str2) char (*) aligned;

/* This proc handles attach errors */

	     if com_err_sw then call com_err_ (code, terminal_device_name, str1, str2);
	     a_code = code;
	     if comm_iocbp ^= null then do;
		call iox_$detach_iocb (comm_iocbp, (0));
		comm_iocbp = null;
	     end;
	     if adp ^= null then
		call release_temp_segment_ (terminal_device_name, adp, code);
	     go to attach_return;

	end abort_attach;

select_device: proc;

/* This proc selects the device and the terminal */

	     if ad.terminal_id ^= "" then do;
		if ad.device_type = printer then
		     ctl_string = ad.terminal_id || ad.printer_select || ENQ;
		else if ad.device_type = punch then
		     ctl_string = ad.terminal_id || ad.punch_select || ENQ;
		else return;
	     end;
	     else do;
		if ad.device_type = punch then ctl_string = ad.punch_select;
		else if ad.device_type = printer then ctl_string = ad.printer_select;
		else return;
	     end;
	     call write_nontransparent;
	     return;

	end select_device;

set_tabs:	proc;

/* This proc sets the tabs of the selected terminal. */

	     ctl_string = ESC || HT;			/* control prefix */
	     do i = 1 to ad.phys_line_length;
		if mod (i, 10) = 0 then substr (ctl_string, i, 1) = HT;
	     end;
	     call write_nontransparent;
	     return;

	end set_tabs;

put_string: proc;

/* This proc writes the data contained in input. */

	     input_chars = min (remaining_chars, ad.record_len);
	     input = substr (char_string, 1, input_chars);
	     remaining_chars = remaining_chars - input_chars;
	     charp = addr (substr (char_string, input_chars + 1, 1));
	     if ^quit_mode then do;
		if ad.transparent then do;
		     if ad.device_type = punch then input = input || copy (" ", 80-length (input));
		     else if ad.device_type = printer then
			input = input || copy (" ", ad.phys_line_length + carriage_control_char - length (input));
		end;
		prefix = "";
		k = 1;
		if ad.device_type ^= punch then do;
		     k = 3;
		     ad.escape_output = "0"b;
		     call convert_string_$output (substr (input, 1, 2), addr (ad.remote_ttt_info), prefix, code);
		     ad.escape_output = "1"b;
		     if code ^= 0 then return;
		end;
		call convert_string_$output (substr (input, k), addr (ad.remote_ttt_info), output, code);
		if code ^= 0 then return;
		output = prefix || output;
retry:		call iox_$put_chars (comm_iocbp, addrel (addr (output), 1), length (output), code);
		if code = error_table_$bisync_bid_fail then do;
		     on cleanup begin;
			quit_mode = "0"b;
		     end;
		     quit_mode = "1"b;
		     signal quit;
		     quit_mode = "0"b;
		     goto retry;
		end;
	     end;
	     return;

	end put_string;

get_string: proc;

/* This proc reads  data into the variable card_image up to the preset length */

	     call iox_$get_chars (comm_iocbp, addrel (addr (card_image), 1), 80, num_chars_rec, code);
	     if code ^= 0 then return;
	     card_image = substr (card_image, 1, num_chars_rec);
	     call convert_string_$input (card_image, addr (ad.remote_ttt_info), card_image, code);
	     if code ^= 0 then return;
	     if substr (card_image, num_chars_rec, 1) = EM then
		card_image = substr (card_image, 1, num_chars_rec -1);
	     char_string = card_image;
	     data_chars = data_chars + length (card_image);
	     charp = addr (substr (char_string, length (card_image) + 1, 1));
	     remaining_chars = remaining_chars - length (card_image);
	     return;

	end get_string;


ibm2780_io_call: proc;

/* This proc  handles the io_call orders by  mapping then into control order calls to this dim */

	     io_call_infop = infop;
	     order = io_call_info.order_name;
	     if order = "set_bsc_modes" then do;
		local_bsc_modes.char_mode = (ad.char_mode = ebcdic);
		local_bsc_modes.transparent = ad.transparent;
		do i = 1 to hbound (io_call_info.args, 1);
		     if io_call_info.args (i) = "ascii" then local_bsc_modes.char_mode = "0"b;
		     else if io_call_info.args (i) = "ebcdic" then local_bsc_modes.char_mode = "1"b;
		     else if io_call_info.args (i) = "transparent" then local_bsc_modes.transparent = "1"b;
		     else if io_call_info.args (i) = "nontransparent" then local_bsc_modes.transparent = "0"b;
		end;
		call iox_$control (iocbp, order, addr (local_bsc_modes), code);
		if code ^= 0 then return;
	     end;
	     else if order = "select_device" then do;
		device = io_call_info.args (1);
		call iox_$control (iocbp, order, addr (device), code);
	     end;
	     else if order = "set_multi_record_mode" then do;
		multi_record_cnt = convert (multi_record_cnt, io_call_info.args (1));
		call iox_$control (iocbp, order, addr (multi_record_cnt), code);
	     end;
	     else call iox_$control (comm_iocbp, "io_call", infop, code);
	     return;

	end ibm2780_io_call;

init_printer: proc;

/* This proc initializes the printer, setting tabs if required */

	     if ad.ht then call set_tabs;
	     return;

	end init_printer;

handler:	proc;

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

	     call continue_to_signal_ (code);
	     return;

	end handler;
write_nontransparent: proc;

/* This proc sends the data in ctl_string in a nontransparent mode */


	     ad.escape_output = "0"b;
	     call convert_string_$output (ctl_string, addr (ad.remote_ttt_info), ctl_string, code);
	     ad.escape_output = "1"b;
	     if code ^= 0 then return;
	     send_nontransparent.char_string = ctl_string;
	     send_nontransparent.len = length (ctl_string);
	     call iox_$control (comm_iocbp, "send_nontransparent_msg", addr (send_nontransparent), code);

	     return;

	end write_nontransparent;
     end ibm2780_;
   



		    ibm2780_conv_.alm               02/02/88  1719.8r w 02/02/88  1538.2       30618


" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"ibm2780_conv_ - Conversion routine for producing ascii IBM2780 printer output
"	Coded March 1977 by David Vinograd

" 1) Version -- for new Printer DIM.

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


"
" The manner in which this procedure is utilized is described in detail
" in the listing of prt_conv_.
"
" This proc puts carriage control chars
" at the beginning of each output line.


	name	ibm2780_conv_

	segdef	printer
	segdef	punch
	segdef	teleprinter

	tempd	init_outp
	tempd	saved_outp
	tempd	saved_lp
	tempd	saved_sb

	tempd	saved_aq
	include	stack_header
	temp	carriage_ctl
	equ	pci,5
	equ	outp,3
	equ	inp,2


teleprinter:
printer:
	tra	send_init
	tra	send_chars
	tra	send_slew_pattern
	tra	send_slew_count

punch:
	tra	pr7|0
	tra	send_chars
	tra	pr7|0
	tra	no_slew
no_slew:
	lda	0,du
	tra	pr7|0


" 

	include	prt_conv_info


" 

send_init:

	spri3	init_outp		store output ptr
	ldq	2,dl		advance output ptr
	a9bd	outp|0,ql		..
	tra	pr7|0		return

" 

send_chars:
	eax2	0,2		set indicators from X2
	tmoz	nospace		if no white space, skip following

	mlr	(),(pr,rl),fill(040)  insert blanks into output
	desc9a	*,0		..
	desc9a	outp|0,x2		..

	a9bd	outp|0,2		step output pointer over blanks

nospace:
	mlr	(pr,rl),(pr,rl)	copy characters into output
	desc9a	inp|0,au		..
	desc9a	outp|0,au		..

	a9bd	inp|0,au		step input and output pointers
	a9bd	outp|0,au		..
	eax2	0		make sure X2 now zero
	tra	pr7|0		return to caller

" 

send_slew_pattern:
	eax7	0		initialize for search
	sprilp	saved_lp
	sprisb	saved_sb
	epbpsb	sp|0
	staq	saved_aq
	epaq	*
	lprplp	sb|stack_header.lot_ptr,*au
	ldaq	saved_aq
	equ	nslew,6
	epplp 	lp|slew_ctl_table_ptr,*
	rpt	nslew/2,2,tze	search for slew characters
	cmpa	lp|0,7		..
	ldq	lp|-1,7

stslew:
	epplp	saved_lp,*
	eppsb	saved_sb,*
	stq	carriage_ctl	save carriage control chars
	spri3	saved_outp	store output ptr
	epp3	init_outp,*	move ptr to register
	mlr	(pr),(pr)		move carriage control into output
	desc9a	carriage_ctl,2	..
	desc9a	pr3|0,2		..
	epp3	saved_outp,*	restore orignal output ptr
	tra	pr7|0		return to caller


send_slew_count:
	eaq	0,al		line count in QU
	sbla	3,dl		can slew at most 3 lines at a time
	tmoz	*+2		if more than 3 lines,
          ldq       3,du                do only 3 to start
	sprilp	saved_lp
	sprisb	saved_sb
	epbpsb	sp|0
	staq	saved_aq
	epaq	*
	lprplp	sb|stack_header.lot_ptr,*au
	ldaq	saved_aq
	ldq	lp|carriage_ctl_table_ptr,*qu
	eppsb	saved_sb,*
	epplp	saved_lp,*
	tra	stslew		and store it for later

	use internal_static
	join	/link/internal_static
	segdef	carriage_ctl_table_ptr
	segdef	slew_ctl_table_ptr
carriage_ctl_table_ptr:
	even
	its	-1,1
slew_ctl_table_ptr:
	its	-1,1


	end
  



		    ibm3780_.pl1                    08/08/90  1040.5rew 08/08/90  1037.8      445176


/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1984 *
        *                                                         *
        *********************************************************** */

/* ibm3780_: An I/O module for communicating with an IBM 3780. */

/* Coded:     March 1977 by David Vinograd */
/* Modified:  1979 April by Art Beattie to accept abbreviated control
	    arguments, set default pll for printer to 120, and check for
	    required tty and comm control arguments. */
/* Rewritten: February 1984 by Allan Haggett because it did not work so well.
	    Of the things done differently in this version, the
	    multiplexing of multiple ibm3780_ attachments over a single
	    bisync_ attachment is the most important change. */
/* Modified:  July 1984 by Laurent Hazard to fix space expansion. */


/****^  HISTORY COMMENTS:
  1) change(86-07-28,Beattie), approve(86-07-28,MCR7483),
     audit(86-09-03,Brunelle), install(86-09-03,MR12.0-1144):
     Modify interpretation of 512 character limit to include protocol overhead.
  2) change(90-06-13,Vu), approve(90-06-13,MCR8178), audit(90-07-13,Bubric),
     install(90-08-08,MR12.4-1023):
     ibm3780_ gets "size" condition after 99 attaches.
                                                   END HISTORY COMMENTS */


/* * 
   *  Each ibm3780_ switch of a station is attached to a single bisync_
   *  switch. For each bisync_ attachment maintain a Comm Info Block
   *  (A rose is a rose ...) which describes the current state of affairs
   *  in the bisync_ world. Each ibm3780_ switch's "cib" is pointed to by
   *  "ad.cib_ptr".
   *
   *  In order for this to work, we depend upon a "select_device" control
   *  order being issued before resuming operations on a new ibm3780_
   *  switch (device). This allows us to change the characteristics of the
   *  bisync_ attachment to suit the ibm3780_ device about to be used.
* */

/* format: style4,indattr,ifthenstmt,ifthen,^indcomtxt,^indproc,indcom,comcol56 */
ibm3780_: procedure ();

	return;

/**** Parameters */

dcl  P_iocb_ptr	        pointer parameter;
dcl  P_code	        fixed bin (35) parameter;
dcl  P_attach_options       (*) char (*) varying parameter; /* attach */
dcl  P_loud_sw	        bit (1) parameter;	     /* attach */
dcl  P_open_mode	        fixed bin parameter;	     /* open */
dcl  P_ignore_sw	        bit (1) parameter;	     /* open */
dcl  P_inbuf_ptr	        pointer parameter;	     /* get_chars: ptr to user buffer */
dcl  P_inbuf_len	        fixed bin (21) parameter;  /* get_chars: length of user buffer */
dcl  P_inbuf_count	        fixed bin (21) parameter;  /* get_chars: count of char's we are returning */
dcl  P_outbuf_ptr	        pointer parameter;	     /* put_chars: ptr to user buffer */
dcl  P_outbuf_len	        fixed bin (21) parameter;  /* put_chars: count of char's to write */
dcl  P_pos_type	        fixed bin parameter;	     /* position */
dcl  P_pos_value	        fixed bin (21) parameter;  /* position */
dcl  P_order	        char (*) parameter;	     /* control: the order */
dcl  P_info_ptr	        pointer parameter;	     /* control: order info structure */
dcl  P_new_modes	        char (*) parameter;	     /* modes */
dcl  P_old_modes	        char (*) parameter;	     /* modes */

/**** Automatic */

dcl  ad_initialized_sw      bit (1);		     /* Attach data is meaningful? */
dcl  char_string_ptr        pointer;
dcl  code		        fixed bin (35);
dcl  unrecognized_attach_options char (256) varying;
dcl  data_count	        fixed bin (21);
dcl  option_comm	        char (32);
dcl  option_tty	        char (32);
dcl  info_ptr	        pointer;
dcl  iocb_ptr	        pointer;
dcl  loud_sw	        bit (1);		     /* Set if com_err_ sould be called on attach error */
dcl  ips_mask	        bit (36) aligned;
dcl  open_mode	        fixed bin;
dcl  order	        char (32);
dcl  converted_chars        char (512) varying;
dcl  remaining_count        fixed bin (21);
dcl  system_free_area_ptr   pointer;
dcl  two_digits             picture "99";

dcl  1 set_bsc_modes_auto   like info_set_bsc_modes aligned;

/**** Based */

dcl  info_string	        char (32) based (info_ptr);
dcl  char_string	        char (80) based (char_string_ptr);
dcl  system_free_area       area aligned based (system_free_area_ptr);

/**** Used by "control" entry. */
dcl  1 info_read_status     aligned based (info_ptr),
       2 event_channel      fixed bin (71),
       2 input_pending      bit (1);

dcl  1 info_set_bsc_modes   aligned based (info_ptr),
       2 transparent        bit (1) unal,
       2 ebcdic_sw	        bit (1) unal,
       2 pad	        bit (34) unal;


/**** Internal static and constants. */

dcl  static_attach_count    fixed bin init (0) int static;
dcl  static_conv_proc_initialized_sw bit (1) static init ("0"b); /* Per process */
/**** CIB list head and tail. */
dcl  first_cib_ptr	        pointer internal static init (null ());
dcl  last_cib_ptr	        pointer internal static init (null ());

dcl  BASE_VALUE	        fixed bin internal static options (constant) init (64);
dcl  IBM3780_BIGGEST_BUFFER_SIZE fixed bin internal static options (constant) init (512);
dcl  PROTOCOL_OVERHEAD      fixed bin internal static options (constant) init (8);

dcl  IRS		        char (1) internal static options (constant) init ("");
dcl  IGS		        char (1) internal static options (constant) init ("");
dcl  ME		        char (32) init ("ibm3780_") internal static options (constant);
dcl  NL		        char (1) internal static options (constant) init ("
");
dcl  DEFAULT_PRINTER_SELECT char (1) internal static options (constant) init ("");
dcl  DEFAULT_PUNCH_SELECT   char (1) internal static options (constant) init ("");
dcl  SPACE	        char (1) internal static options (constant) init (" ");
dcl  SPACE_CHAR	        (2) char (1) internal static options (constant) init (" ", "@"); /* ASCII & EBCDIC */
dcl  (LOWERCASE	        init ("abcdefghijklmnopqrstuvwxyz"),
     UPPERCASE	        init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ")) char (26) internal static options (constant);
dcl  DEFAULT_CARRIAGE_CTL_TABLE (4) char (4) aligned internal static options (constant) init ("M", "/", "S", "T");
dcl  DEFAULT_SLEW_CTL_TABLE (6) char (4) aligned internal static options (constant)
		        init ("    ",	     /* (4) NUL */
		        "A",		     /* ESC A   */
		        "   ",					     /* (3) NUL VT */
		        "A",		     /* ESC A   */
		        "   	",	     /* (3) NUL TAB */
		        "A");		     /* ESC A   */

/**** Entries */

dcl  com_err_	        entry options (variable);
dcl  continue_to_signal_    entry (fixed bin (35));
dcl  convert_string_$input  entry (char (*) var, pointer, char (*) var, fixed bin (35));
dcl  convert_string_$output entry (char (*) var, pointer, char (*) var, fixed bin (35));
dcl  cu_$arg_list_ptr       entry () returns (pointer);
dcl  cu_$arg_ptr	        entry (fixed bin, pointer, fixed bin (21), fixed bin (35));
dcl  cv_dec_check_	        entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  get_system_free_area_  entry returns (pointer);
dcl  get_ttt_info_	        entry (pointer, 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  ibm3780_io_call_control_ entry (pointer, pointer, pointer, fixed bin (35));
dcl  ioa_$rsnnl	        entry options (variable);
dcl  ioa_$general_rs        entry (pointer, fixed bin, fixed bin, char (*), fixed bin, bit (1) aligned, bit (1) aligned);

/**** External */

dcl  (error_table_$action_not_performed,
     error_table_$bad_arg,
     error_table_$bad_conversion,
     error_table_$bad_mode,
     error_table_$badopt,
     error_table_$bisync_bid_fail,
     error_table_$inconsistent,
     error_table_$no_operation,
     error_table_$noarg,
     error_table_$not_attached,
     error_table_$not_closed,
     error_table_$not_detached,
     error_table_$not_open,
     error_table_$null_info_ptr,
     error_table_$wrong_no_of_args) fixed bin (35) external static;
dcl  ibm3780_conv_$transparent fixed bin external;
dcl  ibm3780_conv_$slew_ctl_table_ptr pointer external;
dcl  ibm3780_conv_$carriage_ctl_table_ptr pointer external;
dcl  sys_info$max_seg_size  fixed bin external;


dcl  (any_other, cleanup, quit) condition;

dcl  (addr, after, before, char, codeptr, copy, divide, fixed,
     hbound, lbound, length, ltrim, maxlength, min, null, rtrim, 
     search, substr, translate, unspec) builtin;
%page;
	/* Attach an IO switch to a new or existing comm switch. */

ibm3780_attach:
     entry (P_iocb_ptr, P_attach_options, P_loud_sw, P_code);

	/* Copy parameters and make gullibility check. */
	iocb_ptr = P_iocb_ptr;
	loud_sw = P_loud_sw;
	code, P_code = 0;


	if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_detached;
	     if loud_sw then call com_err_ (P_code, ME, "Switch ^a.", iocb_ptr -> iocb.name);
	     return;
	end;

	adp = null ();			     /* No attach data yet. */
	ad_initialized_sw = "0"b;		     /* ... */
	cib_ptr = null ();
	system_free_area_ptr = get_system_free_area_ ();

	on condition (cleanup) call attach_cleaner ();

	if hbound (P_attach_options, 1) < 4 then
	     call abort_attach (error_table_$wrong_no_of_args,
		"At least ""-comm"" and ""-tty"" must be supplied.");

	/* One time: Put some defaults here. These values also live in the */
	/* attach data and are set at each "select_device". */
	if ^static_conv_proc_initialized_sw then do;
	     ibm3780_conv_$carriage_ctl_table_ptr = addr (DEFAULT_CARRIAGE_CTL_TABLE);
	     ibm3780_conv_$slew_ctl_table_ptr = addr (DEFAULT_SLEW_CTL_TABLE);
	     ibm3780_conv_$transparent = 0;
	     static_conv_proc_initialized_sw = "1"b;
	end;

	/* Setup default attach data. */
	call allocate_attach_data ();
	ad_initialized_sw = "1"b;		     /* Trust it now. */

	ad.attach_desc = rtrim (ME);		     /* ibm3780_ */
	unrecognized_attach_options = "";	     /* Pass these to comm module. */
	option_tty, option_comm = "";

	/* Simply move this loop into its own procedure. It may punt. */
	call process_attach_options ();

	/* Do we have all required options -comm and -tty ? */
	if option_comm = "" then call abort_attach (error_table_$noarg, """-comm""");
	if option_tty = "" then call abort_attach (error_table_$noarg, """-tty""");

	/* Cross-check attach options. */
	if (ad.char_mode = ASCII & ad.transparent) then
	     call abort_attach (error_table_$inconsistent, "^/Control arguments -ascii and -transparent.");

	if ad.phys_line_length = 0 then	     /* We will decide? */
	     if ad.device_type = PRINTER then ad.phys_line_length = 120;
	     else ad.phys_line_length = 80;

	/* These values are taken from old ibm3780_ code. */
	if (^ad.transparent | ad.multi_record) then
	     ad.record_len = IBM3780_BIGGEST_BUFFER_SIZE;
	else ad.record_len = ad.phys_line_length;

	/* See this procedure for notes. */
	call set_ad_multirecord_info ();

	/* Find a Comm Info Block for this channel. */
	do cib_ptr = first_cib_ptr repeat (cib_ptr -> cib.chain.next_cib_ptr) while (cib_ptr ^= null ());
	     if cib_ptr -> cib.device_channel = option_tty then
		goto CHANNEL_HAS_CIB;
	end;

	/* Fell through... have to create a new CIB. */
	call cib_create (cib_ptr);		     /* Allocate it. */
	cib.device_channel = option_tty;

CHANNEL_HAS_CIB:				     /* Ith switch for this CIB. */
	ad.cib_ptr = cib_ptr;		     /* Have to get at switch's CIB. */

	/* Do we have to attach the comm module? */
	if ^cib.attached_sw then do;		     /* Once per target channel. */

	     /* See this procedure for fascinating notes. */
	     call attach_comm_module (option_comm, option_tty, unrecognized_attach_options, cib.comm_iocb_ptr);
	     cib.attached_sw = "1"b;
	end;

	/* Make changes and tell anyone concerned. */
	ips_mask = ""b;
	on condition (any_other) call any_other_handler ();

	call hcs_$set_ips_mask ((""b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = addr (ad.attach_desc);
	iocb_ptr -> iocb.attach_data_ptr = adp;
	iocb_ptr -> iocb.open = ibm3780_open;
	iocb_ptr -> iocb.detach_iocb = ibm3780_detach;

	/* This switch is now officially using this CIB. */
	cib.n_attached = cib.n_attached + 1;

	call iox_$propagate (iocb_ptr);

	revert condition (cleanup);		     /* All is OK now. */

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	revert condition (any_other);		     /* Not our fault. */

ATTACH_RETURN:				     /* Non local target for abort_attach. */
	return;
%page;
ibm3780_detach:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr;
	P_code = 0;

	/* Just be sure it is attached and opened. */
	if iocb_ptr -> iocb.attach_descrip_ptr = null () then do;
	     P_code = error_table_$not_attached;
	     return;
	end;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	/* Looks good so finish initialization. */
	system_free_area_ptr = get_system_free_area_ ();
	adp = iocb_ptr -> iocb.attach_data_ptr;
	cib_ptr = ad.cib_ptr;

	/* Remove knowledge of this switch from the CIB. */
	cib.n_attached = cib.n_attached - 1;

	call attach_cleaner ();		     /* Maybe free the CIB too. */

	ips_mask = ""b;			     /* Complete IOCB. */

	on condition (any_other) call any_other_handler ();
	call hcs_$set_ips_mask ((""b), ips_mask);

	iocb_ptr -> iocb.attach_descrip_ptr = null ();
	iocb_ptr -> iocb.attach_data_ptr = null ();
	iocb_ptr -> iocb.detach_iocb = iox_$err_not_attached;
	iocb_ptr -> iocb.open = iox_$err_not_attached;
	iocb_ptr -> iocb.control = iox_$err_not_attached;

	call iox_$propagate (iocb_ptr);
	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	revert condition (any_other);

	return;
%page;
ibm3780_open:
     entry (P_iocb_ptr, P_open_mode, P_ignore_sw, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_code = 0;

	if iocb_ptr -> iocb.open_descrip_ptr ^= null () then do;
	     P_code = error_table_$not_closed;
	     return;
	end;

	open_mode = P_open_mode;

	/* We support SI, SO, and SIO. Comm switch is always SIO though. */
	if ^((open_mode = Stream_input) | (open_mode = Stream_output) | (open_mode = Stream_input_output)) then do;
	     P_code = error_table_$bad_mode;
	     return;
	end;

	adp = iocb_ptr -> iocb.attach_data_ptr;
	cib_ptr = ad.cib_ptr;

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

	/* Is this the first open for this comm? */
	if ^cib.opened_sw then do;
	     call open_comm_module (P_code);
	     if P_code ^= 0 then return;	     /* Has to work. */
	     else cib.opened_sw = "1"b;
	end;

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();
	call hcs_$set_ips_mask ((""b), ips_mask);

	if ((open_mode = Stream_input) | (open_mode = Stream_input_output)) then do;
	     iocb_ptr -> iocb.get_chars = ibm3780_get_chars;
	     iocb_ptr -> iocb.get_line = ibm3780_get_line;
	end;

	if ((open_mode = Stream_output) | (open_mode = Stream_input_output)) then
	     iocb_ptr -> iocb.put_chars = ibm3780_put_chars;

	iocb_ptr -> iocb.control = ibm3780_control;
	iocb_ptr -> iocb.position = ibm3780_position;
	iocb_ptr -> iocb.modes = ibm3780_modes;
	iocb_ptr -> iocb.close = ibm3780_close;
	iocb_ptr -> iocb.detach_iocb = ibm3780_detach;

	/* Make it officially open. */
	iocb_ptr -> iocb.open_descrip_ptr = addr (ad.open_description);

	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	revert condition (any_other);

	return;
%page;
ibm3780_close:
     entry (P_iocb_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_code = 0;

	if iocb_ptr -> iocb.open_descrip_ptr = null () then do; /* Closed. */
	     P_code = error_table_$not_open;
	     return;
	end;

	adp = iocb_ptr -> iocb.attach_data_ptr;
	cib_ptr = ad.cib_ptr;

	/* Close the comm switch if this is the last ibm3780 switch on it. */
	if cib.opened_sw then
	     if cib.n_attached <= 1 then do;
		call iox_$close (cib.comm_iocb_ptr, (0));
		cib.opened_sw = "0"b;
	     end;

	ips_mask = ""b;

	on condition (any_other) call any_other_handler ();
	call hcs_$set_ips_mask ((""b), ips_mask);

	iocb_ptr -> iocb.open_descrip_ptr = null ();

	iocb_ptr -> iocb.open = ibm3780_open;
	iocb_ptr -> iocb.detach_iocb = ibm3780_detach;

	iocb_ptr -> iocb.control,
	     iocb_ptr -> iocb.position,
	     iocb_ptr -> iocb.modes,
	     iocb_ptr -> iocb.get_chars,
	     iocb_ptr -> iocb.get_line,
	     iocb_ptr -> iocb.put_chars = iox_$err_no_operation;

	call iox_$propagate (iocb_ptr);
	call hcs_$reset_ips_mask (ips_mask, ips_mask);

	revert condition (any_other);

	return;
%page;
/****^ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *   							       *
 *   Control Notes:						       *
 *							       *
 *   There is a crock here which will work as long as users of this IO       *
 *   module use the "select_device" order before initiating a new series     *
 *   of IO operations for a device. We take this as a cue to perform any     *
 *   necessary reconfiguration of the comm connection to suite the device    *
 *   selected. We also have to set static in the ibm3780_conv_ module so     *
 *   that the hacking performed by "prt_conv_", as called from someone       *
 *   like "remote_printer_" BEFORE calling iox_$put_chars, will result       *
 *   in the right transformations for this device. Not pretty...	       *
 *							       *
 *   All identifiers beginning with "info_" are based on "info_ptr".	       *
 *							       *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

ibm3780_control:
     entry (P_iocb_ptr, P_order, P_info_ptr, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	order = P_order;
	info_ptr = P_info_ptr;
	P_code, code = 0;

	adp = iocb_ptr -> iocb.attach_data_ptr;
	cib_ptr = ad.cib_ptr;

	/* Be compatible with old ibm3780_. */
	if cib.comm_iocb_ptr = null () then do;
	     P_code = error_table_$no_operation;
	     return;
	end;

	if order = "select_device" then do;	     /* setup device */

	     call reject_null_info ();

	     if info_string = TELEPRINTER then
		ad.device_type = PRINTER;
	     else if (info_string = PRINTER | info_string = PUNCH) then
		ad.device_type = info_string;
	     else do;			     /* Unknown device. Code is for compatibility. */
		P_code = error_table_$no_operation;
		return;
	     end;

	     if iocb_ptr = cib.last_selected_iocb_ptr then /* Last select over bisync_ was for this switch? */
		if ad.device_type = ad.last_selected_device then /* And we are selecting the same device? */
		     return;		     /* Optimize at a certain risk. */

	     call select_device (code);	     /* Select it and set */
	     if code ^= 0 then goto CONTROL_RETURN;
	     call configure_comm (code);	     /* up bisync_ for it. */
	     if code ^= 0 then goto CONTROL_RETURN;

	     /* It all worked so... */
	     cib.last_selected_iocb_ptr = iocb_ptr;
	     ad.last_selected_device = ad.device_type;

	end;				     /* select_device */

	else if order = "set_bsc_modes" then do;

	     call reject_null_info ();

	     ad.transparent = info_set_bsc_modes.transparent;
	     if info_set_bsc_modes.ebcdic_sw then
		ad.char_mode = EBCDIC;
	     else ad.char_mode = ASCII;

	     /* This informs bisync_ of changes. */
	     call configure_comm (code);

	end;				     /* set_bsc_modes */

	else if order = "set_multi_record_mode" then do;

	     ad.multi_record = "1"b;
	     goto PASS_CONTROL_ORDER;

	end;				     /* set_multi_record_mode */

	else if order = "runout" | order = "end_write_mode" then do;

	     call write_buffer ();
	     ad.output_buf = "";
	     goto PASS_CONTROL_ORDER;

	end;				     /* runout */

	else if order = "resetwrite" then do;

	     ad.output_buf = "";
	     goto PASS_CONTROL_ORDER;

	end;				     /* resetwrite */

	else if order = "resetread" then do;

	     ad.input_buf = "";
	     goto PASS_CONTROL_ORDER;

	end;				     /* resetread */

	else if order = "reset" then ad.edited = "1"b;
	else if order = "io_call" then
	     call ibm3780_io_call_control_ (adp, iocb_ptr, info_ptr, code);

	/* See if this is understood by comm module. */
	else do;
PASS_CONTROL_ORDER:
	     call iox_$control (cib.comm_iocb_ptr, order, info_ptr, code);
	end;

	/* Postprocessing: We have a say in read_status order. */
	if code = 0 then			     /* Comm took it. */
	     if order = "read_status" then	     /* And it was this. */
		info_read_status.input_pending = (length (ad.input_buf) > 0 | info_read_status.input_pending);

CONTROL_RETURN:
	P_code = code;			     /* Pass back any error. */
	return;


/**** Control entry procedure to make sure we have an info pointer. */
reject_null_info:
     procedure ();

	if info_ptr ^= null () then return;	     /* Continue... */

	code = error_table_$null_info_ptr;
	goto CONTROL_RETURN;

     end reject_null_info;
%page;
/**** This code is from old module. Note that the old module would never
      return a non-zero code, so we do not either. */

ibm3780_modes:
     entry (P_iocb_ptr, P_new_modes, P_old_modes, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_old_modes = "";			     /* No modes are passed back. */
	P_code = 0;

	if P_new_modes = "" then return;

	adp = iocb_ptr -> iocb.attach_data_ptr;

	if P_new_modes = "non_edited" then
	     ad.edited = "0"b;
	else if P_new_modes = "default" then
	     ad.edited = "1"b;
	else ;				     /* Old module would assign error to */
					     /* automatic variable, then return! */

	return;
%page;
ibm3780_position:
     entry (P_iocb_ptr, P_pos_type, P_pos_value, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_code = 0;

	adp = iocb_ptr -> iocb.attach_data_ptr;
	cib_ptr = ad.cib_ptr;

	call iox_$position (cib.comm_iocb_ptr, P_pos_type, P_pos_value, P_code);

	return;
%page;
/**** Get_line and get_chars perform the same operation (compatible with old). */

ibm3780_get_line:
ibm3780_get_chars:
     entry (P_iocb_ptr, P_inbuf_ptr, P_inbuf_len, P_inbuf_count, P_code);

	/*
   This procedure along with get_string do not seem to make any
   real use of the variable remaining_count, and assume that the caller
   has provided a big enough buffer to hold an entire card image.
   This is probably okay, but I'm not sure and it should be looked
   into in the near future. - CLM */

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_code = 0;

	adp = iocb_ptr -> iocb.attach_data_ptr;
	cib_ptr = ad.cib_ptr;
	code = 0;

	P_inbuf_count, data_count = 0;	     /* Count of char's read. */
	remaining_count = P_inbuf_len;	     /* We can return this many. */
	char_string_ptr = P_inbuf_ptr;

	call get_string ();			     /* Do it here. */

GET_CHARS_RETURN:				     /* Update the output parameters from auto's. */
	P_code = code;
	P_inbuf_count = data_count;

	return;
%page;
ibm3780_put_chars:
     entry (P_iocb_ptr, P_outbuf_ptr, P_outbuf_len, P_code);

	iocb_ptr = P_iocb_ptr -> iocb.actual_iocb_ptr;
	P_code = 0;

	adp = iocb_ptr -> iocb.attach_data_ptr;
	cib_ptr = ad.cib_ptr;
	code = 0;

	if (P_outbuf_len < 0 | P_outbuf_len > sys_info$max_seg_size * 4) then do;
	     P_code = error_table_$bad_arg;
	     return;
	end;

	remaining_count = P_outbuf_len;
	char_string_ptr = P_outbuf_ptr;

	do while (remaining_count > 0);
	     call put_string ();
	     if code ^= 0 then goto PUT_CHARS_RETURN;
	end;

PUT_CHARS_RETURN:
	P_code = code;

	return;
%page;
/**** This is the procedure which does all the work for "get_chars".
      It returns the data in card_image to the user buffer. */

get_string:
     procedure ();

dcl  card_image	        char (80) varying;	     /* Card readers *always* send 80 characters. */
dcl  igs_pos	        fixed bin (21);
dcl  space_cnt	        fixed bin;

	if (length (ad.input_buf)) = 0 then
	     call read_buffer ();

	if ad.transparent then do;
	     if ad.multi_record then do;

		/* Need those 80 characters. */
		if length (ad.input_buf) < 80 then
		     call read_buffer ();	     /* Get more from comm. */
		card_image = substr (ad.input_buf, 1, 80);

		if length (ad.input_buf) > 80 then
		     ad.input_buf = substr (ad.input_buf, 81);
		else ad.input_buf = "";
	     end;
	     else do;
		card_image = ad.input_buf;
		ad.input_buf = "";
	     end;
	end;

	else do;				     /* Not transparent. */

	     /* If no IRS in buffer, then read some more. */
	     if search (ad.input_buf, IRS) = 0 then
		call read_buffer ();

	     card_image = before (ad.input_buf, IRS);
	     ad.input_buf = after (ad.input_buf, IRS);

	     /* Hack space compression. */
	     igs_pos = search (card_image, IGS);
	     do while (igs_pos > 0);
		space_cnt = fixed (unspec (substr (card_image, (igs_pos + 1), 1)), 9) - BASE_VALUE;
		card_image = substr (card_image, 1, (igs_pos - 1)) || copy (SPACE_CHAR (ad.char_mode), space_cnt)
		     || substr (card_image, (igs_pos + 2));
		igs_pos = search (card_image, IGS);
	     end;
	end;

	call convert_string_$input (card_image, addr (ad.ttt_info), converted_chars, code);
	if code ^= 0 then return;

	/* Copy bytes and update state. */
	char_string = converted_chars;
	data_count = data_count + length (converted_chars);
	char_string_ptr = substraddr (char_string, (length (converted_chars) + 1));
	remaining_count = remaining_count - length (card_image);

	return;


/**** Internal procedure of "get_string" to read data into the variable
      card_image up to the preset length.  We handle the case where there are
      characters already in our input buffer but we have been called to get
      more.  This allows us to go after a character we need (ie.  IRS) but
      did not get from comm last time.  */

read_buffer:
     procedure ();

dcl  n_read	        fixed bin (21);
dcl  n_not_processed        fixed bin (21);	     /* Now in buffer. */

	n_not_processed = length (ad.input_buf);     /* Could be zero. */
	if n_not_processed >= ad.record_len then return;


	call iox_$get_chars (cib.comm_iocb_ptr,
	     substraddr (ad.input_buf, (n_not_processed + 1)), /* Fill from here. */
	     (ad.record_len - n_not_processed),	     /* Up to this many. */
	     n_read, code);

	if code ^= 0 then goto GET_CHARS_RETURN;     /* Has to work. */

	ad.input_buf = substr (ad.input_buf, 1, (n_read + n_not_processed));

	return;

     end read_buffer;

     end get_string;
%page;
/**** This is the procedure which does all the work for "put_chars". It takes
      user data in chunks and puts it in the output buffer. This code is almost
      identical to that in the old ibm3780_ module. */

put_string:
     procedure ();

dcl  input	        char (512) varying;
dcl  input_count	        fixed bin;		     /* Number of characters to transmit. */
dcl  (igs_pos, igs_found_pos) fixed bin;
dcl  substring	        char (512) varying;

	input_count = min (remaining_count, ad.record_len);
	input = substr (char_string, 1, input_count);
	converted_chars = "";

	if ad.device_type ^= PUNCH then do;
	     ad.ttt_info.escape_output = "0"b;
	     call convert_string_$output (substr (input, 1, 2), addr (ad.ttt_info), converted_chars, code);
	     ad.ttt_info.escape_output = "1"b;
	     if code ^= 0 then return;
	     igs_found_pos = 3;
	end;
	else igs_found_pos = 1;

	igs_pos = search (substr (input, igs_found_pos), IGS);
	do while (igs_pos > 0);
	     call convert_string_$output (substr (input, igs_found_pos, igs_pos), addr (ad.ttt_info), substring, code);
	     if code ^= 0 then return;
	     igs_found_pos = igs_found_pos + igs_pos + 1;
	     converted_chars = converted_chars || substring;
	     converted_chars = converted_chars || substr (input, igs_found_pos - 1, 1);
	     igs_pos = search (substr (input, igs_found_pos), IGS);
	end;
	call convert_string_$output (substr (input, igs_found_pos), addr (ad.ttt_info), substring, code);
	if code ^= 0 then return;

	converted_chars = converted_chars || substring;

	if ad.transparent then do;
	     ad.output_buf = converted_chars;
	     call write_buffer ();
	     if code ^= 0 then return;
	     ad.output_buf = "";
	end;
	else do;

	     /* If we cannot stuff anymore, then we add IRS and write it. */
	     if length (ad.output_buf) + length (converted_chars) >= ad.record_len then do;
		call write_buffer ();
		if code ^= 0 then return;
		ad.output_buf = "";
	     end;
	     ad.output_buf = ad.output_buf || converted_chars || IRS;
	end;

	remaining_count = remaining_count - input_count;
	char_string_ptr = substraddr (char_string, (input_count + 1));
	return;

     end put_string;
%page;
/**** This is probably a crock. Anyway, this code is taken directly from old module. */

write_buffer:
     procedure ();

	if ^cib.in_quit_state_sw then do;	     /* This BISYNC_ is healthy? */
WRITE_BUFFER_RETRY:

	     call iox_$put_chars (cib.comm_iocb_ptr, substraddr (ad.output_buf, 1), length (ad.output_buf), code);
	     if code = 0 then return;

	     /* Check for bad bisync_ lossage. */
	     else if code = error_table_$bisync_bid_fail then do;

		on condition (cleanup) begin;
		     cib.in_quit_state_sw = "0"b;
		end;

		cib.in_quit_state_sw = "1"b;
		signal condition (quit);
		cib.in_quit_state_sw = "0"b;
		goto WRITE_BUFFER_RETRY;

	     end;
	end;

	return;

     end write_buffer;
%page;
/**** Select the device (ad.device_type) and the terminal (ad.terminal_id). */
select_device:
     procedure (P_code);

dcl  P_code	        fixed bin (35) parameter;

dcl  control_string	        char (256) varying;	     /* Send this. */
dcl  tab_pos	        fixed bin;

	P_code = 0;

	/* A non-null terminal ID means we have to prepend it to select. */
	if ad.terminal_id ^= "" then do;	     /* Have to send this? */
	     if ad.device_type = PRINTER then
		control_string = ad.terminal_id || ad.printer_select;
	     else if ad.device_type = PUNCH then
		control_string = ad.terminal_id || ad.punch_select;
	     else return;			     /* No select. */

	     control_string = control_string || ENQ;
	end;

	else do;				     /* No terminal ID. */
	     if ad.device_type = PRINTER then
		control_string = ad.printer_select;
	     else if ad.device_type = PUNCH then
		control_string = ad.punch_select;
	     else return;
	end;

	/* Do the actual select. This procedure, which is internal, writes "control_string". */
	call write_nontransparent ();

	/* May have to set tabs if we are selecting printer. */
	if (ad.device_type = PRINTER & ad.has_tabs) then do;

	     /* Clear control string forcibly. */
	     substr (control_string, 1, maxlength (control_string)) = "";

	     control_string = ESC || HT;	     /* Control prefix. */

	     /* Put a tab every 10th column. */
	     do tab_pos = 10 by 10 while (tab_pos < ad.phys_line_length);
		substr (control_string, tab_pos, 1) = HT;
	     end;

	     control_string = control_string || NL;
	     call write_nontransparent ();

	end;				     /* printer init */

WRITE_NONTRANSPARENT_ERROR:			     /* Our code parameter is set, return now. */
	return;


/****^ Internal procedure of "select_device". We transmit "control_string"
       in nontransparent mode in a single block.  We use "P_code" and return
       if any error is encountered. */

write_nontransparent:
     procedure ();

	ad.ttt_info.escape_output = "0"b;
	call convert_string_$output (control_string, addr (ad.ttt_info), control_string, P_code);
	ad.ttt_info.escape_output = "1"b;
	if P_code ^= 0 then goto WRITE_NONTRANSPARENT_ERROR;

	/* The old ibm3780_ copied data to a varying string overlay before calling bisync_. We do not. */

	call iox_$control (cib.comm_iocb_ptr, "send_nontransparent_msg", addr (control_string), P_code);
	if P_code ^= 0 then goto WRITE_NONTRANSPARENT_ERROR;

	return;

     end write_nontransparent;

     end select_device;
%page;
/****^ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *   							       *
 *   A "select_device" is being performed. We have multiple switches, each   *
 *   with a different requirement as to how the single comm (bisync_)	       *
 *   switch should be configured. We simply reconfigure to characteristics   *
 *   in the attach data for this switch. This is not fool-proof of course.   *
 *							       *
 *   This is also called at open time to be sure that BISYNC world is ready. *
 *							       *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

configure_comm:
     procedure (P_code);

dcl  P_code	        fixed bin (35) parameter;
dcl  multi_record_count     fixed bin (35);

	/* First, set the static used for output pre-conversion. */
	ibm3780_conv_$carriage_ctl_table_ptr = addr (ad.carriage_ctl_table);
	ibm3780_conv_$slew_ctl_table_ptr = addr (ad.slew_ctl_table);
	ibm3780_conv_$transparent = fixed (ad.transparent, 35, 0);

	/* Tell BISYNC_ about transparency and character mode. */
	unspec (set_bsc_modes_auto) = ""b;
	set_bsc_modes_auto.transparent = ad.transparent;
	if ad.char_mode = EBCDIC then set_bsc_modes_auto.ebcdic_sw = "1"b;

	call iox_$control (cib.comm_iocb_ptr, "set_bsc_modes", addr (set_bsc_modes_auto), P_code);
	if P_code ^= 0 then return;		     /* Bad lossage. */

	call set_ad_multirecord_info ();	     /* Set multi-record info based on transparency. */

	multi_record_count = ad.multi_record_count;
	call iox_$control (cib.comm_iocb_ptr, "set_multi_record_mode", addr (multi_record_count), P_code);

	return;

     end configure_comm;
%page;
set_ad_multirecord_info:
     procedure ();

/****^ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *   							     *
 *   This code is taken from the old ibm3780_ IO module.  I am not sure    *
 *   why it is done exactly like this, but we will leave it until is is    *
 *   proven defective. This procedure is called at attach time, and 	     *
 *   whenever we have to set the characteristics of the comm attachment.   *
 *							     *
 *   Note that the bit ad.multi_record is redundant, as a count of 1 means *
 *   that it is not multi-record. See bisync_.pl1.
 *							     *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

	/* Set multi-record information based on transparency mode. */
	if ^ad.transparent then do;
	     ad.multi_record = "1"b;
	     ad.multi_record_count = 512;
	end;
	else if ad.multi_record then do;
	     ad.multi_record = "1"b;
	     ad.multi_record_count = 6;
	end;
	else do;
	     ad.multi_record = "0"b;
	     ad.multi_record_count = 1;
	end;

	return;

     end set_ad_multirecord_info;
%page;
/**** Usage: call abort_attach (code, ioa_args) */
abort_attach:
     procedure () options (variable, non_quick);


dcl  the_code	        fixed bin (35) based (the_code_ptr);
dcl  the_code_ptr	        pointer;

dcl  abort_msg	        character (256);

	call cu_$arg_ptr (1, the_code_ptr, (0), (0));

	if loud_sw then do;			     /* an error message is requested */
	     call ioa_$general_rs (cu_$arg_list_ptr (), 2, 3, abort_msg, (0), "1"b, "0"b);
	     call com_err_ (the_code, ME, "Switch ^a. ^a", iocb_ptr -> iocb.name, abort_msg);
	end;

	call attach_cleaner ();		     /* Undo any work. */

	if the_code = 0 then		     /* Caller must get non-zero code. */
	     P_code = error_table_$action_not_performed;
	else P_code = the_code;

	go to ATTACH_RETURN;

     end abort_attach;
%page;
/**** Attach entry calls us to alloc and init our attach block. */

allocate_attach_data:
     procedure ();

	allocate ad in (system_free_area) set (adp);
	unspec (ad) = ""b;
	ad.ptrs = null ();			     /* Get these level */
	ad.chars = "";			     /*    3 variables. */
	ad.printer_select = DEFAULT_PRINTER_SELECT;
	ad.punch_select = DEFAULT_PUNCH_SELECT;
	ad.char_mode = EBCDIC;		     /* Default. */
	ad.record_len = 80;
	ad.carriage_ctl_table (*) = DEFAULT_CARRIAGE_CTL_TABLE (*);
	ad.slew_ctl_table (*) = DEFAULT_SLEW_CTL_TABLE (*);
					     /* Initialize remote_ttt_info. */
	ad.ttt_info.ttt_ptrs = null ();	     /* Again, assigning */
	ad.ttt_info.ttt_bits = "1"b;		     /*    to level 3's. */
	ad.ttt_info.terminal_type = "";
	ad.ttt_info.kill_char = "@";
	ad.ttt_info.erase_char = "#";

	return;

     end allocate_attach_data;
%page;
/**** Attach entry procedure for processing attachment arguments. */

process_attach_options:
     procedure ();

dcl  arg_idx	        fixed bin;		     /* Current option. */
dcl  arg_len	        fixed bin (21);
dcl  arg_ptr	        pointer;
dcl  arg		        char (arg_len) based (arg_ptr); /* An attach option. */
dcl  ctl_string	        char (8) varying;	     /* For carriage and slew control. */

	do arg_idx = lbound (P_attach_options, 1) to hbound (P_attach_options, 1);

	     /* Set up "arg" and add option to attach description. */
	     call access_option (arg_idx);

	     /* Do not let this one get through. */
	     if arg = "-size" then
		call abort_attach (error_table_$badopt, "^a", arg);
	     else if arg = "-transparent" then ad.transparent = "1"b;
	     else if arg = "-nontransparent" then ad.transparent = "0"b;
	     else if arg = "-ebcdic" then ad.char_mode = EBCDIC;
	     else if arg = "-ascii" then ad.char_mode = ASCII;
	     else if arg = "-horizontal_tab" | arg = "-htab" then ad.has_tabs = "1"b;
	     else if arg = "-multi_record" then ad.multi_record = "1"b;
	     else if arg = "-multi_point" then
		ad.terminal_id = fetch_arg ("Terminal ID");
	     else if arg = "-printer_select" then
		ad.printer_select = fetch_arg ("Printer select character");
	     else if arg = "-punch_select" then
		ad.punch_select = fetch_arg ("Punch select character");
	     else if arg = "-physical_line_length" | arg = "-pll" then
		ad.phys_line_length = fetch_numarg ("Line length");
	     else if arg = "-terminal_type" | arg = "-ttp" then do;
		ad.terminal_type = fetch_arg ("Terminal type");
		ad.terminal_type = translate (ad.terminal_type, UPPERCASE, LOWERCASE);
		call get_ttt_info_ (addr (ad.ttt_info), code);
		if code ^= 0 then call abort_attach (code, "Cannot get ttt info for ""^a"".", arg);
	     end;

	     /* The old ibm3780_ never checked lengths, so I suppose we cannot either. */
	     else if arg = "-carriage_ctl" then do;
		ctl_string = fetch_arg ("Carriage control characters");
		call set_carriage_ctl (ctl_string, ad.carriage_ctl_table);
	     end;
	     else if arg = "-slew_ctl" then do;
		ctl_string = fetch_arg ("Slew control characters");
		call set_slew_ctl (ctl_string, ad.slew_ctl_table);
	     end;
	     else if arg = "-device" then do;
		ad.device_type = fetch_arg ("Device name");

		/* Compatibility: No checking on name here. */
	     end;

	     /* These next two are required arguments. */
	     else if arg = "-comm" then option_comm = fetch_arg ("Comm module name");
	     else if arg = "-tty" then option_tty = fetch_arg ("TTY channel name");

	     else do;
		unrecognized_attach_options = unrecognized_attach_options || SPACE;
		unrecognized_attach_options = unrecognized_attach_options || arg;
	     end;

	end;				     /* option processing loop */

	return;
%page;
/**** Internal procedures of "process_attach_options" for argument manipulation. */

access_option:
     procedure (P_arg_idx);

dcl  P_arg_idx	        fixed bin parameter;

	/* Make "arg" reference P_attach_option (P_arg_idx). Assert: P_arg_idx <= bound (P_attach_options, 1) */
	arg_ptr = substraddr (P_attach_options (P_arg_idx), 1);
	arg_len = length (P_attach_options (P_arg_idx));

	/* All options go into our attach description. */
	ad.attach_desc = ad.attach_desc || SPACE || arg;

	return;

     end access_option;


/**** Procedures for fetching a value of a control (the current) argument. */

fetch_arg:
     procedure (P_desc) returns (char (*));

dcl  P_desc	        char (*) parameter;
dcl  control_arg	        char (32);

	control_arg = arg;			     /* Save it for error. */

	if arg_idx = hbound (P_attach_options, 1) then
	     call abort_attach (error_table_$noarg, "^a following ""^a"".", P_desc, control_arg);

	arg_idx = arg_idx + 1;		     /* Something is there. */

	call access_option (arg_idx);		     /* Set up "arg". */

	if arg = "" then
	     call abort_attach (0, "^a for ""^a"" must be a non-null string.", P_desc, control_arg);

	return (arg);

     end fetch_arg;


/**** Same thing except we return a fixed bin. */

fetch_numarg:
     procedure (P_desc) returns (fixed bin (35));

dcl  P_desc	        char (*) parameter;
dcl  control_arg	        char (32);
dcl  numarg	        fixed bin (35);
dcl  code		        fixed bin (35);	     /* Just for us. */

	control_arg = arg;

	if arg_idx = hbound (P_attach_options, 1) then
	     call abort_attach (error_table_$noarg, "^a following ""^a"".", P_desc, control_arg);

	arg_idx = arg_idx + 1;

	call access_option (arg_idx);

	numarg = cv_dec_check_ (arg, code);

	if code ^= 0 then
	     call abort_attach (error_table_$bad_conversion,
		"^a for ""^a"" must be a number; not ""^a"".", P_desc, control_arg, arg);

	return (numarg);			     /* Some number. */

     end fetch_numarg;


/**** Passed a varying string, set a control table array in the attach data. */

set_carriage_ctl:
     procedure (P_string, P_table);

dcl  P_string	        char (8) varying aligned parameter;
dcl  P_table	        (*) char (4) aligned parameter;
dcl  idx		        fixed bin;

/****^	Take the characters from the string 2 at a time, putting each pair
	in the next element of the table (vector). There is already a default
	control table in the table, put there at attach data initialization
	time.  NOTE: We take characters up to the last *pair* only. The old
	ibm3780_ marched on whether he had no characters or an odd number of
	characters.  We also make sure that we do not try to stuff characters
	off the end of the array (see "min" function at loop start. We do
	assume, correctly, that tables have lbound of 1. */

	do idx = 1 to min (hbound (P_table, 1), divide (length (P_string), 2, 17, 0));
	     P_table (idx) = substr (P_string, ((idx * 2) - 1), 2);
	end;

	return;


/**** Slew control table lives in elements 2, 4, and 6 of a six element vec. */

set_slew_ctl:
     entry (P_string, P_table);


	/* As usual, strip off chars until we run out of chars of string or elements of array. */
	/* Note that we divide the hbound by 2 as we double idx in loop. */
	do idx = 1 to min (divide (hbound (P_table, 1), 2, 17, 0), divide (length (P_string), 2, 17, 0));
	     P_table (idx * 2) = substr (P_string, ((idx * 2) - 1), 2);
	end;

	return;

     end set_carriage_ctl;


     end process_attach_options;
%page;
attach_cleaner:				     /* Cleanup handler */
     procedure ();

	/* If we do not have attach data, then there is nothing to do. */
	if adp = null () then return;

	if ad_initialized_sw then do;		     /* Trust it? */
	     if ad.cib_ptr ^= null () then	     /* Using a CIB? */
		call cib_janitor (ad.cib_ptr);     /* Still need it? */
	end;

	/* Ok, now free our attach data. */
	free ad in (system_free_area);
	adp = null ();			     /* Be clean. */

	return;

     end attach_cleaner;
%page;
attach_comm_module:
     procedure (P_io_module_name, P_tty_channel, P_other_args, P_iocb_ptr) options (non_quick);

/****^ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 *   							     *
 *   For each CIB there is a comm attachment. There may be multiple	     *
 *   devices, and therefore switches, which are multiplexed over this	     *
 *   single unique attachment. We attach with the simplest attach	     *
 *   description possible, as per-device options are set for the comm	     *
 *   module at "select_device" time. The only option we must specify	     *
 *   at attach time is buffer size, as bisync_ will not allow us to	     *
 *   ask later for a buffer larger than that specified in the attach	     *
 *   options. We ask for the biggest we may need (512), plus some space    *
 *   for bisync_ overhead.					     *
 *							     *
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

dcl  P_io_module_name       char (32) parameter;	     /* Input */
dcl  P_tty_channel	        char (32) parameter;	     /* Input */
dcl  P_other_args	        char (256) varying parameter; /* Input */
dcl  P_iocb_ptr	        pointer parameter;	     /* Output */

dcl  switch_name	        char (32);
dcl  attach_desc	        char (256);
dcl  attach_code	        fixed bin (35);

          /* Allows up to 99 attachments (compatibility code). 
             but if there are more than 99 then attach as many
             as required (related bug fix phx17327.) */

          static_attach_count = static_attach_count + 1;

          if static_attach_count < 100 then do;
               two_digits = static_attach_count;
       	     switch_name = rtrim (ME) || two_digits;
            end;
          else
               switch_name = rtrim (ME) || ltrim(char(static_attach_count));

	call ioa_$rsnnl ("^a ^a -size ^d ^a", attach_desc, (0),
	     P_io_module_name, P_tty_channel,

	/* Some IBM3780 emulators don't want more than 512 including
	   overhead added by whatever protocol being used.
          */
	     (IBM3780_BIGGEST_BUFFER_SIZE - PROTOCOL_OVERHEAD),
	     P_other_args);

	call iox_$attach_name (switch_name, P_iocb_ptr, attach_desc, codeptr (ibm3780_), attach_code);
	if attach_code ^= 0 then call abort_attach (attach_code, "Cannot attach comm module.^/Attach description: ""^a"".", attach_desc);

	return;

     end attach_comm_module;
%page;
open_comm_module:
     procedure (P_code);

dcl  P_code	        fixed bin (35) parameter;

	P_code = 0;
	call iox_$open (cib.comm_iocb_ptr, Stream_input_output, ("0"b), P_code);

	/* If open worked, then finish off the BISYNC initialization. */
	/* This *must* be done now before user tries to use any switch. */
	if P_code = 0 then
	     call configure_comm ((0));

	return;

     end open_comm_module;
%page;
/**** Procedures for managing CIBlocks. */

cib_create:
     procedure (P_cib_ptr);

dcl  P_cib_ptr	        pointer parameter;

	allocate cib in (system_free_area) set (P_cib_ptr);
	unspec (P_cib_ptr -> cib) = ""b;
	P_cib_ptr -> cib.comm_iocb_ptr = null ();
	P_cib_ptr -> cib.last_selected_iocb_ptr = null ();
	P_cib_ptr -> cib.next_cib_ptr = null ();
	P_cib_ptr -> cib.prev_cib_ptr = last_cib_ptr;/* null if first. */

	/* Thread it in. */
	if first_cib_ptr = null () then	     /* Very first CIB. */
	     first_cib_ptr = P_cib_ptr;
	else last_cib_ptr -> cib.next_cib_ptr = P_cib_ptr;

	/* This is now the most recent. */
	last_cib_ptr = P_cib_ptr;
	return;


/**** Checks to see if CIB is still needed. */
cib_janitor:
     entry (P_cib_ptr);

	/* If we have a comm attachment but no ibm3780_ users on it, then remove the comm. */
	if P_cib_ptr -> cib.attached_sw then	     /* Bisync_ attached? */
	     if P_cib_ptr -> cib.n_attached < 1 then do; /* Ibm3780_ switches. */
		call iox_$close (P_cib_ptr -> cib.comm_iocb_ptr, (0));
		call iox_$detach_iocb (P_cib_ptr -> cib.comm_iocb_ptr, (0));
		P_cib_ptr -> cib.attached_sw = "0"b;

		/* If first CIB, then update head of list. */
		if P_cib_ptr -> cib.prev_cib_ptr = null () then
		     first_cib_ptr = P_cib_ptr -> cib.next_cib_ptr;

		/* Our forward pointer is bequeathed to previous block. */
		else P_cib_ptr -> cib.prev_cib_ptr -> cib.next_cib_ptr = P_cib_ptr -> cib.next_cib_ptr;

		/* Are we the tail? */
		if P_cib_ptr -> cib.next_cib_ptr = null () then
		     last_cib_ptr = P_cib_ptr -> cib.prev_cib_ptr; /* Update static. */

		/* Our backward pointer goes into our "next" CIB. */
		else P_cib_ptr -> cib.next_cib_ptr -> cib.prev_cib_ptr = P_cib_ptr -> cib.prev_cib_ptr;

		/* It is unthreaded... free it. */
		free P_cib_ptr -> cib in (system_free_area);
		P_cib_ptr = null ();	     /* Useless now. */
	     end;

	return;


     end cib_create;
%page;
/**** Handler for IPS masked code. */

any_other_handler:
     procedure ();

	/* Simply unmask and lateral. */
	if ips_mask then call hcs_$reset_ips_mask (ips_mask, ips_mask);
	ips_mask = ""b;

	call continue_to_signal_ ((0));
	return;

     end any_other_handler;
%page;
/**** SUBSTRADDR functions stolen from hasp_host_. */

/**** Return a pointer to the specified character of a varying or nonvarying string.  When the substraddr
      builtin function is finally implemented, these internal procedures should be removed */

dcl  substraddr	        generic (substraddr_nonvarying when (character (*) nonvarying, fixed binary precision (1:35)),
		        substraddr_varying when (character (*) varying, fixed binary precision (1:35)));


substraddr_nonvarying:
     procedure (P_string, P_position) returns (pointer);

dcl  P_string	        character (*) nonvarying parameter;
dcl  P_position	        fixed binary (21) parameter;

dcl  string_overlay	        (length (P_string)) character (1) unaligned based (addr (P_string));

	return (addr (string_overlay (P_position)));

     end substraddr_nonvarying;


substraddr_varying:
     procedure (P_string, P_position) returns (pointer);

dcl  P_string	        character (*) varying parameter;
dcl  P_position	        fixed binary (21) parameter;

dcl  1 string_overlay       aligned based (addr (P_string)),
       2 lth	        fixed binary (21),
       2 characters	        (0 refer (string_overlay.lth)) character (1) unaligned;

	return (addr (string_overlay.characters (P_position)));

     end substraddr_varying;

%page; %include ibm3780_data;
%page; %include remote_ttt_info;
%page; %include iocb;
%page; %include iox_entries;
%page; %include iox_modes;

     end ibm3780_;



		    ibm3780_conv_.alm               02/02/88  1719.8r w 02/02/88  1538.3       38673


" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"ibm3780_conv_ - Conversion routine for producing ascii IBM3780 printer output
"	Coded March 1977 by David Vinograd

" 1) Version -- for new Printer DIM.

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


"
" The manner in which this procedure is utilized is described in detail
" in the listing of prt_conv_.
"
" This proc puts carriage control chars
" at the beginning of each output line.


	name	ibm3780_conv_
	segdef	printer
	segdef	punch
	segdef	teleprinter

	tempd	init_outp
	tempd	saved_outp
	tempd	saved_lp
	tempd	saved_sb

	tempd	saved_aq
	include	stack_header
	temp	carriage_ctl
	equ	pci,5
	equ	outp,3
	equ	inp,2


teleprinter:
printer:
	tra	send_init
	tra	send_chars
	tra	send_slew_pattern
	tra	send_slew_count

punch:
	tra	pr7|0
	tra	send_chars
	tra	pr7|0
	tra	no_slew
no_slew:
	lda	0,du
	tra	pr7|0
" 

	include	prt_conv_info


" 

send_init:

	spri3	init_outp		store output ptr
	ldq	2,dl		advance output ptr
	a9bd	outp|0,ql		..
	tra	pr7|0		return

" 

send_chars:
	sprilp	saved_lp
	sprisb	saved_sb
	staq	saved_aq
	epbpsb	sp|0
	epaq	*
	lprplp	sb|stack_header.lot_ptr,*au
	ldq	lp|transparent
	tze	spaceloop
	eaq	0,2
	tmoz	nospace
	tra	spaceout
spaceloop:
	eaq	0,2		white space count in QU
	tmoz	nospace		skip if no white space
	sbx2	63,du		can take only 63 at a time
	tmoz	*+2		..
	ldq	63,du		if more, take 63 to begin with
	cmpq	3,du		if fewer than 3 spaces,
	tmi	blankout		insert blanks instead

	mlr	(),(pr)		insert  dup char
	desc9a	dupchar,1	..
	desc9a	bb|0,1		..

	mlr	(qu),(pr)		insert dup count character
	desc9a	duptable,1	..
	desc9a	bb|0(1),1		..

	ldq	2,dl		step output pointer
	a9bd	bb|0,ql		..
	tra	spaceloop		loop

blankout:	mlr	(),(pr,rl),fill(040)  insert requisite number of blanks
	desc9a	*,0		..
	desc9a	bb|0,qu		..

	a9bd	bb|0,qu		bump output pointer
	tra	spaceloop		and loop

spaceout:
	epplp	saved_lp,*
	eppsb	saved_sb,*
	mlr	(),(pr,rl),fill(040)
	desc9a	*,0
	desc9a	bb|0,2

	a9bd	bb|0,2
nospace:
	epplp	saved_lp,*
	eppsb	saved_sb,*
	ldaq	saved_aq
	mlr	(pr,rl),(pr,rl)	copy characters into output
	desc9a	inp|0,au		..
	desc9a	outp|0,au		..

	a9bd	inp|0,au		step input and output pointers
	a9bd	outp|0,au		..
	eax2	0		make sure X2 now zero
	tra	pr7|0		return to caller

" 

send_slew_pattern:
	eax7	0		initialize for search
	sprilp	saved_lp
	sprisb	saved_sb
	epbpsb	sp|0
	staq	saved_aq
	epaq	*
	lprplp	sb|stack_header.lot_ptr,*au
	ldaq	saved_aq
	equ	nslew,6
	epplp	lp|slew_ctl_table_ptr,*
	rpt	nslew/2,2,tze	search for slew characters
	cmpa	lp|0,7		..
	ldq	lp|-1,7

stslew:
	epplp	saved_lp,*
	eppsb	saved_sb,*
	stq	carriage_ctl	save carriage control chars
	spri3	saved_outp	store output ptr
	epp3	init_outp,*	move ptr to register
	mlr	(pr),(pr)		move carriage control into output
	desc9a	carriage_ctl,2	..
	desc9a	pr3|0,2		..
	epp3	saved_outp,*	restore orignal output ptr
	tra	pr7|0		return to caller


send_slew_count:
	eaq	0,al		line count in QU
	sbla	3,dl		can slew at most 3 lines at a time
	tmoz	*+2		if more than 3 lines,
          ldq       3,du                do only 3 to start
	sprilp	saved_lp
	sprisb	saved_sb
	epbpsb	sp|0
	staq	saved_aq
	epaq	*
	lprplp	sb|stack_header.lot_ptr,*au
	ldaq	saved_aq
	ldq	lp|carriage_ctl_table_ptr,*qu
	tra	stslew		and store it for later

dupchar:
	vfd	o9/035
duptable:
	aci	"@ABCDEFGHIJKLMNO"
	aci	"PQRSTUVWXYZ[\]^_"
	aci	"`abcdefghijklmno"
	aci	"pqrstuvwxyz{|}~"
	use internal_static
	join	/link/internal_static
	segdef	carriage_ctl_table_ptr
	segdef	slew_ctl_table_ptr
	segdef	transparent

transparent:
	oct	0
	even
carriage_ctl_table_ptr:
	its	-1,1
slew_ctl_table_ptr:
	its	-1,1


	end
   



		    ibm3780_io_call_control_.pl1    04/02/85  1515.7rew 04/02/85  1514.5       55377


/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */
/* Module called to handle io_call control orders. */

/* Written:  March 1984 by Allan Haggett. */

ibm3780_io_call_control_:
     procedure (P_attach_data_ptr, P_iocb_ptr, P_info_ptr, P_code);

/**** Parameters */

dcl  P_attach_data_ptr      pointer;
dcl  P_iocb_ptr	        pointer parameter;
dcl  P_info_ptr	        pointer parameter;	     /* To io_call_info */
dcl  P_code	        fixed bin (35);

/**** Automatic */

dcl  arg_count	        fixed bin;
dcl  caller	        character (32);
dcl  code		        fixed bin (35);
dcl  device	        character (32);	     /* For select_device */
dcl  idx		        fixed bin;
dcl  iocb_ptr	        pointer;
dcl  multi_record_count     fixed bin (35);
dcl  order	        character (32);	     /* From io_call_info. */
dcl  (report,
     error)	        entry variable options (variable);
dcl  1 set_bsc_modes        automatic,
       2 transparent        bit (1) unaligned,
       2 ebcdic_sw	        bit (1) unaligned,
       2 pad	        bit (34) unaligned;

/**** Constant */

dcl  SIMPLE_ORDERS	        (5) character (32) internal static options (constant)
		        init ("runout", "end_write_mode", "resetread", "resetwrite", "reset");

/**** Entries and external. */

dcl  cv_dec_check_	        entry (character (*), fixed bin (35)) returns (fixed bin (35));
dcl  iox_$control	        entry (ptr, character (*), ptr, fixed bin (35));

dcl  (error_table_$badopt,
     error_table_$noarg,
     error_table_$no_operation) fixed bin (35) external static;

dcl (addr, hbound, null) builtin;
%page;
	/* Copy parameters. */
	adp = P_attach_data_ptr;		     /* Attach Data Ptr */
	iocb_ptr = P_iocb_ptr;
	io_call_infop = P_info_ptr;		     /* See io_call_info.incl.pl1 */
	P_code = 0;

	/* Get a pointer to the CommInfoBlock for this switch. This is */
	/* a block of information about the single "bisync_" attachment. */
	cib_ptr = ad.cib_ptr;

	order = io_call_info.order_name;
	arg_count = io_call_info.nargs;
	caller = io_call_info.caller_name;
	error = io_call_info.error;
	report = io_call_info.report;
	code = 0;				     /* Pass this back at the very end. */

	/* Check to see if this order can simply be passed on without any */
	/* further processing. Should we check the argument count? */
	do idx = 1 to hbound (SIMPLE_ORDERS, 1)
	     while (order ^= SIMPLE_ORDERS (idx));
	end;

	if (idx <= hbound (SIMPLE_ORDERS, 1)) then
	     call iox_$control (iocb_ptr, order, null (), code);

	else if (order = "set_bsc_modes") then do;

	     /* No arguments means we just make sure bisync_ is in sync. */
	     set_bsc_modes.ebcdic_sw = (ad.char_mode = EBCDIC);
	     set_bsc_modes.transparent = ad.transparent;

	     do idx = 1 to arg_count;

		if (io_call_info.args (idx) = "ascii") then
		     set_bsc_modes.ebcdic_sw = "0"b;
		else if (io_call_info.args (idx) = "ebcdic") then
		     set_bsc_modes.ebcdic_sw = "1"b;
		else if (io_call_info.args (idx) = "transparent") then
		     set_bsc_modes.transparent = "1"b;
		else if (io_call_info.args (idx) = "nontransparent") then
		     set_bsc_modes.transparent = "0"b;
		else do;			     /* Unknown keyword. */
		     call error (error_table_$badopt, caller, "Invalid BISYNC mode: ^a", io_call_info.args (idx));
		     goto ERROR_RETURN;	     /* code = 0 */
		end;
	     end;

	     /* Keywords are processed, pass it to ourself. */
	     call iox_$control (iocb_ptr, order, addr (set_bsc_modes), code);

	end;

	/* Debugging order. */
	else if (order = "ibm3780_info") then do;

	     call report ("Bisync modes:^21t^[non^]transparent,^[ascii^;ebcdic^]",
		^ad.transparent, (ad.char_mode = ASCII));
	     call report ("Multi-record:^21t^[ON^;OFF^] (count=^d)",
		ad.multi_record, ad.multi_record_count);
	     call report ("Record length:^21t^d", ad.record_len);

	end;

	else if (order = "select_device") then do;
	     if (arg_count < 1) then do;
		call error (error_table_$noarg, caller, "No device name for ^a order.", order);
		goto ERROR_RETURN;
	     end;

	     /* Copy device string and pass pointer. */
	     device = io_call_info.args (1);
	     call iox_$control (iocb_ptr, order, addr (device), code);

	     /* Interpret code returned by ibm3780_. */
	     if (code = error_table_$no_operation) then do;
		call error (0, caller, "Invalid device name: ^a", device);
		code = 0;			     /* So io_call does not try again. */
	     end;
	end;

	else if (order = "set_multi_record_mode") then do;

	     if (arg_count = 0) then
		call iox_$control (iocb_ptr, order, null (), code);
	     else do;			     /* Get number. */
		multi_record_count = get_numeric_arg (1, "record count");
		call iox_$control (iocb_ptr, order, addr (multi_record_count), code);
	     end;
	end;

	/* See if bisync_ will accommodate. */
	else call iox_$control (cib.comm_iocb_ptr, "io_call", io_call_infop, code);

ERROR_RETURN:
	P_code = code;			     /* Pass it back. */

	return;
%page;
get_numeric_arg:
     procedure (P_idx, P_what) returns (fixed bin (35));

dcl  P_idx	        fixed bin parameter;
dcl  P_what	        character (*) parameter;

dcl  bad_pos	        fixed bin (35);	     /* From cv_deck_check_. */
dcl  result	        fixed bin (35);

	if (P_idx > arg_count) then do;
	     call error (error_table_$noarg, caller, "No ^a for ^a order.",
		P_what, order);
	     goto ERROR_RETURN;
	end;

	result = cv_dec_check_ ((io_call_info.args (P_idx)), bad_pos);
	if (bad_pos ^= 0) then do;
	     call error (0, caller, "Bad integer value for ^a: ^a", P_what, io_call_info.args (P_idx));
	     goto ERROR_RETURN;
	end;

	if (result < 0) then do;
	     call error (0, caller, "Value for ^a cannot be less than zero: ^d",
		P_what, result);
	     goto ERROR_RETURN;
	end;

	return (result);

     end get_numeric_arg;

%page; %include ibm3780_data;
%page; %include remote_ttt_info;
%page; %include io_call_info;

     end ibm3780_io_call_control_;


		    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