



		    decode_nstd_status_.pl1         11/19/82  1410.9rew 11/19/82  0929.8       63324



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


decode_nstd_status_: proc (status, return_string);


/* This procedure will decode the status returned by nstd_ and will return
   a short description of the status in a varying character string. It is called
   with two arguments. The first is the 72 bit status. The second is a 50 (or
   longer) character varying string in which the status interpretation message
   will be returned.

   WRITTEN BY DICK SNYDER .... 1971
   MODIFIED BY T. CASEY AUGUST 1974, NOVEMBER 1974

*/


dcl  status bit (72) aligned;
dcl  phyem char (100) varying;
dcl  return_string char (*) varying;

dcl 1 stat_word aligned based (addr (status)),
    2 fill bit (26) unaligned,
    2 major bit (4) unaligned,
    2 minor bit (6) unaligned;

dcl 1 minor_bits aligned based (addr (status)),
    2 fill2 bit (30) unaligned,
    2 mb1 bit (1) unaligned,
    2 mb2 bit (1) unaligned,
    2 mb3 bit (1) unaligned,
    2 mb4 bit (1) unaligned,
    2 mb5 bit (1) unaligned,
    2 mb6 bit (1) unaligned;

dcl (addr, string, substr) builtin;

	if major = "0000"b then do;			/* Peripheral Subsystem Ready */
	     if minor = "000000"b then phyem = "tape ready";
	     else if minor = "001100"b then phyem = "ASCII alert";
	     else if mb6 &^mb3 then phyem = "write protected";
	     else if mb5 &substr (minor, 1, 3) = "000"b then phyem = "positioned at BOT";
	     else if mb4 then phyem = "9 track handler";
	     else if ^mb5 then do;
		if substr (minor, 1, 3) = "010"b then phyem = "two bit fill";
		else if substr (minor, 1, 3) = "100"b then phyem = "four bit fill";
		else if substr (minor, 1, 3) = "110"b then phyem = "six bit fill";
		else goto unknown_ready;
	     end;
	     else
unknown_ready: phyem = "peripheral subsystem ready - unknown substatus";
	end;

	else if major = "0001"b then do;		/* Device Busy */
	     if minor = "000001"b then phyem = "in rewind";
	     else if minor = "100000"b then phyem = "device reserved";
	     else if minor = "000010"b then phyem = "alternate channel in control";
	     else if minor = "000100"b then phyem = "device loading";
	     else phyem = "device busy - unknown substatus";
	end;

	else if major = "0010"b then do;		/* Device Attention */
	     if mb1 then goto unknown_attention;
	     else if ^mb2 & substr (minor, 5, 2) = "01"b then phyem = "write protected";
	     else if mb2 & substr (minor, 5, 2) = "00"b then phyem = "blank tape on write";
	     else if substr (minor, 4, 2) = "10"b then phyem = "handler in standby";
	     else if mb3 &^mb5 then phyem = "handler check";
	     else
unknown_attention: phyem = "device attention - unknown substatus";
	end;

	else if major = "0011"b then do;		/* Device Data Alert */
	     if minor = "000001"b then phyem = "transfer timing alert";
	     else if minor = "000010"b then phyem = "blank tape on read";
	     else if substr (minor, 5, 2) = "11"b then phyem = "bit detected during erase";
	     else if mb4 then phyem = "transmission parity alert";
	     else if mb3 then phyem = "lateral tape parity alert";
	     else if mb2 then phyem = "longitudinal tape parity alert";
	     else if mb1 then phyem = "end-of-tape mark";
	     else phyem = "device data alert - unknown substatus";
	end;

	else if major = "0100"b then do;		/* End of File */
	     if minor = "001111"b then phyem = "eof 7 track";
	     else if minor = "010011"b then phyem = "eof 9 track";
	     else if minor = "111111"b then phyem = "data alert";
	     else phyem = "single character record";
	end;

	else if major = "0101"b then do;		/* Command Reject */
	     if minor = "000000"b then phyem = "invalid set density";
	     else if minor = "001000"b then phyem = "backspace while at at BOT";
	     else if minor = "010000"b then phyem = "forward read after write";
	     else if minor = "100000"b then phyem = "9 track command to 7 track handler";
	     else if substr (minor, 1, 3) = "000"b then do;
		if mb6 then phyem = "invalid operation code";
		else if mb5 then phyem = "invalid device code";
		else if mb4 then phyem = "invalid IDCW parity";
		else goto unknown_reject;
	     end;
	     else
unknown_reject: phyem = "command reject - unknown substatus";
	end;

	else if major = "0111"b then phyem = "program load termination"; /* MTS 400s only */

	else if major = "1000"b then phyem = "peripheral subsystem busy"; /* MTS 400s only */

	else if major = "1010"b then do;		/* MPC Device Attention */
	     if minor = "000001"b then phyem = "configuration switch error";
	     else if minor = "000010"b then phyem = "multiple devices with same id";
	     else if minor = "000011"b then phyem = "illegal device id number";
	     else if minor = "001000"b then phyem = "incompatible  PE and NRZI modes";
	     else if minor = "010000"b then phyem = "handler malfunction";
	     else if minor = "010001"b then phyem = "multiple BOT markers";
	     else if substr (minor, 1, 4) = "0011"b then phyem = "TCA malfunction";
	     else phyem = "MPC device attention - unknown substatus";
	end;

	else if major = "1011"b then do;		/* MPC Device Data Alert */
	     if minor = "000001"b then phyem = "transmission parity alert";
	     else if minor = "000010"b then phyem = "inconsistent command";
	     else if minor = "000011"b then phyem = "sum check (sic) error";
	     else if minor = "000100"b then phyem = "byte locked out";
	     else if minor = "001000"b then phyem = "PE-burst write error";
	     else if minor = "001001"b then phyem = "preamble error";
	     else if minor = "100000"b then phyem = "marginal condition";
	     else if minor = "010000"b then phyem = "multi-track error";
	     else if minor = "010001"b then phyem = "skew error";
	     else if minor = "010010"b then phyem = "postamble error";
	     else if minor = "010011"b then phyem = "NRZI correctable error";
	     else if minor = "010100"b then phyem = "code alert";
	     else phyem = "MPC device data alert - unknown substatus";
	end;

	else if major = "1101"b then do;		/* MPC command reject */
	     if minor = "000001"b then phyem = "illegal procedure";
	     else if minor = "000010"b then phyem = "illegal logical channel number";
	     else if minor = "000011"b then phyem = "illegal suspended logical channel number";
	     else if minor = "000100"b then phyem = "IDCW continue bit not set";
	     else phyem = "MPC command reject - unknown substatus";
	end;

	else phyem = "unknown major status";

	return_string = phyem;			/* one assignment to the char (*) return string, to avoid/
						   length-checking code for all the above assignments */
	return;

     end decode_nstd_status_;




		    gcos_card_utility.pl1           09/12/83  1115.2rew 09/12/83  0913.6      393021



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


gcos_card_utility: gcu: proc;

/*
   *  This command copies GCOS card image files, changing their format,
   *  content and medium as specified by the control arguments given.
   *
   *	USAGE: gcu input_specification output_specification
   *
   *  The input and output specifications are composed of pathnames and
   *  control arguments. The list of arguments that can be used is very long,
   *  and is documented in the MPM, so it will not be repeated here.
   *
   *  This procedure only processes the command line. It calls the subroutine
   *  gcos_card_utility_ to do the real work.
*/
%page;
/*
   *	WRITTEN BY T. CASEY	 MAY 1973
   *	MODIFIED BY T. CASEY
   *			 SEPTEMBER 1973
   *			 OCTOBER 1973
   *			 MARCH 1974
   *			 AUGUST 1974
   *			 NOVEMBER 1974
   *			 JULY 1975
   *			 MARCH 1976
   *
   *	MODIFIED BY S. AKERS AUGUST, 1981:
   *				     Fix range errors in suffix checking.
   *				     Make suffix checking more efficient.
   *
   *				     Add "-canonicalize" "-can" "-ncan"
   *				     "-gcos_bcd" "-gcb" control_args.
   *				     Change handling of canonicalization,
   *				     new default is to NOT do it. Ignore
   *				     the "-no" control_arg.
   *
   *				     Changed formfeed to %page;
   *
   *				     Fixed control_arg checker so it
   *				     doesn't generate stringrange errors.
   *  Modified: Ron Barstad      82-09-28  Fixed typo error in label err(68)
   *  Modified: Ron Barstad  2.0 83-02-08  Fix nested if in -tape arg processing
   *                                       Added version in "me", started with 2.0
   * Modified: Ron Barstad  2.1 83-06-09  Allowed conversion to ascii or gcos_ascii
   *                                      from BCD media code 0 to be over 80 chars
   * Modified: Ron Barstad  2.2 83-07-13  Fixed -tape group again, find bad -args >4 chars
   */
%page;
/*  D  E  C  L  A  R  A  T  I  O  N  S     */

/*	 External Entries		*/

dcl  com_err_ ext entry options (variable);
dcl  cu_$arg_count entry (fixed bin, fixed bin(35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  cv_dec_check_ ext entry (char (*), fixed bin(35)) returns (fixed bin);
dcl  db ext entry;
dcl  decode_nstd_status_ ext entry (bit (72) aligned, char (*) varying);
dcl  expand_path_ entry (ptr, fixed bin(21), ptr, ptr, fixed bin(35));
dcl  get_system_free_area_ ext entry returns (ptr);
dcl  gcos_card_utility_ ext entry (ptr, ptr, fixed bin(35));
dcl  hcs_$initiate_count ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(24), fixed bin(2), ptr, fixed bin(35));
dcl  hcs_$terminate_noname ext entry (ptr, fixed bin(35));
dcl (ioa_, ioa_$nnl) ext entry options (variable);
dcl  ios_$attach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);
dcl  ios_$detach ext entry
    (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned);

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

/*	Builtin	*/

dcl (addr, baseno, divide, length,
     max, null, substr, index, reverse, rtrim, unspec)	builtin;

dcl  cleanup condition;

/*	 For argument processing	*/

dcl  ap ptr;
dcl  al fixed bin(21);
dcl  arg char (al) based (ap);
dcl (nargs, argno) fixed bin;

dcl (i, j, k, l, m, n) fixed bin(24);
dcl (starting_line_no, ending_line_no, no_of_lines) fixed bin(24)init (0);

dcl  status bit (72) aligned;
dcl  code fixed bin(35) aligned based (addr (status));
dcl  numeric_arg fixed bin(24);
dcl  tab_index fixed bin(24)init (0);

dcl  expected_arg fixed bin(24)init (0);

/* For program readability, we assign names to the numeric values
   that the multi-valued switch - expected_arg - can have */

dcl (						/* names in alphabetic order */
     first_line init (31)
     , last_line init (32)
     , line_count init (33)
     , list init (34)
     , list_file init (35)
     , tabs init (36)
     , tape_id init (37)
     , tape_label init (38)
     ) fixed bin(24)int static;

dcl (						/* switches init off */
     io_spec_given (2),				/* on when input or output spec is completed */
     io_source_given (2),				/* on after a tape or file name has been given */
     list_finished (2)				/* on when a list has been given - only one is allowed */
     ) bit (1) aligned init ((2) (1) "0"b);

dcl (
     fixed_in_db
     , list_started					/* on while reading list elements from arg list */
     , verify_suffix				/* on if we must check for consistent suffixes
						   in a list of pathnames */
     , detach_tapes					/* on if only detaching tapes left attached
						   from previous use of this command */
     , normal_termination				/* distinguish cleanup condition from normal termination */
     ) bit (1) aligned init ("0"b);

dcl  me char (23) aligned int static options (constant) init ("gcos_card_utility (2.2)");

dcl  dirname char (168) aligned;
dcl  ename char (32) aligned;
dcl  bitcount fixed bin(24);
dcl  segptr ptr init (null);
dcl  seglen fixed bin(24);
dcl  seg_olay char (seglen) based (segptr);

dcl  rw char (1) aligned;						/* "r" or " " (rw) for tape attachments */

dcl  newline char (1) unaligned int static init ("
");

dcl  word_string_len fixed bin(24)init (1);
dcl  word_string (word_string_len) bit (36) aligned based;
dcl (numeric, control) bit (1) init ("0"b);

dcl  free_ptr ptr based (free_ptr_ptr);						/* used in cleanup_proc to free allocated storage */
dcl  free_ptr_ptr ptr;						/* this is NOT a typing error */

dcl  system_free_ptr ptr init (get_system_free_area_ ());
dcl  system_free_area area based (system_free_ptr);

/*	For calling gcos_card_utility_	*/

dcl 1 input_structure_area like input automatic;						/* place to put input structure */
dcl 1 output_structure_area like output automatic;						/* place to put output structure */


%include gcos_utility_args_;
%page;
/*  P  R  O  C  E  D  U  R  E     */

	call cu_$arg_count (nargs,code);
	if nargs = 0 then do;
	     code = error_table_$noarg;
	     call com_err_ (code, me,
		"^/Usage: gcu input_specification output_specification");
	     return;
	end;

/*  Initialize */

	input_ptr = addr (input_structure_area);
	output_ptr = addr (output_structure_area);
	unspec (input) = ""b;			/* zero out the structures */
	unspec (output) = ""b;			/* to avoid problems with garbage */

	input.list_ptr, input.tape_ptr = null;		/* don't want zeros there, though */
	output.list_ptr, output.tape_ptr = null;
	input.sw = input_code;
	output.sw = output_code;

	input.com_err = "1"b;			/* tell gcos_card_utility_ subroutine to
						   call com_err_ if any errors occur */

	io_ptr = input_ptr;				/* start with input spec unless user says -output */
	input.no_canon = "1"b;			/* Default is no canonicalization */

	on condition (cleanup) call cleanup_proc;


arg_loop:	do argno = 1 to nargs;

	     call cu_$arg_ptr (argno, ap, al, code);
	     if code ^= 0 then call arg_error (2);

	     numeric_arg = cv_dec_check_ (arg, code);	/* see if it's a numeric arg */
	     if code = 0 then numeric = "1"b;
	     else numeric = "0"b;
	     code = 0;				/* to avoid confusion if errors later */

	     if substr (arg, 1, 1) = "-" then control = "1"b; /* see if it's a control arg */
	     else control = "0"b;

	     if expected_arg ^= 0 then		/* if we are expecting anything specific */
interpret_expected_arg: do;

/* In alphabetic order by name */

		if expected_arg = first_line then do;
		     if ^numeric then call arg_error (3); /* numeric arg missing */
		     starting_line_no = numeric_arg;
		     expected_arg = 0;
		end;

		else if expected_arg = last_line then do;
		     if ^numeric then call arg_error (4); /* expected numeric arg missing */
		     ending_line_no = numeric_arg;
		     expected_arg = 0;
		end;

		else if expected_arg = line_count then do;
		     if ^numeric then call arg_error (5); /* numeric arg missing */
		     no_of_lines = numeric_arg;
		     expected_arg = 0;
		end;

		else if expected_arg = list then do;
		     if list_started then do;		/* if not first time */
			if control then do;		/* control arg signals end of list */
			     expected_arg = 0;	/* back to looking for ctl args */
			     list_finished (io.sw) = "1"b; /* remember that list was read */
			     goto interpret_control_arg; /* go process this arg */
			end;

			if al > io.list_name_size then call arg_error (6); /* name too long */
			io.list_count = io.list_count + 1; /* bump count */

			if io.set = multiple_files	/* if pathname */
			then do;
			     io_list (io.list_count).names = get_io_pathname (arg);
			     call check_suffix (arg);
			     end;
			else io_list (io.list_count).names = arg; /* else snumb or edit name */

		     end;

		     else do;			/* first argument in list - it could be the first name,
						   or one of -all, -name, or -file_input */
			if control then do;
			     if arg = "-fi" | arg = "-file" | arg = "-file_input" then
				expected_arg = list_file; /* next arg will be pathname */
			     else if arg = "-all" then do;
				if io.sw = output_code then
				     call arg_error (7); /* -all only allowed in input list */
				if input.set = multiple_files then
				     call arg_error (8); /* -all only allowed after -gmap ot -library or -imcv */
				input.all = "1"b;
				input.list_count = 99999; /* arbitrary large number */
				expected_arg = 0;
			     end;
			     else if arg = "-nm" | arg = "-name" | arg = "-names" then do;
				if io.sw = input_code then
				     call arg_error (9); /* -name only allowed in output list */
				output.name_files = "1"b;
				output.list_count = 99999; /* arbitrary large number */
				expected_arg = 0;
			     end;
			     else call arg_error (10); /* expected arg missing */
			end;

			else do;			/* allocate and initialize list */
			     if al > io.list_name_size then call arg_error (11); /* name too long */
			     list_started = "1"b;
			     io.list_count = nargs - argno + 1; /* max list length is rest of args */
			     allocate io_list in (system_free_area) set (io.list_ptr);
			     unspec (io_list) = ""b;	/* clear it */
			     io.list_count = 1;
			     io_list (1).names = arg; /* save first item in list */
			end;			/* end alloc and init list */
		     end;				/* end first time */
		end;				/* end expecting list item */

		else if expected_arg = list_file then do;

		     expected_arg = 0;		/* turn off the expected switch */

		     call expand_path_ (addr (arg), al, addr (dirname), addr (ename), code);
		     if code ^= 0 then call arg_error (12); /* from a file system call */
		     call hcs_$initiate_count (dirname, ename, "", bitcount, 0, segptr, code);
		     if segptr = null then call arg_error (13); /* from a file system call */
		     code = 0;			/* clear possble error_table_$segknown,
						   to avoid confusion if a real error occurs later */

		     seglen = divide (bitcount, 9, 17, 0);
		     k = 0;			/* counter for newlines */
		     n = 1;			/* start with first char */
		     l = seglen;			/* have whole seg left to search */

		     do while (l > 0);		/* search whole seg */
			m = index (substr (seg_olay, n, l), newline); /* for newlines */
			if m ^= 0 then do;		/* if we found one */
			     if m > 1 then		/* don't blow up on blank lines */
				k = k + 1;	/* count newlines (actually counting names) */
			     if m > io.list_name_size + 1 then call arg_error (14); /* name too long */
			     l = l - m;		/* shorten string yet to be searched */
			     n = n + m;		/* move past this newline */
			end;
			else l = 0;		/* no newline at end - but end of segment anyway */
		     end;				/* end of name counting loop */

		     io.list_count = k;		/* actual length of list */
		     allocate io_list in (system_free_area) set (io.list_ptr); /* allocate storage for list */
		     unspec (io_list) = ""b;		/* clear it */

		     l = seglen;			/* re init length of string to be processed */
		     n = 1;			/* and starting char of the string */
		     do k = 1 to io.list_count;	/* copy names from seg to structure */
indx:			m = index (substr (seg_olay, n, l), newline);
			if m > 1 then do;		/* check for blank lines */
			     if io.set = multiple_files	/* if pathname */
			     then do;
				io_list (k).names = get_io_pathname (substr (seg_olay, n, m-1));
				call check_suffix (substr (seg_olay, n, m-1));
				end;
			     else			/* else must be snumb or edit name */
			     io_list (k).names = substr (seg_olay, n, m-1); /* name, less the newline */
			end;
			n = n + m;		/* move past name */
			l = l - m;		/* shorten the string */
			if m = 1 then goto indx;	/* dont increment k if it was a blank line */
		     end;
		     list_finished (io.sw) = "1"b;	/* remember that we already have the list */
		     call hcs_$terminate_noname (segptr, code);
		     if code ^= 0 then
			call arg_error (67);	/* OUT OF ORDER - ADDED LATER */
		end;				/* end of expecting list file do group */

		else if expected_arg = tabs then do;

		     if ^numeric then do;		/* can't be a tabstop if not numeric */
			if tab_index = 0 then
			     call arg_error (15);	/* tabstop arguments missing */
			else do;			/* end of tabstop list is signified by any non numeric arg */
			     expected_arg = 0;
			     if control then
				goto interpret_control_arg;
			     else goto interpret_path;
			end;
		     end;				/* end of non numeric do group */

		     else do;			/* it was numeric - see if it is a legal tabstop */
			if numeric_arg < 2
			| numeric_arg > 80 then
			     call arg_error (16);	/* tabstop can't be before col 2 or past col 80 */
			if tab_index > 0 then	/* if not first tabstop */
			     if numeric_arg ^> input.tabstops (tab_index) then /* it must be > previous one */
				call arg_error (17); /* tabstops not in increasing numeric order */

			tab_index = tab_index + 1;
			if tab_index > 10 then
			     call arg_error (18);	/* only 10 tabstops allowed */
			input.tabstops (tab_index) = numeric_arg;
		     end;				/* end of numeric arg do group */
		end;				/* end of expecting tabstops do group */

		else if expected_arg = tape_id then do;
		     if al > 32 then call arg_error (19); /* tape id too long */
		     io_tape.id = arg;
		     if control then
			if arg = "-att" | arg = "-attached" then
			     io_tape.attached = "1"b;
		     expected_arg = 0;
		end;

		else if expected_arg = tape_label then do;
		     expected_arg = 0;
		     if numeric then		/* check for easiest case first */
			io_tape.position = numeric_arg;
		     else do;			/* check for label or n,label or label,n */
			i = index (arg, ",");	/* look for comma */
			if i = 0 then do;		/* no comma - all label */
			     m = 1;		/* set up substr parameters to pick up whole arg */
			     n = al;
			     goto check_label;	/* and go see if its an ok label */
			end;
						/* set up substring parameters */
			k = 1;l = i-1;		/* part before comma */
			m = i+1;n = al-i;		/* part after comma */
			j = index (substr (arg, m, n), ","); /* look for extra comma */
			if j ^= 0 then
			     call arg_error (20);	/* bad tape label format - 2 commas */
cv_dec_label:		j = cv_dec_check_ (substr (arg, k, l), code);
			if code ^= 0 then do;
			     code = 0;		/* not an error_table_ code - clear it */
			     if m = 1 then		/* if we already switched */
				call arg_error (21); /* bad tape label format - comma but no numeric field */
			     else do;		/* switch fields */
				k = m;l = n;	/* maybe the second part is numeric */
				m = 1;n = i-1;	/* and the first is the label */
				goto cv_dec_label;	/* go try to convert it */
			     end;			/* end switch fields */
			end;			/* end code = 0 */
			io_tape.position = j;	/* save position */
check_label:		if n > 12 then
			     call arg_error (22);	/* bad tape label format - label > 12 chars */
			io_tape.label = substr (arg, m, n);
		     end;				/* end of check for label or n,label do group */
		end;				/* end of expecting label do group */


		else				/* expected arg has bad value */
		call arg_error (-1);		/* -1 means "program bug" */

	     end interpret_expected_arg;


	     else if control then			/* not expecting anything */
interpret_control_arg: do;				/* if control arg, see what it is */

/* In alphabetic order by the long spelling of the argument */

/* -all only allowed in a list; checked for after all legal args, below */

		if arg = "-app" | arg = "-append" then do;
		     if io.sw = input_code then call arg_error (23); /* -append legal only for output */
		     output.append = "1"b;
		end;

		else if arg = "-aci" | arg = "-ascii" then do;
		     if io.format ^= 0 then
			if io.format ^= ascii then
			     call arg_error (24);	/* inconsistent format spec */
		     io.format = ascii;
		     if io.medium ^= 0 then		/* DON'T THINK THIS CAN EVER HAPPEN - */
			if io.medium ^= file then	/* BUT LET'S BE SAFE */
			     call arg_error (25);	/* inconsistent medium spec */
		     io.medium = file;
		end;

		else if arg = "-att" | arg = "-attached" then do;
		     if io.medium ^= tape then
			call arg_error (50);	/* OUT OF ORDER - MESSAGE CHANGED */
		     io_tape.attached = "1"b;
		end;

		else if arg = "-bf" | arg = "-brief" then
		     io.brief = "1"b;

		else if arg = "-cdk" | arg = "-comdk" then do;
		     io.comdk = "1"b;
		     if io.format ^= 0 then
			if io.format ^= gcos then
			     call arg_error (26);	/* inconsistent format spec */
		     io.format = gcos;
		end;

		else if arg = "-ct" | arg = "-count" then do;
		     if io.sw = output_code then call arg_error (27); /* not allowed for output */
		     if no_of_lines ^= 0 | ending_line_no ^= 0 then /* if that info already given */
			call arg_error (28);	/* inconsistent args */
		     expected_arg = line_count;
		end;

		else if arg = "-db" | arg = "-debug" then
		     input.debug = "1"b;

		else if arg = "-det" | arg = "-detach" then do;
		     if argno = nargs then		/* check for special case */
			if argno = 1		/* -detach the only argument */
			| (argno = 2 & input.debug) then /* or just preceeded by -debug */
			     detach_tapes = "1"b;	/* if so detach tapes and quit */
detach_tape:
		     call ios_$detach (tape_stream (io.sw), "", "", status);
		     if code ^= 0 then
			if code ^= error_table_$ioname_not_found then
			     call arg_error (29);	/* error detaching tape */
		     if detach_tapes then do;		/* if detaching both tapes */
			if io.sw = input_code then do;
			     io_ptr = output_ptr;
			     goto detach_tape;
			end;
			else return;		/* all done - just called to detach tapes */
		     end;				/* end of just detaching do group */
		end;				/* end of -detach do group */

/* -file_input only allowed in a list; checked for after all legal args, below */

		else if arg = "-ft" | arg = "-first" then do;
		     if io.sw = output_code then call arg_error (30); /* not legal for output */
		     if starting_line_no ^= 0 then call arg_error (31);
		     expected_arg = first_line;
		end;

		else if arg = "-gc" | arg = "-gcos" then do;
gcos_arg:		     if io.format ^= 0 then
			if io.format ^= gcos then
			     call arg_error (32);	/* inconsistent format spec */
		     io.format = gcos;
		end;

		else if arg = "-gca" | arg = "-gcos_ascii" then do;
		     if io.sw = input_code then call arg_error (72); /* OUT OF ORDER - ADDED LATER */
		     output.gcos_ascii = "1"b;
		     goto gcos_arg;
		end;

		else if arg = "-gcb" | arg = "-gcos_bcd" then do;
		     if io.sw = input_code then call arg_error (72); /* OUT OF ORDER - ADDED LATER */
		     output.gcos_bcd = "1"b;
		     goto gcos_arg;
		end;

		else if arg = "-gmap" | arg = "-lib" | arg = "-library" then do;
		     input.set = library;
		     input.list_name_size = 4;	/* library edit names are 4 chars */
set_up_for_list:					/* come here from -imcv to finish setting up for list */
		     if io.sw = output_code then call arg_error (33);
		     if list_finished (io.sw) then call arg_error (34); /* already given */
		     expected_arg = list;
		     list_started = "0"b;		/* we want to special-case the first list element */
		end;

		else if arg = "-imcv" then do;
		     input.set = imcv;
		     input.list_name_size = 5;	/* snumbs are 5 chars max */
		     goto set_up_for_list;		/* go share code with -library */
		end;

		else if arg = "-in" | arg = "-input" then do;
		     if argno > 1 then		/* except for first argument, when io.sw is
						   initialized to the default (input_code) */
			if argno ^= 2 | ^input.debug then /* (or if first arg was -db and this is the 2nd) */
			     io_spec_given (io.sw) = "1"b; /* remember that input or output (io.sw says which)
						   specs have already been given */
		     if io_spec_given (input_code) then /* if input specs have already been given */
			call arg_error (35);	/* do not allow them to be given again */
		     io_ptr = input_ptr;		/* switch to processing the input specification */
		end;

		else if arg = "-lbl" | arg = "-label" then do;
		     if io.medium ^= tape then
			call arg_error (36);	/* -tape must preceed -retain or -label */
		     expected_arg = tape_label;
		end;

/* -library is a generalization of -gmap, and is processed above, with -gmap */

		else if arg = "-lt" | arg = "-last" then do;
		     if io.sw = output_code then call arg_error (37); /* not allowed for output */
		     if no_of_lines ^= 0 | ending_line_no ^= 0 then /* if that info already given */
			call arg_error (38);	/* inconsistent args */
		     expected_arg = last_line;
		end;

		else if arg = "-ls" | arg = "-list" then do;
		     if io_source_given (io.sw) then
			call arg_error (39);	/* can't say -list if -tape or pathname already given */
		     io_source_given (io.sw) = "1"b;
		     if list_finished (io.sw) then
			call arg_error (40);	/* only one list allowed */
		     list_started = "0"b;		/* so we can special case the first list item */
		     expected_arg = list;
		     io.list_name_size = 168;		/* max length of pathname */
		     io.set = multiple_files;
		     if io.medium ^= raw then
			io.medium = file;
		     if io.format ^= 0 then		/* if format already given */
			verify_suffix = "0"b;	/* ignore suffixes */
		     else verify_suffix = "1"b;	/* otherwise first suffix determines format,
						   and the rest must be consistent with it */
		end;

		else if arg = "-lg" | arg = "-long" then
		     io.long = "1"b;

		else if arg = "-no" | arg = "-no_canonicalize"
		      | arg = "-ncan"
		     then do;
			if io.sw = output_code then call arg_error (41); /* legal only for input */
			input.no_canon = "1"b;
			end;

		else if arg = "-can" | arg = "-canonicalize"
		     then do;
			if io.sw = output_code then call arg_error (41); /* legal only for input */
			input.no_canon = "0"b;
			end;

/* -name only allowed in a list; checked for after all legal args, below */

		else if arg = "-out" | arg = "-output" then do;
		     if argno > 1 then
			if argno ^= 2 | ^input.debug then
			     io_spec_given (io.sw) = "1"b; /* same logic as for input */
		     if io_spec_given (output_code) then call arg_error (42);
		     io_ptr = output_ptr;		/* switch to processing output specification */
		end;

		else if arg = "-raw" then do;
		     if io.medium = tape then
			call arg_error (43);	/* inconsistent medium spec */
		     io.medium = raw;
		     if io.format ^= 0 then
			if io.format ^= gcos then
			     call arg_error (44);	/* inconsistent format spec */
		     io.format = gcos;
		end;

		else if arg = "-ret" | arg = "-retain" then do;
		     if io.medium ^= tape then
			call arg_error (45);	/* -tape must preceed -retain or -label */
		     io_tape.retain = "1"b;
		end;

		else if arg = "-tabs" then do;
		     if io.sw = output_code then
			call arg_error (66);	/* OUT OF ORDER - ADDED LATER */
		     if input.tabs_given then
			call arg_error (46);	/* can't give tabs twice */
		     input.tabs_given = "1"b;
		     expected_arg = tabs;
		end;

		else if (arg = "-tape") | (arg = "-tape7") | (arg = "-tape9") then do;
		     if io_source_given (io.sw) then
			call arg_error (47);	/* can't say -tape after giving file name */
		     io_source_given (io.sw) = "1"b;
		     if io.medium ^= 0 then		/* possible -raw -tape */
			call arg_error (69);	/* OUT OF ORDER - ADDED LATER */
		     io.medium = tape;
		     if io.format ^= 0 then
			if io.format ^= gcos then
			     call arg_error (48);	/* inconsistent format spec */
		     io.format = gcos;		/* can only be gcos files on tape */
		     allocate io_tape in (system_free_area) set (io.tape_ptr);
		     unspec (io_tape) = ""b;		/* clear it */
		     io_tape.label = "";		/* want blanks (not zeros) in label field */
		     if al > 5 then do;		/* see if a 7 or 9 on the end */
			io_tape.tracks = substr (arg, 6, 1);
			if (io_tape.tracks ^= "7"
			& io_tape.tracks ^= "9")
			|al ^= 6
			then call arg_error (49);
		     end;
		     else io_tape.tracks = " ";
		     expected_arg = tape_id;
		end;				/* end of -tape do group */

		else if arg = "-tc" | arg = "-tnc" | arg = "-truncate" then
		     io.truncate_ascii = "1"b;


/* The following control arguments are only allowed in place of some expected
   argument, and their occurrence out of context is an error */

		else if arg = "-fi" | arg = "-file" | arg = "-file_input"
		| arg = "-all" | arg = "-nm" | arg = "-name" then
		     call arg_error (51);		/* only allowed in place of a list */

		else				/* bad control arg */
		call arg_error (52);

	     end interpret_control_arg;


/* interpret non-control arg - i.e. pathname not preceeded by ctl arg */

	     else
interpret_path: do;

check_if_given:	if io_source_given (io.sw) then	/* if a pathname or tape number was already given */
switch_io:	     do;				/* for the current spec, switch to the other one */
						/* if -in and -out not given, the default is -in, then -out, with
						   the switch being made when the second pathname is found */
		     if io.sw = input_code then
			io_ptr = output_ptr;
		     else call arg_error (53);
		     goto check_if_given;		/* in case both have been given */
		end switch_io;

		io.set = single_file;
		if io.medium ^= raw then		/* unless -raw preceeded this */
		     io.medium = file;
		io_source_given (io.sw) = "1"b;

		io.file_name = get_io_pathname (arg);	/* expand the pathname */
		call check_suffix (arg);		/* validate the suffix, if there is one */

	     end interpret_path;

	end arg_loop;

/* Check input and output specification for completeness and consistency */

	if expected_arg ^= 0 then do;			/* still expecting an argument? */
	     if list_started then			/* were we in a list, with first item already given? */
		list_finished (io.sw) = "1"b;		/* it's ok for arg list to end in a list */
	     else if expected_arg ^= tabs then		/* also ok to end with list of tabstops */
		call arg_error (54);		/* expected arg missing after last arg on line */
	end;

/* check io stuff */
	do io_ptr = input_ptr, output_ptr;

	     if io.format = 0 then
		io.format = ascii;			/* the default */

	     if io.set = 0 then
		io.set = single_file;		/* if no list was given, this is still zero */

	     if ^io_source_given (io.sw) then
		call arg_error (55);		/* io spec incomplete - must give tape or file name */

	     if io.format ^= ascii then
		if io.truncate_ascii then
		     call arg_error (56);		/* -truncate only allowed for ascii */

/* check input-only stuff */

	     if io.sw = input_code
	     then do;

		input.first_line = starting_line_no;	/* will be zero if -ft not given */
		if no_of_lines ^= 0			/* if -ct given */
		then input.last_line = max (input.first_line, 1) + no_of_lines -1; /* then compute last line no */
		else input.last_line = ending_line_no;	/* will be zero if -lt not given */

		end;

/* check output-only stuff */
	     if io.sw = output_code
	     then do;
		if output.append
		then if output.medium = tape
		     then call arg_error (58);	/* can not append to a tape file */
		if output.name_files 
		then if input.set ^= library 
		     then if input.set ^= imcv
			then call arg_error (70);	/* OUT OF ORDER - ADDED LATER */
		end;
	end;

/* Check for tape to disk copy, to avoid deblocking if possible */

	do io_ptr = input_ptr, output_ptr;
	     if io.format ^= gcos then goto not_blocks;
	     if io.comdk then goto not_blocks;
	     if io.medium = raw then goto not_blocks;
	     if io.set ^= single_file then goto not_blocks;
	end;
	if output.append 		then goto not_blocks;
	if output.gcos_ascii 	then goto not_blocks;
	if output.gcos_bcd 		then goto not_blocks;
	if input.first_line  ^= 0 	then goto not_blocks;
	if input.last_line   ^= 0 	then goto not_blocks;

	input.format, output.format = blocks;		/* We can copy without deblocking */

not_blocks:


/* Attach tapes here to minimize mounting and dismounting */

	do io_ptr = input_ptr, output_ptr;
	     if io.sw = input_code then
		rw = "r";				/* attach input tape in read-only mode */
	     else rw = " ";				/* equivalent to "rw" for ios_$attach */
	     if io.medium = tape then
		if ^io_tape.attached then do;

/* ***** NOTE *****
   The method of specifying tracks and density is undergoing some changes
   (July 1975). The validity of this code must be reviewed periodically. */
		     if io_tape.tracks ^= " " then do;	/* if tracks given by -tape7 or -tape9 */
			i = index (io_tape.id, " ");	/* find end of tape name and append ",Ntrack" */
			if substr (io_tape.id, i-5, 5) ^= "track" then /* but make sure it's not there already */
			     if i <= 26 then	/* and there's room to put it there */
				substr (io_tape.id, i, 7) = "," || io_tape.tracks || "track";
		     end;
		     io_tape.attached = "1"b;		/* for cleanup_proc; turn on BEFORE calling attach */
		     call ios_$attach (tape_stream (io.sw), "nstd_", io_tape.id, rw, status);
		     if code ^= 0 then
			call arg_error (59);	/* error attaching tape */
		end;				/* end tape and not attached do group */
	end;					/* end attach tapes do loop */

/* now call subroutine to do the real work */
	call gcos_card_utility_ (input_ptr, output_ptr, code);
	if code ^= 0 then
	     if ^input.com_err then			/* if subroutine did not call com_err_ */
		call com_err_ (code, me);

	revert cleanup;

	normal_termination = "1"b;			/* tell cleanup_proc that this is not cleanup condition */
	call cleanup_proc;				/* used for cleanup and normal termination */
quit:	return;
%page;
/*  I  N  T  E  R  N  A  L     P  R  O  C  E  D  U  R  E  S     */


/* Procedure to format and print error messages */

arg_error: proc (error_code);

dcl  error_code fixed bin(24);			/* identifies the place where the error occurred.  Each call
						   has a different number, even if the message is the same.
						   The first 64 are in order in the program. Those above 64
						   were added later and are out of order. */

dcl  max_error_code fixed bin(24)init (71);		/* next available error_code value is 72 */

dcl  bad_arg char (168) varying;			/* the bad argument or pathname */
dcl (err_msg, msg2) char (200) varying;			/* portions of message text */

dcl  mnames (11:20) char (8) aligned int static init (
     "filename",
     "snumb",
     "editname",
     "filename",
     "ascii",
     "gcos",
     "blocks",
     "raw",
     "tape",
     "file");


	     bad_arg = arg;				/* the bad thing is the current argument */
	     goto arg_error_common;

/* Entry called from get_io_pathname - second argument is the bad pathname */
path_error:    entry (error_code, err_path);

dcl  err_path char (*);						/* might be from a file instead of an argument */

	     bad_arg = err_path;			/* argment or file item to be printed */

arg_error_common:

	     if error_code < 2 | error_code > max_error_code then do;
		err_msg = "Program bug. ^a";
		goto call_com_err;
	     end;

/* Use error_code as an index into a transfer vector that the compiler
   will build for us. This is implemented efficiently in the v2pl1 compiler */

	     goto err (error_code);

/* Since we checked the upper and lower bound of error code above, no problems can arise */

err (2):
	     err_msg = "^a From cu_$arg_ptr.";
	     goto call_com_err;

err (3): err (4): err (5):
	     err_msg = "Numeric, before ^a";
	     goto et_noarg;				/* go set code = error_table_$noarg */

err (6): err (11):
	     err_msg = "Name in list is too long: ^a^/Max length of ^a is ^d.";
	     msg2 = mnames (io.set);
	     numeric_arg = io.list_name_size;
	     goto call_com_err;

err (7): err (27): err (30): err (33): err (37): err (41): err (66):
	     err_msg = "This argument is only allowed in the input specification: ^a";
	     goto call_com_err;

err (8):
	     err_msg = "-all only allowed immediately following -gmap, -library, or -imcv";
	     goto call_com_err;

err (9): err (23): err (72):
	     err_msg = "This argument is only allowed in the output specification: ^a";
	     goto call_com_err;

err (10):
	     err_msg = "list item, before ^a";
	     goto et_noarg;

err (12): err (60):
	     err_msg = "From expand_path_ ^a";
	     goto call_com_err;

err (13):
	     err_msg = "From hcs_$initiate_count ^a";
	     goto call_com_err;

err (14):
	     bad_arg = substr (seg_olay, n, m-1);	/* pick up bad name from file */
	     goto err (6);				/* and go set up the "too long" message */

err (15):
	     err_msg = "Tabstops, before ^a";
	     goto et_noarg;

err (16):
	     err_msg = "Illegal tabstop value: ^a^/Value must be 2 thru 80.";
	     goto call_com_err;

err (17):
	     err_msg = "Tabstop value out of order: ^a^/Previous value was ^s^d";
	     numeric_arg = input.tabstops (tab_index);
	     goto call_com_err;

err (18):
	     err_msg = "Only 10 tabstops allowed: ^a is the 11th.";
	     goto call_com_err;

err (19):
	     err_msg = "Tape number too long: ^a^/Max length is 32 characters.";
	     goto call_com_err;

err (20):
	     err_msg = "Bad tape label format - 2 commas: ^a";
	     goto call_com_err;

err (21):
	     err_msg = "Bad tape label format - comma but no numeric field: ^a";
	     goto call_com_err;

err (22):
	     err_msg = "Bad tape label format - file name too long: ^a^/Max length is 12 characters.";
	     bad_arg = substr (bad_arg, m, n);
	     goto call_com_err;

err (24): err (26): err (32): err (44): err (48): err (61): err (62): err (63): err (64):
	     msg2 = mnames (io.format);
	     goto inconsistent_message;		/* go set err_msg and error_table_$inconsistent */

err (25): err (43): err (69):
	     msg2 = mnames (io.medium);
	     goto inconsistent_message;

err (28): err (31): err (38):
	     err_msg = "^a and the previously specified -first, -last, or -count.";
	     goto et_inconsistent;

err (29):
	     err_msg = "From ios_$detach the previously retained tape.";
	     goto tape_message;			/* check for and decode tape hardware status */

err (34): err (40):
	     err_msg = "Only one list is allowed in the input or output specification: ^a";
	     goto call_com_err;

err (35):
	     msg2 = "the input specification";
	     goto given_message;

err (36): err (45):
	     err_msg = "-tape must preceed ^a";
	     goto call_com_err;

err (39): err (47):
	     msg2 = "a pathname or tape number";
	     goto given_message;

err (42): err (53):
	     msg2 = "the output specification";
	     goto given_message;

err (46):
	     msg2 = "a set of tabstops";
	     goto given_message;

err (49):
	     err_msg = "Illegal form of -tape argument: ^a";
	     goto call_com_err;

err (50):
	     err_msg = "^a only allowed after -tape, in place of, or in addition to, tape number";
	     goto call_com_err;

err (51):
	     err_msg = "^a only allowed in place of a list.";
	     goto call_com_err;

err (52):
	     code = error_table_$badopt;
	     err_msg = "^a";
	     goto call_com_err;

err (54):
	     err_msg = "After ^a";
	     goto et_noarg;

err (55):
	     err_msg = "^a pathname or tape number";
	     bad_arg = io_names (io.sw);
	     goto et_noarg;

err (56):
	     err_msg = "-truncate only allowed for an ASCII file";
	     goto call_com_err;

err (57):
	     err_msg = "-no_canonicalize only allowed for an ASCII file.";
	     goto call_com_err;

err (58):
	     err_msg = "-append is not allowed for a tape output file.";
	     goto call_com_err;

err (59):
	     err_msg = "from ios_$attach ^a";
	     goto tape_id_message;

err (65):
	     err_msg = "From ios_$detach ^a";
	     goto tape_id_message;

err (67): err (68):
	     err_msg = "From hcs_$terminate_noname ^a";
	     goto call_com_err;

err (70):
	     err_msg = "-name only allowed when input is gmap, library, or imcv.";
	     goto call_com_err;

/* Set up error codes and messages common to several of the above */

et_noarg:
	     code = error_table_$noarg;
	     goto call_com_err;

inconsistent_message:
	     err_msg = "^/^a and ^a (previously specified or implied).";
et_inconsistent:
	     code = error_table_$inconsistent;
	     goto call_com_err;

given_message:
	     err_msg = "^a is an error because ^a was previously given.";
	     goto call_com_err;

tape_id_message:
	     bad_arg = io_tape.id;
tape_message:
	     if substr (status, 1, 1) then do;		/* hardware status */
		msg2 = bad_arg;			/* save the tape id */
		call decode_nstd_status_ (status, bad_arg);
		err_msg = "^a^/" || err_msg;		/* print decoded status before rest of message */
	     end;
	     goto call_com_err;

call_com_err:  call com_err_ (code, me, err_msg, bad_arg, msg2, numeric_arg);

	     if argno <= nargs then			/* if not past end of arglist */
		call ioa_$nnl ("Argument number ^d.  ", argno);
	     if nargs > 0 then
		call ioa_ ("^a specification.", io_names (io.sw));


	     if input.debug then do;
		call ioa_ ("arg error number ^d", error_code);
		call ioa_ ("CALLING DB");
		call db;
	     end;

	     if ^fixed_in_db then do;
		normal_termination = ^normal_termination; /* by flipping the switch instead of turning it on,
						   we avoid an infinite loop in the case where cleanup_proc
						   gets an error detaching tape, and if the switch is on,
						   it calls us back again to print an error message */
		call cleanup_proc;			/* detach tapes and free allocated storage */
		goto quit;
	     end;

	     fixed_in_db = "0"b;			/* turn off switch for next time */
	     return;
	end arg_error;

%page;
check_suffix: proc (given_path);

/*

	This  procedure  checks  the  suffix (if any) in the pathname, and
	complains  to  the  user  if the suffix does not match the control
	arguments  which  were specified.  If the suffix is acceptable, it
	is used to provide gcos_card_utility_ with the data type contained
	in the file.

*/

dcl  given_path			char (*)		parm;
dcl  suffix_string			char (32) varying;

     call get_suffix (given_path, suffix_string);
     if   length (suffix_string) ^= 0		/* only if suffix exists */
     then do;
	if io.format = 0			/* If format not given, get it from suffix. */
	then do;

	     if suffix_string = ".ascii" then io.format = ascii;
	     else if suffix_string = ".gcos" then io.format = gcos;
	     else if suffix_string = ".raw"
		then do;
		     io.format = gcos;
		     io.medium = raw;
		     end;
	     else if suffix_string = ".comdk"
		then do;
		     io.format = gcos;
		     io.comdk = "1"b;
		     end;

	     if io.medium = 0 then io.medium = file;	/* If not raw or tape, then file. */

	     end;

	else if verify_suffix
	     then do;		/* check for consistent suffixes within a list */
		if suffix_string = ".ascii"
		then do;
		     if io.format ^= ascii
		     then call path_error (61, given_path); /* inconsistent suffixes */
		     end;
		else if suffix_string = ".gcos"
		     then do;
			if io.format ^= gcos 
			then call path_error (62, given_path); /* inconsistent suffixes */
			end;
		else if suffix_string = ".raw"
		     then do;
			if io.format ^= gcos | io.medium ^= raw
			then call path_error (63, given_path); /* inconsistent suffixes */
			end;
		else if suffix_string = ".comdk"
		     then do;
						/* comdk is not inconsistent with gcos -
						   but if it was not the first suffix given,
						   then the gcos suffix determines the format */
			if io.format ^= gcos
			     then call path_error (64, given_path); /* inconsistent suffixes */
			end;
		end;				/* end of verify suffix do group */
	end;				/* end of suffix-checker */
	return;
     end check_suffix;
%page;
/* Procedure to detach tapes and free allocated storage.
   Called on cleanup condition, and also for normal termination.
   The switch, normal_termination, tells us which it is. */

cleanup_proc: proc;

/* Detach tapes (unless user said -retain) */

	     do io_ptr = input_ptr, output_ptr;
		if io.tape_ptr ^= null then do;	/* there is a tape */
		     if io_tape.retain then do;	/* but user said retain */
			if io_tape.attached then	/* if the tape is really attached */
			     if ^io.brief then	/* and user did not say -brief */
				call com_err_ (0, me, "Tape ^a will remain attached.", io_tape.id);
		     end;				/* end retain */
		     else do;			/* detach it */
			if io_tape.attached then do;	/* only if it is already attached */
			     call ios_$detach (tape_stream (io.sw), "", "", status);
			     if code ^= 0 then do;
				if normal_termination then /* avoid infinite loop */
				     call arg_error (65); /* OUT OF ORDER - ADDED LATER */
			     end;			/* end code ^= 0 */
			end;			/* end attached */
		     end;				/* end ^retain */
		end;				/* end io.tape_ptr ^= null */
	     end;					/* end detach tapes do loop */


/* Free allocated storage */
	     do free_ptr_ptr =
		     addr (input.list_ptr),
		     addr (input.tape_ptr),
		     addr (output.list_ptr),
		     addr (output.tape_ptr);

		if free_ptr ^= null then
		     if baseno (system_free_ptr) = baseno (free_ptr) then /* make sure it is in free area */
			free free_ptr -> word_string; /* can point to any old thing -
						   only the pointer is passed to the free routine */
	     end;

	     if segptr ^= null then do;
		call hcs_$terminate_noname (segptr, code);
		if code ^= 0 then
		     if normal_termination then
			call arg_error (68);	/* OUT OF ORDER- ADDED LATER */
	     end;

	end cleanup_proc;
%page;
/* Procedure to expand pathname */

get_io_pathname: proc (given_path) returns (char (168));

dcl  given_path char (*);
dcl  expanded_path char (168);
dcl  pl fixed bin(21);

	     pl = length (given_path);

	     call expand_path_ (addr (given_path), pl, addr (expanded_path), null, code);
	     if code ^= 0 then
		call path_error (60, given_path);
	     return (expanded_path);

	end get_io_pathname;
%page;
get_suffix: proc (input_string, return_suffix);

/*

      This  procedure  returns  the  suffix  of  an input_string
      (.gcos,  .ascii,  etc.).   If  there  are  more  than  two
      components  in  an input_string, the last one is returned.
      If  there is no suffix, the suffix field is returned null.

*/

dcl   input_string			char(*)		parm;
dcl   return_suffix			char(*) varying	parm;

dcl   work_string			char(168) varying;
dcl   dot_index			fixed bin (24);
dcl   dot				char(1)
				internal static
				options(constant)
				init(".");

     work_string = reverse (rtrim (input_string));
     dot_index = index (work_string, dot);

     if   dot_index ^= 0

     then return_suffix = reverse (substr (work_string, 1, dot_index));

     else return_suffix = "";

     return;

     end get_suffix;

end gcos_card_utility;




		    gcos_card_utility_.pl1          09/12/83  1115.2rew 09/12/83  0913.7     1126494



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


gcos_card_utility_: proc (a_input_ptr, a_output_ptr, a_code);


/*

   This  subroutine does the work of the gcu (gcos_card_utility)
   command.

   It  is called with pointers to two structures in the argument
   list, one containing all information pertaining to input, the
   other, all information pertaining to output.

   These  structures contain pointers to other structures, which
   contain  information  about  magnetic  tape  I/O, or lists of
   input  or  output items.  These structures are only allocated
   if needed.  Otherwise, the pointers to them are null.

   All  these  structures  are  described  by  the include file:
   gcos_utility_args_.incl.pl1

   Actual   space   for   these   structures   is  allocated  in
   gcos_card_utility.pl1

   This  procedure  is  composed  of  a large number of internal
   procedures,  for  the purpose of making it easily extensible,
   and  to  allow  the  flow of control to be easily followed by
   readers   of  the  code.   The  procedures  are  arranged  in
   alphabetic order by name, following the main procedure.
*/
%page;
/*
   WRITTEN  BY T. CASEY MAY 1973
   MODIFIED BY T. CASEY SEPTEMBER 1973
   *		    OCTOBER 1973
   *		    MARCH 1974
   *		    AUGUST 1974
   *		    DECEMBER 1974
   *		    JULY 1975
   *		    MARCH 1976
   *		    JANUARY 1977
   *
   MODIFIED BY D. WARD  APRIL 1981:
   *				Changed to octal bit constants. 
   *				Changed \014 to %page;
   *
   MODIFIED BY S. AKERS AUGUST 1981:
   *			       	Fixed problem of writing zero-length
   *				BCWs to tapes when prior input block
   *				is exactly 320 words.
   *
   *				Added conversion from gcos_ascii to
   *    				gcos_bcd.
   *
   *				Cleaned up format of program, putting
   *				more stuff into internal procedures.
   *
   *				Fixed bug which caused an EOF RCW to
   *				be written to a tape.
   *
   *				Changed Multics ASCII output to
   *				omit trailing blanks.
   *
   *				Fixed bug in converting GCOS ASCII
   *				to GCOS BCD.
   *
   * Modified: Ron Barstad  2.1 83-06-09  Allowed conversion to ascii or gcos_ascii
   *                                      from BCD media code 0 to be over 80 chars
   * Modified: Ron Barstad  2.2 83-07-13  Read and believe "char position" field of rcw of gcos records.
   */
%page;
/*	D  E  C  L  A  R  A  T  I  O  N  S  	*/


/*	Arguments		*/

dcl  a_code                   fixed bin(35) parm;
dcl  a_input_ptr              ptr parm;
dcl  a_output_ptr             ptr parm;

/*	Argument Structures		*/

%include gcos_utility_args_;



/*	Error Table Entries		*/

dcl  error_table_$action_not_performed ext fixed bin(35);


/*	External Static	*/

dcl (gcos_control_tables_$activity_table,
     gcos_control_tables_$cardtable (8) char (8),
     gcos_control_tables_$exc_offset fixed bin(17),
     gcos_control_tables_$nonact fixed bin(24),
     gcos_control_tables_$tablelen fixed bin(17),
     gcos_control_tables_$tabstops) external static;


/*	External Entries		*/

dcl (
     clock_ entry returns (fixed bin(71)),
     com_err_ entry options (variable),
     command_query_ entry options (variable),
     db entry,
     decode_clock_value_ entry (fixed bin(71), fixed bin(24), fixed bin(24), fixed bin(24), fixed bin(71), fixed bin(24), char (3) aligned),
     decode_nstd_status_ entry (bit (72) aligned, char (*) varying),
     gcos_cv_ascii_gebcd_check_ entry (ptr, fixed bin(24), ptr, fixed bin(35)),
     gcos_cv_gebcd_ascii_ entry (ptr, fixed bin(24), ptr),
     ioa_ entry options (variable),

     ios_$attach entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned),
     ios_$detach entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned),
     ios_$order entry (char (*) aligned, char (*) aligned, ptr, bit (72) aligned),
     ios_$read entry (char (*) aligned, ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned),
     ios_$seek entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(24), bit (72) aligned),
     ios_$setdelim entry (char (*) aligned, fixed bin(24), bit (9), fixed bin(24), bit (9), bit (72) aligned),
     ios_$setsize entry (char (*) aligned, fixed bin(24), bit (72) aligned),
     ios_$tell entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(24), bit (72) aligned),
     ios_$write entry (char (*) aligned, ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned),
     system_info_$installation_id entry (char (*))
     ) external;

dcl (addr, addrel, before, bin, bit, divide, fixed, hbound, index, length, max, min, mod,
     null, reverse, rtrim, string, substr, unspec, verify) builtin;

dcl  cleanup                  condition;



/*	Work areas and overlays for them		*/


dcl  ascii_block              char (input_block_len) based (input_block_ptr);
dcl  input_block              (320) bit (36) aligned	/* PLACE FOR ios_$read TO PUT THE DATA */;
dcl  input_block_len          fixed bin(24);
dcl  input_block_ptr          ptr;

dcl 1 bcw aligned based,

      2 bsn bit (18) unaligned,
      2 length bit (18) unaligned;

dcl 1 bcw_word based (input_block_ptr) aligned,

      2 bcw_num fixed bin (18) unsigned unaligned,
      2 bcw_len fixed bin (18) unsigned unaligned;

dcl  ascii_card               char (ascii_line_len) aligned based (addr (ascii_line));
dcl  ascii_line               char (1280) aligned	/* PLACE TO PUT ASCII LINE TRANSLATED FROM BCD */;

dcl  ascii_line_ptr           ptr;
dcl  ascii_line_len           fixed bin(24)init (80);	/* a variable, in case we ever want to
						   create variable length output lines */

dcl  gcos_work_area           (320) bit (36) aligned;	/* PLACE TO PUT GCOS RECORD,
						   TRANSLATED FROM ASCII OR RAW INPUT */
dcl  gcos_work_area_ptr       ptr;

dcl 1 bcd_card aligned based (bcd_work_area_ptr),
    2 rcw bit (36) unaligned,
    2 column (84) bit (6) unaligned;

dcl 1 bin_card aligned based,
    2 rcw bit (36) unaligned,
    2 column (80) bit (12) unaligned;

dcl  comdk_card_ptr           ptr;
dcl 1 comdk_card aligned based (comdk_card_ptr),		/* for decoding input comdk cards */
    2 rcw bit (36) unaligned,
    2 col1 bit (12) unaligned,			/* col 1 */
    2 seq_no bit (24) unaligned,			/* cols 2, 3 */
    2 checksum bit (36) unaligned,			/* cols 4-6 */
    2 char (132) bit (6) unaligned,			/* cols 7-72 */
    2 seq_col (8) bit (12) unaligned;						/* col 73-80 */

dcl 1 k_card like comdk_card aligned based (comdk_work_area_ptr)	/* for encoding output comdk cards */;

dcl  bit_string               bit (bit_string_len) unaligned based	/* overlay for moving bcd chars */;
dcl  bit_string_len           fixed bin(24);

dcl  char_string              char (char_string_len) unaligned based	/* overlay for moving ASCII chars */;
dcl  char_string_len          fixed bin(24);

dcl  word_string              (word_string_len) bit (36) aligned based	/* overlay for moving words */;
dcl  word_string_len          fixed bin(24);

dcl  bcd_work_area            (15) bit (36) aligned	/* PLACE TO BUILD BCD RECORD FROM COMDK CARDS */;
dcl  bcd_work_area_ptr        ptr;

dcl  gcos_record_len          fixed bin(24);
dcl  gcos_record_ptr          ptr;
dcl 1 gcos_record aligned based (gcos_record_ptr),	/* overlay for wherever a gcos record is - in input_block,
						   in gcos_work_area, or in bcd_work_area */
    2 rcw bit (36) aligned,
    2 data_words (gcos_record_len) bit (36) aligned;

dcl 1 rcw aligned based,
    2 length bit (18) unaligned,
    2 char_pos bin (2) unsigned unaligned,
    2 eof bit (4) unaligned,
    2 zeroes bit (2) unaligned,
    2 media_code bit (4) unaligned,
    2 report_code bit (6) unaligned;

dcl  raw_card                 (80) bit (12) unaligned	/* PLACE TO BUILD RAW OUTPUT CARD TRANSLATED FROM BCD */;
dcl  raw_card_ptr             ptr;

dcl  comdk_work_area          (28) bit (36) aligned	/* PLACE TO BUILD OUTPUT COMDK CARDS */;
dcl  comdk_work_area_ptr      ptr;

dcl  write_buffer             (320) bit (36) aligned	/* PLACE TO ACCUMULATE OUTPUT RECORDS FOR ios_$write */;
dcl  write_buffer_ptr         ptr;

dcl  act_ptr                  ptr	/* to look up tabstops for an activity */;
dcl 1 act_table_entry aligned based (act_ptr),		/* overlay for table entry for one activity */
    2 fill1 fixed bin(24),
    2 fill2 char (4),
    2 tab_index fixed bin(24);	/* position in tabstops table of settings for this activity */

dcl  tabstop_ptr              ptr	/* pointer to external static tabstop table */;
dcl 1 tabstops aligned based (tabstop_ptr),
    2 count fixed bin(24)aligned,			/* number of sets of tabstops */
    2 tab (0:tabstops.count - 1),
      3 stop (10) fixed bin(24)aligned;			/* each set is 10 or fewer stops */



/* Tape label structures */

dcl 1 header_label aligned based (label_ptr),
    2 btl bit (72) aligned,				/* GE/b/b600/bBTL/b */
    2 installation bit (36) aligned,
    2 reel_ser_no bit (36) aligned,			/* /bxxxxx */
    2 file_ser_no bit (36) aligned,			/* must = reel_ser_no, for single-reel files */
    2 reel_seq_no bit (36) aligned,			/* /b/bxxxx - xxxx=1 for single-reel files */
    2 creation_date bit (36) aligned,			/* /byyddd */
    2 retention_days bit (36) aligned,			/* /b/b/bxxx */
    2 file_name bit (72) aligned,
    2 unused (3) bit (36) aligned,
    2 prverr bit (36) aligned;						/* /b/b/b/b/b/b */

dcl 1 saved_header_label like header_label aligned automatic;

dcl 1 partial_label aligned based (label_ptr),
    2 btl bit (72) aligned,
    2 installation bit (36) aligned,
    2 reel_ser_no bit (36) aligned,
    2 zero_words (6) bit (36) aligned,			/* must be zero, for partial label */
    2 unused (4) bit (36) aligned;

dcl 1 trailer_label aligned based (label_ptr),
    2 eof bit (36) aligned,				/* /bEOF/b/b or /bEOR/b/b */
    2 block_count bit (36) aligned,
    2 unused (11) bit (36) aligned,
    2 next_reel bit (36) aligned;						/* /b/b/b/b/b/b */

/*	Switches		*/

dcl (
     appending_to_output,
     eof,
     eoj,
     file_eob,
     file_eof,
     found_last_line,
     input_comdk_open,
     just_looking,
     looking_for_first_line,
     looking_for_last_line,
     no_end_card,
     output_comdk_open,
     rcw_eof
     ) bit (1) aligned init ("0"b);

dcl  no_label                 (2) bit (1) aligned init ((2) (1)"0"b);


/*	Error Handling Variables		*/

dcl  code                     fixed bin(35) based (addr (status));
dcl  status                   bit (72) aligned;


/*	Fixed Bin		*/

dcl  tod                      fixed bin(71);

dcl (
     bcd_col_index,
     bin_cards_skipped,
     block_serial_number,
     comdk_char_index,
     comdk_error_count,
     comdk_out_index,
     dom,
     dow,
     element_size,
     elements_wanted,
     elements_written,
     err_num,
     field_len,
     file_record_count,
     first_key,
     i,
     input_block_count,
     input_record_count,
     item_index,
     item_length,
     j,
     k,
     last_key,
     list_index,
     month,
     next_input_index,
     next_output_index,
     nondollar_tab_index,
     offset,
     output_block_count,
     output_block_len,
     output_record_count,
     path_len,
     prev_comdk_seq_no,
     raw_cards_bad,
     raw_chars_bad,
     remaining_block_len,
     remaining_output_words,
     string_len,
     year
     ) fixed bin(24)init (0);

dcl  chase                    fixed bin(1) init (1);
dcl  seq_col                  (5:8) fixed bin(24)/* numeric values of punches in cols 77-80 */;


/*	Pointers - Additional pointers are declared adjacent to the variables whose addresses they are initialized to */

dcl (
     label_ptr,
     output_word_ptr,
     saved_record_ptr)
     ptr;


/*	Strings		*/

/*	ASCII strings */

dcl  punches                  char (36) varying;

dcl  punch                    (12) char (3) int static init ("-12", "-11", "-0", "-1", "-2", "-3", "-4", "-5", "-6", "-7", "-8", "-9");


dcl  inst                     char (32);
dcl  me                       char (20) int static init ("gcos_card_utility_");
dcl  tape_status_message      char (50) varying;
dcl (input_stream_name, output_stream_name) char (32) aligned;

dcl  ascii_search_key         (15) char (15) aligned int static init (
     "$      snumb   ",
     "$      gmap    ",
     "$      355map  ",
     "$      object  ",
     "$      forty   ",
     "$      fortran ",
     "$      ids     ",
     "$      pl1     ",
     "$      cobol   ",
     "$      asm66   ",
     "$      cbl74   ",
     "$      cbl68   ",
     "$      malt    ",
     "$      ilang   ",
     "$      ids2    ");

dcl  answer                   char (8) varying init ("");
dcl  card_type                char (8) aligned;
dcl  edit_name                char (8);
dcl  item_name                char (8) aligned	/* edit name or snumb */;
dcl  next_output_suffix       char (6) aligned;
dcl  zone                     char (3) aligned;
dcl  ascii_newline            char (1) int static init ("
");
dcl  ascii_backspace          char (1) int static init ("");
dcl  ascii_pads               char (4) int static init ("")	/* four octal 177's */;
dcl  ascii_tab                char (1) int static init ("	");

/*	BCD and binary strings */

dcl  bcd_blank_card           (14) bit (36) aligned int static init
    ((13) (6) "010000"b, "010000010000"b);	/* we HOPE this puts blanks in 80 6-bit chars,
					   and fills the rest of the last word with zeros */

dcl  bcd_btl                  bit(72)static int options(constant) init("272520200600002022634320"b3) /* GEbb600bBTLb (BCD). */;

dcl  bcd_beofbb               bit(36)static int options(constant)init("202546262020"b3) /* bEOFbb (BCD). */;

dcl  bcd_beorbb               bit(36)static int options(constant)init("202546512020"b3) /* bEORbb (BCD). */;

dcl  bcd_b1                   bit(36)static int options(constant)init("200000000000"b3) /* b00000 (BCD). */;

dcl  bcd_b2                   bit(36)static int options(constant)init("202000000000"b3) /* bb0000 (BCD). */;

dcl  bcd_b3                   bit(36)static int options(constant)init("202020000000"b3) /* bbb000 (BCD). */;

dcl  bcd_b6                   bit(36)static init options(constant)init((6)"20"b3) /* 6 blanks (BCD). */;

dcl  ascii_header_rcw         bit(36) static int options(constant) init("000024001000"b3);
						/* rec len = 20; media code = 8 */

dcl  bcd_rcw                  bit(36)static int options(constant)init("000016000200"b3);
						/* rec len = 14; media code = 0010 (bcd card) */

dcl  bin_rcw                  bit(36)static int options(constant)init( "000033000100"b3);
						/* rec len = 27; media code = 0001 (binary card) */

dcl  eof_rcw                  bit(36)static int options(constant)init( "000000170000"b3);
						/* rec len = 0; eof = bcd_eof; media code,report code = 0 */
dcl  bcd_endjob               bit(36)static int options(constant)init( "254524414622"b3) /* ENDJOB (BCD). */;
dcl  gcd_star_eof             bit(36)static int options(constant)init( "545454254626"b3) /* ***EOF (BCD). */;
dcl  bcd_search_key           (15)bit(36)static int options(constant)init(
 "624564442220"b3	/* SNUMBb (BCD). */
,"274421472020"b3	/* GMAPbb (BCD). */
,"030505442147"b3	/* 355MAP (BCD). */
,"462241252363"b3	/* OBJECT (BCD). */
,"264651637020"b3	/* FORTYb (BCD). */
,"264651635121"b3	/* FORTRA (BCD). */
,"312462202020"b3	/* IDSbbb (BCD). */
,"474301202020"b3	/* PL1bbb (BCD). */
,"234622464320"b3	/* COBOLb (BCD). */
,"216244060620"b3	/* ASM66b (BCD). */
,"232243070420"b3	/* CBL74b (BCD). */
,"232243061020"b3	/* CBL68b (BCD). */
,"442143632020"b3	/* MALTbb (BCD). */
,"314321452720"b3	/* ILANGb (BCD). */
,"312462022020"b3	/* IDS2bb (BCD). */
);

dcl  bcd_dkend                bit(36)static int options(constant)init( "244225452420"b3) /* DKENDb (BCD). */;

dcl  bcd_edit_name            (8) bit (6) unaligned;

dcl  comdk_col_1              bit(12)static int options(constant)init("5005"b3);

dcl  ascii_header_media_code  bit (4) unaligned int static init ("1000"b) /* media code 8 - header for gcos TSS ascii file */;
dcl  ascii_media_code         bit (4) unal int static init ("0110"b)	/* media code 6 - ASCII  */;
dcl  bcd_blank                bit(6)static int options(constant)init("20"b3) /* blank (BCD). */;
dcl  bcd_dollar               bit(6)static int options(constant)init( "53"b3) /* $ (BCD). */;
dcl  bcd_eof                  bit(4)static int options(constant)init("1111"b);
dcl  bcd_media_code           bit (4) unaligned int static init ("0010"b)	/* media code 2 - BCD card */;
dcl  plain_bcd_media_code     bit (4) unal int static init ("0000"b) /* media code 0 - BCD variable length record */;


dcl  pten                     (0:5) int static fixed bin(24)init (1, 10, 100, 1000, 10000, 100000);




/* TRANSLATION TABLES FOR CONVERSION FROM-TO RAW CARD IMAGES */


/* BCD characters, in same order as their corresponding card punch codes in bin_table, below */

dcl  bcd_table                (0:63) bit (6) aligned internal static init (
     "010000"b,					/* " " */
     "001001"b,					/* "9" */
     "001000"b,					/* "8" */
     "000111"b,					/* "7" */
     "001111"b,					/* "?" */
     "000110"b,					/* "6" */
     "001110"b,					/* ">" */
     "000101"b,					/* "5" */
     "001101"b,					/* ":" */
     "000100"b,					/* "4" */
     "001100"b,					/* "@" */
     "000011"b,					/* "3" */
     "001011"b,					/* "#" */
     "000010"b,					/* "2" */
     "001010"b,					/* "[" */
     "000001"b,					/* "1" */
     "000000"b,					/* "0" */
     "111001"b,					/* "z" */
     "111000"b,					/* "y" */
     "110111"b,					/* "x" */
     "111111"b,					/* "!" */
     "110110"b,					/* "w" */
     "111110"b,					/* """ */
     "110101"b,					/* "v" */
     "111101"b,					/* "=" */
     "110100"b,					/* "u" */
     "111100"b,					/* "%" */
     "110011"b,					/* "t" */
     "111011"b,					/* "," */
     "110010"b,					/* "s" */
     "111010"b,					/* "<-" */
     "110001"b,					/* "/" */
     "101010"b,					/* "-" */
     "101001"b,					/* "r" */
     "101000"b,					/* "q" */
     "100111"b,					/* "p" */
     "101111"b,					/* "'" */
     "100110"b,					/* "o" */
     "101110"b,					/* ";" */
     "100101"b,					/* "n" */
     "101101"b,					/* ")" */
     "100100"b,					/* "m" */
     "101100"b,					/* "*" */
     "100011"b,					/* "l" */
     "101011"b,					/* "$" */
     "100010"b,					/* "k" */
     "100001"b,					/* "j" */
     "100000"b,					/* "|" */
     "011010"b,					/* "&" */
     "011001"b,					/* "i" */
     "011000"b,					/* "h" */
     "010111"b,					/* "g" */
     "011111"b,					/* "\" */
     "010110"b,					/* "f" */
     "011110"b,					/* "<" */
     "010101"b,					/* "e" */
     "011101"b,					/* "(" */
     "010100"b,					/* "d" */
     "011100"b,					/* "]" */
     "010011"b,					/* "c" */
     "011011"b,					/* "." */
     "010010"b,					/* "b" */
     "010001"b,					/* "a" */
     "110000"b					/* "+" */
     );

/* card punch codes for the GEBCD characters, arranged in ascending order of their
   numeric values, to allow lookup of INPUT raw card column contents, using a
   half-interval (binary) search */

dcl  bin_table                (0: 63) bit (12) aligned internal static init (
     "000000000000"b,				/* " " */
     "000000000001"b,				/* "9" */
     "000000000010"b,				/* "8" */
     "000000000100"b,				/* "7" */
     "000000000110"b,				/* "?" */
     "000000001000"b,				/* "6" */
     "000000001010"b,				/* ">" */
     "000000010000"b,				/* "5" */
     "000000010010"b,				/* ":" */
     "000000100000"b,				/* "4" */
     "000000100010"b,				/* "@" */
     "000001000000"b,				/* "3" */
     "000001000010"b,				/* "#" */
     "000010000000"b,				/* "2" */
     "000010000010"b,				/* "[" */
     "000100000000"b,				/* "1" */
     "001000000000"b,				/* "0" */
     "001000000001"b,				/* "z" */
     "001000000010"b,				/* "y" */
     "001000000100"b,				/* "x" */
     "001000000110"b,				/* "!" */
     "001000001000"b,				/* "w" */
     "001000001010"b,				/* """ */
     "001000010000"b,				/* "v" */
     "001000010010"b,				/* "=" */
     "001000100000"b,				/* "u" */
     "001000100010"b,				/* "%" */
     "001001000000"b,				/* "t" */
     "001001000010"b,				/* "," */
     "001010000000"b,				/* "s" */
     "001010000010"b,				/* "<-" */
     "001100000000"b,				/* "/" */
     "010000000000"b,				/* "-" */
     "010000000001"b,				/* "r" */
     "010000000010"b,				/* "q" */
     "010000000100"b,				/* "p" */
     "010000000110"b,				/* "'" */
     "010000001000"b,				/* "o" */
     "010000001010"b,				/* ";" */
     "010000010000"b,				/* "n" */
     "010000010010"b,				/* ")" */
     "010000100000"b,				/* "m" */
     "010000100010"b,				/* "*" */
     "010001000000"b,				/* "l" */
     "010001000010"b,				/* "$" */
     "010010000000"b,				/* "k" */
     "010100000000"b,				/* "j" */
     "011000000000"b,				/* "|" */
     "100000000000"b,				/* "&" */
     "100000000001"b,				/* "i" */
     "100000000010"b,				/* "h" */
     "100000000100"b,				/* "g" */
     "100000000110"b,				/* "\" */
     "100000001000"b,				/* "f" */
     "100000001010"b,				/* "<" */
     "100000010000"b,				/* "e" */
     "100000010010"b,				/* "(" */
     "100000100000"b,				/* "d" */
     "100000100010"b,				/* "]" */
     "100001000000"b,				/* "c" */
     "100001000010"b,				/* "." */
     "100010000000"b,				/* "b" */
     "100100000000"b,				/* "a" */
     "101000000000"b				/* "+" */
     );

/* card punch codes for the GEBCD characters, arranged in order of the numeric
   values of their corresponding 6-bit BCD codes, to allow OUTPUT raw card column
   contents to be obtained using the BCD character as an index into the table */

dcl  raw_table                (0:63) bit (12) aligned int static init (
     "001000000000"b,				/* 0 */
     "000100000000"b,				/* 1 */
     "000010000000"b,				/* 2 */
     "000001000000"b,				/* 3 */
     "000000100000"b,				/* 4 */
     "000000010000"b,				/* 5 */
     "000000001000"b,				/* 6 */
     "000000000100"b,				/* 7 */
     "000000000010"b,				/* 8 */
     "000000000001"b,				/* 9 */
     "000010000010"b,				/* [ */
     "000001000010"b,				/* # */
     "000000100010"b,				/* @ */
     "000000010010"b,				/* : */
     "000000001010"b,				/* > */
     "000000000110"b,				/* ? */
     "000000000000"b,				/* blank */
     "100100000000"b,				/* A */
     "100010000000"b,				/* B */
     "100001000000"b,				/* C */
     "100000100000"b,				/* D */
     "100000010000"b,				/* E */
     "100000001000"b,				/* F */
     "100000000100"b,				/* G */
     "100000000010"b,				/* H */
     "100000000001"b,				/* I */
     "100000000000"b,				/* & */
     "100001000010"b,				/* . */
     "100000100010"b,				/* ] */
     "100000010010"b,				/* ( */
     "100000001010"b,				/* < */
     "100000000110"b,				/* \ */
     "011000000000"b,				/* | */
     "010100000000"b,				/* J */
     "010010000000"b,				/* K */
     "010001000000"b,				/* L */
     "010000100000"b,				/* M */
     "010000010000"b,				/* N */
     "010000001000"b,				/* O */
     "010000000100"b,				/* P */
     "010000000010"b,				/* Q */
     "010000000001"b,				/* R */
     "010000000000"b,				/* - */
     "010001000010"b,				/* $ */
     "010000100010"b,				/* * */
     "010000010010"b,				/* ) */
     "010000001010"b,				/* ; */
     "010000000110"b,				/* ' */
     "101000000000"b,				/* + */
     "001100000000"b,				/* / */
     "001010000000"b,				/* S */
     "001001000000"b,				/* T */
     "001000100000"b,				/* U */
     "001000010000"b,				/* V */
     "001000001000"b,				/* W */
     "001000000100"b,				/* X */
     "001000000010"b,				/* Y */
     "001000000001"b,				/* Z */
     "001010000010"b,				/* <- (left arrow) */
     "001001000010"b,				/* , */
     "001000100010"b,				/* % */
     "001000010010"b,				/* = */
     "001000001010"b,				/* " */
     "001000000110"b				/* ! */
     );






%include query_info;

%include gcos_xlate_bcd_ascii_;
%page;
/*	P  R  O  C  E  D  U  R  E   	*/

/* Initialization */

	input_ptr = a_input_ptr;			/* copy argument structure pointers to */
	output_ptr = a_output_ptr;			/* local storage, for better accessing code */
	nondollar_tab_index = -1;			/* initialize to "no value assigned" code */
	query_info.yes_or_no_sw = "1"b;		/* we ask only yes or no questions */

	on condition (cleanup) call cleanup_proc;

	unspec (write_buffer) = ""b;			/* zero the output buffer,
						   to avoid garbage at the ends of short records */
	if output.name_files
	then do;			/* set suffix for output file names */
	     if output.format = ascii then
		next_output_suffix = ".ascii";
	     else if output.medium = raw then
		next_output_suffix = ".raw";
	     else if output.comdk then
		next_output_suffix = ".comdk";
	     else next_output_suffix = ".gcos";
	     end;

	do io_ptr = input_ptr, output_ptr;
	     if io.medium = tape then
		if io_tape.label = "-nl"
		 | io_tape.label = "-no_label"
		 | io_tape.label = "-no_labels"
		then no_label (io.sw) = "1"b;
	end;

	input_block_ptr = addr (input_block);		/* get pointers to work areas */
	ascii_line_ptr = addr (ascii_line);
	gcos_work_area_ptr = addr (gcos_work_area);
	bcd_work_area_ptr = addr (bcd_work_area);
	raw_card_ptr = addr (raw_card);
	comdk_work_area_ptr = addr (comdk_work_area);
	write_buffer_ptr = addr (write_buffer);

/* do not get ptr to ext static tabstop table now. wait to see if it is needed.
   do it in open_input. */


  /*          Processing (What there is of it...)          */

	if input.set = single_file
	   then call process_single_file;
     else if input.set = imcv
	   then call process_imcv;
     else if input.set = library
	   then call process_library_file;
     else if input.set = multiple_files
	   then call process_multiple_files;
     else call fatal_error (1);		/* error_table_$badcall */

        /* Just return normally, no fuss, no bother. */

	a_code = code;
	return;

  /* Whoops! Something went bust, so gotta clean up first. */

cleanup_and_return:
	call cleanup_proc;
	a_code = code;
	return;

/*	 END OF MAIN PROCEDURE. INTERNAL PROCEDURES AND DEBUGGING ENTRIES FOLLOW */
%page;
bcd_string: proc (in_string, in_count) returns (bit (*) aligned);

dcl  in_string                char (*);
dcl  ret_bits                 bit (ret_len) aligned based (addr (work_bits));
dcl  work_bits                bit (72) aligned;
dcl  work_chars               char (12) aligned;
dcl (digit, i, in_count, in_no, indx, num, ret_len, xnum) fixed bin(24);

	     work_chars = in_string;			/* align the input string */
	     call gcos_cv_ascii_gebcd_check_ (addr (work_chars), in_count, addr (work_bits), code);
	     if code ^= 0 then do;
		call ioa_ ("Error in character ^d of : ~a", code, in_string);
		code = 0;				/* code is position of bad char - not error table code */
		call fatal_error (2);		/* bad string - can't convert to BCD */
	     end;

return_string:					/* come here from bcd_string_bin entry point */
	     ret_len = in_count*6;			/* compute length in bits of the BCD string */
	     return (ret_bits);

bcd_string_bin: entry (in_no, in_count) returns (bit (*) aligned);

	     indx = 1;
	     num = in_no;

	     do i = in_count-1 by -1 to 0;		/* convert digits left to right */
		xnum = mod (num, pten (i));		/* get digits to right of the one we want */
						/* pten(i) contains 10**i */
		digit = divide (num-xnum, pten (i), 17, 0); /* get digit we want */
		if indx = 1 then			/* if first time around loop */
		     if digit > 9 then		/* check for number too large for field */
			call fatal_error (3);	/* number to large for BCD field */
		substr (work_bits, indx, 6) = bit (fixed (digit, 6)); /* make BCD char from digit */
		indx = indx + 6;			/* move to next digit in receiving field */
		num = xnum;			/* work with digits to right of one just converted */
	     end;

	     goto return_string;			/* go return the string when done converting */

end bcd_string;
%page;
canonicalizer: proc (input_string_ptr, initial_input_characters,
		output_card_ptr, initial_output_columns);

/* NOTE: a copy of this internal procedure exists also in gcos_gein_pass1_.
   The initialization is different, but the canonicalization is the same.
   Any changes should be made to both copies, if appropriate. */

dcl  initial_input_characters fixed bin(24);
dcl  input_string             char (initial_input_characters) based (input_string_ptr);
dcl  input_string_ptr         ptr;

dcl  initial_output_columns   fixed bin(24);
dcl  output_card              char (initial_output_columns) based (output_card_ptr);
dcl  output_card_ptr          ptr;

dcl (
     next_input_character,
     next_output_column,
     next_backspace,				/* relative to next_input_character */
     next_tab,					/* relative to next_input_character */
     remaining_input_characters,
     remaining_output_columns,
     character_count,
     blank_count,
     first_blank,
     i,
     backspace_count
     ) fixed bin(24);

dcl (more_backspaces,
     more_tabs) bit (1) aligned;

dcl  tabstop                  (10) fixed bin(24)based (tab_ptr)	/* tabstops currently in use */;
dcl  tab_ptr                  ptr	/* pointer to tabs currently in use */;



/*     INITIALIZE        */

	     next_input_character, next_output_column = 1;
	     remaining_input_characters = initial_input_characters;
	     remaining_output_columns = initial_output_columns;

	     more_backspaces, more_tabs = "1"b;		/* we want to look for backspaces and tabs at the start */

	     if substr (input_string, remaining_input_characters, 1) = ascii_newline /* if last char is a newline */
	     then remaining_input_characters = remaining_input_characters - 1; /* then get rid of it */


	     if substr (input_string, 1, 1) = "$" then
set_dollar_tabs:	do;

		tab_ptr = addr (tab (0));		/* get pointer to dollar tabs */

		end set_dollar_tabs;

	     else					/* not a dollar card */
set_nondollar_tabs: do;

		if input.tabs_given then		/* if user supplied nondollar tabstops */
		     tab_ptr = addr (input.tabstops);	/* get pointer to user-supplied tabstops */

		else do;				/* otherwise use the ones we looked up */
		     if nondollar_tab_index = -1 then call fatal_error (4); /* check for case of:
						   1) not a complete job,
						   so no activity card to determine tabs from, and
						   2) no tabs given by user, resulting in no tabstops to use */

		     else tab_ptr = addr (tab (nondollar_tab_index)); /* get pointer to tabs for this activity */
		end;

		end set_nondollar_tabs;


/*     MAIN LOOP. FILL UP OUTPUT CARD */

canon_loop:    do while (remaining_output_columns > 0);	/* keep going while there is any room on output card */

		if more_backspaces then		/* if there MIGHT be more backspaces */
find_next_backspace:     do;				/* then look for one */

		     next_backspace = index (substr (input_string, next_input_character,
			remaining_input_characters), ascii_backspace);
		     if next_backspace = 0 then more_backspaces = "0"b; /* if none found, remember not to look again */

		     end find_next_backspace;

		if more_tabs then			/* if there MIGHT be more tabs */
find_next_tab:	     do;				/* then look for one */
		     next_tab = index (substr (input_string, next_input_character,
			remaining_input_characters), ascii_tab);
		     if next_tab = 0 then more_tabs = "0"b; /* if none found, remember not to look again */
		     end find_next_tab;

		if more_backspaces then		/* if we found a backspace */
look_at_backspace:	     do;				/* see if it is in a legal position */
						/* maybe sometime allow backspaces to be in places other than
						   immediately following tabs, but for now, it's an error */

		     if ^more_tabs | next_backspace ^= next_tab+1 then call fatal_error (5);

		     end look_at_backspace;

		if more_tabs then			/* if we found a tab, we want to move the characters before it */
process_tab:	     do;				/* to the output card, and fill with blanks to next tab stop */

		     character_count = min (		/* compute the number of characters */
			next_tab - 1,		/* before the tab */
			remaining_output_columns);	/* but not more than there's room for on output card */

		     first_blank = next_output_column + character_count;

		     do i = 1 to hbound (tabstop, 1)	/* look for a tabstop */
			     while (tabstop (i) <= first_blank); /* that's past the characters */
						/* if it's in the column immediately after the characters,
						   then go to the next one, the way a typewriter will */
		     end;

		     if i <= hbound (tabstop, 1) then	/* if we found one */

			blank_count = min (		/* compute the number of blanks */
			tabstop (i) - first_blank,	/* needed to get there */
			remaining_output_columns);	/* but not more than there's room for on output card */

		     else				/* if no more tabstops, replace tab with one blank */
		     blank_count = min (1, remaining_output_columns);


		     end process_tab;

		else
no_more_tabs:	do;				/* if there are no more tabs,
						   we want to move the rest of the input characters
						   to the output card, and fill the rest of it with blanks */

		     character_count = min (		/* compute rest of characters to move */
			remaining_input_characters,	/* all the rest, since no more tabs */
			remaining_output_columns);	/* but not more than there's room for on output card */

		     blank_count = max (0,		/* compute blanks needed to fill rest of card */
			remaining_output_columns - remaining_input_characters);

		     end no_more_tabs;

		if character_count > 0 then		/* move characters to output card, if there are any */
move_characters:	     do;
		     substr (output_card, next_output_column, character_count) =
			substr (input_string, next_input_character, character_count);

		     remaining_input_characters = remaining_input_characters - character_count;

		     next_input_character = next_input_character + character_count;

		     remaining_output_columns = remaining_output_columns - character_count;

		     next_output_column = next_output_column + character_count;

		     end move_characters;

		if blank_count > 0 then		/* fill with blanks, if any */
move_blanks:	     do;

		     substr (output_card, next_output_column, blank_count) = "";

		     remaining_output_columns = remaining_output_columns - blank_count;

		     next_output_column = next_output_column + blank_count;

		     end move_blanks;



		if more_tabs then do;		/* move past tab in input string */
		     remaining_input_characters = remaining_input_characters - 1;
		     next_input_character = next_input_character + 1;
		end;




		if more_backspaces then
backspace:	     do;				/* if we found a backspace, we will:
						   1) see if there's more than one of them, and
						   2) move back that many columns, deleting whatever is there,
						   (probably only blanks ) */

		     do i = next_input_character to initial_input_characters
			     while (substr (input_string, i, 1) = ascii_backspace);
		     end;

		     character_count = i - next_input_character; /* count backspace characters */

		     backspace_count = min (character_count, /* count columns to backspace */
			next_output_column - 1);	/* but don't backspace past beginning of card */


/* skip over input backspace characters */
		     remaining_input_characters = remaining_input_characters - character_count;

		     next_input_character = next_input_character + character_count;

/* backspace on output card */
		     remaining_output_columns = remaining_output_columns + backspace_count;

		     next_output_column = next_output_column - backspace_count;

		     end backspace;

		     end canon_loop;

/*     WE FALL THRU HERE WHEN remaining_output_columns BECOMES ZERO */


	     if remaining_input_characters > 0 then	/* if input left over */
		if ^input.truncate_ascii then		/* and user did not say -truncate */
		     call fatal_error (6);		/* complain */


	     if ^input.tabs_given then		/* if user did not supply the nondollar tab stops */
		if substr (output_card, 1, 1) = "$" then
look_up_tabstops:	     do;				/* we will determine them from the type of activity */

		     card_type = substr (output_card, 8, 8); /* get card type */

		     do i = 1 to gcos_control_tables_$tablelen /* look it up in cardtable */
			     while (card_type ^= gcos_control_tables_$cardtable (i));
		     end;				/* fall thru if found, or end of table */
						/* don't really care which */
		     if i >= gcos_control_tables_$exc_offset then /* if its not before the first activity card */
			if i < gcos_control_tables_$nonact then /* and not after the last one */
act_card:			     do;			/* then it must be one */

			     act_ptr = addr (gcos_control_tables_$activity_table); /* pointer to data table */
			     act_ptr = addrel (act_ptr, (i - gcos_control_tables_$exc_offset)*3);
						/* pointer to data for this activity */
			     nondollar_tab_index = act_table_entry.tab_index; /* index to tabs for this activity */
			     end act_card;
			     end look_up_tabstops;


	     return;

end canonicalizer;
%page;
check_bin_cards: proc;

	     if bin_cards_skipped > 0 then do;
		call ioa_ ("^a: ^d non-bcd-card records skipped just before:^/^a", me,
		     bin_cards_skipped, ascii_card);
		bin_cards_skipped = 0;
	     end;

	     return;

end check_bin_cards;
%page;
check_for_eod: proc returns (bit (1));			/* check for end of library deck */

dcl  i                        fixed bin(24);

	     if eof then goto eod;


	     if output.format = ascii | output.gcos_ascii then do;
		if substr (ascii_card, 1, 1) = "$" then do; /* a dollar card can indicate end of deck */
		     if substr (ascii_card, 1, 15) = "$      dkend   " then goto eod;
		     do i = 2 to 15;		/* check for missing end card -
						   this might be a GMAP, 355MAP, or OBJECT card */
			if substr (ascii_card, 1, 15) = ascii_search_key (i) then goto noend;
		     end;
		     goto eod;			/* NOTE - we are assuming that any other dollar card
						   also ends the library deck, without starting a new one */
		end;
	     end;

	     else do;				/* check it in BCD */
		if gcos_record_ptr -> bcd_card.column (1) = bcd_dollar then do;
		     if substr (string (gcos_record), 79, 36) = bcd_dkend then goto eod;
		     do i = 2 to 15;
			if substr (string (gcos_record), 79, 36) = bcd_search_key (i) then goto noend;
		     end;
		     goto eod;			/* see NOTE above */
		end;
	     end;

	     return ("0"b);

noend:	     no_end_card = "1"b;
eod:	     return ("1"b);

end check_for_eod;
%page;
check_for_eoj: proc returns (bit (1));

	     if eof then return ("1"b);

	     if output.format = ascii | output.gcos_ascii then do; /* check it in ascii */
		if substr (ascii_card, 1, 15) = ascii_search_key (1) then do; /* $ snumb */
		     no_end_card = "1"b;
		     return ("1"b);
		end;
	     end;

	     else do;				/* check it in BCD */
		if gcos_record_ptr -> bcd_card.column (1) = bcd_dollar then do;
		     if substr (string (gcos_record), 79, 36) = bcd_search_key (1) then do; /* SNUMB */
			no_end_card = "1"b;
			return ("1"b);
		     end;
		end;				/* end dollar card */
	     end;					/* end check it in BCD */

	     return ("0"b);

end check_for_eoj;
%page;
cleanup_proc: proc;

dcl  i                        fixed bin(24);

/* Detach file streams. Leave tapes for caller to detach or retain. */

	     do i = 1 to 2;
		call ios_$detach ((file_stream (i)), "", "", status);
	     end;

	     return;

end cleanup_proc;
%page;
close_comdk_output: proc;

	     k_card.char (comdk_out_index) = "111110"b;	/* 76 octal - end of comdk */
	     call write_comdk_card;			/* write out the last card */
	     output_comdk_open = "0"b;		/* remember that comdk is no longer open */

	     return;

end close_comdk_output;
%page;
close_input: proc;

	     io_ptr = input_ptr;			/* in case of error, to indicate which file */

	     if input.medium = tape then do;

		if found_last_line then		/* if we stopped because of -last or -count */
		     if ^file_eof then do;		/* and the last block has not been read */
			call ios_$order (output_stream_name, "forward_file", null, status);
			if code ^= 0 then
			     call interpret_tape_status;
			if ^file_eof then
			     call fatal_error (61);
		     end;

		if ^no_label (io.sw) then do;		/* if labeled tape, read trailer label */
		     label_ptr = input_block_ptr;
		     file_eof = "0"b;
read_trailer:	     call read_block;		/* read the trailer label */
		     if file_eof then do;
			if rcw_eof then do;		/* if we had not yet read the eof tape mark */
			     rcw_eof = "0"b;	/* we just did */
			     goto read_trailer;	/* so go try to read trailer again */
			end;
			call fatal_error (7);	/* eof when trailer label expected */
		     end;				/* end file_eof do group */
		     if input_block_len ^= 14 then
			call fatal_error (8);	/* data record when trailer label expected */
		     if trailer_label.eof ^= bcd_beofbb then /* /bEOF/b/b */
			if trailer_label.eof ^= bcd_beorbb then /* /bEOR/b/b */
			     call fatal_error (9);	/* bad trailer label format */

		     input_block_count = input_block_count - 2; /* deduct the eof and the trailer label */
		     if fixed (trailer_label.block_count) ^= input_block_count then
			if ^input.brief then
			     call ioa_ ("^a: warning: block count in trailer label (^d) ^= blocks read (^d).",
			     me, fixed (trailer_label.block_count), input_block_count);

		     call read_block;		/* read the eof mark after the trailer label */
		     if ^file_eof then
			call fatal_error (10);	/* expected eof after trailer not found */
		end;				/* end of labeled tape do group */

		else do;				/* unlabeled tape */
		     if rcw_eof then do;		/* if we have not yet read the eof tape mark */
			file_eof, rcw_eof = "0"b;	/* turn off switches */
			call read_block;		/* and read it now */
			if ^file_eof then		/* if eof tape mark not there */
			     call fatal_error (60);	/* expected eof after unlabeled tape file missing */
		     end;
		end;

	     end;

	     else do;

		call ios_$detach (input_stream_name, "", "", status);

		if code ^= 0 then call fatal_error (11);

	     end;

	     tape_status_message = "";
	     return;

end close_input;
%page;
close_output: proc;

	     io_ptr = output_ptr;			/* in case of error, to indicate which file */

	     if output_comdk_open then		/* if we were writing a comdk */
		call close_comdk_output;		/* put out the last card */

	     if output.medium ^= raw			/* if an ordinary GCOS file */
	     then if output.format ^= ascii
		then if output.format ^= blocks
		     then if output.medium ^= tape	/* and not a tape file, */

			then call write_gcos_record (addr (eof_rcw), 1); /* then write eof record */

	     if output.medium = tape then do;

		call write_tape_eof;		/* write eof and check error code */

		if ^no_label (io.sw) then do;		/* if labeled tape, build and write trailer label */
		     label_ptr = write_buffer_ptr;	/* build it in the write buffer */
		     unspec (trailer_label) = ""b;	/* clear it first */
		     trailer_label.eof = bcd_beofbb;	/* /bEOF/b/b */
		     trailer_label.block_count = bit (fixed (output_block_count, 36));
		     trailer_label.next_reel = bcd_b6;	/* six bcd blanks */

		     call write_tape_label;		/* write label and eof, checking error codes */

/* build partial label */
		     word_string_len = 14;		/* length of label */
						/* use word_string overlay because structure assignment
						   compiles into element-by-element assignment */
		     addr (header_label) -> word_string = addr (saved_header_label) -> word_string;
						/* partial label is header label, */
		     unspec (partial_label.zero_words) = ""b; /* with words 5-10 zeroed */

		     call write_tape_label;		/* write it and an eof, checking error codes */

/* now, in case there is more to write on the tape, backspace to beginning of partial label,
   so it will be overwritten if there is more */

		     do i = 1 to 2;
			file_eof = "0"b;
			call ios_$order (output_stream_name, "backspace_file", null, status);
			if code ^= 0 then
			     call interpret_tape_status;
			if ^file_eof then		/* should get eof status from backspace file */
			     call fatal_error (12);	/* error while backspacing over partial label */
		     end;

/* read the eof before the partial label */
		     call ios_$read (output_stream_name, input_block_ptr, 0, elements_wanted, input_block_len, status);
		     file_eof = "0"b;
		     if code ^= 0 then
			call interpret_tape_status;
		     if ^file_eof then
			call fatal_error (13);	/* while positioning to partial label */
		end;				/* end of labeled tape do group */

	     end;

	     else do;

		call ios_$detach (output_stream_name, "", "", status);

		if code ^= 0 then call fatal_error (14);

	     end;

	     tape_status_message = "";
	     return;

end close_output;
%page;
copy_jobs:     proc;

	     do list_index = 1 to input.list_count while (^eof);
		call find_list_item;

		if ^eof
		then do;

		     if output.set = multiple_files
		     then call open_next_output;
		     call copy_one_job;
		     if output.set = multiple_files
		     then call close_output;

		     end;
	     end;
end copy_jobs;
%page;
copy_one_deck: proc;				/* procedure to copy one library deck */
dcl  first_card               bit (1) aligned;

	     eof, eoj = "0"b;
	     first_card = "1"b;

	     do while (^eoj);
		if ^first_card then
		     eoj = check_for_eod ();		/* see if this card is an end of deck indicator */
		else first_card = "0"b;
		if ^eof then			/* if there is a card there */
		     if ^no_end_card then		/* and its not the first card of the next deck, write it */
			call write_output;		/* first card was read by find_list_item */
		if ^eoj then call read_and_convert_input;
	     end;

end copy_one_deck;
%page;
copy_one_file: proc;

	     eof = "0"b;

	     do while (^eof);

		call read_and_convert_input;
		if ^eof then call write_output;
	     end;

	     return;
end copy_one_file;
%page;
copy_one_job: proc;
dcl  first_card               bit (1) aligned;

	     eof, eoj = "0"b;
	     first_card = "1"b;

	     do while (^eoj);

		if ^first_card then
		     eoj = check_for_eoj ();
		else first_card = "0"b;
		if ^eof then			/* if there is a card there */
		     if ^no_end_card then		/* and its not the first card of the next job, write it */
			call write_output;		/* first card ( $ snumb) was read by find_list_item */
		if ^eoj then call read_and_convert_input;
	     end;

end copy_one_job;
%page;
cv_bin_to_bcd: proc (input_ptr, output_ptr);
dcl (
     direction,					/* direction of half-interval search */
     i,						/* loop index */
     interval,					/* increment for half-interval search */
     j,						/* loop index */
     k,
     search_index					/* index into binary table */
     ) fixed bin(24)aligned;

dcl (
     input_ptr,					/* pointer to binary data (argument) */
     output_ptr					/* pointer to bcd output (argument) */
     ) ptr aligned;

dcl (
     bad_card,					/* turned on if a bad char is found */
     bin_char_not_found				/* ON until bin_table search is successful */
     ) bit (1) aligned;


dcl (
     divide
     ) builtin;


dcl 1 bcd_chars aligned based (output_ptr),		/* bcd output structure */
    2 bcd_char (0:79) bit (6) unaligned;

dcl  bin_char                 (0:79) bit (12) unaligned based (input_ptr)	/* mask for looking at binary input */;
dcl  this_char                bit (12) aligned	/* copy char to aligned string to avoid hardware bug in cmpb */;


/* perform conversion */

	     bad_card = "0"b;

cv_card:	     do i = 0 to 79;			/* convert 80 characters */

		this_char = bin_char (i);		/* copy to aligned string to avoid hardware bug */
		if this_char = "0"b			/* make quick check for blank */
		then bcd_char (i) = bcd_blank;

		else				/* not binary blank */
translate_char:	do;

		     direction = 1;			/* set up half-interval search */
		     interval = 32;
		     search_index = 0;
		     bin_char_not_found = "1"b;

search_table:	     do j = 1 to 6 while (bin_char_not_found);

			search_index = search_index + direction*interval; /* compute index into binary table */

			if this_char = bin_table (search_index) /* match found */
			then do;
			     bcd_char (i) = bcd_table (search_index); /* set bcd character */
			     bin_char_not_found = "0"b;
			end;

			else			/* not a match */
			do;
			     if this_char > bin_table (search_index) /* set direction of search increment */
			     then direction = 1;
			     else direction = -1;
			     interval = divide (interval, 2, 17, 0); /* set search increment magnitude */
			end;

			end search_table;

		     if bin_char_not_found then	/* no match found */
illegal_char:		do;			/* not a GEBCD card code */

			bcd_char (i) = bcd_blank;	/* leave column blank */
			if ^bad_card then do;	/* if first bad char on card */
			     bad_card = "1"b;	/* remembr it */
			     raw_cards_bad = raw_cards_bad + 1; /* count cards */
			end;

			raw_chars_bad = raw_chars_bad + 1; /* count bad characters */

			if ^input.brief then do;	/* tell user what's wrong, unless told not to */

			     punches = "";		/* clear the string first */

			     do k = 1 to 12;	/* then tell user which rows were punched */
				if substr (this_char, k, 1) then /* if this row punched */
				     punches = punches || punch (k); /* add row number to string to be printed */
			     end;
			     substr (punches, 1, 1) = " "; /* get rid of leading "-" */
			     call ioa_ ("^a: raw card ^d, column ^d - not GEBCD punch:^a^/Processing continues.",
				me, input_block_count, i+1, punches);
			end;
		     end illegal_char;


		end translate_char;

	     end cv_card;

	     return;
end cv_bin_to_bcd;
%page;
fatal_error: proc (error_code);

dcl  error_code               fixed bin(24);		/* identifies the place where the error occurred.  Each call
						   has a different number, even if the message is the same.
						   The first 58 are in order in the program. Those above 58
						   were added later and are out of order. */
dcl  fixed_in_db              bit (1) aligned init ("0"b);
dcl  max_error_code           fixed bin(24)init (61)	/* next available code is 62 */;
dcl (err_msg, msg2) char (200) varying init ("");

	     if ^input.com_err then goto set_code;	/* print only if caller said to */

	     if error_code < 1 | error_code > max_error_code then do;
		err_msg = "Program error - bad internal error code: ^s^d";
		err_num = error_code;
		goto call_com_err;
	     end;

	     goto err (error_code);

err (1): err (44): err (55):
	     err_msg = "Invalid input arguments.";
	     goto call_com_err;

err (2):
	     err_msg = "ASCII character without BCD equivalent in the above value from the command line.";
	     goto call_com_err;

err (3):
	     err_msg = "Program error - converting numeric to BCD for tape label.";
	     goto call_com_err;

err (4):
	     err_msg = "No activity card before data cards in ^a.
Must give either -tabs or -no_canonicalize.";
	     goto call_com_err;

err (5):
	     err_msg = "Backspace not immediately preceeded by tab, in ^a, line ^d";
	     goto set_line_no;

err (6): err (41):
	     err_msg = "Line > 80 characters and -truncate not given:
^a, line ^d.";
	     goto set_line_no;

err (7):
	     err_msg = "File mark where trailer label expected, on ^a ^s^a";
	     goto call_com_err;

err (8):
	     err_msg = "Data record where trailer label expected, on ^a ^s^a";
	     goto call_com_err;

err (9):
	     err_msg = "Bad trailer label on ^a ^s^a";
	     goto call_com_err;

err (10):
	     err_msg = "Expected filemark after trailer not found on ^a ^s^a";
	     goto call_com_err;

err (11): err (14):
	     err_msg = "From ios_$detach ^a";		/* detaching input or output file - not tape */
	     goto call_com_err;
err (12):
	     err_msg = "While backspacing over partial label on ^a ^s^a ^a";
	     goto call_com_err;

err (13):
	     err_msg = "While positioning to partial label on ^a ^s^a ^a";
	     goto call_com_err;

err (15):
	     err_msg = "End of file in middle of comdk: ^a, BCD card ^d";
	     goto set_line_no;

err (16):
	     err_msg = "Non-comdk card in middle of comdk: ^a, BCD card ^d";
	     goto set_line_no;

err (17): err (22):
	     err_msg = "Comdk sequence number error: ^a, BCD card ^d";
	     goto set_line_no;

err (18):
	     err_msg = "Null comdk card: ^a, BCD card ^d";
	     goto set_line_no;

err (19): err (23):
	     err_msg = "Bad comdk field length: ^a, BCD card ^d";
	     goto set_line_no;

err (20):
	     err_msg = "Bad comdk string length: ^a, BCD card ^d";
	     goto set_line_no;

err (21):
	     err_msg = "Comdk field > remainder of BCD card: ^a, BCD card ^d";
	     goto set_line_no;

err (24): err (27):
	     err_msg = "From ios_$attach ^a";
	     goto call_com_err;

err (25): err (28):
	     err_msg = "From ios_$setsize ^a";
	     goto call_com_err;

err (26):
	     err_msg = "From ios_$setdelim ^a";
	     goto call_com_err;

err (29):
	     err_msg = "From ios_$tell last ^a";
	     goto call_com_err;

err (30):
	     err_msg = "From ios_$seek last first ^a";
	     goto call_com_err;

err (31):
	     err_msg = "Program error - unable to append to existing gcos file ^a";
	     goto call_com_err;

err (32):
	     err_msg = "While rewinding ^a ^s^a ^a";
	     goto call_com_err;

err (33):
	     err_msg = "Unexpected filemark read while positioning ^a (file number ^d) ^a";
	     goto call_com_err;

err (34):
	     err_msg = "While positioning ^a (file number ^d) ^a ^a";
	     goto call_com_err;

err (35):
	     err_msg = "Partial label (end of information) read while positioning ^a ^s^a";
	     goto call_com_err;

err (36):
	     err_msg = "Expected header label not found, while positioning ^a ^s^a";
	     goto call_com_err;

err (37):
	     err_msg = "End of reel label (file continued on another reel) read while positioning ^a ^s^a";
	     goto call_com_err;

err (38):
	     err_msg = "Expected trailer label not found, while positioning ^a ^s^a";
	     goto call_com_err;

err (39):
	     err_msg = "Program error while positioning ^a ^s^a";
	     goto call_com_err;

err (40):
	     err_msg = "No newline for over 1280 characters - not an ASCII file: ^a, line ^d";
	     goto set_line_no;

err (42):
	     err_msg = "ASCII character without BCD equivalent: ^/^a, line ^d";
	     goto set_line_no;

err (43):
	     err_msg = "BCD card record > 18 words: ^a, card ^d";
	     goto set_line_no;

err (45): err (46):
	     err_msg = "From ios_$read:";
	     goto set_block_no;

err (47):
	     err_msg = "Read error - wrong number of elements read:";
	     goto set_block_no;

err (48):
	     err_msg = "Read error - zero length block:";
	     goto set_block_no;

err (49):
	     err_msg = "Bad length in block control word:";
	     goto set_block_no;

err (50):
	     err_msg = "Error while deblocking - bad block or record control word:";
	     goto set_block_no;

err (51): err (52):
	     err_msg = "From ios_$write";
	     goto set_out_block_no;

err (53):
	     err_msg = "Write error - wrong number of elements written:";
	     goto set_out_block_no;

err (54):
	     err_msg = "Program error - attempt to write GCOS record > 319 words into";
	     goto set_out_block_no;

err (56):
	     err_msg = "Program error - bad record length or media code for raw output file: ^a, card ^d";
	     err_num = output_block_count;
	     goto call_com_err;

err (57):
	     err_msg = "While writing filemark on ^a ^s^a ^a";
	     goto call_com_err;

err (58):
	     err_msg = "While writing label on ^a ^s^a ^a";
	     goto call_com_err;

err (59):
	     err_msg = "Program error - while encoding output comdk.";
	     goto call_com_err;

err (60):
	     err_msg = "Expected filemark after last block of unlabeled tape file not found on ^a^s^a";
	     goto call_com_err;

err (61):
	     err_msg = "While skipping to trailer label.";
	     goto set_block_no;

set_block_no:
	     err_num = input_block_count;
	     goto set_block_msg;

set_out_block_no:
	     err_num = output_block_count;
	     goto set_block_msg;

set_block_msg:
	     err_msg = err_msg || " ^a, block ^d ^s^a";
	     goto call_com_err;

set_line_no:
	     err_num = file_record_count;

	     if input.set = library then
		msg2 = " edit name = ";
	     else if input.set = imcv then
		msg2 = " snumb = ";
	     else goto call_com_err;

	     msg2 = msg2 || item_name;
	     err_msg = err_msg || " ^a";		/* add control to print msg2 */

call_com_err:
	     call com_err_ (code, me, err_msg, io.file_name, err_num, msg2, tape_status_message);

	     if input.debug then do;
		call ioa_ ("error number gcu_^d", error_code);
		call ioa_ ("CALLING DB");
		call db;

		if fixed_in_db then return;
	     end;
set_code:	     if code = 0 then code = error_table_$action_not_performed;
	     goto cleanup_and_return;

end fatal_error;
%page;
find_list_item: proc;				/* procedure to find the next $ GMAP, $ 355MAP, $ OBJECT
						   $ FORTRAN, $COBOL, or $ SNUMB card
						   that has one of the selected item names on it */

dcl  i                        fixed bin(24);
dcl  saved_comdk_sw           bit (1) aligned;

	     saved_comdk_sw = input.comdk;		/* save value of comdk switch */
	     input.comdk = "0"b;			/* and turn it off, to save the cost of
						   uncoming decks that are not being copied */
	     just_looking = "1"b;			/* suppress the "bin cards skipped" messages */
	     if no_end_card then do;			/* if no end card in previous item  */
		no_end_card = "0"b;			/* we already have one of the key cards in the buffer */
		if output.format = ascii | output.gcos_ascii then goto have_aci; /* so go look at it */
		else goto have_bcd;			/* in ascii or bcd, as the case may be */
	     end;

find_item_read: call read_and_convert_input;		/* read next record */
	     if eof then do;
		input.comdk = saved_comdk_sw;		/* possible multiple file input */
		just_looking = "0"b;		/* so clean up */

		if looking_for_first_line then	/* if we never found the -first card */
		     if saved_comdk_sw then		/* and we were not uncompressing */
			call ioa_ ("^a: Warning: comdks were NOT being uncompressed during the
search for card ^d, resulting in a lower card count than you expected", me, input.first_line);
		return;
	     end;

	     if output.format = ascii | output.gcos_ascii then do; /* ASCII card */
		if substr (ascii_card, 1, 1) ^= "$" then /* if not a dollar card */
		     goto find_item_read;		/* go read the next one */
		do i = first_key to last_key;		/* these indices select either:
						   1) $ SNUMB card, or
						   2) $ GMAP, $ 355MAP, or $ OBJECT card */
		     if substr (ascii_card, 1, 15) = ascii_search_key (i) then /* if this is one of those cards */
			goto have_aci;		/* go get the name off it */
		end;				/* if we fall thru here, it is not one of they key cards */
		goto find_item_read;		/* so go read the next card */
have_aci:		item_name = substr (ascii_card, item_index, item_length); /* pick up edit name or snumb */
	     end;

	     else if gcos_record_ptr -> rcw.media_code = bcd_media_code then do; /* BCD card */
		if gcos_record_ptr -> bcd_card.column (1) ^= bcd_dollar then /* if not dollar card */
		     goto find_item_read;		/* go read next one */
		do i = first_key to last_key;		/* indices pick out either:
						   1) $ SNUMB card, or
						   2) $ GMAP, $ 355MAP, or $ OBJECT */
		     if substr (string (gcos_record), 79, 36) = bcd_search_key (i) then /* if this is one of them */
			goto have_bcd;		/* go get the name off it */
		end;				/* if we fall thru, it is not one of the key cards */
		goto find_item_read;		/* so go read the next one */
have_bcd:		item_name = "";			/* blank out ascii item name */
		do i = 0 to item_length-1;		/* and convert BCD item name to ASCII */
		     substr (item_name, i+1, 1) = xlate (fixed (gcos_record_ptr -> bcd_card.column (item_index+i)));
		end;
	     end;

	     else goto find_item_read;		/* binary card. read next one */

/* if we fall thru here, we have a key card, and we have gotten the item name from it */

	     if item_length = 5 then do;		/* if snumb card, check for short snumb */
		i = index (item_name, ",");		/* look for comma */
		if i ^= 0 then			/* if there was one */
		     substr (item_name, i) = "";	/* blank out it, and whatever follows */
	     end;

	     if input.all then goto print_being_copied;	/* if user said -all, we copy all input items */
	     do i = 1 to input.list_count		/* if not, look up this name in the input list */
						/* comparing only the first N characters of the item name */
						/* with the input list items */
		     while (input_list (i).names ^= substr (item_name, 1, input.list_name_size));
	     end;					/* where N is the length of the input list items */
						/* This is temporary until the command procedure and the input_list
						   structure in the include file can be changed to allow variable length
						   item names, longer than 4 characters (up to 8) */
	     if i = input.list_count + 1 then do;	/* if not found */
		if input.long then call ioa_ (item_name);
		goto find_item_read;		/* keep reading */
	     end;

	     input_list (i).used = "1"b;		/* keep track of which ones we found,
						   for later error message printing */
						/* It might be good to add code to check for
						   a name appearing more than once in the input file,
						   and warn the user, and ask if it should be copied again */

print_being_copied: if input.long | output.long then call ioa_ ("^a  being copied", item_name);

	     input.comdk = saved_comdk_sw;
	     just_looking = "0"b;

	     return;				/* we found one */

end find_list_item;
%page;
get_comdk: proc (record_ptr, record_len);

dcl  fb_temp                  fixed bin(24);
dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;

	     record_len = 14;			/* we will always return a bcd card */
	     record_ptr = bcd_work_area_ptr;		/* in the work area reserved for us */
	     word_string_len = 14;			/* move 14 words */
	     addrel (record_ptr, 1) -> word_string =	/* into the work area */
		addr (bcd_blank_card) -> word_string;	/* initializing it to 80 bcd blanks */
	     bcd_col_index = 1;			/* start filling in card at col 1 */

uncom_loop:    if field_len = 0 then do;		/* end of comdk card - read next one */
		call read_record (comdk_card_ptr, fb_temp);
		if eof then call fatal_error (15);	/* eof in middle of comdk */
		if (fb_temp ^= 27 & fb_temp ^= 24)	/* if not proper length */
		| comdk_card.col1 ^= comdk_col_1	/* or not comdk code in col 1 */
		then call fatal_error (16);		/* non-comdk card in comdk */
		fb_temp = fixed (comdk_card.seq_no);
		if fb_temp ^= prev_comdk_seq_no + 1 then
		     call fatal_error (17);		/* bad comdk sequence number */
		prev_comdk_seq_no = fb_temp;
		field_len = fixed (comdk_card.char (1));
		if field_len = 0 then
		     call fatal_error (18);		/* null comdk card */
		comdk_char_index = 2;
	     end;


	     if field_len = 63 then do;		/* end of bcd card */
		field_len = fixed (comdk_card.char (comdk_char_index)); /* get next field length */
		comdk_char_index = comdk_char_index + 1;
		if field_len = 62 then do;		/* end of this comdk */
		     if comdk_error_count >0 then
			call ioa_ ("^d field length errors", comdk_error_count);
		     if input.set = library then
			call ioa_ ("(in ^a)", item_name);
		     input_comdk_open = "0"b;		/* so don't come here next time */
		end;
		return;
	     end;


	     if field_len > 55 then
		call fatal_error (19);		/* bad comdk field length */

	     string_len = fixed (comdk_card.char (comdk_char_index)); /* this string length */
	     comdk_char_index = comdk_char_index + 1;
	     if comdk_char_index + string_len > 132 then	/* first char after string */
		call fatal_error (20);		/* comdk string runs off comdk card */
	     if bcd_col_index + field_len > 85 then do;
		if input.debug then do;
		     comdk_error_count = comdk_error_count + 1;
		     if ^input.brief then do;
			call ioa_ ("Illegal comdk: field runs off end of BCD card");
			call ioa_ ("comdk card number ^d, character ^d is field length of ^d",
			     prev_comdk_seq_no, comdk_char_index-2, field_len);
			call ioa_ ("BCD card number ^d, column ^d is next col to fill",
			     file_record_count, bcd_col_index);
			call ioa_ ("Skipping field and blanking rest of BCD card");
		     end;
		     goto next_string;
		end;
		else call fatal_error (21);		/* comdk field runs off bcd card */
	     end;

	     bcd_col_index = bcd_col_index + field_len - string_len; /* move past blanks */
	     bit_string_len = string_len*6;		/* string length in bits, for move */
						/* move the string into the bcd card */
	     addr (bcd_card.column (bcd_col_index)) -> bit_string =
		addr (comdk_card.char (comdk_char_index)) -> bit_string;

	     bcd_col_index = bcd_col_index + string_len;	/* next vacant column */
next_string:   comdk_char_index = comdk_char_index + string_len; /* index of next field length */
	     field_len = fixed (comdk_card.char (comdk_char_index)); /* next field length */
	     comdk_char_index = comdk_char_index + 1;	/* next item on comdk card */
	     goto uncom_loop;


end get_comdk;
%page;
interpret_tape_status: proc;

	     if substr (status, 1, 3) = "100"b then do;	/* if this is hardware status, decode it */
		if substr (status, 27, 4) = "0100"b	/* major status End of File */
		& (substr (status, 31, 6) = "001111"b	/* EOF 7track */
		| substr (status, 31, 6) = "010011"b)	/* EOF 9track */
		then file_eof = "1"b;

		else call decode_nstd_status_ (status, tape_status_message);

	     end;					/* if not hardware status, just return */

	     return;

end interpret_tape_status;
%page;
julian_day: proc (month, dom, year) returns (fixed bin);

dcl  mlen                     (12) fixed bin(24)int static init (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
dcl (i, month, dom, year, jday) fixed bin(24);

	     jday = 0;
	     do i = 1 to month-1;			/* add up days in preceeding months */
		jday = jday+mlen (i);
	     end;
	     jday = jday + dom;			/* add date in this month */
	     if month > 2 then			/* if March or later */
		if mod (year, 4) = 0 then		/* and this is leap year */
		     jday = jday + 1;		/* add in Feb 29 */
	     return (jday);
end julian_day;
%page;
make_gcos_record:	proc;				/* come here to build gcos records */

		gcos_record_ptr = gcos_work_area_ptr;	/* build record in gcos_work_area */

		if output.gcos_ascii then do;

		     char_string_len = ascii_line_len;	/* length of ascii char string to move */
		     addrel (gcos_record_ptr, 1) -> char_string = ascii_card; /* move it into gcos record */

		     i = mod (char_string_len, 4);	/* number of chars in partially filled word */
		     if i ^= 0 then do;		/* if there is a partially filled word */
			i = 4-i;			/* compute number of pad characters needed to fill it out */
			char_string_len = char_string_len + i; /* lengthen string by that much */
			substr (addrel (gcos_record_ptr, 1) -> char_string, ascii_line_len+1, i) =
			     substr (ascii_pads, 1, i);
		     end;				/* and move in the pad characters */

		     gcos_record.rcw = ""b;		/* clear the rcw, and fill in some fields */
		     gcos_record_len = divide (char_string_len, 4, 17, 0); /* word length of record */
		     gcos_record_ptr -> rcw.length = bit (fixed (gcos_record_len, 18)); /* into rcw */
		     gcos_record_ptr -> rcw.media_code = ascii_media_code; /* media code = 6 */

		     if i ^= 0 then do;		/* if last word is partially filled */
			i = 4-i;			/* get back the number of chars in it */
			substr (gcos_record.rcw, 19, 2) = bit (bin (i, 2)); /* and put it in the rcw, in a new field
						   that used to be part of the eof indicator */
		     end;

		end;

		else do;				/* regular BCD record wanted */

		     gcos_record_len = 14;		/* fixed bin(24)copy of rcw.length */
		     gcos_record.data_words = bcd_b6;	/* fill with BCD spaces */
		     call gcos_cv_ascii_gebcd_check_
			(ascii_line_ptr, ascii_line_len, addrel (gcos_record_ptr, 1), code);
		     if code ^= 0 then do;
			call ioa_ ("Error on character ^d of:^/^a", code, ascii_card);
			code = 0;			/* code is position of bad char - not error table code */
			call fatal_error (42);
		     end;

		     gcos_record.rcw = bcd_rcw;

		end;

	     return;
end make_gcos_record;
%page;
open_comdk_input: proc (record_ptr, record_len);

dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;

	     comdk_error_count = 0;
	     input_comdk_open = "1"b;			/* remember that comdk is open */
	     comdk_card_ptr = record_ptr;		/* point to first comdk card */
	     prev_comdk_seq_no = fixed (comdk_card.seq_no);
	     if prev_comdk_seq_no ^= 1 then
		call fatal_error (22);		/* bad initial comdk seq no */
	     field_len = fixed (comdk_card.char (1));	/* first field len */
	     if field_len < 1 | field_len > 55 then
		call fatal_error (23);		/* bad initial comdk field len */
	     comdk_char_index = 2;			/* since we got char 1 above */
	     bcd_work_area_ptr -> gcos_record.rcw = bcd_rcw; /* initialize the rcw */


	     return;


end open_comdk_input;
%page;
open_comdk_output: proc;

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

	     string (k_card) = ""b;			/* clear the 28 word buffer used to build comdk cards */

	     k_card.rcw = bin_rcw;			/* rec len = 27, media code = 1 */
	     k_card.col1 = comdk_col_1;		/* 5005 octal (12-0-7-9 punch) */
	     comdk_out_index = 1;			/* start with first char on output card */

	     k_card.seq_no = bit (bin (1, 24));		/* fixed bin(24)24 constant 1 */

/* Initialize sequence columns (73-80) to "EEEE0000" where EEEE is the first 4 characters of the edit name */

	     if input.set = library then
		edit_name = substr (item_name, 1, 4);
	     else if input.medium = tape then
		edit_name = "....";
	     else do;				/* get an edit name from the file name */
		i, j = 1;				/* don't want it to be ">udd", so find entry name */
find_edit_name:
		j = index (substr (input.file_name, i), ">"); /* look for another ">" */
		if j ^= 0 then do;			/* found one */
		     i = i + j;			/* move past it */
		     goto find_edit_name;
		end;
		edit_name = substr (input.file_name, i, 4);
	     end;

	     unspec (bcd_edit_name) = bcd_string (edit_name, 4); /* convert edit name to bcd */
	     do i = 1 to 4;				/* use numeric value of bcd character as index into table */
		k_card.seq_col (i) = raw_table (fixed (bcd_edit_name (i))); /* of card punch patterns for those chars */
	     end;

	     do i = 5 to 8;				/* initialize col 77-80 to zeros */
		k_card.seq_col (i) = raw_table (0);
		seq_col (i) = 0;			/* fixed bin(24)copy of 77-80, for incrementing */
	     end;

	     output_comdk_open = "1"b;

	     return;


end open_comdk_output;
%page;
open_input: proc;

	     io_ptr = input_ptr;			/* for position tape, and to tell which file, if error */

	     if input.medium = tape then do;		/* the tape will already be attached */

		input_stream_name = tape_stream (input.sw);

		element_size = 36;
		elements_wanted = 320;
		call position_tape;			/* reads and verifies labels */

	     end;					/* end open tape */

	     else do;

		input_stream_name = file_stream (input.sw);

		call ios_$attach (input_stream_name, "file_", input.file_name, "r", status);
		if code ^= 0 then call fatal_error (24);

		if input.medium = raw then do;
		     element_size = 960;		/* 12 rows X 80 columns */
		     elements_wanted = 1;

		     input_block_ptr = addrel (gcos_work_area_ptr, 1); /* read directly into the record, after the rcw */

/* by reading the record directly into gcos_work_area, we save copying it later */
/* input_block_ptr tells ios_$read where to put the input */

		end;

		else if input.format = ascii then do;
		     element_size = 9;		/* the default - set in case changed previously */
		     elements_wanted = 1280;		/* the buffer size */
		end;

		else do;				/* all other possibilities */
		     element_size = 36;		/* one word */
		     elements_wanted = 320;		/* one block */
		end;

		call ios_$setsize (input_stream_name, element_size, status);
		if code ^= 0 then call fatal_error (25);

	     end;					/* end open non tape */

	     if input.format = ascii then do;

		if ^input.no_canon then		/* if we are going to call canonicalizer */
		     tabstop_ptr = addr (gcos_control_tables_$tabstops); /* get pointer to tab table */
						/* by waiting to do it now,
						   we avoid initiating segment gcos_control_tables_ in
						   cases where we are not going to use anything in it */

		call ios_$setdelim (input_stream_name, 1, unspec (ascii_newline), 1, unspec (ascii_newline), status);
		if code ^= 0 then call fatal_error (26);
						/* we had to set the delimiter back to newline, since the
						   ios_$setsize call removes the default delimiter */

	     end;

	     file_eob = "1"b;			/* always read a block on first read call */
	     file_eof = "0"b;			/* not eof 'til we read an eof */
	     rcw_eof = "0"b;
	     found_last_line = "0"b;

	     looking_for_first_line, looking_for_last_line = "0"b;
	     if input.first_line > 0 then
		looking_for_first_line = "1"b;

	     else					/* don't start looking for last line til first line found */
	     if input.last_line > 0 then
		looking_for_last_line = "1"b;

	     tape_status_message = "";

	     if input.long then
		call ioa_ ("^a being read", input.file_name);

	     return;

end open_input;
%page;
open_next_input: proc;

	     next_input_index = next_input_index + 1;
	     input.file_name = input_list (next_input_index).names;
	     call open_input;
	     input_list (next_input_index).used = "1"b;
	     file_record_count = 0;			/* causes -first, -last, -count to be
						   applied separately to each input file */

	     return;

end open_next_input;
%page;
open_next_output: proc;

	     next_output_index = next_output_index + 1;

	     if next_output_index > output.list_count then do;
		if ^input.brief then do;
		     io_ptr = input_ptr;
		     call report_missing_items;
		end;
		goto cleanup_and_return;
	     end;

	     if output.name_files then do;
		if index (substr (item_name, 1, item_length), " ") > 1 then
		     output.file_name = before (item_name, " ")||next_output_suffix;
		else output.file_name = substr (item_name, 1, item_length)||next_output_suffix;
	     end;
	     else do;
		output.file_name = output_list (next_output_index).names;
		output_list (next_output_index).used = "1"b;
	     end;

	     call open_output;

	     return;


end open_next_output;
%page;
open_output: proc;

	     io_ptr = output_ptr;			/* for position_tape, and to tell which file, if error */

	     if output.medium = tape then do;

		output_stream_name = tape_stream (output.sw);

/* tape is already attached */

		call position_tape;

		if ^no_label (io.sw) then do;		/* if labeled tape, build and write header label */
		     label_ptr = write_buffer_ptr;	/* build it in the write buffer */
		     unspec (header_label) = ""b;	/* clear it first */

		     header_label.btl = bcd_btl;	/* GE/b/b600/bBTL/b */

		     call system_info_$installation_id (inst); /* get installation id */
		     header_label.installation = bcd_string (inst, 6); /* first 6 chars of it in BCD */

		     header_label.reel_ser_no = bcd_b1; /* blank first char */
		     substr (header_label.reel_ser_no, 7, 30) = bcd_string (string (output_tape.id), 5);
						/* ser no in last 5 chars */

		     header_label.file_ser_no = header_label.reel_ser_no; /* always the same for single reel files */

		     header_label.reel_seq_no = bcd_b2; /* blank first 2 chars */
		     substr (header_label.reel_seq_no, 36, 1) = "1"b; /* last 24 bits are the fixed binary number 1 */

		     header_label.creation_date = bcd_b1; /* blank first char */
		     call decode_clock_value_ (clock_ (), month, dom, year, tod, dow, zone); /* get date */
		     substr (header_label.creation_date, 7, 12) = bcd_string_bin (mod (year, 100), 2);
						/* last 2 digits of year, in BCD */
		     substr (header_label.creation_date, 19, 18) = bcd_string_bin (julian_day (month, dom, year), 3);
						/* 3 digit julian day, in BCD */

		     header_label.retention_days = bcd_b3; /* first 3 chars blank */
						/* last 3 all zero - no retention days */

		     header_label.file_name = bcd_string (string (output_tape.label), 12);

		     header_label.prverr = bcd_b6;	/* 6 BCD blanks */

		     word_string_len = 14;		/* length of label */
		     addr (saved_header_label) -> word_string = addr (header_label) -> word_string;
						/* save it to use for building partial label later */
						/* use word_string overlay, since structure assignment
						   compiles into element-by-element assignment */

		     call write_tape_label;		/* write label and eof, checking error codes */
		end;				/* end of labeled tape do group */

	     end;

	     else do;

		output_stream_name = file_stream (output.sw);

		call ios_$attach (output_stream_name, "file_", output.file_name, "rw", status);
						/* attach in "rw" mode, to allow reading to end of file
						   to be appended to, if there is one */
		if code ^= 0 then call fatal_error (27);

/* set element size */

		if output.medium = raw then
		     element_size = 960;

		else if output.format = ascii then
		     element_size = 9;

		else
		element_size = 36;

		call ios_$setsize (output_stream_name, element_size, status);
		if code ^= 0 then call fatal_error (28);


		call ios_$tell (output_stream_name, "last", "first", offset, status);
		if code ^= 0 then call fatal_error (29);

		appending_to_output = "0"b;		/* initialize switch to off */
		if offset ^= 0 then			/* if output seg has something in it already */
		     if output.append then		/* and user said -append */
			appending_to_output = "1"b;	/* then remember to do so */

		     else do;			/* else ask what to do */
			call command_query_ (addr (query_info), answer, me,
			     "^a already exists. Do you want to overwrite it?", output.file_name);

			if answer = "no" then goto cleanup_and_return;

			else do;			/* truncate the output file */
			     call ios_$seek (output_stream_name, "last", "first", 0, status);
			     if code ^= 0 then call fatal_error (30);
			end;

		     end;				/* end ask user about existing file */
	     end;					/* end attach non tape */

	     if output.medium ^= raw then
		if output.format ^= ascii then
		     if output.format ^= blocks then do;

			if appending_to_output then do;

			     call ios_$read (output_stream_name, gcos_record_ptr, 0, 320, gcos_record_len, status);
			     return;
			end;

			else do;
			     remaining_output_words = 319;
			     output_word_ptr = addrel (write_buffer_ptr, 1);
			     block_serial_number = 1;
			     write_buffer_ptr -> bcw.bsn = bit (fixed (block_serial_number, 18));
			     output_block_len = 0;	/* fixed bin(24)copy of bcw.length */
			     write_buffer_ptr -> bcw.length = (18)"0"b;

			     if output.gcos_ascii then do; /* write an empty 20-word record at the start of a gcos
						   ascii file to be compatible in format with the real gcos */
				output_block_len = output_block_len + 21; /* 20 words plus rcw */
				write_buffer_ptr -> bcw.length = bit (bin (output_block_len, 18));
				output_word_ptr -> word_string (1) = ascii_header_rcw;
				output_word_ptr = addrel (output_word_ptr, 21);
				remaining_output_words = remaining_output_words - 21;
			     end;

			end;

		     end;

	     tape_status_message = "";

	     if output.long then
		call ioa_ ("^a being written", output.file_name); /* print file name or tape message */

	     return;

end open_output;
%page;
position_tape: proc;

dcl  expected_input           fixed bin(24)/* next thing expected from tape */;
dcl (header init (1),				/* names for things expected from tape */
     trailer init (2),
     eof_after_header init (3),
     eof_after_trailer init (4),
     eof_after_forward_file init (5)
     )int static fixed bin(24);
dcl  file_number              fixed bin(17)init (0);
dcl  position_found           bit (1) aligned init ("0"b);	/* to remember that we found the position,
						   while we are reading past the eof mark after a label */
dcl  ascii_file_name          char (12) aligned;
dcl  ascii_ser_no             char (5) aligned;
dcl  i                        fixed bin(24);

dcl 1 hdr aligned based (label_ptr),			/* overlay for header label */
    2 fill1 (3) bit (36) aligned,			/* to pick up chracters in reel_ser_no and file_name */
    2 ser (0:5) bit (6) unaligned,			/* one at a time */
    2 fill2 (4) bit (36) aligned,
    2 fname (12) bit (6) unaligned;			/* don't care about rest of it */

dcl 1 tape_message aligned based (addr (io.file_name)),
   (2 io_name char (6),
    2 b1 char (1),
    2 tape char (4),
    2 b2 char (1),
    2 tape_id char (5),
    2 b3 char (1),
    2 file char (4),
    2 b4 char (1),
    2 fileno char (3),
    2 b5 char (1),
    2 filename char (12)) unaligned;

/* Put tape information into io.filename, for convenience of message printing */
	     io.file_name = "";
						/* tape_message overlays beginning of io.file_name */
	     tape_message.tape = "tape";
	     tape_message.io_name = substr (io_names (io.sw), 1, length (tape_message.io_name)); /* "input" or "output" */
	     tape_message.tape_id = substr (io_tape.id, 1, length (tape_message.tape_id));


/* Check for nothing to do */
	     if io_tape.position = 0 then do;		/* if user did not give position */
		if io.sw = output_code then return;	/* use current position for output */
		else if no_label (io.sw) then return;	/* do the same for input, if there are no labels */
		else if io_tape.label = "" then	/* or, if input file name not given */
		     goto omit_rewind;		/* just read past the header label */
	     end;

/* Rewind tape */
	     call ios_$order ((tape_stream (io.sw)), "rewind", null, status);
	     if code ^= 0 then
		call fatal_error (32);		/* error rewinding tape */
	     if io.sw = output_code | no_label (io.sw) then
		if io_tape.position = 1 then goto set_fileno; /* we are already there */
omit_rewind:					/* come here to just read past header label of current file */

/* Initialize for search loop */
	     label_ptr = input_block_ptr;
	     if no_label (io.sw) then do;		/* if unlabeled tape */
		expected_input = eof_after_forward_file; /* just skip to requested position */
		file_number = 1;			/* we are already at first file */
	     end;

	     else expected_input = header;

/* Search loop */
position_loop: file_eof = "0"b;
	     err_num = file_number;			/* in case of error while positioning */

	     if expected_input = eof_after_forward_file then /* skip over data records */
		call ios_$order ((tape_stream (io.sw)), "forward_file", null, status);
	     else					/* just read labels and eof marks */
	     call ios_$read ((tape_stream (io.sw)), input_block_ptr, 0, elements_wanted, input_block_len, status);

	     if code ^= 0 then do;

		call interpret_tape_status;		/* check for eof or other error */

		if file_eof then do;		/* eof mark read */

		     if expected_input = eof_after_forward_file then do;
			if ^no_label (io.sw) then	/* unless this is an unlabeled tape, */
			     expected_input = trailer; /* the next thing will be a trailer label */

			else do;			/* it is an unlabeled tape */
			     if io.long then	/* tell user that previous file was skipped */
				call ioa_ ("tape ^a, file ^d will be skipped", io_tape.id, file_number);
			     file_number = file_number + 1; /* increment file number */
			     if file_number = io_tape.position then /* if this is the file we want */
				goto set_fileno;	/* go put its number into message and return */
			end;

		     end;

		     else if expected_input = eof_after_trailer then
			if position_found then goto set_filename; /* positioned for writing label of output file */
			else expected_input = header;

		     else if expected_input = eof_after_header then
			if position_found then goto set_filename; /* positioned for reading input data records */
			else expected_input = eof_after_forward_file; /* skip over data records */

		     else call fatal_error (33);	/* unexpected eof while positioning tape */

		end;				/* end eof mark read */

		else call fatal_error (34);		/* io error while positioning tape */

	     end;					/* end code ^= 0 */

	     else if expected_input = header then do;	/* want header label */
		if header_label.btl = bcd_btl then do;	/* this is one */
		     expected_input = eof_after_header;
		     file_number = file_number + 1;

		     if unspec (partial_label.zero_words) = ""b then /* check for partial label */
			call fatal_error (35);	/* partial label while positioning tape */

		     if file_number = 1 then do;	/* first file on tape */
			do i = 1 to 5;		/* convert reel serial number in label to ASCII */
			     substr (ascii_ser_no, i, 1) = xlate (fixed (hdr.ser (i)));
			end;

			if substr (io_tape.id, 1, 4) = "-att" then /* if we did not know the serial no */
			     tape_message.tape_id, io_tape.id = ascii_ser_no; /* we do now */

			else do;			/* if we already knew it, verify correct tape */
			     if substr (io_tape.id, 1, 5) ^= ascii_ser_no then do; /* need substr because of possible
						   trailing ",Ntrack in id */
				call command_query_ (addr (query_info), answer, me,
				     "Label on ^a tape contains reel serial number ^a.
You specified reel ^a. Do you wish to proceed?", io_names (io.sw), ascii_ser_no, io_tape.id);
				if answer = "no" then goto cleanup_and_return;
			     end;			/* end mismatched ser nos */
			end;			/* end we already knew ser no */

		     end;				/* end file number = 1 */

		     do i = 1 to 12 ;		/* convert file name in label to ASCII */
			substr (ascii_file_name, i, 1) = xlate (fixed (hdr.fname (i)));
		     end;

		     if io_tape.position ^= 0 then do;	/* if user gave position */
			if file_number = io_tape.position then do; /* and this is it */
			     if io_tape.label ^= "" then do; /* if file name also given */
				if ascii_file_name ^= io_tape.label then do; /* compare them */
				     call command_query_ (addr (query_info), answer, me,
					"File ^d on tape ^a is named ^a.
You specified the file name: ^a. Do you wish to proceed?",
					file_number, io_tape.id, ascii_file_name, io_tape.label);
				     if answer = "no" then goto cleanup_and_return;
				     io_tape.label = ascii_file_name; /* replace given name by one from tape label */
				end;		/* end names not the same */
			     end;			/* end user gave label */

			     position_found = "1"b;

			end;			/* end this is specified position */
		     end;				/* end user gave position */

		     else do;			/* user did not give position */
						/* this has to be input */
			if io_tape.label = "" then	/* we were just reading past header label */
			     goto found_input_position; /* of current file */
			if ascii_file_name = io_tape.label then
found_input_position:	     position_found = "1"b;
		     end;

		     if io.long then do;
			if position_found then
			     answer = "copied";
			else answer = "skipped";
			call ioa_ ("tape ^a, file ^d (^a) will be ^a."
			     , ascii_ser_no, file_number, ascii_file_name, answer);
		     end;

		end;				/* end this is a header label */

		else call fatal_error (36);		/* expected header label not found */
	     end;					/* end expecting header label */

	     else if expected_input = trailer then do;
		if trailer_label.eof = bcd_beofbb then do;
		     expected_input = eof_after_trailer;
		     if io.sw = output_code then do;	/* for output, stop after trailer of previous file */
			if file_number = io_tape.position - 1 then do;
						/* if this file immediately preceeds the one to be written */
			     position_found = "1"b;
			     if io.long then
				call ioa_ ("Output will be written on tape ^a after file ^d (^a).",
				ascii_ser_no, file_number, ascii_file_name);
			end;

		     end;				/* end output */
		end;				/* end eof label */

		else if trailer_label.eof = bcd_beorbb then
		     call fatal_error (37);		/* eor label while positioning */

		else call fatal_error (38);		/* expected trailer label missing while positioning */

	     end;					/* end expecting trailer */

	     else call fatal_error (39);		/* bug in position tape */

	     goto position_loop;

set_filename:					/* put file name into tape message */
	     tape_message.filename = io_tape.label;
						/* fall thru and put file number in it too */
set_fileno:    ;
dcl p13 pic "(12)z9";
dcl 1 p13_ovl based(addr(p13))
,2 l10 char(10)unal
,2 r3  char( 3)unal
;
	     p13 = file_number;
	     tape_message.fileno = p13_ovl.r3;		/* last 3 of the 10 digits returned
						   by char for fixed bin(17) */
	     tape_message.file = "file";
	     return;

end position_tape;
%page;
process_imcv:  proc;

	     call open_input;

	     if output.set ^= multiple_files then call open_output;

/* set up parameters for find_list_item */

	     item_index = 16;			/* snumb begins in col 16 */
	     item_length = 5;			/* and can be up to 5 chars long */
	     first_key = 1;				/* look for $ SNUMB */
	     last_key = 1;				/* only */
	     eof = "0"b;

	     call copy_jobs;		/* Now do the grubby work */

	     if output.set ^= multiple_files then call close_output;

	     else if ^output.name_files then
		if next_output_index < output.list_count then
		     if ^output.brief then do;
			io_ptr = output_ptr;
			call report_missing_items;
		     end;

	     if eof then do;
		if ^input.all then
		     if list_index ^= input.list_count + 1 then
			if ^input.brief then do;
			     io_ptr = input_ptr;
			     call report_missing_items;
			end;

		if looking_for_first_line then
		     call report_suspicious_eof;
	     end;

	     call close_input;

end process_imcv;
%page;
process_library_file:    proc;

	     call open_input;
	     if output.set ^= multiple_files then call open_output;
	     eof = "0"b;


/* set up parameters for find_list_item */

	     item_index = 73;			/* edit name starts in col 73 */
	     item_length = 8;			/* and is up to 8 chars long */
	     first_key = 2;				/* look for $ GMAP (2) */
						/* $ 355MAP (3) */
						/* $ OBJECT (4) */
						/* $ FORTRAN (5) */
	     last_key = 15;				/* or $ IDS2 (15) */

copy_library_decks: do list_index = 1 to input.list_count while (^eof);

		call find_list_item;

		if ^eof
		then do;
		     if output.set = multiple_files then call open_next_output;
		     call copy_one_deck;
		     if output.set = multiple_files then call close_output;
		end;

	     end copy_library_decks;

	     if input.long then call ioa_ ("^/End of Library copy.");
	     if output.set ^= multiple_files then call close_output;

	     else if ^output.name_files then
		if next_output_index < output.list_count then
		     if ^output.brief then do;
			io_ptr = output_ptr;
			call report_missing_items;
		     end;

	     if eof then do;
		if ^input.all then			/* if all decks were not being copied */
		     if list_index ^= input.list_count + 1 then
			if ^input.brief then do;
			     io_ptr = input_ptr;
			     call report_missing_items;
			end;

		if looking_for_first_line then
		     call report_suspicious_eof;
	     end;

	     call close_input;

end process_library_file;
%page;
process_multiple_files: proc;

	     if output.set ^= multiple_files then call open_output;


copy_files:    do list_index = 1 to input.list_count;

		call open_next_input;
		if output.set = multiple_files then call open_next_output;

		call copy_one_file;

		call close_input;
		if output.set = multiple_files then call close_output;

	     end copy_files;

	     if output.set ^= multiple_files then call close_output;

	     else					/* check for all of the output files written */
	     if ^output.name_files then		/* but only if names were given */
		if next_output_index ^= output.list_count then
		     if ^output.brief then do;
			io_ptr = output_ptr;
			call report_missing_items;
		     end;

end process_multiple_files;
%page;
process_single_file: proc;

	     call open_input;
	     if output.set = multiple_files then	/* if user did a dumb thing - i.e.
						   gave several output files, but only one input file */
		call open_next_output;		/* we will be sensible, by writing into the first one,
						   instead of trying to write into a file whose name is given
						   by the garbage in an uninitialized variable */

	     else call open_output;

	     call copy_one_file;

	     call close_input;
	     call close_output;

	     if output.set = multiple_files then	/* if user did a dumb thing */
		if output.list_count > 1 then		/* and it was a very dumb thing */
		     if ^output.brief then do;	/* if he is willing to be told about it */
			io_ptr = output_ptr;	/* tell him */
			call report_missing_items;
		     end;

end process_single_file;
%page;
put_comdk: proc (record_ptr, record_len);

dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;

dcl  b_col                    fixed bin(24)/* current column from b_card */;
dcl  extra_chars              fixed bin(24)/* number of chars past the limit of 55 per field */;
dcl  field_len                fixed bin(24)/* length of compressed field, including leading blanks */;
dcl  saved_string_len         fixed bin(24)/* remember nonblank count when limit of 55 is exceeded */;
dcl  string_len               fixed bin(24)/* length of trailing nonblank string in compressed field */;
dcl  string_start             fixed bin(24)/* b_col where nonblank string starts */;
dcl 1 b_card like bcd_card aligned based (record_ptr);

dcl  blank                    bit (1) aligned	/* on if current char from b_card is blank */;
dcl  in_blanks                bit (1) aligned	/* on while in a string of 3 or more blanks */;
dcl  prev_blanks              fixed bin(24)/* counter used to find 3 or more consecutive blanks */;


	     prev_blanks, field_len, string_len = 0;
	     string_start = 1;			/* first string starts in col 1 */
	     in_blanks = "1"b;			/* to compress 1 or 2 blanks at start of card */

	     if comdk_out_index = 132 then		/* if current output card is full */
		call finish_comdk_card;		/* write it out and initialize a new one */

	     do b_col = 1 to 80;			/* scan input card for compressible fields */

		if b_card.column (b_col) = bcd_blank
		then blank = "1"b;
		else blank = "0"b;

		if ^blank then			/* if in a nonblank string */
		     if comdk_out_index > 129 then	/* but there is no room for another field */
						/* on the current output card */
			call finish_comdk_card;	/* write it out and initialize another one */

		field_len = field_len + 1;		/* add this char to length of field */

		if in_blanks then do;		/* if already in a string of blanks */
		     if ^blank then do;		/* not blank - end of blank string */
			in_blanks = "0"b;
			string_len = 1;		/* start a new nonblank string */
			string_start = b_col;	/* at this column */
		     end;
		end;				/* end of in blanks do group */

		else do;				/* not in blanks */
		     string_len = string_len + 1;	/* add this char to length of nonblank string */
		     if blank then do;		/* if this is a blank */
			if prev_blanks = 2 then do;	/* we found 3 consecutive blanks */
			     in_blanks = "1"b;
			     prev_blanks = 0;
			     if field_len > 3 then do; /* if there was a field before the blanks */
				field_len = field_len - 3; /* remove the them from it */
				string_len = string_len - 3;
				call put_comdk_string; /* and write it out */
			     end;
			     string_len = 0;	/* new field has no trailing nonblanks yet */
			     field_len = 3;		/* but it has 3 leading blanks */
			end;			/* end found 3 blanks do group */
			else
			prev_blanks = prev_blanks + 1; /* count blanks */
		     end;				/* end this is a blank do group */
		     else				/* not a blank */
		     prev_blanks = 0;		/* reset, in case 1 or 2 blanks preceeded this nonblank */
		end;				/* end not in blanks do group */

		if ^in_blanks then do;		/* we might not be in blanks now, although we were before */

		     if field_len = 56 then		/* if 1 char too many */
			if b_col = 80 then		/* but this is the last column */
						/* the check for >=57, below, will fail */
			     goto field_too_long;	/* so go write out the first 55 chars now */

		     if field_len >= 57 then do;	/* max field length is 55, but we let it go longer,
						   in case the card ends in a long string of blanks,
						   or there are 3 consecutive blanks in chars 54-57 */
field_too_long:					/* come here if 56th char is in col 80 */
			extra_chars = field_len - 55;
			call put_long_comdk_string;	/* go put out first 55 chars, and adjust for extras */
		     end;				/* end >=57 char do group */

		     if ^blank then do;		/* if no possibility of getting into blanks */
			extra_chars = string_len + 2 + comdk_out_index -132; /* check for full output card */
			if extra_chars >= 0 then do;	/* if we will fill or overfill it */
			     if extra_chars = 0 then	/* we might exactly fill the output card */
				if field_len = 56 then /* with character 56 of a field (illegal) */
				     extra_chars = 1; /* because we let it grow to 57 (see above) */
			     call put_long_comdk_string; /* go put out first 55 chars and adjust for extras */
			end;			/* end of string-fills-card do group */
		     end;				/* end of this-is-not-a-blank do group */
		end;				/* end not-in-blanks-now do group */

	     end;					/* end 1 to 80 loop on b_col */

/* Fall thru here after looking at all 80 columns */

	     if prev_blanks > 0 then do;		/* discard 1 or 2 trailing blanks */
		string_len = string_len - prev_blanks;
		field_len = field_len - prev_blanks;
	     end;

	     if string_len > 0 then			/* if the card ends in a nonblank string */
		call put_comdk_string;		/* put it out now */
	     k_card.char (comdk_out_index) = "111111"b;	/* 77 octal - end of bcd card */
	     comdk_out_index = comdk_out_index + 1;

	     return;

/* * * * * * * * * * *

   INTERNAL PROCEDURES WITHIN THIS INTERNAL PROCEDURE */

put_comdk_string: proc;

/* FOR DEBUGGING */
		if field_len > 55 then goto k_len_err;
		if string_len + 2 > 132 - comdk_out_index then
k_len_err:
		     call fatal_error (59);		/* program error while encoding output comdk */

		k_card.char (comdk_out_index) = bit (fixed (field_len, 6));
		comdk_out_index = comdk_out_index + 1;
		k_card.char (comdk_out_index) = bit (fixed (string_len, 6));
		comdk_out_index = comdk_out_index + 1;

		if string_len > 0 then do;		/* if there is a non blank string */
		     bit_string_len = string_len * 6;	/* move it as based bit string */
		     addr (k_card.char (comdk_out_index)) -> bit_string =
			addr (b_card.column (string_start)) -> bit_string;
		     comdk_out_index = comdk_out_index + string_len;
		end;

		if comdk_out_index = 132 then		/* if card completely full */
		     call finish_comdk_card;		/* write it out */
						/* however, if there is room for the end of bcd card and
						   end of deck indicators, we will put off writing it out
						   until we know if there is more data */

		return;

	     end put_comdk_string;

/* * * * * * * * * * * */

put_long_comdk_string: proc;

		field_len = field_len - extra_chars;	/* get rid of the extra chars */
		saved_string_len = string_len;	/* remember how many nonblanks there were */
		string_len = max (0, string_len - extra_chars); /* possibility of more than 55 blanks */
		call put_comdk_string;		/* put out the 55 char field */
		field_len = extra_chars;		/* the left over chars start a new field */
		string_len = min (saved_string_len, extra_chars); /* if nonblank after many blanks,
						   string_len will be 1, while extra_chars will be larger */
		string_start = b_col - string_len + 1;	/* position of first nonblank extra char */

		if comdk_out_index > 129 then		/* if there is no room for another field
						   on the current output card */
		     if string_len > 0 then		/* but we have the makings of another field */
			if prev_blanks ^= string_len then /* and there is no possibility of its being all blank */
			     call finish_comdk_card;	/* write out the current output card and initialize another */

		if ^in_blanks then do;
		     if prev_blanks = string_len then	/* if first 1 or 2 chars of left over string are blank */
			prev_blanks, string_len = 0;	/* get rid of them */
		     if string_len = 0 then		/* if there are no nonblank chars */
			in_blanks = "1"b;		/* any leading blanks get compressed out */
		     else if b_card.column (string_start) = bcd_blank then do;
			string_start = string_start + 1;
			string_len = string_len - 1;
		     end;
		end;

	     end put_long_comdk_string;


/* * * * * * * * * * * */

finish_comdk_card: proc;

dcl  i                        fixed bin(24);

		k_card.char (comdk_out_index) = "000000"b; /* end of comdk card - more to come */
		call write_comdk_card;		/* write out the card */
		string (k_card.char) = "0"b;		/* clear the 132 output characters */
		comdk_out_index = 1;		/* and start with the first one */
		k_card.seq_no = bit (fixed (1+fixed (k_card.seq_no), 24)); /* increment sequence number */

/* Increment sequence field - columns 77-80 */

		i = 8;				/* seq_col(1:8) correspond to card col(73:80) */
seq_carry:	seq_col (i) = seq_col (i) + 1;
		if seq_col (i) = 10 then seq_col (i) = 0; /* check for carry */
		k_card.seq_col (i) = raw_table (seq_col (i));
		if seq_col (i) = 0 then do;		/* if we carried 1 */
		     i = i - 1;			/* add it to the column to the left */
		     if i >= 5 then goto seq_carry;	/* but don't overflow into column 76 */
		end;

		return;
	     end finish_comdk_card;


end put_comdk;
%page;
read_and_convert_ascii: proc;

dcl  i                        fixed bin(24);

	     call read_block;

/* read_block will return file_eof when it is returning the last block.
   read_and_convert_input checks file_eof before calling us, so we do not
   have to check for eof here */

	     if input_block_len = elements_wanted then
		if substr (ascii_block, input_block_len, 1) ^= ascii_newline then
		     call fatal_error (40);		/* no newline for a long way in ascii file */

	     if substr (ascii_block, input_block_len, 1) = ascii_newline then /* if there is a trailing newline */
		input_block_len = input_block_len - 1;	/* get rid of it */

	     if input_block_len = 0 then do;		/* check for empty line */
		input_block_len = input_block_len + 1;	/* aos instead of lda sta */
		substr (ascii_block, 1, 1) = " ";	/* put in 1 blank to avoid trouble later */
	     end;

	     if input.no_canon then do;		/* if we are not canonicalizing, fix up line length here */
		if (output.gcos_ascii) | (output.format = ascii) then
		     ascii_line_len = input_block_len;	/* records are variable length */
		else do;				/* otherwise they are fixed length 80 column card images */
		     ascii_line_len = 80;
		     if input_block_len > 80 then do;	/* if input line is too long */
			if ^input.truncate_ascii then /* and user did not say truncate */
			     call fatal_error (41);	/* complain */
			input_block_len = 80;	/* else truncate */
		     end;
		end;
		ascii_card = ascii_block;		/* copy input line into work area */
	     end;					/* end no_canonicalize do group */

	     else do;				/* we are canonicalizing */
		if (output.gcos_ascii) | (output.format = ascii) then /* if variable length records */
		     ascii_line_len = length (ascii_line); /* allow max length for canonicalized line */
		else ascii_line_len = 80;		/* else make it 80 column card image */
		call canonicalizer (input_block_ptr, input_block_len, ascii_line_ptr, ascii_line_len);
		if output.gcos_ascii then do;		/* now get rid of the trailing blanks, if we
						   allowed max length for variable length line */
		     i = verify (reverse (ascii_card), " "); /* i will be position of first nonblank */
		     ascii_line_len = ascii_line_len - i + 1; /* so get rid of i-1 trailing blanks */
		end;
	     end;					/* end of canonicalize do group */


	     if output.format ^= ascii then call make_gcos_record;

	     return;

end read_and_convert_ascii;
%page;
read_and_convert_gcos: proc;

dcl  i                        fixed bin(24);
dcl  fill_index		fixed bin (24);
dcl  media_code               bit (4) unaligned;

skip_card: ;					/* come here after discarding a non-bcd card,
						   to get another card */
	     if input.comdk then call read_comdk (gcos_record_ptr, gcos_record_len);
	     else call read_record (gcos_record_ptr, gcos_record_len);

/* we now have a gcos record, complete with rcw */


	     if eof then do;			/* maybe we don't have a record... */

		if output.format = ascii | output.gcos_ascii then
		     if ^output.brief then do;

			ascii_card = "END OF FILE";	/* supply something to print, since there is no card */
			call check_bin_cards;	/* and go see if deck ended with binary cards */
		     end;

		return;

	     end;

	     media_code = gcos_record_ptr -> rcw.media_code;


	     if media_code = ascii_header_media_code then do;
		if input.long then
		     call ioa_ ("discarding gcos ascii header record");
		goto skip_card;
	     end;

	     else if media_code = ascii_media_code then do; /* if we have a gcos ascii record */
		ascii_line_len = 4*fixed (gcos_record_ptr -> rcw.length); /* record length in chars */
		if (gcos_record_ptr -> rcw.char_pos ^= 0)
		     then ascii_line_len = ascii_line_len -4 +(gcos_record_ptr -> rcw.char_pos);
		char_string_len = ascii_line_len;	/* length of string to move */
		ascii_card = addrel (gcos_record_ptr, 1) -> char_string; /* move it out of record */
		if ascii_line_len < 6		/* gotta pad first word */
		then do;
		     fill_index = ascii_line_len +1;
		     ascii_line_len = 6;
		     substr (ascii_card, fill_index, (7 - fill_index)) = " ";
		     end;
	     end;


	     if output.format = ascii | output.gcos_ascii then do;

		if (media_code = bcd_media_code) | (media_code = plain_bcd_media_code) then do; /* if bcd record */
						/* or media code = 0 */

		     if (gcos_record_len > 18) & (media_code = bcd_media_code)
			then call fatal_error (43);

		     if gcos_record_len <= 14		/* if this is an ordinary BCD card */
		     then ascii_line_len = 80;	/* make it exactly 80 columns */
		     else ascii_line_len = gcos_record_len*6; /* if BCD record is longer than a card */
		     ascii_card = "";		/* blank out 'ascii_line_len' characters
						   (the conversion routine doesn't) */

		     call gcos_cv_gebcd_ascii_ (addrel (gcos_record_ptr, 1), min (ascii_line_len, gcos_record_len*6), ascii_line_ptr);

		     if ^input.brief then call check_bin_cards; /* go see if binary cards preceeded this one */

		     if output.gcos_ascii		/* chop off trailing blanks */
		     then do;
			ascii_line_len = length (rtrim (ascii_card));
			if ascii_line_len = 0	/* but leave at least one char
						   so we don't get shot down */
			then do;
			     ascii_line_len = ascii_line_len + 1;
			     substr (ascii_card, ascii_line_len, 1) = " ";
			     end;
			call make_gcos_record;
			end;

		end;

		else if media_code ^= ascii_media_code then do; /* if not BCD or ASCII record,
						   we have to discard it on ASCII output */

		     if ^input.brief then
			if ^just_looking then	/* we skip thru comdks while looking for edit name or snumb */
			     bin_cards_skipped = bin_cards_skipped + 1;
						/* keep track of binary cards, to print in message later */

		     goto skip_card;		/* skip this binary card; go get next card */

		end;

	     end;

	     else					/* output is BCD */
	     if media_code = ascii_media_code then	/* if we have gcos_ascii input */
		call make_gcos_record;		/* go convert it to BCD */

	     return;

end read_and_convert_gcos;
%page;
read_and_convert_input: proc;				/* a call to this procedure will:
						   1) read next record from input file, whatever its type, and
						   2) convert it to proper format for output, except for
						   compressing for comdk output, which is done in write_output */

	     io_ptr = input_ptr;			/* to tell which file, if error */

read_next_record:					/* come here while searching for first line */
	     file_record_count = file_record_count + 1;
	     if looking_for_last_line then
		if file_record_count > input.last_line then do;
		     found_last_line = "1"b;
		     goto return_eof;
		end;

	     if looking_for_first_line then
		if file_record_count >= input.first_line then do;
		     looking_for_first_line = "0"b;
		     if input.last_line > 0 then
			looking_for_last_line = "1"b;
		end;

	     if file_eof then
		if file_eob then
		     if ^input_comdk_open then do;
return_eof:		eof = "1"b;
			return;
		     end;

	     if input.format = ascii then call read_and_convert_ascii;
	     else if input.format = blocks then do;
		if file_eof then do;
		     eof = "1"b;
		     return;
		end;
		call read_block;
		if input.medium = tape then
		     if file_eof then do;
			eof = "1"b;
			return;
		     end;
	     end;
	     else if input.format = gcos then call read_and_convert_gcos;
	     else call fatal_error (44);

	     input_record_count = input_record_count + 1;

	     if looking_for_first_line then
		goto read_next_record;

	     return;

end read_and_convert_input;
%page;
read_block: proc;					/* procedure to call ios_$read and interpret status code */

	     call ios_$read (input_stream_name, input_block_ptr, 0, elements_wanted, input_block_len, status);

	     input_block_count = input_block_count + 1;	/* count blocks */

	     if input.medium ^= tape then do;

		file_eof = substr (status, 46, 1);
		if code ^= 0 then call fatal_error (45);
		if file_eof
		then if output.medium = tape		/* chop off the EOF RCW if tape output */
		     then bcw_word.bcw_len = bcw_word.bcw_len - 1;
 
	     end;					/* end check non-tape status */

	     else do;

		if code ^= 0 then do;
		     file_eof = "0"b;
		     call interpret_tape_status;
		     if ^file_eof then		/* if not just end of file */
			call fatal_error (46);	/* tape read error */
		     else do;			/* skip block length checking if end of file */
			if output.medium = tape	/* chop off the EOF RCW if tape output */
			then bcw_word.bcw_len = bcw_word.bcw_len - 1;
			return;
			end;
		end;

	     end;					/* end check tape status */

	     if input.format ^= ascii
	     then if input.medium ^= tape
		then if elements_wanted ^= input_block_len
		     then call fatal_error (47);

	     if input_block_len = 0 then call fatal_error (48);

	     return;

end read_block;
%page;
read_comdk: proc (record_ptr, record_len);		/* returns a bcd or binary card in a gcos record;
						   uncompresses any comdks that it reads */

dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;


	     if input_comdk_open then call get_comdk (record_ptr, record_len); /* if already in a comdk */

	     else do;

		call read_record (record_ptr, record_len);

		if eof then return;

		if (record_len = 27|record_len = 24) then /* if the length is that of a binary card */
		     if record_ptr -> bin_card.column (1) = comdk_col_1 /* and col 1 has the comdk code in it */
		     then do;			/* then this is the start of a comdk */
			call open_comdk_input (record_ptr, record_len); /* send comdk card to open routine */
			call get_comdk (record_ptr, record_len); /* now go get first uncomed card from it */
		     end;

	     end;

	     return;

end read_comdk;
%page;
read_gcos_record: proc (record_ptr, record_len);		/* procedure to read next record from a
						   standard system format gcos file */

dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;

	     if file_eob then do;			/* if no more records in this block */


		if file_eof then do;		/* check for end of file from last read block call */
		     eof = "1"b;			/* tell caller, if eof */
		     return;			/* and return */
		end;
						/* else keep reading */
		call read_block;			/* get next block */
			/* End of file checking is made complicated by the fact that the file_ dim
			   returns an EOF status from the same call that returns the last words in the file,
			   and we have to remember that status and act on it the NEXT time we want to
			   read a block. The nstd_ dim, however, returns EOF when there are no more
			   tape records to be returned. If we are reading a tape, we have to check
			   for EOF again, now. */

		if input.medium = tape then		/* if reading tape */
		     if file_eof then do;		/* and there are no more records */
			eof = "1"b;		/* tell caller */
			return;			/* and return to him immediately */
		     end;

		remaining_block_len = fixed (input_block_ptr -> bcw.length); /* get block length */
		if remaining_block_len > 319 | remaining_block_len < 1 then call fatal_error (49);

		file_eob = "0"b;			/* remember that we got block */

		record_ptr, saved_record_ptr = addrel (input_block_ptr, 1); /* get first record */

	     end;

	     else					/* else just get next record */
	     record_ptr, saved_record_ptr = addrel (saved_record_ptr, fixed (saved_record_ptr -> rcw.length) + 1);

	     if record_ptr -> rcw.eof = bcd_eof then do;	/* check for eof record */

		rcw_eof, eof, file_eof, file_eob = "1"b; /* if so, turn on all end switches */
		return;				/* and return */
	     end;

	     record_len = fixed (record_ptr -> rcw.length); /* get record length */

	     remaining_block_len = remaining_block_len - record_len - 1; /* decrement block length */
	     if remaining_block_len < 0 then call fatal_error (50); /* should never go negative */
	     if remaining_block_len = 0 then file_eob = "1"b; /* check for end of block */

	     return;

end read_gcos_record;
%page;
read_raw_record: proc (record_ptr, record_len);		/* procedure to get next card from a raw card file,
						   and return it in a gcos standard record */


dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;

	     if file_eof then do;
		eof = "1"b;
		return;
	     end;

	     record_ptr = gcos_work_area_ptr;
	     gcos_work_area = "0"b;			/* clear work area */
	     call read_block;			/* read one 960-bit string into it, in words 2-28 */

	     if substr (gcos_work_area (2), 10, 3) = "101"b then do; /* 7-9 punch ? */
		gcos_work_area (1) = bin_rcw;		/* rcw for binary card */
		record_len = 27;
	     end;

	     else do;				/* bcd card */

		call cv_bin_to_bcd (input_block_ptr, input_block_ptr);
						/* NOTE translation in place: output is half as long as input */

		gcos_work_area (1) = bcd_rcw;		/* rcw for bcd record */
		record_len = 14;
	     end;

	     return;


end read_raw_record;
%page;
read_record: proc (record_ptr, record_len);		/* procedure to get the next gcos record;
						   decides whether to read from a gcos file, or
						   build one from the next card in a raw file;
						   comdk cards are passed to the caller unchanged */

dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;

	     if input.medium = raw then call read_raw_record (record_ptr, record_len);
	     else call read_gcos_record (record_ptr, record_len);

	     return;

end read_record;
%page;
report_missing_items: proc;

dcl  i                        fixed bin(24);

	     if io.sw = input_code then do;

		if ^eof then do;			/* must have run out of output names */
		     call ioa_ ("^a: Output list exhausted while input items remain to be copied.
The following input item(s) have not been copied:^/^a", me, item_name);
		end;
		else call ioa_ ("^a: The following input items were not found:", me);
	     end;

	     else call ioa_ ("^a: Input list exhausted while output file names remain.
The following output file(s) have not been written:", me);

	     if io.list_ptr = null then		/* must be input -all, and there is no list */
		call ioa_ ("^/And any that follow it in the input file.");

	     else do i = 1 to io.list_count;
		if ^io_list (i).used then
		     call ioa_ (io_list (i).names);
	     end;

	     return;

end report_missing_items;
%page;
report_suspicious_eof: proc;

	     call ioa_ ("^a: End of file after card ^d of ^a, while seeking card ^d", me,
		file_record_count, input.file_name, input.first_line);
	     return;

end report_suspicious_eof;
%page;
write_block: proc (block_ptr, block_len);		/* procedure to call ios_$write and interpret status code */

dcl  block_ptr                ptr;
dcl  block_len                fixed bin(24);		/* THIS block_len IS THE TOTAL NUMBER OF ELEMENTS
						   TO BE WRITTEN; FOR A GCOS BLOCK, THE CALLER MUST ADD 1
						   TO bcw.length TO OBTAIN THE CORRECT VALUE */


	/* Don't write a zero-length (BCW-only) block to a tape */

	     if output.format = ascii
	      | block_len > 1

	     then do;

		output_block_count = output_block_count + 1;
		call ios_$write (output_stream_name, block_ptr, 0, block_len, elements_written, status);

		if code ^= 0

		then do;

		     if output.medium = tape

		     then do;

			call interpret_tape_status;
			call fatal_error (51);		/* tape write error */
			end;

		     else call fatal_error (52);

		     end;

		if elements_written ^= block_len
		then call fatal_error (53);
		end;

	     return;

end write_block;
%page;
write_comdk: proc (record_ptr, record_len);

dcl  dont_compress            bit (1) aligned;
dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;

	     dont_compress = "0"b;

	     if record_ptr -> rcw.media_code ^= bcd_media_code then
		dont_compress = "1"b;		/* don't compress binary cards */
	     else					/* it is a bcd card */
	     if record_ptr -> bcd_card.column (1) = bcd_dollar then
		dont_compress = "1"b;		/* don't compress dollar cards, either */

	     if output_comdk_open then do;
		if dont_compress then do;		/* close it */
		     call close_comdk_output;
		     call write_record (record_ptr, record_len); /* and then write this record */
		end;

		else call put_comdk (record_ptr, record_len);

	     end;					/* end comdk open */

	     else do;				/* comdk not open */
		if dont_compress then
		     call write_record (record_ptr, record_len);

		else do;
		     call open_comdk_output;
		     call put_comdk (record_ptr, record_len);
		end;

	     end;					/* end comdk not open */

	     return;

end write_comdk;
%page;
write_comdk_card: proc;

dcl  checksum                 fixed bin(71);
dcl  i                        fixed bin(24);

/* compute checksum of word 1 and words 3-24 of the comdk record */

	     checksum = fixed (comdk_work_area_ptr -> gcos_record.data_words (1), 36);

	     do i = 3 to 24;
		if checksum >= 68719476736 then	/* 2**36 */
		     checksum = checksum - 68719476736 + 1; /* a carry into bit 37 gets added to bit 1 */
		checksum = checksum + fixed (comdk_work_area_ptr -> gcos_record.data_words (i), 36);
	     end;
						/* NOTE: a carry into bit 37 when the LAST word is added
						   is ignored and not added to bit 1 - this is apparently
						   the way GEFRC does it, so we will do the same */

/* put checksum into record */
	     k_card.checksum = bit (fixed (checksum, 36));

/* write it out */
	     call write_record (comdk_work_area_ptr, 27);

	     return;

end write_comdk_card;
%page;
write_gcos_record: proc (record_ptr, record_len);

dcl  record_ptr               ptr;
dcl  record_len               fixed bin(24);		/* THIS record_len INCLUDES THE RCW; THE CALLER MUST ADD 1
						   TO rcw.length TO OBTAIN THE CORRECT VALUE */
dcl  block_len                fixed bin(24)/* to send block length to write block */;
dcl  record                   (record_len) bit (36) based;

	     if record_len > 319 then call fatal_error (54);

	     if record_len > remaining_output_words then do; /* write out the block */

		if output.medium = tape then		/* for tape files */
		     block_len = output_block_len + 1;	/* write 320 words or less */
		else				/* for disk files, we pad blocks to 320 words */
		block_len = 320;			/* so a read of 320 words will get exactly one block */

		call write_block (write_buffer_ptr, block_len);

		unspec (write_buffer) = ""b;		/* zero the output buffer,
						   to avoid garbage at the ends of short blocks */

		remaining_output_words = 319;
		output_word_ptr = addrel (write_buffer_ptr, 1);

		block_serial_number = block_serial_number + 1;
		write_buffer_ptr -> bcw.bsn = bit (fixed (block_serial_number, 18));

		output_block_len = 0;		/* fixed bin(24)copy of bcw.length */

	     end;

	     output_block_len = output_block_len + record_len;
	     write_buffer_ptr -> bcw.length = bit (fixed (output_block_len, 18));

	     output_word_ptr -> record = record_ptr -> record;

	     output_word_ptr = addrel (output_word_ptr, record_len);
	     remaining_output_words = remaining_output_words - record_len;

	     if record_len = 1 then do;		/* record_len of 1 must be an end-of-file word
						   (000000170000 octal), so force out the block */
		if output.medium = tape then do;	/* tape files should not end with eof records */
		     write_buffer_ptr -> bcw.length = bit (bin (output_block_len-1, 18)); /* adjust bcw.length */
		     block_len = output_block_len;	/* write one less word (omit the eof_rcw) */
		end;

		else block_len = 320;		/* if not tape, write exactly 320 words */
		call write_block (write_buffer_ptr, block_len);
	     end;

	     return;

end write_gcos_record;
%page;
write_output: proc;

dcl  i                        fixed bin(24);

	     io_ptr = output_ptr;			/* to tell which file, if error */

	     if output.format = gcos then do;
		if output.comdk then call write_comdk (gcos_record_ptr, gcos_record_len);
		else call write_record (gcos_record_ptr, gcos_record_len);
	     end;
	     else if output.format = ascii then do;
		i = length (rtrim (ascii_card)) + 1;	/* get rid of trailing blanks */

		if output.truncate_ascii
		then if i > 81
		     then i = 81;			/* chop the line at 80 chars */

		substr (ascii_line, i, 1) = ascii_newline; /* last char must be newline */
		call write_block (ascii_line_ptr, i);
	     end;

	     else if output.format = blocks
		then do;
		     if output.medium = tape
		     then i = bcw_word.bcw_len + 1;	/* pick up block length, including bcw */

		     else if input.medium = tape	/* if tape to segment copy */
			then i = 320;			/* pad output block to 320 words */
			else i = input_block_len;		/* if not tape, write out exactly what was read in */
		     call write_block (input_block_ptr, i);
		     end;

		else call fatal_error (55);

	     output_record_count = output_record_count + 1;

	     return;

end write_output;
%page;
write_raw_record: proc (record_ptr, record_len);

dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;

dcl  i                        fixed bin(24);
dcl  raw_ptr                  ptr;

	     if (record_len = 27|record_len = 24)	/* if binary card */
	     &record_ptr -> rcw.media_code = "0001"b then do;
		raw_ptr = addrel (record_ptr, 1);	/* data starts right after rcw */
		goto write_raw;			/* go write it out */
	     end;

	     else if record_len = 14			/* if BCD card */
	     &record_ptr -> rcw.media_code = "0010"b then do;
		do i = 1 to 80;
		     raw_card (i) = raw_table (fixed (record_ptr -> bcd_card.column (i)));
		end;
		raw_ptr = raw_card_ptr;

write_raw:	call write_block (raw_ptr, 1);	/* write one 960-bit element */
		return;
	     end;

	     else call fatal_error (56);		/* bad record length or media code */

end write_raw_record;
%page;
write_record: proc (record_ptr, record_len);

dcl  record_len               fixed bin(24);
dcl  record_ptr               ptr;

	     if output.medium = raw then call write_raw_record (record_ptr, record_len);
	     else call write_gcos_record (record_ptr, record_len + 1);
						/* +1 because rcw not included in record_len, and
						   write_gcos_record wants total number of words to be written */

	     return;

end write_record;
%page;
write_tape_eof: proc;

	     call ios_$order (output_stream_name, "eof", null, status);
	     if code ^= 0 then do;
		call interpret_tape_status;
		call fatal_error (57);		/* error while writing tape eof */
	     end;

	     return;

end write_tape_eof;
%page;
write_tape_label: proc;		/* write a label on magnetic tape */

	     call write_block (label_ptr, 14);
	     if code ^= 0 then do;
		call interpret_tape_status;
		call fatal_error (58);		/* error writing tape label */
	     end;

	     output_block_count = output_block_count - 1; /* do not count label as a block -
						   exact count is needed to put in trailer label */
	     call write_tape_eof;			/* write eof mark and check error code */

	     return;

end write_tape_label;


/* ******************************************************************************************************************** */
/* ******************************************************************************************************************** */
/* ******************************************************************************************************************** */
/* ******************************************************************************************************************** */

end gcos_card_utility_;




		    gcos_create_file.pl1            11/19/82  1410.9rew 11/19/82  0930.8       53532



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


gcos_create_file: gcf: proc ();


/* ***************************************************************
   ***************************************************************
   *
   *
   *		G C O S   C R E A T E   F I L E
   *
   *   This command is used to create a Multics segment or
   *   multisegment file to be used as a GCOS file with the GCOS
   *   Environment Simulator. The GCOS attributes of the file are
   *   recognized by this command and are passed to the support
   *   subroutine which actually creates the file.
   *   The command syntax is:
   *
   *	gcos_create_file <filename> {<-control_arg>}
   *
   *   where -control_arg is one of the following:
   *
   *	-llinks <n>		file size in llinks
   *	-links <n>		file size in links
   *
   *
   *	Written by M. R. Jordan, 12/10/77
   *
   *
   ***************************************************************
   *************************************************************** */

dcl  ME char (16) static internal options (constant) init ("gcos_create_file"); /*  my name  */
dcl  addr builtin;
dcl  arg char (arg_len) based (arg_ptr);		/*  string to access current arg  */
dcl  arg_len fixed bin;				/*  len of current arg  */
dcl  arg_ptr ptr;					/*  loc of current arg  */
dcl  code fixed bin (35);				/*  status code used in calls  */
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_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  dname char (168);				/*  directory name of target  */
dcl  ename char (32);				/*  entry name of target  */
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_$wrong_no_of_args fixed bin (35) ext;
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  gcos_create_file_ entry (char (*), char (*), ptr, fixed bin (35));
dcl  multiplier fixed bin (18);			/*  multiplier to get file size in words  */
dcl  nargs fixed bin;				/*  number of args supplied by user  */

%include gcos_file_info;


dcl 1 my_gcos_file_info like gcos_file_info;

/*

   Get the number of arguments passed to the command.

*/


	call cu_$arg_count (nargs);
	if nargs < 1 then do;
	     call com_err_ (error_table_$noarg, ME, "^/Usage is:  gcos_create_file filename {-links N|-llinks N}");
	     return;
	end;


/*

   Now get the file name argument.

*/


	call cu_$arg_ptr (1, arg_ptr, arg_len, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "Error referencing argument 1.");
	     return;
	end;

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


/*

   Initialize the file info structure with default values.

*/


	my_gcos_file_info.version = 1;
	my_gcos_file_info.size_in_llinks = 1;
	my_gcos_file_info.max_size_in_llinks = 0;
	my_gcos_file_info.flags.random = "0"b;
	my_gcos_file_info.flags.pad = (35)"0"b;
	my_gcos_file_info.flags.original_file_has_been_written = "0"b;
	my_gcos_file_info.flags.user_specified_attributes = (35)"0"b;
	my_gcos_file_info.ids_attributes.first_page_in_subfile = 0;
	my_gcos_file_info.ids_attributes.last_page_in_subfile = 0;
	my_gcos_file_info.ids_attributes.multiuser = "0"b;
	my_gcos_file_info.ids_attributes.reserveed_1 = (17)"0"b;
	my_gcos_file_info.ids_attributes.words_per_page = 0;
	my_gcos_file_info.ids_attributes.reserved_2 = (18)"0"b;
	my_gcos_file_info.ids_attributes.lines_per_page = 0;
	my_gcos_file_info.ids_attributes.reserved_3 = (18)"0"b;
	my_gcos_file_info.ids_attributes.page_fill_percent = "202020"b3;
	my_gcos_file_info.ids_attributes.reserved_4 = (6)"0"b;
	my_gcos_file_info.ids_attributes.area_number = 0;
	my_gcos_file_info.ids_attributes.reserved_5 = (6)"0"b;
	my_gcos_file_info.ids_attributes.num_pages_in_area = 0;
	my_gcos_file_info.ids_attributes.minus_one = -1;
	my_gcos_file_info.ids_attributes.reserved_6 (*) = (36)"0"b;


/*

   Now process all control arguments.

*/


	if nargs> 1 then do;

	     call cu_$arg_ptr (2, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, "Error referencing argument 2.");
		return;
	     end;

	     if arg = "-links" then multiplier = 12;
	     else if arg = "-llinks" then multiplier = 1;
	     else do;
		call com_err_ (error_table_$badopt, ME, "^a", arg);
		return;
	     end;

	     if nargs > 2 then do;

		call cu_$arg_ptr (3, arg_ptr, arg_len, code);
		if code ^= 0 then do;
		     call com_err_ (code, ME, "Error referencing argument 3.");
		     return;
		end;

		my_gcos_file_info.size_in_llinks = cv_dec_check_ (arg, code)*multiplier;
		if code ^= 0 then do;
		     call com_err_ (error_table_$bad_conversion, ME, "Error converting ""^a"" to decimal integer.", arg);
		     return;
		end;

		if nargs > 3 then do;
		     call com_err_ (error_table_$wrong_no_of_args, ME, "Too many arguments supplied.");
		     return;
		end;

	     end;
	     else do;
		call com_err_ (error_table_$noarg, ME, "Decimal file size missing.");
		return;
	     end;

	end;

/*

   Now that we have all of the pertinent information, create the file.

*/


	call gcos_create_file_ (dname, ename, addr (my_gcos_file_info), code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a^[>^]^a", dname, (dname ^= ">"), ename);
	end;


	return;


     end gcos_create_file;




		    gcos_create_file_.pl1           11/19/82  1410.9rew 11/19/82  0930.8       48150



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


gcos_create_file_: proc (a_dname, a_ename, a_info_ptr, a_code);


/* ***************************************************************
   ***************************************************************
   *
   *
   *   This subroutine is called to create a segment or multisegment
   *   file that is to be used as a GCOS file with the GCOS
   *   Environment Simulator. The data structure gcos_file_info
   *   contains all GCOS file attributes that can be specified by the
   *   caller. The size is converted to a total bit count and an MSF
   *   is created if necessary.
   *
   *
   *	Written by M. R. Jordan, 12/10/77
   *
   *
   ***************************************************************
   *************************************************************** */

dcl  BITS_PER_LLINK fixed bin static internal options (constant) init (11520);
dcl  RW fixed bin (5) static internal options (constant) init (01010b);
dcl  SMA fixed bin (5) static internal options (constant) init (01011b);
dcl  a_code fixed bin (35);				/*  returned status code  */
dcl  a_dname char (*);				/*  directory name passed by caller  */
dcl  a_ename char (*);				/*  entry name passed by caller  */
dcl  a_info_ptr ptr;				/*  ptr to file info passed by caller  */
dcl  bit_count fixed bin (24);			/*  bit count passed to hcs_  */
dcl  code fixed bin (35);				/*  status code from hcs_  */
dcl  comp_name char (32) ;				/*  component name for msf component  */
dcl  comp_name_len fixed bin;				/*  length of component name  */
dcl  component fixed bin;				/*  component number  */
dcl  cu_$level_get entry () returns (fixed bin);
dcl  divide builtin;
dcl  dname char (168);				/*  directory name used in calls to hcs_  */
dcl  ecode fixed bin (35);				/*  temp status code  */
dcl  ename char (32);				/*  entry name used in calls to hcs_  */
dcl  get_group_id_$tag_star entry () returns (char (32));
dcl  hcs_$append_branchx entry (char (*), char (*), fixed bin (5), (3) fixed bin (3), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl  hcs_$delentry entry (char (*), char (*), fixed bin (35));
dcl  ioa_$rsnnl entry options (variable);
dcl  max_bits_per_seg fixed bin (24);
dcl  max_llinks_per_seg fixed bin;
dcl  msf_name char (168) ;				/*  name of msf being created  */
dcl  msf_name_len fixed bin;				/*  length of msf name  */
dcl  ncomp fixed bin;				/*  number of components needed  */
dcl  rings (3) fixed bin (3) ;
dcl  substr builtin;
dcl  sys_info$max_seg_size fixed bin (24) ext;
dcl  total_bit_count fixed bin (71);			/*  total bit count to represent # llinks  */
dcl  user_id char (32);				/*  person.project.*  */

%include gcos_file_info;

/*

   Copy all input arguments.

*/


	dname = a_dname;
	ename = a_ename;
	gcos_file_info_ptr = a_info_ptr;


/*

   Initialize a few essential data items.

*/


	code = 0;
	max_bits_per_seg = sys_info$max_seg_size*36;
	max_llinks_per_seg = divide (max_bits_per_seg, BITS_PER_LLINK, 17, 0);
	rings (*) = cu_$level_get ();
	user_id = get_group_id_$tag_star ();


/*

   Determine the number of components to be created and the total bit count needed.

*/


	ncomp = divide (gcos_file_info.size_in_llinks+max_llinks_per_seg-1, max_llinks_per_seg, 17);
	total_bit_count = gcos_file_info.size_in_llinks*BITS_PER_LLINK; /* BITS_PER_LLINK = 320 * 36 */


/*

   If only one component is to be created, do so.
   Otherwise, create a MSF with the required number
   of components.

*/


	if ncomp = 1 then call Create_A_Seg ();
	else call Create_A_MSF ();


/*

   We are all finished.  Clean up and get out.

*/


	a_code = code;

	return;

/*

   This internal procedure creates a multisegment file with the proper
   bit count and access.

*/


Create_A_MSF: proc ();


	     call hcs_$append_branchx (dname, ename, SMA, rings, user_id, 1, 0, (ncomp), code);
	     if code ^= 0 then return;


	     do component = 0 to ncomp-1;

		if total_bit_count <= max_bits_per_seg then bit_count = total_bit_count;
		else bit_count = max_bits_per_seg;
		total_bit_count = total_bit_count-bit_count;

		call ioa_$rsnnl ("^a^[>^]^a", msf_name, msf_name_len, dname, (dname ^= ">"), ename);
		call ioa_$rsnnl ("^d", comp_name, comp_name_len, component);

		call hcs_$append_branchx (substr (msf_name, 1, msf_name_len), substr (comp_name, 1, comp_name_len),
		     RW, rings, user_id, 0, 0, bit_count, code);
		if code ^= 0 then do;
		     call hcs_$delentry (dname, ename, ecode);
		     return;
		end;

	     end;


	     return;


	end Create_A_MSF;

/*

   This internal procedure creates a segment with the proper bit count
   and access.

*/


Create_A_Seg: proc ();


	     bit_count = total_bit_count;
	     call hcs_$append_branchx (dname, ename, RW, rings,
		user_id, 0, 0, bit_count, code);
	     if code ^= 0 then return;


	end Create_A_Seg;



     end gcos_create_file_;




		    gcos_gsr_read_.pl1              11/19/82  1410.9rew 11/19/82  0930.4       65358



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


/* This procedure will return one record from a gcos standard format
   320 word block.  It will read from the stream "attname" and return a
   pointer to the record just read in buffp, the length of the read
   data will be in reclen, the record header (media and report codes)
   will be in rcrdhdr, and eofsw will be set if this record is the last
   in the last block

   WRITTEN BY DICK SNYDER      1971
   MODIFIED BY P.M. HABER SEPTEMBER 1973
   MODIFIED BY T. CASEY APRIL 1974, AUGUST 1974, NOVEMBER 1974

   */


gcos_gsr_read_: proc (attname, buffp, reclen, rcrdhdr, eofsw, fx_code);

dcl  attname char (*);
dcl  eofsw bit (1);
dcl  buffp ptr;
dcl  reclen fixed bin;
dcl  rcrdhdr bit (12);
dcl  fx_code fixed bin (35);

dcl 1 word based aligned,
    2 upper bit (18) unaligned,
    2 lower bit (18) unaligned;

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

dcl (error_table_$bad_file, error_table_$file_already_opened, error_table_$file_not_opened) ext fixed bin (35);
dcl  forcesw bit (1) init ("0"b);
dcl (first, last) ptr int static init (null);

dcl 1 c_block based (cp),				/* control block for a file being read */
    2 name char (32),				/* file name */
    2 mybuf char (1280),				/* read buffer */
    2 rcrdp ptr,
    2 myeofsw bit (1),
    2 readsw bit (1),
    2 blklen fixed bin,
    2 forward ptr,
    2 backward ptr;

dcl  cp ptr init (null) int static;
dcl  st bit (72) aligned;
dcl  code fixed bin (35) based (addr (st));
dcl  stringlen fixed bin;
dcl  mybufp ptr;
dcl  j fixed bin;
dcl (addr, addrel, baseno, fixed, null, substr) builtin;

dcl  closing bit (1) aligned init ("0"b);

dcl  get_system_free_area_ ext entry returns (ptr);
dcl  system_free_ptr ptr int static init (null);
dcl  system_free_area area based (system_free_ptr);

/*  */

COMMON:						/* come here from gsr_read_close entry point */
	fx_code = 0;				/* initialize return code */
	if first = null then go to error;		/* attempt to read without initing */

	cp = first;				/* get ptr to first control block */
srch_loop:
	if attname = c_block.name then go to hit;
	cp = c_block.forward;
	if cp ^= null then go to srch_loop;		/* continue to look */
error:
	fx_code = error_table_$file_not_opened;
	return;

hit:
	if closing then goto nodata;			/* if entered at gsr_read_close entry point */

	mybufp = addr (c_block.mybuf);
	if readsw then do;
	     if myeofsw then do;			/* eof already encountered */
nodata:
		if c_block.backward = null then do;	/* first block in chain */
		     first = c_block.forward;		/* set first to point to next block */
		     if first ^= null then		/* don't reference thru null ptr if only 1 block */
			first -> c_block.backward = null; /* set back point in next block to null */
						/* (it is new first blk) */
		end;
		else if c_block.forward = null then do; /* last block in chain */
		     last = c_block.backward;		/* set up new last ptr */
		     last -> c_block.forward = null;	/* previous block is new last block */
		end;
		else do;				/* block is in middle of chain */
		     c_block.backward -> c_block.forward = c_block.forward; /* thread this block out of list */
		     c_block.forward -> c_block.backward = c_block.backward;
		end;

		free cp -> c_block in (system_free_area); /* deallocate block */

		if closing then return;		/* if entered at gsr_read_close entry point */

		eofsw = "1"b;
		reclen = 0;
		return;
	     end;

read:
	     call ios_$read (attname, mybufp, 0, 320, j, st);
	     if substr (st, 1, 3) = "100"b		/* hardware status returned */
		then do;
		if substr (st, 27, 4) = "0100"b	/* "tape mark" status */
		     then do;
		     myeofsw = "1"b;		/* return eof condition to caller */
		     substr (st, 1, 36) = "0"b;	/* and zero out returned error code */
		end;
		else goto io_error;			/* not "tape mark" status, error */
	     end;

	     else					/* not hardware status */
	     do;
		if code ^= 0 then do;		/* error occurred */
io_error:		     fx_code = code;		/* return error code */
		     return;
		end;
		myeofsw = substr (st, 1, 46);		/* take eof switch from normal location */
	     end;
	     readsw = "0"b;

	     if j = 0 then go to nodata;		/* nothing read */
	     rcrdp = addrel (mybufp, 1);		/* point to first record */
	     blklen = fixed (mybufp -> word.lower, 17);	/* reinit block len */
	     if blklen > 319 | blklen < 1 then do;	/* test for legal block length */
		buffp = mybufp;			/* return pointer to bad bcw, in case
						   caller wants to examine or display it */
		goto fmt_err;
	     end;
	end;

	if substr (rcrdp -> word.lower, 1, 6) = "001111"b then goto nodata; /* check for eof in rcw */

	reclen = fixed (rcrdp -> word.upper, 17);	/* get record len */
	if reclen >= blklen | reclen > 318 | reclen = 0 then do; /* check for legal record length */
	     buffp = rcrdp;				/* return pointer to bad rcw, in case
						   caller wants to examine or display it */
	     goto fmt_err;
	end;
	rcrdhdr = substr (rcrdp -> word.lower, 7, 12);	/* return report and media codes */
	blklen = blklen - reclen - 1;			/* decrement block len */
	if blklen = 0 then readsw = "1"b;		/* remember to read new block if end of block */
	eofsw = "0"b;
	buffp = addrel (rcrdp, 1);			/* point to data */
	rcrdp = addrel (rcrdp, reclen+1);		/* point to next record */
	return;


/* Come here if bcw or rcw had bad length field */

fmt_err:	fx_code = error_table_$bad_file;
	goto nodata;




/* 	Must enter here before reading to init control block */


gsr_read_init: entry (attname, fx_code);

	fx_code = 0;				/* initialize return code */
	if first = null then go to create;		/* no blocks yet */
	cp = first;				/* see if guy is attmepting to init same file twice */
cr_loop:
	if attname = c_block.name then do;
	     fx_code = error_table_$file_already_opened;
	     return;
	end;

	if c_block.forward = null then go to create;
	cp = c_block.forward;			/* on to next one */
	go to cr_loop;

create:
	if system_free_ptr = null then system_free_ptr = get_system_free_area_ ();
	allocate c_block in (system_free_area) set (last); /* allocate a control block for this file */
	if first = null then do;
	     cp, first = last;			/* this is first and only block */
	     c_block.backward = null;			/* no back block */
	end;
	else do;
	     c_block.forward = last;			/* fill in forward pointer in last block */
	     last -> c_block.backward = cp;		/* fill in backward pointer in this block */
	     cp = last;				/* point now to new block */
	end;

	c_block.forward = null;			/* no next block */
	c_block.readsw = "1"b;			/* cause read at next call */
	c_block.myeofsw = "0"b;			/* no eof */
	c_block.name = attname;
	return;


gsr_read_close: entry (attname, fx_code);

	closing = "1"b;
	goto COMMON;

     end gcos_gsr_read_;




		    gcos_gsr_write_.pl1             11/19/82  1410.9rew 11/19/82  0930.5       60561



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


/*
   This procedure will write one record in gecos standard format.
   It will write blocks to the stream "attname", it will copy the record
   into a block from the place pointed to by buffp, it will copy the
   number of words specified by reclen, it will use the supplied report
   code, and if eofsw is on, it will force the current block to be
   written out even if not full ( and will not allow anymore write
   calls until reinitialized).

   WRITTEN BY DICK SNYDER     1971
   MODIFIED BY P.M. HABER SEPTEMBER 1973
   MODIFIED BY T. CASEY APRIL 1974

   */


gcos_gsr_write_: proc (attname, buffp, reclen, report_code, eofsw, fx_code);
dcl  attname char (*);
dcl  eofsw bit (1);
dcl  report_code bit (12);
dcl  buffp pointer;
dcl  reclen fixed bin;
dcl  fx_code fixed bin (35);

dcl 1 word based aligned,
    2 upper bit (18) unaligned,
    2 lower bit (18) unaligned;
dcl  ios_$write ext entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned);
dcl (error_table_$file_not_opened, error_table_$file_already_opened) ext fixed bin (35);
dcl  thing char (20) varying;
dcl  forcesw bit (1) init ("0"b);
dcl (first, last) pointer int static init (null);
dcl 1 c_block based (cp),				/* control block for a file being written */
    2 name char (32),				/* file name */
    2 mybuf char (1280),				/* write buffer */
    2 rcrdp pointer,
    2 serial_no fixed bin,
    2 blklen fixed bin,
    2 forward pointer,
    2 backward pointer;

dcl  cp pointer int static init (null);
dcl  st bit (72) aligned;
dcl  code fixed bin (35) based (addr (st));
dcl  stringlen fixed bin;
dcl  basedstring bit (stringlen) based;
dcl  mybufp pointer;
dcl  j fixed bin;
dcl (addr, addrel, baseno, null, unspec, substr) builtin;

dcl  closing bit (1) aligned init ("0"b);

dcl  get_system_free_area_ ext entry returns (ptr);
dcl  system_free_ptr ptr int static init (null);
dcl  system_free_area area based (system_free_ptr);


COMMON:						/* come here from gsr_write_close entry */
	fx_code = 0;				/* initialize return argument */

	if first = null then go to error;		/* attempt to write without initing */

	cp = first;				/* get pointer to first control block */
srch_loop:
	if attname = c_block.name then go to hit;
	cp = c_block.forward;
	if cp ^= null then go to srch_loop;		/* continue to look */
error:	
	fx_code = error_table_$file_not_opened;
	return;


hit:	
	if closing then goto free_buffer;		/* if entered at gsr_write_close entry */

	mybufp = addr (c_block.mybuf);
	if blklen = -1 then do;			/* new block */

newblk:	     mybufp -> word.upper = substr (unspec (serial_no), 19, 18); /* put serial no in block */
	     serial_no = serial_no+1;			/* update serial no */
	     blklen = 0;
	     rcrdp = addrel (mybufp, 1);		/* point to first record header */
	end;

	if blklen + reclen > 318 then do;		/* new record won't fit in current block */
force:	     mybufp -> word.lower = substr (unspec (blklen), 19, 18); /* put block len in block */
	     blklen = -1;
	     call ios_$write (attname, mybufp, 0, 320, j, st); /* write block */
	     if code ^= 0 then do;
		fx_code = code;			/* return error code */
		return;
	     end;

	     if forcesw then do;			/* all done if eof being written */
free_buffer:	

		if c_block.backward = null then do;	/* first block in chain */

		     first = c_block.forward;		/* set first to point to next block */
		     if first ^= null then		/* don't reference thru null ptr if only 1 block */
		     first -> c_block.backward = null;	/* set back point in next block to null */
						/* (it is new first block ) */
		end;
		else if c_block.forward = null then do;	/* last block in chain */

		     last = c_block.backward;		/* set up new last pointer */
		     last -> c_block.forward = null;	/* previous block is new last block */
		end;

		else do;				/* we have block in middle of chain */

		     c_block.backward -> c_block.forward = c_block.forward; /* thread this block out of list */
		     c_block.forward -> c_block.backward = c_block.backward;
		end;

		free cp -> c_block in (system_free_area); /* deallocate block */
		return;
	     end;

	     go to newblk;
	end;

	if reclen ^= 0 then do;
	     rcrdp -> word.upper = substr (unspec (reclen), 19, 18); /* put record len in rcrd header */
	     rcrdp -> word.lower = "0"b;		/* put report and */
	     substr (rcrdp -> word.lower, 7, 12) = report_code; /* media codes in rcrd header */
	     rcrdp = addrel (rcrdp, 1);		/* now point to data area */
	     stringlen = 36*reclen;			/* get length of rcrd in bits */
	     rcrdp -> basedstring = buffp -> basedstring;	/* copy record into buffer */
	     rcrdp = addrel (rcrdp, reclen);		/* point to next record header */
	     blklen = blklen+reclen+1;		/* update block length */
	end;

	forcesw = eofsw;				/* supposed to write eof? */
	if forcesw then go to force;			/* yes */

	return;



/* 	Must enter here before writing to init control block */


gsr_write_init: entry (attname, fx_code);

	fx_code = 0;				/* initialize returned code */
	if first = null then go to create;		/* no blocks yet */
	cp = first;				/* see if guy is attmepting to init same file twice */
cr_loop:	
	if attname = c_block.name then do;
	     fx_code = error_table_$file_already_opened;
	     return;
	end;

	if c_block.forward = null then go to create;
	cp = c_block.forward;			/* on to next one */
	go to cr_loop;

create:	
	if system_free_ptr = null then system_free_ptr = get_system_free_area_ ();
	allocate c_block in (system_free_area) set (last); /* allocate a control block for this file */
	if first = null then do;
	     cp, first = last;			/* this is first and only block */
	     c_block.backward = null;			/* no back block */
	end;
	else do;
	     c_block.forward = last;			/* fill in forward pointer in last block */
	     last -> c_block.backward = cp;		/* fill in backward pointer in this block */
	     cp = last;				/* point now to new block */
	end;

	c_block.forward = null;			/* no next block */
	c_block.blklen = -1;
	c_block.serial_no = 1;
	c_block.name = attname;
	return;


gsr_write_close: entry (attname, fx_code);

	closing = "1"b;				/* remember we are just going to free a buffer */
	goto COMMON;				/* go look for it */

     end gcos_gsr_write_;




		    gcos_label_tape.pl1             11/19/82  1410.9rew 11/19/82  0918.5      150282



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */
gcos_label_tape:
	   gclt: proc;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Written:	Scott C. Akers	FEB 82					*/
          /* Changed:  Ron Barstad  Oct 1982  To accept only 5 char for tape label                  */
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
%page;
/*
Syntax:  gcos_label_tape REEL_NUM {NEW_NUM} {-control_args}


Function:  Writes a GCOS label on a tape.


Arguments:

REEL_NUM
   is the number on the label of the tape reel to be used.
NEW_NUM
   is the new serial  number to be written on the tape.   If it is the
   same as the REEL_NUM, it may be omitted.


Control arguments:

-density N, -den N
   Specify the tape density.  Default is 1600 BPI.
-track N, -tk N
   Specify 7- or 9-track tape.  Default is 9-track.
-erase | -no_erase
   Erase/don't  erase  the tape  before  labeling it.   Default  is to
   overwrite  the old  label (if it  exists), and  leave the remaining
   data intact (-no_erase).


Notes:

If no control arguments are given, the command:
     gclt xyz12
is equivalent to the command:
     gclt xyz12 xyz12 -tk 9 -den 1600 -no_erase

If  conflicting  control arguments  are  given, the  rightmost control
argument is used (e.g.  "gclt m1266 -tk  7 -tk 9" will label a 9-track
tape.)
*/
%page;
	call init_routine;				/* Set default values. */

	on   condition (cleanup)
	begin;
	     call close_file;
	     goto exit_gclt;
	     end;

	call cu_$arg_list_ptr (arg_list_ptr);		/* Get an argument pointer. */
	if get_args (arg_list_ptr)			/* Validate the args. */
	then if built_label ()			/* Try to build the label. */
	     then if tape_labeled ()			/* Attempt to do the labeling. */
		then if label_ok ()			/* Make sure it matches. */
		     then call goodie_message;	/* Tell user it succeeded. */

	call close_file;				/* Close and detach the tape. */

exit_gclt: ;

	return;
%page;
asc_to_bcd: proc (in_string, out_string, field_length) returns (bit (1));

						/* Translates an ASCII character
						/* string to its BCD equivalent,
						/* padding on the right to fill
						/* output field. */

dcl  field_length	fixed bin		parm;
dcl  in_string	char (*)		parm;
dcl  out_string	bit (*)		parm;


	error = "0"b;
	fill_count = 0;
	max_xlate = min (length (rtrim (in_string)), field_length);


	do   counter = 1 to max_xlate
	     while (^error);

	     if   in_char (counter) <= hbound (asc_to_bcd_table, 1)
	     then do;
		out_char (counter) = asc_to_bcd_table (in_char (counter));
		fill_count = fill_count + 1;
		end;
	     else do;
		call com_err_ (error_table_$bad_conversion, MYNAME,
			     "^/ASCII character ""^o"" has no BCD counterpart.",
			     in_char (counter));
		error = "1"b;
		end;
	     end;

	if   ^error
	then do   counter = fill_count+1 to field_length;
		out_char (counter) = "20"b3;
		end;

	return (^error);

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

dcl  error		bit (1);
dcl  in_char		(length (rtrim (in_string))) fixed bin (9)
			unsigned unaligned based (addr (in_string));
dcl  max_xlate		fixed bin;
dcl  out_char		(field_length) bit (6)
			unaligned based (addr (out_string));

end asc_to_bcd;
%page;
built_label: proc returns (bit (1));			/* Fills in label structure. */

	if   new_vol_id = " "
	then new_vol_id = atd_structure.vol_id;		/* Use old VOL_ID if new one not given. */

	if   asc_to_bcd ("ge  600 btl", tape_label.label_id, 12)
	then if   asc_to_bcd (ascii_inst_id, tape_label.installation_id, 6)
	     then if   asc_to_bcd (" " || new_vol_id, tape_label.tape_serial_number, 6)
		then if   asc_to_bcd (" " || new_vol_id, tape_label.file_serial_number, 6)
		     then if   asc_to_bcd ("  0001", tape_label.reel_sequence_number, 6)
			then if   asc_to_bcd (" " || ascii_cr_date, tape_label.creation_date, 6)
			     then if   asc_to_bcd (" ", tape_label.file_name, 12)
				then if   asc_to_bcd ("gcos env simulator", tape_label.blurb, 18)
				     then if   asc_to_bcd (" ", tape_label.blanks, 6)
					then return ("1"b);
	return ("0"b);

end built_label;
%page;
close_file: proc;

	code = 0;

	if   iocb_ptr ^= null ()
	then do;

	     call iox_$close (iocb_ptr, code);
	     call iox_$detach_iocb (iocb_ptr, code);
	     call iox_$destroy_iocb (iocb_ptr, code);

	     if   code ^= 0
	     then call com_err_ (code, MYNAME,
			     "^/Error while trying to detach/close ^a",
			     stream_name);
	     end;

	return;

end close_file;
%page;
day_of_year: proc returns (char (3));

	call datebin_$dayr_clk (clock_reading, num_day);

	return (ltrim (char (num_day,17)));

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

dcl  num_day		fixed bin;

end day_of_year;
%page;
get_args: proc (arg_list_ptr) returns (bit(1));		/* Does the argument processing. */

dcl  arg_list_ptr	ptr	parm;

	error = "0"b;
	call cu_$arg_count_rel (arg_count, arg_list_ptr, code);

	if   code ^= 0
	then do;
	     call com_err_ (code, MYNAME);
	     error = "1"b;
	     end;

	if   arg_count > 0
	then do arg_no = 1 to arg_count while (^error);
	     call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr);
	     if   code = 0
	     then do;
		if   substr (arg, 1, 1) = "-"
		then do;
		     error = ^valid_ctl_arg (arg);
		     expect.new_vol_id = "0"b;
		     end;
		else error = ^valid_vanilla_arg (arg);
		end;
	     end;

	else do;
	     call com_err_ (error_table_$noarg, MYNAME,
			"^/You must supply a reel number.");

	     error = "1"b;
	     end;

	return (^error);

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

dcl  arg				char (arg_len) based (arg_ptr);
dcl  error			bit (1);
end get_args;
%page;
goodie_message: proc;				/* Tells user labeling succeeded. */

	call ioa_ ("^/Tape# ^a labeled as ""^a""^/",
		 atd_structure.vol_id,
		 new_vol_id);

	return;
end goodie_message;
%page;
init_routine: proc;					/* Sets up default values. */

	clock_reading = clock_ ();

	erase = "0"b;				/* Default is to not erase. */

	iocb_ptr = null ();

	unspec (compare_buffer) = "0"b;

	unspec (tape_label) = "0"b;

	unspec (expect) = "0"b;
	expect.reel_id = "1"b;

	new_vol_id = " ";

	atd_string = " ";				/* Fill with blanks first. */
	atd_structure.dim = "tape_nstd_";		/* Now fill in the goodies. */
	atd_structure.tracks = "-track 9";
	atd_structure.write = "-write";
	atd_structure.block_size = "-block 2800";
	atd_structure.density = "-density 1600";

	ascii_cr_date = year_num () || day_of_year ();

	call system_info_$installation_id (ascii_inst_id);

	return;

end init_routine;
%page;
label_ok: proc returns (bit (1));

	call iox_$control (iocb_ptr, "rewind", (null ()), code);

	if   code = 0
	then call iox_$read_record (iocb_ptr, (addr (compare_buffer)),
			        (14*4), return_count, code);
	
	if   code = 0
	then do;
	     if   tape_label_string ^= compare_buffer
	     then do;
		code = error_table_$bad_label;
		call print_label_contents;
		end;
	     end;

	else call com_err_ (code, MYNAME,
			"^/Error attempting to verify label.");

	return (code = 0);

end label_ok;
%page;
print_label_contents: proc;

	call com_err_ (code, MYNAME,
		     "^/Error while verifying label");

	overlay_ptr = addr (tape_label);

	call com_err_$suppress_name (0,MYNAME, "^2^/^-EXPECTED DATA"
			        ||"^/^w  ^w  ^w  ^w"
			        ||"^/^w  ^w  ^w  ^w"
			        ||"^/^w  ^w  ^w  ^w"
			        ||"^/^w  ^w",
			        dump_overlay (1), dump_overlay (2),
			        dump_overlay (3), dump_overlay (4),
			        dump_overlay (5), dump_overlay (6),
			        dump_overlay (7), dump_overlay (8),
			        dump_overlay (9), dump_overlay (10),
			        dump_overlay (11), dump_overlay (12),
			        dump_overlay (13), dump_overlay (14));

	overlay_ptr = addr (compare_buffer);

	call com_err_$suppress_name (0,MYNAME, "^2^/^-ACTUAL DATA"
			        ||"^/^w  ^w  ^w  ^w"
			        ||"^/^w  ^w  ^w  ^w"
			        ||"^/^w  ^w  ^w  ^w"
			        ||"^/^w  ^w",
			        dump_overlay (1), dump_overlay (2),
			        dump_overlay (3), dump_overlay (4),
			        dump_overlay (5), dump_overlay (6),
			        dump_overlay (7), dump_overlay (8),
			        dump_overlay (9), dump_overlay (10),
			        dump_overlay (11), dump_overlay (12),
			        dump_overlay (13), dump_overlay (14));

	return;

end print_label_contents;
%page;
tape_attached: proc returns (bit (1));

	stream_name = "lbl_" || rtrim (atd_structure.vol_id);
	call iox_$attach_name (stream_name, iocb_ptr, atd_string, null (), code);
	if   code = 0
	then call iox_$open (iocb_ptr, (6), ("0"b), code);

	if   code = 0
	then call iox_$control (iocb_ptr, "rewind", (null ()), code);

	if   code = 0
	then if   tape_erased ()
	     then code = 0;

	if   code ^= 0
	then call com_err_ (code, MYNAME,
			"^/Error while attaching/positioning tape.");

	return (code = 0);

end tape_attached;
%page;
tape_erased: proc returns (bit (1));

	code = 0;

	if erase
	then do;

	     do   while (code = 0);
		call iox_$control ( iocb_ptr, "erase", null (), code);
		end;

	     if   code = error_table_$tape_error
	     then code = 0;

	     if   code = 0
	     then call iox_$control (iocb_ptr, "rewind", (null ()), code);

	     if   code ^= 0
	     then call com_err_ (code, MYNAME, "^/Error while erasing tape.");

	     end;

	return (code = 0);

end tape_erased;
%page;
tape_labeled: proc returns (bit (1));

	if   tape_attached ()
	then do;
	     call iox_$write_record (iocb_ptr, addr (tape_label), (14*4), code);
	     if code ^= 0
	     then call com_err_ (code, MYNAME,
			     "^/Error while trying to write new label.");

	     else do;
		call iox_$control (iocb_ptr, "write_eof", (null ()), code);
		if   code ^= 0
		then call com_err_ (code, MYNAME,
				"^/Error while writing EOF. ");
		end;
	     end;

	else code = error_table_$not_attached;

	return (code = 0);

end tape_labeled;
%page;
valid_ctl_arg: proc (ctl_arg)	returns (bit (1));

dcl  ctl_arg		char (*)	parm;

	error = "0"b;

	if   arg_no < 2
	then do;
	     call com_err_ (error_table_$noarg, MYNAME,
			"^/You must supply a reel number.");
	     error = "1"b;
	     end;

	else do;

	     if   ctl_arg = "-density"
	        | ctl_arg = "-den"
	     then expect.density = "1"b;
	     else if   ctl_arg = "-track"
		   | ctl_arg = "-tk"
		then expect.track = "1"b;
		else if   ctl_arg = "-erase"
		     then erase = "1"b;
		     else if ctl_arg = "-no_erase"
			then erase = "0"b;
			else do;
			     call com_err_ (error_table_$bad_arg, MYNAME,
					"^/Argument: ^a",ctl_arg);
			     error = "1"b;
			     end;

	     end;

	return (^error);

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

dcl  error		bit (1);

end valid_ctl_arg;
%page;
valid_vanilla_arg: proc (vanilla_arg) returns (bit (1));

dcl  vanilla_arg		char (*) parm;

	error = "0"b;

	if   expect.reel_id
	then do;
	     if   length (rtrim (vanilla_arg)) > 5
	     then do;
		call com_err_ (error_table_$bigarg, MYNAME,
			     "^/Maximum of 5 characters for reel_id.");
		error = "1"b;
		end;

	     else do;
		atd_structure.vol_id = rtrim (vanilla_arg);
		expect.new_vol_id = "1"b;
		expect.reel_id = "0"b;
		end;
	     end;

     else if   expect.new_vol_id
	then do;
	     if   length (rtrim (vanilla_arg)) > 5
	     then do;
		call com_err_ (error_table_$bigarg, MYNAME,
			     "^/Maximum of 5 characters for new vol_id.");
		error = "1"b;
		end;

	     else do;
		new_vol_id = rtrim (vanilla_arg);
		expect.new_vol_id = "0"b;
		end;
	     end;

     else if   expect.track
	then do;
	     if   vanilla_arg = "9"
	        | vanilla_arg = "7"
	     then do;
		atd_structure.tracks = "-track " || rtrim (vanilla_arg);
		expect.track = "0"b;
		end;

	     else do;
		call com_err_ (0, MYNAME, "Only 7- or 9-track tapes may be specified.");
		error = "1"b;
		end;
	     end;

     else if   expect.density
	then do;
	     if   vanilla_arg = "6250"
	        | vanilla_arg = "1600"
	        | vanilla_arg = "800"
	        | vanilla_arg = "556"
	        | vanilla_arg = "200"

	     then do;
		atd_structure.density = "-density " || rtrim (vanilla_arg);
		expect.density = "0"b;
		end;
	     else do;
		call com_err_ (0, MYNAME,
			     "Bad density specification: ^a"
			     || "^/Valid densities:^-6250^-1600^-800^-556^-200",
			     vanilla_arg);
		error = "1"b;
		end;
	     end;


	return (^error);

end valid_vanilla_arg;
%page;
year_num: proc returns (char (2));

	call date_time_ (clock_reading, date_string);

	return (substr (date_string, 7, 2));

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */

dcl  date_string		char (50);

end year_num;
%page;
dcl  addr				builtin;
dcl  arg_count			fixed bin;
dcl  arg_len			fixed bin (21);
dcl  arg_list_ptr			pointer;
dcl  arg_no			fixed bin;
dcl  arg_ptr			pointer;
dcl  ascii_cr_date			char (6);
dcl  ascii_inst_id			char (20);
dcl  atd_string			char (60)
				based (addr (atd_structure));
dcl  char                               builtin;
dcl  cleanup			condition;
dcl  clock_			entry() returns(fixed bin(71));
dcl  clock_reading			fixed bin (71);
dcl  code				fixed bin (35);
dcl  com_err_			entry() options(variable);
dcl  com_err_$suppress_name		entry() options(variable);
dcl  compare_buffer			bit (14*36) aligned;
dcl  counter			fixed bin;
dcl  cu_$arg_count_rel		entry (fixed bin, ptr, fixed bin(35));
dcl  cu_$arg_list_ptr		entry (ptr);
dcl  cu_$arg_ptr_rel		entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr);
dcl  datebin_$dayr_clk		entry (fixed bin(71), fixed bin);			
dcl  date_time_			entry (fixed bin(71), char(*));
dcl  dump_overlay			(14) bit (36) based (overlay_ptr);
dcl  erase			bit (1);
dcl  error			bit (1);
dcl  error_table_$bad_arg		fixed bin (35) ext static;
dcl  error_table_$bad_conversion	fixed bin (35) ext static;
dcl  error_table_$bad_label		fixed bin (35) ext static;
dcl  error_table_$bigarg		fixed bin (35) ext static;
dcl  error_table_$noarg		fixed bin (35) ext static;
dcl  error_table_$not_attached	fixed bin (35) ext static;
dcl  error_table_$tape_error		fixed bin (35) ext static;
dcl  fill_count			fixed bin;
dcl  hbound			builtin;
dcl  ioa_				entry() options(variable);
dcl  iocb_ptr			pointer;
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_$read_record		entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35));
dcl  iox_$write_record		entry (ptr, ptr, fixed bin(21), fixed bin(35));
dcl  length			builtin;
dcl  ltrim			builtin;
dcl  min				builtin;
dcl  MYNAME			char (10)	internal static
					options (constant)
					init ("gclt");
dcl  new_vol_id			char (6);
dcl  null                               builtin;
dcl  overlay_ptr			pointer;
dcl  return_count			fixed bin (21);
dcl  rtrim			builtin;
dcl  stream_name			char (12);
dcl  system_info_$installation_id entry (char(*));
dcl  substr                             builtin;
dcl  tape_label_string		bit (14*36) based (addr (tape_label));
dcl  unspec                             builtin;
%page;
dcl 1 tape_label			aligned,
    2 label_id		bit (72)	unaligned,
    2 installation_id	bit (36)	unaligned,
    2 tape_serial_number	bit (36)	unaligned,
    2 file_serial_number	bit (36)	unaligned,
    2 reel_sequence_number	bit (36)	unaligned,
    2 creation_date		bit (36)	unaligned,
    2 retention_days	bit (36)	unaligned,
    2 file_name		bit (72)	unaligned,
    2 blurb		bit (108)	unaligned,
    2 blanks		bit (36)	unaligned;


dcl 1 atd_structure		aligned,
    2 dim			char (11)	unaligned,
    2 fill_1		char (1)	unaligned,
    2 vol_id		char (6)	unaligned,
    2 fill_2		char (1)	unaligned,
    2 tracks		char (8)	unaligned,
    2 fill_3		char (1)	unaligned,
    2 write		char (6)	unaligned,
    2 fill_4		char (1)	unaligned,
    2 block_size		char (11)	unaligned,
    2 fill_5		char (1)	unaligned,
    2 density		char (13)	unaligned;

dcl 1 expect		aligned,
    2 reel_id		bit (1)	unaligned,
    2 new_vol_id		bit (1)	unaligned,
    2 density		bit (1)	unaligned,
    2 track		bit (1)	unaligned;
%page;
%include asc_to_bcd_table;


end gcos_label_tape;




		    gcos_sys_xlate_.alm             11/19/82  1410.9rew 11/19/82  0949.7       63648



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"
"	G C O S  S Y S O U T  T R A N S L A T O R
"
"  This program takes 3 arguments. The first is a pointer to a 320 word buffer which
"  contains a GCOS system standard format block. The second is a pointer to an output area
"  for the translated output. The third is a return argument which is the number
"  of ascii characters which were placed in the output buffer.
"
"  Certain special bcd character conventions are recognized:
"
"	17		ignored
"	77n		n is a line skip count unless n is 20
"			in which case a skip to head of form
"			is called for.
"	7777X		put any character X in the buffer
"
"  Two ASCII conventions are recognized:
"
"	records with media codes > 5 are ASCII, and characters are copied without translation.
"
"	records with media code = 6 have no trailing newlines, so one will be appended.
"
"
"
"	INDEX REGISTER USAGE
"
"	X1		holds remaining block size (in words)
"	X3		holds current offset in input buffer (characters)
"	X4		holds size of current record not yet processed (characters)
"	X5		holds size of current record (words)
"	X6		holds current offset in output buffer (characters)
"
"
"
"	WRITTEN BY DICK SNYDER FEBRUARY 3,1971
"	MODIFIED BY T. CASEY, AUGUST 1973, TO PRODUCE UPPERCASE OUTPUT
"	MODIFIED BY T. CASEY, MARCH 1974 TO:
"		IGNORE ANY GARBAGE IN RECORD AFTER 77n
"		MAKE UPPER OR LOWER CASE TRANSLATION AN OPTION
"		ACCEPT ASCII RECORDS
"	MODIFIED BY D. KAYDEN JANUARY 1975 TO USE EIS
"	MODIFIED BY R.H. MORRISON 5/19/76
"		CHANGED uc_table AND lc_table TO CONFORM TO REAL GCOS
"	Modified by M. R. Jordan, September 1976 to process all printer escapes
"	MODIFIED BY:	Dave Ward		March 1978	TO:
"					Process overprint correctly, i.e., "!0"
"					BCD control sequence implies carriage-return.
"
"
"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""


	name	gcos_sys_xlate_
	entry	gcos_sys_xlate_
	entry	gcos_sys_xlate_lc_

gcos_sys_xlate_lc_:
	save
	eppbb	lc_table		point to lower case table
	tra	get_args



gcos_sys_xlate_:
	save
	eppbb	uc_table		point to upper case table

get_args:
	spriap	sp|0		save ap for return arg access
	eppbp	ap|2,*
	eppbp	bp|0,*		bp->input buffer
	eppap	ap|4,*
	eppap	ap|0,*		ap->output buffer

	eax6	0		set output buffer offset
	lxl1	bp|0		get block size
	eppbp	bp|1		point to first record
xlrcd:	cmpx1	bp|0		make sure rec len < curr block len
	tmoz	fini		it isn't..we're done
	sbx1	bp|0		decrement remaining block size
	sbx1	1,du		including rcw
	ldx5	bp|0		get record size
	tze	fini		yes..eof and end of block
"
"  Check for ASCII media code, and set switches appropriately
"
	lda	bp|0		get media code from rcw
	als	26		by getting rid of the 26 bits to its left
	arl	32		and the 6 bits to its right
	eppbp	bp|1		point to beginning of record data
	cmpa	=8,dl		tss type 8?
	tze	endrec		ignore this one
	cmpa	=o5,dl		ASCII or BCD?
	tpl	xlasc		if >= 5, its ASCII
	eaq	0,5		get record length in chars
	mpy	6,dl
	eax4	0,qu		save it in x4
	eax3	0		set char offset in record

lp:	stz	tally
	tct	(pr,x3,rl)	scan for a "!" or "?"
	desc6a	bp|0,x4
	arg	tctable
	arg	tally
	lxl7	tally		number of chars passed over
	tze	lp1		none
	stx7	tally

	mvt	(pr,x3,rl),(pr,x6,rl) translate nonedit chars passed over
	desc6a	bp|0,x7
	desc9a	ap|0,x7
	arg	bb|0

	adx3	tally		increment input record offset
	adx6	tally		increment output buffer offset
	sbx4	tally		decrement remaining record length
	cmpx4	2,du		at least 2 chars left ?
	tmi	endrec		done with record

lp1:	mlr	(pr,x3),(pr),fill(00) extract next 3 chars
	desc6a	bp|0,3
	desc6a	temp,6

	lda	temp
	ana	=o770000,du	examine first char
	cmpa	=o770000,du	is it a "!"
	tnz	ignore		no - must be a "?"
	lda	temp		examine second character
	ana	=o7700,du
	cmpa	=o7700,du		is it another "!"
	tnz	space		no - form spacing request
	cmpx4	3,du		were there 3 chars left
	tmi	endrec		no - done with record
	mvt	(pr),(pr,x6)	translate third char
	desc6a	temp(2),1
	desc9a	ap|0,1
	arg	bb|0
	adx6	1,du		increment output buffer offset
	adx3	3,du		increment input record offset
	sbx4	3,du		decrement remaining record length
	tpnz	lp		scan rest of record
	tra	endrec		done with record

ignore:	adx3	1,du		increment input record offset
	sbx4	1,du		decrement remaining record length
	tpnz	lp		scan rest of record
	tra	endrec		done with record
"
"
"	Come here when other than an ignore or escaped print is to be performed.
"
"
space:	arl	6+4		split the key and value
	tra	*+1,au		do the right thing
	tra	feed_countdown	00xxxx => feed by countdown
	tra	feed_vfu		01xxxx => feed to xxxx on VFU loop
	tra	insert_spaces	10xxxx => insert 8*xxxx spaces

	null			11xxxx => if not 77(8) then no action
no_action:
	adx3	2,du		increment input record offset
	sbx4	2,du		decrement remaining record length
	tpnz	lp		scan rest of record
	tra	endrec		done with record

insert_spaces:
	als	4+3		get 8*xxxx in au
	ana	=o170,du
	mlr	(),(pr,x6,rl),fill(040)
	desc9a	*,0
	desc9a	ap|0,au
	sta	temp		save the number of spaces inserted
	adx6	temp		update the output offset
	adx3	2,du		increment the input record offset
	sbx4	2,du		decrement the remaining record length
	tpnz	lp		scan rest of record
	tra	endrec		done with record

feed_vfu:
	mlr	(),(pr,x6),fill(014)
	desc9a	*,0
	desc9a	ap|0,1
	adx6	1,du
	tra	endrec

feed_countdown:
	tnz	feeds
"	Provide for !0 => overprint.
"	Output 1 carriage return.
	lda	1,du
	mrl	(),(pr,x6,rl),fill(015)
	desc9a	*,0
	desc9a	ap|0,au
	tra	fin_feeds

"	Provide newlines.
"	Number of newlines in a-reg bits 18-21.
feeds:	als	4		get the number of lines
	ana	=o17,du
	mlr	(),(pr,x6,rl),fill(012)
	desc9a	*,0
	desc9a	ap|0,au  		add right number of newlines
fin_feeds:
	sta	temp
	adx6	temp		increment output buffer offset

endrec:	eppbp	bp|0,5		move pointer to next record
	cmpx1	0,du		end of block yet ?
	tnz	xlrcd		no

fini:	eppap	sp|0,*		restore ap
	stz	ap|6,*		return no of chars
	sxl6	ap|6,*
	return

xlasc:	eaq	0,5		get record length in chars
	qls	2
	mlr	(pr,rl),(pr,x6,rl)
	desc9a	bp|0,qu
	desc9a	ap|0,qu

	stq	temp
	adx6	temp		increment output buffer offset
	cmpa	6,dl		is this media code 6
	tnz	endrec		no
	mlr	(),(pr,x6),fill(012)  add a newline
	desc9a	*,0
	desc9a	ap|0,1
	adx6	1,du		increment output buffer offset
	tra	endrec

"
"
"	Translation tables...BCD to ASCII
"
"
uc_table:	aci	x0123456789[#@:>?x
	aci	x ABCDEFGHI&.](<\x
	aci	x^JKLMNOPQR-$*);'x
	aci	x+/STUVWXYZ_,%="!x

lc_table:	aci	X0123456789[#@:>?X
	aci	X abcdefghi&.](<\X
	aci	X^jklmnopqr-$*);'X
	aci	X+/stuvwxyz_,%="!X

tctable:	dec	0,0,0,1
	dec	0,0,0,0
	dec	0,0,0,0
	dec	0,0,0,1
	temp	temp,tally
	end




		    gcos_sysprint.pl1               11/19/82  1410.9rew 11/19/82  0948.9      285273



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


gcos_sysprint: gsp: proc;


/* 

     GSP  will  translate  a  sysout  or print file, produced by the gcos
     environment simulator, from BCD to ASCII, and either print it on the
     user's  terminal,  or  write  it  into  a  file  (whose  pathname is
     supplied) for later dprinting.
    
    	USAGE:  gcos_sysprint input_path {output_path} {-lower_case}
    
      1) input_path  is  the  pathname  of a sysout or print file.  If it
    		contains  the  special records that are placed in the
    		output file by the simulator, it will be treated as a
    		sysout file, and:
    
    			a) The  execution  report  will  be located
    			   within the file and printed first

					and

    			b) The  records  for  each activity will be
    			   grouped  by report code, and printed for
    			   each activity.
    
    		Otherwise,  the file will be treated as a print file,
    		and  its records will be converted and printed in the
    		order in which they appear in the input file, with no
    		grouping or reordering of any kind.
    
      2) output_path  is  the optional pathname of an output file.  If it
    		is  not  supplied,  lines  will  be  printed  on  the
    		terminal  as they are converted.  If the file already
    		exists, it will be replaced with no warning.
    
      3) -lower_case (-lc) is an optional control argument whose use will
    		cause  BCD  alphabetic characters to be translated to
    		lower  case  ASCII,  instead  of the default of upper
    		case.
    
     Translation  is  performed  by  gcos_sys_xlate_ (or its entry point,
     gcos_sys_xlate_lc_,  if  -lower_case is given), which will recognize
     ASCII  media  codes  (those  >=  5),  and  copy the ASCII characters
     without  translation,  allowing mixed upper and lower case output to
     be produced from ASCII input records.
    
*/
%page;
/* *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*     HISTORY     *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-* */


/*

   Author: Dick Snyder	1971

   Change: Tom Casey	Sep73, Dec73, Mar74, Aug74

   Change: Dave Ward	01/13/81

   Change: Dave Ward	01/20/81 potential bug indexing pdstring.

   Change: Dave Ward	02/17/81 write_line proc.  Delete initial form feed.

   Change: Scott C. Akers     09/24/81	Rewrite  the whole thing from scratch,
				using iox_ instead of ios_, increasing
				the  modularity  of  the  program, and
				chopping    out   oodles   of   GOTOs.
				Eliminate sorting of report codes.
				Ignore -temp_dir ctl_arg.

  Change: Ron Barstad         10/07/82  Increased size of outbuf to accomidate
                                        possible conversion of bcd control
                                        sequences into more than 1 ascii char 
*/
%page;
/*

			 D__e_t_a_i_l_s

     GSP  processes  two kinds of files: regular GCOS ASCII files, and
     files   which  contain  BCD  print_line  images  (variable-length
     records).

     When  GSP  is  first  called, it checks the file to see if it's a
     vanilla-flavored  GCOS file, or a SYSOUT file.  It then calls one
     of  two  routines,  if  the file fits one of these categories, or
     prints an error messages and quits if the file is inconsistent or
     nonconforming.
     
     The  first (and simplest) routine is "process_simple_file", which
     converts GCOS ASCII files to Multics ASCII in a form suitable for
     printing.  It simply reads a block from the input file, and ships
     it off to write_line for conversion and printing.

     The  second  is  "process_sysout_file",  which searches the input
     file  for the execution report, and prints it first.  If there is
     no  execution  report,  a warning is printed.  Once the execution
     report  (if  it  exists)  has  been  processed, we search for the
     individual  activities  which make up the rest of the file.  They
     are  already  ordered  within the file, but the reports within an
     activity  are  not  grouped  neatly  together.   Instead,  it  is
     possible  that  some  records for report 74 will be followed by a
     few  records  for report 00, and then some more stuff for 74.  It
     is  the  responsibility  of  GSP  to collect all the records with
     matching report codes before we can process the next report.

     Each  activity  has  an  offset  relative to the beginning of the
     input  file.   The  offset  (in 320-word blocks) is placed in the
     acty_table  entry  corresponding  to  the  ordinal  number of the
     activity.

     In  order  to  find  all  the  records which belong to a specific
     report,   we   have   two   routines,  "find_next_rept_code"  and
     "find_current_report_code",  which scan each activity looking for
     report  codes.   As  each report code is encountered, an entry is
     made  for  it  in the "encountered" table.  Once all records in a
     given  report  are printed, an entry for that report code is made
     in  the "done" table.  This insures that the report code will not
     be considered again within this activity.

		       << continued >>

*/
%page;
/*

     The  actual  output  mechanism  is  fairly  straightforward,  but
     tedious.   Once a block is read in, it is scanned for occurrences
     of  the  current  report  code.   Each  record which contains the
     current  report code is placed in an output block, and its length
     is  added  to  the  SIZE  field  of the output block control word
     (BCW).   When  the  input block is exhausted, the output block is
     shipped off to write_line for conversion and printing.

     There  were  other  possible  methods for accomplishing the task.
     The  original  method  was  to  gather up all the records for one
     report,  and  put them in a separate file.  Then, the next report
     was  gathered  up  and  put  away.   This continued until all the
     records had been picked up and put somewhere else.  This entailed
     the  opening  of  up  to  65 or 70 files for a large, complicated
     activity.   The  process  directory was often not large enough to
     hold  all these, and a special directory had to be specified as a
     workspace.   It  was  also  necessary  to move all that data back
     together  again  to  assemble  the  final  report.  This was very
     costly.

     Another  method  made  use of a linked list to keep track of each
     record  in  the  file.  This, too, entails some overhead, and the
     list could (potentially) be too large to fit in a single segment,
     and  would  overflow the process_directory.  The big advantage of
     this  method  is that it does not require shuffling large amounts
     of  data from file to file except for the final output stage.  It
     does,  however,  necessitate  the  maintenance  of  a  segment or
     segments  (each  255  pages  long)  to hold the list, so there is
     still the potential need to specify a directory for workspace.

     The  method  I  finally chose involves a bit more data-shuffling,
     but  requires  no  more  than  two  files  to  be open during the
     invocation  of  the command.  These are, naturally, the input and
     (possibly)  output files.  If the output is to be directed to the
     user's  terminal, only the input file is opened.  This completely
     eliminates  the  need  for  a  workspace  directory  of any kind,
     because  data  is moved from the input file as needed, converted,
     and  placed  in  the  output  file.   No  extra files are needed,
     regardless of the size of the input or output files.
						
     Upon  looking  over  the declarations, you will notice that there
     are  some  moderately  kinky uses of based structures.  Please be
     careful  when  modifying  the  code,  since  pointers are fragile
     creatures.   It  is  not  at all uncommon to change a pointer and
     discover that your I/O control block has magically disappeared.

			<< END >>

*/
%page;
	on   condition (cleanup)			/* Set up handlers. */
	     goto abnormal_exit;

 	call cu_$arg_count (nargs);
 	if   nargs = 0
 	then do;
 	     call com_err_ (error_table_$noarg,		/* No arguments. */
 			ENTRY_NAME,
 			USAGE);
	     goto quick_exit;
 	     end;
	call init_routine;				/* Initialize before reading args. */
	call cu_$arg_list_ptr (arglistp);		/* Get a pointer to the args */
	call process_args;				/* Process the args */
	if   code ^= 0
	then goto abnormal_exit;			/* Bail out if error. */

	call check_file;				/* See if file is sysout or vanilla flavored. */

	if   code ^= 0
	then do ;
	     call com_err_ (code, ENTRY_NAME, "^/^a",real_path);
	     goto abnormal_exit;
	     end;

	if   sysout_sw
	then call process_sysout_file;
	else call process_simple_file;

	if   code = 0
	then goto normal_exit;
	else goto abnormal_exit;


normal_exit:	;				/* If all goes well */

abnormal_exit:	;				/* When all doesn't go well */

 	call fixup_before_dying;			/* Don't leave loose ends dangling */

quick_exit:	;				/* Bail out if no args specified */

 	return;
%page;
attach_stream: proc (stream_name, iocb_ptr,		/* attaches all I/O streams */
		 pathname, mode);

dcl  stream_name	char(*)		parm;		/* INPUT */
dcl  iocb_ptr 	pointer		parm;		/* INPUT */
dcl  pathname	char(168)		parm;		/* INPUT */
dcl  mode		char(2)		parm;		/* INPUT */
dcl  attach_descr	char(200);
dcl  open_mode	fixed bin;

dcl (stream_io	init (3),
     stream_in	init (1)

    )		fixed bin internal static options (constant);


 	attach_descr = "vfile_ " || pathname;		/* Build the attach description */
 	call iox_$attach_name (stream_name,
 			   iocb_ptr,
 			   attach_descr,
 			   (null),
 			   code);

 	if code = 0				/* Don't mess with this unless */
	 | code = error_table_$noentry		/* the attachment went O.K. */

 	then do;
	     code = 0;

 	     if mode = "r"
 	     then open_mode = stream_in;
 	     else open_mode = stream_io;

 	     call iox_$open (iocb_ptr, open_mode, ("0"b), code);

 	     end;

 	return;

end attach_stream;
%page;
build_block: proc;					/* Build a block for output */

	BCW.BSN = BCW.BSN + 1;			/* Set this so write_line knows there's
						   a valid block. */
	RECORD_PTR = addr (BLOCK.DATA);
	block_ptr = addr (BCW.data);			/* Set up pointer to output block. */
	BCW.block_size = 0;				/* Start with empty output block. */
	rec_count = 0;
	do   while (rec_count < BLOCK.SIZE);		/* Move all records whose report code
						   matches the current one. */
	     if   RCW.REPORT_CODE = current_rept_code
	     then do;
		out_record = in_record;
		BCW.block_size = BCW.block_size + RCW.LENG + 1;
		block_ptr = addrel (block_ptr, RCW.LENG + 1);
		end;

	     rec_count = rec_count + RCW.LENG + 1;
	     RECORD_PTR = addrel (RECORD_PTR, RCW.LENG + 1);
	     end;

	return;

end build_block;
%page;
check_file: proc;					/* See if file is sysout or simple file.
						   If it's sysout, then set sysout_sw.
						   If it's not a legal GCOS file,
						   return a non-zero error code. */

	call rewind_file (in_ptr);
	if code = 0
	then do;
	     call read_stream (in_ptr, buffp, 16, dummy);
	     if code = 0
	     then do;
		if BCW.BSN ^= 1
		then code = error_table_$bad_file;
		else do;
		     if first_record.rec1 = "rec1"
		     then sysout_sw = "1"b;
		     else sysout_sw = "0"b;
		     end;
		end;
	     end;

	else code = 0;

	return;

end check_file;
%page;
detach_stream: proc (iocb_ptr);			/* Detach an I/O stream */

dcl  iocb_ptr	pointer		parm;		/* INPUT */

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

 	return;

end detach_stream;
%page;
expand_path: proc (n, in_path, dir_name, e_name)returns (bit (1));

/*
Expand in_path into dir_name and e_name and combine the two into real_path.
*/

dcl  dir_name	char(*)		parm;		/* OUTPUT */
dcl  e_name	char(*)		parm;		/* OUTPUT */
dcl  n		fixed bin		parm;		/* INPUT */
dcl  in_path	char(*)		parm;		/* INPUT */

 	call expand_pathname_ (in_path, dir_name, e_name, code);

 	if code = 0
 	then do;
 	     real_path = rtrim (dir_name) || ">" || rtrim (e_name);
 	     return ("0"b);
 	     end;
 	else do;
 	     call com_err_ (code, ENTRY_NAME, "^/""^a""^[ (arg ^i)^;^s^]", in_path, n>0, n);
 	     return ("1"b);
 	     end;

end expand_path;
%page;
find_activities: proc;				/* Find activities in a sysout file */

	call rewind_file (in_ptr);
	if code = 0
	then do;
	     acty_table (1) = 0;			/* First activity */
	     acty_index = 2;
	     acty_count, acty_offset = 0;
	     unspec (buffer) = "0"b;
	     more_actys = "1"b;
	     do   while (more_actys);			/* Pick up all the activity offsets. */
		acty_table (acty_index) = 0;
		acty_offset = 0;
		do   while (acty_offset = 0);
		     call read_stream (in_ptr,	/* Grab a block */
				   buffp,
				   (sysout_chunk.chars),
				   dummy);
		     if code ^= 0
		      | eofsw			/* We should NEVER have an EOF.
						/* We'll know we're done when
						/* we see the "start ex rpt" string. */
		     then do;
			if code = 0
			then code = error_table_$end_of_info;
			call com_err_ (code,
				     ENTRY_NAME,
				     "^/Error while reading input file.");
			end;
		     else do;
			acty_offset = index (buffer, "start ex rpt");
			if acty_offset = 0
			then do;
			     acty_offset = index (buffer, "end activity");
			     if acty_offset > (4 * BCW.block_size)
			     then acty_offset = 0;
			     acty_table (acty_index) = acty_table (acty_index) + sysout_chunk.blocks;
			     end;
			else do;
			     more_actys = "0"b;
			     end;
			end;
		     end;

		acty_index = acty_index + 1;

     		end;

	     acty_count = acty_index - 3;

	     end;

	return;

end find_activities;
%page;
find_current_rept_code: proc;

/*
       Scan the block for the current report code (current_rept_code),
       and set "found" true if we find it.  Otherwise, leave it false.
       As  we're doing this, we also make entries in the "encountered"
       table, so we know what report codes are left to be checked.
*/

	rec_count = 0;
	found = "0"b;
	RECORD_PTR = addr (BLOCK.DATA);

	do   while (rec_count < BLOCK.SIZE);

	     encountered (RCW.REPORT_CODE) = "1"b;
	     if   RCW.REPORT_CODE = current_rept_code
	        & ^done (current_rept_code)
	     then found = "1"b;
	     rec_count = rec_count + RCW.LENG + 1;
	     RECORD_PTR = addrel (RECORD_PTR, RCW.LENG+1);
	     end;

	return;

end find_current_rept_code;
%page;
find_next_rept_code: proc;				/* Scan the block for the next report code.
						   Note: This routine cannot be merged with
						   find_current_rept code because it is not
						   always called. */

	rec_count = 0;
	RECORD_PTR = addr (BLOCK.DATA);
	current_rept_code = 62;			/* Gotta pretend we've already got a dead one. */

	do   while (rec_count < BLOCK.SIZE & done (current_rept_code));
	     encountered (RCW.REPORT_CODE) = "1"b;
	     current_rept_code = RCW.REPORT_CODE;
	     rec_count = rec_count + RCW.LENG + 1;
	     RECORD_PTR = addrel (RECORD_PTR, RCW.LENG+1);
	     end;

	if ^done (current_rept_code)			/* If we find a winner */
	then call make_rept_code_banner;		/* then print the banner. */

	return;

end find_next_rept_code;
%page;
fixup_before_dying: proc;				/* clean up for both normal and abnormal terminations */

 	call detach_stream (in_ptr);
	call detach_stream (out_ptr);

 	return;

end fixup_before_dying;
%page;
init_routine: proc;					/* Perform initialization stuff */


 	in_dir, in_ent, out_dir, out_ent = " ";
 	out_stream = "user_output";
	in_ptr, out_ptr = null;
	sysout_sw = "0"b;
 	buffp = addr (buffer);
 	outbufp = addr (outbuf);
	recbuffp = addrel (buffp, 1);
	recordp = addrel (buffp,2);
	output_record_count = 0;
	acty_table = 0;

	do   ptr_index = 0 to (chunk_size.blocks - 1);
	     buff_ptr(ptr_index) = addrel (buffp, (320*ptr_index));
	     end;

	return;

end init_routine;
%page;
make_rept_code_banner: proc;				/* Prints report code headers on
						   terminal or output file. */

	if   out_ptr = null
	then call ioa_$ioa_switch (iox_$user_output,
			  "^2/   SNUMB# ^5a, Activity # ^2d, REPORT CODE = ^2o^2/",
			  snumb,
			  acty_index,
			  current_rept_code);

	else call ioa_$ioa_switch (out_ptr,
			  "^|   SNUMB# ^5a, Activity # ^2d, REPORT CODE = ^2o^2/",
			  snumb,
			  acty_index,
			  current_rept_code);

	return;

end make_rept_code_banner;
%page;
more_reports_in_acty: proc returns (bit (1));		/* Returns true if there are more reports
						   in the current activity, and
						   returns false otherwise. */

	match = "0"b;
	do   test_index = 0 to 63 while (^match);
	     match = (encountered (test_index) & ^done (test_index));
	     end;

	return (match);

dcl  match	bit(1);
dcl  test_index	fixed bin;

end more_reports_in_acty;
%page;
position_file: proc (file_ptr, file_position);		/* Sets the file pointer to the indicated word */

dcl  file_ptr	ptr		parm;		/* INPUT */
dcl  file_position	fixed bin (21)	parm;		/* INPUT */

	call iox_$position (file_ptr, (2), (4 * file_position), code);

	return;

end position_file;
%page;
process_args: proc;					/* Argument processing.
						   If an error occurs, it is reported here, so
						   the caller doesn't have to do anything but die. */

	do   argno = 1 to nargs;

 	     call cu_$arg_ptr_rel	(argno, argp, argl,
				code, arglistp);

 	     if code ^= 0
 	     then do;
		call com_err_ (code, ENTRY_NAME, "^/Arg ^i.", argno);
		goto exit_p_a;
		end;

 	     if argno = 1
 	     then do;				/* First arg must be input file. */
 		in_stream = "gcos_sysprint_input_";
 		if expand_path (argno, arg, in_dir, in_ent)
 		then do;
		     code = error_table_$badopt;
		     call com_err_ (code, ENTRY_NAME,
				"^/Arg #^i (^a)",
				argno, arg);
		     goto exit_p_a;
		     end;

 		call attach_stream (in_stream, in_ptr, real_path, "r");
 		if code ^= 0
 		then do;
 		     call com_err_ (code, ENTRY_NAME,
				"^/Cannot attach input stream ^a:^/^a",
				in_stream, real_path);
 		     goto exit_p_a;
 		     end;

		end;				/* END OF ARG 1 PROCESSING */

 /* 	Get possible second argument - name of file to write output into	 */

 	     else
 	     if argno = 2
	     then do;
 		if substr (arg, 1, 1) = "-"
		then do;				/* must be control arg */
		     call process_ctl_arg;
		     if code ^= 0
		     then do;
			call com_err_ (code, ENTRY_NAME,
				     "^/Arg #^i (^a)",
				     argno, arg);
			goto exit_p_a;
			end;
		     end;

		else do;
		     filesw = "1"b;			/* it must be a file name */
		     out_stream = "GSP_output_";	/* write output file thru this stream */				

		     if expand_path (argno, arg, out_dir, out_ent)
		     then do;
			call com_err_ (code, ENTRY_NAME,
				     "^/Arg #^i (^a)",
				     argno, arg);
			goto exit_p_a;
			end;

		     call attach_stream (out_stream,	/* attach output name */
				     out_ptr,
				     real_path,
				     "rw");

		     if code ^= 0
		     then do;
			call com_err_ (code, ENTRY_NAME,
				     "^/Cannot attach output stream ^a:^/^a",
				     out_stream, real_path);
			goto exit_p_a;
			end;
		     end;
		end;				/* END OF ARG 2 PROCESSING */

 	     else if temp_sw
		then temp_sw = "0"b;		/* if previous arg was -temp_dir, this is the path */

 	     else do;
		call process_ctl_arg;
		if code ^= 0
		then do;
		     call com_err_ (code, ENTRY_NAME, arg);
		     goto exit_p_a;
		     end;
		end;
	     end;

exit_p_a:	;

	return;

end process_args;
%page;
process_ctl_arg: proc;				/* Parse the control arguments */

	code = 0;
	if arg = "-lc" | arg = "-lower_case"
	then lc_switch = "1"b;

     else if arg = "-td" | arg = "-temp_dir"
	then temp_sw = "1"b;			/* path of temp_dir will be next arg */

     else code = error_table_$badopt;

	return;

end process_ctl_arg;
%page;
process_ex_rept: proc;				/* Process the execution report */

	acty_index = 0;				/* For write_line, if error */
	call rewind_file (in_ptr);
	if   code = 0
	then call read_stream (in_ptr, buffp, 28, dummy);	/* Get info for execution report */
	if code = 0
	then do;
	     snumb = first_record.jobs_snumb;		/* Pick up SNUMB and EX REPT offset */
	     if   first_record.er_offset = 0
	     then do;
		call com_err_ (0, ENTRY_NAME,
			     "WARNING: Incomplete sysout file - execution report missing");
		end;
	     else do;

		call position_file (in_ptr, (first_record.er_offset));
		if code ^= 0
		then do;
		     call com_err_ (code, ENTRY_NAME,
				"Attempting to position input file");
		     end;
		else do;
		     call read_stream (	in_ptr,
				     buffp,
				     (chunk_size.chars),
				     dummy);

		     do   while (^eofsw & code = 0);

			do   ptr_index = 0 to (output_block_count - 1) while (code = 0);
			     buffp = buff_ptr (ptr_index);
			     call write_line;
			     end;

			if code = 0
			then do;
			     buffp = addr (buffer);

			     call read_stream (  in_ptr,
					     buffp,
					     (chunk_size.chars),
					     dummy);
			     end;
			end;
		     end;
		end;
	     end;

	return;

end process_ex_rept;
%page;
process_rept_codes: proc;				/* Collect and print report codes within an activity. */

						/* Determine the absolute file position
						   for this activity. */
	acty_offset = acty_offset + (320 * acty_table (acty_index));

	done, encountered = "0"b;			/* Reset the "done" flags for this activity. */
	current_rept_code = 62;			/* Force a guaranteed non-kosher
						   report code (76 octal). */
	encountered (62) = "1"b;			/* Gotta fake out the "more report" finder. */
       
	do   while (code = 0 & more_reports_in_acty ());

	     done (62) = "1"b;			/* So we don't keep looking for this rept code */
	     call position_file (in_ptr, (acty_offset));

	     do   rept_index = 1 to acty_table (acty_index+1) while (code = 0);

		call read_stream (  in_ptr,
				addr (BLOCK),
				1280,
				dummy);

		if code = 0
		then do;
		     if   done (current_rept_code)
		     then call find_next_rept_code;	/* Find the next report code */
		     if ^done (current_rept_code)
		     then do;
			call find_current_rept_code;	/* Scan block for current report code. */
			if   found		/* If we find it */
			then do;
			     call build_block;	/* Build the output block. */
			     call write_line;	/* Write block to output stream. */
			     end;
			end;
		     end;
		end;

	     done (current_rept_code) = "1"b;		/* Mark this report code as "used up". */

	     end;

	return;

end process_rept_codes;
%page;
process_simple_file: proc;				/* Process a regular GCOS file */

	call rewind_file (in_ptr);			/* Rewind the input file */
	call read_stream (in_ptr,			/* Pick up the first 3 blocks. */
		        buffp,
		        (chunk_size.chars),
		        dummy);

	if code ^= 0
	 | eofsw
	then call com_err_ (code, ENTRY_NAME, "^/Error while reading ^a", in_stream);
	else do   while (^eofsw);

		do   ptr_index = 0 to (output_block_count - 1);
		     buffp = buff_ptr (ptr_index);
		     call write_line;
		     end;

		buffp = addr (buffer);

		call read_stream (in_ptr,
			        buffp,
			        (chunk_size.chars),
			        dummy);

		end;

 
	return;

end process_simple_file;
%page;
process_sysout_file: proc;				/* Process a SYSOUT file */

	call process_ex_rept;			/* Do the execution summary first. */
	if code = 0				/* Bail out if it blows up. */
	then do;
	     call find_activities;			/* Locate all the activities in this file. */
	     call rewind_file (in_ptr);
	     acty_offset = 0;			/* Reset the activity offset,
						   because we use it in the
						   report-code processor to 
						   determine our absolute
						   file position. */

	     do   acty_index = 1 to acty_count;
		BCW.BSN = 0;			/* Reset before each activity. */
		call process_rept_codes;
		end;
	     end;

	return;

end process_sysout_file;
%page;
read_stream: proc (iocb_ptr, buffer_ptr, how_many, qty_got);

/*

   Read  from  the  indicated  stream  and place the data in the
   buffer pointed to by buffer_ptr.  If fewer than the requested
   number  of characters are read, we set a flag, and return the
   EOF  indication  the  next time around.  If the read comes up
   short for any reason other than error_table_$short_record, we
   return an error.

*/

dcl (iocb_ptr, buffer_ptr)	ptr		parm;	/* INPUT, INPUT */
dcl (how_many, qty_got)	fixed bin (21)	parm;	/* INPUT, OUTPUT */

dcl  short_switch		bit (1) internal static init ("0"b);

	if short_switch
	then do;
	     eofsw = "1"b;
	     short_switch = "0"b;
	     end;

	else do;
	     eofsw = "0"b;
	     call iox_$get_chars  (   iocb_ptr,
				buffer_ptr,
				how_many,
				qty_got,
				code);

	     if code ^= 0
	     then if code = error_table_$end_of_info
		then do;
		     eofsw = "1"b;
		     code = 0;
		     end;

		else if code = error_table_$short_record
						/* Short blocks are O.K. We'll get
						   an EOF next time 'round. */
		     then do;
			code = 0;
			short_switch = "1"b;
			end;

		end;

	output_block_count = ceil (divide (qty_got, (4*320), 17));

	return;

end read_stream;
%page;
rewind_file: proc (iocb_ptr);				/* Rewind the specified file */

dcl  iocb_ptr	ptr	parm;			/* INPUT */

	call iox_$position (iocb_ptr, (-1), 0, code);
	if code ^= 0
	then call com_err_ (code, ENTRY_NAME,
			"^/Could not rewind file.");

	return;

end rewind_file;
%page;
write_line: proc;					/* Write the next output line. */

	if   BCW.BSN ^= 0
	   & BCW.block_size ^= 0
	then do;

 	     if lc_switch				/* if -lowercase control argument given */
	     then call gcos_sys_xlate_lc_ (buffp,	/* translate buffer from BCD to lowercase ASCII */
				     outbufp,
				     conv_count);
 	     else call gcos_sys_xlate_ (buffp,		/* translate buffer from BCD to uppercase ASCII */
				  outbufp,
				  conv_count);

 	     output_record_count = output_record_count + 1;
	     j = conv_count;
 	     if output_record_count = 1
 	      & char1 = "014"b3

	     then call write_stream (out_ptr, addr (out1(2)), (j-1));
 	     else call write_stream (out_ptr, outbufp, (j));

 	     if code ^= 0
	     then do;
		call com_err_ (code,
			     ENTRY_NAME,
			     "^/Error attempting to write Activity # ^2d."
			  || "^/Block # ^6o (octal), ^6d (decimal)^/",
			     
			     acty_index,
			     BCW.BSN,
			     BCW.BSN);
		end;

	     end;

	return;

end write_line;
%page;
write_stream: proc (iocb_ptr, buffer_ptr, qty_sent);	/* Write on the specified output stream */

dcl  stream_ptr ptr;

dcl (iocb_ptr ptr,					/* INPUT */
     buffer_ptr ptr,				/* INPUT */
     qty_sent fixed bin (21)		) parm;		/* INPUT */

	if iocb_ptr = null				/* See if terminal I/O */
	then stream_ptr = iox_$user_output;
	else stream_ptr = iocb_ptr;

	call iox_$put_chars (stream_ptr, buffer_ptr, qty_sent, code);

	return;

end write_stream;
%page;
 /*	Variables for gcos_sysprint:		*/

 /*   IDENTIFIER		ATTRIBUTES	*/

dcl  acty_table		(1:64) fixed bin (35);
dcl (acty_index,
     acty_count,
     acty_offset)		fixed bin;
dcl (addr,
     addrel)		builtin;
dcl  arg			char (argl) based (argp);
dcl  argl			fixed bin (21);
dcl  argno		fixed bin;
dcl  argp			pointer;
dcl  arglistp		pointer;
dcl  block_ptr		pointer;
dcl  buffer		char (chunk_size.chars);
dcl  buffp		pointer;
dcl  buff_ptr		(0:chunk_size.blocks) pointer;
dcl  ceil			builtin;
dcl  char1                    bit(9) unaligned based (outbufp);
dcl  1 chunk_size 		internal static aligned options (constant),
      2 blocks		fixed bin init (3),
      2 words		fixed bin init (960),
      2 chars		fixed bin init (3840);
dcl  cleanup		condition;
dcl  code			fixed bin(35);
dcl  com_err_		entry() options(variable);
dcl  conv_count		fixed bin;
dcl  cu_$arg_count		ext entry (fixed bin);
dcl  cu_$arg_ptr_rel	ext entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr);
dcl  cu_$arg_list_ptr	ext entry (ptr);
dcl  divide		builtin;
dcl  done			(0:63) bit (1);
dcl  encountered		(0:63) bit (1);
dcl  ENTRY_NAME		char(19) int static options (constant)
			init ("gcos_sysprint(10.0)");
dcl  eofsw		bit (1);
dcl (error_table_$badopt,
     error_table_$bad_file,
     error_table_$end_of_info,
     error_table_$noarg,
     error_table_$noentry,
     error_table_$short_record

    )			ext fixed bin (35);

dcl  expand_pathname_	entry (char(*), char(*), char(*), fixed bin(35));
dcl  filesw		bit (1) init ("0"b);
dcl  file_index		fixed bin init (-1)		/* current file index used */;
dcl  found		bit (1);
dcl  gcos_sys_xlate_	ext entry (pointer, pointer, fixed bin);
dcl  gcos_sys_xlate_lc_	ext entry (pointer, pointer, fixed bin);
dcl  index		builtin;
dcl  in_dir		char(168);
dcl  in_ent		char(32);
dcl  in_ptr		pointer;
dcl  in_record		char (4*(RCW.LENG+1)) based (RECORD_PTR);
dcl  in_stream		char(32);
dcl (ioa_$ioa_switch entry() options(variable),
     iox_$position entry (ptr, fixed bin, fixed bin(21), fixed bin(35)),
     iox_$get_chars entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
     iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)),
     iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)),
     iox_$close entry (ptr, fixed bin(35)),
     iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)),
     iox_$detach_iocb entry (ptr, fixed bin(35)),
     iox_$destroy_iocb entry (ptr, fixed bin(35)),
     iox_$user_output pointer static
    )		external;

dcl  j			fixed bin(21);
dcl  lc_switch		bit (1) aligned init ("0"b)	/* "1"b => "-lower_case was given" */;
dcl  more_actys		bit (1);
dcl  nargs		fixed bin;
dcl  null			builtin;
dcl  current_rept_code	fixed bin (6) unsigned unaligned;
dcl  out1			(2) char(1) unaligned based (outbufp);
dcl  outbuf		char (2100);
dcl  outbufp		pointer;
dcl  output_block_count	fixed bin;
dcl  output_record_count	fixed bin;
dcl  out_dir		char(168);
dcl  out_ent		char(32);
dcl  out_ptr		pointer;
dcl  out_record		char (4*(RCW.LENG+1)) based (block_ptr);
dcl  out_stream		char(32);
dcl  ptr_index		fixed bin;
dcl  rec_count		fixed bin (35);
dcl  recbuffp		ptr;
dcl  recordp		pointer;
dcl  rept_index		fixed bin (35);
dcl  rtrim		builtin;
dcl  snumb		char (5) init ("");
dcl  substr		builtin;
dcl  1 sysout_chunk		internal static options (constant),
      2 blocks		fixed bin (21) init (1),
      2 words		fixed bin (21) init (320),
      2 chars		fixed bin (21) init (1280);
dcl  sysout_sw		bit (1) aligned		/* "1"b => "this is a sysout file" */;
dcl  temp_sw		bit (1) aligned init ("0"b)	/* on when path of temp dir expected */;
dcl  real_path		char (168);

dcl  unspec		builtin;
dcl  USAGE		char(78)static int options(constant) init(
 "^/USAGE: gcos_sysprint input_path {output_path} {-lower_case}"
 );

dcl 1 first_record aligned based (recordp),		/* overlay for very first record of a sysout file */
     2 newline_word bit (36),				/* contains BCD newline, for benefit of gcos_sys_xlate_ */
     2 rec1 char (4),				/* must = "rec1" before we believe the rest of this stuff */
     2 er_offset fixed bin aligned,			/* offset to seek to, to read execution report */
     2 jobs_snumb char (5)				/* snumb of this job, for heading lines */;

dcl 1 BCW aligned based (buffp),
     2 BSN	fixed bin (18) unsigned	unaligned,
     2 filler_1	bit	(9)		unaligned,
     2 block_size	fixed bin	(9)  unsigned	unaligned,
     2 data	char	(1276)		unaligned;

dcl  dummy		fixed bin (21);
%page;
%include gcos_block_overlay;
end gcos_sysprint;




		    gcos_syspunch.pl1               11/19/82  1544.7rew 11/19/82  1544.1      112446



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


/*

	   This  procedure  takes  a  segment  which contains BCD
	   and/or  binary card images in GCOS standard format and
	   produces   another   segment,   NAME.raw,   which   is
	   acceptable for punching by the daemon in "raw" mode.

*/
%page;
/*

   Written by Dick Snyder		??? 71
   Modified by P. Haber		AUG 73
   Modified by T. Casey		DEC 74
   Modified by R.H. Morrison		MAY 76
   Modified by S. C. Akers		NOV 81	Clean up after termination.
					Improve modularity.
					Perform argument validation.
					Convert to iox_.
					Change expand_path_ to expand_pathname_.
					Eliminate use of gcos_gsr_read_.
					Remove GOTOs.

*/
%page;
gcos_syspunch: gspn: proc;

	on   condition (cleanup)
	     call syspunch_cleanup;

	call process_arg;				/* Check for legal pathname. */
	if   code = 0
	then do;

	     call attach_input;			/* Attach the I/O streams. */
	     if   code = 0
	     then do;

		call attach_output;
		if   code = 0
		then call convert_file;		/* Do the actual work. */
		end;

	     call syspunch_cleanup;			/* Clean up after ourselves */
	     end;

	return;

%page;
attach_input: proc;					/* Attach the input stream. */

	call iox_$attach_name ("gcos_syspunch_input_",
			   in_ptr,
			   "vfile_ " || in_path,
			   (null),
			   code);

	if   code = 0
	then call iox_$open (in_ptr, 1, ("0"b), code);

	if   code ^= 0
	then call com_err_ (code, my_name, "^/^a", in_path);

	return;

end attach_input;

/*
   ******************************************************************************************
   ******************************************************************************************
   ******************************************************************************************
*/

attach_output: proc;				/* Attach the output stream. */

	call hcs_$make_seg ((out_dir), out_name, "", 11, out_ptr, code);
	if   code ^= 0
	then do;
	     if   code = error_table_$segknown
	        | code = error_table_$namedup

	     then code = 0;				/* Certain codes are O.K. */

	     else call com_err_ (code, my_name, "^/^a", out_path);
	     end;

	return;

end attach_output;
%page;
convert_bcd: proc;					/* Convert a BCD card image. */

	do   i = 1 to record_len;			/* Put a punch image of BCD char in card image */

	     out_olay.cols (i) = transmog (fixed (bit (in_olay (i), 6), 17));
	     end;

	do   j = i to 80;
	     out_olay.cols (j) = ""b;	/* Blank fill remaining columns. */
	     end;

	call get_record;				/* Get the next record. */

	return;

end convert_bcd;

/*
   ******************************************************************************************
   ******************************************************************************************
   ******************************************************************************************
*/

convert_binary: proc;				/* Convert binary card image. */

	i = record_len * 6;				/* Get bit length of record. */
	outbuf = bits;				/* Copy record into output record. */
	if   i < 960
	then substr (outbuf, i+1, 960-i) = ""b;		/* Zero out rest of punch record. */

	call get_record;				/* Get the next record. */

	return;

end convert_binary;
%page;
convert_file: proc;					/* Perform the actual conversion. */

	BLOCK.SIZE, curr_bsn, outindex, words_used = 0;	/* Initialize some things. */
	data_read, eofsw = "0"b;			/* Haven't read anything yet. */

	call get_record;				/* Get a data record. */

	if   ^eofsw
	   & code = 0
	then data_read = "1"b;			/* Remember that we read some data. */


	do   while (^eofsw & code = 0);

	     outindex = outindex+1;			/* Bump output card image index. */

	     if   RCW.MEDIA_CODE = 1			/* Binary card image. */
	     then call convert_binary;

	     else if   RCW.MEDIA_CODE = 2		/* Hollerith card image. */
		then call convert_bcd;

		else do;
		     call com_err_ (0, my_name,
				"Record not binary or Hollerith card image.^2/^a^5o^10x^a^7d^/",
				"Block #", BLOCK.BSN, "  Record #", outindex);

		     code = error_table_$improper_data_format;	/* So we get out of the loop */
		     end;
	     out_ptr = addr (out_olay.next_out_olay);
	     end;

	if   code ^= 0
	then call com_err_ (code, my_name,
			"^/Error while reading:^/^a",
			in_path);

	if   ^data_read
	   & eofsw
	then call com_err_ (0, my_name,
			"No data found on file:^/^a",
			in_path);

	call hcs_$set_bc ((out_dir), out_name,	/* Set bitcount of output seg. */
		        960*outindex, code);
	if   code ^= 0
	then call com_err_ (code, my_name,
			"^/Attempting to set bitcount on: ^/^a",
			out_path);

	return;

end convert_file;
%page;
get_record: proc;					/* Takes care of reading the
						   the input file and returning
						   a record. */

	code = 0;					/* Start off clean. */
	if   words_used >= BLOCK.SIZE			/* Any more data in this block? */
	then do;
	     call iox_$get_chars (in_ptr, addr(BLOCK),
			      1280, how_many, code);

	     if   code = 0
	     then do;
		curr_bsn = curr_bsn + 1;		/* Bump block counter. */
		if   BLOCK.BSN = curr_bsn
		then do;
		     RECORD_PTR = addr(BLOCK.DATA);
		     if   RCW.EOF_MARKER = "0"b
		     then do;
			inp = addrel (RECORD_PTR, 1);
			words_used = RCW.LENG + 1;
			record_len = RCW.LENG * 6;
			if   record_len > 80
			then record_len = 80;
			end;

		     else eofsw = "1"b;
		     end;

		else do;
		     code = error_table_$bad_file;
		     call com_err_ (0,my_name,
				"Block serial number error while reading block #^5o",
				curr_bsn,
				in_path);
		     end;

		end;
	     else if   code = error_table_$end_of_info
		then do;
		     eofsw = "1"b;
		     code = 0;
		     end;
		else call com_err_ (code, my_name,
				"^/Error while reading:^/^a",
				in_path);

	     end;

	else do;
	     RECORD_PTR = addrel (RECORD_PTR, (RCW.LENG + 1));
	     if RCW.EOF_MARKER = "0"b
	     then do;
		inp = addrel (RECORD_PTR, 1);
		words_used = words_used + RCW.LENG + 1;
		record_len = RCW.LENG * 6;
		if   record_len > 80
		then record_len = 80;
		end;

	     else eofsw = "1"b;
	     end;

	return;

end get_record;
%page;
process_arg: proc;					/* Check the input pathname for legality */

	code = 1;					/* Assume we're gonna fail.
						   It will get reset if we
						   make it to the arg-checker. */

	call cu_$arg_count (nargs);
	if   nargs < 1
	then call com_err_ (error_table_$noarg, my_name,
			"^/You must supply a pathname.");
	else if   nargs > 1
	     then call com_err_ (error_table_$too_many_args, my_name,
			     "^/Only one argument allowed.");
	     else do;

		call cu_$arg_ptr (1, argp, arglen, code);    /* Get pathname. */
		if   code = 0
		then do;

		     input_arg = substr (arg, 1, arglen);    /* Chop garbage off end of arg */

		     call expand_pathname_ (input_arg, in_dir,
				        in_name, code);
		     if   code = 0
		     then in_path =    rtrim (in_dir)
				|| ">"
				|| in_name;

		     else call com_err_ (code, my_name, "^/^a", input_arg);

		     end;

		else call com_err_ (code, my_name);

		end;

	if   code = 0
	then do;
	     call expand_pathname_$add_suffix ( in_name,    /* Build output pathname. */
					"raw",
					out_dir,
					out_name,
					code);
	     if   code = 0
	     then out_path  =   rtrim (out_dir)
			 || ">"
			 || out_name;

	     else call com_err_ (code, my_name, "^/^a.raw", in_name);
	     end;

	return;

end process_arg;
%page;
syspunch_cleanup: proc;				/* Close files and clean up. */

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

	return;

end syspunch_cleanup;
%page;
dcl (arglen, i, j, outindex) fixed bin;
dcl (argp, inp, out_ptr) pointer;
dcl  arg char (168) based (argp);
dcl  bits bit (i) aligned based (inp);
dcl  code fixed bin (35);
dcl  curr_bsn fixed bin (35);
dcl  data_read bit (1);
dcl  eofsw bit (1);
dcl  how_many fixed bin (21);
dcl  in_dir char (168);
dcl  in_name char (32);
dcl  in_olay (80) bit (6) unaligned based (inp);
dcl  in_path char (168);
dcl  in_ptr pointer init (null);
dcl  input_arg char (168);
dcl  my_name char(16)	internal static options (constant)
			init ("gcos_syspunch");
dcl  nargs fixed bin;
dcl  out_dir char (168);
dcl  out_name char (32);
dcl  outbuf bit (960) unaligned based (out_ptr);
dcl  out_path char (168);
dcl  record_len fixed bin;
dcl  words_used fixed bin;
%page;
dcl 1  out_olay	 	based (out_ptr)		unaligned,
     2 cols	(80)	bit (12)			unaligned,
     2 next_out_olay	bit (1)			unaligned;


%include gcos_block_overlay;
%page;
dcl  cleanup condition;

dcl (
     addr, addrel, bit, fixed,
     index, null, rtrim, substr
    )				builtin;

dcl (
     error_table_$bad_file,
     error_table_$end_of_info,
     error_table_$improper_data_format,
     error_table_$namedup,
     error_table_$noarg,
     error_table_$segknown,
     error_table_$too_many_args
    )				fixed bin(35) ext static;

dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr ext entry (fixed bin, pointer, fixed bin, fixed bin (35));
dcl  com_err_ ext entry options (variable);
dcl  expand_pathname_ ext entry (char(*), char(*), char(*), fixed bin(35));
dcl  expand_pathname_$add_suffix ext entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  hcs_$set_bc ext entry (char(*), char(*), fixed bin(24), fixed bin(35));
dcl  hcs_$make_seg ext entry (char (*) aligned, char (*), char (*), fixed bin (5), pointer, fixed bin (35));

dcl (iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)),
     iox_$close entry (ptr, fixed bin(35)),
     iox_$destroy_iocb entry (ptr, fixed bin(35)),
     iox_$detach_iocb entry (ptr, fixed bin(35)),
     iox_$get_chars entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)),
     iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35))

     )	external;
%page;
dcl  transmog (0: 63) bit (12) aligned internal static init (

     "001000000000"b,				/* 0 */
     "000100000000"b,				/* 1 */
     "000010000000"b,				/* 2 */
     "000001000000"b,				/* 3 */
     "000000100000"b,				/* 4 */
     "000000010000"b,				/* 5 */
     "000000001000"b,				/* 6 */
     "000000000100"b,				/* 7 */
     "000000000010"b,				/* 8 */
     "000000000001"b,				/* 9 */
     "000010000010"b,				/* [ */
     "000001000010"b,				/* # */
     "000000100010"b,				/* @ */
     "000000010010"b,				/* : */
     "000000001010"b,				/* > */
     "000000000110"b,				/* ? */
     "000000000000"b,				/* blank */
     "100100000000"b,				/* A */
     "100010000000"b,				/* B */
     "100001000000"b,				/* C */
     "100000100000"b,				/* D */
     "100000010000"b,				/* E */
     "100000001000"b,				/* F */
     "100000000100"b,				/* G */
     "100000000010"b,				/* H */
     "100000000001"b,				/* I */
     "100000000000"b,				/* & */
     "100001000010"b,				/* . */
     "100000100010"b,				/* ] */
     "100000010010"b,				/* ( */
     "100000001010"b,				/* < */
     "100000000110"b,				/* \ */
     "011000000000"b,				/* ^ */
     "010100000000"b,				/* J */
     "010010000000"b,				/* K */
     "010001000000"b,				/* L */
     "010000100000"b,				/* M */
     "010000010000"b,				/* N */
     "010000001000"b,				/* O */
     "010000000100"b,				/* P */
     "010000000010"b,				/* Q */
     "010000000001"b,				/* R */
     "010000000000"b,				/* - */
     "010001000010"b,				/* $ */
     "010000100010"b,				/* * */
     "010000010010"b,				/* ) */
     "010000001010"b,				/* ; */
     "010000000110"b,				/* ' */
     "101000000000"b,				/* + */
     "001100000000"b,				/* / */
     "001010000000"b,				/* S */
     "001001000000"b,				/* T */
     "001000100000"b,				/* U */
     "001000010000"b,				/* V */
     "001000001000"b,				/* W */
     "001000000100"b,				/* X */
     "001000000010"b,				/* Y */
     "001000000001"b,				/* Z */
     "001010000010"b,				/* <- (left arrow) */
     "001001000010"b,				/* , */
     "001000100010"b,				/* % */
     "001000010010"b,				/* = */
     "001000001010"b,				/* " */
     "001000000110"b				/* ! */

     ) options (constant);

end gcos_syspunch;





		    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
