



		    g115_.alm                       02/23/78  1042.6rew 02/23/78  1038.9       13599



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

"Interface Module Transfer Vector for the
"g115 printer Interface Module
" modified 07-22-77 by Bob Franklin to add resetread,resetwrite,abort entries.

	entry	g115_module
g115_module:
	tra *+1,6		go to proper transfer instruction

	tra <g115_dim_>|[g115_attach]
	tra <g115_dim_>|[g115_detach]
	tra <g115_dim_>|[g115_read]
	tra <g115_dim_>|[g115_write]
	tra <g115_dim_>|[g115_cntrl]     abort call
	tra <g115_dim_>|[g115_order]
	tra <g115_dim_>|[g115_cntrl]     resetread call
	tra <g115_dim_>|[g115_cntrl]     resetwrite call
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <g115_dim_>|[g115_modes]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]
	tra <ios_>|[no_entry]

	end




		    g115_as_.pl1                    02/23/78  1042.6rew 02/23/78  1039.5       36513



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

g115_as_: proc;


/* g115_as_ - procedure to interface answering service when it needs to
   work the g115 or mds2400.
   tty_index entry must be called first to establish a data structure for the device.
   the other entries rely on the presence of this data structure */


/* coded 07/11/75 by Bob Adsit */

dcl (t_twx, asw, dflag, state, istate, aoffset, anelem, anelemt) fixed bin;

dcl  process_id bit (36) aligned,
     save_trim bit (1);

dcl (bufp, orderp) ptr;
dcl  null builtin;

dcl (device, order, new_mode, old_mode) char (*);
dcl (rcard varying, bcard based (bufp)) char (80);

dcl  event fixed bin (71);
dcl  code fixed bin (35);
dcl  error_table_$not_attached fixed bin (35) ext;

dcl 1 modes aligned,
      2 len fixed bin,
      2 str char (256);

dcl  g115_util_$set_ptr entry (ptr),
     g115_util_$get_data_ptr entry (fixed bin) returns (ptr),
     g115_util_$conv_card entry (char (*) varying),
     g115_control_$init entry (char (*), fixed bin, fixed bin (35)),
     g115_control_$detach entry (fixed bin, fixed bin(35)),
     g115_io_$read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)),
     g115_io_$write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)),
     hcs_$tty_index entry (char (*), fixed bin, fixed bin, fixed bin (35)),
     hcs_$tty_event entry (fixed bin, fixed bin(71), fixed bin, fixed bin(35)),
     hcs_$tty_abort entry (fixed bin, fixed bin, fixed bin, fixed bin(35)),
     hcs_$tty_state entry (fixed bin, fixed bin, fixed bin(35)),
     hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin(35)),
     hcs_$tty_detach_new_proc entry (fixed bin, bit (36) aligned, fixed bin, fixed bin (35));



%include g115_data;



as_index: entry (device, t_twx, state, code);

	call hcs_$tty_index (device, t_twx, state, code);
	if code ^= 0 then return;

	call g115_control_$init (device, t_twx, code);
	return;


as_event: entry (t_twx, event, state, code);

	call init_device;
	g115_data.as_ev_chan = event;
	call hcs_$tty_event (t_twx, event, state, code);
	return;


as_order: entry (t_twx, order, orderp, state, code);

	call hcs_$tty_order (t_twx, order, orderp, state, code);
	return;


as_changemode: entry (t_twx, new_mode, old_mode, code);

	modes.len = length (modes.str);
	modes.str = new_mode;
	call hcs_$tty_order (t_twx, "modes", addr (modes), istate, code);
	old_mode = modes.str;
	return;


as_state: entry (t_twx, state, code);

	call hcs_$tty_state (t_twx, state, code);
	return;


as_abort: entry (t_twx, asw, state, code);

	call hcs_$tty_abort (t_twx, asw, state, code);
	return;


as_detach: entry (t_twx, dflag, state, code);

	call init_device;
	call g115_control_$detach (t_twx, code);
	state = 1;
	return;


as_detach_new_proc: entry (t_twx, process_id, state, code);

	call hcs_$tty_detach_new_proc (t_twx, process_id, state, code);
	return;


as_read:	entry (t_twx, bufp, aoffset, anelem, anelemt, state, code);

	call init_device;
	call g115_util_$conv_card (rcard);		/* get and convert a card for the as */
	bcard = rcard;				/* return it */
	anelemt = length (rcard);
	return;



as_write:
as_write_force: entry (t_twx, bufp, aoffset, anelem, anelemt, state, code);

	call init_device;
	call g115_io_$write (t_twx, bufp, aoffset, anelem, anelemt, code);
	return;



init_device: proc;

	data_ptr = g115_util_$get_data_ptr (t_twx);
	if data_ptr = null then do;
	     code = error_table_$not_attached;
	     go to error;
	end;
	g115_data.no_block = "1"b;
	call g115_util_$set_ptr (data_ptr);
	state = 5;
	code = 0;
	return;

     end;

error:	return;

  end;




		    g115_control_.pl1               02/23/78  1042.6rew 02/23/78  1038.1      158139



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

g115_control_: proc;


/* g115_control_ - Main control procedure for the g115_ DIM.
   This routine controls attaching and detaching of the device and
   the order and mode calls. Attaching includes a step which waits
   for the device to become ready, called listening. */

/* Coded April 26, 1974 Mike Grady */

/* modified 06/10/75 by Bob Adsit to move line_control to MCS/355 */
/* modified 04/10/77 by Bob Franklin to fix bugs, add order codes of
   start, quit_disable, and quit_enable.  */
/* Modified 2/78 by J. C. Whitmore to use new prt_conv_info.incl.pl1 */

dcl (dev_index, nelemt, j, lmode, k, state, new_line_type, msg_len) fixed bin,
     periph_type based (order_ptr) fixed bin,
     code fixed bin (35),
    (error_table_$undefined_order_request, error_table_$ionmat,
     error_table_$bad_mode, error_table_$bad_arg, error_table_$inconsistent,
     error_table_$noalloc) fixed bin (35) ext,
     ostring char (120) varying,
    (request, new_mode, old_mode, dev_name) char (*),
    (order_ptr, sysareap int static, msg_ptr) ptr,
    (addr, bool, null, rel) builtin,
    (area, storage) condition;

dcl  g115_io_$write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35));

dcl  NL char (1) init ("
"),
     VT_or_FF char (2) init ("");

dcl  g115_conv_$g115_conv_ fixed bin ext;

dcl  sys_area area based (sysareap);

dcl 1 page_labels based (order_ptr) aligned,		/* structure used in "page_labels" call */
    2 top_label char (136),				/* label for top of page */
    2 bottom_label char (136);			/* label for bottom of page */

dcl 1 counts based (order_ptr) aligned,			/* structure used in "get_count" call */
    2 line fixed bin,				/* line number */
    2 page_length fixed bin,				/* length of page */
    2 lmarg fixed bin,				/* left margin indentation */
    2 rmarg fixed bin,				/* line length */
    2 line_count fixed bin,				/* count of lines printed */
    2 page_count fixed bin;				/* count of pages printed */

dcl 1 info_structure aligned based (order_ptr),
    2 ev_chan fixed bin (71),
    2 input_available bit (1);

dcl 1 modes aligned,
    2 len fixed bin,
    2 str char (256);

dcl 1 chan_info aligned,
    2 id char (4),
    2 baud_rate fixed bin (17) unal,
    2 line_type fixed bin (17) unal,
    2 pad bit (36),
    2 tty_type fixed bin;

dcl  g115_util_$get_ptr entry returns (ptr),
     g115_util_$set_ptr entry (ptr),
     g115_util_$get_data_ptr entry (fixed bin) returns (ptr),
     g115_util_$link_data_ptr entry (ptr),
     g115_util_$unlink_data_ptr entry (fixed bin) returns (ptr),
     g115_util_$block entry (fixed bin (35)),
     g115_message_$read entry (ptr, fixed bin, fixed bin (35)),
     hcs_$tty_index entry (char (*), fixed bin, fixed bin, fixed bin (35)),
     hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35)),
     hcs_$tty_state entry (fixed bin, fixed bin, fixed bin (35)),
     hcs_$tty_detach entry (fixed bin, fixed bin, fixed bin, fixed bin (35)),
     hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35)),
     ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)),
     get_system_free_area_ entry returns (ptr);
dcl  hcs_$tty_abort entry (fixed bin, fixed bin, fixed bin, fixed bin (35));


%include g115_data;

%include g115_msg;
%include g115_stat;
/*  */
init:	entry (dev_name, dev_index, code);
						/*  called to establish a g115_data structure for the device */

	data_ptr = g115_util_$get_data_ptr (dev_index);
	if data_ptr = null then do;			/* first call for this device */

	     on condition (storage) call clean;		/* establish handlers to catch area package signals */
	     on condition (area) call clean;

	     sysareap = get_system_free_area_ ();	/* get pointer to system free segment */

	     allocate g115_data in (sys_area) set (data_ptr); /* allocate the global data base */
	     unspec (g115_data) = "0"b;
	     call g115_util_$link_data_ptr (data_ptr);	/* link into chain - new g115_data structure */

	     revert condition (area);
	     revert condition (storage);
	end;
	g115_data.dev_name = dev_name;
	g115_data.twx = dev_index;

	g115_data.write_split,
	     g115_data.punch,
	     g115_data.teleprinter = "0"b;

	g115_data.write_compress = "1"b;
	g115_data.mask_sw = bool (rel (addr (g115_data.output_buffer1)),
	     rel (addr (g115_data.output_buffer2)), "0110"b);
	g115_data.wait_list.nchan = 2;
	call ipc_$create_ev_chn (g115_data.wait_list.hcs_ev_chan, code); /* create ring 0  event channel */
	if code ^= 0 then return;
	call ipc_$create_ev_chn (g115_data.wait_list.timeout_chan, code);
	if code ^= 0 then return;

	pcip = addr (g115_data.conv_info);
	pci.cv_proc = addr (g115_conv_$g115_conv_);
	pci.phys_line_length = 132;
	pci.phys_page_length = 66;
	pci.lpi = 6;				/* assume 6 lines per inch */
	call g115_util_$set_ptr (data_ptr);
	call order (dev_index, "reset", null, code);
	pci.line = 1;				/* the final initialization of pci */
						/* all other variables xeroed by "unspec" above */

	do slot_ptr = addr (g115_data.output_buffer1 (1)),
		addr (g115_data.output_buffer2 (1));

	     g115_hdr.full_cc,
		g115_hdr.msg_type,
		g115_hdr.sub_type,
		g115_hdr.aux_bit_count,
		g115_hdr.null_ct,
		g115_hdr.text_char_count = 0;
	     g115_msg.soh = g115_stat.soh_char;
	     g115_msg.fmt_code = g115_stat.service_noaux;
	     g115_msg.addr_code = g115_stat.addr_code_char;
	     g115_msg.op_code.ascii_pad = "00"b;
	     g115_msg.op_code.use = "1"b;
	     g115_msg.op_code.ack,
		g115_msg.op_code.cmd = "0"b;
	     g115_msg.id_code = g115_stat.id_code_char;
	     g115_msg.stx = g115_stat.stx_char;
	     g115_msg.etx = g115_stat.etx_char;
	end;

	slot_ptr = addr (g115_data.input_buffer (1));
	g115_hdr.full_cc,
	     g115_hdr.text_char_count = 0;

	code = 0;					/* no error */
ret:	return;




clean:	proc;

	     code = error_table_$noalloc;
	     go to ret;

	end clean;






/*  */
modes:	entry (dev_index, new_mode, old_mode, code);

	code = 0;
	data_ptr = g115_util_$get_ptr ();
	pcip = addr (g115_data.conv_info);

	ostring = "";				/* Initialize current modes. */

	pcip = addr (g115_data.conv_info);		/* Get pointer to conversion info. */

	call add_bit ("noskip,", pci.overflow_off);	/* Insert noskip mode. */

	call add_bit ("single,", pci.single_space);	/* Insert single space mode. */

	call add_bit ("non_edited,", pci.non_edited);	/* Insert non-edited mode. */

	call add_bit ("truncate,", pci.truncate);	/* Insert truncate mode. */

	call add_bit ("trim,", g115_data.trim);		/* Insert trim mode. */

	call add_num ("ll", pci.rmarg);		/* Insert line length mode. */

	call add_num (",in", pci.lmarg);		/* Insert indent mode. */

	call add_num (",pl", pci.page_length);		/* Insert page length mode. */

	ostring = ostring || ".";			/* Place period at end of string. */
	old_mode = ostring;				/* Return old mode settings. */


add_num:	proc (m, n);				/* internal proc to add numeric mode to ostring */

dcl  m char (*),					/* mode name */
     n fixed bin;					/* number to be converted */

dcl  number pic "zzzzz9",				/* for converting number */
     i fixed bin;					/* offset of first nonblank character */

	     ostring = ostring || m;			/* Insert mode name in ostring. */

	     number = n;				/* Zap! You're converted. */
	     i = verify (number, " ");		/* Search for nonblank. */
	     ostring = ostring || substr (number, i);	/* Insert number in ostring. */

	     return;


add_bit:	     entry (m, b);				/* internal proc to add on/off mode to ostring */

dcl  b bit (1);					/* mode bit */

	     if ^b then ostring = ostring || "^";	/* If bit off, add NOT sign. */
	     ostring = ostring || m;			/* Insert mode name in ostring. */

	     return;


	end add_num;



	j = verify (reverse (new_mode), " .;");		/* Search backwards over final breaks. */
	if j = 0 then return;			/* If no meat on the bones, just return. */
	lmode = length (new_mode) - j + 1;		/* Compute length to be examined. */

	do k = 1 repeat k + j while (k < lmode);	/* Step through new modes. */
	     j = search (substr (new_mode, k), ",;. ");	/* Search for break character. */
	     if j = 0 then j = lmode - k + 2;		/* If no breaks, take remaining length. */

	     if test ("default") then do;		/* Default should be first and only mode. */
		pci.modes = "0"b;			/* Reset all mode bits. */
		pci.top_label_length,
		     pci.bot_label_length = 0;	/* Reset labels. */
		pci.rmarg = pci.phys_line_length;	/* Reset line and page lengths. */
		pci.lmarg = 0;
		pci.page_length = pci.phys_page_length - pci.lpi;
	     end;

	     else if tests ("noskip", pci.overflow_off) then;
						/* If page overflow to be ignored ... */

	     else if tests ("single", pci.single_space) then;
						/* If single spacing to be forced ... */

	     else if tests ("non_edited", pci.non_edited) then;
						/* If non-edited mode to be forced ... */

	     else if tests ("truncate", pci.truncate) then;
						/* If long lines to be truncated ... */

	     else if tests ("trim", g115_data.trim) then; /* If setting/resetting trim mode ... */

	     else if testn ("ll", pci.rmarg) then;	/* If changing line length ... */

	     else if testn ("in", pci.lmarg) then;	/* If changing indentation ... */

	     else if testn ("pl", pci.page_length) then;	/* If changing page length ... */

	     else					/* If unrecognized key ... */
	     code = error_table_$bad_mode;

	end;

	pci.rmarg = min (pci.rmarg, pci.phys_line_length); /* Insure that line is not too long. */
	pci.lmarg = min (pci.lmarg, pci.rmarg);		/* Left margin must be to left of right margin. */

	if pci.overflow_off then do;			/* Check for "noskip" mode set. */
	     pci.top_label_length,			/* "noskip" and page labels are inconsistent. */
		pci.bot_label_length = 0;
	     pci.sheets_per_page = 1;			/* One sheet per page in noskip mode. */
	     pci.page_length = pci.phys_page_length - pci.lpi; /* Reset logical page length. */
	end;
	else					/* If "^noskip" mode ... */
	pci.sheets_per_page = divide (pci.page_length + (pci.lpi - 1) + pci.phys_page_length, pci.phys_page_length, 17, 0);
						/* Compute physical sheets of paper per page. */

	return;



test:	proc (s) returns (bit (1) aligned);		/* internal proc to test for mode key */

dcl  s char (*) aligned;				/* mode key */


	     return (substr (new_mode, k, length (s)) = s); /* Return success or failure. */


tests:	     entry (s, t) returns (bit (1) aligned);	/* entry to test for mode or ^mode */

dcl  t bit (1) unal;				/* key or ^key flag */


	     if substr (new_mode, k, length (s)) = s then do; /* If key found ... */
		t = "1"b;				/* Set flag to true. */
		return ("1"b);			/* And return. */
	     end;
	     else if substr (new_mode, k+1, length (s)) = s then
		if substr (new_mode, k, 1) = "^" then do;
		     t = "0"b;			/* If ^key found, set flag to false. */
		     return ("1"b);			/* And return. */
		end;

	     return ("0"b);				/* Key not found. */


testn:	     entry (s, i) returns (bit (1) aligned);	/* internal proc to set numeric mode */

dcl  i fixed bin;					/* numeric mode */


	     if substr (new_mode, k, length (s)) = s then do; /* If key found ... */
		i = convert (i, substr (new_mode, k + 2, j - 3)); /* Return converted number. */
		return ("1"b);
	     end;

	     return ("0"b);


	end test;

/*  */
order:	entry (dev_index, request, order_ptr, code);

	data_ptr = g115_util_$get_ptr ();		/* get ptr to dcms' global data base */

	code = 0;					/* initialize return argument */
	pcip = addr (g115_data.conv_info);

	if request = "set_periph" then do;		/* request to set target periph type */
	     g115_data.teleprinter = "0"b;		/* init to default to printer */
	     g115_data.punch = "0"b;
	     if order_ptr = null then return;		/* cant continue */
	     if periph_type = 3 then
		g115_data.teleprinter = "1"b;
	     if periph_type = 4 then
		g115_data.punch = "1"b;
	end;
	else if request = "read_status" then do;	/* request to get read status */
	     info_structure.ev_chan = g115_data.hcs_ev_chan; /* return ev chn on which read will return */
	     info_structure.input_available = "0"b;	/* none yet */
	     msg_ptr = addr (g115_data.input_buffer);	/* set ptr */
	     if msg_ptr -> g115_hdr.full_cc ^= 0 then do; /* input is ready */
		info_structure.input_available = "1"b;	/* go to it daemons */
		return;
	     end;
	     call g115_message_$read (msg_ptr, msg_len, code); /* read any ring-0 data */
	     if msg_len = 0 then return;
	     if msg_ptr -> g115_hdr.full_cc ^= 0 then	/* go some real data */
		info_structure.input_available = "1"b;
	     return;
	end;

	else if request = "inside_page" then		/* Space to top of inside page. */
	     call write_nl (2);

	else if request = "outside_page" then		/* Space to top of outside page */
	     call write_nl (4);

	else if request = "end_of_page" then		/* Position at end of page, below bottom label */
	     call write_nl (3);

	else if request = "page_labels" then do;	/* set page top and bottom labels */
	     if order_ptr = null () then do;		/* If null, reset labels. */
		pci.top_label_length,
		     pci.bot_label_length = 0;
	     end;

	     else if pci.overflow_off then		/* Cannot have labels with overflow off. */
		code = error_table_$inconsistent;

	     else do;				/* Set the labels. */
		pci.top_label_line = page_labels.top_label;
		call set_label (pci.top_label_line, pci.top_label_length);

		pci.bot_label_line = page_labels.bottom_label;
		call set_label (pci.bot_label_line, pci.bot_label_length);
	     end;
	end;

	else if request = "reset" then do;		/* Reset modes and counts. */
	     pci.lmarg = 0;
	     pci.rmarg = pci.phys_line_length;
	     pci.page_length = pci.phys_page_length - pci.lpi;
	     pci.sheets_per_page = 1;
	     pci.line_count = 0;
	     pci.page_count = 0;
	     pci.func = 0;
	     pci.modes = "0"b;
	     pci.top_label_line = "";
	     pci.bot_label_line = "";
	     pci.top_label_length = 0;
	     pci.bot_label_length = 0;
	end;

	else if request = "get_count" then do;		/* Get lengths and counts. */
	     counts.line = pci.line;
	     counts.page_length = pci.page_length;
	     counts.lmarg = pci.lmarg;
	     counts.rmarg = pci.rmarg;
	     counts.line_count = pci.line_count;
	     counts.page_count = pci.page_count * pci.sheets_per_page;
	end;

	else if request = "start" then
	     call hcs_$tty_order (dev_index, "start", null, state, code); /* pass it on */

	else if request = "quit_enable" then do;
	     call hcs_$tty_order (dev_index, "quit_enable", null, state, code);
	end;

	else if request = "quit_disable" then do;
	     call hcs_$tty_order (dev_index, "quit_disable", null, state, code);
	end;

	else code = error_table_$undefined_order_request; /* unrecognized order call */

	return;


write_nl:	proc (f);

dcl  f fixed bin;					/* function code */

	     pci.func = f;				/* Set correct function code. */
	     call g115_io_$write (g115_data.twx, addr (NL), 0, length (NL), nelemt, code);
	     pci.func = 0;				/* Make sure function code reset. */
	     if code ^= 0 then return;

	     return;


	end write_nl;




set_label: proc (line, lth);

dcl  line char (136) aligned,				/* label line */
     lth fixed bin;					/* label length */


	     if line = "" then lth = 0;		/* If line is all blank, length is zero. */

	     else if search (line, VT_or_FF) ^= 0 then do; /* Do not allow VT or FF. */
		lth = 0;				/* Set length to zero. */
		code = error_table_$bad_arg;
	     end;

	     else do;
		lth = 136 + 1 - verify (reverse (line), " ");
	     end;

	     return;


	end set_label;

/*  */

attach:	entry (dev_name, dev_index, code);		/* entry to get device started */

	call hcs_$tty_index (dev_name, dev_index, state, code);
	if code ^= 0 then return;

	call init (dev_name, dev_index, code);		/* allocate and initialize g115_data structure */
	if code ^= 0 then return;

	data_ptr = g115_util_$get_data_ptr (dev_index);

	if data_ptr = null then do;
	     code = error_table_$ionmat;
	     return;
	end;
	call g115_util_$set_ptr (data_ptr);

	call hcs_$tty_event (dev_index, g115_data.hcs_ev_chan, state, code); /* pass the call event to ring 0 */
	if code ^= 0 then return;

	call hcs_$tty_order (dev_index, "info", addr (chan_info), state, code);
	if chan_info.line_type ^= 6 & chan_info.line_type ^= 7 then do; /* not set right */
	     new_line_type = 6;			/* set to hardwired type */
	     call hcs_$tty_order (dev_index, "set_line_type", addr (new_line_type), state, code);
	     if code ^= 0 then return;
	end;

	call hcs_$tty_order (dev_index, "listen", null, state, code);
	do while (state ^= 5);
	     call g115_util_$block (code);
	     call hcs_$tty_state (dev_index, state, code);
	end;

	modes.len = length (modes.str);
	modes.str = "rawo,rawi,hndlquit";
	call hcs_$tty_order (dev_index, "modes", addr (modes), state, code);

	call hcs_$tty_order (dev_index, "quit_enable", null, state, code);

	return;



detach:	entry (dev_index, code);

	code = 0;

	data_ptr = g115_util_$unlink_data_ptr (dev_index);
	if data_ptr = null then return;		/* nothing to free */
	free g115_data in (sys_area);

	call hcs_$tty_detach (dev_index, 1, state, code);
	return;



     end;




		    g115_conv_.alm                  02/23/78  1042.6rew 02/23/78  1038.9       34272



" G115_CONV_ - Conversion for G115 remote printer.
"	coded 12/12/74 by Noel I. Morris
"	last modified 6/23/75 by Noel I. Morris
"	modified 04/10/77 by Bob Franklin to change top of inside page char
"		and dont slew on punch


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


" This module performs the necessary conversion for printing on the
" G115 remote printer.
"
" The manner in which this procedure is utilized is described in detail
" in the listing of prt_conv_.
"
" A media code character will be inserted at the beginning of each
" output line.  This character must have been placed in pci.temp
" before this procedure is called.


	name	g115_conv_

	segdef	g115_conv_


	temp	char		place for slew and record separator characters


g115_conv_:
	tra	g115_send_init
	tra	g115_send_chars
	tra	g115_send_slew_pattern
	tra	g115_send_slew_count

" 

	include	prt_conv_info


" 

g115_send_init:
	mlr	(pr),(pr)		insert media code at beginning of line
	desc9a	lb|pci.temp,1	..
	desc9a	bb|0,1		..

	ldq	1,dl		bump output pointer by 1 character
	a9bd	bb|0,ql		..

	tra	sb|0		return to caller

" 

g115_send_chars:

spaceloop:
	eaq	0,2		white space count in QU
	tmoz	nospace		skip if no white space
	sbx2	64,du		can take only 64 at a time
	tmoz	*+2		..
	ldq	64,du		if more, take 64 to begin with
	cmpq	4,du		if fewer than 4 spaces,
	tmi	blankout		insert blanks instead

	mlr	(),(pr)		insert blank and dup char
	desc9a	dupblank,2	..
	desc9a	bb|0,2		..

	mlr	(qu),(pr)		insert dup count character
	desc9a	duptab-1(3),1	..
	desc9a	bb|0(2),1		..

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

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

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

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

	a9bd	bp|0,au		step input and output pointers
	a9bd	bb|0,au		..

	eax2	0		clear white space counter
	tra	sb|0		return to caller


dupblank:
	vfd	a9/ ,o9/037

duptab:	aci	"0123456789[#@:>?"
	aci	" ABCDEFGHI&.](<\"
	aci	"^JKLMNOPQR-$*);'"
	aci	"+/STUVWXYZ_,%=""!"

" 

g115_send_slew_pattern:
	eax7	0		initialize for search
	rpt	nslew/2,2,tze	search for slew characters
	cmpa	slew,7		..
	xec	-1,7		get correct carriage control

stslew:	orq	separator		follow by separator character
	eax7	2		will really have two
	ldx6	lb|pci.temp	look at mc supplied
	cmpx6	=o117000,du	for punch?
	tze	*+3	yes - drop slew from q
	cmpx6	=o116000,du	for teleprinter?
	tnz	*+3		no, all is well
	eax7	1		teleprinter mc, no slew
	qls	9		drop slew from q
	stq	char		and store

	mlr	(pr,rl),(pr,rl)	copy into output
	desc9a	char,x7		..
	desc9a	bb|0,x7		..

	a9bd	bb|0,7		..

	tra	sb|0		return to caller


slew:
	vfd	27/,o9/0		FF
	ldq	=1a ,du
	vfd	27/,o9/013	top of inside page
	ldq	=1a ,du	changed from A (101 octal) to space for Mohawk printer
	vfd	27/,o9/011	top of outside page
	ldq	=1aB,du

	equ	nslew,*-slew


separator:
	vfd	9/,o9/036

" 

g115_send_slew_count:
	eaq	0,al		count in QU
	sbla	15,dl		decrement A by 15
	tmoz	*+2		can only take 15 lines at a time
	ldq	15,du		if > 15, take 15 for now
	ldq	skip,qu		get correct skip character
	tra	stslew		join common code


skip:	aci	"0"
	aci	"1"
	aci	"2"
	aci	"3"
	aci	"4"
	aci	"5"
	aci	"6"
	aci	"7"
	aci	"8"
	aci	"9"
	aci	"["
	aci	"#"
	aci	"@"
	aci	":"
	aci	">"
	aci	"?"




	end




		    g115_dim_.pl1                   02/23/78  1042.6rew 02/23/78  1039.6       83475



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

g115_dim_: proc;

/* DIM for g115 remote batch terminals, interfaces with g115 DCM */

/* Coded 11/20/73 by Mike Grady */

/* modified 06-10-75 by Bob Adsit to move line_control to MCS/355 */
/* modified 07-22-77 by Bob Franklin to add entries for resetread, resetwrite,
   and abort calls which are all treated as no-ops. */

dcl (stream_name, type, device, mode, disposal, order_type) char (*),
    (t_twx, attach_type, aoffset, anelem, anelemt) fixed bin,
    (new_mode, old_mode) char (*),
     rcard char (80) varying,
     bcard based (bufp) char (length (rcard)),
     rstatus bit (72) aligned,
     sareap ptr int static,
     sarea area based (sareap),
     code fixed bin (35),
     sp ptr,
     bufp ptr,
     orderp ptr;

dcl  g115_control_$attach entry (char (*), fixed bin, fixed bin (35)),
     g115_control_$order entry (fixed bin, char (*), ptr, fixed bin (35)),
     g115_control_$modes entry (fixed bin, char (*), char (*), fixed bin (35)),
     g115_control_$detach entry (fixed bin, fixed bin (35)),
     g115_util_$set_ptr entry (ptr),
     g115_util_$get_data_ptr entry (fixed bin) returns (ptr),
     g115_util_$conv_card entry (char (*) varying),
     g115_io_$write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)),
     g115_io_$read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35)),
     get_system_free_area_ entry returns (ptr);

dcl (null, addr) builtin;

dcl (area, storage) condition;

dcl (error_table_$ionmat,
     error_table_$bad_mode,
     error_table_$multiple_io_attachment,
     error_table_$noalloc,
     error_table_$invalid_read,
     error_table_$invalid_write,
     error_table_$device_end,
     error_table_$not_attached) fixed bin (35) ext;

dcl  sdbp ptr;					/* pointer to stream data block */

dcl 1 g115_dim_sdb aligned based (sdbp),		/* stream data block */
    2 outer_mod_name char (32),			/* = "g115_" */
    2 device_namep ptr init (addr (g115_dim_sdb.device_name)), /* points to device name */
    2 device_type fixed bin,
    2 device_name,
      3 next_ptr ptr init (null),
      3 name_size fixed bin init (32),
      3 name char (32);


dcl  dim_data_ptr ptr int static init (null);		/* pointer to dim_data */

dcl 1 g115_dim_data aligned based (dim_data_ptr),
    2 twx fixed bin,
    2 dev_name char (6),
    2 attach_count fixed bin;

%include io_status;
%include g115_data;

/*  */
g115_attach: entry (stream_name, type, device, mode, rstatus, sdbp); /* attach printer */

	call set_attach_type;			/* call subr to set type from mode */

	if sdbp ^= null then			/* error stream already attached */
	     call return_status (error_table_$ionmat, "0"b);

	if dim_data_ptr = null then do;		/* first init for this device */

	     call g115_control_$attach (device, t_twx, code); /* index this device */
	     if code ^= 0 then
		call return_status (code, "1"b);	/* error from attachment, bad */

	     sareap = get_system_free_area_ ();		/* grab ptr to free area */

	     on condition (area) call return_status (error_table_$noalloc, "1"b);
	     on condition (storage) call return_status (error_table_$noalloc, "1"b);

	     allocate g115_dim_data in (sarea) set (dim_data_ptr);

	     revert condition (area);
	     revert condition (storage);

	     g115_dim_data.twx = t_twx;		/* save twx for future calls */
	     g115_dim_data.dev_name = device;		/* save name for future attaches */
	     g115_dim_data.attach_count = 0;		/* init this */


	end;

	if device ^= g115_dim_data.dev_name then	/* error, only one device at a time */
	     call return_status (error_table_$multiple_io_attachment, "1"b);

	on condition (area) call return_status (error_table_$noalloc, "1"b);
	on condition (storage) call return_status (error_table_$noalloc, "1"b);

	allocate g115_dim_sdb in (sarea) set (sdbp);	/* allocate an sdb for this stream */

	revert condition (area);
	revert condition (storage);

	g115_dim_sdb.outer_mod_name = type;		/* set outer mod name */
	g115_dim_sdb.device_type = attach_type;		/* record attach type */
	g115_dim_sdb.name = device;			/* set device name in here also */

	g115_dim_data.attach_count = g115_dim_data.attach_count + 1; /* count up attaches */

	call return_status (0, "0"b);			/* done, return zero code */

/*  */

g115_read: entry (sdbp, bufp, aoffset, anelem, anelemt, rstatus); /* entry to read */

	call check_attachment;


	if g115_dim_sdb.device_type = 2 |		/* not a readable device */
	g115_dim_sdb.device_type = 4 then
	     call return_status (error_table_$invalid_read, "0"b);

	if g115_dim_sdb.device_type = 3 then do;	/* special for teleprinter read */
	     call g115_util_$conv_card (rcard);		/* convert card */
	     bcard = rcard;				/* return to user */
	     anelemt = length (rcard);		/* set len */
	     call return_status (0, "0"b);		/* done */
	end;
	call g115_io_$read (g115_dim_data.twx, bufp, aoffset, anelem, anelemt, code); /* pass on read */

	if code = error_table_$device_end then call return_status (1, "0"b);

	call return_status (code, "0"b);



g115_write: entry (sdbp, bufp, aoffset, anelem, anelemt, rstatus); /* write here */

	call check_attachment;


	if g115_dim_sdb.device_type < 2 then		/* not a writeable device */
	     call return_status (error_table_$invalid_write, "0"b);

	call g115_control_$order (g115_dim_data.twx, "set_periph", addr (g115_dim_sdb.device_type), code);
						/* set the device type for the write */

	call g115_io_$write (g115_dim_data.twx, bufp, aoffset, anelem, anelemt, code);

	call return_status (code, "0"b);		/* done */

/*  */

g115_modes: entry (sdbp, new_mode, old_mode, rstatus);

	call check_attachment;

	call g115_control_$modes (g115_dim_data.twx, new_mode, old_mode, code);

	call return_status (code, "0"b);


g115_order: entry (sdbp, order_type, orderp, rstatus);	/* order call stuff */

	call check_attachment;


	call g115_control_$order (g115_dim_data.twx, order_type, orderp, code); /* easy, pass it along */

	call return_status (code, "0"b);		/* return code if any */




g115_detach: entry (sdbp, device, disposal, rstatus);	/* entry to detach device */

	call check_attachment;


	g115_dim_data.attach_count = g115_dim_data.attach_count - 1; /* count down for detach */

	code = 0;

	if g115_dim_data.attach_count = 0 then		/* if no streams attached now, dump device */
	     call g115_control_$detach (g115_dim_data.twx, code);

	call return_status (code, "1"b);		/* return code, if any and detach */

g115_cntrl: entry (sdbp, rstatus);			/* resetread, resetwrite, abort ignored */

	call check_attachment;
	code = 0;
	call return_status (code, "0"b);

/*  */
/* internal proc to return status as real ios status */

return_status: proc (rcode, rdet_bit);

dcl  rcode fixed bin (35),
     rdet_bit bit (1);

	     sp = addr (status);
	     status_bits = "0"b;			/* clear to init */

	     if rcode = 1 then do;			/* if 1 set eod */
		rcode = 0;
		status.end_of_data = "1"b;
	     end;

	     status.ioname_detached = rdet_bit;		/* set det bit in status word */
	     status.code = rcode;

	     if rdet_bit then do;			/* if we are detaching then do */

		if sdbp ^= null then do;		/* free sdb if allocated */
		     free g115_dim_sdb in (sarea);
		     sdbp = null;
		end;

		if dim_data_ptr ^= null then		/* check dim_data */
		     if g115_dim_data.attach_count = 0 then do; /* no more streams attached, free block */
			free g115_dim_data in (sarea);
			dim_data_ptr = null;
		     end;

	     end;

	     rstatus = status_bits;			/* copy back status */
	     go to ret;				/* nonlocal goto to exit */

	end;


ret:	return;


/* internal procedure to check correctness of call to g115_dim_$... */

check_attachment: proc;

	     if dim_data_ptr = null | sdbp = null then	/* error - no previous attach call */
		call return_status (error_table_$not_attached, "0"b);

	     if g115_dim_sdb.name ^= g115_dim_data.dev_name then /* device names do not match */
		call return_status (error_table_$multiple_io_attachment, "0"b);

	     data_ptr = g115_util_$get_data_ptr (g115_dim_data.twx);
	     if data_ptr = null then			/* no g115_data structure for this device */
		call return_status (error_table_$not_attached, "0"b);
	     call g115_util_$set_ptr (data_ptr);
	     g115_data.no_block = "0"b;		/* turn off no block flag */

	     return;
	end;


set_attach_type: proc;

	     attach_type = 0;			/* set default to none */

	     if index (mode, "teleprinter") ^= 0 then attach_type = 3;
	     else if index (mode, "reader") ^= 0 then attach_type = 1;
	     else if index (mode, "printer") ^= 0 then attach_type = 2;
	     else if index (mode, "punch") ^= 0 then attach_type = 4;
	     else if mode = "" then attach_type = 3;

	     if attach_type = 0 then			/* wrong mode, gripe */
		call return_status (error_table_$bad_mode, "1"b);

	     return;

	end;

     end;




		    g115_input_proc_.pl1            02/23/78  1042.6rew 02/23/78  1039.7       40626



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

g115_input_proc_: proc (slot_ptr, bufp, nelem, nelemt, code);

/* input processor, rewritten 8/14/75 by Mike Grady */
/* modified by Bob Franklin 04/10/77 to fix bugs */

dcl (i, j, k, ct, uct, inelem, nelem, nelemt) fixed bin,
     code fixed bin (35),
    (bufp, rbufp) ptr,
     bchars char (82) based (addr (g115_msg.text (g115_hdr.read_offset))),
     ccard char (80) varying init ((80)" "),
     card char (80) varying init ((80)" "),
     blanks char (80) init ((80)" "),
     outstr char (1000) based (rbufp),
     chara (0:1000) char (1) based (rbufp);

dcl (rs, cc, char) char (1),
     nl char (1) init ("
");

dcl  debug entry options (variable);
dcl  g115_util_$get_ptr entry returns (ptr);

%include g115_data;
%include g115_msg;
%include g115_stat;


dcl  g115_ascii_to_bits (0:63) bit (9) unaligned int static init (
     "000010000"b, "000111111"b, "000111110"b, "000001011"b,
     "000101011"b, "000111100"b, "000011010"b, "000101111"b,
     "000011101"b, "000101101"b, "000101100"b, "000110000"b,
     "000111011"b, "000101010"b, "000011011"b, "000110001"b,
     "000000000"b, "000000001"b, "000000010"b, "000000011"b,
     "000000100"b, "000000101"b, "000000110"b, "000000111"b,
     "000001000"b, "000001001"b, "000001101"b, "000101110"b,
     "000011110"b, "000111101"b, "000001110"b, "000001111"b,
     "000001100"b, "000010001"b, "000010010"b, "000010011"b,
     "000010100"b, "000010101"b, "000010110"b, "000010111"b,
     "000011000"b, "000011001"b, "000100001"b, "000100010"b,
     "000100011"b, "000100100"b, "000100101"b, "000100110"b,
     "000100111"b, "000101000"b, "000101001"b, "000110010"b,
     "000110011"b, "000110100"b, "000110101"b, "000110110"b,
     "000110111"b, "000111000"b, "000111001"b, "000001010"b,
     "000011111"b, "000011100"b, "000100000"b, "000111010"b);

	data_ptr = g115_util_$get_ptr ();
	unspec (rs) = g115_stat.rs_char;
	unspec (cc) = g115_stat.comp_char;
	nelemt, code = 0;
	rbufp = bufp;
	inelem = nelem;

	do while (g115_hdr.full_cc > 0);		/* loop reading all in message */
	     i = index (bchars, rs);			/* find rs at end of card */
	     ccard = substr (bchars, 2, i-2);		/* take all between mc and rs */
	     g115_hdr.read_offset = g115_hdr.read_offset + i; /* skip over that */
	     card = "";

	     j = 1;				/* init ptr to packed card */
	     k = index (ccard, cc);			/* see if any compression chars in card */
	     do while (k > 0);			/* loop de-compressing card */
		card = card || substr (ccard, j, k-1);	/* copy all up to compression char */
		char = substr (ccard, j+k-2, 1);	/* pickup repeated char */
		uct = fixed (unspec (substr (ccard, j+k, 1)), 17); /* get count */
		uct = fixed (g115_ascii_to_bits (uct - 32), 17); /* get real count */
		do ct = 1 to uct;			/* loop unpacking chars */
		     card = card || char;		/* unpack a char */
		end;
		j = j + k + 1;			/* bump ptr up to next virgin piece */
		k = index (substr (ccard, j), cc);	/* look for next cc */
	     end;
	     card = card || substr (ccard, j, i-2-j+1);	/* copy remainder of card */
	     card = card || substr (blanks, 1);
	     g115_hdr.full_cc = g115_hdr.full_cc - 80;	/* decrement card count in message */

	     if substr (card, 1, 6) = "***EOF" then do;	/* found eof marker card */
		code = 2;				/* set funny code */
		return;
	     end;

	     if g115_data.trim then			/* trimming blanks off end then */
		ct = 80 - verify (reverse (card), " ") + 1; /* get real count for card */
	     else ct = 80;				/* full card to be returned */
	     if inelem < ct + 1 then do;		/* not enough room to return all */
		ct = inelem;
		substr (outstr, 1, ct) = substr (card, 1, ct);
		nelemt = nelemt + ct;
		return;
	     end;
	     substr (outstr, 1, ct + 1) = substr (card, 1, ct) || nl; /* return whats wanted plus nl */
	     nelemt = nelemt + ct + 1;		/* amt returned */
	     inelem = inelem - ct - 1;		/* amt left in buffer */
	     rbufp = addr (chara (ct+1));		/* bump ptr */
	     if inelem = 0 then return;
	end;

	code = 1;					/* still need more input from 115 */
	return;

     end;




		    g115_io_.pl1                    02/23/78  1042.6rew 02/23/78  1039.8      115830



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

g115_io_: proc;

/* This procedure handles the logical reading and writing of data
   to the g115 remote computer. */

/* Coded 5/2/74 by Mike Grady */

/* modified 06/10/75 by Bob Adsit to move line_control to MCS/355 */

/* modified 04/10/77 by Bob Franklin to: fix bugs, add upper_case only
   conversion table,turn off teleprinter, reset pci.pos,etc */

dcl (twx, i, offset, nelem, nelemt, nel, nelt, neltx) fixed bin,
    (wp, readp, curp, nextp, msg_ptr, to_ptr, from_ptr, wksp) ptr,
    (msg_len, inelem, tidx) fixed bin,
     code fixed bin (35),
    (fc, mc) bit (9),
     nrdp (0:1000) char (1) based (readp) unal,
     bchr char (neltx) based unal;

dcl  g115_message_$read entry (ptr, fixed bin, fixed bin (35)),
     g115_message_$write entry (ptr, fixed bin (35)),
     g115_input_proc_ entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)),
     prt_conv_ entry (ptr, fixed bin, ptr, fixed bin, ptr),
     g115_util_$get_ptr entry returns (ptr),
     g115_util_$block entry (fixed bin (35));

dcl (null, rel, bool) builtin;

dcl (error_table_$not_attached,
     error_table_$device_end,
     error_table_$unable_to_do_io) fixed bin (35) ext;

dcl  temp_line (40) fixed bin,
     temp_count fixed bin,
     temp_filled bit (1) init ("0"b);

dcl  string (128) char based (wksp) unal;
dcl  string1 (128) fixed bin (8) unal based;
dcl (left_to_print, nelt_to_print, j) fixed bin;
dcl  wksp1 ptr;
dcl  buffer_print char (4000);

dcl  tptr ptr;

dcl  table (0:127) bit (9) unaligned int static init (
     "000000000"b,					/* 000 null */
     "000000001"b,					/* 001 soh */
     "000000010"b,					/* 002 stx */
     "000000011"b,					/* 003 etx */
     "000000100"b,					/* 004 eot */
     "000000101"b,					/* 005 enq */
     "000000110"b,					/* 006 ack */
     "000000111"b,					/* 007 bel */

     "000001000"b,					/* 010 bc  */
     "000001001"b,					/* 011 ht  */
     "000001010"b,					/* 012 nl  */
     "000001011"b,					/* 013 vt  */
     "000001100"b,					/* 014   */
     "000001101"b,					/* 015 cr  */
     "000001110"b,					/* 016   */
     "000001111"b,					/* 017  */

     "000010000"b,					/* 020 dle */
     "000010001"b,					/* 021 dc1 */
     "000010010"b,					/* 022 dc2 */
     "000010011"b,					/* 023 dc3 */
     "000010100"b,					/* 024 dc4 */
     "000010101"b,					/* 025 nak */
     "000010110"b,					/* 026 syn */
     "000010111"b,					/* 027 etb */

     "000011000"b,					/* 030 can */
     "000011001"b,					/* 031 em  */
     "000011010"b,					/* 032 sub */
     "000011011"b,					/* 033 esc */
     "000011100"b,					/* 034 fs  */
     "000011101"b,					/* 035 gs  */
     "000011110"b,					/* 036 rs  */
     "000011111"b,					/* 037    */

     "000100000"b,					/* 040 blank */
     "000100001"b,					/* 041 ! */
     "000100010"b,					/* 042 " */
     "000100011"b,					/* 043 pound sign */
     "000100100"b,					/* 044 dollar */
     "000100101"b,					/* 045 percent */
     "000100110"b,					/* 046 ampersand */
     "000100111"b,					/* 047 accent */

     "000101000"b,					/* 050 ( */
     "000101001"b,					/* 051 ) */
     "000101010"b,					/* 052 asterisk */
     "000101011"b,					/* 053 plus */
     "000101100"b,					/* 054 comma */
     "000101101"b,					/* 055 minus */
     "000101110"b,					/* 056 period */
     "000101111"b,					/* 057 slash */

     "000110000"b,					/* 060 zero */
     "000110001"b,					/* 061 1 */
     "000110010"b,					/* 062 2 */
     "000110011"b,					/* 063 3 */
     "000110100"b,					/* 064 4 */
     "000110101"b,					/* 065 5 */
     "000110110"b,					/* 066 6 */
     "000110111"b,					/* 067 7 */

     "000111000"b,					/* 070 8 */
     "000111001"b,					/* 071 9 */
     "000111010"b,					/* 072 colon */
     "000111011"b,					/* 073 semicolon */
     "000111100"b,					/* 074 less than */
     "000111101"b,					/* 075 = */
     "000111110"b,					/* 076 > */
     "000111111"b,					/* 077 question */

     "001000000"b,					/* 100 at sign */
     "001000001"b,					/* 101 A */
     "001000010"b,					/* 102 B */
     "001000011"b,					/* 103 C */
     "001000100"b,					/* 104 D */
     "001000101"b,					/* 105 E */
     "001000110"b,					/* 106 F */
     "001000111"b,					/* 107 G */

     "001001000"b,					/* 110 H */
     "001001001"b,					/* 111 I */
     "001001010"b,					/* 112 J */
     "001001011"b,					/* 113 K */
     "001001100"b,					/* 114 L */
     "001001101"b,					/* 115 M */
     "001001110"b,					/* 116 N */
     "001001111"b,					/* 117 O */

     "001010000"b,					/* 120 P */
     "001010001"b,					/* 121 Q */
     "001010010"b,					/* 122 R */
     "001010011"b,					/* 123 S */
     "001010100"b,					/* 124 T */
     "001010101"b,					/* 125 U */
     "001010110"b,					/* 126 V */
     "001010111"b,					/* 127 W */

     "001011000"b,					/* 130 X */
     "001011001"b,					/* 131 Y */
     "001011010"b,					/* 132  Z */
     "001011011"b,					/* 133 [ */
     "001011100"b,					/* 134 slash */
     "001011101"b,					/* 135 ] */
     "001011110"b,					/* 136 up arrow */
     "001011111"b,					/* 137 _ */

     "000111111"b,					/* 140 = 077 = ? */
     "001000001"b,					/* 141 = 101 = A */
     "001000010"b,					/* 142 = 102 = B */
     "001000011"b,					/* 143 = 103 = C */
     "001000100"b,					/* 144 = 104 = D */
     "001000101"b,					/* 145 = 1-5 = E */
     "001000110"b,					/* 146 = 106 = F */
     "001000111"b,					/* 147 = 107 = G */

     "001001000"b,					/* 150 = 110 = H */
     "001001001"b,					/* 151 = 111 = I */
     "001001010"b,					/* 152 = 112 = J */
     "001001011"b,					/* 153 = 113 = K */
     "001001100"b,					/* 154 = 114 = L */
     "001001101"b,					/* 155 = 115 = M */
     "001001110"b,					/* 156 = 116 = N */
     "001001111"b,					/* 157 = 117 = O */


     "001010000"b,					/* 160 = 120 = P */
     "001010001"b,					/* 161 = 121 = Q */
     "001010010"b,					/* 162 = 122 = R */
     "001010011"b,					/* 163 = 123 = S */
     "001010100"b,					/* 164 = 124 = T */
     "001010101"b,					/* 165 = 125 = U */
     "001010110"b,					/* 166 = 126 = V */
     "001010111"b,					/* 167 = 127 = W */

     "001011000"b,					/* 170 = 130 = X */
     "001011001"b,					/* 171 = 131 = Y */
     "001011010"b,					/* 172 = 132 = Z */
     "000101000"b,					/* 173 = 050 = ( */
     "001011110"b,					/* 174 = 136 = up arrow */
     "000101001"b,					/* 175 = 051 = ) */
     "000111111"b,					/* 176 = 077 = ? */
     "000111111"b					/* 177 = 077 = ? */
     );

%include g115_data;
%include g115_msg;
%include g115_stat;


write:	entry (twx, wp, offset, nelem, nelemt, code);

	code, nelemt = 0;				/* init return stuff */
	if nelem = 0 then return;

	data_ptr = g115_util_$get_ptr ();		/* get data ptr */
	if g115_data.twx ^= twx then do;		/* error, wrong device  */
	     code = error_table_$not_attached;
	     return;
	end;

	pcip = addr (g115_data.conv_info);
	if g115_data.teleprinter then do;		/* telelprinter in use now */
	     pci.pos = 0;				/* darn trailer leaves it at 132 */
	     mc = g115_stat.teleprinter_mc;		/* set media code */
	     fc = g115_stat.special_c;		/* set format code to special compressed */
	end;
	else if g115_data.write_compress then do;	/* wants compressed records */
	     g115_data.write_split = "0"b;		/* and not split records */
	     fc = g115_stat.info_ns_c;		/* set format code to information no split compressed */
	     if g115_data.punch then mc = g115_stat.punch_mc;
	     else mc = g115_stat.printer_mc;
	end;
	else do;
bad_type:	     code = error_table_$unable_to_do_io;
	     return;
	end;

	wksp = addr (wp -> nrdp (offset));
	tptr = addr (table);			/* set to convert */
	i = 0;
	left_to_print = nelem;
loop:
	if left_to_print > 0 then do;			/* process until done */
	     wksp1 = addr (buffer_print);
	     if left_to_print > 4000 then
		nelt_to_print = 4000;		/* don't print more than buffer size */
	     else nelt_to_print = left_to_print;
	     do j = 1 to nelt_to_print;
		wksp1 -> string (j) = wksp -> string (i+j);
	     end;
	     left_to_print = left_to_print - nelt_to_print; /* keep counts up-to-date */
	     i = i + nelt_to_print;
	     inelem = nelt_to_print;
	     curp = addr (g115_data.output_buffer1);	/* get addr of first  output buffer */
	     nextp = null;				/* no next buffer yet */

	     call fill_buffer (curp, code);		/* fill first buffer */
	     if code ^= 0 then return;		/* must be error, return */

next_write:					/* loop here to write next buffer */
	     if curp = null then go to finished_write;	/* no next, all done */
	     call g115_message_$write (curp, code);	/* write the buffer */
	     if code ^= 0 then return;		/* any error, punt  */

	     nextp = switch_buffers (curp);		/* get ptr to new buffer  */
	     call fill_buffer (nextp, code);		/* fill this buffer */
	     if code = 1 then nextp = null;		/* no more data to write */
	     else if code ^= 0 then return;		/* must be error */

	     curp = nextp;				/* set next to current */
	     nextp = null;				/* next is gone */
	     go to next_write;			/* loop back and write */

finished_write:
	     go to loop;
	end;
	g115_data.teleprinter = "0"b;			/* turn off teleprinter */
	nelemt = nelem;
	code = 0;
xit:	return;

read:	entry (twx, wp, offset, nelem, nelemt, code);

	code, nelemt = 0;				/* init return stuff */
	nel = nelem;
	nelt = 0;
	readp = wp;

	if nelem = 0 then return;			/* nothing to do for now */

	data_ptr = g115_util_$get_ptr ();		/* get the data ptr */

	if g115_data.twx ^= twx then do;		/* not this one today */
	     code = error_table_$not_attached;
	     return;
	end;

	msg_ptr = addr (g115_data.input_buffer);	/* get pointer to buffer */
	if msg_ptr -> g115_hdr.full_cc ^= 0 then go to process;

next_read:					/* loop here reading data */
	if g115_data.no_block then do;		/* answering  service read */
	     call g115_message_$read (msg_ptr, msg_len, code); /* read data cards */
	     if code ^= 0 then return;
	     if msg_len = 0 then goto finished_read;
	end;
	else
	call get_message;				/* read in the data msg */
process:
	call g115_input_proc_ (msg_ptr, readp, nel, neltx, code); /* convert input msgs */
	readp = addr (nrdp (neltx));
	nelt = nelt + neltx;
	nel = nel - neltx;

	if code = 1 then				/* more input needed */
	     go to next_read;			/*  read some more */

	else if code = 2 then
	     code = error_table_$device_end;

finished_read:
	nelemt = nelt;
	return;

switch_buffers: proc (old_ptr) returns (ptr);

dcl (old_ptr, new_ptr) ptr,
    (old_offset, new_offset) bit (18);

	     old_offset = rel (old_ptr);		/* get the offset */
	     new_offset = bool (old_offset, g115_data.mask_sw, "0110"b);

	     new_ptr = ptr (old_ptr, new_offset);
	     return (new_ptr);

	end;



get_message: proc ;


gloop:	     call g115_message_$read (msg_ptr, msg_len, code); /* read in message */
	     if code ^= 0 then go to xit;

	     if msg_len ^= 0 then return;

	     call g115_util_$block (code);
	     if code ^= 0 then go to xit;

	     go to gloop;

	end;


fill_buffer: proc (optr, code);			/* proc to fill one output buffer */

dcl  optr ptr,
     code fixed bin (35);

	     code = 0;

	     if inelem = 0 & ^temp_filled then do;	/* we have processed all data */
		code = 1;
		return;
	     end;

	     pci.temp = mc;				/* set media code for g115_conv_ */
	     optr -> g115_hdr.null_ct = 0;
	     optr -> g115_hdr.text_char_count = 0;	/* clear count to init */
	     optr -> g115_msg.fmt_code = fc;		/* fill in fmt code in message */
	     optr -> g115_msg.op_code.cmd = g115_stat.no_op; /* no op on std write request */
	     tidx = 1;				/* init to first in data */

	     do while (inelem > 0 | temp_filled);	/* pump output till done */
		if temp_filled then neltx = temp_count; /* process temp first */
		else call prt_conv_ (wksp1, inelem, addr (temp_line), neltx, pcip); /* get next temp */

		if (tidx - 1) + neltx > g115_stat.max_msg_len then do; /* enough for this buffer */
		     temp_filled = "1"b;		/* indicate that for next time */
		     temp_count = neltx;
		     go to fill_done;
		end;
		else temp_filled = "0"b;

		to_ptr = addr (optr -> g115_msg.text (tidx)); /* set to ptr */
		from_ptr = addr (temp_line);		/* set from ptr */
		to_ptr -> bchr = from_ptr -> bchr;	/* copy converted string */
		tidx = tidx + neltx;
	     end;

fill_done:
	     optr -> g115_hdr.text_char_count = tidx -1;	/* set count */
	     optr -> g115_msg.etx = g115_stat.etx_char;
	     return;

	end;

     end;




		    g115_message_.pl1               02/23/78  1042.6rew 02/23/78  1040.0      131445



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

g115_message_: proc;

/* this procedure handles the actual read and writing of the
   data to the MDS2400 via hcs_$tty calls. */

/* Coded 4/30/74 by Mike Grady */

/* modified 06/10/75 by Bob Adsit to move line_control to MCS/355 */

/* modified 04/10/77 by Bob Franklin to fix many bugs. Now multiple
   blocks must be unpacked on input in g115_message, special control
   records must be ignored, etc. Ignore Quit error on Writes.
   */

dcl  msg_ptr ptr,
     msg_len fixed bin,
     input_ptr ptr,
     put_ptr ptr,
     msg_ct fixed bin,
     msg_ct1 fixed bin,
     offset fixed bin,
     out_try fixed bin,
     last_char_was_rs bit (1),
     parity bit (1),
     i fixed bin,
     state fixed bin,
     error_type fixed bin,
     fmt_index fixed bin,
     temp_full_cc fixed bin,
     code fixed bin (35);
dcl  debug entry options (variable);
dcl  quit_code fixed bin (35) int static init (3000005);	/* quit occurred */

dcl 1 info aligned,
    2 pad fixed bin (71),
    2 output_pending bit (1);


dcl  com_err_ entry options (variable);
dcl  ioa_ entry options (variable);
dcl  hcs_$tty_write entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35)),
     hphcs_$tty_write_force entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35)),
     hcs_$tty_read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (35)),
     hcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35)),
     hcs_$tty_event entry (fixed bin, fixed bin (71), fixed bin, fixed bin (35)),
     g115_util_$get_ptr entry returns (ptr),
     g115_util_$block entry (fixed bin (35)),
     ipc_$mask_ev_calls entry (fixed bin (35)),
     ipc_$unmask_ev_calls entry (fixed bin (35)),
     timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)),
     timer_manager_$reset_alarm_wakeup entry (fixed bin (71)),
     error_table_$buffer_big ext fixed bin (35);

dcl  str_ptr1 ptr;
dcl  after_etx fixed bin;
dcl  read_chars char (msg_len) based (input_ptr) unal,
     string char (g115_hdr.total_left) based (str_ptr) unal,
     str_ptr pointer,
     char char (1),
    (unspec, index) builtin;

dcl 1 aux_ctl (0:7) aligned int static,
    2 split bit (1) init ("1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "1"b, "0"b),
    2 compress bit (1) init ("1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "0"b);

%include g115_data;
%include g115_msg;
%include g115_stat;

write:	entry (msg_ptr, code);

/* This procedure writes messages to the MDS2400 and will do retries
   if hcs_$tty_write could not write any chars */

	data_ptr = g115_util_$get_ptr ();		/* get data ptr for us */

	code = 0;					/* set error code to 0 */
	out_try = 0;				/* clear number of trys */

	msg_ct1 = msg_ptr -> g115_hdr.text_char_count + 8; /* get actual length of message */

	msg_ptr -> g115_msg.seq_code = "0"b;		/* set the xmt seq code in msg */

	put_ptr = addr (msg_ptr -> g115_msg);		/* get addr for tty_write */

	if g115_data.no_block then do;		/* force output for answering service */
	     call hcs_$tty_event (g115_data.twx, g115_data.hcs_ev_chan, state, code); /* replace with our chan for block */
	     call hcs_$tty_order (g115_data.twx, "write_status", addr (info), state, code);
	     if code ^= 0 then return;
	     do while (info.output_pending);		/* if told to wait */
		call ipc_$mask_ev_calls (code);	/* stop as for a sec */
		call timer_manager_$alarm_wakeup (3, "11"b, g115_data.wait_list.timeout_chan);
		call g115_util_$block (code);		/* wait for device */
		call ipc_$unmask_ev_calls ((0));	/* reset mask */
		if code ^= 0 then return;
		call timer_manager_$reset_alarm_wakeup (g115_data.wait_list.timeout_chan); /* made it */
		call hcs_$tty_order (g115_data.twx, "write_status", addr (info), state, code);
	     end;
	     call hcs_$tty_event (g115_data.twx, g115_data.as_ev_chan, state, code); /* return as ev can to tty_dim */
	     call hphcs_$tty_write_force (g115_data.twx, put_ptr, 0, msg_ct1, msg_ct, state, code);
	     return;
	end;

	offset = 0;

try_again:
	call hcs_$tty_order (g115_data.twx, "write_status", addr (info), state, code);
	if code ^= 0 then return;
	do while (info.output_pending);
block_it:
	     call g115_util_$block (code);
	     call hcs_$tty_order (g115_data.twx, "write_status", addr (info), state, code);
	end;

retry:
	call hcs_$tty_write (g115_data.twx, put_ptr, offset, msg_ct1, msg_ct, state, code);
	if code = quit_code then go to retry;		/* ignore quit error0its been reset */
	if code ^= 0 then return;			/* really terrible error has occured */

	if msg_ct1 = msg_ct then return;		/* all data was sent by ring 0 */
	if msg_ct = 0 then go to block_it;		/* whoops - nothing written */

	msg_ct1 = msg_ct1 - msg_ct;			/* try to send remainder */
	offset = offset + msg_ct;
	go to try_again;


read:	entry (msg_ptr, msg_len, code);

/* entry to read and check messages from the MDS2400 */

	data_ptr = g115_util_$get_ptr ();		/* get data ptr */

check_1:
	code = 0;
	parity = "0"b;
	msg_ptr = addr (g115_data.input_buffer);	/* init the buffer ptr */
	input_ptr = addr (msg_ptr -> g115_msg);
	slot_ptr = msg_ptr;
	if g115_hdr.last_rs ^= 0 then go to partial_card; /* whoops - a mess */
	if g115_hdr.total_left ^= 0 then go to process_1; /* don't need to read, just unblock */

rloop:
	if g115_hdr.total_left > 459 then return;
	call hcs_$tty_read (g115_data.twx,
	     input_ptr,
	     g115_hdr.total_left,
	     460 - g115_hdr.total_left,
	     msg_len,
	     state,
	     code);
	if code ^= 0 then return;
	if g115_hdr.last_rs ^= 0 then do;		/* must delete imbedded header */
	     if msg_len = 0 then do;
		if g115_hdr.total_left = 0 then do;	/* may want to go blocked */
block:		     call g115_util_$block (code);
		     if code ^= 0 then return;
		     go to rloop;
		end;
		if after_etx = 0 then go to block;	/* partial line */
	     end;
	     after_etx = after_etx + msg_len - 7;	/* actual number to move */
	     g115_hdr.total_left = g115_hdr.total_left + msg_len;
	     str_ptr1 = addr (g115_msg.text (g115_hdr.soh_offset - g115_hdr.last_rs -9));
	     str_ptr = addr (g115_msg.text (g115_hdr.soh_offset - g115_hdr.last_rs));
	     substr (str_ptr1 -> string, 1, after_etx) =
		substr (str_ptr -> string, 1, after_etx);
	     last_char_was_rs = "1"b;
	     g115_hdr.total_left = g115_hdr.total_left - 9; /* adjust for missing header */
	     g115_hdr.text_offset = -6;
	     unspec (char) = g115_stat.etx_char;
	     str_ptr = addr (g115_msg.text (g115_hdr.text_offset));
	     msg_len = index (substr (string, 1, g115_hdr.total_left), char);
	     if msg_len = 0 then return;
	     go to enter;
	end;
	g115_hdr.total_left = g115_hdr.total_left + msg_len;
	g115_hdr.soh_offset = -6;
	g115_hdr.text_offset = 0;

	if msg_len = 0 then return;			/* no data yet, so done */

process_1:
	unspec (char) = g115_stat.etx_char;
	str_ptr = addr (g115_msg.text (g115_hdr.soh_offset));
	if g115_hdr.total_left < 9 then go to move_read;	/* need more characters */
	msg_len = index (substr (string, 1, g115_hdr.total_left), char);
	if msg_len = 0 then go to move_read;		/* can't find ETX, need more characters */

enter:
	call check_message_format (code);		/* check the message */

	if code ^= 0 then do;			/* format check failed - throw away message */
	     g115_hdr.total_left = 0;
	     g115_hdr.last_rs = 0;
	     call ioa_ ("g115_message_: code = ^d", error_type);
	     return;
	end;

	if g115_hdr.msg_type = 1 then go to check_1;	/* skip service messages */
	if g115_hdr.msg_type = 2 then do;		/* skip special control records temporarily */
	     g115_hdr.full_cc = g115_hdr.full_cc - 80;	/* don't forget its been incr */
	     go to check_1;
	end;


	g115_hdr.read_offset = g115_hdr.text_offset;
	if g115_hdr.text_offset = -6 then
	     g115_hdr.text_offset = g115_hdr.soh_offset + 7;
	return;

move_read:					/* move remainder to top then read */
	substr (input_ptr -> string, 1, g115_hdr.total_left) =
	     substr (str_ptr -> string, 1, g115_hdr.total_left);
	go to rloop;

partial_card:
	after_etx = g115_hdr.total_left;		/* save it for later */
	g115_hdr.total_left = g115_hdr.soh_offset - g115_hdr.last_rs +
	     g115_hdr.total_left-1;			/* total chars to move down */
	str_ptr = addr (g115_msg.text (g115_hdr.last_rs+1));
	go to move_read;				/* now move it down */

check_message_format: proc (code);

/* This procedure checks the format of a g115 message and returns an index specifying the
   type of message read.  It also sets the variables in the message slot referring
   to that message. */

dcl  code fixed bin (35);


	     code = 0;

	     error_type = 0;

	     if g115_hdr.last_rs ^= 0 then do;		/* get back in sync */
		g115_hdr.text_char_count = msg_len - 1;
		g115_hdr.last_rs = 0;
		g115_hdr.total_left = g115_hdr.total_left - msg_len - 1;
		g115_hdr.soh_offset = msg_len - 5;
		go to enter1;
	     end;

	     g115_hdr.aux_bit_count,
		g115_hdr.null_ct,
		g115_hdr.text_char_count = 0;
	     g115_hdr.read_split,
		g115_hdr.read_compression = "0"b;

/* check SOH character */
	     if g115_msg.text (g115_hdr.soh_offset) ^= g115_stat.soh_char then do;
		error_type = 19;
		go to CHECK_RETURN;
	     end;

/* check format code */

	     fmt_index = bin (substr (g115_msg.text (g115_hdr.soh_offset+1), 5, 5), 17); /* compute format index */
	     if fmt_index < 1 | fmt_index > 11		/* illegal value */
	     then go to FMT_CODE_CHECK (1);

	     go to FMT_CODE_CHECK (fmt_index);

FMT_CODE_CHECK (2):					/* service message, no auxilliary fields */
	     g115_hdr.msg_type = 1;
	     g115_hdr.sub_type = 1;
	     g115_hdr.total_left = g115_hdr.total_left - 9;
	     g115_hdr.soh_offset = g115_hdr.soh_offset + 9; /* skip message */
	     go to END_FMT_CODE_CHECK;

FMT_CODE_CHECK (3):					/* service message, auxilliary field */

	     g115_hdr.msg_type = 1;
	     g115_hdr.sub_type = 2;
	     g115_hdr.aux_bit_count = 9;
	     if bit (substr (g115_msg.text (g115_hdr.text_offset - 4), 7, 3)) =
	     g115_stat.select then do;
		i = fixed (substr (g115_msg.text (g115_hdr.text_offset-2), 4, 6), 17);
		g115_data.write_split = aux_ctl (i).split; /* set split option */
		g115_data.write_compress = aux_ctl (i).compress; /* set compression option */
	     end;
	     g115_hdr.total_left = g115_hdr.total_left - 10;
	     g115_hdr.soh_offset = g115_hdr.soh_offset + 10; /* skip message */
	     msg_len = 0;
	     go to END_FMT_CODE_CHECK;

FMT_CODE_CHECK (4):					/* special control record; no split, no compression */

	     g115_hdr.read_split,
		g115_hdr.read_compression = "0"b;
	     g115_hdr.msg_type = 2;
	     g115_hdr.sub_type = 1;
	     go to fcp7;

FMT_CODE_CHECK (5):					/* special control record; no split, compression */

	     g115_hdr.read_split = "0"b;
	     g115_hdr.read_compression = "1"b;
	     g115_hdr.msg_type = 2;
	     g115_hdr.sub_type = 2;
	     go to fcp7;

FMT_CODE_CHECK (8):					/* information message; no split, no compression */

	     g115_hdr.read_split,
		g115_hdr.read_compression = "0"b;
	     g115_hdr.msg_type = 3;
	     g115_hdr.sub_type = 1;
	     go to fcp7;

FMT_CODE_CHECK (9):					/* information message; no split, compression */

	     g115_hdr.read_split = "0"b;
	     g115_hdr.read_compression = "1"b;
	     g115_hdr.msg_type = 3;
	     g115_hdr.sub_type = 2;
	     go to fcp7;

FMT_CODE_CHECK (10):				/* information message; split, no compression */

	     g115_hdr.read_split = "1"b;
	     g115_hdr.read_compression = "0"b;
	     g115_hdr.msg_type = 3;
	     g115_hdr.sub_type = 3;
	     go to fcp7;

FMT_CODE_CHECK (11):				/* information message; split, compression */

	     g115_hdr.read_split, g115_hdr.read_compression = "1"b;
	     g115_hdr.msg_type = 3;
	     g115_hdr.sub_type = 4;
fcp7:

	     g115_hdr.text_offset = g115_hdr.soh_offset + 7;
	     go to END_FMT_CODE_CHECK;

FMT_CODE_CHECK (1):					/* error in fmt code */
FMT_CODE_CHECK (6):
FMT_CODE_CHECK (7):

	     error_type = 6;
	     go to CHECK_RETURN;

END_FMT_CODE_CHECK:

	     if fmt_index < 4 then return;
	     g115_hdr.soh_offset = g115_hdr.soh_offset + msg_len + 1;
	     g115_hdr.total_left = g115_hdr.total_left - msg_len - 1;
	     g115_hdr.text_char_count = msg_len - 8;
enter1:
	     temp_full_cc = 0;

/*   set text length */

	     do;					/* service messages don't reach here */
		if g115_hdr.text_char_count > 0	/* message contains text */
		then if ^g115_hdr.read_split then do;	/* message is not split */
			if g115_msg.text (g115_hdr.text_offset) ^= g115_stat.bin_mc_char
			& g115_msg.text (g115_hdr.text_offset) ^= g115_stat.bcd_mc_char then do; /* first text char not media code */
			     error_type = 17;
			     go to CHECK_RETURN;
			end;
			if g115_msg.text (g115_hdr.text_char_count + g115_hdr.text_offset - 1) ^= g115_stat.rs_char then do;
			     error_type = 18;	/* error, last text char not record separator */
			     go to CHECK_RETURN;
			end;
			last_char_was_rs = "1"b;	/* had to be */
		     end;

		do i = 1 to g115_hdr.text_char_count;	/* compute real text char count */
		     if g115_msg.text (i + g115_hdr.text_offset - 1) = g115_stat.bcd_mc_char |
		     g115_msg.text (i + g115_hdr.text_offset - 1) = g115_stat.bin_mc_char then do;
			if last_char_was_rs then	/* if was rs then dont count mc */
			     last_char_was_rs = "0"b;
		     end;
		     else				/* char is not media code */
		     if last_char_was_rs then do;	/* error, missing media code */
			error_type = 19;
			go to CHECK_RETURN;
		     end;
		     if g115_msg.text (i + g115_hdr.text_offset - 1) = g115_stat.rs_char then do; /* record separators don't count */
			g115_hdr.last_rs = i;	/* save position of last rs */
			temp_full_cc = temp_full_cc + 80;
			last_char_was_rs = "1"b;	/* remember */
		     end;
		end;

		if g115_hdr.last_rs = g115_hdr.text_char_count then
		     g115_hdr.last_rs = 0;
		if g115_hdr.last_rs ^= 0 then do;	/* check special case of prev last_rs */
		     if g115_hdr.text_offset = -6 then
			g115_hdr.last_rs = g115_hdr.last_rs - 7;
		end;
		g115_hdr.full_cc = temp_full_cc;	/* set value in message slot */
	     end;

CHECK_RETURN:  if error_type ^= 0 then code = 1;		/* some error in message */
	     return;

	end;

     end;




		    g115_util_.pl1                  02/23/78  1042.6rew 02/23/78  1040.2       42831



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

g115_util_: proc;

/* utilities procedure for the g115 DCM */

/* coded 11/8/73 by Mike Grady */

/* modified 06/10/75 by Bob Adsit to move line_control to MCS/355 */

dcl  a_ptr ptr,
     dev_index fixed bin,
     icode fixed bin (35),
     code fixed bin (35);

dcl  int_data_ptr ptr int static;
dcl  head_data_ptr ptr int static init (null);
dcl  null builtin;

dcl (save_trim, loopsw) bit (1);

dcl  ipc_$block entry (ptr, ptr, fixed bin (35));

dcl 1 event_info aligned,				/* wakeup information */
    2 channel_id fixed bin (71) aligned,		/* channel over which to send wakeup */
    2 message char (8) aligned,			/* event message */
    2 sender bit (36) aligned,			/* process id of sending process */
    2 origin,
      3 dev_signal bit (18) unaligned,			/* ON if event occurred as result of i/o interrupt */
      3 ring bit (18) unaligned,			/* sender's validation level */
    2 data_ptr ptr aligned;				/* pointer to answer service data (answer table) */

dcl (acard, card varying, rcard varying) char (80),
     i fixed bin;

dcl (lower_case init ("abcdefghijklmnopqrstuvwxyz"),
     upper_case init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") ) char (26) int static;

dcl  g115_io_$read entry (fixed bin, ptr, fixed bin, fixed bin, fixed bin, fixed bin (35));
dcl  error_table_$device_end fixed bin (35) ext,
     error_table_$net_timeout fixed bin (35) ext;
	
%include g115_data;
/*  */

get_ptr:	entry returns (ptr);

/* entry to set the data_ptr */

	return (int_data_ptr);			/* thats it */


set_ptr:	entry (a_ptr);

/* entry to init the data_ptr */

	int_data_ptr = a_ptr;			/* copy to int static */

	return;

block:	entry (code);

	data_ptr = int_data_ptr;
	call ipc_$block (addr (g115_data.wait_list), addr (event_info), code);
	if event_info.message = "alarm___" then code = error_table_$net_timeout;
		else code = 0;
	return;


get_data_ptr: entry (dev_index) returns (ptr);
						/* entry to search the g115_data structure chain  */
	data_ptr = head_data_ptr;
	do while (data_ptr ^= null);
	     if g115_data.twx = dev_index then return (data_ptr); /* found dev_index structure */
	     data_ptr = g115_data.next_data_ptr;	/* advance to next structure */
	end;
	return (null);				/* no structure found for dev_index */

link_data_ptr: entry (a_ptr);

/* entry to add a new g115_data structure to the chain */

	data_ptr = a_ptr;
	g115_data.next_data_ptr = head_data_ptr;	/* set forward link in chain */
	head_data_ptr = data_ptr;
	return;


unlink_data_ptr: entry (dev_index) returns (ptr);

/* entry to remove g115_data structure from the chain */

	data_ptr = head_data_ptr;
	do while (data_ptr ^= null);
	     if g115_data.twx = dev_index then do;	/* found dev_index structure */
		if head_data_ptr = data_ptr		/* head of chain */
		then head_data_ptr = g115_data.next_data_ptr; /* must be adjusted */
		else int_data_ptr -> g115_data.next_data_ptr = g115_data.next_data_ptr; /* preserve forward link */
		return (data_ptr);
	     end;
	     int_data_ptr = data_ptr;
	     data_ptr = g115_data.next_data_ptr;	/* advance to next structure */
	end;
	return (null);				/* no structure found for dev_index */


conv_card: entry (rcard);

/* entry to convert one card image to lower case and do backslash
   escape processing. also appends new_line */

	save_trim = g115_data.trim;			/* save trim mode */
	g115_data.trim = "0"b;			/* no trim wanted */
	loopsw = "1"b;
	do while (loopsw);
	     call g115_io_$read (g115_data.twx, addr (acard), 0, 80, i, icode);
	     if icode ^= error_table_$device_end then loopsw = "0"b;
	end;
	g115_data.trim = save_trim;
	if g115_data.no_block & i = 0 then return;	/* none yet */
	i = 80 - verify (reverse (acard), " ") + 1;	/* find first non blank */
	card = substr (acard, 1, i);			/* copy interesting part of card */
	card = translate (card, lower_case, upper_case);	/* change all upper case to lower */

	i = index (card, "\");			/* look for upper case escapes */
	do while (i > 0);				/* loop processing all of them */
	     card = substr (card, 1, i-1) || translate (substr (card, i+1, 1), upper_case, lower_case) ||
			substr (card, i+2);		/* copy card dropping "\" and changeing char */
	     i = index (card, "\");			/* look for next one */
	end;

	rcard = card || "
";						/* copy to return arg, adding nl */
	return;

     end;




		    g115_output_request_.pl1        02/23/78  1042.6rew 02/23/78  1040.3      320985



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

g115_output_request_: proc (a_stream_name, a_element_size, a_stat_p, a_banner_proc, a_code);

/* General procedure for doing output for an I/O daemon device driver */

/* Rewritten from old procedure "io_daemon" in August 1973 by Robert S. Coren */

/*  Modified in March 1975 by J.C. Whitmore during driver restructuring */

/* Modified in December 1975 by M. A. Braida to include new restart capabilities and update
   the accounting mechanism */
/* modified 05/76 by THVV for set_kst_attributes & force deactivation */
/* Modified 06/76 by J. C. Whitmore to fix translate hardware bug */
/* Modified June 1976 by J. L. Homan to accommodate charging by line count instead of block count. */
/* modified July 1976 by THVV for message notification */
/* modified April 1977 by Bob Franklin to output request message to slave */

dcl  a_stream_name char (*);				/* stream to write the output on */
dcl  a_element_size fixed bin;			/* number of bits in each stream element */
dcl  a_stat_p ptr;					/* the value of stat_p from caller */
dcl  a_banner_proc entry;				/* procedure to be called for head and tail banners */
dcl  a_code fixed bin (35);				/* error code....used for driver_fatal_error */


/* AUTOMATIC */

dcl  abort_msg char (256) var;			/* string for bad error messages */
dcl  access_class bit (72) aligned;			/* access class of user file */
dcl  auth bit (72) aligned;				/* authorization used to set banner access class */
dcl  auth_string char (680);				/* string form of auth */
dcl  banner_proc entry variable options (variable);	/* proc to be called for messages */
dcl  bitcnt fixed bin (24);
dcl  code fixed bin (35);
dcl  curl fixed bin (24);
dcl  errlen fixed bin;
dcl  fac fixed bin;
dcl  l fixed bin;
dcl  mode fixed bin (5);
dcl  more_components bit (1) aligned;			/* we expect more MSF components */
dcl  mult_ind fixed bin;
dcl  mult_no fixed bin (24);
dcl  new_clock fixed bin (71);
dcl  new_cpu fixed bin (52);
dcl  new_pp fixed bin;
dcl  new_waits fixed bin (35);
dcl  old_cpu fixed bin (52);
dcl  old_pp fixed bin;
dcl  old_waits fixed bin (35);
dcl  save_code fixed bin (35);
dcl  tpe fixed bin (2);
dcl  val fixed bin;					/* for validation level */
dcl (lng2, nelt, nret) fixed bin;

dcl  dest char (12) aligned;
dcl  ename char (32) aligned;				/* entry name of file for output */
dcl  mailname char (32) aligned;
dcl  err_mess char (200) var;
dcl  full_path char (168) aligned;
dcl  gt char (1);					/* > for directory names */
dcl  header_found bit (1);
dcl  header_sw bit (1);
dcl  last char (20);
dcl  mes_space char (100) aligned;
dcl  msf_sw bit (1) aligned;
dcl  pverb char (5) aligned ;
dcl  req_stream char (32);
dcl  short_mes char (8) aligned;
dcl  status bit (72) aligned;				/* error code returned by i/o system */
dcl  user_dir char (168) aligned;			/* directory containing users' segment */
dcl (tailsw, chgsw) bit (1) aligned;			/* indicate whether to print out a tail sheet, or to charge */
dcl  comp_dir char (168) aligned;			/* MSF component directory name */
dcl  comp_name char (32) aligned;			/* entry name of the MSF component */
dcl  dir_len fixed bin;				/* length of component directory name */

dcl  segp ptr;
dcl  fcbp ptr;
dcl  desc_ptr ptr;
dcl  dr_ptr ptr;					/* pointer to driver status segment */
dcl  driver_data_p ptr;


/* INTERNAL STATIC */

dcl  bits_per_page fixed bin int static options (constant) init (36864);
dcl  header fixed bin int static options (constant) init (1); /* value for header wanted */
dcl  tail fixed bin int static options (constant) init (2); /* value for tail wanted */
dcl  error_msg fixed bin int static options (constant) init (3); /* value for print error message */
dcl  stars char (40) int static options (constant) aligned init ((40)"*"); /* For error messages */

dcl  privileged bit (1) static init ("1"b);		/* TRUE if we can call hphcs_ */
dcl  first_call bit (1) static init ("1"b);		/* TRUE on first call */
dcl  fault_mess char (32) aligned int static;
dcl  fault_name char (32) aligned int static;

dcl  err_label label int static;			/* point of return from condition handler */

dcl  request_data_p ptr int static;			/* ptr to REQUEST for set_single_copy entrry */

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

dcl  tab_nl_vt_ff char (4) int static options (constant) init ("
");						/* ht, nl, vert tab and form feed chars */

/* EXTERNAL STATIC */

dcl  error_table_$noentry fixed bin (35) ext static;
dcl  error_table_$moderr fixed bin (35) ext static;
dcl  error_table_$dirseg ext static fixed bin (35);
dcl  error_table_$ai_restricted ext static fixed bin (35);


/* EXTERNAL ENTRIES */

dcl  aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  aim_check_$greater entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  check_fs_errcode_ ext entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl  clock_ ext entry returns (fixed bin (71));		/* gets clock time */
dcl  com_err_ entry options (variable);
dcl  convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  convert_authorization_$to_string entry (bit (72) aligned, char (*), fixed bin (35));
dcl  cpu_time_and_paging_ entry (fixed bin (35), fixed bin (52), fixed bin);
dcl  date_time_ entry (fixed bin (71), char (*) aligned);
dcl  hphcs_$set_kst_attributes entry (fixed bin, ptr, fixed bin (35));
dcl  phcs_$deactivate entry (ptr, fixed bin (35));
dcl  hcs_$fs_get_mode ext entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$fs_get_path_name entry (ptr, char (*) aligned, fixed bin, char (*) aligned, fixed bin (35));
dcl  hcs_$get_access_class entry (char (*) aligned, char (*) aligned, bit (72) aligned, fixed bin (35));
dcl  hcs_$get_user_effmode entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin,
     fixed bin (5), fixed bin (35));
dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24),
     fixed bin, ptr, fixed bin (35));
dcl  hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed bin (1), ptr, ptr, fixed bin (35));
dcl  hcs_$status_minf entry (char (*) aligned, char (*) aligned, fixed bin, fixed bin (2), fixed bin (24), fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  io_daemon_account_ entry (ptr, ptr);
dcl  ioa_$ioa_stream entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  ios_$order entry (char (*), char (*), ptr, bit (72) aligned);
dcl  ios_$write entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned);
dcl  msf_manager_$close entry (ptr);
dcl  msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35));
dcl  msf_manager_$open entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35));
dcl  read_allowed_ entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned);
dcl  send_mail_$access_class entry (char (*) aligned, char (*) aligned, ptr, bit (72) aligned, fixed bin (35));



/* BASED VARIABLES */

dcl  fbpart fixed bin (35) based (addr (status));


/* STRUCTURES */


dcl 1 bla aligned,					/* Info returned by status & status_long */
    2 (type bit (2), nnames bit (16), nrp bit (18)) unal,
    2 (dtm, dtu) bit (36),
    2 (mode bit (5), pad1 bit (13), records bit (18)) unal,
    2 (dtd, dtem, acct) bit (36),
    2 (curlen bit (12), bitcnt bit (24)) unal,
    2 ((did, mdid) bit (4), copysw bit (1), pad2 bit (9), rbs (0:2) bit (6)) unal,
    2 uid bit (36);

dcl 1 ksta like kst_attributes aligned;

dcl 1 print_driver_data aligned based (driver_data_p),	/* defines driver data of request_descriptor */
    2 copies_done fixed bin (17) unal,			/* number of copies already printed */
    2 copies_charged fixed bin (17) unal,		/* number of copies already charged */
    2 pad fixed bin;


dcl 1 counts aligned,				/* Structure returned by "get_count" order */
    2 curline fixed bin,
    2 maxline fixed bin,
    2 indent fixed bin,
    2 page_width fixed bin,
    2 line_count fixed bin,
    2 page_count fixed bin;


/* BUILTINS */

dcl (addr, bit, divide, fixed, length, null, substr, verify, reverse, translate) builtin;
dcl (baseno, binary, string, unspec) builtin;


/* CONDITIONS */

dcl (cleanup, linkage_error, daemon_again, daemon_again_slave, daemon_kill, daemon_cancel) condition;



/* INCLUDE FILES */

%include output_request_data;

%include driver_status;

%include mseg_return_args;

%include dprint_msg;

%include request_descriptor;

%include iodd_static;

%include kst_attributes;

%include send_mail_info;

/*  */
/* copy arguments and initialize pointers and control switches */

	stat_p = a_stat_p;
	string (ksta) = "0"b;
	if first_call then do;			/* Conduct an experiment to see about hphcs_ */
	     on linkage_error begin;
		privileged = "0"b;
		go to tough;
	     end;
	     call hphcs_$set_kst_attributes (binary (baseno (stat_p), 18), addr (ksta), (0));
						/* This is a NOP - structure is 0 */
tough:	     revert linkage_error;			/* If we get here we are privileged */
	     first_call = "0"b;			/* Now we know */
	     ksta.set.tpd, ksta.value.tpd = "1"b;	/* Dont put on bulkstore just for lil ole me */
	     ksta.set.explicit_deactivate_ok, ksta.value.explicit_deactivate_ok = "1"b;
	     ksta.set.allow_write = "1"b;		/* Dont let me wreck user seg by accident */
	     ksta.set.tus, ksta.value.tus = "1"b;	/* Save a vtoc write */
	end;
	banner_proc = a_banner_proc;
	req_stream = a_stream_name;
	fac = a_element_size;
	a_code = 0;				/* set to zero for now */

	dr_ptr = iodd_static.driver_ptr;		/* get ptr to the current driver status seg */
	desc_ptr = addr (dr_ptr -> driver_status.descriptor); /* and to the request descriptor */
	ms_arg_ptr = desc_ptr;			/* first part of desciptor is ms_return_args */
	dmp = addr (dr_ptr -> driver_status.message);	/* set dprint_msg default pointer */
	request_data_p = addr (REQUEST);		/* get ready to handle "single copy" request */
	driver_data_p = addr (desc_ptr -> request_descriptor.driver_data); /* get ptr to printer_driver_data */

	on cleanup call clean_proc;			/* establish a cleanup handler */
	err_label = abort_request;

/* Set up master structure used by this pgm. */

	REQUEST.requestor = mseg_return_args.sender_id;
	REQUEST.continued = desc_ptr -> request_descriptor.continued;
	REQUEST.restarted = desc_ptr -> request_descriptor.restarted;
	REQUEST.separator = "1"b;			/* we always want a print separator first time */
	REQUEST.device_name = dr_ptr -> driver_status.dev_name_label;
	REQUEST.request_type = dr_ptr -> driver_status.req_type_label;
	REQUEST.queue = desc_ptr -> request_descriptor.q;
	REQUEST.request_no = desc_ptr -> request_descriptor.seq_id; /* coord assigned the number */
	REQUEST.restart_no = desc_ptr -> request_descriptor.prev_seq_id;
						/* previous number of request (0 = not restarted) */
	REQUEST.contd_no = desc_ptr -> request_descriptor.contd_seq_id;
						/* previous number of continued request (0 = not continued) */
	REQUEST.dpmp = dmp;
	REQUEST.delete = dprint_msg.delete_sw;
	if ^REQUEST.continued then print_driver_data.copies_done = 0; /* no copies assumed, unless continued */
						/* if none completed, it's not continued */
	else if print_driver_data.copies_done < 1 then REQUEST.continued = "0"b;
	REQUEST.copies = dprint_msg.copies;
	REQUEST.notify = (dprint_msg.notify = 1);
	REQUEST.total_charge = 0e0;
	l = length (REQUEST.requestor) + 1 - 2 - verify (reverse (REQUEST.requestor), " ");
	mailname = substr (REQUEST.requestor, 1, l);
	unspec (send_mail_info) = "0"b;
	send_mail_info.version = 1;
	send_mail_info.wakeup = "1"b;
	send_mail_info.always_add = "1"b;
	send_mail_info.sent_from = REQUEST.request_type;

	if dprint_msg.output_module = 1 then do;
	     REQUEST.punsw = 0;
	     pverb = "print";
	end;
	else do;
	     REQUEST.punsw = 1;
	     pverb = "punch";
	end;

/* Find the access class to use for the banner */

	if aim_check_$greater (mseg_return_args.sender_authorization, dr_ptr -> driver_status.min_banner) then
	     auth = mseg_return_args.sender_authorization;
	else auth = dr_ptr -> driver_status.min_banner;	/* mark the output with auth */

	call convert_authorization_$to_string (auth, auth_string, code); /* get string form */
	if code ^= 0 then call fatal_error;		/* this is real bad */

	l = 681 - verify (reverse (auth_string), " ");	/* how long is the string */
	if l < 681 then				/* quick test for blank string */
	     if l > 132 then do;			/* too long for normal output..check for short form */
		call convert_authorization_$from_string (access_class, "system_high", code);
		if code ^= 0 then call fatal_error;
		if aim_check_$equal (auth, access_class) then auth_string = "SYSTEM HIGH"; /* this is shorter */
	     end;

	REQUEST.access_class_string = auth_string;	/* save all we can for the label */


/* 	get pathname of file for header and error messages */

	user_dir = dprint_msg.dirname;
	ename = dprint_msg.ename;
	if substr (user_dir, 1, 4) = ">   " then gt = " ";
	else gt = ">";
	call ioa_$rsnnl ("^a^a^a", full_path, lng2, user_dir, gt, ename);

	REQUEST.full_path = translate (full_path, "", tab_nl_vt_ff); /* force a page fault on the table - HARDWARE BUG WRITEAROUND */
	full_path = translate (full_path, "", tab_nl_vt_ff); /* remove bad chars for banner */
	dprint_msg.destination = translate (dprint_msg.destination, "", tab_nl_vt_ff);
	dprint_msg.heading = translate (dprint_msg.heading, "", tab_nl_vt_ff);

	REQUEST.full_path = full_path;		/* save the clean copy */
	segp, fcbp = null;				/* ready for an early restart */
	REQUEST.line_count = 0;
	REQUEST.page_count = 0;

/* we now know enough to be able to restart this request if desired */

repr_start:

	header_found, header_sw, msf_sw = "0"b;
	tailsw, chgsw = "0"b;			/* initialize accounting switches */
	old_cpu, bitcnt, nelt = 0;			/* just in case they get used before being set */

	REQUEST.time_start_request = clock_ ();
	call date_time_ (REQUEST.time_start_request, REQUEST.date_time_start_request);

	REQUEST.cpu_time = 0;			/* reset the usage data */
	REQUEST.real_time = 0;
	REQUEST.page_waits = 0;
	REQUEST.pre_pages = 0;
	REQUEST.bit_count = 0;
	REQUEST.charge = 0e0;
	REQUEST.copy_no = print_driver_data.copies_done + 1; /* initialize copy-counter */
	REQUEST.output_mode = "";

	header_found = "1"b;			/* we now have enough info to print a head/tail banner */

	on daemon_again begin;			/* to restart the current request.... */
	     call restart_request ("master");		/* talking to master terminal */
	     go to repr_start;
	end;

	on daemon_again_slave begin;			/* to restart the current request.... */
	     call restart_request ("slave");		/* talking to slave terminal */
	     go to repr_start;
	end;

	on daemon_kill go to flush_request;		/* flush the current request */

	on daemon_cancel go to flush_request;		/* likewise,  the cancelled flag has been set */

	iodd_static.request_in_progress = "1"b;		/* ready to accept kill, cancel etc. */

	call clean_proc;				/* see if we need to terminate after restart */

	err_mess = "";				/* no message until it is set */
	header_sw = "0"b;				/* so we'll get header now and on reprint */

/*	record the event of processing this request */

	if REQUEST.separator then do;			/* only have to log the request once */

	     dest = dprint_msg.destination;		/* keep this locally */

	     if dest = ""
	     then last = "";			/* set up "destination" part of log msg */
	     else call ioa_$rsnnl (" (to ^a)", last, l, dest);

	     if iodd_static.slave.active then do;	/* tell slave */
		call ioa_$ioa_stream (iodd_static.slave_output, "Request ^d.^d: ^a",
		     REQUEST.request_no, REQUEST.queue, pverb);
		call ioa_$ioa_stream (iodd_static.slave_output, "   ^a ",
		     full_path);
		call ioa_$ioa_stream (iodd_static.slave_output, "   for ^a^a",
		     REQUEST.requestor, last);
	     end;
	     call ioa_$ioa_stream (iodd_static.log_stream, "Request ^d.^d: ^a ^a for ^a^a",
		REQUEST.request_no, REQUEST.queue, pverb, full_path, REQUEST.requestor, last);

	end;

	call cpu_time_and_paging_ (old_waits, old_cpu, old_pp); /* keep time and page waits for accounting */


/* check the requestor's access to the pathname he specified */

	val = mseg_return_args.level;

	call check_user_access (user_dir, ename, code);	/* use the internal proc to do the work */
	if code ^= 0 then call fatal_error;		/* it won't return to here */

	err_mess = full_path;			/* let this sit here in case of error */

	call hcs_$status_minf (user_dir, ename, 1, tpe, mult_no, code); /* see what kind of a thing it is */
	if code ^= 0 then call fatal_error;

	if tpe = 2 then				/* directory */
	     if mult_no < 1 then do;			/* it was a directory */
		code = error_table_$dirseg;
		call fatal_error;
	     end;
	     else do;				/* it is a multi_segment file - handle different */

		call msf_manager_$open (user_dir, ename, fcbp, code);
		if code ^= 0 then do;
		     err_mess = "Could not open multi-segment file "||full_path;
		     call fatal_error;
		end;
		msf_sw = "1"b;			/* indicate that it is an MSF */

	     end;

	else do;					/* it is an ordinary segment */

	     call hcs_$initiate_count (user_dir, ename, "", bitcnt, 1, segp, code);
	     if segp = null then do;
		err_mess = "Cannot initiate "||full_path;
		call fatal_error;
	     end;
	     msf_sw = "0"b;				/* it is not an MSF, make it clear */
	     if privileged				/* If we can be nice, we will */
	     then call hphcs_$set_kst_attributes (binary (baseno (segp), 18), addr (ksta), (0));

	end;

/*	Now we are ready to output the number of copies the user requested. */
/*	The structure of the loop and internal procedures is set to handle */
/*	different access and bitcounts per MSF component. */

	do while (REQUEST.copies >= REQUEST.copy_no);	/* once around for each copy */

	     call banner_proc (req_stream, header, addr (REQUEST), code); /* print header banner */
	     if code ^= 0 then do;			/* I/O error trying to print header */
		call driver_fatal_error (code, "I/O ERROR -- trying to print header.");
		go to clean_out;			/* abort this request completely */
	     end;


	     REQUEST.separator = "0"b;		/* separator bar was for first banner only */
	     header_sw, tailsw = "1"b;		/* header was ok, do tail */
	     more_components = "1"b;			/* get ready for MSF components of this copy */

/*	The banner_proc set the user's output modes based on REQUEST.dpmp ... we just write the stream as it stands */

	     if ^msf_sw then do;			/* the normal case is the segment */

		call output_segment (user_dir, ename, segp); /* internal proc does the work */

	     end;

	     else do mult_ind = 0 by 1 while (more_components); /* MSF - go through each component starting with 0 */

		call msf_manager_$get_ptr (fcbp, mult_ind, "0"b, segp, bitcnt, code);
		if segp = null then do;
		     if code = error_table_$noentry then more_components = "0"b; /* we are done */
		     else do;			/* try for more after other errors */
			call ioa_$rsnnl ("Could not get pointer to ^a>^d", err_mess, errlen,
			     full_path, mult_ind);
			call error_write (code, err_mess);
			more_components = "1"b;	/* just to be safe */
		     end;
		     go to next_component;
		end;

/*		we got a pointer to something...where is it */
/*		and does the requestor have access to it? */

		call hcs_$fs_get_path_name (segp, comp_dir, dir_len, comp_name, code);
		if code ^= 0 then do;
		     err_mess = "Could not get MSF component pathname.";
		     call error_write (code, err_mess);
		     go to next_component;
		end;

		call check_user_access (comp_dir, comp_name, code);
		if code ^= 0 then do;		/* he tried to pull a fast one and got caught */
		     err_mess = err_mess || "  " || substr (comp_dir, 1, dir_len) || ">" || comp_name;
		     call error_write (code, err_mess); /* most of err_mess was set by check_user_access */
		end;

		else do;				/* He made it through the obstacles */
		     if privileged			/* .. do it (gently if possible) */
		     then call hphcs_$set_kst_attributes (binary (baseno (segp), 18), addr (ksta), (0));
		     call output_segment (comp_dir, comp_name, segp);
		     if privileged then call phcs_$deactivate (segp, (0));
		end;

next_component: end;				/* look for the next MSF component */


	     if REQUEST.copies > print_driver_data.copies_charged then do;
						/* user honestly deserves these charges */
		chgsw = "1"b;
		print_driver_data.copies_charged = print_driver_data.copies_charged + 1;
	     end;
	     else chgsw = "0"b;

	     call charge_for_work;			/* do the accounting so we can put price on tail */

	     call banner_proc (req_stream, tail, addr (REQUEST), code); /* this will put on the tail banner */
	     if code ^= 0 then do;			/* some type of error..don't do it again */
		call driver_fatal_error (code, "I/O ERROR -- attempting to write tail banner.");
		go to clean_out;
	     end;


	     print_driver_data.copies_done = print_driver_data.copies_done + 1;
	     REQUEST.copy_no = REQUEST.copy_no + 1;	/* get ready for next copy */
	     REQUEST.time_start_request = new_clock;	/* from accounting */
	     old_cpu = new_cpu;
	     old_waits = new_waits;
	     old_pp = new_pp;

	     REQUEST.bit_count = 0;			/* restart bit count */
	     header_sw, tailsw = "0"b;

	     call ios_$order (req_stream, "runout", null, status); /* make device disgorge */

	end;					/* done with this copy...check for more in while loop */


	if REQUEST.notify then do;
	     call ioa_$rsnnl ("^aed ^a $^.2f queue ^d ^a ^d", abort_msg, l,
		pverb, REQUEST.full_path, REQUEST.total_charge,
		REQUEST.queue, REQUEST.device_name, REQUEST.request_no);
	     call send_mail_$access_class (mailname, substr (abort_msg, 1, l), addr (send_mail_info),
		mseg_return_args.sender_authorization, code);
	end;
clean_out:					/* get ready for the next users' request */

	call ios_$order (req_stream, "runout", null, status); /* make device disgorge */

	call clean_proc;				/* get junk out of the address space */

	iodd_static.request_in_progress = "0"b;		/* no more commands can be effective */


	return;

/* =================================================================================== */

/*  This is where the condition handlers "go to" when something has gone wrong */

flush_request:					/* signal handler jumps back here */

	fault_name = "Operator aborted listing";	/* message for kill and cancel */

abort_request:					/* unclaimed signals transfer to here */

	if fault_name = "seg_fault_error" & iodd_static.segptr = segp then
	     chgsw = "1"b;				/* if user causes the fault then charge him for work */
	else chgsw = "0"b;

	if REQUEST.delete ^= 0
	then fault_mess = "; segment will not be deleted";
	else fault_mess = "";

	desc_ptr -> request_descriptor.dont_delete = "1"b; /* like we said */


	call ioa_$rsnnl ("^a during processing of request^a.", err_mess, l,
	     fault_name, fault_mess);

	code = 0;

	call fatal_error;				/* this will clean things up a bit */

	go to clean_out;				/* fatal_error will actually make the transfer */

/*  */
/* *****    INTERNAL PROCEDURES ***** */

charge_for_work: proc;

/* Accounting section, done at end of processing each copy of output. */

	     counts.line_count = 0;			/* Clear these items so that if the order is unknown.. */
	     counts.page_count = 0;			/* .. (like if card dim doesn't do them) we still go */
	     call ios_$order (req_stream, "get_count", addr (counts), status);
	     new_clock = clock_ ();
	     call cpu_time_and_paging_ (new_waits, new_cpu, new_pp);

	     if counts.line_count > 0 then
		REQUEST.line_count = counts.line_count;
	     else REQUEST.line_count = divide (REQUEST.bit_count+699, 700, 24, 0); /* Use block count
						   if dim returns zero line count */
	     REQUEST.page_count = counts.page_count;
	     if REQUEST.time_start_request = 0 | old_cpu = 0 then go to no_charge; /* don't give huge erroneous times */
	     if chgsw then do;			/* charge him */
		REQUEST.cpu_time = new_cpu - old_cpu;
						/* REQUEST.bit_count was set when chgsw was */
		REQUEST.real_time = new_clock - REQUEST.time_start_request;
		REQUEST.page_waits = fixed (new_waits - old_waits, 35);
		REQUEST.pre_pages = fixed (new_pp - old_pp, 35);
		call io_daemon_account_ (dr_ptr -> driver_status.acct_ptr, addr (REQUEST));
	     end;
	     else do;				/* tell user he wasn't charged */
no_charge:	REQUEST.charge = 0e0;		/* reset any undefined values */
		REQUEST.cpu_time = 0;
		REQUEST.real_time = 0;
		REQUEST.page_waits = 0;
		REQUEST.pre_pages = 0;
	     end;
	     REQUEST.total_charge = REQUEST.total_charge + REQUEST.charge;

	     return;

	end charge_for_work;


/* ======================================================================================== */

check_user_access: proc (user_dir, ename, ec);

/* Internal procedure to check that the requestor has at least "r" access to
   the specified segment */

dcl  user_dir char (*) aligned;
dcl  ename char (*) aligned;
dcl  code fixed bin (35);
dcl  ec fixed bin (35);

	     call hcs_$get_user_effmode (user_dir, ename, REQUEST.requestor, val, mode, code);
	     if code ^= 0 then do;
		err_mess = "Unable to get user's mode to segment.";
		ec = code;
		return;
	     end;

	     if (bit (mode, 5) & "01000"b) = "0"b then do;
		err_mess = "User does not have read access on segment.";
		ec = error_table_$moderr;
		return;
	     end;

	     call hcs_$get_access_class (user_dir, ename, access_class, code);
	     if code ^= 0 then do;
		err_mess = "Unable to get access class of segment.";
		ec = code;
		return;
	     end;

	     if ^ read_allowed_ (mseg_return_args.sender_authorization, access_class) then do;
		ec = error_table_$ai_restricted;
		err_mess = "User not allowed to read segment.";
		return;
	     end;

	     ec = 0;				/* ok, user passed the checks */

	     return;

	end check_user_access;


/* ======================================================================================== */

fatal_error: proc;

/* This is an internal procedure only to make the flow of control cleaner
   in the main procedure.  */

	     save_code = code;			/* keep current error for reporting */

	     if ^header_sw & header_found then do;
		call banner_proc (req_stream, header, addr (REQUEST), code);
		if code = 0 then header_sw, tailsw = "1"b; /* all was well */
		else header_sw, tailsw = "0"b;	/* just to be sure */
	     end;

	     call error_write (save_code, err_mess);

	     call ioa_$ioa_stream (iodd_static.log_stream, "Processing of request terminated.");

	     if iodd_static.slave.active then
		if iodd_static.slave.print_errors then
		     call ioa_$ioa_stream (iodd_static.slave_output, "Processing of request terminated.");

	     desc_ptr -> request_descriptor.dont_delete = "1"b; /* make sure we don't delete msf */

	     if tailsw then do;			/* if we owe a tail banner, do it */
		call charge_for_work;		/* charge for good part that may have been done */
		call banner_proc (req_stream, tail, addr (REQUEST), code);
	     end;

	     go to clean_out;			/* we'll stop rather than returning */

	end fatal_error;

/* =========================================================================================== */

error_write: proc (code, message);			/* for writing error messages to console &
						   request stream */
dcl  code fixed bin (35);
dcl  message char (*) varying;

	     if code ^= 0 then call check_fs_errcode_ (code, short_mes, mes_space);
	     else mes_space = "";

	     call ioa_$ioa_stream (iodd_static.log_stream, "io_daemon: ^a ^a", mes_space, message);

	     call ioa_$rsnnl ("Unable to ^a ^a. ^a ^a", abort_msg, l,
		pverb, REQUEST.full_path, mes_space, message);
	     call send_mail_$access_class (mailname, substr (abort_msg, 1, l), addr (send_mail_info),
		mseg_return_args.sender_authorization, (0));

	     if iodd_static.slave.active then
		if iodd_static.slave.print_errors then
		     call ioa_$ioa_stream (iodd_static.slave_output, "io_daemon: ^a ^a", mes_space, message);

	     if header_sw then do;			/* if banner_proc does a "reset" line and page count is lost */
		call ioa_$rsnnl ("^2/^a^/io_daemon: ^a ^a^/^a^|", abort_msg, l,
		     stars, mes_space, message, stars);
		call banner_proc (req_stream, error_msg, addr (abort_msg), code); /* put out error msg to media */
	     end;
	     return;

	end error_write;





/*  =============================================================================================== */

driver_fatal_error: proc (code, err_msg);

/* Internal procedure to print messages when there is an IO error on the output stream */

dcl  code fixed bin (35);
dcl  err_msg char (*);

	     call com_err_ (code, "io_daemon", "^a ^/ Driver returning to command level.", err_msg);

	     desc_ptr -> request_descriptor.dont_delete = "1"b; /* give a reprieve....in case */

	     a_code = code;				/* report driver_fatal_error */

	     return;

	end driver_fatal_error;

/* ======================================================================================== */

output_segment: proc (user_dir, ename, segp);

/* This internal procedure checks the Daemon's access to the segment, then calculates
   the length as determined by bitcount and current length, then data is written. */

dcl  user_dir char (*) aligned;
dcl  ename char (*) aligned;
dcl  segp ptr;

	     iodd_static.segptr = segp;		/* tell signal handler what segment we are using */

	     call hcs_$fs_get_mode (segp, mode, code);	/*  make sure daemon has access  */
	     if code ^= 0 then do;
		err_mess = "I/O Daemon does not have access to segment.";
		call error_write (code, err_mess);
		REQUEST.copies = 1;			/* don't do it again */
		return;
	     end;
	     if (bit (mode, 5) & "01000"b) = "0"b then do;
		err_mess = "I/O daemon does not have read access on segment.";
		call error_write (0, err_mess);
		REQUEST.copies = 1;			/* don't allow the error to be repeated */
		return;
	     end;

/*		find the current segment length in pages and in bits */

	     call hcs_$status_long (user_dir, ename, 1, addr (bla), null, code);
	     if code ^= 0 then do;
		err_mess = "I/O Daemon cannot get length of segment.";
		call error_write (code, err_mess);
		REQUEST.copies = 1;			/* don't do it again */
		return;
	     end;

	     bitcnt = fixed (bla.bitcnt);		/* relevant bits according to the user */

	     curl = fixed (bla.curlen, 12)*bits_per_page; /* calculate the current length in bits */

	     if bitcnt > curl then			/* excess would be \000 anyway */
		bitcnt = curl;			/* we use this value for accounting */

	     nelt = divide (bitcnt, fac, 17, 0);	/* see now many elements to write on the req_stream */
	     if nelt = 0 then do;
		code = 0;
		call ioa_$rsnnl ("^a>^a is a zero length segment.", err_mess, l, user_dir, ename);
		call error_write (code, err_mess);
		REQUEST.copies = 1;			/* as said before */
		return;
	     end;

	     REQUEST.bit_count = REQUEST.bit_count + bitcnt; /* update the amount of output */

	     call ios_$write (req_stream, segp, 0, nelt, nret, status); /* This is the actual output of segment */

	     if fbpart ^= 0 then do;			/* I/O error */
		call driver_fatal_error (fbpart, "I/O ERROR -- during user segment output.");
		go to clean_out;
	     end;

	     return;

	end output_segment;

/* ======================================================================================== */

restart_request: proc (source);

/* internal procedure used to question operator regarding the restart of current request */

dcl  answer char (120);
dcl  cnt_msg char (10);				/* space to specify a continued request */
dcl  copies_good fixed bin (35);			/* operator response to number of good copies */
dcl (input_stream, output_stream) char (32);
dcl  io_stat bit (72) aligned;
dcl 1 st aligned based (addr (io_stat)),
    2 code fixed bin (35),
    2 junk bit (36);
dcl  pg_count_msg char (30);				/* space to specify pages per copy */
dcl  restrt_msg char (30);				/* space that the request is to be restarted */
dcl  source char (*);

dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  ios_$read entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned);

/* set up input/output stream for the master terminal */

	     if source = "master" then do;
		input_stream = iodd_static.input_stream;
		output_stream = "user_output";
	     end;

/* set up input/output stream for the slave terminal */

	     else do;
		input_stream = iodd_static.slave.slave_input;
		output_stream = iodd_static.slave.slave_output;
	     end;


/* is there a need to query the operator? */

	     if REQUEST.punsw = 1 | print_driver_data.copies_done = 0 | REQUEST.copies = 1 then do;

		restrt_msg = "";
		REQUEST.separator = "1"b;
		print_driver_data.copies_done = 0;

	     end;

	     else do;				/* must query operator */

		if REQUEST.page_count > 0 then	/* is there a non zero page count? */
		     call ioa_$rsnnl (" (^d pages each)", pg_count_msg, nret, REQUEST.page_count);
		else pg_count_msg = "";

		if REQUEST.continued then		/* is this a continued request? */
		     cnt_msg = " (continued request)";
		else cnt_msg = "";

ask_how_many_good:					/* tell operator how many were done */
		call ioa_$ioa_stream (output_stream, "^d of ^d copies^a were done^a.  How many were good?",
		     print_driver_data.copies_done, REQUEST.copies, pg_count_msg, cnt_msg);
						/* now let's see what the operator tells us */
		call ios_$read (input_stream, addr (answer), 0, 10, nelt, io_stat);

		if st.code ^= 0 then do;
		     copies_good = 0;
		     go to tell_operator;
		end;

		if substr (answer, nelt, 1) = NL then
		     answer = substr (answer, 1, nelt - 1);

		copies_good = cv_dec_check_ (answer, st.code);

		if st.code ^= 0 then do;		/* was the answer a number? */
bad_no:		     call ioa_$ioa_stream (output_stream, "Please specify a number between 0 and ^d",
			print_driver_data.copies_done);
		     go to ask_how_many_good;
		end;

		if copies_good < 0 | copies_good > print_driver_data.copies_done then go to bad_no;

tell_operator:	print_driver_data.copies_done = copies_good; /* update the record of finished copies */

		if copies_good = 0 then REQUEST.separator = "1"b;

		call ioa_$rsnnl (" from copy number ^d", restrt_msg, nret, copies_good + 1);

	     end;

	     call ioa_$ioa_stream (output_stream, "Restarting request^a.", restrt_msg);

	     return;

	end restart_request;

/* ======================================================================================== */

clean_proc: proc;

	     iodd_static.segptr = null;		/* tell signal handler we are done with it */

	     if fcbp ^= null then
		call msf_manager_$close (fcbp);

	     else if segp ^= null then do;
		if privileged then call phcs_$deactivate (segp, (0));
		call hcs_$terminate_noname (segp, code);
	     end;

	     segp, fcbp = null;			/* because this is used for several functions */

	     return;

	end clean_proc;



error_during_request: entry (cond);			/* for coming back after signal */

dcl  cond char (*);

	fault_name = cond;

	go to err_label;



set_single_copy: entry;

/*  to abort multiple copies if the single command must be used */

	request_data_p -> ordata.copies = 1;		/* make it fall out of the loop after tail sheet */

	return;


     end g115_output_request_;






		    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
