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