


		    PNOTICE_pps.alm                 11/18/82  1707.8rew 11/18/82  1630.1        5643


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

	aci	"W1PPPM0A1000"
	aci	"W2PPPM0A1000"
	aci	"W3PPPM0A1000"
	end
 



		    cv_ppscf.pl1                    11/18/82  1707.8rew 11/18/82  1629.3      180927


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


(subrg, size):
cv_ppscf: proc ();


/*		PARAMETERS		*/


/*		ENTRY CONSTANTS		*/


dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_hex_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_ppscf$cv_ppscf ext;
dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl  get_pdir_ entry () returns (char (168));
dcl  ioa_ entry options (variable);
dcl  ioa_$ioa_stream entry options (variable);
dcl  ioa_$ioa_switch entry options (variable);
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));


/*		EXTERNAL DATA		*/


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


/*		BUILTIN FUNCTIONS & CONDITIONS		*/


dcl  addr builtin;
dcl  fixed builtin;
dcl  hbound builtin;
dcl  length builtin;
dcl  ltrim builtin;
dcl  null builtin;
dcl  rtrim builtin;
dcl  search builtin;
dcl  size builtin;
dcl  substr builtin;
dcl  unspec builtin;
dcl  verify builtin;

dcl  cleanup condition;


/*		AUTOMATIC STORAGE		*/


dcl  X (20) fixed bin (8) unal;
dcl  arg_len fixed bin;
dcl  arg_ptr ptr;
dcl  code fixed bin (35);
dcl  default_char fixed bin;
dcl  dname char (168);
dcl  ename char (168);
dcl  error_flag bit (1);
dcl  hex_value fixed bin (35);
dcl  i fixed bin;
dcl  init bit (1) aligned;
dcl  input file;
dcl  input_i fixed bin;
dcl  input_iocb_ptr ptr;
dcl  input_l fixed bin;
dcl  input_line char (128);
dcl  j fixed bin;
dcl  line_num fixed bin;
dcl  list_flag bit (1);
dcl  list_iocb_ptr ptr;
dcl  listing output file;
dcl  long_flag bit (1);
dcl  me_ptr ptr;
dcl  n_hits fixed bin;
dcl  n_read fixed bin (21);
dcl  nargs fixed bin;
dcl  oc fixed bin (8) unal;
dcl  output output file;
dcl  output_iocb_ptr ptr;
dcl  pps (0:255) fixed bin (8) unal;
dcl  sort_iocb_ptr ptr;
dcl  source_name char (32) var;
dcl  source_path char (168) var;
dcl  space_char fixed bin;
dcl  sysprint print file;
dcl  table (0:127-32, 0:255) fixed bin (8) unal;
dcl  text_l fixed bin;
dcl  text_ptr ptr;
dcl  token_l fixed bin;
dcl  token_ptr ptr;
dcl  value fixed bin;
dcl  word_ptr ptr;
dcl  x fixed bin;

dcl 1 index_table,
    2 default_char fixed bin (8) unal,
    2 space_char fixed bin (8) unal,
    2 tab (0:255),
      3 ascii_char fixed bin (8) unal,
      3 pps_char fixed bin (8) unal;


dcl 1 sort_rec,
    2 key char (14) unal,
    2 value fixed bin (8) unal,
    2 nl char (1);


/*		CONSTANTS			*/


dcl  BS char (1) static internal options (constant) init ("");
dcl  ME char (8) static internal options (constant) init ("cv_ppscf");
dcl  NL char (1) static internal options (constant) init ("
");
dcl  WS char (4) static internal options (constant) init (" 	");

dcl  CODE_LINE (18) char (80) var static internal options (constant) init (
     "	epp1	ap|2,*		address of source string to pr1",
     "	epp3	ap|4,*		address of target string to pr3",
     "	ldx3	0,du		set x3 not to skip parent pointer if none",
     "	lxl2	ap|0		load argument list code value",
     "	canx2	=o000004,du	check for code 4 - no parent pointer",
     "	tnz	*+2		transfer if no parent pointer",
     "	ldx3	2,du		parent pointer - set x3 to skip it",
     "	lda	ap|6,x3*		load source string descriptor",
     "	ldq	ap|8,x3*		load target string descriptor",
     "	ana	mask		drop all but string size bits",
     "	anq	mask		ditto",
     "	even",
     "	mvt	(pr,rl),(pr,rl),fill(040)	translate ascii to ebcdic",
     "	desc9a	1|0,al		source string",
     "	desc9a	3|0,ql		target string",
     "	arg	mvtt",
     "	short_return		""exit",
     "mask:	oct	000077777777");


/*		INTERNAL STATIC		*/


dcl  db_sw bit (1) aligned static init ("0"b);


/*		BASED VARIABLES		*/


dcl  arg char (arg_len) based (arg_ptr);
dcl  input_array (128) char (1) unal based (addr (input_line));
dcl  text char (text_l) based (text_ptr);
dcl  token char (token_l) based (token_ptr);
dcl  word (6144) bit (36) aligned based (word_ptr);

	me_ptr = addr (cv_ppscf$cv_ppscf);


	call cu_$arg_count (nargs);
	if nargs < 1 then do;
	     code = error_table_$noarg;
	     call com_err_ (code, ME,
 "^/Usage is: cv_ppscf path {-list|-ls|-long|-lg}...");
	     return;
	end;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME);
	     return;
	end;
	call expand_pathname_$add_suffix (arg, "ppscf", dname, ename, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a", arg);
	     return;
	end;
	source_name = substr (ename, 1, length (rtrim (ename))-6);
	if dname = ">" then source_path = "";
	else source_path = rtrim (dname);
	source_path = source_path || ">" || source_name;


	list_flag = "0"b;
	long_flag = "0"b;
	do i = 2 to nargs;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Referencing argument #^d.", i);
		return;
	     end;
	     if arg = "-list" | arg = "-ls" then list_flag = "1"b;
	     else if arg = "-long" | arg = "-lg" then long_flag = "1"b;
	     else do;
		code = error_table_$badopt;
		call com_err_ (code, ME, "^a", arg);
		return;
	     end;
	end;

	input_iocb_ptr = null ();
	output_iocb_ptr = null ();
	list_iocb_ptr = null ();
	sort_iocb_ptr = null ();

	on cleanup call CLEANUP ();

	call iox_$attach_name ("input", input_iocb_ptr, "vfile_ " || source_path || ".ppscf ", me_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "Error attaching input stream.^/Attach description: ^a",
		"vfile_ " || source_path || ".ppscf");
	     return;
	end;
	call iox_$open (input_iocb_ptr, 1, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a", "input");
	     call CLEANUP ();
	     return;
	end;

	call iox_$attach_name ("output", output_iocb_ptr, "vfile_ " || source_path || ".alm", me_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "Error attaching output stream.^/Attach description: ^a",
		"vfile_ " || source_path || ".alm");
	     call CLEANUP ();
	     return;
	end;
	call iox_$open (output_iocb_ptr, 2, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a", "output");
	     call CLEANUP ();
	     return;
	end;

	if list_flag then do;
	     call iox_$attach_name ("listing", list_iocb_ptr, "vfile_ " || source_path || ".ppsctl", me_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Error attaching listing switch.^/Attach description: ^a",
		     "vfile_ " || source_path || ".ppsctl");
		call CLEANUP ();
		return;
	     end;
	     call iox_$open (list_iocb_ptr, 2, "0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "^a", "listing");
		call CLEANUP ();
		return;
	     end;
	end;

	call iox_$attach_name ("sort", sort_iocb_ptr, "vfile_ " || rtrim (get_pdir_ ()) || ">sort", me_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "Error attaching sort stream.^/Attach description: ^a",
		"vfile_ " || rtrim (get_pdir_ ()) || ">sort");
	     call CLEANUP ();
	     return;
	end;
	call iox_$open (sort_iocb_ptr, 2, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a", "sort");
	     call CLEANUP ();
	     return;
	end;

	error_flag = "0"b;
	default_char = 0;
	line_num = 1;
	code = 0;
	do while (code ^= error_table_$end_of_info);
	     input_line = "";
	     call iox_$get_line (input_iocb_ptr, addr (input_line), length (input_line), n_read, code);
	     if code = error_table_$long_record then do;
		call ioa_$ioa_stream ("error_output", "ERROR ON LINE ^d^/The input line is too long.^/SOURCE:  ^a^/",
		     line_num, input_line);
		code = 0;
	     end;
	     else if code = 0 then do;
		if substr (input_line, n_read, 1) = NL then
		     n_read = n_read -1;
		if n_read > 0 then do;
		     call PROCESS_INPUT_LINE ();
		     if text_ptr ^= null () then
			call WRITE_INPUT_LINE ();
		end;
	     end;
	     else if code ^= error_table_$end_of_info then do;
		call com_err_ (code, ME, "Error on line number ^d while reading input file.", line_num);
		call CLEANUP ();
		return;
	     end;
	     line_num = line_num+1;
	end;

	if error_flag then goto FATAL;

	call SORT_INPUT ();

/*

   Initialize the tables involved.

*/


	do i = 0 to hbound (table, 1);
	     do j = 0 to hbound (table, 2);
		table (i, j) = default_char;
	     end;
	end;

	do i = 0 to hbound (pps, 1);
	     pps (i) = default_char;
	end;

	index_table.default_char = default_char;
	index_table.space_char = space_char;
	do i = 0 to hbound (index_table.tab, 1);
	     index_table.tab (i).ascii_char = -1;
	     index_table.tab (i).pps_char = -1;
	end;

	line_num = 0;
	n_hits = 0;


/*

   Now process the input file.

*/


	code = 0;

	do while (code ^= error_table_$end_of_info);

	     call GET_A_LINE ();

	     if code ^= error_table_$end_of_info then
		if x ^= 0 then
		     call PROCESS_A_LINE ();

	end;

	value = space_char;
	if ^SET_PPS (0) then;
	if ^SET_TABLE (0, (space_char)) then;

	if list_flag then
	     call ioa_$ioa_switch (list_iocb_ptr, "^d out of ^d table entries used.", n_hits, size (table)*4);
	if long_flag then
	     call ioa_ ("^d out of ^d table entries used.", n_hits, size (table)*4);


/*

   Now we have a completed table!  Create a source segment.

*/


	call ioa_$ioa_switch (output_iocb_ptr, "^-segdef^-^a_move^/^a_move:",
	     source_name, source_name);
	do i = 1 to hbound (CODE_LINE, 1);
	     call ioa_$ioa_switch (output_iocb_ptr, "^a", CODE_LINE (i));
	end;
	call ioa_$ioa_switch (output_iocb_ptr, "^/^-segdef^-^a_table^/^a_table:",
	     source_name, source_name);
	word_ptr = addr (table);
	do i = 1 to size (table) by 4;
	     call ioa_$ioa_switch (output_iocb_ptr, "^-oct^-^w,^w,^w,^w",
		word (i), word (i+1), word (i+2), word (i+3));
	end;
	call ioa_$ioa_switch (output_iocb_ptr, "^|mvtt:^-null");
	word_ptr = addr (pps);
	do i = 1 to size (pps) by 4;
	     call ioa_$ioa_switch (output_iocb_ptr, "^-oct^-^w,^w,^w,^w",
		word (i), word (i+1), word (i+2), word (i+3));
	end;
	call ioa_$ioa_switch (output_iocb_ptr, "^-end");


	if list_flag then
	     do i = 0 to hbound (index_table.tab, 1);
	     if index_table.tab (i).ascii_char = -1 then
		call ioa_$ioa_switch (list_iocb_ptr, "^d", i);
	     else call ioa_$ioa_switch (list_iocb_ptr, "^d^2x^a", i, ASCII_STRING ((i)));
	end;


FATAL:

	call CLEANUP ();


	return;

GET_A_LINE: proc ();


dcl  i fixed bin;
dcl  t_val bit (9) aligned;


	     x = 0;
	     call iox_$get_line (sort_iocb_ptr, addr (sort_rec), size (sort_rec)*4, n_read, code);
	     if code ^= 0 then do;
		if code = error_table_$end_of_info then return;
		call com_err_ (code, ME, "Error reading the sort file.");
		goto FATAL;
	     end;
	     line_num = line_num+1;
	     if db_sw then
		call ioa_ ("line number ^d = ""^a ^d""", line_num, ltrim (sort_rec.key, " "), sort_rec.value);

	     do i = 1 to length (sort_rec.key);
		t_val = unspec (substr (sort_rec.key, i, 1));
		if t_val ^= "0"b then do;
		     x = x+1;
		     X (x) = fixed (t_val) - 32;
		     if db_sw then
			call ioa_ ("X(^d)=^d", x, X (x));
		end;
	     end;
	     value = sort_rec.value;

	     return;


	end GET_A_LINE;

PROCESS_A_LINE: proc ();


	     if x = 1 then do;
		if ^SET_PPS (X (1)) then do;
		     call com_err_ (0, "create_table",
			"""^a"" character is already defined as ""^a"".",
			ASCII_CHAR (X (1)), ASCII_CHAR (pps (X (1))));
		     return;
		end;
		if ^SET_TABLE (X (1), pps (X (1)+32)) then do;
		     call com_err_ (0, "create_table",
			"itself overstruck with itself is not unique.",
			ASCII_CHAR (X (1)));
		     return;
		end;
	     end;
	     else do i = 1 to x;
		init = "0"b;
		do j = 1 to x;
		     if i ^= j then do;
			if ^init then do;
			     init = "1"b;
			     oc = pps (X (j)+32);
			     if oc = default_char then do;
				call com_err_ (0, "create_table",
				     "PPS character representation for ""^a"" is not yet defined.",
				     ASCII_CHAR (X (j)));
				return;
			     end;
			end;
			else do;
			     if table (X (j), oc) = default_char then do;
				call com_err_ (0, "create_table",
				     """^a"" overstruck with ""^a"" is not yet defined.",
				     ASCII_STRING ((oc)), ASCII_CHAR (X (j)));
				return;
			     end;
			     oc = table (X (j), oc);
			end;
		     end;
		end;
		if ^SET_TABLE (X (i), oc) then do;
		     call com_err_ (0, "create_table",
			"""^a"" overstruck with ""^a"" is not unique.",
			ASCII_STRING ((oc)), ASCII_CHAR (X (i)));
		     return;
		end;
		if ^SET_TABLE (X (i), (value)) then do;
		     call com_err_ (0, "create_table",
			"""^a"" overstruck with ""^a"" is not unique.",
			ASCII_STRING ((value)), ASCII_CHAR (X (i)));
		     return;
		end;
	     end;

	     return;


	end PROCESS_A_LINE;

ASCII_CHAR: proc (c_val) returns (char (1));


dcl  c_val fixed bin (8) unal;
dcl  collate builtin;


	     return (substr (collate (), (c_val+32+1), 1));

	end ASCII_CHAR;

ASCII_STRING: proc (pc) returns (char (*));


dcl  pc fixed bin (8) unal;


	     if index_table.tab (pc).pps_char = -1 then
		return (ASCII_CHAR (index_table.tab (pc).ascii_char));
	     else
	     return (ASCII_CHAR (index_table.tab (pc).ascii_char) || ASCII_STRING (index_table.tab (pc).pps_char));


	end ASCII_STRING;

SET_PPS:	proc (ascii_char) returns (bit (1));


dcl  ascii_char fixed bin (8) unal;


	     if pps (ascii_char+32) ^= default_char then
		if pps (ascii_char+32) = value then return ("1"b);
		else return ("0"b);

	     if db_sw then call ioa_ ("pps(^d)=^d", ascii_char+32, value);
	     pps (ascii_char+32) = value;
	     if index_table.tab (value).ascii_char = -1 then
		index_table.tab (value).ascii_char = ascii_char;
	     return ("1"b);


	end SET_PPS;

SET_TABLE: proc (ascii_char, pps_char) returns (bit (1));


dcl  ascii_char fixed bin (8) unal;
dcl  pps_char fixed bin (8) unal;


	     if table (ascii_char, pps_char) ^= default_char then
		if table (ascii_char, pps_char) = value then return ("1"b);
		else return ("0"b);

	     if db_sw then call ioa_ ("table(^d,^d)=^d", ascii_char, pps_char, value);
	     table (ascii_char, pps_char) = value;
	     n_hits = n_hits+1;
	     if index_table.tab (value).ascii_char = -1 then
		if index_table.tab (value).pps_char ^= value then do;
		     index_table.tab (value).ascii_char = ascii_char;
		     index_table.tab (value).pps_char = pps_char;
		end;
	     return ("1"b);


	end SET_TABLE;

CLEANUP:	proc ();


	     if input_iocb_ptr ^= null () then do;
		call iox_$close (input_iocb_ptr, code);
		call iox_$detach_iocb (input_iocb_ptr, code);
	     end;

	     if output_iocb_ptr ^= null () then do;
		call iox_$close (output_iocb_ptr, code);
		call iox_$detach_iocb (output_iocb_ptr, code);
	     end;

	     if list_iocb_ptr ^= null () then do;
		call iox_$close (list_iocb_ptr, code);
		call iox_$detach_iocb (list_iocb_ptr, code);
	     end;

	     if sort_iocb_ptr ^= null () then do;
		call iox_$close (sort_iocb_ptr, code);
		call iox_$detach_iocb (sort_iocb_ptr, code);
	     end;

	     return;


	end CLEANUP;

PROCESS_INPUT_LINE: proc ();


	     input_i = 1;
	     input_l = n_read;
	     token_ptr, text_ptr = null ();
	     if line_num = 1 then do;
		call GET_HEX ();
		default_char = hex_value;
		call GET_HEX ();
		space_char = hex_value;
	     end;
	     else do;
		call GET_HEX ();
		if token_ptr = null () then return;
		call GET_TEXT ();
		if text_ptr = null () then return;
		call SKIP_COMMENT ();
		if input_l ^= 0 then
		     call ioa_$ioa_stream ("error_output", "ERROR ON LINE ^d^/Extra text in input line.^/Source:  ^a",
		     line_num, input_line);
	     end;

	     return;


	end PROCESS_INPUT_LINE;

GET_HEX:	proc ();

	     call GET_TOKEN ();
	     if token_ptr = null () then do;
		call ioa_$ioa_stream ("error_output", "ERROR ON LINE ^d^/Missing hexidecimal value.^/SOURCE:  ^a",
		     line_num, input_line);
		hex_value = 0;
		return;
	     end;
	     hex_value = cv_hex_check_ (token, code);
	     if code ^= 0 then do;
		call ioa_$ioa_stream ("error_output", "ERROR ON LINE ^d^/Illegal hexidecimal value.^/SOURCE:  ^a",
		     line_num, input_line);
		hex_value = 0;
	     end;
	     if hex_value > fixed ("ff"b4) then do;
		call ioa_$ioa_stream ("error_output", "ERROR ON LINE ^d^/Hexidecimal value is too large.^/SOURCE:  ^a",
		     line_num, input_line);
		hex_value = 0;
	     end;
	     return;

	end GET_HEX;

SKIP_WS:	proc ();

dcl  i fixed bin;

	     i = verify (substr (input_line, input_i, input_l), WS)-1;
	     if i < 0 then do;
		input_i = input_l+1;
		input_l = 0;
	     end;
	     else do;
		input_i = input_i + i;
		input_l = input_l - i;
	     end;
	     return;

	end SKIP_WS;

GET_TOKEN: proc ();

	     if input_l > 0 then call SKIP_WS ();
	     if input_l <= 0 then do;
		token_ptr = null ();
		token_l = 0;
		return;
	     end;
	     token_ptr = addr (input_array (input_i));
	     token_l = search (substr (input_line, input_i, input_l), WS)-1;
	     if token_l < 0 then token_l = input_l;
	     input_i = input_i+token_l;
	     input_l = input_l - token_l;
	     return;

	end GET_TOKEN;

GET_TEXT:	proc ();

	     call GET_TOKEN ();
	     text_ptr = token_ptr;
	     text_l = token_l;
	     if text_ptr = null () then
		call ioa_$ioa_stream ("error_output", "ERROR ON LINE ^d^/Missing text.^/SOURCE:  ^a",
		line_num, input_line);
	     return;

	end GET_TEXT;

SKIP_COMMENT: proc ();

	     input_i = input_i+input_l+1;
	     input_l = 0;
	     return;

	end SKIP_COMMENT;

WRITE_INPUT_LINE: proc ();


dcl  i fixed bin;
dcl  temp char (128) var;


	     unspec (sort_rec) = "0"b;
	     nl = "
";
	     sort_rec.value = hex_value;

	     temp = "";
	     do i = 1 to length (text);
		if substr (text, i, 1) ^= BS then do;
		     if unspec (substr (text, i, 1)) < "040"b3 |
		     unspec (substr (text, i, 1)) > "177"b3 then
			call ioa_$ioa_stream ("error_output", "ERROR ON LINE ^d^/Illegal text character.  ""^a""^/SOURCE:  ^a",
			line_num, substr (text, i, 1), input_line);
		     else temp = temp || substr (text, i, 1);
		end;
	     end;
	     if temp = "" then return;

	     if length (temp) > length (key) then
		call ioa_$ioa_stream ("error_output", "ERROR ON LINE ^d^/Text is too long.  Limit is ^d characters.^/SOURCE:  ^a",
		line_num, length (key), input_line);
	     substr (sort_rec.key, length (sort_rec.key)-length (temp)+1) = temp;
	     if db_sw then
		call ioa_ ("keyline = ""^a ^d""", sort_rec.key, sort_rec.value);
	     call iox_$put_chars (sort_iocb_ptr, addr (sort_rec), size (sort_rec)*4, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Error writing to sort file.");
		goto FATAL;
	     end;

	     return;


	end WRITE_INPUT_LINE;

SORT_INPUT: proc ();


	     call iox_$close (sort_iocb_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Error closing sort file.");
		goto FATAL;
	     end;

	     call sort_seg (rtrim (get_pdir_ ())||">sort");
dcl  sort_seg entry (char (*));

	     call iox_$open (sort_iocb_ptr, 1, "0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Error reopening sort file.");
		goto FATAL;
	     end;

	     return;


	end SORT_INPUT;

debug:	entry ();


	db_sw = ^db_sw;
	call ioa_ ("debug switch is ^[on^;off^].", db_sw);
	return;


     end cv_ppscf;
 



		    make_pps_tape.pl1               11/18/82  1707.8rew 11/18/82  1626.5       56547


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


make_pps_tape: proc ();


/*		CONSTANTS			*/


dcl  ME char (13) static internal options (constant) init ("make_pps_tape");
dcl  silent bit(1) static internal options (constant) init("1"b);

	     
/*		AUTOMATIC			*/


dcl  arg_len fixed bin;
dcl  arg_no fixed bin;
dcl  arg_ptr ptr;
dcl  attach_arg_len fixed bin;
dcl  attach_arg_ptr ptr;
dcl  attach_desc_supplied bit (1);
dcl  bit_count fixed bin (24);
dcl  code fixed bin (35);
dcl  dir char (168);
dcl  ent char (32);
dcl  header_printed bit (1);
dcl  iocb_ptr ptr;
dcl  job_num fixed bin;
dcl  modestring char (256) varying;
dcl  modestring_next bit (1);
dcl  n_bytes fixed bin (21);
dcl  nargs fixed bin;
dcl  seg_ptr ptr;
dcl  target_switch_name char (19);


/*		BASED			*/


dcl  arg char (arg_len) based (arg_ptr);
dcl  attach_arg char (attach_arg_len) based (attach_arg_ptr);


/*		EXTERNAL ENTRIES		*/


dcl  com_err_ entry options (variable);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$destroy_iocb entry (ptr, fixed bin(35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  make_pps_tape$make_pps_tape ext;
dcl  unique_chars_ entry (bit (*)) returns (char (15));


/*	          CONDITIONS	          */

dcl  cleanup condition;


/*		ERROR CODES		*/


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


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  divide builtin;
dcl  null builtin;

	code = 0;
	job_num = 1;
	iocb_ptr = null ();
	on cleanup call DETACH_PPS(silent);
	modestring = "";
	modestring_next = "0"b;
	header_printed = "0"b;
	target_switch_name = "PPS." || unique_chars_ ("0"b);


	call cu_$arg_count (nargs);
	call cu_$arg_ptr (2, attach_arg_ptr, attach_arg_len, code);
	if code ^= 0 then do;
USAGE:	     call com_err_ (code, ME,
		"^/Usage is:  make_pps_tape {-volume XX|-vol XX|-target_description XX|-tds XX} paths");
	     return;
	end;


	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME);
	     return;
	end;
	if arg = "-volume"
	| arg = "-vol"
	then attach_desc_supplied = "0"b;
	else if arg = "-target_description"
	| arg = "-tds"
	then attach_desc_supplied = "1"b;
	else do;
	     code = error_table_$badopt;
	     goto USAGE;
	end;


	call ATTACH_PPS ();
	if code ^= 0 then return;


	do arg_no = 3 to nargs while (code = 0);
	     call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Error referencing argument #^d.", arg_no);
		return;
	     end;
	     call PRINT_ON_PPS ((arg_no >= nargs));
	end;


	call DETACH_PPS (^silent);


	return;

ATTACH_PPS: proc ();


	     if attach_desc_supplied then do;
		call iox_$attach_name (target_switch_name, iocb_ptr, attach_arg, addr (make_pps_tape$make_pps_tape),
		     code);
		if code ^= 0 then do;
		     call com_err_ (code, ME, "Error while attaching PPS tape.^/Attach description: ^a", attach_arg);
		     call DETACH_PPS(silent);
		     return;
		end;
	     end;
	     else do;
		call iox_$attach_name (target_switch_name, iocb_ptr, "pps_ -vol " || attach_arg,
		     addr (make_pps_tape$make_pps_tape), code);
		if code ^= 0 then do;
		     call com_err_ (code, ME, "Error while attaching PPS tape.^/Attach description: pps_ -vol ^a",
			attach_arg);
		     call DETACH_PPS(silent);
		     return;
		end;
	     end;

	     call iox_$open (iocb_ptr, 2, "0"b, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Error attempting to open PPS file.");
		call DETACH_PPS(silent);
		return;
	     end;


	     return;


	end ATTACH_PPS;

DETACH_PPS: proc (quiet_sw);

dcl  quiet_sw bit(1),
     code fixed bin(35);

	  if iocb_ptr ^= null() then do;
	     call iox_$close (iocb_ptr, code);
	     if (code ^= 0  & ^quiet_sw) then
		call com_err_ (code, ME, "Error attempting to close PPS file.");

	     call iox_$detach_iocb (iocb_ptr, code);
	     if (code ^= 0  & ^quiet_sw) then
		call com_err_ (code, ME, "Error attempting to detach PPS file.");

	     call iox_$destroy_iocb(iocb_ptr, code);
	     end;
	
	return;


     end DETACH_PPS;

PRINT_ON_PPS: proc (last_request);


dcl  last_request bit (1);				/* ON => last request for this command invocation. */


	     call expand_pathname_ (arg, dir, ent, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "^a", arg);
		return;
	     end;

	     if ^header_printed then
		call ioa_ ("JOB #^-PATH");
	     header_printed = "1"b;

	     call hcs_$initiate_count (dir, ent, "", bit_count, 0, seg_ptr, code);
	     if seg_ptr = null () then do;
		call com_err_ (code, ME, "^a^[>^]^a", dir, (dir ^= ">"), ent);
		return;
	     end;
	     n_bytes = divide (bit_count, 9, 24, 0);

	     call iox_$put_chars (iocb_ptr, seg_ptr, n_bytes, code);
	     if code ^= 0 then
		call com_err_ (code, ME, "Error attempting to write to PPS file.");

	     call ioa_ ("^5d^-^a^[>^]^a", job_num, dir, (dir ^= ">"), ent);
	     job_num = job_num+1;

	     if ^last_request then do;
		call iox_$control (iocb_ptr, "new_report", null (), code);
		if code ^= 0 then
		     call com_err_ (code, ME,	"Error starting new report.");
	     end;

	     return;


	end PRINT_ON_PPS;


     end make_pps_tape;
 



		    ppf6023.ppscf                   11/18/82  1707.8rew 11/18/82  1626.5       10161


ff 40
07	-=_
07	-=
11	+-_
11	+-
32	-<_
32	-<
3d	^_|
3d	^|
4a	_c|
4a	c|
4b	._
4b	.
4c	<_
4c	<
4d	(_
4d	(
4e	+_
4e	+
4f	_|
4f	|
50	&_
50	&
5a	!_
5a	!
5b	$_
5b	$
5c	*_
5c	*
5d	)_
5d	)
5e	;_
5e	;
5f	^_
5f	^
60	-_
60	-
61	/_
61	/
6b	,_
6b	,
6c	%_
6c	%
6d	_
6e	>_
6e	>
6f	?_
6f	?
7a	:_
7a	:
7b	#_
7b	#
7c	@_
7c	@
7d	'_
7d	'
7e	=_
7e	=
7f	"_
7f	"
81	_a
81	a
82	_b
82	b
83	_c
83	c
84	_d
84	d
85	_e
85	e
86	_f
86	f
87	_g
87	g
88	_h
88	h
89	_i
89	i
8b	_{
8b	{
8c	<=_
8c	<=
8f	-_|
8f	-|
91	_j
91	j
92	_k
92	k
93	_l
93	l
94	_m
94	m
95	_n
95	n
96	_o
96	o
97	_p
97	p
98	_q
98	q
99	_r
99	r
9b	_}
9b	}
a2	_s
a2	s
a3	_t
a3	t
a4	_u
a4	u
a5	_v
a5	v
a6	_w
a6	w
a7	_x
a7	x
a8	_y
a8	y
a9	_z
a9	z
ad	[_
ad	[
ae	=>_
ae	=>
bd	]_
bd	]
be	=_|
be	=|
c1	A_
c1	A
c2	B_
c2	B
c3	C_
c3	C
c4	D_
c4	D
c5	E_
c5	E
c6	F_
c6	F
c7	G_
c7	G
c8	H_
c8	H
c9	I_
c9	I
d1	J_
d1	J
d2	K_
d2	K
d3	L_
d3	L
d4	M_
d4	M
d5	N_
d5	N
d6	O_
d6	O
d7	P_
d7	P
d8	Q_
d8	Q
d9	R_
d9	R
e0	\_
e0	\
e2	S_
e2	S
e3	T_
e3	T
e4	U_
e4	U
e5	V_
e5	V
e6	W_
e6	W
e7	X_
e7	X
e8	Y_
e8	Y
e9	Z_
e9	Z
f0	0_
f0	0
f1	1_
f1	1
f2	2_
f2	2
f3	3_
f3	3
f4	4_
f4	4
f5	5_
f5	5
f6	6_
f6	6
f7	7_
f7	7
f8	8_
f8	8
f9	9_
f9	9
   



		    ppf6025.ppscf                   11/18/82  1707.8rew 11/18/82  1626.5       10143


ff 40
02	/0
04	+-_
07	-=
11	+-
16	=>_
17	c|_
18	/=_
18	=|_
22	^_
23	<=_
24	+_
25	!_
26	"_
27	#_
28	$_
29	%_
2a	&_
2b	'_
2c	(_
2d	)_
2e	*_
30	._
31	-_
32	-<
33	,_
34	/_
35	0_
36	1_
37	2_
38	3_
39	4_
3a	5_
3b	6_
3c	7_
3d	^|
3d	^|_
3e	8_
3f	9_
41	:_
42	;_
43	<_
44	=_
45	>_
46	?_
47	@_
48	A_
49	B_
4a	c|
4b	.
4c	<
4d	(
4e	+
4f	|
50	&
51	C_
52	D_
53	E_
54	F_
55	G_
56	H_
57	I_
58	J_
59	L_
5a	!
5b	$
5c	*
5d	)
5e	;
5f	^
60	-
61	/
62	M_
63	N_
64	O_
65	P_
66	Q_
67	R_
68	S_
69	T_
6a	U_
6b	,
6c	%
6d	_
6e	>
6f	?
70	V_
71	W_
72	X_
73	Y_
74	Z_
75	]_
78	b_
79	c_
7a	:
7b	#
7c	@
7d	'
7e	=
7f	"
80	d_
81	a
82	b
83	c
84	d
85	e
86	f
87	g
88	h
89	i
8a	e_
8b	{
8c	<=
8f	-|
90	f_
91	j
92	k
93	l
94	m
95	n
96	o
97	p
98	q
99	r
9a	g_
9b	}
a2	s
a3	t
a4	u
a5	v
a6	w
a7	x
a8	y
a9	z
aa	h_
ad	[
ae	=>
ba	i_
bd	]
be	/=
be	=|
c1	A
c2	B
c3	C
c4	D
c5	E
c6	F
c7	G
c8	H
c9	I
ca	j_
cb	K_
cc	k_
cd	l_
cf	m_
d0	n_
d1	J
d2	K
d3	L
d4	M
d5	N
d6	O
d7	P
d8	Q
d9	R
da	o_
db	[_
dc	p_
dd	q_
de	r_
df	s_
e0	\
e0	\_
e1	a_
e2	S
e3	T
e4	U
e5	V
e6	W
e7	X
e8	Y
e9	Z
ea	t_
eb	u_
ed	v_
ee	w_
ef	x_
f0	0
f1	1
f2	2
f3	3
f4	4
f5	5
f6	6
f7	7
f8	8
f9	9
fa	y_
fb	z_
fc	{_
fd	|_
fe	}_
 



		    pps_.pl1                        02/02/88  1717.2r w 02/02/88  1540.0      149679


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


pps_attach: proc (iocb_ptr_arg, option_array, com_err_switch, code);

/* Modified 84-08-22 to call unique_chars_... -E. A. Ranzenbach */

/*		PARAMETERS		*/


dcl  code fixed bin (35);
dcl  com_err_switch bit (1) aligned;
dcl  iocb_ptr_arg ptr;
dcl  option_array (*) char (*) varying;


/*		ENTRY CONSTANTS		*/


dcl  com_err_ entry options (variable);
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);
dcl  cv_ptr_ entry (char (*), fixed bin (35)) returns (ptr);
dcl  default_handler_$set entry (entry);
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  hcs_$reset_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  hcs_$set_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  iox_$propagate entry (ptr);
dcl  mvt_entry entry (char (*), char (*)) variable;
dcl  ppf6023$ppf6023_move entry (char (*), char (*));
dcl  pps_$pps_attach entry (ptr, (*) char (*), bit (1) aligned, fixed bin (35));
dcl  pps_control entry (ptr, char (*), ptr, fixed bin (35));
dcl  pps_detach entry (ptr, fixed bin (35));
dcl  pps_modes entry (ptr, char (*), char (*), fixed bin (35));
dcl  pps_open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  pps_util_$find_ppscb entry (char (*), char (*), char (*), ptr, fixed bin (35));
dcl  requote_string_ entry (char (*)) returns (char (*));
dcl  unique_chars_ entry (bit (*)) returns (char (15));


/*		EXTERNAL DATA		*/


dcl  error_table_$bad_arg fixed bin (35) ext;
dcl  error_table_$bad_conversion fixed bin (35) ext;
dcl  error_table_$badopt fixed bin (35) ext;
dcl  error_table_$noarg fixed bin (35) ext;
dcl  error_table_$not_detached fixed bin (35) ext;
dcl  error_table_$unimplemented_version fixed bin (35) ext;
dcl  ppf6023$ppf6023_table ext;
dcl  pps_conv_$pps_conv_ ext;


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  hbound builtin;
dcl  length builtin;
dcl  ltrim builtin;
dcl  null builtin;
dcl  rtrim builtin;
dcl  substr builtin;

/*		AUTOMATIC STORAGE		*/


dcl  bottom_label char (132);
dcl  file_number pic "9999999999";
dcl  i fixed bin;
dcl  iocb_ptr ptr;
dcl  j fixed bin;
dcl  mask fixed bin (35);
dcl  may_be_volid bit (1);
dcl  modes_index fixed bin;
dcl  n fixed bin;
dcl  n_opts fixed bin;
dcl  ppscb_dir char (168);
dcl  ppscb_entry char (32);
dcl  ppscb_name char (32);
dcl  ppscb_ptr ptr;
dcl  retain_option char (4) varying;
dcl  string_len fixed bin (21);
dcl  string_ptr ptr;
dcl  table_ptr ptr;
dcl  tape_density pic "99999";
dcl  top_label char (132);
dcl  volids char (256) varying;


/*		CONSTANTS			*/


dcl  DEFAULT_TARGET_ATTACH_DESCRIP char (121) static internal options (constant) init ("tape_ibm_ ^a -create -name FILE^d -number ^d -format fb -record 133 -block 1596 -density ^d -retain ^a -force -mode ascii");
dcl  ME char (4) static internal options (constant) init ("pps_");
dcl  OPT_NAME_ARRAY (20) static internal char (16) varying options (constant) init (
     "-bottom_label",
     "-blbl",
     "-char_table",
     "-ct",
     "-control_block",
     "-cblk",
     "-density",
     "-den",
     "-label",
     "-lbl",
     "-modes",
     "-mds",
     "-number",
     "-nb",
     "-retain",
     "-ret",
     "-top_label",
     "-tlbl",
     "-volume",
     "-vol");
dcl  OPT_INDEX_ARRAY (20) static internal fixed bin options (constant) init (
     1, 1, 6, 6, 2, 2, 3, 3, 4, 4, 5, 5, 9, 9, 10, 10, 7, 7, 8, 8);

/*		INTERNAL STATIC		*/


/*		BASED VARIABLES		*/


dcl  string char (string_len) based (string_ptr) varying;

/*

   Initialize necessary data items.

*/


	code = 0;
	mask = 0;
	iocb_ptr = iocb_ptr_arg;

	call default_handler_$set (Default_Condition_Handler);


/*

   Now check to see if the I/O switch is attached. If so, complain. If not, then process the options and, if no errors
   are found, attach the I/O switch.

*/


	if iocb.attach_descrip_ptr ^= null () then do;
	     code = error_table_$not_detached;
	     if com_err_switch then
		call com_err_ (code, ME, "^a", iocb.name);
	     return;
	end;


/*

   Process the attach description arguments from left to right.

*/


	call Process_Options ();
	if code ^= 0 then return;


/*

   Now get the attach data in order.

*/


	call Update_Attach_Block ();
	if code ^= 0 then return;

/*

   Now, very carefully, update the IOCB.

*/


	call hcs_$set_ips_mask (0, mask);

	iocb.attach_data_ptr = ppsab_ptr;
	iocb.attach_descrip_ptr = addr (ppsab.attach_descrip);
	iocb.control = pps_control;
	iocb.modes = pps_modes;
	iocb.open = pps_open;
	iocb.detach_iocb = pps_detach;
	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (mask, mask);


/*

   If there were modes specified in the attach description, try to put them in effect.

*/


	if modes_index > 0 then do;
	     call pps_modes (iocb_ptr, (option_array (modes_index)), "", code);
	     if code ^= 0 then
		if com_err_switch then
		     call com_err_ (code, ME, "^a^/Default modes remain in effect.", option_array (modes_index));
	end;


	return;

Update_Attach_Block: proc ();


dcl  string char (512) varying;
dcl  init_ppsab bit (1) aligned;


/*

   Make sure we have an attach data block and determine the proper file number from this data block and the file
   number which may have been specified in the attach description.

*/


	     call hcs_$make_seg ("", (rtrim (iocb.name)||".ppsseg"), "", 01010b, ppsab_ptr, code);
	     if ppsab_ptr = null () then do;		/* ERROR - cannot create ppsseg. */
		if com_err_switch then
		     call com_err_ (code, ME, "Cannot create ppsseg in process directory.");
		return;
	     end;
	     if code ^= 0 then do;			/* Must have already been there. */
		code = 0;
		if ppsab.version = pps_attach_block_version_1 then init_ppsab = "0"b;
		else if ppsab.version = 0 then init_ppsab = "1"b;
		else do;
		     code = error_table_$unimplemented_version;
		     if com_err_switch then
			call com_err_ (code, ME, "^a.ppsseg in process directory has bad version.", iocb.name);
		     return;
		end;
	     end;
	     else init_ppsab = "1"b;


	     if file_number ^= 0 then do;
		if file_number > ppsab.file_number+1 then do;
		     code = error_table_$bad_arg;
		     if com_err_switch then
			call com_err_ (code, ME, "File number specified is beyond end of volume.");
		     return;
		end;
	     end;
	     else file_number = ppsab.file_number+1;

/*

   Compose an attach description for the iocb.attach_descrip_ptr.

*/


	     string = "pps_ -volume " || rtrim (volids) || " -density " || ltrim (tape_density, "0")
		|| " -number " || ltrim (file_number, "0") || " -retain " || retain_option;
	     if top_label ^= "" then do;
		string = string || " -top_label ";
		string = string || requote_string_ (rtrim (top_label));
	     end;
	     if bottom_label ^= "" then do;
		string = string || " -bottom_label ";
		string = string || requote_string_ (rtrim (bottom_label));
	     end;
	     if ppscb_entry ^= "" then do;
		string = string || " -ppscb ";
		if ppscb_dir ^= ">" then string = string || ppscb_dir;
		string = string || ">";
		string = string || ppscb_entry;
		string = string || " ";
		string = string || ppscb_name;
	     end;


/*

   Fill in the appropriate items in the attach data block.

*/


	     ppsab.attach_descrip = string;
	     ppsab.file_number = file_number;
	     ppsab.ppscb_dir = ppscb_dir;
	     ppsab.ppscb_entry = ppscb_entry;
	     ppsab.ppscb_name = ppscb_name;
	     ppsab.ppscb_ptr = ppscb_ptr;
	     ppsab.retain_option = retain_option;
	     ppsab.table_ptr = table_ptr;
	     ppsab.mvt_entry = mvt_entry;
	     ppsab.target_iocb_ptr = null ();
	     ppsab.open_descrip = "";


	     if ^init_ppsab then return;


	     ppsab.version = pps_attach_block_version_1;
	     ppsab.target_name = "pps_"||unique_chars_ ("0"b);
	     ppsab.target_attach_descrip = DEFAULT_TARGET_ATTACH_DESCRIP;
	     ppsab.tape_density = tape_density;
	     ppsab.volids = volids;

/*

   Initialize the prt_conv_info structure.

*/


	     ppsab.pps_pci.cv_proc = addr (pps_conv_$pps_conv_);
	     ppsab.pps_pci.lmarg = 0;			/* default indent = 0 */
	     ppsab.pps_pci.rmarg = 132;		/* default line length = 132 */
	     ppsab.pps_pci.page_length = 58;		/* default page_length = physical_page_length - pages_per_inch */
	     ppsab.pps_pci.phys_line_length = 132;	/* for 11 inch paper */
	     ppsab.pps_pci.phys_page_length = 58+6;	/* for 8.5 inch paper */
	     ppsab.pps_pci.lpi = 6;			/* the default */
	     ppsab.pps_pci.sheets_per_page = 1;
	     ppsab.pps_pci.line_count = 0;
	     ppsab.pps_pci.page_count = 0;
	     ppsab.pps_pci.func = 0;
	     ppsab.pps_pci.modes.overflow_off = "0"b;
	     ppsab.pps_pci.modes.single_space = "0"b;
	     ppsab.pps_pci.modes.non_edited = "0"b;
	     ppsab.pps_pci.modes.truncate = "0"b;
	     ppsab.pps_pci.modes.esc = "0"b;
	     ppsab.pps_pci.modes.ctl_char = "0"b;
	     ppsab.pps_pci.coroutine_modes.upper_case = "0"b;
	     ppsab.pps_pci.coroutine_modes.ht = "0"b;
	     ppsab.pps_pci.coroutine_modes.slew_table_idx = "000"b;
	     ppsab.pps_pci.top_label_line = top_label;
	     ppsab.pps_pci.bot_label_line = bottom_label;
	     ppsab.pps_pci.top_label_length = length (rtrim (top_label));
	     ppsab.pps_pci.bot_label_length = length (rtrim (bottom_label));
	     do i = 1 to hbound (ppsab.pps_pci.form_stops, 1);
		ppsab.pps_pci.form_stops (i).lbits = (9)"0"b;
		ppsab.pps_pci.form_stops (i).rbits = (9)"0"b;
	     end;
	     ppsab.pps_pci.level = 0;
	     ppsab.pps_pci.pos = 0;
	     ppsab.pps_pci.line = 0;
	     ppsab.pps_pci.slew_residue = 0;
	     ppsab.pps_pci.label_nelem = 0;
	     ppsab.pps_pci.label_wksp = null ();
	     ppsab.pps_pci.sav_pos = 0;
	     ppsab.pps_pci.esc_state = 0;
	     ppsab.pps_pci.esc_num = 0;
	     ppsab.pps_pci.temp = (36)"0"b;


	     return;


	end Update_Attach_Block;

Process_Options: proc ();


/*

   Initialize data items for pps_attach_block structure later.

*/


	     bottom_label = "";
	     file_number = 0;
	     may_be_volid = "1"b;
	     modes_index = 0;
	     mvt_entry = ppf6023$ppf6023_move;
	     ppscb_dir = "";
	     ppscb_entry = "";
	     ppscb_name = "";
	     ppscb_ptr = null ();
	     retain_option = "none";
	     table_ptr = addr (ppf6023$ppf6023_table);
	     tape_density = 1600;
	     top_label = "";
	     volids = "";


/*

   Now, process the options in the option_array.

*/


	     n_opts = hbound (option_array, 1);
	     i = 1;
	     do while (i <= n_opts);


/*

   Look up the option in the name array.

*/


		if substr (option_array (i), 1, 1) ^= "-" then do;
		     if ^may_be_volid then goto bad_opt;
		     volids = volids || option_array (i) || " ";
		     goto next_opt;
		end;

		may_be_volid = "0"b;

		do j = 1 to hbound (OPT_NAME_ARRAY, 1);
		     if OPT_NAME_ARRAY (j) = option_array (i) then
			goto OPTION (OPT_INDEX_ARRAY (j));
		end;


bad_opt:

		code = error_table_$badopt;
		if com_err_switch then
		     call com_err_ (code, ME, "^a", option_array (i));
		return;


OPTION (1):					/*  -bottom_label XX, -blbl XX */

		call Get_Next_String ();
		bottom_label = string;
		goto next_opt;


OPTION (2):					/*  -control_block cbpath cbname, -cblk cbpath cbname */


		call Get_Next_String ();
		call expand_pathname_ ((string), ppscb_dir, ppscb_entry, code);
		if code ^= 0 then do;
		     if com_err_switch then
			call com_err_ (code, ME, "^a", string);
		     return;
		end;
		call Get_Next_String ();
		ppscb_name = string;
		call pps_util_$find_ppscb (ppscb_dir, ppscb_entry, ppscb_name, ppscb_ptr, code);
		if ppscb_ptr = null () then do;
		     if com_err_switch then
			call com_err_ (code, ME, "Could not find PPS control block ^a in ^a^[>^]^a.",
			ppscb_name, ppscb_dir, (ppscb_dir ^= ">"), ppscb_entry);
		     return;
		end;
		goto next_opt;


OPTION (3):					/*  -density _n, -den _n  */

		call Get_Next_Dec ();
		if (n ^= 800) & (n ^= 1600) then do;
		     code = error_table_$bad_arg;
		     if com_err_switch then
			call com_err_ (code, ME, "Illegal density specification.  ^d", n);
		     return;
		end;
		tape_density = n;
		goto next_opt;


OPTION (4):					/*  -label XX, -lbl XX  */

		call Get_Next_String ();
		top_label, bottom_label = string;
		goto next_opt;

OPTION (5):					/*  -modes XX, -mds XX  */

		call Get_Next_String ();
		modes_index = i;
		goto next_opt;


OPTION (6):					/*  -char_table XX, -ct XX  */

		call Get_Next_String ();
		mvt_entry = cv_entry_ ((string||"$"||string||"_move"), addr (pps_$pps_attach), code);
		if code ^= 0 then do;
		     if com_err_switch then
			call com_err_ (code, ME, "^a|^a_move", string, string);
		end;
		table_ptr = cv_ptr_ ((string||"$"||string||"_table"), code);
		if code ^= 0 then do;
		     if com_err_switch then
			call com_err_ (code, ME, "^a|^a_table", string, string);
		     return;
		end;
		goto next_opt;


OPTION (7):					/*  -top_label XX, -tlbl XX  */

		call Get_Next_String ();
		top_label = string;
		goto next_opt;


OPTION (8):					/*  -volume XX, -vol XX  */

		call Get_Next_String ();
		if string = "" then do;
		     code = error_table_$bad_arg;
		     if com_err_switch then
			call com_err_ (code, ME, "Invalid volume idetifier specified.  ^a", string);
		     return;
		end;
		volids = volids||string||" ";
		goto next_opt;


OPTION (9):					/* -number N, -nb N  */

		call Get_Next_Dec ();
		file_number = n;
		goto next_opt;


OPTION (10):					/*  -retain XX, -ret XX  */

		call Get_Next_String ();
		if string ^= "all"
		& string ^= "none" then do;
		     code = error_table_$bad_arg;
		     if com_err_switch then
			call com_err_ (code, ME, "Invalid retain specification.  ^a",
			string);
		     return;
		end;
		else retain_option = string;
		goto next_opt;


next_opt:

		i = i+1;
	     end;


	     if volids = "" then do;
		code = error_table_$noarg;
		if com_err_switch then
		     call com_err_ (code, ME, "No volume identifer(s) specified.");
		return;
	     end;


fatal_opt_err:

	     return;

Get_Next_Dec:  proc ();


		if i >= n_opts then do;
		     code = error_table_$noarg;
		     if com_err_switch then
			call com_err_ (code, ME, "Missing decimal integer following ^a control argument.",
			option_array (i));
		     goto fatal_opt_err;
		end;
		i = i+1;
		n = cv_dec_check_ ((option_array (i)), code);
		if code ^= 0 then do;
		     code = error_table_$bad_conversion;
		     if com_err_switch then
			call com_err_ (code, ME, "Bad decimal integer following ^a control argument.  ^a",
			option_array (i-1), option_array (i));
		     goto fatal_opt_err;
		end;
		return;


	     end Get_Next_Dec;

Get_Next_String: proc ();


		if i >= n_opts then do;
		     code = error_table_$noarg;
		     if com_err_switch then
			call com_err_ (code, ME, "String missing following ^a control argument.", option_array (i));
		     goto fatal_opt_err;
		end;
		i = i+1;
		string_ptr = addr (option_array (i));
		string_len = length (option_array (i));
		return;


	     end Get_Next_String;


	end Process_Options;

/*

   Internal procedure to handle faults while IPS interrupts are masked. While not masked, any signals are simply
   passed on up the stack to their normal handlers. For a fault while masked, the process is terminated (with the
   reason "unable to do critical I/O") because the I/O control blocks are in an inconsistent state, and we can
   tolerate neither spawning a command loop with interrupts masked nor a restart with a possibly changed mask.

*/


Default_Condition_Handler: proc (p1, name, p2, p3, continue);


dcl  continue bit (1) aligned;
dcl  error_table_$unable_to_do_io fixed (35) ext;
dcl  name char (*);
dcl  p1 ptr;
dcl  p2 ptr;
dcl  p3 ptr;
dcl  terminate_process_ entry (char (*), ptr);

dcl 1 ti aligned,
    2 version fixed,
    2 code fixed (35);


	     if mask ^= 0 then do;
		ti.version = 0;
		ti.code = error_table_$unable_to_do_io;
		call terminate_process_ ("fatal_error", addr (ti));
	     end;
	     if name ^= "cleanup" then continue = "1"b;
	     return;


	end Default_Condition_Handler;

%include iocbv;

%include pps_attach_block;


     end pps_attach;
 



		    pps_close.pl1                   02/02/88  1717.2r w 02/02/88  1540.0       27405


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


pps_close: proc (iocb_ptr_arg, code);


/*		PARAMETERS		*/


dcl  code fixed bin (35);
dcl  iocb_ptr ptr;


/*		ENTRY CONSTANTS		*/


dcl  default_handler_$set entry (entry);
dcl  hcs_$reset_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  hcs_$set_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  iox_$propagate entry (ptr);
dcl  pps_control entry (ptr, char (*), ptr, fixed bin (35));
dcl  pps_detach entry (ptr, fixed bin (35));
dcl  pps_open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  pps_report_man_$stop entry (ptr, fixed bin (35));


/*		EXTERNAL DATA		*/


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  null builtin;


/*		AUTOMATIC STORAGE		*/


dcl  iocb_ptr_arg ptr;
dcl  mask fixed bin (35);


/*		CONSTANTS			*/


/*		INTERNAL STATIC		*/


/*		BASED VARIABLES		*/

/*

   Initialize necessary data.

*/


	code = 0;
	mask = 0;
	iocb_ptr = iocb_ptr_arg -> iocb.actual_iocb_ptr;
	ppsab_ptr = iocb.attach_data_ptr;

	call default_handler_$set (Default_Condition_Handler);


/*

   Now close the I/O switch.

*/


	call hcs_$set_ips_mask (0, mask);

	iocb.open_descrip_ptr = null ();
	iocb.open = pps_open;
	iocb.detach_iocb = pps_detach;
	iocb.control = pps_control;
	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (mask, mask);


/*

   Terminate the current output report (close and detach target I/O switch).

*/


	call pps_report_man_$stop (iocb_ptr, code);


	return;

/*

   Internal procedure to handle faults while IPS interrupts are masked. While not masked, any signals are simply
   passed on up the stack to their normal handlers. For a fault while masked, the process is terminated (with the
   reason "unable to do critical I/O") because the I/O control blocks are in an inconsistent state, and we can
   tolerate neither spawning a command loop with interrupts masked nor a restart with a possibly changed mask.

*/


Default_Condition_Handler: proc (p1, name, p2, p3, continue);


dcl  continue bit (1) aligned;
dcl  error_table_$unable_to_do_io fixed (35) ext;
dcl  name char (*);
dcl  p1 ptr;
dcl  p2 ptr;
dcl  p3 ptr;
dcl  terminate_process_ entry (char (*), ptr);

dcl 1 ti aligned,
    2 version fixed,
    2 code fixed (35);


	     if mask ^= 0 then do;
		ti.version = 0;
		ti.code = error_table_$unable_to_do_io;
		call terminate_process_ ("fatal_error", addr (ti));
	     end;
	     if name ^= "cleanup" then continue = "1"b;
	     return;


	end Default_Condition_Handler;

%include iocbv;

%include pps_attach_block;


     end pps_close;
   



		    pps_control.pl1                 02/02/88  1717.2r w 02/02/88  1540.0       78651


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


pps_control: proc (iocb_ptr_arg, order_arg, info_ptr, code);


/*		PARAMETERS		*/


dcl  code fixed bin (35);
dcl  info_ptr ptr;
dcl  iocb_ptr_arg ptr;
dcl  order_arg char (*);


/*		ENTRY CONSTANTS		*/


dcl  iox_$control entry (ptr, char (*), ptr, fixed bin (35));
dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  pps_print$flush entry (ptr, fixed bin (35));
dcl  pps_report_man_$attach entry (ptr, fixed bin (35));
dcl  pps_report_man_$init entry (ptr, fixed bin (35));
dcl  pps_report_man_$start entry (ptr, fixed bin (35));
dcl  pps_report_man_$stop entry (ptr, fixed bin (35));


/*		EXTERNAL DATA		*/


dcl  error_table_$bad_arg fixed bin (35) ext;
dcl  error_table_$inconsistent fixed bin (35) ext;
dcl  error_table_$no_operation fixed bin (35) ext;
dcl  error_table_$not_open fixed bin (35) ext;


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  divide builtin;
dcl  hbound builtin;
dcl  length builtin;
dcl  min builtin;
dcl  null builtin;
dcl  rtrim builtin;
dcl  substr builtin;


/*		AUTOMATIC STORAGE		*/


dcl  cpi fixed dec (5, 1);
dcl  i fixed bin;
dcl  iocb_ptr ptr;
dcl  lpi fixed dec (5, 1);
dcl  ppscbd_ptr ptr;
dcl  sheet_length fixed dec (5, 1);
dcl  sheet_width fixed dec (5, 1);


/*		CONSTANTS			*/


dcl  NL char (1) static internal options (constant) init ("
");
dcl  ORDER_NAME_ARRAY (19) char (24) static internal options (constant) init (
     "io_call",
     "page_labels",
     "get_ppscb_info",
     "set_ppscb_info",
     "retain_all",
     "retain_none",
     "inside_page",
     "outside_page",
     "end_of_page",
     "reset",
     "get_count",
     "get_position",
     "set_position",
     "channel_stops",
     "paper_info",
     "runout",
     "get_error_count",
     "pps_paper_info",
     "new_report");


/*		INTERNAL STATIC		*/


/*		BASED VARIABLES		*/

	iocb_ptr = iocb_ptr_arg -> iocb.actual_iocb_ptr;
	ppsab_ptr = iocb.attach_data_ptr;
	code = 0;


	do i = 1 to hbound (ORDER_NAME_ARRAY, 1);
	     if order_arg = ORDER_NAME_ARRAY (i) then goto PROCESS_ORDER (i);
	end;
	code = error_table_$no_operation;
	return;


PROCESS_ORDER (1):					/* io_call */

	return;


PROCESS_ORDER (2):					/* page_labels */

	if info_ptr = null () then do;
	     pps_pci.top_label_length,
		pps_pci.bot_label_length = 0;
	end;
	else if pps_pci.modes.overflow_off then
	     code = error_table_$inconsistent;
	else do;
	     orderp = info_ptr;
	     pps_pci.bot_label_line = page_labels.bottom_label;
	     pps_pci.bot_label_length = min (length (rtrim (page_labels.bottom_label)), length (pps_pci.bot_label_line));
	     pps_pci.top_label_line = page_labels.top_label;
	     pps_pci.top_label_length = min (length (rtrim (page_labels.top_label)), length (pps_pci.top_label_line));
	end;
	return;


PROCESS_ORDER (3):					/* get_ppscb_info */

	ppscbd_ptr = info_ptr;
	ppscb_data.dir_name = ppsab.ppscb_dir;
	ppscb_data.entry_name = ppsab.ppscb_entry;
	ppscb_data.name = ppsab.ppscb_name;
	ppscb_data.ppscb_ptr = ppsab.ppscb_ptr;
	return;


PROCESS_ORDER (4):					/* set_ppscb_info */

	ppscbd_ptr = info_ptr;
	ppsab.ppscb_dir = ppscb_data.dir_name;
	ppsab.ppscb_entry = ppscb_data.entry_name;
	ppsab.ppscb_name = ppscb_data.name;
	ppsab.ppscb_ptr = ppscb_data.ppscb_ptr;
	return;


PROCESS_ORDER (5):					/* retain_all */

	if iocb.open_descrip_ptr ^= null () then do;
	     call iox_$control (ppsab.target_iocb_ptr, "retain_all", null (), code);
	     if code ^= 0 then return;
	end;
	ppsab.retain_option = "all";
	return;


PROCESS_ORDER (6):					/* retain_none */

	if iocb.open_descrip_ptr ^= null () then do;
	     call iox_$control (ppsab.target_iocb_ptr, "retain_none", null (), code);
	     if code ^= 0 then return;
	end;
	ppsab.retain_option = "none";
	return;


PROCESS_ORDER (7):					/* inside_page */


PROCESS_ORDER (8):					/* outside_page */

	if iocb.open_descrip_ptr = null () then goto NOT_OPEN;
	pps_pci.func = 1;
	call iox_$put_chars (ppsab.target_iocb_ptr, addr (NL), length (NL), code);
	pps_pci.func = 0;
	return;


PROCESS_ORDER (9):					/* end_of_page */

	if iocb.open_descrip_ptr = null () then goto NOT_OPEN;
	pps_pci.func = 3;
	call iox_$put_chars (ppsab.target_iocb_ptr, addr (NL), length (NL), code);
	pps_pci.func = 0;
	return;


PROCESS_ORDER (10):					/* reset */

	ppsab.modes.no_print = "0"b;
	ppsab.modes.single_page = "0"b;
	ppsab.stop_every = 0;
	ppsab.chars_printed = 0;
	return;


PROCESS_ORDER (11):					/* get_count */

	orderp = info_ptr;
	counts.line = pps_pci.line;
	counts.page_length = pps_pci.page_length;
	counts.lmarg = pps_pci.lmarg;
	counts.rmarg = pps_pci.rmarg;
	counts.line_count = pps_pci.line_count;
	counts.page_count = pps_pci.page_count * pps_pci.sheets_per_page;
	return;


PROCESS_ORDER (12):					/* get_position */

	orderp = info_ptr;
	position_data.line_number = pps_pci.line;	/* which line we are printing */
	position_data.page_number = pps_pci.page_count * pps_pci.sheets_per_page; /* which  phys page number */
	position_data.total_lines = pps_pci.line_count;	/* lines printed since "reset" order */
	position_data.total_chars = ppsab.chars_printed;
	return;


PROCESS_ORDER (13):					/* set_position */

	pps_pci.line_count = position_data.total_lines;
	pps_pci.page_count = divide (position_data.page_number, pps_pci.sheets_per_page, 17);
	ppsab.chars_printed = position_data.total_chars;
	return;


PROCESS_ORDER (14):					/* channel_stops */

	do i = 1 to hbound (pps_pci.form_stops, 1);
	     pps_pci.form_stops (i).lbits = "0"b || substr (channel_stops (i), 1, 8);
	     pps_pci.form_stops (i).rbits = "1"b || substr (channel_stops (i), 9, 8);
	end;
	return;


PROCESS_ORDER (15):					/* paper_info */

	lpi = paper_info.lines_per_inch;
	cpi = 12.5;
	sheet_length = divide (paper_info.phys_page_length, lpi, 5, 1);
	sheet_width = divide (paper_info.phys_line_length, cpi, 5, 1);
	call Set_Page_Size ();
	return;


PROCESS_ORDER (16):					/* runout */

	call pps_print$flush (iocb_ptr, code);
	return;


PROCESS_ORDER (17):					/* get_error_count */

	orderp = info_ptr;
	ret_error_count = 0;
	return;


PROCESS_ORDER (18):					/* pps_paper_info */

	ppspip = info_ptr;
	sheet_length = pps_paper_info.sheet_length;
	sheet_width = pps_paper_info.sheet_width;
	lpi = pps_paper_info.lines_per_inch;
	cpi = pps_paper_info.chars_per_inch;
	call Set_Page_Size ();
	return;


PROCESS_ORDER (19):					/* new_report */

if ppsab.retain_option = "none" then do;
call iox_$control(ppsab.target_iocb_ptr,"retain_all",null(),code);
if code ^= 0 then return;
end;

	call pps_report_man_$stop (iocb_ptr, code);
	if code ^= 0 then goto RESET_RETAIN;

	ppsab.file_number = ppsab.file_number+1;

	call pps_report_man_$attach (iocb_ptr, code);
	if code ^= 0 then goto RESET_RETAIN;
	call pps_report_man_$init (iocb_ptr, code);
	if code ^= 0 then goto RESET_RETAIN;
	call pps_report_man_$start (iocb_ptr, code);


RESET_RETAIN:

if ppsab.retain_option = "none" then
call iox_$control(ppsab.target_iocb_ptr,"retain_none",null(),(0));

	return;


NOT_OPEN:

	code = error_table_$not_open;
	return;

Set_Page_Size: proc ();


dcl  cpii fixed bin;
dcl  lpii fixed bin;
dcl  sli fixed bin;
dcl  swi fixed bin;


	     do cpii = 1 to hbound (CPI, 1);
		if CPI (cpii) = cpi then goto CPI_OK;
	     end;
	     code = error_table_$bad_arg;
	     return;


CPI_OK:

	     do lpii = 1 to hbound (LPI, 1);
		if LPI (lpii) = lpi then goto LPI_OK;
	     end;
	     code = error_table_$bad_arg;
	     return;


LPI_OK:

	     do swi = 1 to hbound (PAPER_WIDTH, 1);
		if PAPER_WIDTH (swi) = sheet_width then goto PW_OK;
	     end;
	     code = error_table_$bad_arg;
	     return;


PW_OK:

	     do sli = 1 to hbound (PAPER_LENGTH, 1);
		if PAPER_LENGTH (sli) = sheet_length then goto PL_OK;
	     end;
	     code = error_table_$bad_arg;
	     return;


PL_OK:

	     pps_pci.phys_page_length = sheet_length*lpi-4;
	     pps_pci.phys_line_length = min (132, sheet_width*cpi-4);
	     pps_pci.lpi = 4;
	     ppsab.cpii = cpii;
	     ppsab.lpii = lpii;
	     ppsab.swi = swi;
	     ppsab.sli = sli;
	     return;


	end Set_Page_Size;

%include iocbv;

%include pps_attach_block;

%include prt_order_info;

%include pps_paper_info;
	
%include pps_paper_sizes;

%include pps_control_block_info;


     end pps_control;
 



		    pps_conv_.alm                   02/02/88  1717.2r w 02/02/88  1538.3       20241


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


" The manner in which this procedure is utilized is described in detail
" in the listing of prt_conv_.
"
" This procedure is responsible for placing a carriage control character
" at the beginning of each output line.


	name	pps_conv_

	segdef	pps_conv_


pps_conv_:
	tra	pps_send_init
	tra	pps_send_chars
	tra	pps_send_slew_pattern
	tra	pps_send_slew_count

" 

	include	prt_conv_info


" 

pps_send_init:
	szn	lb|pci.temp	was there a previous slew?
	tnz	icc		yes, insert carriage control character

	lda	=a    "		first time, use carriage control of blank
	sta	lb|pci.temp	..

icc:	mlr	(pr),(pr)		move carriage control into output
	desc9a	lb|pci.temp,1	..
	desc9a	bb|0,1		..

	ldq	1,dl		step output pointer over carriage control
	a9bd	bb|0,ql		..

	tra	sb|0		return

" 

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

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

	a9bd	bb|0,2		step output pointer over blanks

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		make sure X2 now zero
	tra	sb|0		return to caller

" 

pps_send_slew_pattern:
	ldq	slew

stslew:	stq	lb|pci.temp	save for next line
	tra	sb|0		return to caller


slew:	aci	"1   "


pps_send_slew_count:
	eaq	0,al		line count in QU
	sbla	3,dl		can slew at most 3 lines at a time
	tmoz	*+2		if more than 3 lines,
          ldq       3,du                do only 3 to start
	ldq	slewn,qu		get correct carriage control
	tra	stslew		and store it for later


slewn:
	aci	"+   "		supress space
	aci	"    "		one space
	aci	"0   "		two space
	aci	"-   "		three space


	end
   



		    pps_detach.pl1                  02/02/88  1717.2r w 02/02/88  1540.0       25542


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


pps_detach: proc (iocb_ptr_arg, code);


/*		PARAMETERS		*/


dcl  code fixed bin (35);
dcl  iocb_ptr_arg ptr;


/*		ENTRY CONSTANTS		*/


dcl  default_handler_$set entry (entry);
dcl  hcs_$reset_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  hcs_$set_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));
dcl  iox_$propagate entry (ptr);


/*		EXTERNAL DATA		*/


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  null builtin;


/*		AUTOMATIC STORAGE		*/


dcl  iocb_ptr ptr;
dcl  mask fixed bin (35);


/*		CONSTANTS			*/


/*		INTERNAL STATIC		*/


/*		BASED VARIABLES		*/

/*

   Initialize necessary data.

*/


	code = 0;
	mask = 0;
	iocb_ptr = iocb_ptr_arg;
	ppsab_ptr = iocb.attach_data_ptr;
	ppscb_ptr = ppsab.ppscb_ptr;

	call default_handler_$set (Default_Condition_Handler);


/*

   Now detach the I/O switch.

*/


	call hcs_$set_ips_mask (0, mask);

	iocb.attach_descrip_ptr = null ();
	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (mask, mask);


/*

   And free the buffer space.

*/


	if ppsab.retain_option = "none" then
	     call hcs_$truncate_seg (addr (ppsab), 0, code);


	return;

/*

   Internal procedure to handle faults while IPS interrupts are masked. While not masked, any signals are simply
   passed on up the stack to their normal handlers. For a fault while masked, the process is terminated (with the
   reason "unable to do critical I/O") because the I/O control blocks are in an inconsistent state, and we can
   tolerate neither spawning a command loop with interrupts masked nor a restart with a possibly changed mask.

*/


Default_Condition_Handler: proc (p1, name, p2, p3, continue);


dcl  continue bit (1) aligned;
dcl  error_table_$unable_to_do_io fixed (35) ext;
dcl  name char (*);
dcl  p1 ptr;
dcl  p2 ptr;
dcl  p3 ptr;
dcl  terminate_process_ entry (char (*), ptr);

dcl 1 ti aligned,
    2 version fixed,
    2 code fixed (35);


	     if mask ^= 0 then do;
		ti.version = 0;
		ti.code = error_table_$unable_to_do_io;
		call terminate_process_ ("fatal_error", addr (ti));
	     end;
	     if name ^= "cleanup" then continue = "1"b;
	     return;


	end Default_Condition_Handler;

%include iocbv;

%include pps_attach_block;

%include pps_control_block;


     end pps_detach;
  



		    pps_modes.pl1                   02/02/88  1717.2r w 02/02/88  1540.0       83790


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


pps_modes: proc (iocb_ptr_arg, new_modes, old_modes, code);


/*		PARAMETERS		*/


dcl  code fixed bin (35);
dcl  iocb_ptr_arg ptr;
dcl  new_modes char (*);
dcl  old_modes char (*);


/*		ENTRY CONSTANTS		*/


dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  default_handler_$set entry (entry);
dcl  hcs_$reset_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  hcs_$set_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  pps_print$set_debug_sw entry (bit (1));


/*		EXTERNAL DATA		*/


dcl  error_table_$bad_mode fixed bin (35) ext;


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  divide builtin;
dcl  index builtin;
dcl  length builtin;
dcl  ltrim builtin;
dcl  substr builtin;
dcl  verify builtin;


/*		AUTOMATIC STORAGE		*/


dcl  bot_label_length fixed bin;
dcl  ctl_char bit (1);
dcl  debug bit (1);
dcl  esc bit (1);
dcl  indent fixed bin;
dcl  iocb_ptr ptr;
dcl  line_length fixed bin;
dcl  mask fixed bin (35);
dcl  no_print bit (1);
dcl  non_edited bit (1);
dcl  overflow_off bit (1);
dcl  page_length fixed bin;
dcl  physical_line_length fixed bin;
dcl  physical_page_length fixed bin;
dcl  sheets_per_page fixed bin;
dcl  single_page bit (1);
dcl  single_space bit (1);
dcl  stop_count fixed bin (71);
dcl  stop_every fixed bin;
dcl  top_label_length fixed bin;
dcl  truncate bit (1);


/*		CONSTANTS			*/


/*		INTERNAL STATIC		*/


/*		BASED VARIABLES		*/

	iocb_ptr = iocb_ptr_arg -> iocb.actual_iocb_ptr;
	ppsab_ptr = iocb.attach_data_ptr;
	code = 0;
	mask = 0;

	call default_handler_$set (Default_Condition_Handler);

	call Get_Old_Modes ();

	call Parse_New_Modes ();

	call Check_New_Modes ();

	call Set_New_Modes ();

	return;


bad_mode:

	code = error_table_$bad_mode;
	return;

Check_New_Modes: proc ();


	     if line_length > physical_line_length then goto bad_mode;

	     if indent >= line_length then goto bad_mode;

	     if overflow_off then do;
		top_label_length,
		     bot_label_length = 0;
		sheets_per_page = 1;
		page_length = physical_page_length - pps_pci.lpi;
	     end;
	     else sheets_per_page =
		divide (page_length+pps_pci.lpi-1+physical_page_length, physical_page_length, 17, 0);

	     return;


	end Check_New_Modes;

Get_Old_Modes: proc ();


dcl  oldm char (length (old_modes)) varying;
dcl  pic pic "zzzzzzz9";


	     indent = pps_pci.lmarg;
	     line_length = pps_pci.rmarg;
	     page_length = pps_pci.page_length;
	     physical_line_length = pps_pci.phys_line_length;
	     physical_page_length = pps_pci.phys_page_length;
	     non_edited = pps_pci.modes.non_edited;
	     overflow_off = pps_pci.modes.overflow_off ;
	     truncate = pps_pci.modes.truncate ;
	     single_space = pps_pci.modes.single_space ;
	     esc = ppsab.pps_pci.modes.esc;
	     ctl_char = ppsab.pps_pci.modes.ctl_char;
	     debug = ppsab.modes.debug;
	     top_label_length = pps_pci.top_label_length;
	     bot_label_length = pps_pci.bot_label_length;
	     stop_every = ppsab.stop_every;
	     stop_count = ppsab.stop_count;
	     single_page = ppsab.modes.single_page;
	     no_print = ppsab.modes.no_print;

	     if length (old_modes) <= 0 then return;

	     oldm = "";
	     if non_edited then oldm = oldm || "^edited,";
	     if overflow_off then oldm = oldm || "^endpage,";
	     if truncate then oldm = oldm || "^fold,";
	     if single_space then oldm = oldm || "^vertsp,";
	     if esc then oldm = oldm || "esc,";
	     if debug then oldm = oldm || "debug,";
	     if stop_every > 0 then do;
		pic = stop_every;
		oldm = oldm || "stop" || ltrim (pic) || ",";
	     end;
	     if indent > 1 then do;
		pic = indent;
		oldm = oldm || "in" || ltrim (pic) || ",";
	     end;
	     pic = line_length;
	     oldm = oldm || "ll" || ltrim (pic) || ",";
	     pic = page_length;
	     oldm = oldm || "pl" || ltrim (pic) || ",";
	     pic = physical_line_length;
	     oldm = oldm || "pll" || ltrim (pic) || ",";
	     pic = physical_page_length;
	     oldm = oldm || "ppl" || ltrim (pic);

	     old_modes = oldm;


	     return;


	end Get_Old_Modes;

Parse_New_Modes: proc ();


dcl  bitval bit (1);
dcl  i fixed bin;
dcl  l fixed bin;
dcl  mode char (32);


	     i = verify (new_modes, " ");
	     if i <= 0 then return;


	     do while (i <= length (new_modes));

		l = index (substr (new_modes, i), ",")-1;
		if l < 0 then l = length (new_modes)-i+1;

		if l > 0 then do;

		     if substr (new_modes, i, 1) = "^" then do;
			bitval = "0"b;
			i = i+1;
			if i > length (new_modes) then return;
			l = l-1;
			if l = 0 then goto bad_mode;
		     end;
		     else bitval = "1"b;

		     mode = substr (new_modes, i, l);
		     i = i+l+1;

		     if mode = "default" then do;
			overflow_off,
			     single_space,
			     non_edited,
			     truncate,
			     esc,
			     ctl_char,
			     no_print = "0"b;
			top_label_length,
			     bot_label_length = 0;
			physical_line_length = 132;	/* for 11 inch paper */
			physical_page_length = 58+6;	/* for 8.5 inch paper */
			line_length = physical_line_length;
			indent = 0;
			page_length = physical_page_length - pps_pci.lpi;
			stop_every,
			     stop_count = 0;
		     end;
		     else if mode = "edited" then non_edited = ^bitval;
		     else if mode = "non_edited" then non_edited = bitval;
		     else if mode = "endpage" then overflow_off = ^bitval;
		     else if mode = "noskip" then overflow_off = bitval;
		     else if mode = "fold" then truncate = ^bitval;
		     else if mode = "truncate" then truncate = bitval;
		     else if mode = "vertsp" then single_space = ^bitval;
		     else if mode = "single" then single_space = bitval;
		     else if mode = "esc" then esc = bitval;
		     else if mode = "debug" then debug = bitval;
		     else if mode = "1pg" then single_page = bitval;
		     else if mode = "print" then no_print = ^bitval;
		     else if substr (mode, 1, 4) = "stop" then do;
			stop_every = cv_dec_check_ (substr (mode, 5), code);
			stop_count = 0;
			if code ^= 0 then goto bad_mode;
		     end;
		     else if substr (mode, 1, 2) = "in" then do;
			indent = cv_dec_check_ (substr (mode, 3), code);
			if code ^= 0 then goto bad_mode;
		     end;
		     else if substr (mode, 1, 3) = "pll" then do;
			physical_line_length = cv_dec_check_ (substr (mode, 4), code);
			if code ^= 0 then goto bad_mode;
		     end;
		     else if substr (mode, 1, 3) = "ppl" then do;
			physical_page_length = cv_dec_check_ (substr (mode, 4), code);
			if code ^= 0 then goto bad_mode;
		     end;
		     else if substr (mode, 1, 2) = "ll" then do;
			line_length = cv_dec_check_ (substr (mode, 3), code);
			if code ^= 0 then goto bad_mode;
		     end;
		     else if substr (mode, 1, 2) = "pl" then do;
			page_length = cv_dec_check_ (substr (mode, 3), code);
			if code ^= 0 then goto bad_mode;
		     end;
		     else goto bad_mode;

		end;

	     end;


	     return;


	end Parse_New_Modes;

Set_New_Modes: proc ();


	     call hcs_$set_ips_mask (0, mask);

	     pps_pci.lmarg = indent;
	     pps_pci.rmarg = line_length;
	     pps_pci.page_length = page_length;
	     pps_pci.phys_line_length = physical_line_length;
	     pps_pci.phys_page_length = physical_page_length;
	     pps_pci.modes.non_edited = non_edited;
	     pps_pci.modes.overflow_off = overflow_off;
	     pps_pci.modes.truncate = truncate;
	     pps_pci.modes.single_space = single_space;
	     ppsab.pps_pci.modes.esc = esc;
	     ppsab.modes.debug = debug;
	     ppsab.stop_every = stop_every;
	     ppsab.stop_count = stop_count;
	     ppsab.modes.single_page = single_page;
	     ppsab.modes.no_print = no_print;

	     call hcs_$reset_ips_mask (mask, mask);


	     call pps_print$set_debug_sw (ppsab.modes.debug);


	     return;


	end Set_New_Modes;

/*

   Internal procedure to handle faults while IPS interrupts are masked. While not masked, any signals are simply
   passed on up the stack to their normal handlers. For a fault while masked, the process is terminated (with the
   reason "unable to do critical I/O") because the I/O control blocks are in an inconsistent state, and we can
   tolerate neither spawning a command loop with interrupts masked nor a restart with a possibly changed mask.

*/


Default_Condition_Handler: proc (p1, name, p2, p3, continue);


dcl  continue bit (1) aligned;
dcl  error_table_$unable_to_do_io fixed (35) ext;
dcl  name char (*);
dcl  p1 ptr;
dcl  p2 ptr;
dcl  p3 ptr;
dcl  terminate_process_ entry (char (*), ptr);

dcl 1 ti aligned,
    2 version fixed,
    2 code fixed (35);


	     if mask ^= 0 then do;
		ti.version = 0;
		ti.code = error_table_$unable_to_do_io;
		call terminate_process_ ("fatal_error", addr (ti));
	     end;
	     if name ^= "cleanup" then continue = "1"b;
	     return;


	end Default_Condition_Handler;

%include iocbv;
%include pps_attach_block;


     end pps_modes;
  



		    pps_open.pl1                    02/02/88  1717.2r w 02/02/88  1540.0       33003


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


pps_open: proc (iocb_ptr_arg, mode, extend, code);


/*		PARAMETERS		*/


dcl  code fixed bin (35);
dcl  extend bit (1) aligned;
dcl  iocb_ptr_arg ptr;
dcl  mode fixed bin;


/*		ENTRY CONSTANTS		*/


dcl  default_handler_$set entry (entry);
dcl  hcs_$reset_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  hcs_$set_ips_mask entry (fixed bin (35), fixed bin (35));
dcl  iox_$propagate entry (ptr);
dcl  pps_close entry (ptr, fixed bin (35));
dcl  pps_put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  pps_report_man_$attach entry (ptr, fixed bin (35));
dcl  pps_report_man_$init entry (ptr, fixed bin (35));
dcl  pps_report_man_$start entry (ptr, fixed bin (35));


/*		EXTERNAL DATA		*/


dcl  error_table_$incompatible_attach fixed bin (35) ext;


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;


/*		AUTOMATIC STORAGE		*/


dcl  iocb_ptr ptr;
dcl  mask fixed bin (35);


/*		CONSTANTS			*/


dcl  STR_OUT fixed bin static internal options (constant) init (2);


/*		INTERNAL STATIC		*/


/*		BASED VARIABLES		*/

/*

   Initialize necessary data items.

*/


	code = 0;
	mask = 0;
	iocb_ptr = iocb_ptr_arg -> iocb.actual_iocb_ptr;
	ppsab_ptr = iocb.attach_data_ptr;

	call default_handler_$set (Default_Condition_Handler);


/*

   Validate the opening mode requested.

*/


	if (mode ^= STR_OUT) | extend then do;
	     code = error_table_$incompatible_attach;
	     return;
	end;


/*

   Attach the target I/O switch.

*/


	call pps_report_man_$attach (iocb_ptr, code);
	if code ^= 0 then return;


/*

   Assign values to the proper entry variables in the iocb.

*/


	call hcs_$set_ips_mask (0, mask);

	ppsab.open_descrip = "stream_output";

	call pps_report_man_$init (iocb_ptr, code);	/* code will always be 0 */

	iocb.close = pps_close;
	iocb.put_chars = pps_put_chars;
	iocb.open_descrip_ptr = addr (ppsab.open_descrip);
	call iox_$propagate (iocb_ptr);

	call hcs_$reset_ips_mask (mask, mask);


/*

   Now start the new report.

*/


	call pps_report_man_$start (iocb_ptr, code);


	return;

/*

   Internal procedure to handle faults while IPS interrupts are masked. While not masked, any signals are simply
   passed on up the stack to their normal handlers. For a fault while masked, the process is terminated (with the
   reason "unable to do critical I/O") because the I/O control blocks are in an inconsistent state, and we can
   tolerate neither spawning a command loop with interrupts masked nor a restart with a possibly changed mask.

*/


Default_Condition_Handler: proc (p1, name, p2, p3, continue);


dcl  continue bit (1) aligned;
dcl  error_table_$unable_to_do_io fixed (35) ext;
dcl  name char (*);
dcl  p1 ptr;
dcl  p2 ptr;
dcl  p3 ptr;
dcl  terminate_process_ entry (char (*), ptr);

dcl 1 ti aligned,
    2 version fixed,
    2 code fixed (35);


	     if mask ^= 0 then do;
		ti.version = 0;
		ti.code = error_table_$unable_to_do_io;
		call terminate_process_ ("fatal_error", addr (ti));
	     end;
	     if name ^= "cleanup" then continue = "1"b;
	     return;


	end Default_Condition_Handler;

%include iocbv;

%include pps_attach_block;

%include pps_control_block;


     end pps_open;
 



		    pps_print.pl1                   11/18/82  1707.8rew 11/18/82  1629.4       35199


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


pps_print: proc (iocb_ptr, current_string, table_ptr, mvt_entry, code);


/*		PARAMETERS		*/


dcl  a_debug_sw bit (1);
dcl  code fixed bin (35);
dcl  current_string char (*);
dcl  iocb_ptr ptr;
dcl  mvt_entry entry (char (*), char (*)) variable;
dcl  table_ptr ptr;


/*		ENTRY CONSTANTS		*/


dcl  ioa_$nnl entry options (variable);
dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));


/*		EXTERNAL DATA		*/


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  fixed builtin;
dcl  length builtin;
dcl  min builtin;
dcl  null builtin;
dcl  substr builtin;
dcl  unspec builtin;


/*		AUTOMATIC STORAGE		*/


dcl  curr_i fixed bin ;
dcl  current_string_len fixed bin;
dcl  hold_i fixed bin;
dcl  i fixed bin;
dcl  len fixed bin;
dcl  stop_index fixed bin;
dcl  temp_string char (133);

dcl 1 hex_data aligned,
    2 upper_bit bit (1) unal,
    2 digit (2) bit (4) unal;


/*		CONSTANTS			*/


dcl  HEX (0:15) char (1) static internal options (constant) init (
     "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "a", "b", "c", "d", "e", "f");
dcl  OVERSTRIKE char (1) static internal options (constant) init ("+");


/*		INTERNAL STATIC		*/


dcl  debug_sw bit (1) static init ("0"b);
dcl  hold_string char (133) static;
dcl  hold_string_len fixed bin static;


/*		BASED VARIABLES		*/


dcl  table (0:127-32, 0:255) char (1) unal based (table_ptr);

	code = 0;


	if table_ptr = null () then do;
	     call mvt_entry (current_string, hold_string);
	     if ^debug_sw then
		call iox_$write_record (iocb_ptr, addr (hold_string), length (hold_string), code);
	     return;
	end;


	current_string_len = length (current_string);
	if current_string_len = 0 then goto no_overstrike;


	if substr (current_string, 1, 1) ^= OVERSTRIKE then do;
no_overstrike:
	     call Output ();
	     if code ^= 0 then return;
	     if current_string_len > 0 then do;
		call mvt_entry (current_string, hold_string);
	     end;
	     hold_string_len = current_string_len;
	     return;
	end;


	stop_index = min (current_string_len, hold_string_len);
	do i = 2 to stop_index;

	     hold_i = fixed (unspec (substr (hold_string, i, 1)), 9);
	     curr_i = fixed (unspec (substr (current_string, i, 1)), 9)-32;
	     if curr_i ^= 0 then
		substr (hold_string, i, 1) = table (curr_i, hold_i);

	end;


	if current_string_len > hold_string_len then do;
	     stop_index = stop_index+1;
	     len = current_string_len-hold_string_len;
	     call mvt_entry (substr (current_string, stop_index, len), temp_string);
	     substr (hold_string, stop_index, len) = substr (temp_string, stop_index, len);
	     hold_string_len = current_string_len;
	end;


	return;

init:	entry ();


	hold_string_len = 0;


	return;

flush:	entry (iocb_ptr, code);


	code = 0;
	call Output ();
	return;

set_debug_sw: entry (a_debug_sw);


	debug_sw = a_debug_sw;
	return;

Output:	proc ();


	     if hold_string_len = 0 then return;
	     if debug_sw then do;
		do i = 1 to length (hold_string);
		     unspec (hex_data) = unspec (substr (hold_string, i, 1));
		     call ioa_$nnl ("^[1^; ^]^a^a^x", hex_data.upper_bit, HEX (fixed (hex_data.digit (1), 4)), HEX (fixed (hex_data.digit (2), 4)));
		end;
		call ioa_$nnl ("^/");
	     end;
	     else call iox_$write_record (iocb_ptr, addr (hold_string), (length (hold_string)), code);
	     hold_string_len = 0;
	     return;


	end Output;


     end pps_print;
 



		    pps_put_chars.pl1               02/02/88  1717.2r w 02/02/88  1540.0       16659


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


pps_put_chars: proc (iocb_ptr_arg, buff_ptr_arg, n_bytes_arg, code);


/*		PARAMETERS		*/


dcl  buff_ptr_arg ptr;
dcl  code fixed bin (35);
dcl  iocb_ptr_arg ptr;
dcl  n_bytes_arg fixed bin;


/*		ENTRY CONSTANTS		*/


dcl  pps_print entry (ptr, char (*), ptr, entry, fixed bin (35));
dcl  prt_conv_ entry (ptr, fixed bin, ptr, fixed bin, ptr);


/*		EXTERNAL DATA		*/


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  substr builtin;


/*		AUTOMATIC STORAGE		*/


dcl  buff_ptr ptr;
dcl  iocb_ptr ptr;
dcl  n_bytes fixed bin;
dcl  out_buf char (160);
dcl  out_len fixed bin;
dcl  out_ptr ptr;


/*		CONSTANTS			*/


/*		INTERNAL STATIC		*/


/*		BASED VARIABLES		*/


dcl  string char (256) based;

/*

   Initialize data.

*/


	iocb_ptr = iocb_ptr_arg -> iocb.actual_iocb_ptr;
	buff_ptr = buff_ptr_arg;
	n_bytes = n_bytes_arg;
	code = 0;
	ppsab_ptr = iocb.attach_data_ptr;
	pcip = addr (ppsab.pps_pci);


/*

   Now process the text supplied.

*/


	out_ptr = addr (out_buf);
	do while (n_bytes>0);
	     call prt_conv_ (buff_ptr, n_bytes, out_ptr, out_len, pcip);
	     if out_len > 0 then
		call pps_print (ppsab.target_iocb_ptr, substr (out_buf, 1, out_len), ppsab.table_ptr, ppsab.mvt_entry, code);
	     if code ^= 0 then return;
	end;


	return;

%include iocbv;

%include pps_attach_block;


     end pps_put_chars;
 



		    pps_report_man_.pl1             02/02/88  1717.2r w 02/02/88  1540.0       44145


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


pps_report_man_: proc (); return;


/*		PARAMETERS		*/


dcl  code fixed bin (35);


/*		ENTRY CONSTANTS		*/


dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
dcl  iox_$close entry (ptr, fixed bin (35));
dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
dcl  iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  pps_print$init entry ();
dcl  pps_print$flush entry (ptr, fixed bin (35));
dcl  pps_put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl  pps_util_$make_ppscb_record entry (ptr, ptr, fixed bin, fixed bin (35));


/*		EXTERNAL DATA		*/


/*		BUILTIN FUNCTIONS		*/


dcl  addr builtin;
dcl  divide builtin;
dcl  length builtin;
dcl  null builtin;
dcl  substr builtin;
dcl  unspec builtin;


/*		AUTOMATIC STORAGE		*/


dcl  i fixed bin;
dcl  iocb_ptr ptr;
dcl  my_ppscb_rec_len fixed bin;
dcl  string char (256);
dcl  string_len fixed bin;


dcl 1 my_ppscb_rec aligned,
    2 line (100) char (133);


/*		CONSTANTS			*/


dcl  FF char (1) static internal options (constant) init ("");
dcl  SEQ_OUT fixed bin static internal options (constant) init (5);


/*		INTERNAL STATIC		*/


/*		BASED VARIABLES		*/

/*

   This entry provides the attachment of the target I/O switch.

*/


attach: entry (iocb_ptr, code);


	code = 0;
	ppsab_ptr = iocb.attach_data_ptr;
	ppscb_ptr = ppsab.ppscb_ptr;


/*

   Create the attach description for the target I/O switch.

*/


	call ioa_$rsnnl (ppsab.target_attach_descrip, string, string_len, ppsab.volids, ppsab.file_number,
	     ppsab.file_number, ppsab.tape_density, ppsab.retain_option);


/*

   Attach the target I/O switch.

*/


	if ppsab.modes.debug then call ioa_ ("Attaching target iocb as ""^a"".", substr (string, 1, string_len));
	else call iox_$attach_ioname (ppsab.target_name, ppsab.target_iocb_ptr, substr (string, 1, string_len), code);
	if code ^= 0 then return;


/*

   Open the target I/O switch.

*/


	if ppsab.modes.debug then call ioa_ ("Opening target iocb.");
	else call iox_$open (ppsab.target_iocb_ptr, SEQ_OUT, "0"b, code);
	if code ^= 0 then return;			/* may need to detach */


/*

   Now, if we have a control block, convert it to a ppscb record and write it to tape.

*/


	if ppscb_ptr = null () then ppscb_ptr = addr (DEFAULT_PPS_CONTROL_BLOCK);
	unspec (my_ppscb_rec) = "0"b;
	call pps_util_$make_ppscb_record (ppscb_ptr, addr (my_ppscb_rec), my_ppscb_rec_len, code);
	if code ^= 0 then return;


	do i = 1 to divide ((my_ppscb_rec_len+3), 4, 17, 0);
	     call iox_$write_record (ppsab.target_iocb_ptr, addr (my_ppscb_rec.line (i)), length (my_ppscb_rec.line (i)), code);
	     if code ^= 0 then return;
	end;

	return;

/*

   This entry is called to initialize certain values in the attach data after
   the target I/O switch has been attached.

*/


init: entry (iocb_ptr,code);


	code = 0;
	ppsab_ptr = iocb.attach_data_ptr;

	ppsab.pps_pci.level = 0;
	ppsab.pps_pci.pos = 0;
	ppsab.pps_pci.line = ppsab.pps_pci.phys_page_length*ppsab.pps_pci.sheets_per_page
	     -divide (ppsab.pps_pci.lpi, 2, 17, 0)+1;
	ppsab.pps_pci.slew_residue = 0;
	ppsab.pps_pci.label_wksp = null ();
	ppsab.pps_pci.label_nelem = 0;
	ppsab.pps_pci.sav_pos = 0;
	ppsab.pps_pci.temp = (36)"0"b;

	return;

/*

   This entry is called to start a new report.  It must be called after the two
   preceeding entries.

*/


start: entry (iocb_ptr,code);


	code = 0;


/*

   Initialize the kludge module which will handle the overprinting.

*/


	call pps_print$init ();


/*

   Now we must initialize the output procedure, prt_conv_, to get him to the top of his output page.

*/


	call pps_put_chars (iocb_ptr, addr (FF), length (FF), code);


	return;

stop: entry (iocb_ptr, code);


      code = 0;
      ppsab_ptr = iocb.attach_data_ptr;


/*

   Flush any buffered output.

*/


	call pps_print$flush (ppsab.target_iocb_ptr, code);


/*

   Now close and detach the target I/O switch.

*/


	if ppsab.modes.debug then call ioa_ ("Closing and detaching target.");
	else do;
	     call iox_$close (ppsab.target_iocb_ptr, code);
	     call iox_$detach_iocb (ppsab.target_iocb_ptr, code);
	end;


	return;


%include iocbv;

%include pps_attach_block;

%include pps_control_block;


     end pps_report_man_;
   



		    pps_util_.pl1                   11/18/82  1707.8rew 11/18/82  1629.4       16605


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


pps_util_: proc ();


	return;

/*		PARAMETERS		*/


dcl  a_ppscb_dir char (*);
dcl  a_ppscb_entry char (*);
dcl  a_ppscb_name char (*);
dcl  a_ppscb_ptr ptr;
dcl  a_ppscb_rec_len fixed bin;
dcl  a_ppscb_rec_ptr ptr;
dcl  code fixed bin (35);


/*		ENTRY CONSTANTS		*/


dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));


/*		EXTERNAL DATA		*/


/*		BUILTIN FUNCTIONS		*/


dcl  null builtin;


/*		AUTOMATIC STORAGE		*/


/*		CONSTANTS			*/


/*		INTERNAL STATIC		*/


/*		BASED VARIABLES		*/

find_ppscb: entry (a_ppscb_dir, a_ppscb_entry, a_ppscb_name, a_ppscb_ptr, code);


	a_ppscb_ptr = null ();
	code = 0;


/*

   First we need the segment in which the control block supposedly resides.

*/


	call hcs_$initiate (a_ppscb_dir, a_ppscb_entry, "", 0, 0, ppscb_ptr, code);
	if code ^= 0 then return;


/*

   Now find the particular control block in the spcified segment.

*/


	code = 99;				/* Not yet implemented. */


	return;

make_ppscb_record: entry (a_ppscb_ptr, a_ppscb_rec_ptr, a_ppscb_rec_len, code);


	ppscb_ptr = a_ppscb_ptr;
	ppscb_rec_ptr = a_ppscb_rec_ptr;


/* move data from the ppscb structure to ppscb_rec structure */


	a_ppscb_rec_len = 0;


	return;

%include pps_control_block;

%include pps_control_block_rec;


     end pps_util_;


		    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