



		    ibm3270_.pl1                    11/15/82  1830.5rew 11/15/82  1506.4      150039



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


/* IBM3270_: An I/O module for controling multi-station 3270 controllers */

/* Written September 1977 by Larry Johnson */

ibm3270_: proc;

/* Parameters */

dcl  arg_iocbp ptr;
dcl  arg_option (*) char (*) var;			/* Options for attach */
dcl  arg_sw bit (1);				/* Com_err_ switch for attach */
dcl  arg_code fixed bin (35);
dcl  arg_mode fixed bin;				/* The open mode */
dcl  arg_event_call_infop ptr;

/* Automatic */

dcl  com_err_sw bit (1);				/* Set if com_err_ sould be called on attach error */
dcl  i fixed bin;
dcl  code fixed bin (35);
dcl  iocbp ptr;
dcl  mask bit (36) aligned;				/* For setting ips mask */
dcl  state fixed bin;
dcl  ch char (1);
dcl 1 my_area_info aligned like area_info automatic;

dcl 1 mode_data aligned,
    2 req_len fixed bin,
    2 req char (256);

dcl 1 event_info aligned,
    2 channel_id fixed bin (71),
    2 message fixed bin (71),
    2 sender bit (36),
    2 origon,
      3 dev_signal bit (18) unal,
      3 ring bit (18) unal,
    2 channel_index fixed bin (17);

dcl  event_call_infop ptr;
dcl 1 event_call_info aligned based (event_call_infop),
    2 channel_id fixed bin (71),
    2 message fixed bin (71),
    2 sender bit (36),
    2 origon,
      3 dev_signal bit (18) unal,
      3 ring bit (18) unal,
    2 data_ptr ptr;

dcl 1 rw_status aligned,				/* For read_status and write_status */
    2 channel fixed bin (71),
    2 flag bit (1);

dcl 1 poll_addr aligned,
    2 length fixed bin,
    2 data char (4);

dcl  dial_msg_chan char (6);				/* Variables for dial manager */
dcl  dial_msg_module char (32);
dcl  dial_msg_ndialed fixed bin;

dcl 1 dma aligned,
    2 version fixed bin,
    2 dial_qual char (22),
    2 event_channel fixed bin (71),
    2 channel_name char (32);

dcl 1 dial_msg_flags aligned,
    2 dialed_up bit (1) unal,
    2 hung_up bit (1) unal,
    2 control bit (1) unal,
    2 pad bit (33) unal;

/* Constants */

dcl  iomodule_name char (8) int static options (constant) init ("ibm3270_");

/* External stuff */

dcl  define_area_ entry (ptr, fixed bin (35));
dcl  release_area_ entry (ptr);
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl  ipc_$decl_ev_wait_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  convert_ipc_code_ entry (fixed bin (35));
dcl  timer_manager_$reset_alarm_wakeup entry (fixed bin (71));
dcl  hcs_$set_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl  iox_$propagate entry (ptr);
dcl  com_err_ entry options (variable);
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  get_process_id_ entry returns (bit (36) aligned);
dcl  dial_manager_$privileged_attach entry (ptr, fixed bin (35));
dcl  convert_dial_message_ entry (bit (72) aligned, char (*), char (*), fixed bin, 1 like dial_msg_flags aligned,
     fixed bin (35));
dcl  hcs_$tty_attach entry (char (*), fixed bin (71), fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_detach entry (fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
dcl  ibm3270_control_$control ext entry;
dcl  ibm3270_control_$timer_handler ext entry;
dcl  ibm3270_control_$wakeup_handler ext entry;

dcl (addr, hbound, length, null, rtrim, string, unspec) builtin;

dcl  sys_info$max_seg_size ext fixed bin (35);
dcl  error_table_$bad_mode ext fixed bin (35);
dcl  error_table_$line_status_pending 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_$badopt ext fixed bin (35);
dcl  error_table_$action_not_performed ext fixed bin (35);
dcl  error_table_$request_pending ext fixed bin (35);
dcl  error_table_$noarg ext fixed bin (35);

dcl  conversion condition;




%include iocb;

%include iox_modes;


%include area_info;

%include bisync_line_data;

%include ibm3270_attach_data;

/* Attach entry point */

ibm3270_attach: entry (arg_iocbp, arg_option, arg_sw, arg_code);

	iocbp = arg_iocbp;
	com_err_sw = arg_sw;
	arg_code = 0;

	area_infop = addr (my_area_info);
	area_info.version = area_info_version_1;
	string (area_info.control) = "0"b;
	area_info.extend = "1"b;
	area_info.zero_on_free = "1"b;
	area_info.owner = iomodule_name;
	area_info.size = sys_info$max_seg_size;
	area_info.areap = null;
	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 define_area_ (area_infop, code);
	if code ^= 0 then call abort_attach ("Unable to allocate temp area.", "");
	allocate ad in (area_info.areap -> work_area);
	unspec (ad) = "0"b;
	ad.work_areap = area_info.areap;
	ad.processid = get_process_id_ ();

/* Process options */

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

	ad.device = arg_option (1);

	do i = 2 to hbound (arg_option, 1);
	     if arg_option (i) = "-ebcdic" then ad.ascii = "0"b;
	     else if arg_option (i) = "-ascii" then ad.ascii = "1"b;
	     else if arg_option (i) = "-async" then ad.async = "1"b;
	     else if arg_option (i) = "-retry_limit" then do; /* Times to retry i/o */
		i = i + 1;			/* Check next arg */
		if i > hbound (arg_option, 1) then do;
		     code = error_table_$noarg;
		     call abort_attach ("^a", "After -retry_limit");
		end;
		on conversion begin;		/* In case bad arg */
		     code = 0;
		     call abort_attach ("Invalid retry limit: ^a", (arg_option (i)));
		end;
		ad.retry_limit = bin (arg_option (i));
		revert conversion;
		if ad.retry_limit < 0 then ad.retry_limit = 0;
	     end;
	     else do;
		code = error_table_$badopt;
		call abort_attach ("^a", (arg_option (i)));
	     end;
	end;

	ad.nchan = 1;
	call create_channel (ad.user_channel);
	call create_channel (ad.io_channel);
	call create_channel (ad.attach_channel);
	call create_channel (ad.timer_channel);

/* Now mask and complete the iocb */

	ad.attach_description = iomodule_name;
	do i = 1 to hbound (arg_option, 1);
	     ad.attach_description = ad.attach_description || " ";
	     ad.attach_description = ad.attach_description || arg_option (i);
	end;
	call hcs_$set_ips_mask ("0"b, mask);
	iocbp -> iocb.attach_descrip_ptr = addr (ad.attach_description);
	iocbp -> iocb.attach_data_ptr = adp;
	iocbp -> iocb.open = ibm3270_open;
	iocbp -> iocb.control = ibm3270_control_$control;
	iocbp -> iocb.detach_iocb = ibm3270_detach;
	call iox_$propagate (iocbp);
	call hcs_$reset_ips_mask (mask, mask);
attach_return:
	return;


/* Internal procedure to handle attach errors */

abort_attach: proc (str1, str2);

dcl (str1, str2) char (*) aligned;

	     if com_err_sw then call com_err_ (code, iomodule_name, str1, str2);
	     if code = 0 then code = error_table_$badopt;
	     arg_code = code;

	     if adp ^= null then do;
		if ad.user_channel ^= 0 then call ipc_$delete_ev_chn (ad.user_channel, code);
	     end;
	     if area_info.areap ^= null then call release_area_ (area_info.areap);
	     go to attach_return;

	end abort_attach;

/* Internal procedure used by attach to create event channels */

create_channel: proc (ch);

dcl  ch fixed bin (71);

	     call ipc_$create_ev_chn (ch, code);
	     if code = 0 then return;
	     call convert_ipc_code_ (code);
	     call abort_attach ("Creating event channel.", "");

	end create_channel;

/* Detach entry point */

ibm3270_detach: entry (arg_iocbp, arg_code);

	iocbp = arg_iocbp;
	arg_code = 0;

	adp = iocbp -> iocb.attach_data_ptr;

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

	call ipc_$delete_ev_chn (ad.user_channel, code);
	call ipc_$delete_ev_chn (ad.timer_channel, code);
	call ipc_$delete_ev_chn (ad.attach_channel, code);
	call ipc_$delete_ev_chn (ad.io_channel, code);
	call release_area_ (addr (work_area));

	return;

/* Open entry point */

ibm3270_open: entry (arg_iocbp, arg_mode, arg_sw, arg_code);

	iocbp = arg_iocbp -> iocb.actual_iocb_ptr;
	arg_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	if arg_mode ^= Stream_input_output then do;
	     code = error_table_$bad_mode;
	     go to report_open_code;
	end;

/* See if we are completing a previously started open */

	if ad.open_in_progress then do;
	     if ad.open_wakeup_occured then do;		/* Got the wakeup */
		ad.open_in_progress, ad.open_wakeup_occured = "0"b;
		go to complete_open;
	     end;
	     code = error_table_$request_pending;	/* Still not done */
	     go to report_open_code;
	end;

/* Get bisync channel from answering service. */

	dma.version = 1;				/* Setup dial manager data structure */
	dma.event_channel = ad.attach_channel;
	dma.channel_name = ad.device;
	dma.dial_qual = "";
	call dial_manager_$privileged_attach (addr (dma), code);
	if code = error_table_$action_not_performed then go to maybe_mine_already;
	if code ^= 0 then go to report_open_code;

/* Make ansering service call us back when line is ready */

	call ipc_$decl_ev_call_chn (ad.attach_channel, open_wakeup_handler, iocbp, 1, code);
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     go to report_open_code;
	end;

	ad.open_in_progress = "1"b;
	if ad.async then do;			/* Cant block here */
	     code = error_table_$request_pending;
	     go to report_open_code;
	end;
	call block;				/* Wait for answering service */
	ad.open_in_progress, ad.open_wakeup_occured = "0"b;
	if code ^= 0 then go to report_open_code;

complete_open:
	call convert_dial_message_ (unspec (ad.open_event_message), dial_msg_chan, dial_msg_module,
	     dial_msg_ndialed, dial_msg_flags, code);
	if code ^= 0 then go to report_open_code;
maybe_mine_already:

/* Attach the device */

	call hcs_$tty_attach ((ad.device), ad.io_channel, ad.tty_index, state, code);
	if code ^= 0 then go to report_open_code;
retry_modes:
	mode_data.req_len = length (mode_data.req);
	mode_data.req = "rawi,rawo";
	call hcs_$tty_order (ad.tty_index, "modes", addr (mode_data), state, code);
	if code = error_table_$line_status_pending then do;
	     call flush_line_status;
	     if code = 0 then go to retry_modes;
	end;
	if code ^= 0 then go to report_open_code;

retry_message_size:
	i = 256;
	call hcs_$tty_order (ad.tty_index, "set_input_message_size", addr (i), state, code);
	if code = error_table_$line_status_pending then do;
	     call flush_line_status;
	     if code = 0 then go to retry_message_size;
	end;
	if code ^= 0 then go to report_open_code;

	call line_control (SET_3270_MODE, 0);
	if code ^= 0 then go to report_open_code;
	call line_control (SET_BID_LIMIT, 3);
	if code ^= 0 then go to report_open_code;
	call line_control (CONFIGURE, 1);
	if code ^= 0 then go to report_open_code;
	call line_control2 (SET_TTD_PARAMS, 2, 2);
	if code ^= 0 then go to report_open_code;


	call ipc_$decl_ev_call_chn (ad.io_channel, ibm3270_control_$wakeup_handler, iocbp, 1, code);
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     go to report_open_code;
	end;

	call ipc_$decl_ev_call_chn (ad.timer_channel, ibm3270_control_$timer_handler, iocbp, 1, code);
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     go to report_open_code;
	end;

/* Initialize attach data variables */

	ad.first_read_infop = null;
	ad.last_read_infop = null;
	ad.header_buf_len = 16;
	allocate header_buf in (work_area);
	ad.input_buf_len = 4096;
	allocate input_buf in (work_area);
	ad.text_buf_len = 4096;
	allocate text_buf in (work_area);
	ad.output_buf_len = 56*40;			/* FNPs arbitrary limit */
	allocate output_buf in (work_area);
	ad.header_len, ad.text_len, ad.unscanned_data_len = 0;
	ad.input_state = 1;
	ad.last_device_polled = -2;			/* Set to invalid number */
	ad.last_device_selected = -2;
	ad.cur_out_reqp = null;			/* No output */
	ad.first_out_reqp (*) = null;
	ad.last_out_reqp (*) = null;
	ad.min_dev, ad.max_dev = -1;
	ad.pend_interval = 30000000;			/* 30 seconds */
	ad.pend_time (*) = 0;
	ad.close_in_progress = "0"b;
	ad.output_in_progress = "0"b;
	ad.input_line_status, ad.output_line_status = 0;
	ad.general_poll, ad.polling_in_progress = "0"b;
	ad.device_responded = "0"b;
	ad.first_poll_reqp, ad.last_poll_reqp = null;

	unspec (ad.stx) = "002"b3;
	unspec (ad.etx) = "003"b3;
	unspec (ad.soh) = "001"b3;
	unspec (ad.sf) = "035"b3;
	unspec (ad.sba) = "021"b3;
	unspec (ad.ic) = "023"b3;
	unspec (ad.eua) = "022"b3;
	if ad.ascii then do;
	     unspec (ad.etb) = "027"b3;
	     unspec (ad.eot) = "004"b3;
	     unspec (ad.pt) = "011"b3;
	     unspec (ad.ra) = "024"b3;
	     unspec (ad.esc) = "033"b3;
	end;
	else do;
	     unspec (ad.etb) = "046"b3;
	     unspec (ad.eot) = "067"b3;
	     unspec (ad.pt) = "005"b3;
	     unspec (ad.ra) = "074"b3;
	     unspec (ad.esc) = "047"b3;
	end;

	do i = 0 to 63;				/* Set up usavble form of address_mapping array */
	     unspec (ch) = "0"b || address_mapping (i);
	     ad.bit6_char (i) = ch;
	end;

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

	call hcs_$set_ips_mask ("0"b, mask);
	iocbp -> iocb.close = ibm3270_close;
	iocbp -> iocb.control = ibm3270_control_$control;
	iocbp -> iocb.open_descrip_ptr = addr (ad.open_description);
	call iox_$propagate (iocbp);
	call hcs_$reset_ips_mask (mask, mask);
	code = 0;
report_open_code:
	arg_code = code;
	return;

/* This entry is the event call handeler for the attach channel during opens */

open_wakeup_handler: entry (arg_event_call_infop);

	event_call_infop = arg_event_call_infop;
	iocbp = event_call_info.data_ptr;
	adp = iocbp -> iocb.attach_data_ptr;

	if ^ad.open_in_progress then return;		/* Came at bad time */
	ad.open_event_message = event_call_info.message;	/* Save the message */
	ad.open_wakeup_occured = "1"b;
	call hcs_$wakeup (ad.processid, ad.user_channel, 0, code);
	return;

/* Close entry point */

ibm3270_close: entry (arg_iocbp, arg_code);

	iocbp = arg_iocbp -> iocb.actual_iocb_ptr;
	arg_code = 0;
	adp = iocbp -> iocb.attach_data_ptr;

	ad.close_in_progress = "1"b;
	call line_control (STOP_AUTO_POLL, 0);
	call hcs_$tty_detach (ad.tty_index, 0, state, code);
	call ipc_$decl_ev_wait_chn (ad.io_channel, code);
	call ipc_$decl_ev_wait_chn (ad.attach_channel, code);
	call ipc_$decl_ev_wait_chn (ad.timer_channel, code);

	call hcs_$set_ips_mask ("0"b, mask);
	iocbp -> iocb.open_descrip_ptr = null;
	iocbp -> iocb.open = ibm3270_open;
	iocbp -> iocb.detach_iocb = ibm3270_detach;
	call iox_$propagate (iocbp);
	call hcs_$reset_ips_mask (mask, mask);

	call ipc_$drain_chn (ad.user_channel, code);
	call ipc_$drain_chn (ad.io_channel, code);
	call ipc_$drain_chn (ad.attach_channel, code);
	call timer_manager_$reset_alarm_wakeup (ad.timer_channel);
	call ipc_$drain_chn (ad.timer_channel, code);

	free header_buf;
	free text_buf;
	free input_buf;
	free output_buf;

	return;

/* Control/* Internal procedure to block */

block:	proc;

	     call ipc_$block (addr (ad.wait_list), addr (event_info), code);
	     if code ^= 0 then call convert_ipc_code_ (code);
	     return;

	end block;

/* Procedure to do a line control order */

line_control: proc (op, val1);

dcl (op, val1, val2) fixed bin;

	     line_ctl.val = 0;
line_control_join:
	     line_ctl.val (1) = val1;
	     line_ctl.op = op;
retry_line_control:
	     call hcs_$tty_order (ad.tty_index, "line_control", addr (line_ctl), state, code);
	     if code = error_table_$line_status_pending then do;
		call flush_line_status;
		if code = 0 then go to retry_line_control;
	     end;
	     return;

line_control2: entry (op, val1, val2);

	     line_ctl.val = 0;
	     line_ctl.val (2) = val2;
	     go to line_control_join;

	end line_control;

flush_line_status: proc;

	     call hcs_$tty_order (ad.tty_index, "line_status", addr (line_stat), state, code);
	     return;

	end flush_line_status;


     end ibm3270_;




		    ibm3270_control_.pl1            11/15/82  1830.5rew 11/15/82  1506.4      345690



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


/* IBM3270_CONTROL_ - Implements the control entry (and the guts of) the ibm3270_ I/O module */
/* Written October 1977 by Larry Johnson */

ibm3270_control_: proc;

/* Paramaters */

dcl  arg_iocbp ptr;
dcl  arg_order char (*);
dcl  arg_info_ptr ptr;
dcl  arg_code fixed bin (35);
dcl  arg_event_call_infop ptr;

/* Automatic */

dcl  code fixed bin (35);
dcl  state fixed bin;
dcl  order char (32);
dcl  info_ptr ptr;
dcl  iocbp ptr;
dcl  event_call_infop ptr;

dcl 1 auto_read_ctl like read_ctl aligned automatic;

dcl 1 event_info aligned,				/* For ipc_$block */
    2 channel_id fixed bin (71),
    2 message fixed bin (71),
    2 sender bit (36),
    2 origon,
      3 dev_signal bit (18) unal,
      3 ring bit (18) unal,
    2 channel_index fixed bin (17);

/* Based */

dcl  based_chan fixed bin (71) based;			/* Event_info order */
dcl  poll_device fixed bin based (info_ptr);		/* Argument for poll order */

dcl 1 event_call_info aligned based (event_call_infop),
    2 channel_id fixed bin (71),
    2 message fixed bin (71),
    2 sender bit (36),
    2 origon,
      3 dev_signal bit (18) unal,
      3 ring bit (18) unal,
    2 data_ptr ptr;

dcl 1 msg unal based (ad.text_buf_ptr),			/* Start of standard reply */
    2 address,
      3 pad1 bit (3),
      3 controller bit (6),
      3 pad2 bit (3),
      3 device bit (6),
    2 pad3 bit (3),
    2 aid bit (6),					/* Action code */
    2 cursor char (2);

dcl  out_reqp ptr;					/* Pointer to current output request */

dcl 1 out_req aligned based (out_reqp),			/* Output is a queue of these structures */
    2 next_out_reqp ptr,				/* Forward pointer */
    2 out_msgp ptr,					/* Pointer to text */
    2 out_msgl fixed bin,				/* Its length */
    2 sent_len fixed bin,				/* Amount of data actually sent */
    2 req_time fixed bin (71),			/* Time request queued */
    2 device fixed bin,				/* Device this message is for */
    2 retry_count fixed bin,				/* Times this output has been tried */
    2 eot_sent bit (1);				/* Send once eot sent for this request */

dcl  out_msg char (out_req.out_msgl) based (out_req.out_msgp);

dcl  poll_reqp ptr;					/* Pointer to poll queue block */

dcl 1 poll_req aligned based (poll_reqp),
    2 next_poll_reqp ptr,
    2 device fixed bin;

/* Constants */


/* The following 2 arrays map the low order 5 bits of an ebcdic aid byte into the values required
   in read_info.key and sub_key */

dcl  aid_to_key (0:31) fixed bin (8) unal int static options (constant) init (
     0, 0, 0, 0, 0, 0, 7, 0, 0, 0, 0, 5, 5, 6, 5, 0,
     9, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 3, 8, 0);

dcl  aid_to_sub_key (0:31) fixed bin (8) unal int static options (constant) init (
     0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 1, 0, 2, 0,
     0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 0, 0, 0);

/* The following map values of write_info.command to the command code */

dcl  command_codes (6) bit (8) unal int static options (constant) init (
     "f1"b4, "f5"b4, "f7"b4, "6f"b4, "f6"b4, "f2"b4);

/* External */

dcl  hcs_$tty_read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
dcl  hcs_$tty_write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  ibm3270_translate_$ascii_to_ebcdic entry (ptr, fixed bin);
dcl  ibm3270_translate_$ebcdic_to_ascii entry (ptr, fixed bin);
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  convert_ipc_code_ entry (fixed bin (35));
dcl  hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl  ibm3270_io_call_ entry (ptr, ptr, fixed bin (35));
dcl  ipc_$mask_ev_calls entry (fixed bin (35));
dcl  ipc_$unmask_ev_calls entry (fixed bin (35));
dcl  timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71));

dcl  error_table_$bad_arg ext fixed bin (35);
dcl  error_table_$no_operation ext fixed bin (35);
dcl  error_table_$request_pending ext fixed bin (35);
dcl  error_table_$unimplemented_version ext fixed bin (35);
dcl  error_table_$line_status_pending ext fixed bin (35);
dcl  error_table_$long_record ext fixed bin (35);

dcl (addr, addrel, bin, clock, divide, hbound, index, lbound, length, low, max, min, mod, null, string, substr, unspec) builtin;

dcl  cleanup condition;

%include ibm3270_attach_data;

%include ibm3270_io_info;

%include iocb;

%include bisync_line_data;


/* The control entry point */

control:	entry (arg_iocbp, arg_order, arg_info_ptr, arg_code);

	iocbp = arg_iocbp -> iocb.actual_iocb_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	order = arg_order;
	info_ptr = arg_info_ptr;
	read_ctlp = addr (auto_read_ctl);

/* Following orders are allowed before open */

	if order = "event_info" then do;
	     info_ptr -> based_chan = ad.user_channel;
	     code = 0;
	     go to control_return;
	end;
	if order = "io_call" then do;
	     call ibm3270_io_call_ (iocbp, info_ptr, code);
	     go to control_return;
	end;

	if iocbp -> iocb.open_descrip_ptr = null then do; /* Not open yet */
	     code = error_table_$no_operation;
	     go to control_return;
	end;

/* Orders allowed after switch is open */

	if order = "general_poll" then do;
	     ad.general_poll = "1"b;			/* We want to be polling */
	     call worker;
	     code = 0;
	end;

	else if order = "stop_general_poll" then do;
	     ad.general_poll = "0"b;
	     call stop_auto_poll;
	     code = 0;
	end;

	else if order = "poll" then do;
	     call queue_poll_req (poll_device);
	     call worker;
	     code = 0;
	end;

	else if order = "read" then do;		/* Get next data block */
	     read_ctlp = info_ptr;
	     if read_ctl.version ^= 1 then do;
		code = error_table_$unimplemented_version;
		go to control_return;
	     end;
	     if ad.first_read_infop = null then call worker; /* Look harder if none yet */
	     do while (ad.first_read_infop = null);	/* Then, block until available */
		ad.wakeup_needed = "1"b;
		if ad.async then do;		/* Cant block here */
		     code = error_table_$request_pending;
		     go to control_return;
		end;
		call ipc_$block (addr (ad.wait_list), addr (event_info), code);
		if code ^= 0 then do;
		     call convert_ipc_code_ (code);
		     go to control_return;
		end;
		ad.wakeup_needed = "0"b;
	     end;

	     read_ctlp = info_ptr;			/* This may have been changed */
	     read_ctl.read_infop = ad.first_read_infop;	/* Return first block */
	     ad.first_read_infop = read_info.next_read_infop;
	     if ad.first_read_infop = null then ad.last_read_infop = null;
	     read_info.next_read_infop = null;		/* Don't let caller see this */
	     code = 0;
	     read_ctl.areap = ad.work_areap;
	     read_ctl.max_len = read_info.max_len;
	     read_ctl.max_fields = read_info.max_fields;
	end;

	else if order = "write" then do;
	     write_infop = info_ptr;
	     if write_info.device < 0 | write_info.device > 31 then do;
		code = error_table_$bad_arg;
		go to control_return;
	     end;
	     call format_write_msg;			/* Setup real output */
	     if code ^= 0 then go to control_return;
	     call queue_out_req;
	     call worker;
	     code = 0;
	end;

	else do;
retry_order:   call hcs_$tty_order (ad.tty_index, order, info_ptr, state, code);
	     if code ^= 0 then do;
		call check_error_code;
		if code ^= 0 then go to control_return; /* Serious error */
		if ad.input_line_status ^= 0 | ad.output_line_status ^= 0 then call worker; /* If line status returned */
		go to retry_order;			/* Then do callers work */
	     end;
	end;
control_return:
	arg_code = code;
	return;

/* This entry is the event call handler for wakeups on the communications channel */

wakeup_handler: entry (arg_event_call_infop);

	event_call_infop = arg_event_call_infop;
	iocbp = event_call_info.data_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	read_ctlp = addr (auto_read_ctl);
	if ad.close_in_progress then return;

	call worker;

	if ad.wakeup_needed & (ad.first_read_infop ^= null) then /* Got good data for caller */
	     call hcs_$wakeup (ad.processid, ad.user_channel, 0, code);

	return;

/* Handler for wakeups on the timer channel */

timer_handler: entry (arg_event_call_infop);

	event_call_infop = arg_event_call_infop;
	iocbp = event_call_info.data_ptr;
	adp = iocbp -> iocb.attach_data_ptr;
	read_ctlp = addr (auto_read_ctl);
	if ad.close_in_progress then return;

	call unpend_out_req;			/* Unpend all requests */

	return;

/* Procedure to do as much I/O as can be done right now */

worker:	proc;

	     call ipc_$mask_ev_calls (code);
	     on cleanup call ipc_$unmask_ev_calls (code);
worker_loop:
	     call scan_more_input;

	     call send_more_output;

	     if ad.input_line_status ^= 0 then go to worker_loop; /* In case read error reported during output */

	     call poll_more_devices;

	     if ad.input_line_status ^= 0 | ad.output_line_status ^= 0 then go to worker_loop;

	     call ipc_$unmask_ev_calls (code);

	     return;

	end worker;

/* Procedure that parses the input data stream at the bisync level */

scan_more_input: proc;

dcl (i, j) fixed bin ;

check_input_status:
	     if ad.input_line_status ^= 0 then do;	/* Some bad condition */
		call queue_error (ad.last_device_polled, (ad.input_line_status));
		ad.input_line_status = 0;
		ad.polling_in_progress = "0"b;
	     end;

get_more_data: if ad.unscanned_data_len = 0 then do;	/* First need some data */
retry_read:	call hcs_$tty_read (ad.tty_index, ad.input_buf_ptr, 0, ad.input_buf_len, ad.unscanned_data_len,
		     state, code);
		if code ^= 0 then do;
		     call check_error_code;
		     if code ^= 0 then do;		/* Bad error */
			call queue_error (-1, code);
			return;
		     end;
		     if ad.input_line_status ^= 0 then go to check_input_status;
		     else go to retry_read;
		end;
		if ad.unscanned_data_len = 0 then return;
		ad.unscanned_data_ptr = ad.input_buf_ptr;
	     end;

/* Now dispatch of current state of input scan and the data type */

	     go to get_data (ad.input_state);

get_data (1):					/* Looking for stx in non_transparent mode */
	     if substr (unscanned_data, 1, 1) = ad.stx then do; /* Found data */
		ad.input_state = 2;
		call advance_unscanned_data (1);
		go to get_more_data;
	     end;
	     if substr (unscanned_data, 1, 1) = ad.soh then do; /* Found header */
		ad.input_state = 4;
		call advance_unscanned_data (1);
		go to get_more_data;
	     end;
	     if substr (unscanned_data, 1, 1) = ad.eot then call process_eot;
	     call advance_unscanned_data (1);		/* Move over eot */
	     go to get_more_data;

get_data (2):					/* In middle of block, looking for etb or etx */
	     i = index (unscanned_data, ad.etx);
	     if i = 1 then do;			/* End of block */
get_data_2a:	call advance_unscanned_data (1);	/* Move over etx */
		call process_input;
		ad.input_state = 3;			/* To skip lrc */
		go to get_more_data;
	     end;

	     j = index (unscanned_data, ad.etb);	/* Check for etb too */
	     if j = 1 then do;			/* Found etb before etx */
get_data_2b:	call advance_unscanned_data (1);	/* Over etb */
		ad.input_state = 3;			/* Skip lrc */
		go to get_more_data;
	     end;
	     if i = 0 then i = j;			/* If not etx, use etb answer */
	     else if j ^= 0 then i = min (i, j);	/* If both, use first */
	     if i = 0 then do;			/* All data is good */
		call move_data (addr (ad.text_data), ad.unscanned_data_len);
		go to get_more_data;
	     end;
	     call move_data (addr (ad.text_data), i-1);	/* Move stuff before etb or etx */
	     if substr (unscanned_data, 1, 1) = ad.etx then go to get_data_2a;
	     else go to get_data_2b;

get_data (3):					/* Skip over lrc character after etx or etb */
	     if ad.ascii then call advance_unscanned_data (1);
	     ad.input_state = 1;
	     go to get_more_data;

get_data (4):					/* Scanning data in header */
	     i = index (unscanned_data, ad.etx);	/* Look for etx */
	     if i = 1 then do;			/* Etx first */
get_data_4a:	call advance_unscanned_data (1);	/* Skip over etxx */
		ad.input_state = 3;
		call process_input;
		go to get_more_data;
	     end;
	     j = index (unscanned_data, ad.etb);	/* Also look for etb */
	     if i = 0 then i = j;			/* If no etx, use etb */
	     else if j ^= 0 then i = min (i, j);	/* Otherwise use what comes first */
	     if i = 1 then do;			/* Etb is first */
get_data_4b:	call advance_unscanned_data (1);	/* Ignore etb */
		ad.input_state = 3;
		go to get_more_data;
	     end;
	     j = index (unscanned_data, ad.stx);	/* This may also terminate header */
	     if i = 0 then i = j;			/* If no etb or etx, use stx */
	     else if j ^= 0 then i = min (i, j);	/* Otherwise use what comes first */
	     if i = 1 then do;			/* Stx is first */
get_data_4c:	call advance_unscanned_data (1);
		ad.input_state = 2;
		go to get_more_data;
	     end;
	     if i = 0 then do;			/* Didnt find any special chars */
		call move_data (addr (ad.header_data), ad.unscanned_data_len);
		go to get_more_data;
	     end;
	     call move_data (addr (ad.header_data), i-1);
	     i = 1;				/* First char is now control char */
	     if substr (unscanned_data, 1, 1) = ad.etx then go to get_data_4a;
	     else if substr (unscanned_data, 1, 1) = ad.etb then go to get_data_4b;
	     else go to get_data_4c;			/* Looking at stx */


	end scan_more_input;

/* Internal procedure to move chars to header or text */

move_data: proc (p, n);

dcl  i fixed bin;
dcl  n fixed bin;
dcl  p ptr;					/* Points to header data or text data */

dcl 1 data aligned based (p),
    2 data_buf_ptr ptr,
    2 data_buf_len fixed bin,
    2 data_len fixed bin;

dcl  data_chars char (data.data_buf_len) based (data.data_buf_ptr);

	     i = min (n, data.data_buf_len - data.data_len); /* Move what fits */
	     if i > 0 then substr (data_chars, data.data_len + 1, i) = substr (unscanned_data, 1, i);
	     call advance_unscanned_data (n);		/* Move past chars moved */
	     data.data_len = data.data_len + i;
	     return;

	end move_data;

/* Procedure to move the pointer in the unscanned data area */

advance_unscanned_data: proc (amt);

dcl  amt fixed bin ;

	     ad.unscanned_data_ptr = substraddr (unscanned_data, amt+1);
	     ad.unscanned_data_len = ad.unscanned_data_len - amt;
	     return;

	end advance_unscanned_data;

/* Routine to process input data once it is found */

process_input: proc;

dcl (i, j) fixed bin;
dcl  fldi (256) fixed bin;
dcl  nf fixed bin;
dcl  max_fldl fixed bin;
dcl  scanp ptr;
dcl  scanl fixed bin;
dcl  scan_data char (scanl) based (scanp);

	     if ad.header_len > 0 then do;		/* Header means some special format */
		if ^ad.ascii then call ibm3270_translate_$ebcdic_to_ascii (ad.header_buf_ptr, ad.header_len);
		if header_data = "%R" then do;	/* Status information */
		     if ad.text_len < 4 then go to process_input_end; /* Not enough data, ignore */
		     call get_read_info (0, 0);	/* Setup  input structure */
		     call extract_address;		/* Get device address */
		     read_info.key = STATUS;
		     substr (read_info.bits, 1, 6) = substr (unspec (substr (text_data, 3, 1)), 4, 6);
		     substr (read_info.bits, 7, 6) = substr (unspec (substr (text_data, 4, 1)), 4, 6);
		     if read_info.bits = "0200"b3 then	/* Ready device */
			ad.pend_time (read_info.device) = 0; /* This unpends output for this device */
		     go to queue_standard;
		end;
		else if header_data = "%/" then do;	/* Test request */
		     call get_read_info (1, ad.text_len);
		     read_info.key = TEST_REQ;
		     read_info.mod_fields = 1;
		     if ^ad.ascii then call ibm3270_translate_$ebcdic_to_ascii (ad.text_buf_ptr, ad.text_len);
		     read_info.contents (1) = text_data;
		     read_info.field_position (1) = 0;
		     go to queue_standard;
		end;
		go to process_input_end;		/* Bad header */
	     end;

/* Data has no header, so standard input text is assumed */

	     if ad.text_len < 2 then go to process_input_end;
	     if ad.text_len > 5 then do;		/* There is data */
		scanp = substraddr (text_data, 6);
		scanl = ad.text_len - 5;
		if substr (scan_data, 1, 1) ^= ad.sba then do; /* Unformatted */
		     call get_read_info (1, scanl);	/* One unformated string */
		     read_info.field_position (1) = -1;
		     call ibm3270_translate_$ebcdic_to_ascii (scanp, scanl);
		     read_info.contents (1) = scan_data;
		     read_info.mod_fields = 1;
		end;
		else do;				/* Formatted screen */
		     nf = 0;
		     max_fldl = 1;
		     i = 1;
		     do while ((i <= scanl) & (nf < 256)); /* Find all sba's */
			j = index (substr (scan_data, i), ad.sba);
			if j ^= 0 then do;		/* Found one */
			     nf = nf + 1;
			     fldi (nf) = i + j - 1;
			     i = i + j;
			     max_fldl = max (max_fldl, j-3);
			end;
			else do;
			     max_fldl = max (max_fldl, scanl - i - 1);
			     i = scanl+1;		/* To stop scan */
			end;
		     end;
		     call get_read_info (nf, max_fldl);
		     do i = 1 to nf;		/* Insert positions */
			read_info.field_position (i) = get_position (substr (scan_data, fldi (i)+1, 2));
		     end;
		     call ibm3270_translate_$ebcdic_to_ascii (scanp, scanl);
		     do i = 1 to nf;		/* Get data */
			if i < nf then j = fldi (i+1) - fldi (i) - 3;
			else j = scanl - fldi (i) - 2;
			read_info.contents (i) = substr (scan_data, fldi (i)+3, j);
		     end;
		     read_info.mod_fields = nf;
		end;
	     end;
	     else call get_read_info (0, 0);		/* No data */
	     call extract_address;
	     if ad.text_len < 3 then go to queue_standard; /* No aid */
	     i = bin (substr (msg.aid, 2, 5));		/* Low order 5 bits of aid */
	     read_info.key = aid_to_key (i);
	     read_info.sub_key = aid_to_sub_key (i);
	     if ad.text_len < 5 then go to queue_standard; /* No cursor */
	     read_info.cursor_position = get_position (msg.cursor);
queue_standard:
	     call queue_read_info;
	     ad.device_responded = "1"b;		/* Means device answered poll */
process_input_end:
	     ad.text_len, ad.header_len = 0;		/* Start new data */
	     return;

	end process_input;

process_eot: proc;

	     ad.polling_in_progress = "0"b;		/* These means polling finished */
	     if ad.last_device_polled >= 0 & ^ad.device_responded then do;
						/* Last poll was to specific device that answered EOT */
		call get_read_info (0, 0);		/* Build dummy ready status */
		read_info.controller = ad.controller;
		read_info.device = ad.last_device_polled;
		read_info.key = STATUS;
		read_info.status.bits = "0200"b3;
		call queue_read_info;
	     end;

	end process_eot;

/* Allocate a read_info structure */

get_read_info: proc (max_fields, max_len);

dcl (max_fields, max_len);

	     read_ctl.max_fields = max_fields;
	     read_ctl.max_len = max_len;
	     allocate read_info in (work_area);
	     read_info.version = 1;
	     read_info.next_read_infop = null;
	     read_info.controller = 0;
	     read_info.device = -1;
	     read_info.reason = 0;
	     read_info.status = "0"b;
	     read_info.cursor_position = 0;
	     read_info.mod_fields = 0;
	     return;

	end get_read_info;

/* Procudure to add a complete read_info structure to the chain */

queue_read_info: proc;

	     read_info.next_read_infop = null;
	     if ad.first_read_infop = null then		/* Only one */
		ad.first_read_infop, ad.last_read_infop = addr (read_info);
	     else do;
		ad.last_read_infop -> read_info.next_read_infop = addr (read_info);
		ad.last_read_infop = addr (read_info);
	     end;
	     return;

	end queue_read_info;

/* Extract device address from input text */

extract_address: proc;

	     read_info.controller = bin (msg.controller);
	     read_info.device = bin (msg.device);
	     return;

	end extract_address;

/* Get address out of 2 character seqyence */

get_position: proc (c) returns (fixed bin);

dcl  c char (2);

	     return (bin (substr (unspec (c), 4, 6) || substr (unspec (c), 13, 6)));

	end get_position;

/* Procedure to set up polling address and initiate a poll operation */

poll:	proc (device);

dcl  device fixed bin;
dcl  controller_char char (1);			/* Controller address, in char form */
dcl  device_char char (1);				/* Device address, in char form */
dcl  select_sw bit (1) init ("0"b);
dcl  auto bit (1) init ("0"b);

poll_join:     if device ^= ad.last_device_polled then do;	/* Skip if fnp already has address */
select_join:	if ^select_sw then controller_char = ad.bit6_char (ad.controller);
		else controller_char = ad.bit6_char (ad.controller + 32);
		if device = -1 then			/* General poll */
		     unspec (device_char) = "177"b3;
		else device_char = ad.bit6_char (device);

		if select_sw then line_ctl.op = SET_SELECT_ADDR;
		else line_ctl.op = SET_POLLING_ADDR;
		valchar.data_len = 4;
		substr (valchar.data, 1, 1), substr (valchar.data, 2, 1) = controller_char;
		substr (valchar.data, 3, 1), substr (valchar.data, 4, 1) = device_char;
retry_addr:	call hcs_$tty_order (ad.tty_index, "line_control", addr (line_ctl), state, code);
		if code ^= 0 then do;
		     call check_error_code;
		     if code ^= 0 then return;
		     else go to retry_addr;
		end;
		if select_sw then do;
		     ad.last_device_selected = device;
		     return;
		end;
		else ad.last_device_polled = device;
	     end;

	     line_ctl.op = START_POLL;		/* Now, poll */
	     line_ctl.val = 0;
	     if auto then line_ctl.val (1) = 1;
retry_poll:    call hcs_$tty_order (ad.tty_index, "line_control", addr (line_ctl), state, code);
	     if code ^= 0 then do;
		call check_error_code;
		if code ^= 0 then return;
		else go to retry_poll;
	     end;
	     if line_ctl.op = START_POLL then do;
		ad.polling_in_progress = "1"b;
		ad.device_responded = "0"b;		/* No answwer yet */
	     end;
	     return;

select:	     entry (device);

	     if ad.last_device_selected = device then return;
	     select_sw = "1"b;
	     go to select_join;

auto_poll:     entry (device);

	     auto = "1"b;
	     go to poll_join;

stop_auto_poll: entry;

	     line_ctl.op = STOP_AUTO_POLL;
	     line_ctl.val = 0;
	     go to retry_poll;

	end poll;

/* This procedure is responsible for keeping output moving */

send_more_output: proc;

dcl  i fixed bin;
dcl  moved fixed bin;
dcl 1 wstat aligned,
    2 chan fixed bin (71),
    2 pending bit (1);

check_output_status:
	     if ad.output_line_status ^= 0 then do;	/* Error to handle first */
		if ad.output_in_progress then do;	/* May be end of output */
		     out_reqp = ad.cur_out_reqp;
		     if out_req.eot_sent then do;	/* Done output */
			if ad.output_line_status = IBM3270_WACK_SELECT then do; /* Device busy, pend output */
			     call pend_out_req;
			     ad.output_in_progress = "0"b;
			     ad.cur_out_reqp = null;
			end;
			else if ad.output_line_status = IBM3270_WACK_MESSAGE then do; /* Device is going to be busy */
			     ad.output_in_progress = "0"b;
			     ad.cur_out_reqp = null;
			     i = out_req.device;
			     call free_out_req;	/* Current output has completed ok */
			     if ad.first_out_reqp (i) ^= null then do; /* If more, pend it - otherwise select will
						   just get wack */
				out_reqp = ad.first_out_reqp (i);
				call pend_out_req;
			     end;
			end;
			else if ad.output_line_status = REVERSE_INTERRUPT then do; /* Device has status */
			     i = out_req.device;
			     if ad.retry_limit > 0 then /* If we should give up eventually */
				if out_req.retry_count >= ad.retry_limit then /* And the time is now */
				     call free_out_req;
				else do;
				     out_req.retry_count = out_req.retry_count + 1;
				     call pend_out_req;
				end;
			     else call pend_out_req;	/* Retry forever */
			     call queue_poll_req_first (i); /* Must poll this device first */
			     ad.output_in_progress = "0"b;
			     ad.cur_out_reqp = null;
			end;
			else do;
			     if ad.output_line_status ^= IBM3270_WRITE_COMPLETE then
						/* Inform user of other serious error before deleting data */
				call queue_error (out_req.device, (ad.output_line_status));
			     ad.output_in_progress = "0"b;
			     ad.cur_out_reqp = null;
			     call free_out_req;
			end;
		     end;
		end;
		ad.output_line_status = 0;
	     end;

	     if ^ad.output_in_progress then do;		/* Not currently doing output */
		if ad.first_poll_reqp ^= null then return; /* If polling to do, don't do output */
		if ad.polling_in_progress then	/* If polling specific device, dont write yet */
		     if ad.last_device_polled ^= -1 then return;
		call get_next_out_req;		/* Find something to do */
		if ad.cur_out_reqp = null then return;
		call select (out_req.device);		/* Tell fnp who to talk to */
		if code ^= 0 then return;
		out_req.eot_sent = "0"b;
		out_req.sent_len = 0;
		ad.output_in_progress = "1"b;
	     end;
	     out_reqp = ad.cur_out_reqp;		/* Pickup current block */
	     if out_req.eot_sent then return;
continue_output:
retry_write_status:
	     call hcs_$tty_order (ad.tty_index, "write_status", addr (wstat), state, code);
	     if code ^= 0 then do;
		call check_error_code;		/* Check for line status */
		if code ^= 0 then go to fatal_output_error; /* Something bad */
		if ad.output_line_status ^= 0 then go to check_output_status; /* Must process status */
		else go to retry_write_status;
	     end;
	     if wstat.pending then return;		/* Cant take more now */
	     if out_req.sent_len = out_req.out_msgl then do; /* Written all data */
retry_eot:	call hcs_$tty_write (ad.tty_index, addr (ad.eot), 0, 1, moved, state, code);
		if code ^= 0 then do;
		     call check_error_code;
		     if code ^= 0 then go to fatal_output_error;
		     if ad.output_line_status ^= 0 then go to check_output_status;
		     else go to retry_eot;
		end;
		if moved = 1 then out_req.eot_sent = "1"b; /* Eot accepted */
		return;
	     end;

retry_write:   call hcs_$tty_write (ad.tty_index, out_req.out_msgp, out_req.sent_len,
		out_req.out_msgl - out_req.sent_len, moved, state, code);
	     if code ^= 0 then do;
		call check_error_code;
		if code ^= 0 then go to fatal_output_error;
		if ad.output_line_status ^= 0 then go to check_output_status;
		else go to retry_write;
	     end;
	     if moved = 0 then return;		/* Can't take it now, try later */
	     out_req.sent_len = out_req.sent_len + moved; /* Accumulate length sent */
	     go to continue_output;			/* Keep trying */

fatal_output_error:
	     call queue_error (-1, code);
	     return;

	end send_more_output;

/* Queue an output request */

queue_out_req: proc;

dcl  i fixed bin;

	     out_req.next_out_reqp = null;
	     out_req.eot_sent = "0"b;
	     out_req.req_time = clock;		/* Remebr time queued */

	     i = out_req.device;
	     if ad.first_out_reqp (i) = null then do;	/* No other output for this device */
		ad.first_out_reqp (i), ad.last_out_reqp (i) = out_reqp;
		ad.pend_time (i) = 0;
		if ad.min_dev = -1 then		/* No other devices have output queued */
		     ad.min_dev, ad.max_dev = i;
		else do;
		     ad.min_dev = min (i, ad.min_dev);
		     ad.max_dev = max (i, ad.max_dev);
		end;
	     end;
	     else do;				/* Thread on end */
		ad.last_out_reqp (i) -> out_req.next_out_reqp = out_reqp;
		ad.last_out_reqp (i) = out_reqp;
	     end;

	     return;

	end queue_out_req;

/* Procedure to pend the current output request */

pend_out_req: proc;

dcl  i fixed bin;

	     i = out_req.device;
	     ad.pend_time (i) = clock + ad.pend_interval; /* Time to retry */
	     call schedule_timer;
	     out_reqp, ad.cur_out_reqp = null;
	     ad.output_in_progress = "0"b;
	     return;

	end pend_out_req;

/* Procedure to select the next output request to perform. The oldest unpended request is used */

get_next_out_req: proc;

dcl  i fixed bin;
dcl  j fixed bin init (-1);
dcl  min_time fixed bin (71) init (10000000000000000000000000000000000000000000000000000b); /* 2**52 */

	     ad.cur_out_reqp, out_reqp = null;		/* Answer if nothing found */
	     if ad.min_dev = -1 then return;		/* Nothing queued */
	     do i = ad.min_dev to ad.max_dev;
		if (ad.first_out_reqp (i) ^= null) & (ad.pend_time (i) = 0) then do;
						/* This device has unpended request */
		     if ad.first_out_reqp (i) -> out_req.req_time < min_time then do;
			min_time = ad.first_out_reqp (i) -> out_req.req_time;
			j = i;			/* Remebert index */
		     end;
		end;
	     end;
	     if j = -1 then return;			/* All requests are pended */
	     ad.cur_out_reqp, out_reqp = ad.first_out_reqp (j);
	     return;

	end get_next_out_req;

/* Procedure to free an output request */

free_out_req: proc;

dcl  i fixed bin;
dcl (min_dev, max_dev) fixed bin;

	     i = out_req.device;
	     ad.first_out_reqp (i) = out_req.next_out_reqp;
	     if ad.first_out_reqp (i) = null then do;	/* No more for this device */
		ad.last_out_reqp (i) = null;
		if (i = ad.min_dev) | (i = ad.max_dev) then do; /* If request is for one of limits, must adjust */
		     min_dev, max_dev = -1;
		     do i = ad.min_dev to ad.max_dev;
			if ad.first_out_reqp (i) ^= null then do;
			     if min_dev = -1 then min_dev = i;
			     max_dev = i;
			end;
		     end;
		     ad.min_dev = min_dev;
		     ad.max_dev = max_dev;
		end;
	     end;
	     free out_msg;
	     free out_req;
	     return;

	end free_out_req;

/* Schuduler error recovery timer */

schedule_timer: proc;

	     call timer_manager_$alarm_wakeup (ad.pend_interval, "10"b, ad.timer_channel);
	     return;

	end schedule_timer;

/* Procedure that is invoked on timer wakeups to unpend all output whose time has come */

unpend_out_req: proc;

dcl  req_pending bit (1) init ("0"b);			/* Set if pended requests are found */
dcl  req_unpended bit (1) init ("0"b);			/* Set if some output released */
dcl  now fixed bin (71);
dcl  i fixed bin;

	     if ad.min_dev = -1 then return;
	     now = clock;
	     do i = ad.min_dev to ad.max_dev;
		if (ad.first_out_reqp (i) ^= null) & (ad.pend_time (i) ^= 0) then do;
		     req_pending = "1"b;
		     if now >= ad.pend_time (i) then do; /* Found one */
			ad.pend_time (i) = 0;
			req_unpended = "1"b;
		     end;
		end;
	     end;
	     if req_unpended & ^ad.output_in_progress then call worker; /* Fire up output */
	     if req_pending & ^req_unpended then call schedule_timer;
	     return;

	end unpend_out_req;

/* Procedure to perform queued device polling */

poll_more_devices: proc;

dcl  i fixed bin;

	     if ad.output_in_progress then return;	/* Must finish output first */

	     if ad.first_poll_reqp ^= null then do;	/* If there is request */
		if ad.polling_in_progress then do;	/* Already polling */
		     if ad.last_device_polled = -1 then call stop_auto_poll; /* Stop polling if general poll */
		     return;			/* Cant do  more polling while polling in progress */
		end;
		poll_reqp = ad.first_poll_reqp;	/* Get firrst request */
		ad.first_poll_reqp = poll_req.next_poll_reqp;
		if ad.first_poll_reqp = null then ad.last_poll_reqp = null;
		i = poll_req.device;
		free poll_req;			/* Dont need this anymore */
		call poll (i);			/* Poll indicated device */
		return;
	     end;

	     else if ^ad.polling_in_progress then	/* If not polling */
		if ad.general_poll then call auto_poll (-1); /* Restart auto general poll */
	     return;

	end poll_more_devices;

/* Queue a poll request */

queue_poll_req: proc (device);

dcl  device fixed bin;
dcl  first bit (1) init ("0"b);			/* If set, entry goes to head of queue */

queue_poll_join:
	     allocate poll_req in (work_area);
	     poll_req.next_poll_reqp = null;
	     poll_req.device = device;

	     if ad.first_poll_reqp = null then		/* Only request in queue */
		ad.first_poll_reqp, ad.last_poll_reqp = poll_reqp;
	     else if first then do;			/* Must queue at head */
		poll_req.next_poll_reqp = ad.first_poll_reqp;
		ad.first_poll_reqp = poll_reqp;
	     end;
	     else do;				/* Must queue at end */
		ad.last_poll_reqp -> poll_req.next_poll_reqp = poll_reqp;
		ad.last_poll_reqp = poll_reqp;
	     end;
	     return;

queue_poll_req_first: entry (device);			/* Satart here to put entry at head of queue */

	     first = "1"b;
	     go to queue_poll_join;

	end queue_poll_req;

/* Procedure to build the output data messages from the write_info structure */

format_write_msg: proc;

dcl  seq char (4);					/* For short control sequences */
dcl (i, j) fixed bin;
dcl  ch char (1);
dcl  msg_len fixed bin;
dcl  bc char (j) based (addr (substr (output_buf, msg_len+1, 1)));

	     msg_len = 0;
	     substr (seq, 1, 1) = ad.stx;		/* Standard start */
	     call move_seq (1);

	     substr (seq, 1, 1) = ad.esc;		/* Start command sequence */
	     unspec (ch) = "0"b || command_codes (write_info.command);
	     substr (seq, 2, 1) = ch;
	     if write_info.command = COPY then do;
		i = bin (substr (string (write_info.write_ctl_char.bits), 1, 4) || write_info.copy_bits);
		substr (seq, 3, 1) = ad.bit6_char (i);	/* The copy control char */
		substr (seq, 4, 1) = ad.bit6_char (write_info.from_device);
		call move_seq (4);
		go to end_format_write;
	     end;
	     if write_info.command = READ_BUFFER | write_info.command = READ_MODIFIED then do;
		call move_seq (2);			/* No wcc for read type commands */
		go to end_format_write;
	     end;
	     substr (seq, 3, 1) = ad.bit6_char (bin (string (write_info.write_ctl_char.bits)));
	     call move_seq (3);			/* Move esc-cmd-wcc */

	     do i = 1 to write_info.mod_fields;		/* Rest of message is per/field */
		if write_info.set_buffer_addr (i) then do;
		     substr (seq, 1, 1) = ad.sba;	/* Set buffer address code */
		     substr (seq, 2, 2) = make_addr (write_info.field_position (i));
		     call move_seq (3);
		end;
		if write_info.start_field (i) then do;	/* New fields */
		     substr (seq, 1, 1) = ad.sf;
		     substr (seq, 2, 1) = ad.bit6_char (bin (string (write_info.attributes (i))));
		     call move_seq (2);
		end;
		if write_info.insert_cursor (i) then do;
		     substr (seq, 1, 1) = ad.ic;
		     call move_seq (1);
		end;
		if write_info.program_tab (i) then do;
		     substr (seq, 1, 1) = ad.pt;
		     call move_seq (1);
		end;
		if write_info.repeat_to_addr (i) then do;
		     substr (seq, 1, 1) = ad.ra;	/* Repeat to address code */
		     substr (seq, 2, 2) = make_addr (write_info.field_position (i));
		     if length (write_info.contents (i)) = 0 then substr (seq, 4, 1) = low (1); /* Default char */
		     else do;
			ch = substr (write_info.contents (i), 1, 1);
			if ^ad.ascii then call ibm3270_translate_$ascii_to_ebcdic (addr (ch), 1);
			substr (seq, 4, 1) = ch;
		     end;
		     call move_seq (4);
		end;
		if write_info.erase_to_addr (i) then do;
		     substr (seq, 1, 1) = ad.eua;
		     substr (seq, 2, 2) = make_addr (write_info.field_position (i));
		     call move_seq (3);
		end;
		j = length (write_info.contents (i));
		if ^write_info.repeat_to_addr (i) & j > 0 then do;
		     if j > (length (output_buf) - msg_len) then go to big_write_err;
		     substr (output_buf, msg_len+1, j) = write_info.contents (i);
		     if ^ad.ascii then call ibm3270_translate_$ascii_to_ebcdic (substraddr (output_buf, msg_len+1), j);
		     msg_len = msg_len + j;
		end;
	     end;

end_format_write:
	     substr (seq, 1, 1) = ad.etx;
	     call move_seq (1);

	     allocate out_req in (work_area);
	     out_req.out_msgl = msg_len;
	     allocate out_msg in (work_area);
	     out_msg = substr (output_buf, 1, msg_len);	/* Copy to smaller buffer */
	     out_req.req_time = 0;
	     out_req.device = write_info.device;
	     out_req.sent_len = 0;
	     out_req.eot_sent = "0"b;
	     out_req.req_time = 0;
	     out_req.retry_count = 0;
	     code = 0;

	     return;

big_write_err:
	     code = error_table_$long_record;
	     return;

/* Procedure to move short control sequqnces into the output stream. These cannot be split between data blocks */

move_seq:	     proc (n);

dcl  n fixed bin;

		if n > (length (output_buf) - msg_len) then go to big_write_err;
		substr (output_buf, msg_len+1, n) = substr (seq, 1, n);
		msg_len = msg_len + n;
		return;

	     end move_seq;

	end format_write_msg;

/* Build 2 character address from a position */

make_addr: proc (pos) returns (char (2));

dcl  pos fixed bin;
dcl (i, j) fixed bin;

	     i = divide (pos, 64, 17, 0);
	     j = mod (pos, 64);
	     return (ad.bit6_char (i) || ad.bit6_char (j));

	end make_addr;

/* This procedure checks errors on calls to the ring0 tty dim. If the error indicates that line
   status is present, it is picked up and classified according to whehter it affects input or output */

check_error_code: proc;

	     if code ^= error_table_$line_status_pending then return; /* More serious error */
	     ad.polling_in_progress = "0"b;		/* Any line status error stops polling */
	     call hcs_$tty_order (ad.tty_index, "line_status", addr (line_stat), state, code); /* Pick up status */
	     if code ^= 0 then return;		/* Seriout error */

	     if line_stat.op < lbound (line_stat_lab, 1) | line_stat.op > hbound (line_stat_lab, 1) then return;
	     go to line_stat_lab (line_stat.op);

line_stat_lab (1):					/* Input codes */
line_stat_lab (4):
	     ad.input_line_status = line_stat.op;
	     return;

line_stat_lab (2):					/* Output codes */
line_stat_lab (3):
line_stat_lab (6):
line_stat_lab (7):
line_stat_lab (8):
line_stat_lab (9):
line_stat_lab (10):
line_stat_lab (11):
line_stat_lab (12):
	     ad.output_line_status = line_stat.op;
	     return;

line_stat_lab (5):					/* Codes to ignore */
	     return;

	end check_error_code;

/* The following procedure queues up an error condition so the input reader will see it. */
/* This is done because the error may be detected by the event call handler who has no-one to tell. */

queue_error: proc (device, code);

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

	     call get_read_info (0, 0);
	     read_info.device = device;
	     read_info.code = code;
	     read_info.key = ERROR;
	     call queue_read_info;
	     return;

	end queue_error;

/* Builtin function substraddr until it is real */

substraddr: proc (c, n) returns (ptr);

dcl  c char (*);
dcl  n fixed bin;
dcl  ca (n) char (1) based (addr (c));

	     return (addr (ca (n)));

	end substraddr;


     end ibm3270_control_;




		    ibm3270_io_call_.pl1            11/15/82  1830.5rew 11/15/82  1506.4       97884



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


/* IBM3270_IO_CALL_ - Handles the io_call order for the ibm3270_ i/o module */
/* Written October 1977 by Larry Johnson */

ibm3270_io_call_: proc (arg_iocbp, arg_info_ptr, arg_code);

/* Parameters */

dcl  arg_iocbp ptr;
dcl  arg_info_ptr ptr;
dcl  arg_code fixed bin (35);

/* Automatic */

dcl  code fixed bin (35);
dcl  iocbp ptr;
dcl  order char (32);
dcl  ev_chan fixed bin (71);
dcl  i fixed bin;
dcl (err, rpt) entry variable options (variable);
dcl  caller char (32);
dcl  free_areap ptr;
dcl  arg_no fixed bin;
dcl  carg char (io_call_info.max_arglen) based (addr (io_call_info.args (arg_no))) var;
dcl  segp ptr;
dcl  segl fixed bin (21);
dcl  seg char (segl) based (segp);
dcl  bit_count fixed bin (24);
dcl  dir char (168);
dcl  ename char (32);

dcl  free_area area based (free_areap);

dcl 1 auto_read_ctl like read_ctl aligned automatic;

/* External */

dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  get_system_free_area_ entry returns (ptr);
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));

dcl  error_table_$noarg ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);

dcl  conversion condition;

dcl (addr, bin, bit, length, null, rtrim, substr, unspec) builtin;

/* Constants */

dcl  write_help (5) char (256) var int static options (constant) init (
     "Usage: io_call control switchname write DEV {control_args}
Command control_args:
  -write, -wr
  -erase_write, -erwr
  -copy DEV, -cp DEV (DEV is from device)
  -erase_unprotected, -erun
  -read_modified, -rdm
  -read_buffer, -rdb",
     "Write control char control_args:
  -print_format BB, -pf BB
  -start_printer, -sp
  -sound_alarm, -sa
  -keyboard_restore, -kr
  -reset_mdt, -rm
  -copy_bits BB, -cb BB",
     "Order control_args:
  -set_buffer_addr POS, -sba POS
  -start_field, -sf
  -insert_cursor, -ic
  -program_tab, -pt
  -repeat_to_addr POS, -rta POS
  -erase_to_addr POS, -eta POS",
     "Attribute control_args (-start_field implied):
  -protected, -pr
  -numeric, -num
  -display_form BB, -df BB
  -mdt",
     "Other args:
  ""data"" (arg with no '-' is stuff to write)
  -string data (for when data starts with -)
  -segment path, -sm path (when data is in segment)
  -next (to start new write_info.data when no data)");

%include io_call_info;

%include ibm3270_io_info;


	iocbp = arg_iocbp;
	io_call_infop = arg_info_ptr;
	order = io_call_info.order_name;
	err = io_call_info.error;
	rpt = io_call_info.report;
	caller = io_call_info.caller_name;
	arg_no = 1;

	if order = "event_info" then do;		/* Return event channel */
	     call iox_$control (iocbp, "event_info", addr (ev_chan), code);
	     if code = 0 then call rpt ("Event channel = ^.3b", unspec (ev_chan));
	end;

	else if order = "poll" then do;
	     i = bin_arg ("device");
	     call iox_$control (iocbp, "poll", addr (i), code);
	end;

	else if order = "read" then do;
	     read_ctlp = addr (auto_read_ctl);
	     read_ctl.version = 1;
	     call iox_$control (iocbp, "read", addr (read_ctl), code); /* Get the data */
	     if code = 0 then do;			/* It worked, print results */
		call rpt ("Device:^-^d ^d  Cursor: ^d", read_info.controller, read_info.device,
		     read_info.cursor_position);
		call rpt ("Reason:^-^d ^d Code ^o", read_info.key, read_info.sub_key, read_info.code);
		if read_info.key = STATUS then call rpt ("Status:^-^b", read_info.bits);
		do i = 1 to read_info.mod_fields;
		     call rpt ("^4d^5d ^a", read_info.field_position (i), length (read_info.contents (i)),
			read_info.contents (i));
		end;
		free read_info;
	     end;
	end;

	else if order = "write" then do;
	     if io_call_info.nargs = 0 then do;		/* Help */
		do i = 1 to 5;
		     call rpt ("^a", write_help (i));
		end;
		code = 0;
		go to control_return;
	     end;
	     free_areap = get_system_free_area_ ();
	     max_write_fields = io_call_info.nargs;
	     max_write_len = io_call_info.max_arglen;
	     do arg_no = 2 to io_call_info.nargs;	/* Gent length of longest -sm arg */
		if carg = "-segment" | carg = "-sm" then do;
		     call path_next_arg;
		     max_write_len = max (max_write_len, segl);
		     call hcs_$terminate_noname (segp, code);
		end;
	     end;
	     allocate write_info in (free_area);	/* Probably too large, but thats ok */
	     unspec (write_info) = "0"b;		/* Start clean */
	     write_info.version = 1;
	     write_info.max_fields = max_write_fields;
	     write_info.max_len = max_write_len;
	     write_info.command = WRITE;
	     arg_no = 1;
	     write_info.device = bin_arg ("device");
	     i = 0;
	     do arg_no = 2 to io_call_info.nargs;
		if carg = "-write" | carg = "-wr" then write_info.command = WRITE;
		else if carg = "-erase_write" | carg = "-erwr" then write_info.command = ERASE_WRITE;
		else if carg = "-copy" | carg = "-cp" then do;
		     write_info.command = COPY;
		     write_info.from_device = bin_next_arg ();
		end;
		else if carg = "-erase_unprotected" | carg = "-erun" then write_info.command = ERASE_UNPROTECTED;
		else if carg = "-read_modified" | carg = "-rdm" then write_info.command = READ_MODIFIED;
		else if carg = "-read_buffer" | carg = "-rdb" then write_info.command = READ_BUFFER;

		else if carg = "-print_format" | carg = "-pf" then write_info.print_format = bit2_next_arg ();
		else if carg = "-start_printer" | carg = "-sp" then write_info.start_printer = "1"b;
		else if carg = "-sound_alarm" | carg = "-sa" then write_info.sound_alarm = "1"b;
		else if carg = "-keyboard_restore" | carg = "-kr" then write_info.keyboard_restore = "1"b;
		else if carg = "-reset_mdt" | carg = "-rm" then write_info.reset_mdt = "1"b;
		else if carg = "-copy_bits" | carg = "-cb" then write_info.copy_bits = bit2_next_arg ();
		else if carg = "-next" then i, write_info.mod_fields = i+1;
		else go to continue_write_scan;	/* Other args require array setup */
		go to end_write_scan;		/* Processed args not releated to data array */
continue_write_scan:
		if i = 0 then i, write_info.mod_fields = 1; /* Must be in at least first array */

		if carg = "-set_buffer_addr" | carg = "-sba" then do;
		     write_info.set_buffer_addr (i) = "1"b;
		     write_info.field_position (i) = bin_next_arg ();
		end;
		else if carg = "-start_field" | carg = "-sf" then write_info.start_field (i) = "1"b;
		else if carg = "-insert_cursor" | carg = "-ic" then write_info.insert_cursor (i) = "1"b;
		else if carg = "-program_tab" | carg = "-pt" then write_info.program_tab (i) = "1"b;
		else if carg = "-repeat_to_addr" | carg = "-rta" then do;
		     write_info.repeat_to_addr (i) = "1"b;
		     write_info.field_position (i) = bin_next_arg ();
		end;
		else if carg = "-erase_to_addr" | carg = "-eta" then do;
		     write_info.erase_to_addr (i) = "1"b;
		     write_info.field_position (i) = bin_next_arg ();
		end;

		else if carg = "-protected" | carg = "-pr" then
		     write_info.protected (i), write_info.start_field (i) = "1"b;
		else if carg = "-numeric" | carg = "-num" then
		     write_info.numeric (i), write_info.start_field (i) = "1"b;
		else if carg = "-display_form" | carg = "-df" then do;
		     write_info.start_field (i) = "1"b;
		     write_info.display_form (i) = bit2_next_arg ();
		end;
		else if carg = "-mdt" then write_info.mdt (i) = "1"b;

		else if carg = "-string" then do;
		     if arg_no = io_call_info.nargs then do;
			call err (error_table_$noarg, caller, "After ^a", carg);
			code = 0;
			go to control_return;
		     end;
		     arg_no = arg_no+1;
		     write_info.contents (i) = carg;
		     if arg_no < io_call_info.nargs then i, write_info.mod_fields = i+1;
		end;
		else if carg = "-segment" | carg = "-sm" then do;
		     call path_next_arg;
		     write_info.contents (i) = seg;
		     call hcs_$terminate_noname (segp, code);
		     if arg_no < io_call_info.nargs then i, write_info.mod_fields = i+1;
		end;
		else if substr (carg, 1, 1) = "-" then do;
		     call err (error_table_$badopt, caller, "^a", carg);
		     code = 0;
		     go to control_return;
		end;
		else do;
		     write_info.contents (i) = carg;
		     if arg_no < io_call_info.nargs then i, write_info.mod_fields = i+1;
		end;
end_write_scan:
	     end;
	     call iox_$control (iocbp, "write", write_infop, code);
	     free write_info;
	end;

	else call iox_$control (iocbp, rtrim (order), null, code);

control_return:
	arg_code = code;
	return;

/* Argument converting routines */

bin_arg:	proc (s) returns (fixed bin);

dcl  s char (*);

	     on conversion go to bin_arg_err;
	     return (bin (carg));
bin_arg_err:
	     call err (0, caller, "Invalid ^a: ^a", s, carg);
	     code = 0;
	     go to control_return;

	end bin_arg;

bin_next_arg: proc returns (fixed bin);

	     if arg_no ^< io_call_info.nargs then do;
		call err (error_table_$noarg, caller, "After ^a", carg);
		code = 0;
		go to control_return;
	     end;
	     arg_no = arg_no + 1;
	     return (bin_arg ((io_call_info.args (arg_no-1))));

	end bin_next_arg;

bit2_arg:	proc (s) returns (bit (2));

dcl  s char (*);

	     on conversion go to bit2_arg_err;
	     return (bit (carg));
bit2_arg_err:
	     call err (0, caller, "Invalid ^a: ^a", s, carg);
	     code = 0;
	     go to control_return;

	end bit2_arg;

bit2_next_arg: proc returns (bit (2));

	     if arg_no ^< io_call_info.nargs then do;
		call err (error_table_$noarg, caller, "After ^a", carg);
		code = 0;
		go to control_return;
	     end;
	     arg_no = arg_no + 1;
	     return (bit2_arg ((io_call_info.args (arg_no-1))));

	end bit2_next_arg;

/* For pathname args */

path_next_arg: proc;

	     if arg_no ^< io_call_info.nargs then do;
		call err (error_table_$noarg, caller, "After ^a", carg);
		code = 0;
		go to control_return;
	     end;
	     arg_no = arg_no + 1;
	     call expand_pathname_ ((carg), dir, ename, code);
	     if code ^= 0 then do;
		call err (code, caller, "^a", carg);
		code = 0;
		go to control_return;
	     end;
	     call hcs_$initiate_count (dir, ename, "", bit_count, 0, segp, code);
	     if segp = null then do;
		call err (code, caller, "^a^[>^]^a", dir, (dir ^= ">"), ename);
		code = 0;
		go to control_return;
	     end;
	     segl = divide (bit_count, 9, 21, 0);
	     return;

	end path_next_arg;

     end ibm3270_io_call_;




		    ibm3270_translate_.alm          11/15/82  1830.5rew 11/15/82  1533.4       44397



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



"	Procedures to do translation for ibm3270_ I/O module.
"	Written January 1978 by Larry Johnson


"	dcl ibm3270_translate_$ascii_to_ebcdic entry (ptr, fixed bin);
"	dcl ibm3270_translate_$ebcdic_to_ascii entry (ptr, fixed bin);

"	call ibm3270_translate_$ebcdic_to_ascii (stringp, stringl);


	name	ibm3270_translate_

	segdef	ascii_to_ebcdic
	segdef	ebcdic_to_ascii

ascii_to_ebcdic:
	epp1	ap|2,*		pointer to first arg
	epp1	1|0,*		pointer to character string
	lda	ap|4,*		string length
	even
	mvt	(pr,rl),(pr,rl),fill(040)
	desc9a	1|0,al
	desc9a	1|0,al
	arg	ae_table
	short_return

ebcdic_to_ascii:
	epp1	ap|2,*		pointer to first arg
	epp1	1|0,*		pointer to character string
	lda	ap|4,*		string length
	even
	mvt	(pr,rl),(pr,rl),fill(040)
	desc9a	1|0,al
	desc9a	1|0,al
	arg	ea_table
	short_return

"			EBCDIC OUTPUT	EBCDIC GRAPHIC	HEXADECIMAL
ae_table:		oct	000001002003	NUL,SOH,STX,ETX	00,01,02,03
		oct	067055056057	EOT,ENQ,ACK,BEL	37,2D,2E,2F
		oct	026005025013	BS,HT,NL,VT	16,05,15,0B
		oct	014015016017	NP,CR,SO,SI	0C,0D,0E,0F
		oct	020021022023	DLE,DC1,DC2,TM	10,11,12,13
		oct	074075062046	DC4,NAK,SYN,ETB	3C,3D,32,26
		oct	030031077047	CAN,EM,SUB,ESC	18,19,3F,27
		oct	034035036037	IFS,IGS,IRS,IUS	1C,1D,1E,1F
		oct	100132177173	space,!,",#	40,5A,7F,7B
		oct	133154120175	$,%,&,apostrophe	5B,6C,50,7D
		oct	115135134116	(,),*,+		4D,5D,5C,4E
		oct	153140113141	",",-,.,/		6B,60,4B,61
		oct	360361362363	0,1,2,3		F0,F1,F2,F3
		oct	364365366367	4,5,6,7		F4,F5,F6,F7
		oct	370371172136	8,9,:,";"		F8,F9,7A,5E
		oct	114176156157	<,=,>,?		4C,7E,6E,6F
		oct	174301302303	@,A,B,C		7C,C1,C2,C3
		oct	304305306307	D,E,F,G		C4,C5,C6,C7
		oct	310311321322	H,I,J,K		C8,C9,D1,D2
		oct	323324325326	L,M,N,O		D3,D4,D5,D6
		oct	327330331342	P,Q,R,S		D7,D8,D9,E2
		oct	343344345346	T,U,V,W		E3,E4,E5,E6
		oct	347350351255	X,Y,Z,[		E7,E8,E9,AD
		oct	340275137155	\,],^,_		E0,BD,5F,6D
		oct	171201202203	`,a,b,c		79,81,82,83
		oct	204205206207	d,e,f,g		84,85,86,87
		oct	210211221222	h,i,j,k		88,89,91,92
		oct	223224225226	l,m,n,o		93,94,95,96
		oct	227230231242	p,q,r,s		97,98,99,A2
		oct	243244245246	t,u,v,w		A3,A4,A5,A6
		oct	247250251300	x,y,z,{		A7,A8,A9,C0
		oct	117320241007	solid bar,},~,DEL	4F,D0,A1,07

"			ASCII OUTPUT	ASCII GRAPHIC	EBCDIC INPUT
ea_table:		oct	000001002003	NUL,SOH,STX,ETX	00-3
		oct	032011032177	-,HT,-,DEL	04-7
		oct	032032032013	-,-,-,VT		08-B
		oct	014015016017	FF,CR,SO,SI	0C-F
		oct	020021022023	DLE,DC1,DC2,DC3	10-3
		oct	032032010032	-,-,BS,-		14-7
		oct	030031032032	CAN,EM,-,-	18-B
		oct	034035036037	FS,GS,RS,US	1C-F
		oct	032032032032	-,-,-,-		20-3
		oct	032012027033	-,LF,ETB,ESC	24-7
		oct	032032032032	-,-,-,-		28-B
		oct	032005006007	-,ENQ,ACK,BEL	2C-F
		oct	032032026032	-,-,SYN,-		30-3
		oct	032032032004	-,-,-,EOT		34-7
		oct	032032032032	-,-,-,-		38-B
		oct	024025032032	DC4,NAK,-,SUB	3C-F
		oct	040032032032	(space),-,-,-	40-3
		oct	032012032032	-,NL,-,-		44-7
		oct	032032032056	-,-,-,.		48-B
		oct	074050053174	<,(,+,|		4C|F
		oct	046032032032	&,-,-,-		50-3
		oct	032032032032	-,-,-,-		54-7
		oct	032032041044	-,-,!,$		58-B
		oct	052051073136	*,),";",^		5C-F
		oct	055057032032	"-",/,-,-		60-3
		oct	032032032032	-,-,-,-		64-7
		oct	032032032054	-,-,-,","		68-B
		oct	045137076077	%,_,>,?		6C-F
		oct	032032032032	-,-,-,-		70-3
		oct	032032032032	-,-,-,-		74-7
		oct	032140072043	-,`,:,#		78-B
		oct	100047075042	@,',=,"		7C-F
		oct	032141142143	-,a,b,c		80-3
		oct	144145146147	d,e,f,g		84-7
		oct	150151032032	h,i,-,-		88-B
		oct	032032032032	-,-,-,-		8C-F
		oct	032152153154	-,j,k,l		90-3
		oct	155156157160	m,n,o,p		94-7
		oct	161162032032	q,r,-,-		98-B
		oct	032032032032	-,-,-,-		9C-F
		oct	032176163164	-,~,s,t		A0-3
		oct	165166167170	u,v,w,x		A4-7
		oct	171172032032	y,z,-,-		A8-B
		oct	032133032032	-,[,-,-		AC-F
		oct	032032032032	-,-,-,-		B0-3
		oct	032032032032	-,-,-,-		B4-7
		oct	032032032032	-,-,-,-		B8-B
		oct	032135032032	-,],-,-		BC-F
		oct	173101102103	{,A,B,C		C0-3
		oct	104105106107	D,E,F,G		C4-7
		oct	110111032032	H,I,-,-		C8-B
		oct	032032032032	-,-,-,-		CC-F
		oct	175112113114	},J,K,L		D0-3
		oct	115116117120	M,N,O,P		D4-7
		oct	121122032032	Q,R,-,-		D8-B
		oct	032032032032	-,-,-,-		DC-F
		oct	134032123124	\,-,S,T		E0-3
		oct	125126127130	U,V,W,X		E4-7
		oct	131132032032	Y,Z,-,-		E8-B
		oct	032032032032	-,-,-,-		EC-F
		oct	060061062063	0,1,2,3		F0-3
		oct	064065066067	4,5,6,7		F4-7
		oct	070071032032	8,9,-,-		F8-B
		oct	032032032032	-,-,-,-		FC-F

	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
