



		    cancel_cobol_program.pl1        05/24/89  1048.6rew 05/24/89  0837.3       38952



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cancel_cobol_program.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 10/25/76 by ORN to comply with error message standards */
/* Modified 03/26/76 by ORN to call cobol_control_$cancel and cobol_stop_run_.
	Change made in conjunction with cobol_control_ modification. */

/* format: style3 */
cancel_cobol_program:
ccp:
     proc;

dcl	(i, arglen, nargs)	fixed bin;
dcl	code		fixed bin (35);
dcl	(rdsw, rfsw)	fixed bin;

dcl	asw		bit (1);
dcl	found		bit (1);

dcl	argptr		ptr;
dcl	arg		char (arglen) based (argptr);

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	cobol_control_$cancel
			entry (char (*), fixed bin, fixed bin, fixed bin (35));
dcl	cobol_stop_run_	entry (ptr, fixed bin, fixed bin, fixed bin (35));

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


/*************************************/
start:
	asw = "0"b;
	rdsw, rfsw = 0;
	call cu_$arg_count (nargs);
	if nargs < 1
	then go to no_arg_error;
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argptr, arglen, code);
	     if code ^= 0
	     then go to multics_error;
	     if substr (arg, 1, 1) = "-"
	     then do;
		     if arg = "-a" | arg = "-all"
		     then asw = "1"b;
		     else if arg = "-retd" | arg = "-retain_data"
		     then rdsw = 1;
		     else if arg = "-rf" | arg = "-retain_files"
		     then rfsw = 1;
		     else go to control_arg_error;
		end;
	end;

	found = "0"b;
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argptr, arglen, code);
	     if code ^= 0
	     then go to multics_error;
	     if substr (arg, 1, 1) ^= "-"
	     then do;
		     if asw
		     then do;
			     call com_err_ (0, "cancel_cobol_program",
				"Redundant names specified with the -all option are ignored.");
			     i = nargs;
			end;
		     else do;
			     if arglen > 65
			     then go to arg_too_long_error;
			     call cobol_control_$cancel (arg, rdsw, rfsw, code);
			     if code ^= 0
			     then do;
				     if code = -2
				     then go to no_run_error;
				     else if code = -1
				     then go to no_prog_error;
				     else go to multics_arg_error;
				end;
			     found = "1"b;
			end;
		end;
	end;

	if asw
	then do;
		call cobol_stop_run_ (null (), rdsw, rfsw, code);
		if code ^= 0
		then go to no_run_error;
	     end;
	else if ^found
	then go to no_arg_error;
	return;


/*************************************/
no_prog_error:
	call com_err_ (0, "cancel_cobol_program", "The program ^a is not active in the current run-unit.",
	     substr (arg, 1, arglen));
	if code > 0
	then go to multics_error;
	return;

arg_too_long_error:
	call com_err_ (error_table_$bigarg, "cancel_cobol_program", substr (arg, 1, arglen));
	return;

no_run_error:
	call com_err_ (0, "cancel_cobol_program", "There are no active programs in the current run-unit.");
	if code > 0
	then go to multics_error;
	return;

no_arg_error:
	call com_err_ (error_table_$noarg, "cancel_cobol_program");
	return;

control_arg_error:
	call com_err_ (error_table_$badopt, "cancel_cobol_program", substr (arg, 1, arglen));
	return;

multics_error:
	call com_err_ (code, "cancel_cobol_program");
	return;

multics_arg_error:
	call com_err_ (code, "cancel_cobol_program", substr (arg, 1, arglen));
	return;

     end cancel_cobol_program;




		    cobol_FILE_.pl1                 05/24/89  1048.6rew 05/24/89  0837.3       71073



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_FILE_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_FILE_:
     proc;
	call com_err_ (0, "cobol_FILE_", "For documentation execute:^/ec >udd>LIS>Wardd>pr_doc cobol_FILE_ MPM");
	return;
IN:
     entry (cn, n1, n2, opn, p, l, k) returns (bit (1));
	p = null ();
	l = 0;					/* Initiate. */
	if length (opn) > 0
	then if ^gn (n1, n2, opn)
	     then call hcs_$initiate (dn, en, "", 0b, 00b, p, e);
	if p = null ()
	then do;
		if gn (n1, n2, "")
		then return ("1"b);
		call hcs_$initiate (dn, en, "", 0b, 00b, p, e);
	     end;
	if p = null ()
	then do;					/* Attempt to use names as an initiated segment. */
		call hcs_$make_ptr (null (), n1 || n2 || opn, "", p, e);
		if length (opn) > 0
		then if p = null ()
		     then call hcs_$make_ptr (null (), n1 || n2, "", p, e);
		if p ^= null ()
		then call hcs_$fs_get_path_name (p, dn, l1, wen, e);
	     end;
	if p = null ()
	then do;
		call com_err_ (e, cn, NAMES ());
		return ("1"b);
	     end;
	call hcs_$status_mins (p, tp, bc, e);
	if e > 0
	then do;
		call com_err_ (e, cn, (NAMES ()));
		return ("1"b);
	     end;
	if k = 0
	then do;
		call com_err_ (0, cn, "Warning,zero divide factor " || NAMES ());
		l = -bc;
		return ("1"b);
	     end;
	if k < 0
	then call com_err_ (0, cn, "Warning, divide factor (^d) negative " || NAMES (), k);
	if bc < 1
	then call com_err_ (0, cn, "Warning, bit-count zero " || NAMES ());
	l = divide ((bc + (k - 1)), k, 35, 0);
	return ("0"b);

LEN:
     entry (cn, n1, n2, l) returns (bit (1));
	if gn (n1, n2, "")
	then return ("1"b);
	if l < 0
	then call hcs_$delentry_file (dn, en, e);
	else do;
		call hcs_$set_bc (dn, en, fixed (l, 24), e);
		if e = 0
		then call hcs_$truncate_file (dn, en, divide ((l + 35), 36, 24, 0), e);
	     end;
	if e > 0
	then do;
		call com_err_ (e, cn, "Attempted bit-count ^d " || NAMES (), l);
		return ("1"b);
	     end;
	return ("0"b);

SBC:
     entry (cn, segp, l) returns (bit (1));
	if l < 0
	then call hcs_$delentry_seg (segp, e);
	else call hcs_$set_bc_seg (segp, fixed (l, 24), e);
	if e > 0
	then do;					/* Obtain  the segment's pathname. */
		call hcs_$fs_get_path_name (segp, dn, l1, en, e);
		call com_err_ (e, cn, "Attempted to set bi ^d " || NAMES (), l);
		return ("1"b);
	     end;
	return ("0"b);


OUT:
     entry (cn, n1, n2, opn, p) returns (bit (1));
	p = null ();
	if gn (n1, n2, "")
	then return ("1"b);
	do l1 = 1 to length (opn);			/* Verify that access is acceptable characters. */
	     l2 = index ("rewa", substr (opn, l1, 1));
	     if l2 < 1
	     then do;
		     call com_err_ (0, cn, "Parameter 4, access must be letters from ""rewa"", (""^a"").", opn);
		     return ("1"b);
		end;
	     substr (mode, (l2 + 1), 1) = "1"b;
	end;
	call hcs_$make_seg (dn, en, "", fixed (mode, 5), p, e);
	if p ^= null ()
	then do;
		call hcs_$truncate_file (dn, en, 0, e);
		call hcs_$set_bc (dn, en, 0, e);
	     end;
	if p = null ()
	then do;
		call com_err_ (e, cn, (NAMES ()));
		return ("1"b);
	     end;
	call hcs_$acl_add1 (dn, en, "*.*.*", 01100b, rbc, e);
	return ("0"b);

PROC:
     entry (cn, n1, n2, p) returns (bit (1));
	p = null ();
	SN = n1 || n2;
	EN = "";
	DN = "";
	i = index (SN, "$");
	if i > 0
	then do;					/* Specific entry name. */
		EN = substr (SN, (i + 1), (length (SN) - i));
		SN = substr (SN, 1, (i - 1));
	     end;					/* Isolate segment name from directory. */
	do i = length (SN) to 1 by -1 while ((substr (SN, i, 1) ^= ">") & (substr (SN, i, 1) ^= "<"));
	end;
	if i > 0
	then do;					/* More than a segment name input. */
		DN = substr (SN, 1, i);
		SN = substr (SN, (i + 1), (length (SN) - i));
	     end;
	if length (EN) < 1
	then EN = SN;				/* Entry name, if not specific. */
						/* Establish calling directory. */
	dp = null ();
	if length (DN) > 0
	then if ^gn ((DN), (SN), "")
	     then call hcs_$initiate (dn, en, "", 0b, 00b, dp, e);
	call hcs_$make_ptr (dp, (SN), (EN), p, e);
	if e > 0
	then do;
		call com_err_ (e, cn, "Could not obtain pointer to an entry from name ""^a^a""", n1, n2);
		return ("1"b);
	     end;
	return ("0"b);


/* Internal procedures. */
gn:
     proc (n1, n2, opn) returns (bit (1));		/* Obtain directory name in dn and entry name in en. */
	if length (n1) > 0
	then N = n1 || n2 || opn;
	else do;
		call cobol_set_pdir (N);
		N = N || ">" || n2 || opn;
	     end;
	call expand_path_ (addrel (addr (N), 1), length (N), addr (dn), addr (en), e);
	if e > 0
	then do;
		if length (opn) > 0
		then call com_err_ (e, cn, "for (""^a"",""^a"",[""^a""]).", n1, n2, opn);
		else call com_err_ (e, cn, "for (""^a"",""^a"").", n1, n2);
		return ("1"b);
	     end;
	return ("0"b);
dcl	(n1, n2, opn)	char (*) parm;
dcl	N		char (256) var;
     end gn;

NAMES:
     proc returns (char (256) var);
	l1 = index (en, " ");
	if l1 < 1
	then l1 = 33;
	else l1 = l1 - 1;
	l2 = index (dn, " ");
	if l2 < 1
	then l2 = 169;
	else l2 = l2 - 1;
	r = "Segment """ || substr (en, 1, l1) || """ in directory """ || substr (dn, 1, l2) || """.";
	return (r);

dcl	r		char (256) var;
     end NAMES;					/* Declarations for variables. */
dcl	(
	cn,					/* Caller's name. */
	n1,					/* Name left part. */
	n2,					/* Name right part. */
	opn					/* Name right optional part (| access mode. */
	)		char (*) parm,
	segp		ptr parm,			/* Input pointer. */
	p		ptr parm,			/* Output pointer. */
	l		fixed bin (35) parm,	/* Output length. */
	k		fixed bin (35) parm,	/* Bit-count divide constant. */
	(l1, l2)		fixed bin (35),
	bc		fixed bin (24),
	tp		bin (2),
	e		fixed bin (35),		/* Error code. */
	com_err_		entry options (variable) ext,
	mode		bit (5) aligned init ("00000"b),
	dn		char (169),
	(en, wen)		char (33);
dcl	(addr, addrel, null, substr, index, length)
			builtin;
dcl	expand_path_	entry (ptr, fixed bin (35), ptr, ptr, fixed bin (35)) ext,
	hcs_$initiate	entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)) ext,
	hcs_$status_mins	entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)) ext,
	hcs_$set_bc	entry (char (*), char (*), fixed bin (24), fixed bin (35)) ext,
	hcs_$set_bc_seg	entry (ptr, fixed bin (24), fixed bin (35)) ext,
	hcs_$delentry_file	entry (char (*), char (*), fixed bin (35)) ext,
	hcs_$delentry_seg	entry (ptr, fixed bin (35)) ext,
	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)) ext,
	hcs_$truncate_seg	entry (ptr, fixed bin (35), fixed bin (35)) ext,
	hcs_$truncate_file	entry (char (*), char (*), fixed bin (35), fixed bin (35)) ext,
	hcs_$fs_get_path_name
			entry (ptr, char (*), fixed bin (35), char (*), fixed bin (35)) ext,
	hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35)) ext;

dcl	hcs_$acl_add1	entry (char (*), char (*), char (*), fixed bin (5), (3) fixed bin (6), fixed bin (35)) ext;
dcl	rbc		(3) fixed bin (6) init (4, 4, 4) static internal;
dcl	cobol_set_pdir	entry (char (*) var) ext;
dcl	SN		char (256) var;
dcl	EN		char (32) var;
dcl	DN		char (168) var;
dcl	i		fixed bin (35);
dcl	dp		ptr;
     end cobol_FILE_;




		    cobol_FP_.pl1                   05/24/89  1048.6rew 05/24/89  0837.3       19134



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_FP_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_FP_:
     proc (p) returns (char (16) var);			/* Format the contents of pointer "p". */
	S = O (fixed (s, 36)) || "|" || O (fixed (w, 36));
	if fixed (b, 36) > 0
	then S = S || "(" || O (fixed (b, 36)) || ")";
	return ((S));

dcl	p		ptr parameter,
	1 ovlp		aligned based (addr (p)),
	  2 s		bit (18) unaligned,		/* Segment number. */
	  2 nu1		bit (12) unaligned,		/* Not used. */
	  2 its		bit (6) unaligned,		/* ITS. */
	  2 w		bit (18) unaligned,		/* Word offset. */
	  2 nu2		bit (2) unaligned,		/* Not used. */
	  2 b		bit (7) unaligned,		/* Bit offset. */
	  2 nu3		bit (3) unaligned,		/* Not used. */
	  2 nu4		bit (6) unaligned,		/* Not used. */
	S		char (16) var,
	addr		builtin;
O:
     proc (v) returns (char (16) var);			/* Return v a octal numeric. */
	if v = 0
	then R = "0";
	else do;
		bz = 0;
		lv = v;
		R = "";
		do while (lv > 0);
		     unspec (c) = substr (bit ((mod (lv, 8) + bz), 9), 1, 9);
		     R = c || R;
		     lv = lv / 8;
		end;
	     end;
	return (R);
dcl	v		fixed bin parameter,
	(lv, bz)		fixed bin,
	c		char (1),
	R		char (16) var,
	(mod, bit)	builtin;
     end O;
     end cobol_FP_;




		    cobol_MSORT_.pl1                05/24/89  1048.6rew 05/24/89  0837.3       59103



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_MSORT_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_MSORT_:
     proc;					/* Version 2. */

/*
	cobol_MSORT_ (a special version of SORT) inputs three data structures and a comparison
	procedure. The "records" specified by the data structures are sorted according
	to the comparison procedure and moved into the "next" merge storage areas (three
	similar data structures).

	The array I (based on SIp) contains SIi entries. Each value in I is the index
	to a row in R (based on SRp). Each row of R contains two values, a
	first bit and the number of bits in a "record" located in the S string (based
	on SSp). The records are sorted according to the procedure pointed to by "cmp".
	The result is stored in an R table and S string, in a sorted order, based on
	the pointers "rp" and "sp". A row in the I array (based on MIp) contains the
	number of records for the "next" merge string.
*/
	i = cobol_SM_$MIi + 1;			/* Count the merge strings. */
	if i > cobol_SM_$max4
	then do;
		cobol_SM_$ec = 4;
		signal condition (SORTM_STOP);
	     end;					/* Create the next merge string R and S segments. */
	if cobol_FILE_$OUT ("cobol_MSORT_", (cobol_SM_$sort_dir), "SRTM.MR." || cobol_NUMS_ (i), "rwa", rp)
	     | cobol_FILE_$OUT ("cobol_MSORT_", (cobol_SM_$sort_dir), "SRTM.MS." || cobol_NUMS_ (i), "rwa", sp)
	then do;
		cobol_SM_$ec = 5;
		signal condition (SORTM_STOP);
	     end;

	if i = 1
	then cmpe = cobol_SM_$cmp;			/* Assign the comparison procedure
				   at the  first call. */
	cobol_SM_$MIi = i;
	cobol_SM_$MIp -> I (i) = cobol_SM_$SIi;		/* The number of "records" in the "next" merge store. */
	cobol_SM_$MRp (i) = rp;			/* Pointer to "next" merge R table. */
	cobol_SM_$MSp (i) = sp;			/* Pointer to "next" merge S string. */

/*
	calculate the lengths of
	lists and their start pointers
	in a linear set.
*/
	t = 0;
	l = cobol_SM_$SIi;
	do n = 1 by 1 while (l > 1);
	     cobol_SM_$s (n) = t;			/* start of the next list. */
	     if substr (unspec (l), 36, 1)
	     then l = l + 1;			/* make the length even. */
	     t = t + l;				/* accumulate the lengths. */
	     l = l / 2;				/* next list is 1/2 the length of the present list. */
	end;
	n = n - 1;

/* fill in all lists. */
	do i = 2 to n;
	     lft = cobol_SM_$s (i - 1);
	     rit = cobol_SM_$s (i);
	     do j = 1 by 2 to (rit - lft);
		x = lft + j;
		v1 = cobol_SM_$SIp -> I (x);
		v2 = cobol_SM_$SIp -> I (x + 1);
		if v2 > 0
		then do;
			cobol_SM_$fb1 = cobol_SM_$SRp -> R.pt (v1);
			cobol_SM_$bl1 = cobol_SM_$SRp -> R.ln (v1);
			cobol_SM_$fb2 = cobol_SM_$SRp -> R.pt (v2);
			cobol_SM_$bl2 = cobol_SM_$SRp -> R.ln (v2);
			call cmpe;
			if cobol_SM_$result > 0
			then v1 = v2;
		     end;
		rit = rit + 1;
		cobol_SM_$SIp -> I (rit) = v1;
	     end;
	end;

/* calculate the list of pointers in o */
	y = cobol_SM_$s (n) + 1;
	do i = 1 to cobol_SM_$SIi;
	     v1 = cobol_SM_$SIp -> I (y);
	     v2 = cobol_SM_$SIp -> I (y + 1);
	     if (v1 = 0) & (v2 = 0)
	     then i = cobol_SM_$SIi + 1;		/* End "i" loop. */
	     else do;
		     if v1 = 0
		     then v1 = v2;
		     else if v2 > 0
		     then do;
			     cobol_SM_$fb1 = cobol_SM_$SRp -> R.pt (v1);
			     cobol_SM_$bl1 = cobol_SM_$SRp -> R.ln (v1);
			     cobol_SM_$fb2 = cobol_SM_$SRp -> R.pt (v2);
			     cobol_SM_$bl2 = cobol_SM_$SRp -> R.ln (v2);
			     call cmpe;
			     if cobol_SM_$result > 0
			     then v1 = v2;
			end;			/* Move the next sorted record to the merge  string. */
		     l = cobol_SM_$SRp -> R.ln (v1);
		     substr (sp -> S, ns, l) = substr (cobol_SM_$SSp -> S, cobol_SM_$SRp -> R.pt (v1), l);
		     np = np + 1;
		     rp -> R.pt (np) = ns;		/* Location of merge record. */
		     rp -> R.ln (np) = l;		/* The length of the merge record. */
		     ns = ns + l;
		     cobol_SM_$SIp -> I (v1) = 0;	/* delete the last winner. */
		     do j = 2 to n;			/* get the next winner. */
			lft = cobol_SM_$s (j - 1);
			if substr (unspec (v1), 36, 1)
			then v2 = v1 + 1;
			else v2 = v1 - 1;
			x = (v1 + 1) / 2;
			v1 = cobol_SM_$SIp -> I (v1 + lft);
			v2 = cobol_SM_$SIp -> I (v2 + lft);
			if v1 = 0
			then v1 = v2;
			else if v2 > 0
			then do;
				cobol_SM_$fb1 = cobol_SM_$SRp -> R.pt (v1);
				cobol_SM_$bl1 = cobol_SM_$SRp -> R.ln (v1);
				cobol_SM_$fb2 = cobol_SM_$SRp -> R.pt (v2);
				cobol_SM_$bl2 = cobol_SM_$SRp -> R.ln (v2);
				call cmpe;
				if cobol_SM_$result > 0
				then v1 = v2;
			     end;
			cobol_SM_$SIp -> I (x + cobol_SM_$s (j)) = v1;
			v1 = x;
		     end;
		end;
	end;
dcl	(
	cobol_SM_$SIp,
	cobol_SM_$SSp,
	cobol_SM_$MIp,
	cobol_SM_$MRp	(1000),
	cobol_SM_$MSp	(1000),
	cobol_SM_$SRp
	)		ptr ext,
	(
	cobol_SM_$SIi,
	cobol_SM_$s	(36),
	cobol_SM_$ec,
	cobol_SM_$fb1,
	cobol_SM_$fb2,
	cobol_SM_$bl1,
	cobol_SM_$bl2,
	cobol_SM_$result,
	cobol_SM_$max4,
	cobol_SM_$MIi
	)		fixed bin (35) ext,
	cobol_SM_$sort_dir	char (168) var ext,
	cobol_SM_$cmp	entry variable ext,
	(sp, rp)		ptr,
	S		bit (2359296) aligned based,
	I		(65536) fixed bin (35) aligned based,
	1 R		(32768) aligned based,
	  2 pt		fixed bin (35),
	  2 ln		fixed bin (35),
	cobol_NUMS_	entry (fixed bin (35)) ext returns (char (13) var),
	cobol_FILE_$OUT	entry (char (*), char (*), char (*), char (*), ptr) ext returns (bit (1)),
	cmpe		entry variable static internal,
	SORTM_STOP	condition ext,
	(
	ns		init (1),
	np		init (0)
	)		fixed bin (35),
	(t, n, v1, v2, l, x, j, y, lft, rit, i)
			fixed bin (35) static internal;


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

     end cobol_MSORT_;




		    cobol_NUMS_.pl1                 05/24/89  1048.6rew 05/24/89  0837.3       13563



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_NUMS_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_NUMS_:
     proc (v) returns (char (13) var);			/* Return "v" as an un-padded numeric string. */
	if v = 0
	then return ("0");
	if v < 0
	then t = -v;
	else t = v;
	do while (t > 0);
	     r = d (mod (t, 10)) || r;
	     t = divide (t, 10, 35, 0);
	end;
	if v < 0
	then r = "-" || r;
	return (r);
dcl	(t, v)		fixed bin (35),
	r		char (13) var aligned init (""),
	d		(0:9) char (1) static internal init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9"),
	(mod, divide)	builtin;
     end cobol_NUMS_;




		    cobol_RELEASE_.pl1              05/24/89  1048.6rew 05/24/89  0837.3       43983



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_RELEASE_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_RELEASE_:
     proc;					/* Version 2. */
						/* Input records while "l">0, then sort. */

	cobol_SM_$disaster1 = cobol_SM_$disaster1 + 1;
	if cobol_SM_$disaster1 > 1
	then do;					/* cobol_RELEASE_  called twice after cobol_SM_$disaster1. */
		cobol_SM_$ec = 1;
		signal condition (SORTM_STOP);
	     end;

	if cobol_SM_$RELbl > 0
	then do;					/* Input call. */
		if cobol_SM_$RELbl > cobol_SM_$max1
		then do;
			cobol_SM_$ec = 2;
			signal condition (SORTM_STOP);
		     end;
		if cobol_SM_$SSi = 0
		then do;				/* This is the initial call to cobol_RELEASE_.  */
			if cobol_FILE_$OUT ("SORTM_", (cobol_SM_$sort_dir), "SRTM.SI", "rwa", cobol_SM_$SIp)
			     | cobol_FILE_$OUT ("SORTM_", (cobol_SM_$sort_dir), "SRTM.SR", "rwa", cobol_SM_$SRp)
			     | cobol_FILE_$OUT ("SORTM_", (cobol_SM_$sort_dir), "SRTM.SS", "rwa", cobol_SM_$SSp)
			     | cobol_FILE_$OUT ("SORTM_", (cobol_SM_$sort_dir), "SRTM.MI", "rwa", cobol_SM_$MIp)
			then do;
				cobol_SM_$ec = 3;
				signal condition (SORTM_STOP);
			     end;
			cobol_SM_$MIi = 0;
			cobol_SM_$SSi = 1;
			cobol_SM_$SIi = 0;
			cobol_SM_$rp1 = cobol_SM_$SSp;
			cobol_SM_$rp2 = cobol_SM_$SSp;
			cobol_SM_$sn1 = 1;		/* Durning sort the merge string number is 1. */
			cobol_SM_$sn2 = 1;
		     end;
		if ((cobol_SM_$RELbl + cobol_SM_$SSi) > cobol_SM_$max2) | (cobol_SM_$SIi > cobol_SM_$max3)
		then do;				/* Sort the accumulated records. */
			call cobol_MSORT_;		/* cobol_SM_$LTSIi=cobol_SM_$TSIi; */
						/* One less than the first record to be sorted _n_e_x_t. */

/* Initialize the sort tables for next input. */
			cobol_SM_$SIi = 0;
			cobol_SM_$SSi = 1;
			if cobol_FILE_$LEN ("cobol_RELEASE_", (cobol_SM_$sort_dir), "SRTM.SI", 0)
			then ;			/* Assure file truncated. */
		     end;				/* Move the input record into the sort storage area. */
		substr (cobol_SM_$SSp -> S, cobol_SM_$SSi, cobol_SM_$RELbl) =
		     substr (input_rec, cobol_SM_$RELfb, cobol_SM_$RELbl);
		cobol_SM_$SIi = cobol_SM_$SIi + 1;	/* Count of the records for the next sort. */
						/* cobol_SM_$TSIi=cobol_SM_$TSIi+1; */
						/* Total record count. */
		cobol_SM_$SRp -> R.pt (cobol_SM_$SIi) = cobol_SM_$SSi;
						/* Location in sort storage segment of the record. */
		cobol_SM_$SRp -> R.ln (cobol_SM_$SIi) = cobol_SM_$RELbl;
						/* The length of the record. */
		cobol_SM_$SSi = cobol_SM_$SSi + cobol_SM_$RELbl;
						/* Update the next location
			   available in the sort storage segment. */
		cobol_SM_$SIp -> I (cobol_SM_$SIi) = cobol_SM_$SIi;
						/* Record index for sort. */
		cobol_SM_$disaster1 = 0;
		return;
	     end;

/* All records have been input.
	   Sort those in storage. Ready for merge output. */
	call cobol_MSORT_;
	return;					/*	Global declarations. */
dcl	input_rec		bit (2359296) based (cobol_SM_$RELp),
	cobol_FILE_$LEN	entry (char (*), char (*), char (*), fixed bin (35)) ext returns (bit (1)),
	cobol_FILE_$OUT	entry (char (*), char (*), char (*), char (*), ptr) ext returns (bit (1)),
	SORTM_STOP	condition ext,
	cobol_MSORT_	entry ext,
	(
	cobol_SM_$SIi,
	cobol_SM_$SSi,
	cobol_SM_$MIi,
	cobol_SM_$disaster1,
	cobol_SM_$TSIi,
	cobol_SM_$LTSIi,
	cobol_SM_$sn1,
	cobol_SM_$sn2,
	cobol_SM_$RELbl,
	cobol_SM_$RELfb,
	cobol_SM_$ec,
	cobol_SM_$max1,
	cobol_SM_$max2,
	cobol_SM_$max3,
	cobol_SM_$max4
	)		fixed bin (35) static external,
	(
	cobol_SM_$SIp,
	cobol_SM_$SRp,
	cobol_SM_$SSp,
	cobol_SM_$rp1,
	cobol_SM_$rp2,
	cobol_SM_$RELp,
	cobol_SM_$MIp,
	cobol_SM_$MRp	(1000),
	cobol_SM_$MSp	(1000)
	)		ptr static external,
	cobol_SM_$sort_dir	char (168) var static external,
						/* Based structures for sort and merge storage segments. */
	I		(65536) fixed bin (35) aligned based,
	S		bit (2359296) aligned based,
	1 R		(32768) aligned based,
	  2 pt		fixed bin (35),		/* Location in S or a record. */
	  2 ln		fixed bin (35),		/* Length of a record. */
	(substr)		builtin;
     end cobol_RELEASE_;




		    cobol_RETURN_.pl1               05/24/89  1048.6rew 05/24/89  0837.2       79992



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_RETURN_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_RETURN_:
     proc;					/* Version 2. */
						/* Entry to return records from the SORTM_. */
	if cobol_SM_$disaster2 = 0
	then do;					/* Initial  call to cobol_RETURN_. */
		cobol_SM_$disaster2 = 1;
		cmpe = cobol_SM_$mcp;		/* Point to the merge comparison procedure. */
		call A0;
		return;
	     end;
	if cobol_SM_$RETbl < 1
	then do;					/* Delete all work files. */
		cobol_SM_$disaster2 = cobol_SM_$disaster2 + 1;
		if cobol_SM_$disaster2 > 2
		then do;
			cobol_SM_$ec = 6;
			signal condition (SORTM_STOP);
		     end;
		j = cobol_SM_$RETbl;
		if cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SI", j)
		     | cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SR", j)
		     | cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SS", j)
		     | cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.MI", j)
		then do;
			cobol_SM_$ec = 7;
			signal condition (SORTM_STOP);
		     end;
		do i = 1 to cobol_SM_$MIi;
		     N = cobol_NUMS_ (i);
		     if cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.MR." || N, j)
			| cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.MS." || N, j)
		     then do;
			     cobol_SM_$ec = 7;
			     signal condition (SORTM_STOP);
			end;
		end;
		return;
	     end;

	if cobol_SM_$MIi < 2
	then do;					/* Single merge string. */
		if ns > n
		then do;
			cobol_SM_$disaster2 = 2;
			cobol_SM_$ec = 8;
			signal condition (SORTM_STOP);
		     end;
		else do;
			cobol_SM_$RETp = cobol_SM_$MSp (1);
			p1 = cobol_SM_$MRp (1);
			cobol_SM_$RETfb = p1 -> R.pt (ns);
			cobol_SM_$RETbl = p1 -> R.ln (ns);
			ns = ns + 1;
		     end;
		return;
	     end;

/* Multiple merge strings. */
	call A2;
	call A1;
	return;

A0:
     proc;					/* SORTM_ return "record" procedure (entry point cobol_RETURN_). */
	if cobol_SM_$MIi < 2
	then do;					/* Single sorted string. */
		n = cobol_SM_$MIp -> I (1);		/* Number of output records. */
		if n < 1
		then do;
			cobol_SM_$ec = 9;
			signal condition (SORTM_STOP);
		     end;
		else do;
			cobol_SM_$RETp = cobol_SM_$MSp (1);
			p1 = cobol_SM_$MRp (1);
			cobol_SM_$RETfb = p1 -> R.pt (1);
			cobol_SM_$RETbl = p1 -> R.ln (1);
			ns = 2;
		     end;
		return;
	     end;

/* Initialize for multiple merge strings. */
/* Truncate merge work files. */
	if (cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SI", 0))
	     | (cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SR", 0))
	then do;
		cobol_SM_$ec = 10;
		signal condition (SORTM_STOP);
	     end;

	do i = 1 to cobol_SM_$MIi;			/* Set indices for merge. */
	     cobol_SM_$SIp -> I (i) = i;
	     cobol_SM_$SRp -> I (i) = 1;
	end;

/*
	calculate the lengths of
	lists and their start pointers
	in a linear set.
	*/
	t = 0;
	l = cobol_SM_$MIi;
	do n = 1 by 1 while (l > 1);
	     cobol_SM_$s (n) = t;			/* start of the next list. */
	     if substr (unspec (l), 36, 1)
	     then l = l + 1;			/* make the length even. */
	     t = t + l;				/* accumulate the lengths. */
	     l = l / 2;				/* next list is 1/2 the length of the present list. */
	end;
	n = n - 1;

/* Set cobol_SM_$s(n) to (one more than) the index to the list
	   for the final 2 records to be compared. */
	do i = 2 to n;
	     lft = cobol_SM_$s (i - 1);
	     rit = cobol_SM_$s (i);
	     do j = 1 by 2 to (rit - lft);
		x = lft + j;
		v1 = cobol_SM_$SIp -> I (x);
		v2 = cobol_SM_$SIp -> I (x + 1);
		if v2 > 0
		then do;
			p1 = cobol_SM_$MRp (v1);
			p2 = cobol_SM_$MRp (v2);
			cobol_SM_$sn1 = v1;
			cobol_SM_$sn2 = v2;
			cobol_SM_$rp1 = cobol_SM_$MSp (v1);
			cobol_SM_$rp2 = cobol_SM_$MSp (v2);
			cobol_SM_$fb1 = p1 -> R.pt (1);
			cobol_SM_$fb2 = p2 -> R.pt (1);
			cobol_SM_$bl1 = p1 -> R.ln (1);
			cobol_SM_$bl2 = p2 -> R.ln (1);
			call cmpe;
			if (cobol_SM_$result = 1) | ((cobol_SM_$result = 2) & (v2 < v1))
			then v1 = v2;
		     end;
		rit = rit + 1;
		cobol_SM_$SIp -> I (rit) = v1;
	     end;
	end;
	i = cobol_SM_$s (n) + 2;
	do i = 1 to i;
	     N = cobol_NUMS_ (cobol_SM_$SIp -> I (i));
	end;

	y = cobol_SM_$s (n) + 1;
	call A1;
	return;
     end A0;

A1:
     proc;					/* Obtain the next record to output. */
	v1 = cobol_SM_$SIp -> I (y);
	v2 = cobol_SM_$SIp -> I (y + 1);
	if (v1 = 0) & (v2 = 0)
	then do;
		cobol_SM_$ec = 11;
		signal condition (SORTM_STOP);
		cobol_SM_$RETbl = 0;
		return;
	     end;
	if v1 = 0
	then do;
		v1 = v2;
		p1 = cobol_SM_$MRp (v2);
		i1 = cobol_SM_$SRp -> I (v2);
	     end;
	else if v2 = 0
	then do;
		p1 = cobol_SM_$MRp (v1);
		i1 = cobol_SM_$SRp -> I (v1);
	     end;
	else if v2 > 0
	then do;
		p1 = cobol_SM_$MRp (v1);
		p2 = cobol_SM_$MRp (v2);
		i1 = cobol_SM_$SRp -> I (v1);
		i2 = cobol_SM_$SRp -> I (v2);
		cobol_SM_$sn1 = v1;
		cobol_SM_$sn2 = v2;
		cobol_SM_$rp1 = cobol_SM_$MSp (v1);
		cobol_SM_$rp2 = cobol_SM_$MSp (v2);
		cobol_SM_$fb1 = p1 -> R.pt (i1);
		cobol_SM_$fb2 = p2 -> R.pt (i2);
		cobol_SM_$bl1 = p1 -> R.ln (i1);
		cobol_SM_$bl2 = p2 -> R.ln (i2);
		call cmpe;

		if (cobol_SM_$result = 1) | ((cobol_SM_$result = 2) & (v2 < v1))
		then do;				/* Second record first  |
						   Key fields equal but
						   2-nd merge string earlier. */
			v1 = v2;
			i1 = i2;
			p1 = p2;
		     end;
	     end;
	cobol_SM_$RETp = cobol_SM_$MSp (v1);
	cobol_SM_$RETfb = p1 -> R.pt (i1);
	cobol_SM_$RETbl = p1 -> R.ln (i1);
	return;
     end A1;
A2:
     proc;					/* Delete last record output. */
	i = cobol_SM_$SRp -> I (v1) + 1;
	if i > cobol_SM_$MIp -> I (v1)
	then cobol_SM_$SIp -> I (v1) = 0;		/* v1-th string depleted. */
	cobol_SM_$SRp -> I (v1) = i;			/* Update the index to which
			   record is next in the v1-th string. */
	do j = 2 to n;
	     lft = cobol_SM_$s (j - 1);
	     if substr (unspec (v1), 36, 1)
	     then v2 = v1 + 1;
	     else v2 = v1 - 1;
	     x = (v1 + 1) / 2;
	     v1 = cobol_SM_$SIp -> I (v1 + lft);
	     v2 = cobol_SM_$SIp -> I (v2 + lft);
	     if v1 = 0
	     then v1 = v2;
	     else if v2 > 0
	     then do;
		     p1 = cobol_SM_$MRp (v1);
		     p2 = cobol_SM_$MRp (v2);
		     i1 = cobol_SM_$SRp -> I (v1);
		     i2 = cobol_SM_$SRp -> I (v2);
		     cobol_SM_$sn1 = v1;
		     cobol_SM_$sn2 = v2;
		     cobol_SM_$rp1 = cobol_SM_$MSp (v1);
		     cobol_SM_$rp2 = cobol_SM_$MSp (v2);
		     cobol_SM_$fb1 = p1 -> R.pt (i1);
		     cobol_SM_$fb2 = p2 -> R.pt (i2);
		     cobol_SM_$bl1 = p1 -> R.ln (i1);
		     cobol_SM_$bl2 = p2 -> R.ln (i2);
		     call cmpe;
		     if (cobol_SM_$result = 1) | ((cobol_SM_$result = 2) & (v2 < v1))
		     then v1 = v2;
		end;
	     cobol_SM_$SIp -> I (x + cobol_SM_$s (j)) = v1;
	     v1 = x;
	end;
     end A2;
dcl	(
	cobol_SM_$SIp,
	cobol_SM_$MIp,
	cobol_SM_$rp1,
	cobol_SM_$rp2,
	cobol_SM_$RETp,
	cobol_SM_$MRp	(1000),
	cobol_SM_$MSp	(1000),
	cobol_SM_$SRp
	)		ptr ext,
	(
	cobol_SM_$disaster2,
	cobol_SM_$s	(36),
	cobol_SM_$sn1,
	cobol_SM_$sn2,
	cobol_SM_$fb1,
	cobol_SM_$fb2,
	cobol_SM_$bl1,
	cobol_SM_$bl2,
	cobol_SM_$result,
	cobol_SM_$RETfb,
	cobol_SM_$RETbl,
	cobol_SM_$ec,
	cobol_SM_$MIi
	)		fixed bin (35) ext,
	cobol_SM_$sort_dir	char (168) var ext,
	cobol_SM_$mcp	entry variable ext,
	S		bit (2359296) aligned based,
	I		(65536) fixed bin (35) aligned based,
	1 R		(32768) aligned based,
	  2 pt		fixed bin (35),
	  2 ln		fixed bin (35),
	N		char (13) var,
	cobol_NUMS_	entry (fixed bin (35)) ext returns (char (13) var),
	cobol_FILE_$LEN	entry (char (*), char (*), char (*), fixed bin (35)) ext returns (bit (1)),
	cobol_FILE_$OUT	entry (char (*), char (*), char (*), char (*), ptr) ext returns (bit (1)),
	cmpe		entry variable internal static,
	SORTM_STOP	condition ext,
	(p1, p2)		ptr,
	(t, n, v1, v2, i1, i2, l, x, j, y, ns, np, lft, rit, i)
			fixed bin (35) static internal;

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

     end cobol_RETURN_;




		    cobol_SET_.pl1                  05/24/89  1048.6rew 05/24/89  0837.1       62550



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_SET_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_SET_:
     proc;					/* Versiin 2. */
						/* Set or print control variables for SORTM_. */
	Lp = addrel (addr (L), 1);
	call cu_$arg_count (i);
	if i < 1
	then do;
		L = "cobol_SET_ S S ...
Each S is a string: name=value  (no spaces).
Name from {sort_dir,disaster1,disaster2,SIi,SSi,MIi,max1,max2,max3,max4}.
Value is an integer except for sort_dir it is a string.";
		L = L || "
If S is ""default"" (only) the values are set to their default values.
If S is ""print"" (only) the current values are printed.
";						/* call ios_$write_ptr(Lp,0,length(L)); */
		return;
	     end;

	do j = 1 to i;
	     call cu_$arg_ptr (j, p, l, e);
	     if e > 0
	     then do;
		     call com_err_ (e, "cobol_SET_", " Could not obtain parameter ^d.", j);
		     return;
		end;


	     if arg = "print"
	     then do;
		     L = "	SORTM_ values  " || substr (L, 2, 24) || "
sort_dir=""" || cobol_SM_$sort_dir || """
";
		     L = L || "disaster1=" || cobol_NUMS_ (cobol_SM_$disaster1) || " disaster2="
			|| cobol_NUMS_ (cobol_SM_$disaster2) || " SIi=" || cobol_NUMS_ (cobol_SM_$SIi) || " SSi="
			|| cobol_NUMS_ (cobol_SM_$SSi) || " MIi=" || cobol_NUMS_ (cobol_SM_$MIi) || " TSIi="
			|| cobol_NUMS_ (cobol_SM_$TSIi) || " LTSIi=" || cobol_NUMS_ (cobol_SM_$LTSIi) || " max1="
			|| cobol_NUMS_ (cobol_SM_$max1) || " max2=" || cobol_NUMS_ (cobol_SM_$max2) || " max3="
			|| cobol_NUMS_ (cobol_SM_$max3) || " max4=" || cobol_NUMS_ (cobol_SM_$max4) || "
";
		     call FME (cobol_SM_$cmp, "cmp");
		     call FME (cobol_SM_$mcp, "mcp");
		     L = L || "SIp=" || cobol_FP_ (cobol_SM_$SIp) || " SRp=" || cobol_FP_ (cobol_SM_$SRp)
			|| " SSp=" || cobol_FP_ (cobol_SM_$SSp) || " MIp=" || cobol_FP_ (cobol_SM_$MIp) || "
";						/* call ios_$write_ptr(Lp,0,length(L)); */
		end;
	     else if arg = "default"
	     then do;
		     cobol_SM_$sort_dir = "";
		     cobol_SM_$disaster1 = 0;
		     cobol_SM_$disaster2 = 0;
		     cobol_SM_$SSi = 0;
		     cobol_SM_$SIi = 0;
		     cobol_SM_$MIi = 0;
		     cobol_SM_$max1 = 64 * 1024 * 36;
		     cobol_SM_$max2 = cobol_SM_$max1;
		     cobol_SM_$max3 = 30000;
		     cobol_SM_$max4 = 1000;
		end;
	     else do;

		     k = index (arg, "=");
		     if k < 1
		     then call err ("contains no ""="".");
		     else do;
			     m = index (/*
.        1        2        3  4  5  6   7   8   9
.1       9        18       27 30 33 36  40  44  48		*/
				"sort_dirdisaster1disaster2SIiSSiMIimax1max2max3max4", substr (arg, 1, (k - 1)));
			     if m < 1
			     then call err ("not a known name.");
			     else do;
				     if m = 1
				     then cobol_SM_$sort_dir = substr (arg, (k + 1), (l - k));
				     else call set_val;
				end;
			end;
		end;
	end;
	return;

CPP:
     entry (PT, PT2);				/* Save the pointer, "p", to the comparison procedure. */
	call cu_$arg_count (i);
	if (i < 1) | (i > 2)
	then do;
		call com_err_ (0, "CPP", " Pointer to comparison procedure required.");
		return;
	     end;

	cobol_SM_$cmp = PT;
	if i = 2
	then cobol_SM_$mcp = PT2;
	cobol_SM_$sort_dir = "";
	cobol_SM_$disaster1 = 0;
	cobol_SM_$disaster2 = 0;
	cobol_SM_$SSi = 0;
	cobol_SM_$SIi = 0;
	cobol_SM_$MIi = 0;
	cobol_SM_$max1 = 64 * 1024 * 36;
	cobol_SM_$max2 = cobol_SM_$max1;
	cobol_SM_$max3 = 30000;
	cobol_SM_$max4 = 1000;
	return;


FME:
     proc (e, n);					/* Format entry "e" named "n". */
	if p2 = null ()
	then do;
		L = L || n || "=(ext proc)" || cobol_FP_ (p1) || " ";
	     end;
	else do;
		L = L || n || "=(int proc)" || cobol_FP_ (p1) || "(in)" || cobol_FP_ (p2) || " ";
	     end;
	return;
dcl	e		entry parm,
	n		char (*) parm,
	1 E		aligned based (addr (e)),
	  2 p1		ptr,
	  2 p2		ptr,
	null		builtin;
     end FME;

set_val:
     proc;					/* Convert the "value" part of the argument and load
	   the specified variable. */

/* Convert the numeric string (unsigned). */
	v = 0;
	do k = (k + 1) to l;
	     c = substr (arg, k, 1);
	     if (c < "0") | (c > "9")
	     then do;
		     call err ("contains non-numeric character """ || c || """ in the numeric value field.");
		     return;
		end;
	     v = (v * 10) + fixed (c, 9) - 0;
	end;

/* Load the value. */
	goto set (red (m));
set (0):
	call err ("unknown name.");
	return;
set (1):
	cobol_SM_$disaster1 = v;
	return;
set (2):
	cobol_SM_$disaster2 = v;
	return;
set (3):
	cobol_SM_$SIi = v;
	return;
set (4):
	cobol_SM_$SSi = v;
	return;
set (5):
	cobol_SM_$MIi = v;
	return;
set (6):
	cobol_SM_$max1 = v;
	return;
set (7):
	cobol_SM_$max2 = v;
	return;
set (8):
	cobol_SM_$max3 = v;
	return;
set (9):
	cobol_SM_$max4 = v;
	return;
     end set_val;

err:
     proc (message);
	L = "cobol_SET_: Parameter " || cobol_NUMS_ (j) || ", """ || arg || """, " || message || "
";						/* call ios_$write_ptr(Lp,0,length(L)); */
	return;
dcl	message		char (*);
     end err;

dcl	(PT, PT2)		entry parm,
	(Lp, p)		ptr,
	L		char (1000) var,
	cu_$arg_count	entry (fixed bin (35)) ext,
	cu_$arg_ptr	entry (fixed bin (35), ptr, fixed bin (35), fixed bin (35)) ext,
						/* 	ios_$write_ptr	entry(ptr,fixed bin(35),fixed bin(35)) ext, */
	com_err_		entry options (variable) ext,
	cobol_NUMS_	entry (fixed bin (35)) ext returns (char (13) var),
	cobol_FP_		entry (ptr) ext returns (char (16) var),
	(i, j, k, m, l, e, v)
			fixed bin (35),
	red		(51) fixed bin (35) static internal
			init ((8) 0, 1, (8) 0, 2, (8) 0, 3, (2) 0, 4, (2) 0, 5, (2) 0, 6, (3) 0, 7, (3) 0, 8, (3) 0,
			9, (3) 0),
	arg		char (l) unaligned based (p),
	c		char (1) aligned,
	(unspec, substr, index, length)
			builtin,			/*	Static external (bindable as internal). */
	(
	cobol_SM_$cmp,
	cobol_SM_$mcp
	)		entry variable ext,
	(
	cobol_SM_$SIp,
	cobol_SM_$SRp,
	cobol_SM_$SSp,
	cobol_SM_$MIp
	)		ptr ext,
	(
	cobol_SM_$SIi,
	cobol_SM_$SSi,
	cobol_SM_$MIi,
	cobol_SM_$TSIi,
	cobol_SM_$LTSIi,
	cobol_SM_$max1,
	cobol_SM_$max2,
	cobol_SM_$max3,
	cobol_SM_$max4,
	cobol_SM_$disaster2,
	cobol_SM_$disaster1
	)		fixed bin (35) ext,
	cobol_SM_$sort_dir	char (168) var ext;
     end cobol_SET_;




		    cobol_SM_.alm                   11/11/82  1550.1rew 11/11/82  1030.7       16794



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

"	cobol_SM_
"	External data for SORTM facility.
"	Bindable as static internal.
"	Modified July 1981 to avoid zero pages in the object segment
"		Benson I. Margulies.

	name	cobol_SM_
	use	textc
	use	linkc
	join	/link/linkc
	join	/text/textc
	use	linkc
	macro	null_pointer
	even
	segdef	&1
&1:
	dup	&2
	its	-1,1
	dupend
	&end

"	cobol_SM$... entry.
	null_pointer	cmp,3
	null_pointer	mcp,3
"	cobol_SM$... ptr.
	null_pointer	SIp,1
	null_pointer	SRp,1
	null_pointer	SSp,1
	null_pointer	MIp,1
	null_pointer	rp1,1
	null_pointer	rp2,1
	null_pointer	stat_ptr,1
	null_pointer	error_ptr,1
	null_pointer	RELp,1
	null_pointer	RETp,1
	null_pointer	MRp,1000
	null_pointer	MSp,1000
"	cobol_SM$... fixed bin(35).
	segdef	SIi
	bss	SIi,1
	segdef	SSi
	bss	SSi,1
	segdef	MIi
	bss	MIi,1
	segdef	TSIi
	bss	TSIi,1
	segdef	LTSIi
	bss	LTSIi,1
	segdef	max1
	bss	max1,1
	segdef	max2
	bss	max2,1
	segdef	max3
	bss	max3,1
	segdef	max4
	bss	max4,1
	segdef	ec
	bss	ec,1
	segdef	disaster1
	bss	disaster1,1
	segdef	disaster2
	bss	disaster2,1
	segdef	sn1
	bss	sn1,1
	segdef	sn2
	bss	sn2,1
	segdef	fb1
	bss	fb1,1
	segdef	fb2
	bss	fb2,1
	segdef	bl1
	bss	bl1,1
	segdef	bl2
	bss	bl2,1
	segdef	result
	bss	result,1
	segdef	RELbl
	bss	RELbl,1
	segdef	RELfb
	bss	RELfb,1
	segdef	RETfb
	bss	RETfb,1
	segdef	RETbl
	bss	RETbl,1
	segdef	s
	bss	s,36
"	cobol_SM$... char var.
	segdef	sort_dir
	bss	sort_dir,43

	end




		    cobol_SORTM_.pl1                05/24/89  1048.6rew 05/24/89  0837.1       16587



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_SORTM_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_SORTM_:
     proc;					/*cobol_SORTM_ is a sort and merge facility. Procedures (SET, CPP, RELEASE
      &  RETURN)  provide  for  establishing  the  pointer  to  a
      comparison procedure, inputting records and  returning  the
      records in a sorted order. */
	L = "cobol_SORTM_ is a sort and merge facility. Procedures (SET, CPP, RELEASE
      &  RETURN)  provide  for  establishing  the  pointer  to  a
      comparison procedure, inputting records and  returning  the";
	L = L || "
      records in a sorted order.
                   ec >udd>LIS>Wardd>pr_runoff SORTM
      will print documentation.
";						/* 	call ios_$write_ptr(addrel(addr(L),1),0,length(L)); */
	return;

dcl	L		char (400) var,		/* 	ios_$write_ptr	entry(ptr,fixed bin(35),fixed bin(35)) ext, */
	(addr, length, addrel)
			builtin;
     end cobol_SORTM_;




		    cobol_blank_stripper_.pl1       05/24/89  1048.6rew 05/24/89  0837.0       29475



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_blank_stripper_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 03/06/81 by FCH, [4.4-1], last line not processed unless ends in c.r. char, BUG469(TR9264) */
/* Modified on 10/03/79 by FCH, [4.0-1], ID field ignored */
/* Created for Version 4.1  by FCH */

/* format: style3 */
cobol_blank_stripper_:
     proc (in_ptr, out_ptr, bc);

dcl	(to_offset, from_offset, ret_loc, i, line_size)
			fixed bin (35);
dcl	(non_blank, quotct) fixed bin (35);
dcl	l_num		fixed bin;
dcl	bc		fixed bin (24);
dcl	(code, cct, rct)	fixed bin (35);

dcl	(argptr, l_ptr, in_ptr, out_ptr)
			ptr;

dcl	ch		char (1);

dcl	(divide, index, addr, substr)
			builtin;



declare	program		char (cct) based (in_ptr);
declare	prog_array	(cct) char (1) based (in_ptr);
declare	rest_prog		char (rct) based (l_ptr);
declare	ln		(ret_loc) char (1) based (l_ptr);


	cct = divide (bc, 9, 31, 0);
	to_offset, from_offset = 1;


	do while ("1"b);

	     if from_offset > cct
	     then do;
		     bc = to_offset * 9 - 9;
		     return;
		end;

	     rct = cct - from_offset + 1;
	     l_ptr = addr (prog_array (from_offset));
	     ret_loc = index (rest_prog, "
");

	     if ret_loc <= 0
	     then do;				/*[4.4-1]*/
		     ret_loc = rct + 1;		/*[4.4-1]*/
		     call scan;

		     bc = to_offset * 9 - 9;
		     return;
		end;

/*[4.4-1]*/
	     call scan;

	end;

/*[4.4-1]*/
scan:
     proc;

	ret_loc = ret_loc - 1;

	if ret_loc < 8
	then call move (ret_loc, ret_loc);
	else /*[4.0-1]*/
	     line_size = ret_loc;

/*[4.0-1]*/
	if ret_loc = 80
	then ret_loc = 72;

	if ln (7) ^= " "				/*[4.0-1]*/
	then call move (ret_loc, line_size);
	else do;
		quotct = 1;
		non_blank = 0;

		do i = ret_loc by -1 to 8;

		     ch = ln (i);
		     if ch = """"
		     then quotct = -quotct;

		     if non_blank = 0
		     then if ch ^= " "
			then non_blank = i;
		end;

		if non_blank = 0
		then call move (7, line_size);
		else if quotct < 0			/*[4.0-1]*/
		then call move (ret_loc, line_size);	/*[4.0-1]*/
		else call move (non_blank, line_size);
	     end;
     end;

move:
     proc (to_size, from_size);

declare	(to_size, from_size)
			fixed bin (35);

	substr (out_ptr -> program, to_offset, to_size + 1) = substr (in_ptr -> program, from_offset, to_size) || "
";

	to_offset = to_offset + to_size + 1;
	from_offset = from_offset + from_size + 1;
     end;

     end;




		    cobol_control_.pl1              05/24/89  1048.6rew 05/24/89  0836.9      270612



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8090 cobol_control_.pl1 Disallow duplicate prime keys in Indexed
     Sequential files.
                                                   END HISTORY COMMENTS */


/* Modified on 12/19/84 by FCH, [5.3-1], BUG573(phx16343), cobol_fsb_type_1.incl.pl1 now used */
/* Modified on 11/30/82 by FCH, [5.2-1], delete handlers for error and command_abort_, BUG545(phx14322) */
/* Modified on 09/08/81 by FCH, [5.0-1], rc fails if abs path name used, BUG499(phx11416) */
/* Modified on 06/09/81 by FCH, [4.4-2], cu_$cp used instead of cu_$ptr_call, BUG468 */
/* Modified on 10/24/80 by PRP, [4.4-1], bug451 phx07665 fix close with lock on internal files*/
/* Modified on 07/17/79 by PRP, [4.0-2], -db option added to rc, it sets sw 8*/
/* Modified on 06/14/79 by PRP, [4.0-2], output of detach messages eliminated except when scr is used */
/* Modified on 05/24/79 by FCH, [4.0-1], cobol_control_seg_ replaced by temp seg */
/* Modified on 01/22/79 by FCH, [3.0-1], on statements used */
/* Modified since Version 3.0	*/
/* { */



/* format: style3 */
cobol_control_:
     proc (pr4_save_ptr);

/*  This is a run-time support routine which provides
			   for getting space for all cobol programs.  It also maintains
			   a record of programs which are part of the current run-unit. */

dcl	control_1		fixed bin;		/* 1 = called by cobol_rts_; 0 = called directly by cobol program */

	call cu_$stack_frame_ptr (stack_frame_ptr);
	stack_frame_ptr = stack_frame.prev_stack_frame_ptr;
	control_1 = 0;
	call start;
	return;

/* Entry for the new control to interface with cobol_rts_ package.	*/


cobol_rts_control_:
     entry (pr4_save_ptr);

	call cu_$stack_frame_ptr (stack_frame_ptr);
	stack_frame_ptr = stack_frame.prev_stack_frame_ptr;
	control_1 = 1;
	call start;
	return;

dcl	pr4_save_ptr	ptr parameter;
dcl	statptr		ptr parameter;		/*
				   statptr		a pointer to the calling program's static
						   data area.  See the include file stat.inc.pl1
						   } */

declare	(stop_run, command_abort_, error, finish)
			condition;		/* [3.0-1] */


/*[4.0-1]*/
dcl	get_temp_segments_	entry (char (*), (*) ptr, fixed bin (35));
						/*[4.0-1]*/
dcl	release_temp_segments_
			entry (char (*), (*) ptr, fixed bin (35));

/*[4.0-1]*/
dcl	tp		(1) ptr static int;

dcl	1 cond		based (cond_ptr),
	  2 next_ptr	ptr,
	  2 action_ptr	ptr,
	  2 action_len	fixed bin (21),
	  2 cont		fixed bin,
	  2 name		char (32),
	  2 action	char (0 refer (cond.action_len));
dcl	mcode		fixed bin (35);
dcl	close_code	fixed bin (35);
dcl	stop_code		fixed bin;
dcl	(i, j, k, m, n)	fixed bin;
dcl	(jlen, klen)	fixed bin;
dcl	(nargs, bl_pos, dlr_pos)
			fixed bin;
dcl	len		fixed bin;
dcl	(arglen, arg1_len)	fixed bin (21);
dcl	rwds		fixed bin;
dcl	continue		fixed bin;
dcl	bc		fixed bin (21);

dcl	stop_run_command	static bit (1);
dcl	stop_run_sw	bit (1) static init ("0"b);
dcl	found		bit (1);
dcl	others_found	bit (1);

dcl	rseg		char (rwds) based (rsegptr);
dcl	nl		char (1) static init ("
");
dcl	dir		char (168);
dcl	error_name	char (3);
dcl	name1		char (32);
dcl	rname		char (32);
dcl	progname		char (32);
dcl	lineno		char (20);
dcl	cobol_data_area	(stat.data_len + 1) fixed bin (35) based;
						/* 08-26-77 */
						/* only need to run pre 3.0 cobol programs */
dcl	based_area	area based;
dcl	area_ptr		ptr;

dcl	evar		entry auto;
dcl	bptr		ptr based (addr (evar));
dcl	arg		char (arglen) based (argptr);

dcl	cond_ptr		ptr;
dcl	(argptr, arg1_ptr)	ptr;
dcl	save_cond_ptr	ptr;
dcl	rsegptr		ptr;
dcl	segptr		ptr;
dcl	error_ptr		ptr;
dcl	iox_$user_output	ptr ext;
dcl	iox_$error_output	ptr ext;
dcl	iox_$user_input	ptr ext;

dcl	condition_	entry (char (*), entry);
dcl	cobol_rts_handler_	entry (ptr, char (*), ptr, ptr, bit (1));
						/*[4.4-2]*/
dcl	add_epilogue_handler_
			entry (entry, fixed bin (35));
dcl	find_command_	entry (ptr, fixed bin (21), ptr, fixed bin (35));
dcl	cu_$cp		entry (ptr, fixed bin (21), fixed bin (35));
dcl	cu_$arg_count	entry (fixed bin);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl	expand_path_	entry (ptr, fixed bin (21), ptr, ptr, fixed bin (35));
dcl	hcs_$terminate_noname
			entry (ptr, fixed bin (35));
dcl	hcs_$delentry_file	entry (char (*), char (*), fixed bin (35));
dcl	get_pdir_		entry returns (char (168));
dcl	hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (21), fixed bin (2), ptr, fixed bin (35));
dcl	hcs_$fs_get_ref_name
			entry (ptr, fixed bin, char (*), fixed bin (35));
dcl	hcs_$truncate_seg	entry (ptr, fixed bin, fixed bin (35));
dcl	hcs_$terminate_seg	entry (ptr, fixed bin, fixed bin (35));
dcl	hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl	cobol_mcs_$stop_run entry;
dcl	com_err_		entry options (variable);
dcl	cobol_error_	entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (65) varying, ptr);
dcl	ioa_		entry options (variable);
dcl	ioa_$rsnnl	entry options (variable);
dcl	cobol_file_control_ entry (char (*), ptr, fixed bin, char (*), bit (1) aligned, fixed bin (35));
dcl	signal_		entry (char (*), ptr, ptr);
dcl	cu_$stack_frame_ptr entry (ptr);

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


/* prologue */

start:
     proc;

/*[3.0-1]*/
	if controlp = null
	then call set_handlers (0);

/*[5.2-1]*/
/* on command_abort_ call COND ("command_abort_"); */
/*[5.2-1]*/
/* on error call COND ("error"); */
/*[4.0-1]*/
	on stop_run call COND ("stop_run");		/*[4.0-1]*/
	on finish call COND ("finish");

	if control_1 ^= 0
	then do;

		stat_ptr = addrel (pr4_save_ptr, 8);
		stack_frame_ptr = stack_frame.prev_stack_frame_ptr;
	     end;
	else stat_ptr = addrel (stack_frame.link_ptr, 8); /* initialize extended fixed_static area if new rts interface */
	if control_1 ^= 0
	then do;

		stat.user_output_ptr = iox_$user_output;
		stat.error_output_ptr = iox_$error_output;
		stat.user_input_ptr = iox_$user_input;
		stat.error_con = "";
	     end;



	j = index (stat.prog_id, "$");

	if j > 0
	then do;

		stat.prog_id_len = stat.prog_id_len - j;
		progname = substr (stat.prog_id, j + 1);
	     end;
	else progname = substr (stat.prog_id, 1, stat.prog_id_len);

	rname = "";

	do j = 1 to 1000 /* nominal */ while (rname = "");

	     if control_1 ^= 0
	     then call hcs_$fs_get_ref_name (pointer (stack_frame.new_return_ptr, 0), j, rname, mcode);
	     else call hcs_$fs_get_ref_name (pointer (stack_frame.return_ptr, 0), j, rname, mcode);

	     if mcode ^= 0
	     then go to control_error;

	end;

	if rname ^= stat.prog_id
	then do;

		j = index (rname, " ");
		if j = 0
		then j = 33;

		stat.prog_id = substr (rname, 1, j - 1) || "$" || progname;
		stat.prog_id_len = stat.prog_id_len + j;
	     end;

	if stat.entry_pt_ptr = control.main_prog_ptr
	then do;

		stat.main_prog_sw = 1;
		control.mpname = substr (stat.prog_id, 1, stat.prog_id_len);
	     end;
	else do;

		stat.main_prog_sw = 0;
		control.mpname = "";
	     end;

	if control.no_of_segs > 0
	then do i = 1 to control.no_of_segs;

		if control.statptr (i) = stat_ptr
		then go to set_data_ptr;

		if control.statptr (i) ^= null
		then do;

			j = index (control.statptr (i) -> stat.prog_id, "$");

			if j = 0
			then j = control.statptr (i) -> stat.prog_id_len;
			else j = j - 1;

			k = index (stat.prog_id, "$");

			if k = 0
			then k = stat.prog_id_len;
			else k = k - 1;

			if substr (control.statptr (i) -> stat.prog_id, 1, j) = substr (stat.prog_id, 1, k)
			then control.statptr (i) = null ();

		     end;
	     end;
	else control.name = stat.prog_id;		/* set run-unit name */

	control.no_of_segs = control.no_of_segs + 1;
	control.statptr (control.no_of_segs) = stat_ptr;
	stat.control_ptr = controlp;

	if sort_dir_len = 0
	then do;
		substr (sort_dir, 1, 168) = get_pdir_ ();
		sort_dir_len = index (sort_dir, " ") - 1;
	     end;

set_data_ptr:
	if stat.data_len > 0
	then if stat.data_ptr = null ()
	     then do;
		     area_ptr = ptr (addr (i), 0) -> stack_header.user_free_ptr;
		     allocate cobol_data_area set (stat.data_ptr) in (area_ptr -> based_area);
		end;

     end;

cobol_stop_run_:
     entry (statptr, rdsw, rfsw, code);


/* This is the entry called by the standard default
			   condition handler for the "stop_run" condition and
			   by the cancel command when the "-all" option is
			   specified.  It causes cancellation of every cobol program
			   in the current run-unit.  */

dcl	rdsw		fixed bin;		/* retain data segments */
dcl	rfsw		fixed bin;		/* retain files */

/* dcl statptr ptr parameter;

				   statptr		a pointer to the calling program's static
						   data area.  See the include file
						   stat.incl.pl1 (input).
						   } */

	stop_run_command = "0"b;
	call start_cobol_stop_run;
	return;


cobol_stop_run_command_:
     entry (statptr, rdsw, rfsw, code);

	stop_run_command = "1"b;
	call start_cobol_stop_run;
	return;

/* [4.0-2] */
/* this new entry point was added so that cobol_stop_run_ can tell
			   the difference between a call from command level and an
			   epilogue handler call.  thus some messages are suppressed unless
			   there is a stop_cobol_run command. */


start_cobol_stop_run:
     proc;

	if statptr ^= null ()
	then error_name = "ccp";
	else error_name = "scr";

	found = "0"b;

	if controlp ^= null ()
	then do;

		if sort_dir_len ^= 0
		then call hcs_$delentry_file (substr (sort_dir, 1, sort_dir_len), "cobol_temp_merge_file_", mcode);

	     end;

	if controlp ^= null ()
	then if control.no_of_segs > 0
	     then do i = 1 to control.no_of_segs;

		     stat_ptr = control.statptr (i);

		     if stat_ptr ^= null ()
		     then do;

			     stat.call_cnt = -1;	/* reset initialization switch */

			     if rfsw = 0
			     then if stat.file_info_ptr ^= null ()
				then do;

					call cobol_file_control_ ("-a", stat_ptr, 0, error_name, "1"b,
					     close_code);
					stat.file_info_ptr = null ();

				     end;

			     if rdsw = 0
			     then if stat.data_ptr ^= null ()
				then do;
					if stat.data_len > 0
					then free stat.data_ptr -> cobol_data_area;
					stat.data_ptr = null ();
				     end;

			     found = "1"b;

			end;
		end;

	stop_run_command = "0"b;

/* purge all communication partial files.	*/

/*[4.4-2]*/
/* 	call cobol_mcs_$stop_run; */

	if ^found
	then code = -1;
	else do;



		code = 0;

		if statptr ^= null ()
		then do;

			stat_ptr = statptr;

			if stat.line_no (1) = 0
			then lineno = "";
			else if stat.line_no (2) = 0
			then call ioa_$rsnnl (" (line ^d)", lineno, len, stat.line_no (1));
			else call ioa_$rsnnl (" (line ^d-^d)", lineno, len, stat.line_no (1), stat.line_no (2));

			call ioa_ ("^a: Run-unit ^a terminated^a.", statptr -> stat.prog_id, control.name, lineno);
		     end;

		call hcs_$truncate_seg (controlp, 0, mcode);
		if mcode ^= 0
		then go to multics_error;

/*		call hcs_$terminate_seg (controlp, 0, mcode);*/
/*[4.4-2]*/
		call release_temp_segments_ ("cobol_control_", tp, mcode);
		if mcode ^= 0
		then go to multics_error;

		controlp = null ();

		call signal_ ("command_abort_", null (), null ());

	     end;

     end;


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

cobol_cancel_:
     entry (name);

dcl	cancel_code	fixed bin;		/* always ignored */
dcl	cobol_control_$cancel
			entry (char (*), fixed bin, fixed bin, fixed bin);

	cancel_code = 0;
	call cobol_control_$cancel (name, 0, 0, cancel_code);
	return;

cancel:
     entry (name, rdsw, rfsw, code);

/* This entry is called by the cancel command and by
			   object programs compiled by cobol to cancel a program
			   in the run-unit by name.  If the named program is not
			   currently active in the run-unit then an error code is
			   returned.  This condition is an error for the cancel command,
			   but is ignored by the code generated for the cancel verb. */

dcl	name		char (*) parameter;		/* dcl rfsw fixed bin;	/* retain files */
						/* dcl rdsw fixed bin;	/* retain data segment */
dcl	code		fixed bin;

/*
			   name		a character string up to 65 chars long
			   identifying the program to be cancelled.
			   This corresponds to the name recorded in
			   stat.prog_id i.e. if the Identification
			   Division prog-id = the segment name, then
			   stat.prog_id = segment name; otherwise, it
			   is segment name$prog-id (input).
			
			   code		set to 0 if program successfully cancelled;
			   otherwise set to 1 (output).
			   } */

	i = index (name, "$");
	if i > 0
	then rname = substr (name, 1, i - 1);
	else rname = name;

	call hcs_$make_ptr (null (), rname, substr (name, i + 1), segptr, mcode);
	if mcode ^= 0
	then go to return_multics_error;

	found, others_found = "0"b;
	if code = -3
	then others_found = "1"b;			/* special - don't ever stop run */
	code = -2;

	if controlp ^= null ()
	then if control.no_of_segs > 0
	     then do i = 1 to control.no_of_segs;

		     stat_ptr = control.statptr (i);

		     if stat_ptr ^= null ()
		     then do;

			     if stat.entry_pt_ptr = segptr & stat.call_cnt ^= -1
			     then do;

				     stat.call_cnt = -1;
						/* reset initialization switch */

				     if rfsw = 0
				     then if stat.file_info_ptr ^= null ()
					then do;

						call cobol_file_control_ ("-a", stat_ptr, 0, "ccp", "1"b,
						     close_code);
						stat.file_info_ptr = null ();

					     end;

				     if rdsw = 0
				     then if stat.data_ptr ^= null ()
					then do;

						if stat.data_len > 0
						then free stat.data_ptr
							-> cobol_data_area in (area_ptr -> based_area);

						stat.data_ptr = null ();

					     end;

				     control.statptr (i) = null ();
				     found = "1"b;
				end;

			     else if stat.call_cnt ^= -1
			     then others_found = "1"b;

			end;
		end;
	     else return;
	else return;

	if ^found
	then code = -1;
	else do;

		code = 0;

		if ^others_found
		then do;

			call com_err_ (0, "cancel_cobol_program",
			     "^a was the only active cobol program of the run-unit.^/Run-unit ^a terminated.", name,
			     control.name);

			call hcs_$truncate_seg (controlp, 0, mcode);
			if mcode ^= 0
			then go to multics_error;

/*		call hcs_$terminate_seg (controlp, 0, mcode);*/
/*[4.4-2]*/
			call release_temp_segments_ ("cobol_control_", tp, mcode);
			if mcode ^= 0
			then go to multics_error;

			controlp = null ();

			call signal_ ("command_abort_", null (), null ());

		     end;
	     end;

	return;


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

cobol_stoprun_:
     entry;

	call cu_$stack_frame_ptr (stack_frame_ptr);

	stack_frame_ptr = stack_frame.prev_stack_frame_ptr;
	stat_ptr = addrel (stack_frame.link_ptr, 8);

	if controlp ^= null ()
	then if control.main_prog_sw ^= 0
	     then call signal_ ("stop_run", null (), stat_ptr);

	stop_code = 0;

	call cobol_stop_run_ (stat_ptr, 0, 0, stop_code);

	call signal_ ("command_abort_", null (), null ());

	return;


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

cobol_finish_:
     entry;

	if controlp ^= null ()
	then call hcs_$delentry_file (substr (sort_dir, 1, sort_dir_len), "cobol_temp_merge_file_", mcode);

	if controlp ^= null ()
	then if control.no_of_segs > 0
	     then do i = 1 to control.no_of_segs;

		     stat_ptr = control.statptr (i);

		     if stat_ptr ^= null ()
		     then if stat.file_info_ptr ^= null ()
			then call cobol_file_control_ ("-a", stat_ptr, 0, "", "1"b, close_code);

		end;

	return;


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


get_pointer:
     entry returns (pointer);

	return (controlp);


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


rc:
run_cobol:
     entry;

	if controlp ^= null ()
	then go to recursion_error;

	call cu_$arg_count (nargs);
	if nargs < 1
	then go to missing_arg_error;

	call cu_$arg_ptr (1, argptr, arglen, mcode);
	if mcode ^= 0
	then go to rc_multics_error;

/*[4.4-2]*/
	arg1_ptr = argptr;
	arg1_len = arglen;

/*[5.0-1]*/
	call find_command_ (argptr, arglen, segptr, mcode);

/*[4.4-2]*/
	if mcode = error_table_$seg_not_found		/*[4.4-2]*/
	then do;
		call com_err_ (0, "run_cobol", "Segment ^a not found", arg);
		return;
	     end;

/* [3.0-1] */
	call set_handlers (1);

	sort_dir_len = 0;

	if nargs > 1
	then do i = 2 to nargs;

		call cu_$arg_ptr (i, argptr, arglen, mcode);
		if mcode ^= 0
		then go to rc_multics_error;

		if arg = "-cs" | arg = "-cobol_switch"
		then do;

switch_loop:
			i = i + 1;

			if i <= nargs
			then do;

				call cu_$arg_ptr (i, argptr, arglen, mcode);
				if mcode ^= 0
				then go to rc_multics_error;

				if substr (arg, 1, 1) = "-"
				then i = i - 1;
				else do;

					if arglen > 1 | arg < "1" | arg > "8"
					then go to bad_arg_error;

					control.sense_sw (fixed (arg, 17)) = 1;

					go to switch_loop;

				     end;
			     end;
		     end;
		else if arg = "-sd" | arg = "-sort_dir"
		then do;

			i = i + 1;

			if i <= nargs
			then do;

				call cu_$arg_ptr (i, argptr, arglen, mcode);
				if mcode ^= 0
				then go to rc_multics_error;

				if substr (arg, 1, 1) = "-"
				then i = i - 1;
				else do;

					call expand_path_ (argptr, arglen, addr (sort_dir), null (), mcode);
					sort_dir_len = index (sort_dir, " ") - 1;
				     end;
			     end;
		     end;
		else if arg = "-sfs" | arg = "-sort_file_size"
		then do;

			i = i + 1;

			if i <= nargs
			then do;
				call cu_$arg_ptr (i, argptr, arglen, mcode);
				if mcode ^= 0
				then go to rc_multics_error;

				if substr (arg, 1, 1) = "-"
				then i = i - 1;
				else sort_file_size = float (arg, 27);

			     end;
		     end;
		else if arg = "-ctu" | arg = "-continue"
		then control.ind_mask = "000000001"b;
		else if arg = "-nsr" | arg = "-no_stop_run"
		then stop_run_sw = "1"b;
		else if arg = "-db" | arg = "-debug"
		then control.sense_sw (8) = 1;
		else go to bad_arg_error;

	     end;

	control.main_prog_ptr = segptr;
	control.main_prog_sw = 1;

	if ^stop_run_sw
	then on stop_run call COND ("stop_run");	/* [3.0-1] */

/*[4.4-2]*/
	call cu_$cp (arg1_ptr, arg1_len, mcode);	/*[4.4-2]*/
	if mcode ^= 0
	then go to invalid_exit_error;		/*[4.4-2]*/
	return;


bad_arg_error:
	call com_err_ (error_table_$badopt, "run_cobol", arg);
	go to rc_error;

recursion_error:
	call com_err_ (0, "run_cobol",
	     "A cobol run-unit already exists; stop_cobol_run must be issued before another can be created.");
	return;

missing_arg_error:
	call com_err_ (error_table_$noarg, "run_cobol");
	go to rc_error;

invalid_exit_error:
	call com_err_ (0, "Error", "An invalid EXIT PROGRAM has been executed.");
	return;

rc_multics_error:
	call com_err_ (mcode, "run_cobol");

rc_error:
	controlp = null ();
	return;



COND:
     proc (cond_name);				/*[3.0-1]*/

declare	find_condition_info_
			entry (ptr, ptr, fixed bin (35));
						/*[3.0-1]*/
declare	code		fixed bin (35),
	cond_name		char (*);			/*[3.0-1]*/


	call find_condition_info_ (null (), addr (cond_info), code);
						/*[3.0-1]*/
	call cobol_hand (cond_name, cond_info.infoptr);	/*[3.0-1]*/
						/*
 call release_temp_segments_ ("cobol_control_", tp, mcode);
*/
     end;						/*[3.0-1]*/

/* called if controlp = null, 0(prologue), 1(run_cobol) */

set_handlers:
     proc (mode);					/*[3.0-1]*/

/**/
declare	mode		fixed bin;

/*[4.0-1]*/
	call get_temp_segments_ ("cobol_control_", tp, mcode);
						/*[4.0-1]*/
	if mcode ^= 0
	then go to control_error;

/*[4.0-1]*/
	controlp = tp (1);

/**/
	if mode ^= 0				/**/
	then do;
		call hcs_$truncate_seg (controlp, 0, mcode);
						/**/
		if mcode ^= 0
		then go to rc_multics_error;		/**/
	     end;

/**/
	evar = cobol_control_;

/**/
	call hcs_$make_ptr (bptr,			/**/
	     "cobol_rts_handler_",			/**/
	     "cobol_rts_handler_",			/**/
	     control.fofl_handler_ptr,		/**/
	     mcode);

/**/
	if mcode ^= 0
	then go to control_error;

/*[4.4-2]*/
	call add_epilogue_handler_ (cobol_finish_, mcode);/**/
	if mcode ^= 0
	then go to control_error;

     end;

/* [3.0-1] */



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

cobol_handler_:
     entry;					/* This entry can be deleted but bound_cobol_rts_.bind must be altered */

	return;

cobol_hand:
     proc (cond_name, infoptr);			/* [3.0-1] */
	;

dcl	cond_name		char (*);
dcl	infoptr		ptr;

	if ^stop_run_sw
	then if cond_name = "stop_run"
	     then do;

		     stop_code = 0;
		     call cobol_stop_run_ (infoptr, 0, 0, stop_code);

		     call com_err_ (0, "Error", "No cobol run-unit exists - cannot STOP RUN.");
		     call signal_ ("command_abort_", null (), null ());


		end;

	call com_err_ (0, "Error", "^a condition raised - internal inconsistency in the run-unit.", cond_name);

     end;


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

cobol_file_control_:
     entry (ioname, statp, type, errorname, dtsw, cfc_code);

dcl	ioname		char (*);
dcl	statp		ptr;
dcl	type		fixed bin;		/* -1=nomes,0=norm,1=long: close; 2=norm,3=long: list */
dcl	errorname		char (*);
dcl	dtsw		bit (1) aligned;
dcl	cfc_code		fixed bin (35);

	begin;
dcl	statptr		ptr;
	     statptr = statp;

dcl	1 opened_files	static,
	  2 n		fixed bin init (0),
	  2 pt		(20) ptr;

dcl	1 dup,
	  2 n		fixed bin,
	  2 pt		(100) ptr;

dcl	mcode		fixed bin (35);
dcl	save_mode		fixed bin;
dcl	i		fixed bin;
dcl	j		fixed bin;
dcl	k		fixed bin;
dcl	m		fixed bin;
dcl	org		fixed bin;
dcl	acc		fixed bin;
dcl	mode		fixed bin;

dcl	odptr		ptr;
dcl	adptr		ptr;

dcl	anysw		bit (1);
dcl	nodupsw		bit (1);
dcl	command_sw	bit (1);

dcl	vstring		char (240) varying based;
dcl	save_od		char (240) varying;
dcl	save_ad		char (240) varying;
dcl	save_ocname	char (65);
dcl	pname		char (65);
dcl	file_name		char (32);
dcl	eicon		char (8);
dcl	pcon		char (69);
dcl	action_con	char (20);
dcl	oiscon		char (3);
dcl	aiscon		char (3);
dcl	mode_con		(0:3) char (6) static init ("extend", "input", "i-o", "output");
dcl	org_con		(0:3) char (10) static init ("stream", "sequential", "relative", "indexed");
dcl	acc_con		(3) char (10) static init ("sequential", "random", "dynamic");

dcl	iox_$close	entry (ptr, fixed bin (35));
dcl	iox_$detach_iocb	entry (ptr, fixed bin (35));	/* dcl ioa_ entry options(variable); */
						/* dcl com_err_ entry options(variable); */


	     cfc_code = -2;

	     if controlp = null ()
	     then return;
	     if control.no_of_segs < 1
	     then return;

	     cfc_code = -1;				/* until something is done */
	     nodupsw = "0"b;
	     dup.n = 0;

	     if substr (ioname, 1, 1) = "-"
	     then anysw = "1"b;
	     else anysw = "0"b;

	     if statptr ^= null ()
	     then do;

		     stat_ptr = statptr;
		     if stat.file_info_ptr = null ()
		     then return;

		     pname = stat.prog_id;
		     file_info_ptr = stat.file_info_ptr;

		     call look;
		end;
	     else do;

		     if anysw
		     then do;

			     nodupsw = "1"b;

			     do i = 1 to control.no_of_segs;

				stat_ptr = control.statptr (i);

				if stat_ptr ^= null ()
				then do;

					if stat.file_info_ptr ^= null ()
					then do;

						pname = stat.prog_id;
						file_info_ptr = stat.file_info_ptr;
						call look;
					     end;
				     end;
			     end;

			end;
		     else do;
			     call hcs_$make_ptr (null (), "cobol_fsb_", ioname, fsb_ptr, mcode);
			     if fsb_ptr = null ()
			     then return;
			     call action;
			end;

		end;

	     return;




/* *********************************** */
/* SUBROUTINES */
/* *********************************** */

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

look:
     proc;

	do k = 1 to divide (file_info.n, 2, 17, 0);

	     if file_info.pt (k) ^= null ()
	     then do;
		     fsb_ptr = file_info.pt (k);
		     dtsw = ^fsb.attach_flag;

/*[5.3-1]*/
		     if fsb.fsb_skel.mod1
		     then fsb.last_key_read = "";

		     if anysw
		     then if ioname = "-a" | ioname = "-i" & fsb.internal | ioname = "-e" & ^fsb.internal
			then call action;
			else ;
		     else do;

			     if ioname = fsb.iocb_ptr -> iocb.name
			     then call action;

			     if fsb.internal
			     then do;
				     j = index (fsb.iocb_ptr -> iocb.name, " ") - 17;
				     if j < 0
				     then j = 16;
				     if ioname = substr (fsb.iocb_ptr -> iocb.name, 1, j)
				     then call action;
				end;

			end;
		end;
	end;

     end;


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

action:
     proc;

	save_ocname = fsb.open_close_name;
	save_mode = fsb.open_mode;

	if nodupsw & pname ^= save_ocname
	then do;

		if substr (save_ocname, 1, 3) = "***" | save_ocname = ""
		then do;				/* by command or non-cobol prog */

			if dup.n > 0
			then do m = 1 to dup.n;

				if dup.pt (m) = fsb_ptr
				then return;
			     end;

			if dup.n < 100
			then dup.n = dup.n + 1;	/* don't be ridiculous */

			dup.pt (dup.n) = fsb_ptr;
			command_sw = "1"b;

		     end;
		else return;

	     end;
	else command_sw = "0"b;

	if fsb.iocb_ptr ^= null ()
	then do;
		if errorname = "scr"
		then if fsb.internal
		     then fsb.lock = "0"b;

		odptr = fsb.iocb_ptr -> iocb.open_descrip_ptr;
		adptr = fsb.iocb_ptr -> iocb.attach_descrip_ptr;

		if odptr ^= null ()
		then save_od = odptr -> vstring;

		if adptr ^= null ()
		then save_ad = adptr -> vstring;
	     end;
	else return;

	if type > 1
	then cfc_code = 0;				/* list only */
	else if pname = save_ocname | ^anysw | command_sw
	then do;

		if save_mode > 0
		then cfc_code = 0;

		if save_mode < 0
		then do;

			if ^anysw
			then do;

				call com_err_ (0, "close_cobol_file",
				     "Not closing external file ^a (it was opened by a non-cobol program).",
				     fsb.iocb_ptr -> iocb.name);
				cfc_code = 0;

			     end;

			return;

		     end;

		if save_mode ^= 0
		then do;

			call iox_$close (fsb.iocb_ptr, mcode);
			if mcode ^= 0
			then go to merror;

			cfc_code = 0;
			fsb.open_mode = 0;
			j = index (errorname, " ") - 1;

			if j < 0
			then j = length (errorname);

			fsb.open_close_name = "***" || substr (errorname, 1, j) || "***";
		     end;

		if dtsw
		then do;

			call iox_$detach_iocb (fsb.iocb_ptr, mcode);

			if mcode ^= 0
			then do;

				if save_mode ^= 0
				then go to merror;
				else return;
			     end;
			else cfc_code = 0;

		     end;
		else if save_mode = 0
		then return;

	     end;
	else return;

	if type < 0
	then return;				/* no message */

	if fsb.internal
	then do;

		j = index (fsb.iocb_ptr -> iocb.name, " ") - 17;

		if j < 0
		then j = 16;

		file_name = substr (fsb.iocb_ptr -> iocb.name, 1, j);
		eicon = "Internal";
		pcon = " in " || substr (stat.prog_id, 1, stat.prog_id_len);
	     end;
	else do;
		file_name = fsb.iocb_ptr -> iocb.name;
		eicon = "External";
		pcon = "";
	     end;

	if type < 2
	then do;

		if dtsw
		then do;
			if save_mode = 0
			then action_con = " detached";
			else action_con = " closed and detached";
		     end;
		else action_con = " closed";

		pcon = "";
	     end;
	else action_con = "";

	if stop_run_command
	then call ioa_ ("^a file ^a^a^a", eicon, file_name, action_con, pcon);
	else ;

	if save_mode = 0
	then if stop_run_command
	     then call ioa_ ("  closed by ^a", save_ocname);
	     else ;
	else do;

		if save_mode < 0
		then if stop_run_command
		     then call ioa_ ("  opened by a non-cobol program");
		     else ;
		else do;

			org = fixed (substr (unspec (save_mode), 33, 2), 2);
			acc = fixed (substr (unspec (save_mode), 35, 2), 2);
			mode = fixed (substr (unspec (save_mode), 31, 2), 2);

/* [4.0-2] */
			if stop_run_command
			then call ioa_ ("  opened by ^a for ^a with ^a organization and ^a access", save_ocname,
				mode_con (mode), org_con (org), acc_con (acc));

		     end;

	     end;

	if type = 0 | type = 2
	then return;				/* normal message */

	if stop_run_command
	then call ioa_ ("  file state block at ^p^/  io_control_block for io_switch ^a at ^p", fsb_ptr,
		fsb.iocb_ptr -> iocb.name, fsb.iocb_ptr);

	if type = 3
	then oiscon, aiscon = "is";
	else do;
		oiscon = "was";

		if dtsw
		then aiscon = "was";
		else aiscon = "is";

	     end;

	if stop_run_command
	then do;
		if odptr ^= null ()
		then call ioa_ ("  open description ^a:	""^a""", oiscon, save_od);

		if adptr ^= null ()
		then call ioa_ ("  attach description ^a:	""^a""", aiscon, save_ad);

		call ioa_ ("");

	     end;
	else ;
	return;
merror:
	call com_err_ (mcode, errorname);
	return;
     end;


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

	end;					/* *********************************** */
						/* *********************************** */
control_error:
	call cu_$stack_frame_ptr (stack_frame_ptr);
	stack_frame_ptr = stack_frame.prev_stack_frame_ptr;
	error_ptr = addrel (stack_frame.return_ptr, -1);
	call cobol_error_ (0, mcode, 0, 0, "cobol_control_", error_ptr);
	return;

multics_error:
	call com_err_ (mcode, "stop_run");
	call signal_ ("command_abort_", null (), null ());
	return;

return_multics_error:
	code = mcode;
	return;


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

/* ****	Declaration for builtin function	**** */

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index, float)
			builtin;

/* ****	End of declaration for builtin function	**** */

%include cobol_control;
%include cobol_fixed_static;
%include cobol_stack_frame;
%include cobol_fsb_type_1;
%include cobol_fsbskel;
%include iocb;
%include stack_header;
%include cobol_file_info;

dcl	1 cond_info,				/*[3.0-1]*/
%include cond_info;

     end;




		    cobol_error_.pl1                05/24/89  1048.6rew 05/24/89  0836.9       79767



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_error_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 06/08/79 by PRP, [4.0-1], print_cobol_error_ made to use error_output */
/* Modified since Version 4.0 */
/*{*/
/* format: style3 */
cobol_error_:
     proc (cobol_code, multics_code, line_no1, line_no2, progname, error_ptr);

/*  This is a run-time routine for reporting object errors
which occur in cobol programs or are discovered by cobol
run-time support routines.  It reports the error to the
error_output stream and signals the "error" condition.
The sub-generators cobol_process_error and cobol_gen_error are used by
code generators to set up a call to this routine.  */

dcl	cobol_code	fixed bin parameter;
dcl	multics_code	fixed bin (35) parameter;
dcl	line_no1		fixed bin parameter;
dcl	line_no2		fixed bin parameter;
dcl	progname		char (65) varying parameter;
dcl	error_ptr		ptr parameter;


/*
cobol_code	indicates the cobol error number (input).

multics_code	indicates the multics status code (input).

line_no1		the line number on which the error occurred.
		If 0, no line number is applicable
		and no such indication will be given in the
		error message (input).

line_no2		the additional line number.  If 0, then only
		a one-part line number is given (input).

progname		a character string containing the name of the
		program which produced the error.  The
		cobol_process_error sub-generator will always
		set is to the name of the program for which
		code is being generated.  Run-time support
		routines may identify the program which
		called them of themselves, depending on the
		nature of the error.  If this is a null
		string, then no program name is applicable
		and none will be attached to the error
		message (input).

error_ptr		a pointer to the location at which the error
		was discovered or to the location at which
		cobol_error_ is called from.  The
		cobol_process_error sub-generator will always
		set it to the latter (input).


The following message(s) will be output to the "error_output" stream:

     ["progname": Multics message (from com_err_)]
     ["progname": COBOL error message]
     Error occurred at "segno|offset"
          [in "progname" [on line ["line_no2"] "line_no1"]]

The first line is printed only if multics_code is non-zero.  The second line is printed
only if cobol_code is non-zero.
The third line is always printed.  The progname portion of it is not present
if progname is null; the line_no2 portion of it is not present is line_no2 is zero;
the line_no1 portion of it is not present if line_no1 is zero.
}*/

/* COBOL ERROR TABLE */
dcl	cet_ptr		ptr static init (null ());
dcl	cet		char (100000) based (cet_ptr);
dcl	1 cobol_error_table based (cet_ptr),
	  2 max		fixed bin aligned,
	  2 error		(0 refer (cobol_error_table.max)) aligned,
	    3 start	fixed bin unal,
	    3 len		fixed bin unal;		/* DECLARATIONS */
dcl	len		fixed bin;
dcl	code		fixed bin (35);

dcl	dname		char (168);
dcl	ename		char (32);
dcl	inprog		char (168);
dcl	online		char (24);
dcl	shortinfo		char (8) aligned;
dcl	longinfo		char (100) aligned;

dcl	evar		entry auto;
dcl	bptr		ptr based (addr (evar));

dcl	cobol_error_$use	entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (65) varying, ptr);
dcl	convert_status_code_
			entry (fixed bin (35), char (8) aligned, char (100) aligned);
dcl	com_err_		entry options (variable);
dcl	hcs_$make_ptr	entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl	ioa_$ioa_stream	entry options (variable);
dcl	ioa_$ioa_stream_nnl entry options (variable);
dcl	ioa_$rs		entry options (variable);
dcl	ioa_$rsnnl	entry options (variable);
dcl	hcs_$fs_get_path_name
			entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl	signal_		entry (char (*));


/*************************************/
start:
	if cet_ptr = null ()
	then call set_cet_ptr;
	if multics_code ^= 0
	then do;
		call convert_status_code_ (multics_code, shortinfo, longinfo);
		if progname ^= ""
		then call ioa_$ioa_stream_nnl ("error_output", "^a: ", progname);
		call ioa_$ioa_stream ("error_output", longinfo);
	     end;

	if cobol_code > 0
	then do;
		if progname ^= ""
		then call ioa_$ioa_stream_nnl ("error_output", "^a: ", progname);
		if cobol_code > cobol_error_table.max
		then call ioa_$ioa_stream ("error_output", "Invalid cobol error code ^d", cobol_code);
		else call ioa_$ioa_stream ("error_output",
			substr (cet, error.start (cobol_code), error.len (cobol_code)));
						/*-06/02/76-*/
	     end;

	call hcs_$fs_get_path_name (error_ptr, dname, len, ename, code);
	if code ^= 0
	then inprog = "";
	else inprog = " in " || substr (dname, 1, len) || ">" || ename;
	if line_no1 > 0 | line_no2 > 0
	then if line_no1 > 0 & line_no2 > 0
	     then call ioa_$rsnnl (" on line ^d-^d", online, len, line_no2, line_no1);
	     else call ioa_$rsnnl (" on line ^d", online, len, line_no1);
	else online = "";
	call ioa_$ioa_stream ("error_output", "Error occurred at ^p^a^a", error_ptr, inprog, online);
	call cobol_error_$use (cobol_code, multics_code, line_no1, line_no2, progname, error_ptr);
						/*-05/10/76-*/
	call signal_ ("error");
	return;


/*************************************/
use:
     entry (cobol_code, multics_code, line_no1, line_no2, progname, error_ptr);
dcl	errline		char (300) static;
dcl	tline		char (120);
dcl	erroff		fixed bin;
dcl	errlen		fixed bin static init (0);

start_use:
	if cet_ptr = null ()
	then call set_cet_ptr;
	erroff = 1;
	if multics_code ^= 0
	then do;
		call convert_status_code_ (multics_code, shortinfo, longinfo);
		if progname ^= ""
		then do;
			call ioa_$rsnnl ("^a: ", tline, len, progname);
			substr (errline, erroff, len) = tline;
			erroff = erroff + len;
		     end;
		call ioa_$rs (longinfo, tline, len);
		substr (errline, erroff, len) = tline;
		erroff = erroff + len;
	     end;

	if cobol_code > 0
	then do;
		if progname ^= ""
		then do;
			call ioa_$rsnnl ("^a: ", tline, len, progname);
			substr (errline, erroff, len) = tline;
			erroff = erroff + len;
		     end;
		if cobol_code > cobol_error_table.max
		then call ioa_$rs ("Invalid cobol error code ^d", tline, len, cobol_code);
						/*-06/02/76-*/
		else do;
			call ioa_$rs (substr (cet, error.start (cobol_code), error.len (cobol_code)), tline, len);
						/*-06/02/76-*/
			substr (errline, erroff, len) = tline;
			erroff = erroff + len;
		     end;
	     end;

	call hcs_$fs_get_path_name (error_ptr, dname, len, ename, code);
	if code ^= 0
	then inprog = "";
	else inprog = " in " || substr (dname, 1, len) || ">" || ename;
	if line_no1 > 0 | line_no2 > 0
	then if line_no1 > 0 & line_no2 > 0
	     then call ioa_$rsnnl (" on line ^d-^d", online, len, line_no2, line_no1);
	     else call ioa_$rsnnl (" on line ^d", online, len, line_no1);
	else online = "";
	call ioa_$rs ("Error occurred at ^p^a^a", tline, len, error_ptr, inprog, online);
	substr (errline, erroff, len) = tline;
	errlen = erroff + len - 1;
	return;


/*************************************/
print_cobol_error_:
     entry;
dcl	stream		char (32);		/*[4.0-1]*/
	stream = "error_output";
	go to join;

switch:
     entry (in_stream);
dcl	in_stream		char (*) parameter;
	stream = in_stream;

join:
	if errlen = 0
	then call ioa_$ioa_stream (stream, "Improper call to print_cobol_error_ - no pending error recorded");
	else call ioa_$ioa_stream (stream, substr (errline, 1, errlen));
	return;

/*************************************/
abort:
	call signal_ ("error");

set_cet_ptr:
     proc;
	evar = cobol_error_;
	call hcs_$make_ptr (bptr, "cobol_error_table_", "cobol_error_table_", cet_ptr, code);
	if cet_ptr = null ()
	then do;
		call com_err_ (code, "cobol rts", "cobol_error_table_$cobol_error_table_");
		go to abort;
	     end;
	return;
     end set_cet_ptr;

/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

     end cobol_error_;




		    cobol_error_table_.alm          11/11/82  1550.1rew 11/11/82  1030.7      131040



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

	name	cobol_error_table_
cobol_error_table_:
	segdef	cobol_error_table_
	oct	000000000076
	oct	000375000016
	oct	000413000060
	oct	000473000051
	oct	000544000052
	oct	000616000040
	oct	000656000051
	oct	000727000030
	oct	000757000052
	oct	001031000063
	oct	001114000066
	oct	001202000070
	oct	001272000054
	oct	001346000033
	oct	001401000072
	oct	001473000023
	oct	001516000076
	oct	001614000060
	oct	001674000024
	oct	001720000067
	oct	002007000075
	oct	002104000026
	oct	002132000076
	oct	002230000115
	oct	002345000052
	oct	002417000025
	oct	002444000034
	oct	002500000027
	oct	002527000114
	oct	002643000035
	oct	002700000027
	oct	002727000030
	oct	002757000036
	oct	003015000115
	oct	003132000111
	oct	003243000123
	oct	003366000100
	oct	003466000034
	oct	003522000060
	oct	003602000101
	oct	003703000070
	oct	003773000123
	oct	004116000105
	oct	004223000106
	oct	004331000054
	oct	004405000063
	oct	004470000076
	oct	004566000071
	oct	004657000047
	oct	004726000062
	oct	005010000020
	oct	005030000073
	oct	005123000045
	oct	005170000044
	oct	005234000051
	oct	005305000050
	oct	005355000050
	oct	005425000031
	oct	005456000020
	oct	005476000072
	oct	005570000102
	oct	005672000070
	oct	005762000062
	oct	117142163157
	oct	154145164145
	oct	040145162162
	oct	157162101164
	oct	164145155160
	oct	164040164157
	oct	040145170145
	oct	143165164145
	oct	040142145171
	oct	157156144040
	oct	154157147151
	oct	143141154040
	oct	145156144040
	oct	157146040160
	oct	162157147162
	oct	141155125156
	oct	141142154145
	oct	040164157040
	oct	143157155160
	oct	154145164145
	oct	040144151163
	oct	160154141171
	oct	040164157040
	oct	165163145162
	oct	137157165164
	oct	160165164125
	oct	156141142154
	oct	145040164157
	oct	040143157155
	oct	160154145164
	oct	145040144151
	oct	163160154141
	oct	171040164157
	oct	040145162162
	oct	157162137157
	oct	165164160165
	oct	164111155160
	oct	162157160145
	oct	162154171040
	oct	145170145143
	oct	165164145144
	oct	040104105103
	oct	114101122101
	oct	124111126105
	oct	123125156141
	oct	142154145040
	oct	164157040143
	oct	157155160154
	oct	145164145040
	oct	141143143145
	oct	160164040146
	oct	162157155040
	oct	165163145162
	oct	137151156160
	oct	165164125156
	oct	141142154145
	oct	040164157040
	oct	145163164141
	oct	142154151163
	oct	150040111117
	oct	103102101164
	oct	164145155160
	oct	164040164157
	oct	040157160145
	oct	156040145170
	oct	164145162156
	oct	141154040146
	oct	151154145040
	oct	141154162145
	oct	141144171040
	oct	157160145156
	oct	101164164145
	oct	155160164040
	oct	164157040157
	oct	160145156040
	oct	151156164145
	oct	162156141154
	oct	040146151154
	oct	145040167150
	oct	151143150040
	oct	151163040141
	oct	154162145141
	oct	144171040157
	oct	160145156116
	oct	157040160162
	oct	145166151157
	oct	165163040141
	oct	164164141143
	oct	150155145156
	oct	164040145163
	oct	164141142154
	oct	151163150145
	oct	144040146157
	oct	162040165156
	oct	141164164141
	oct	143150145144
	oct	040146151154
	oct	145125156141
	oct	142154145040
	oct	164157040143
	oct	154157163145
	oct	040146151154
	oct	145040151156
	oct	040157162144
	oct	145162040164
	oct	157040162145
	oct	141164164141
	oct	143150040164
	oct	150145040111
	oct	057117040163
	oct	167151164143
	oct	150125156141
	oct	142154145040
	oct	164157040144
	oct	145164141143
	oct	150040111057
	oct	117040163167
	oct	151164143150
	oct	040146157162
	oct	040162145141
	oct	164164141143
	oct	150155145156
	oct	164125156141
	oct	142154145040
	oct	164157040141
	oct	164164141143
	oct	150040111057
	oct	117040163167
	oct	151164143150
	oct	125156141142
	oct	154145040164
	oct	157040141164
	oct	164141143150
	oct	040111057117
	oct	040163167151
	oct	164143150040
	oct	165163151156
	oct	147040163160
	oct	145143151146
	oct	151145144040
	oct	141164164141
	oct	143150040157
	oct	160164151157
	oct	156163125156
	oct	141142154145
	oct	040164157040
	oct	157160145156
	oct	040146151154
	oct	145125156141
	oct	142154145040
	oct	164157040160
	oct	157163151164
	oct	151157156040
	oct	144171156141
	oct	155151143040
	oct	141143143145
	oct	163163040157
	oct	165164160165
	oct	164040146151
	oct	154145040164
	oct	157040105117
	oct	106040165160
	oct	157156040157
	oct	160145156101
	oct	164164145155
	oct	160164040164
	oct	157040143154
	oct	157163145040
	oct	151156164145
	oct	162156141154
	oct	040146151154
	oct	145040167150
	oct	151143150040
	oct	151163040156
	oct	157164040157
	oct	160145156125
	oct	156141142154
	oct	145040164157
	oct	040143154157
	oct	163145040146
	oct	151154145125
	oct	156141142154
	oct	145040164157
	oct	040144145164
	oct	141143150040
	oct	111057117040
	oct	163167151164
	oct	143150040141
	oct	146164145162
	oct	040143154157
	oct	163151156147
	oct	040151156164
	oct	145162156141
	oct	154040146151
	oct	154145101164
	oct	164145155160
	oct	164040164157
	oct	040145170145
	oct	143165164145
	oct	040141156040
	oct	165156151156
	oct	151164151141
	oct	154151172145
	oct	144040141154
	oct	164145162141
	oct	142154145040
	oct	107117040124
	oct	117040163164
	oct	141164145155
	oct	145156164125
	oct	156141142154
	oct	145040164157
	oct	040167162151
	oct	164145040162
	oct	145143157162
	oct	144125156141
	oct	142154145040
	oct	164157040163
	oct	145145153040
	oct	163160145143
	oct	151146151145
	oct	144040153145
	oct	171040146157
	oct	162040157165
	oct	164160165164
	oct	040055040160
	oct	157163163151
	oct	142154145040
	oct	144165160154
	oct	151143141164
	oct	151157156124
	oct	150145040166
	oct	141154165145
	oct	040157146040
	oct	141040144141
	oct	164141055156
	oct	141155145040
	oct	165163145144
	oct	040167151164
	oct	150040164150
	oct	145040101104
	oct	126101116103
	oct	111116107040
	oct	143154141165
	oct	163145040151
	oct	163040151156
	oct	157162144151
	oct	156141164145
	oct	154171040154
	oct	141162147145
	oct	101164164145
	oct	155160164040
	oct	164157040160
	oct	145162146157
	oct	162155040111
	oct	057117040157
	oct	156040141156
	oct	040165156157
	oct	160145156145
	oct	144040146151
	oct	154145125156
	oct	141142154145
	oct	040164157040
	oct	162145141144
	oct	040162145143
	oct	157162144125
	oct	156141142154
	oct	145040164157
	oct	040163145145
	oct	153040153145
	oct	171040146157
	oct	162040151156
	oct	160165164125
	oct	156141142154
	oct	145040164157
	oct	040162145141
	oct	144040156145
	oct	170164040153
	oct	145171111156
	oct	166141154151
	oct	144040144145
	oct	154145164145
	oct	040141164164
	oct	145155160164
	oct	145144040055
	oct	040160162145
	oct	166151157165
	oct	163040111057
	oct	117040157160
	oct	145162141164
	oct	151157156040
	oct	167141163040
	oct	156157164040
	oct	141040162145
	oct	141144040151
	oct	156040151055
	oct	157040155157
	oct	144145125156
	oct	141142154145
	oct	040164157040
	oct	163145145153
	oct	040153145171
	oct	040146157162
	oct	040144145154
	oct	145164145125
	oct	156141142154
	oct	145040164157
	oct	040144145154
	oct	145164145040
	oct	162145143157
	oct	162144125156
	oct	141142154145
	oct	040164157040
	oct	162145167162
	oct	151164145040
	oct	162145143157
	oct	162144125156
	oct	141142154145
	oct	040164157040
	oct	163145145153
	oct	040153145171
	oct	040146157162
	oct	040162145167
	oct	162151164145
	oct	111156166141
	oct	154151144040
	oct	162145167162
	oct	151164145040
	oct	141164164145
	oct	155160164145
	oct	144040055040
	oct	160162145166
	oct	151157165163
	oct	040111057117
	oct	040157160145
	oct	162141164151
	oct	157156040167
	oct	141163040156
	oct	157164040141
	oct	040162145141
	oct	144040151156
	oct	040151055157
	oct	040155157144
	oct	145111156166
	oct	141154151144
	oct	040162145167
	oct	162151164145
	oct	040141164164
	oct	145155160164
	oct	145144040141
	oct	164164145155
	oct	160164145144
	oct	040055040156
	oct	145167040153
	oct	145171040151
	oct	163040156157
	oct	164040151144
	oct	145156164151
	oct	143141154040
	oct	164157040157
	oct	154144040153
	oct	145171111156
	oct	166141154151
	oct	144040162145
	oct	167162151164
	oct	145040141164
	oct	164145155160
	oct	164145144040
	oct	055040156145
	oct	167040162145
	oct	143157162144
	oct	040154145156
	oct	147164150040
	oct	151163040156
	oct	157164040151
	oct	144145156164
	oct	151143141154
	oct	040164157040
	oct	157154144040
	oct	162145143157
	oct	162144040154
	oct	145156147164
	oct	150111156166
	oct	141154151144
	oct	040111057117
	oct	040157160145
	oct	162141164151
	oct	157156056040
	oct	040101164164
	oct	145155160164
	oct	040164157040
	oct	163164141162
	oct	164040141040
	oct	146151154145
	oct	040157160145
	oct	156145144040
	oct	141163040157
	oct	165164160165
	oct	164125156141
	oct	142154145040
	oct	164157040163
	oct	145145153040
	oct	153145171040
	oct	146157162040
	oct	163164141162
	oct	164125156141
	oct	142154145040
	oct	164157040163
	oct	164141162164
	oct	040146151154
	oct	145040167151
	oct	164150040163
	oct	160145143151
	oct	146151145144
	oct	040153145171
	oct	040162145154
	oct	141164151157
	oct	156101164164
	oct	145155160164
	oct	040164157040
	oct	123105124040
	oct	141156040151
	oct	156144145170
	oct	040157165164
	oct	163151144145
	oct	040164150145
	oct	040162141156
	oct	147145040157
	oct	146040151164
	oct	163040141163
	oct	163157143151
	oct	141164145144
	oct	040164141142
	oct	154145111156
	oct	166141154151
	oct	144040111057
	oct	117040157160
	oct	145162141164
	oct	151157156056
	oct	040040101164
	oct	164145155160
	oct	164040164157
	oct	040162145141
	oct	144040141156
	oct	040165156157
	oct	160145156145
	oct	144040146151
	oct	154145111156
	oct	166141154151
	oct	144040111057
	oct	117040157160
	oct	145162141164
	oct	151157156056
	oct	040040101164
	oct	164145155160
	oct	164040164157
	oct	040167162151
	oct	164145040141
	oct	040163145161
	oct	165145156164
	oct	151141154154
	oct	171040141143
	oct	143145163163
	oct	145144040146
	oct	151154145040
	oct	157160145156
	oct	145144040141
	oct	163040151055
	oct	157111156166
	oct	141154151144
	oct	040111057117
	oct	040157160145
	oct	162141164151
	oct	157156056040
	oct	040101164164
	oct	145155160164
	oct	040164157040
	oct	144145154145
	oct	164145040151
	oct	156040141040
	oct	146151154145
	oct	040156157164
	oct	040157160145
	oct	156145144040
	oct	141163040151
	oct	055157111156
	oct	166141154151
	oct	144040111057
	oct	117040157160
	oct	145162141164
	oct	151157156056
	oct	040040101164
	oct	164145155160
	oct	164040164157
	oct	040162145167
	oct	162151164145
	oct	040151156040
	oct	141040146151
	oct	154145040156
	oct	157164040157
	oct	160145156145
	oct	144040141163
	oct	040151055157
	oct	120145162146
	oct	157162155040
	oct	163164141164
	oct	145155145156
	oct	164040102131
	oct	040151144145
	oct	156164151146
	oct	151145162040
	oct	145161165141
	oct	154163040172
	oct	145162157056
	oct	126141154165
	oct	145040157146
	oct	040104105120
	oct	105116104111
	oct	116107040117
	oct	116040151164
	oct	145155040151
	oct	163040157165
	oct	164163151144
	oct	145040144145
	oct	146151156145
	oct	144040162141
	oct	156147145111
	oct	156144145170
	oct	040144141164
	oct	141040151164
	oct	145155040151
	oct	156040126101
	oct	122131111116
	oct	107040143154
	oct	141165163145
	oct	040157146040
	oct	123105101122
	oct	103110040151
	oct	163040156157
	oct	164040151156
	oct	151164151141
	oct	154151172145
	oct	144105170160
	oct	157156145156
	oct	164151141164
	oct	151157156040
	oct	145162162157
	oct	162040055040
	oct	074156145147
	oct	141164151166
	oct	145040156165
	oct	155142145162
	oct	076040052052
	oct	040074156157
	oct	156055151156
	oct	164145147145
	oct	162076105170
	oct	160157156145
	oct	156164151141
	oct	164151157156
	oct	040145162162
	oct	157162040055
	oct	040074172145
	oct	162157076040
	oct	052052040074
	oct	172145162157
	oct	076105170160
	oct	157156145156
	oct	164151141164
	oct	151157156040
	oct	145162162157
	oct	162040055040
	oct	074172145162
	oct	157076040052
	oct	052040074156
	oct	145147141164
	oct	151166145040
	oct	156165155142
	oct	145162076123
	oct	117122124057
	oct	115105122107
	oct	105040145162
	oct	162157162125
	oct	156141142154
	oct	145040164157
	oct	040141164164
	oct	141143150040
	oct	111057117040
	oct	163167151164
	oct	143150040055
	oct	040160157163
	oct	163151142154
	oct	145040151156
	oct	166141154151
	oct	144040143141
	oct	164141154157
	oct	147055156141
	oct	155145123117
	oct	122124040145
	oct	162162157162
	oct	040055040165
	oct	156141142154
	oct	145040164157
	oct	040122105114
	oct	105101123105
	oct	040162145143
	oct	157162144123
	oct	117122124040
	oct	145162162157
	oct	162040055040
	oct	165156141142
	oct	154145040164
	oct	157040122105
	oct	124125122116
	oct	040162145143
	oct	157162144123
	oct	117122124040
	oct	145162162157
	oct	162040055040
	oct	165156141142
	oct	154145040164
	oct	157040164145
	oct	162155151156
	oct	141164145040
	oct	164150145040
	oct	163157162164
	oct	123117122124
	oct	040145162162
	oct	157162040055
	oct	040165156141
	oct	142154145040
	oct	164157040151
	oct	156151164151
	oct	141164145040
	oct	164150145040
	oct	163157162164
	oct	123117122124
	oct	040145162162
	oct	157162040055
	oct	040165156141
	oct	142154145040
	oct	164157040143
	oct	157155155145
	oct	156143145040
	oct	164150145040
	oct	163157162164
	oct	125156141142
	oct	154145040164
	oct	157040143141
	oct	154154040151
	oct	144145156164
	oct	151146151145
	oct	162116157040
	oct	145162162157
	oct	162040155145
	oct	163163141147
	oct	145101162147
	oct	165155145156
	oct	164040155151
	oct	163155141164
	oct	143150040055
	oct	040151156143
	oct	157162162145
	oct	143164040156
	oct	165155142145
	oct	162040157146
	oct	040141162147
	oct	165155145156
	oct	164163040163
	oct	165160160154
	oct	151145144101
	oct	162147165155
	oct	145156164040
	oct	155151163155
	oct	141164143150
	oct	040055040144
	oct	141164141040
	oct	164171160145
	oct	040151163040
	oct	156157164040
	oct	143157155160
	oct	141164151142
	oct	154145040167
	oct	151164150040
	oct	164150141164
	oct	040145170160
	oct	145143164145
	oct	144101040163
	oct	165142163143
	oct	162151160164
	oct	040151163040
	oct	157165164163
	oct	151144145040
	oct	164150145040
	oct	162141156147
	oct	145040157146
	oct	040164150145
	oct	040162145146
	oct	145162145156
	oct	143145144040
	oct	164141142154
	oct	145101164164
	oct	145155160164
	oct	040164157040
	oct	157160145156
	oct	040141040146
	oct	151154145040
	oct	143154157163
	oct	145144040167
	oct	151164150040
	oct	164150145040
	oct	114117103113
	oct	040157160164
	oct	151157156000
	end




		    cobol_expand_source_.pl1        05/24/89  1048.6rew 05/24/89  0836.9      323244



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_expand_source_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 04/04/83 by FCH, [5.2-1], span changed to fixed bin(24), phx14809(BUG550) */
/* Modified on 12/29/81 by FCH, [5.1-2], ecs command makes COPY and REPLACE statements into comments, phx11818(BUG519) */
/* Modified on 10/27/81 by FCH, [5.1-1], include file cobol_ecs_info changed, phx11819(BUG517) */
/* Recompiled on 12/10/79 to fix problem with leveling diags on COPY statements */
/* Modified on 04/09/79 by FCH, [4.0-3], emit text manip statement */
/* Modified on 04/05/79 by FCH, [4.0-2], detect illegal pseudo-text */
/* Modified on 02/23/79 by FCH, [4.0-1], copy file name qualification */
/* created for Version 4.0 */






/* format: style3 */
cobol_expand_source_:
     proc;


replace:
     entry (ecs_info_ptr, bc, command, expand_cobol_source_area_ptr);

	call init;

/* Main	processing loop for replace statement */

replace_err:
	call clear_copy;

	do while ("1"b);

	     lexeme_env.error = 0;
	     call cobol_lexeme$find_replace (lexeme_ptr);
next_replace:
	     if lexeme_env.error = 1
	     then do;

		     call merge_to_end;
		     bc = (next_new_position - 1) * 9;
		     call finish;
		     return;
		end;
	     else do;

		     replace_active = "1"b;
		     save_copy_line = lexeme_env.token.line;
		     copy_line_length = lexeme_env.current_line.length;
		     save_copy_column = lexeme_env.token.column;
		     save_source_offset = lexeme_env.token.offset - 1;
		     copy_line_ptr = lexeme_env.current_line.loc;

		     call process_replace_statement;

		end;

	end;					/* end	processing loop for replace statement */

process_replace_statement:
     proc;

/*[4.0-3]*/
	state_pos = lexeme_env.token.offset;

	comp_str_used = 1;
	cr_used, cr_largest, semi_sw, comma_sw = 0;

	lexeme_env.indicators.copy_replace = "1"b;
	lexeme_env.pseudo_text = 1;


	call cobol_lexeme$cobol_lexeme (lexeme_ptr);

	if lexeme_env.error = 1
	then return;				/* replace off. */
	if lexeme_env.token.type = 3 & lexeme_env.token.string = "off"
	then do;

		call cobol_lexeme$cobol_lexeme (lexeme_ptr);
		if lexeme_env.error = 1
		then return;

		if lexeme_env.token.type = 4 & lexeme_env.token.string = "."
		then do;

			call merge_to_copy;
			last_source_offset = lexeme_env.token.offset + 2;
			return;
		     end;
	     end;					/* replace statement */
	if substr (word, 1, lexeme_env.token.string_size) ^= "=="
	then return;

	do while (lexeme_env.token.string ^= ".");

	     if (cr_used + 1) > cr_max
	     then do;

		     call T_alloc (addr (cr_control), "0"b);
		     cr_max = cr_cap / 3;
		end;
	     cr_used = cr_used + 1;

	     call pseudo_text ("L");

	     if lexeme_env.error = 1 | ^(lexeme_env.token.type = 3 & lexeme_env.token.string = "by")
	     then return;

	     call get_next_lexeme ("");

	     call pseudo_text ("R");

	end;

	call merge_to_copy;
	call replace_process;

	lexeme_env.indicators.copy_replace = "0"b;

     end process_replace_statement;

init:
     proc;

/*
				INITILIZATION
			*/

/*[5.1-2]*/
	if ecs_info_table_.command
	then char10 = "*******   ";
	else char10 = " ";

	next_new_position, last_source_offset = 1;
	last_copy_line, insert_space_span = 0;
	fill_last_ln = "0"b;
	replace_active = "0"b;

/*	Allocate Tables for Copy Replacement */

	call T_alloc (addr (cr_control), "1"b);
	cr_max = cr_cap / 3;

	call T_alloc (addr (lbw_control), "1"b);

	lbw_max = lbw_cap / 2;

	call T_alloc (addr (cs_control), "1"b);

	cs_max = cs_cap * 4;

	allocate lexeme_env in (expand_cobol_source_area) set (lexeme_ptr);

	call cobol_lexeme$open (lexeme_ptr);

	lexeme_env.ecs_ptr = expand_cobol_source_area_ptr;
	old_file_ptr = ecs_info_table_.input_ptr;
	new_file_ptr = ecs_info_table_.output_ptr;
	p1 = lexeme_ptr;

/*
				Make the old file known to cobol_lexeme.
			*/

	lexeme_ptr = p1;
	p1 -> lexeme_env.source_table.loc = old_file_ptr;
	lexeme_env.error = 0;

	call cobol_lexeme$set (p1, "file_name", old_file_ptr);

	if lexeme_env.error ^= 0
	then do;

		bc = (next_new_position - 1) * 9;
		call finish;

		return;
	     end;

     end init;

copy:
     entry (ecs_info_ptr, bc, command, expand_cobol_source_area_ptr);

	call init;

/*[4.0-4]*/
	last_char_nl = 0;

cpr_error:
	call clear_copy;

/*	Main	processing loop for copy replacing */

	do while ("1"b);

start:
	     lexeme_env.error = 0;
	     call cobol_lexeme$find_copy (lexeme_ptr);

	     if lexeme_env.error = 1			/* eof */
	     then do;

		     call merge_to_end;
		     bc = (next_new_position - 1) * 9;
		     call finish;
		     return;

		end;
	     else do;

		     save_copy_line = lexeme_env.token.line;
		     copy_line_length = lexeme_env.current_line.length;
		     save_copy_column = lexeme_env.token.column;
		     copy_line_ptr = lexeme_env.current_line.loc;
		     save_source_offset = lexeme_env.token.offset - 1;

		     call process_copy_statement;

		end;

	end;

process_copy_statement:
     proc;

	if lexeme_env.token.col_7 = "D" | lexeme_env.token.col_7 = "d"
	then return;


/*[4.0-3]*/
	state_pos = lexeme_env.token.offset;

	call get_lib_name;

/*
				get_lib_name returns with next word
			*/

	if lexeme_env.token.type = 3
	then if lexeme_env.token.string = "replacing"
	     then do;

/*
						We now have a COPY ... REPLACING statement to	process.
			
						Perform syntax on statement and generate tables.
			*/

		     lexeme_env.indicators.copy_replace = "1"b;
		     lexeme_env.pseudo_text = 1;
		     call rep_spec;

/*
						Merge the library file with the specified replacements.
			*/

		     if valid_lib
		     then call replace_process;
		     else goto cpr_error;

		end;

	     else goto cpr_error;

	else if lexeme_env.token.type = 4
	then if lexeme_env.token.string = "."
	     then do;

/*
					This is a simple COPY so merge the library and go back to start.
			*/

		     if valid_lib
		     then call merge_library;
		     else goto cpr_error;


		     return;

		end;

	     else goto cpr_error;

	else goto cpr_error;

     end process_copy_statement;

get_lib_name:
     proc;

/*
				Get copy file name without converting to lower case.
			*/

	lexeme_env.indicators.lc = "0"b;
	call get_next_lexeme ("");
	lexeme_env.indicators.lc = "1"b;

/*
				Save copy file name.
			*/

	lib_name = substr (word, 1, lexeme_env.token.string_size);

/*
				make library known to cobol_lexeme.
			*/

	allocate lexeme_env in (expand_cobol_source_area) set (lexeme_ptr);

	lexeme_env.ecs_ptr = expand_cobol_source_area_ptr;
	p2 = lexeme_ptr;
	p2 -> lexeme_env.error = 0;
	p2 -> lexeme_env.mem_tab_ptr = p1 -> lexeme_env.mem_tab_ptr;
	p2 -> lexeme_env.x_ptr = p1 -> lexeme_env.x_ptr;

	lexeme_ptr = p1;

/* 	call cobol_lexeme$reset(p1); */
/*
				Check for qualification of copy file name.
			*/

	call get_next_lexeme ("");

	if lexeme_env.token.string ^= "of" & lexeme_env.token.string ^= "in"
						/*[4.0-1]*/
	then qual_name = "";			/*[4.0-1]*/
	else do;

/*
				Get library name without converting to lower case.
			*/

		lexeme_env.indicators.lc = "0"b;

		call get_next_lexeme ("");

		lexeme_env.indicators.lc = "1"b;

/*[4.0-1]*/
		qual_name = substr (word, 1, lexeme_env.token.string_size);

/*[4.0-1]*/
	     end;

/*[4.0-1]*/
	call expand_cobol_source$find_incl_file /*[4.0-1]*/ (substr (lib_name, 1, length (lib_name)),
						/*[4.0-1]*/
	     substr (qual_name, 1, length (qual_name)),	/*[4.0-1]*/
	     old_file_ptr,				/*[4.0-1]*/
	     p2 -> lexeme_env.source_table.loc,		/*[4.0-1]*/
	     code /*[4.0-1]*/);


/*[4.0-1]*/
	call cobol_lexeme$envinit (p2);

/*[4.0-1]*/
	if code ^= 0
	then do;
		valid_lib = "0"b;			/*[4.0-1]*/
		free p2 -> lexeme_env;		/*[4.0-1]*/
	     end;					/*[4.0-1]*/
	else do;
		valid_lib = "1"b;			/*[4.0-1]*/
		lib_file_ptr = p2 -> lexeme_env.source_table.loc;
						/*[4.0-1]*/
	     end;

/*
				Call cobol_lexeme so when we return we will
				be looking at "REPLACING".
			*/

/*[4.0-1]*/
	if qual_name ^= ""
	then call get_next_lexeme ("");

     end get_lib_name;

rep_spec:
     proc;

/*
				Initialize text replacement control parameters.
			*/

	semi_sw, comma_sw = 0;
	cr_used, cr_largest = 0;
	comp_str_used = 1;


/*
				Get token after 'replacing'.
			*/

	call get_next_lexeme ("");

/*
				Main loop for	processing replacing specification.
			*/

	do while (lexeme_env.token.string ^= ".");

/*
			                    Check and see if tcr_table is full.
			*/

	     if (cr_used + 1) > cr_max
	     then do;

		     call T_alloc (addr (cr_control), "0"b);
		     cr_max = cr_cap / 3;
		end;

	     cr_used = cr_used + 1;

/*
			                    Process the left specitication and
			                      build the replacement table.
			*/

	     call left_spec;

/*
			                    Check for the word 'by'.
			*/

	     if lexeme_env.token.string ^= "by"
	     then do;

		     cr_used = cr_used - 1;
		     goto cpr_error;
		end;

	     call get_next_lexeme ("");

/*
			                    Scan off the word 'by' and
			                   	process the right specitication.
			*/

	     call right_spec;

/* put skip  edit ("key ->", substr(compare_string,comp_start(cr_used),comp_len(cr_used)),"<-") (a);  */

	end;					/* end of main loop */

	lexeme_env.indicators.copy_replace = "0"b;

     end rep_spec;

left_spec:
     proc;

/*	This routine calls substr_word with an indicator
				to	process the compare text
			*/

	call subst_word ("L");

     end left_spec;


right_spec:
     proc;

/*	This routine calls substr_word with an indicator
				to	process the replacement text
			*/

	call subst_word ("R");

     end right_spec;

subst_word:
     proc (mode);

dcl	mode		char (1);

/*
				This routines identifies
					==pseudo-text==
					identifier
					literal
					word
				and calls the appropiate subroutine for	process.
				On entry word contains the token.
			*/

	if substr (word, 1, lexeme_env.token.string_size) = "=="
						/* pseudo-text delimiter */
	then call pseudo_text (mode);
	else if token.type = 3			/* word*/
	then call ident (mode);
	else if token.type = 2
	then call literal (mode);
	else goto cpr_error;

     end subst_word;

pseudo_text:
     proc (mode);

dcl	mode		char (1);
dcl	c2		char (2);


	text_string = "";

	if mode = "R"
	then do;

		call cobol_lexeme$find_pseudo_text (lexeme_ptr);

		if lexeme_env.error = 1
		then goto cpr_error;

/*
					Save offset and span of replacement text.
			*/

		repl_offset (cr_used) = lexeme_env.token.offset;
		repl_span (cr_used) = lexeme_env.token.span;
	     end;

/*
				Process left specification pseudo-text.
			*/

	else do;

/*
					Scan past current '==' and get first token in psuedo-text.
			*/

		call get_next_lexeme ("text_word");

		if substr (word, 1, lexeme_env.token.string_size) = ","
		     | substr (word, 1, lexeme_env.token.string_size) = ";"
		then do;

/*
						Special	processing if comma or semi-colon.
			*/

			text_string = " " || substr (word, 1, lexeme_env.token.string_size);

			call get_next_lexeme ("");

			if substr (word, 1, lexeme_env.token.string_size) ^= "=="
			then text_string = "";

		     end;

		do while (substr (word, 1, lexeme_env.token.string_size) ^= "==");

		     text_string = text_string || " " || substr (word, 1, lexeme_env.token.string_size);
		     call get_next_lexeme ("");

/*[4.0-2]*/
		     if lexeme_env.error ^= 0
		     then go to cpr_error;

		end;

/*
					Insert pseudo-text into the compare_string
					and update the parameters in cr_table.
			*/

		text_string_length = length (text_string);
		comp_start (cr_used) = comp_str_used;

/*
					Check and see if text_string will fit into compare_string.
			*/

		do while ((text_string_length + comp_str_used) > cs_max);

		     call T_alloc (addr (cs_control), "0"b);
		     cs_max = cs_cap * 4;

		end;

		substr (compare_string, comp_str_used, text_string_length) = text_string;
		comp_len (cr_used) = text_string_length;
		comp_str_used = comp_str_used + text_string_length;

		if text_string_length > cr_largest
		then cr_largest = text_string_length;

/*
					Test and set an indicator if pseudo-text consists
					solely of a comma(,) or a semi-colon(;).
			*/

		if text_string_length = 2
		then do;

			c2 = substr (text_string, 1, 2);

			if c2 = " ;"
			then semi_sw = cr_used;
			else if c2 = " ,"
			then comma_sw = cr_used;

		     end;

	     end;

/*
				Position to 'by or '.' on return.
			*/

	call get_next_lexeme ("");

	return;

     end pseudo_text;

ident:
     proc (mode);

dcl	mode		char (1);
dcl	replacement_span	fixed bin;

/*	If this is the right specification save the offset of the source
				for replacement. */


	if mode = "R"
	then do;

		repl_offset (cr_used) = token.offset;
		replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span;
	     end;

	else do;

		text_string = "";
		text_string = text_string || " " || substr (word, 1, string_size);
	     end;

	call get_next_lexeme ("");

/*
				Continue to scan and build text_string string as long
				as the identifier is qualified with an "of" or "in".
			*/

	do while (substr (word, 1, lexeme_env.token.string_size) = "in"
	     | substr (word, 1, lexeme_env.token.string_size) = "of");

	     if mode = "R"
	     then replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span;
	     else text_string = text_string || " " || substr (word, 1, lexeme_env.token.string_size);

	     call get_next_lexeme ("");

	     if token.type ^= 3			/* type 3 = word */
	     then do;
		     call copy_error (1);

		     cr_used = cr_used - 1;
		     goto cpr_error;
		end;

	     if mode = "R"
	     then replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span;
	     else text_string = text_string || " " || substr (word, 1, lexeme_env.token.string_size);

	     call get_next_lexeme ("");

	end;

/*
				Check and see if the identifier is subscripted.  If it is
				scan until a right paren ")" is found saving the tokens
				in text_string string;
			*/


	if substr (word, 1, lexeme_env.token.string_size) = "("
	then do;

		if mode = "R"
		then replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span;
		else text_string = text_string || " (";

		call get_next_lexeme ("");

		do while (substr (word, 1, lexeme_env.token.string_size) ^= ")");

		     if mode = "R"
		     then replacement_span =
			     (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span;
		     else text_string = text_string || " " || substr (word, 1, lexeme_env.token.string_size);

		     call get_next_lexeme ("");

		     if string = "by" | string = "copy" | string = "."
		     then do;

			     call copy_error (5);
			     goto cpr_error;

			end;
		end;

		if mode = "R"
		then replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span;
		else text_string = text_string || " )";

		call get_next_lexeme ("");
	     end;


/*	If identifier is from right specification save the span in the source file.
				If the identifier is from the left specification insert the identifier into
				the compare string and make the entries is the cr_table for it.
			*/


	if mode = "R"
	then repl_span (cr_used) = replacement_span;
	else do;
		comp_start (cr_used) = comp_str_used;
		text_string_length = length (text_string);
		comp_len (cr_used) = text_string_length;


/*		Check and see if text_string will fit into compare_string */


		do while ((text_string_length + comp_str_used) > cs_max);

		     call T_alloc (addr (cs_control), "0"b);
		     cs_max = cs_cap * 4;
		end;

		substr (compare_string, comp_str_used, text_string_length) = text_string;
		comp_str_used = comp_str_used + text_string_length;

/*
				          Check and update cr_largest if necessary.
			*/

		if text_string_length > cr_largest
		then cr_largest = text_string_length;
	     end;

     end ident;

literal:
     proc (mode);

dcl	mode		char (1);

	if mode = "R"				/*
			          Process the left specification:  Save the offset and the
			          span of the replacement text from the source file.
			*/
	then do;
		repl_offset (cr_used) = lexeme_env.token.offset;
		repl_span (cr_used) = lexeme_env.token.span;
	     end;

/*
			          Process the right specification: insert the
			          literal into the compare_string and update the
			          cr_table parameters.
			*/

	else do;

		comp_start (cr_used) = comp_str_used;
		comp_len (cr_used) = lexeme_env.token.string_size + 1;
						/*
					Check and see if literal will fit into compare_string.
			*/
		do while ((comp_len (cr_used) + comp_str_used) > cs_max);

		     call T_alloc (addr (cs_control), "0"b);
		     cs_max = cs_cap * 4;
		end;

		substr (compare_string, comp_str_used, lexeme_env.token.string_size + 1) =
		     " " || substr (word, 1, lexeme_env.token.string_size);
		comp_str_used = comp_str_used + lexeme_env.token.string_size + 1;

		if (lexeme_env.token.string_size + 1) > cr_largest
		then cr_largest = (token.string_size + 1);
	     end;

/*
			          Call cobol_lexeme to position to the next word on return.
			*/

	call get_next_lexeme ("");

     end literal;

merge_library:
     proc;

/*
				Copy the old source into the new source up to the copy statement.
			*/

	call merge_to_copy;

	span = p2 -> lexeme_env.source_table.size;
	substr (new_file, next_new_position, span) = substr (lib_file, 1, span);


	next_new_position = next_new_position + span;

     end merge_library;


merge_to_end:
     proc;

/*
				Check and see in any remaining text was on the last copy line.
			*/

	if fill_last_ln
	then do;

		substr (new_file, next_new_position, insert_space_span) = substr (spaces, 1, insert_space_span);
		next_new_position = next_new_position + insert_space_span;
	     end;

	span = p1 -> lexeme_env.source_table.size - last_source_offset + 1;


	substr (new_file, next_new_position, span) = substr (old_file, last_source_offset, span);
	next_new_position = next_new_position + span;

     end merge_to_end;

merge_to_copy:
     proc;

/*
				Check and see if wee have to preserve  the column position of remaining
				text on a line with a copy statement.
			*/

/*[4.0-3]*/
	state_span = lexeme_env.token.offset - state_pos + 1;

	if (last_copy_line = lexeme_env.token.line) | fill_last_ln
	then do;
		span = save_source_offset - last_source_offset + 1;

		if substr (old_file, last_source_offset, span) ^= substr (spaces, 1, span)
		then do;
			substr (new_file, next_new_position, insert_space_span) =
			     substr (spaces, 1, insert_space_span);

			next_new_position = next_new_position + insert_space_span;
			if fill_last_ln
			then fill_last_ln = "0"b;

		     end;
	     end;					/*
				Is the copy the first word on the current line?
			*/

	if substr (source_line, 8, save_copy_column - 8) = substr (spaces, 1, save_copy_column - 8)
	then fill_sw = "0"b;
	else fill_sw = "1"b;

/*
				Do we want to include the beginning of the line
				to the copy.
			*/

	if fill_sw
	then span = save_source_offset - last_source_offset;
	else span = (save_source_offset - last_source_offset) - (save_copy_column - 2);

	if span > 0
	then do;


		substr (new_file, next_new_position, span) = substr (old_file, last_source_offset, span);
		next_new_position = next_new_position + span;

		if fill_sw
		then do;

			substr (new_file, next_new_position, 1) = new_line_character;
			next_new_position = next_new_position + 1;

		     end;

	     end;

	if lexeme_env.token.column < (lexeme_env.current_line.length - 1)
	then do;
		;

		last_source_offset = lexeme_env.token.offset + 1;
		fill_last_ln = "1"b;
	     end;
	else do;

		fill_last_ln = "0"b;
		last_source_offset = lexeme_env.token.offset + 2;
	     end;

	last_copy_line = lexeme_env.token.line;
	insert_space_span = lexeme_env.token.column;

/*[4.0-4]*/
	if ecs_info_table_.format_indicator
	then return;

/*[4.0-3]*/
	substr (new_file, next_new_position, state_span + 11) =
	     /* emit the statement */ /*[5.1-2]*/ char10 || substr (old_file, state_pos, state_span) || "
";

/*[4.0-3]*/
	STR_PTR = addr (new_array (next_new_position));	/*[4.0-3]*/
	SIZE = state_span + 11;

/*[4.0-3]*/
	do while ("1"b);

/*[4.0-3]*/
	     CR_LOC = index (STR, "
");

/*[4.0-3]*/
	     if CR_LOC = SIZE
	     then go to MC;

/*[4.0-3]*/
	     STR_PTR = addr (STR_ARRAY (CR_LOC + 1));	/*[4.0-3]*/
	     SIZE = SIZE - CR_LOC;			/*[5.1-2]*/
	     if ecs_info_table_.command
	     then substr (STR, 1, 7) = "*******";	/*[4.0-3]*/
	end;

MC:						/*[4.0-3]*/
	next_new_position = next_new_position + state_span + 11;



     end merge_to_copy;

T_alloc:
     proc (TT_ptr, first_time);

declare	1 TT_a		based (TT_ptr),
	  2 loc		ptr,
	  2 parity	fixed bin,
	  2 cap		fixed bin,
	  2 incr		fixed bin;

dcl	TT_0		(TABLE_SIZE) aligned fixed bin (35) based (TABLE_PTR);
dcl	TT_1		(TABLE_SIZE) aligned fixed bin (35) based (TABLE_PTR);
dcl	TABLE_SIZE	fixed bin;
dcl	(TT_ptr, TABLE_PTR) ptr;
dcl	first_time	bit (1);

	TABLE_SIZE = TT_a.cap + TT_a.incr;

	if TT_a.parity = 0
	then do;
		allocate TT_1 in (expand_cobol_source_area) set (TABLE_PTR);

		if ^first_time
		then do;
			do i = 1 to TT_a.cap;
			     TT_1 (i) = TT_0 (i);
			end;
			TT_a.loc = TABLE_PTR;
			free TT_0;
		     end;
		else TT_a.loc = TABLE_PTR;

		TT_a.parity = 1;

	     end;
	else do;
		allocate TT_0 in (expand_cobol_source_area) set (TABLE_PTR);

		if ^first_time
		then do;
			do i = 1 to TT_a.cap;
			     TT_0 (i) = TT_1 (i);
			end;
			TT_a.loc = TABLE_PTR;
			free TT_1;
		     end;
		else TT_a.loc = TABLE_PTR;

		TT_a.parity = 0;

	     end;

	TT_a.cap = TABLE_SIZE;
     end T_alloc;

T_free:
     proc (TT_ptr);

dcl	1 TT_a		based (TT_ptr),
	  2 loc		ptr,
	  2 parity	fixed bin,
	  2 cap		fixed bin,
	  2 incr		fixed bin;

dcl	TT_0		(TT_a.cap) aligned fixed bin (35) based (TT_a.loc);
dcl	TT_1		(TT_a.cap) aligned fixed bin (35) based (TT_a.loc);
dcl	TT_ptr		ptr;

	if TT_a.parity = 0
	then free TT_0;
	else free TT_1;

     end T_free;

clear_copy:
     proc;

	cr_used = 0;
	comp_str_used = 1;

	do i = 1 to cr_max;
	     cr_table (i) = 0;
	end;

	do i = 1 to cs_max;
	     substr (compare_string, i, 1) = " ";
	end;

     end clear_copy;

finish:
     proc;

	lexeme_ptr = p1;
	free lexeme_env;

	call cobol_lexeme$close (p1);
	call T_free (addr (cs_control));
	call T_free (addr (cr_control));
	call T_free (addr (lbw_control));

     end finish;

get_next_lexeme:
     proc (entry);

dcl	entry		char (9);

	if entry = "token"
	then call cobol_lexeme$token (lexeme_ptr);
	else if entry = "text_word"
	then call cobol_lexeme$text_word (lexeme_ptr);
	else call cobol_lexeme$cobol_lexeme (lexeme_ptr);

	if lexeme_env.error > 1
	then if ^replace_active
	     then goto cpr_error;
	     else goto replace_err;

     end get_next_lexeme;

replace_process:
     proc;

dcl	library_string	char (cr_largest);

/*
				Copy the old source into the new source up to the copy statement.
			*/

	if ^replace_active
	then do;

		call merge_to_copy;

/*
				          Make library file known to cobol lexeme.
			*/

		lexeme_ptr = p2;
	     end;

/*
				Initialize the replacemnt parameters and get the first library word.
			*/

	lbs_length, lbs_sum, lbw_used = 0;
	lbs_size = cr_largest;
	library_string = spaces;
	base_offset = 1;

	call build_library_string;

	read_more_text = "1"b;

	do while (read_more_text);			/* end of file indicator */

	     matched_word_pos, spec_index = 0;

	     call compare_text;			/*
					If matched_word_pos returns greater than zero it
					will point to the first word matched in the
					library_string and spec_index will be the
					index to the specification in cr_table.
			*/
						/* put skip  edit (matched_word_pos,"->",library_string,"<-") (f(4),x(2),3 a);   */

	     if matched_word_pos > 0
	     then call replace_text;

	     call build_library_string;

	end;					/* do while not end of file */

	if replace_active
	then do;

		replace_active = "0"b;
		goto next_replace;

	     end;

/*
				The remaining library text from the last replacement
				to the end of the segment must also be moved to the new source.
			*/

	move_span = (p2 -> lexeme_env.source_table.size - base_offset) + 1;

/*
			          Size contains the offset of the last character in the
			          library file.  Plus one is used to get the NL character.
			*/

	substr (new_file, next_new_position, move_span) = substr (lib_file, base_offset, move_span);
	next_new_position = next_new_position + move_span;

/*
			          Reset lexeme_ptr so cobol_lexeme will
			          get tokens from the source file.
			*/
	free lexeme_env;
	lexeme_ptr = p1;

/*
				Reset cr_table and clear compare_string.
			*/
	call clear_copy;

build_library_string:
     proc;

dcl	chr		char (1);

read_next_word:
	call cobol_lexeme$text_word (lexeme_ptr);

	if lexeme_env.error = 1 | (replace_active & lexeme_env.token.type = 3 & lexeme_env.token.string = "replace")
	then do;

		library_string = spaces;
		lbw_table (*), lbs_length, lbs_sum = 0;
		read_more_text = "0"b;

		return;

	     end;

/*	Is library word greater than largest compare search key
				if so no checking is needed and the words in the library
				string can be cleared */

	word_length = lexeme_env.token.string_size;

	if (word_length + 1) > cr_largest
	then do;

		do j = 1 to lbw_max;
		     lbw_table (j) = 0;
		end;

		lbw_used, lbs_length = 0;
		library_string = spaces;
		goto read_next_word;

	     end;

/*	check for special	processing for comma and semi */




	if word_length = 1
	then do;

		chr = substr (word, 1, 1);

		if (chr = "," & comma_sw < 1) | (chr = ";" & semi_sw < 1)
		then goto read_next_word;
	     end;

/*
			          The library word will be used for comparision.
			          Insert it into the library_string and update lbw_table.
			*/

	if lbw_used + 1 > lbw_max			/*
			                   The Library Word Table is new full, allocate more space .
			*/
	then do;

		call T_alloc (addr (lbw_control), "0"b);
		lbw_max = lbw_cap / 2;
	     end;

	lbw_used = lbw_used + 1;
	lbw_length (lbw_used) = lexeme_env.token.string_size + 1;
	lbw_offset (lbw_used) = token.offset;
	lbw_span (lbw_used) = token.span;
	substr (aword, 1, 1) = " ";
	substr (aword, 2, word_length) = substr (word, 1, word_length);
	word_length = word_length + 1;

/*
			          If the word will not fit into the library_string remove the
			          oldest word from the left.  Shift the remainging words to the
			          lift to make rome for the new word and insert the new word.
			*/

	do while (lbs_length + word_length > lbs_size);

	     lbs_sum = 0;

	     do j = 1 to (lbw_used - 1);
		lbs_sum = lbs_sum + lbw_length (j);
	     end;

	     lbs_sum = lbs_size - lbs_sum;

/*
		                    lbs_sum is now the size of the remaining space in the library_string
		*/

	     if lbs_sum < word_length			/*
			                               The space abailable in library_string is less
			                                than the length of the word.  Remove a word from
			                                  library-string
			*/
	     then do;

		     substr (library_string, lbs_sum + 1, lbw_length (1)) = substr (spaces, 1, lbw_length (1));
		     lbs_length = lbs_length - lbw_length (1);

		     do j = 1 to (lbw_used - 1);

			lbw_table (j) = lbw_table (j + 1);
		     end;

		     lbw_used = lbw_used - 1;

		end;				/* removing word from library_string */

	end;					/* do while */

/*
			                     Now we shift the library_string to the left
			                      to make room for the new word
			*/

	substr (library_string, 1, lbs_size) = substr (library_string, 1 + word_length, lbs_size - word_length);

/*
			                     Insert word in library_string
			*/

	lbs_length = lbs_length + word_length;
	substr (library_string, lbs_size + 1 - word_length, word_length) = substr (aword, 1, word_length);

     end build_library_string;





compare_text:
     proc;

dcl	ii		fixed bin;

	ii = 1;

start_compare:
	matched_word_pos = 0;

	do i = ii to cr_used while (matched_word_pos = 0);

	     spec_index = i;

	     if comp_len (spec_index) <= lbs_length
	     then matched_word_pos =
		     index (library_string, substr (compare_string, comp_start (spec_index), comp_len (spec_index)));
	end;					/*
				if matched_word_pos is greater than zero it
				points to the first word matched in the
				library_string.  The word matched in the
				library_string should be right justified.
				A check is made to see and if it is not
				the rest of the compare keys if any are used.
			*/

	if matched_word_pos > 0
	then if (cr_largest - matched_word_pos + 1) ^= comp_len (spec_index)
	     then do;
		     ii = i;
		     goto start_compare;
		end;

     end compare_text;


replace_text:
     proc;


/*	Locate the starting word of the matched phrase
				from the library_string.
			*/

	lbs_sum = lbs_size - lbs_length;		/* starting position of first word */
	i = 0;

	do j = 1 to lbw_used while (lbs_sum < matched_word_pos);

	     i = j;
	     lbs_sum = lbs_sum + lbw_length (i);
	end;

/*
				Move the library source from the last replacement to
				the current replacement to the new source
			*/

/* put skip edit ("REP ->", substr(old_file,repl_offset(spec_index),repl_span(spec_index)),"<-") (a);  */

	if replace_active
	then do;

		move_span = lbw_offset (i) - last_source_offset;
		substr (new_file, next_new_position, move_span) = substr (old_file, last_source_offset, move_span);

	     end;
	else do;

		move_span = lbw_offset (i) - base_offset;
		substr (new_file, next_new_position, move_span) = substr (lib_file, base_offset, move_span);

	     end;

/*
			Insert the replacement text from the source file
		*/

	next_new_position = next_new_position + move_span;
	substr (new_file, next_new_position, repl_span (spec_index)) =
	     substr (old_file, repl_offset (spec_index), repl_span (spec_index));

/*
				Update next_new_position and base_offset for next time
			*/

	next_new_position = next_new_position + repl_span (spec_index);

	if replace_active
	then last_source_offset = lbw_offset (i) + lbw_span (i);
	else base_offset = lbw_offset (lbw_used) + lbw_span (lbw_used);

/*
				Clear library string and library word table
			*/

	library_string = spaces;

	do i = 1 to lbw_max;
	     lbw_table (i) = 0;
	end;

	lbw_used, lbs_length = 0;

     end replace_text;


     end replace_process;








copy_error:
     proc (error_no);

dcl	error_no		fixed bin;
dcl	error_msg		(6) char (40)
			init ("A COBOL word is expected here", "End of text during error recovery",
			"The word BY is expected here", "Null or blank pseudo-text illegal",
			"Unmatched left parenthesis", "Error in finding include file");
dcl	source_line	char (current_line.length) based (current_line.loc);

	call ioa_ ("cobol: COPY REPLACING... ^a on line ^d.", error_msg (error_no), lexeme_env.token.line);

     end copy_error;

/* STRUCTURE */

dcl	01 ecs_info_table	aligned automatic structure like ecs_info_table_;

/* BUILTIN */

dcl	substr		builtin;
dcl	length		builtin;
dcl	addr		builtin;
dcl	index		builtin;


/* CHARACTER */

dcl	text_string	char (256) varying;
dcl	(lib_name, qual_name)
			char (128) varying;		/*[4.0-1]*/
dcl	source_line	char (copy_line_length) based (copy_line_ptr);
dcl	word		char (32) based (lexeme_env.token.string_ptr);
dcl	aword		char (265);
dcl	spaces		char (254) init ((254)" ");
dcl	old_file		char (1048576) based (old_file_ptr);
dcl	new_file		char (1048576) based (new_file_ptr);
						/*[4.0-3]*/
dcl	new_array		(1048576) char (1) based (new_file_ptr);
						/*[4.0-3]*/
dcl	STR		char (SIZE) based (STR_PTR);	/*[4.0-3]*/
dcl	STR_ARRAY		(SIZE) char (1) based (STR_PTR);

/*[5.1-2]*/
dcl	char10		char (10);
dcl	lib_file		char (1048576) based (lib_file_ptr);
dcl	new_line_character	char (1) init ("
");


/* POINTERS */

dcl	expand_cobol_source_area_ptr
			ptr;
dcl	lexeme_ptr	ptr;
dcl	old_file_ptr	ptr;
dcl	new_file_ptr	ptr;
dcl	lib_file_ptr	ptr;
dcl	(p1, p2)		ptr;
dcl	copy_line_ptr	ptr;

/* BIT */

dcl	read_more_text	bit (1);
dcl	replace_active	bit (1);
dcl	command		bit (1);
dcl	fill_sw		bit (1);
dcl	fill_last_ln	bit (1);
dcl	valid_lib		bit (1);

/* ENTRIES */

dcl	ioa_		entry options (variable);
dcl	expand_cobol_source$find_incl_file
			entry (char (*), char (*), ptr, ptr, fixed bin (35));
						/*[4.0-1]*/
dcl	cobol_lexeme$envinit
			entry (ptr);		/*[4.0-1]*/


/* AREA */

dcl	expand_cobol_source_area
			area based (expand_cobol_source_area_ptr);
						/* FIXED BINARY */

dcl	bc		fixed bin (24);
dcl	save_copy_line	fixed bin;
dcl	copy_line_length	fixed bin;
dcl	next_new_position	fixed bin (35);
dcl	cr_used		fixed bin;
dcl	cr_largest	fixed bin;
dcl	comma_sw		fixed bin;
dcl	semi_sw		fixed bin;		/* 550 */
dcl	(span, last_char_nl)
			fixed bin (24);
dcl	(i, j)		fixed bin;
dcl	comp_str_used	fixed bin init (1);
dcl	text_string_length	fixed bin;
dcl	cr_max		fixed bin;
dcl	lbw_max		fixed bin;
dcl	lbw_used		fixed bin;
dcl	cs_max		fixed bin;
dcl	code		fixed bin (35);		/*[4.0-1]*/
dcl	last_copy_line	fixed bin;
dcl	insert_space_span	fixed bin;
dcl	save_copy_column	fixed bin;
dcl	save_source_offset	fixed bin;
dcl	last_source_offset	fixed bin (35);
dcl	base_offset	fixed bin;
dcl	lbs_size		fixed bin;
dcl	lbs_length	fixed bin;
dcl	lbs_sum		fixed bin;
dcl	word_length	fixed bin;
dcl	move_span		fixed bin;
dcl	matched_word_pos	fixed bin;
dcl	spec_index	fixed bin;		/*[4.0-3]*/
dcl	(state_span, state_pos, SIZE, CR_LOC)
			fixed bin,
	STR_PTR		ptr;

/*

*/


/* Compare String */

dcl	compare_string	char (cs_max) aligned based (cs_ptr);

dcl /* Copy Replaceing Table */
	1 cr_table	(cr_max) aligned based (cr_ptr),
	  2 comp_start	unaligned fixed bin,	/* begin char pos in compare string */
	  2 comp_len	unaligned fixed bin,	/* length of compare key in string */
	  2 repl_offset	unaligned fixed bin (35),	/* offset of replacement text in source */
	  2 repl_span	unaligned fixed bin (35);	/* span of replacement text in source */


dcl /* Library Word Table */
	1 lbw_table	(lbw_max) aligned based (lbw_ptr),
	  2 lbw_length	unaligned fixed bin,	/* length of word */
	  2 lbw_offset	unaligned fixed bin (35),	/* offset of word in library */
	  2 lbw_span	unaligned fixed bin;	/* span of word in library */


dcl /* Control table for compare string */
	1 cs_control,
	  2 cs_ptr	ptr,
	  2 cs_parity	fixed bin init (1),
	  2 cs_cap	fixed bin init (100),	/* 400 bytes */
	  2 cs_incr	fixed bin init (10);	/* increase by 40 bytes */

dcl /* Control table for library word table */
	1 lbw_control,
	  2 lbw_ptr	ptr,
	  2 lbw_parity	fixed bin init (1),
	  2 lbw_cap	fixed bin init (40),	/* room for 25 library words */
	  2 lbw_incr	fixed bin init (10);	/* add space for 5 more library words */

dcl /* Control Table for Copy Replaceing Table */
	1 cr_control,
	  2 cr_ptr	ptr,
	  2 cr_parity	fixed bin initial (1),
	  2 cr_cap	fixed bin initial (60),	/* room for 25 entries in cr_table */
	  2 cr_incr	fixed bin initial (15);	/* increase cr_table by 5 entries */
						/*

*/
%include cobol_lexeme_env;
%include cobol_ecs_info;
     end cobol_expand_source_;




		    cobol_lexeme.pl1                05/24/89  1048.6rew 05/24/89  0836.9      327510



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



/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8089),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8089 cobol_lexeme.pl1 Remove requirement for write permission to input
     files.
                                                   END HISTORY COMMENTS */


/* Modified on 12/20/84 by FCH, [5.3-2], source prog with r access caused abort */
/* Modified on 10/24/83 by FCH, [5.3-1], ignore COPY in ID, phx14180(BUG599) */
/* Modified on 02/26/79 by FCH, [4.0-1], qualified copy file names */
/* Created for Version 4.0 */






/* format: style3 */
cobol_lexeme:
     proc (lexeme_ptr);

declare	lexeme_ptr	ptr;

dcl	(addr, fixed, index, null, substr, translate, unspec)
			builtin;

declare	hcs_$fs_get_path_name
			entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
declare	hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
declare	hcs_$set_bc_seg	entry (ptr, fixed bin (24), fixed bin (35));

declare	(env_ptr, s_ptr)	ptr,
	sname		char (*);
declare	bc		fixed bin (24),
	code		fixed bin (35);
declare	lc		fixed bin;
declare	ch		char (1),
	ch2		char (2),
	ch_val		fixed bin;
declare	key_word		char (32) varying;
declare	saved_offset	fixed bin (35);
declare	(cont, new_line, more, scan_mode)
			bit (1);
declare	(res, dec_pt_count, sign_count)
			fixed bin,
	mask		bit (8);
declare	(i, j)		fixed bin,
	p		ptr;
declare	file_name		char (44);
declare	(old, new, size, tok_size)
			fixed bin;
declare	dir_name		char (168),
	entry_name	char (32);
declare	(e_offset, e_span)	fixed bin (35);

declare	1 b,
	  2 line		fixed bin,
	  2 column	fixed bin,
	  2 type		fixed bin,
	  2 offset	fixed bin (35),
	  2 span		fixed bin,
	  2 string_size	fixed bin (35),
	  2 string_cap	fixed bin,
	  2 string_ptr	ptr,
	  2 string	char (32) varying,
	  2 col_7		char (1);

declare	ldn		fixed bin;
declare	last_token_space	bit (1);

declare	error_table_$zero_length_seg
			fixed bin (35) ext;
declare	error_table_$segknown
			fixed bin (35) ext;

declare	ss		char (1000000) based;
declare	sa		(1000000) char (1) based;
declare	bit9		bit (9) based;

dcl	alloc_1		char (lexeme_env.alloc.cap1) based (lexeme_env.alloc.ptr1);
dcl	alloc_2		char (lexeme_env.alloc.cap2) based (lexeme_env.alloc.ptr2);


declare	mem_tab		(0:511) bit (8) based (mem_tab_ptr);
declare	x		(0:511) fixed bin (8) based (x_ptr);

declare	expand_cobol_source_area
			area based (ecs_ptr);

declare	find_include_file_$initiate_count
			entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35));

/*
					ignore space tokens, separator comma and
					separator semi-colon
				*/

	call get_token;

	ch = lexeme_env.token.string_ptr -> sa (1);

	do while (lexeme_env.error = 0
	     & (lexeme_env.token.type = 1
	     | (lexeme_env.token.type = 4 & lexeme_env.token.string_size = 1 & (ch = ";" | ch = ","))));

	     call get_token;

	     ch = lexeme_env.token.string_ptr -> sa (1);

	end;

	return;					/*
					initiate usage of cobol_lexeme.pl1
				*/
open:
     entry (lexeme_ptr);

	allocate mem_tab in (expand_cobol_source_area);

	do i = 0 by 1 to 127;
	     mem_tab (i) = m_t (i);
	end;

	do i = 128 by 1 to 511;
	     mem_tab (i) = "0"b;
	end;

	allocate x in (expand_cobol_source_area);

	do i = 0 by 1 to 127;
	     x (i) = x_i (i);
	end;

	do i = 128 by 1 to 511;
	     x (i) = 10;
	end;

/*5.3-1]*/
	state = 1;
	tf = "0"b;

	return;					/*
					terminate usage of cobol_lexeme.pl1
				*/
close:
     entry (lexeme_ptr);

	free mem_tab;
	free x;


	return;

/*
					initialize scanning of source file
				*/

envinit:
     entry (lexeme_ptr);

/*[4.0-1]*/
	call set_bc (lexeme_env.source_table.loc);	/*[4.0-1]*/
	return;

set:
     entry (lexeme_ptr, sname, s_ptr);

	file_name = sname;
	i = 44;

	do while (i > 0 & substr (file_name, i, 1) = " ");

	     i = i - 1;

	end;

	if i > 11
	then if substr (file_name, i - 10, 11) = ".incl.cobol"
	     then do;
		     call find_include_file_$initiate_count ("cobol", s_ptr, sname, bc, lexeme_env.source_table.loc,
			code);

		     if code = error_table_$zero_length_seg
		     then lexeme_env.error = 2;
		     else call env_set;

		     return;
		end;

	lexeme_env.source_table.loc = s_ptr;


/*[4.0-1]*/
	call set_bc (lexeme_env.source_table.loc);	/*[4.0-1]*/
	return;

set_bc:
     proc (p);					/*[4.0-1]*/
dcl	p		ptr;

	call hcs_$fs_get_path_name (p, dir_name, ldn, entry_name, code);
	call hcs_$initiate_count (dir_name, entry_name, "", bc, 1, p, code);

	if code = error_table_$segknown
	then code = 0;

	call env_set;

/*[4.0-1]*/
     end;

env_set:
     proc;					/*[4.0-1]*/
dcl	ch		char (1),
	p		ptr;


/*[4.0-1]*/
	if code = 0				/*[4.0-1]*/
	then do;
		i, j = divide (bc, 9, 31, 0);		/*[4.0-1]*/
		p = lexeme_env.source_table.loc;	/*[4.0-1]*/
		ch = p -> sa (j);

/*[4.0-1]*/
		do while (ch ^= "
");

/*[4.0-1]*/
		     j = j - 1;			/*[4.0-1]*/
		     ch = p -> sa (j);

/*[4.0-1]*/
		end;

/*[4.0-1]*/
		call hcs_$set_bc_seg (p, j * 9, code);

/*[5.3-2]*/
		call env_init;			/*[5.3-2]*/
		return;

/*[4.0-1]*/
	     end;


/*[4.0-1]*/
	lexeme_env.error = 2;

     end;

env_init:
     proc;

	lexeme_env.source_table.offset = 1;
	lexeme_env.source_table.line = 0;
	lexeme_env.current_line.loc = null ();
	lexeme_env.next_line.loc = null ();
	addr (lexeme_env.indicators) -> bit9 = "01"b;

	lexeme_env.alloc.cap1 = 512;			/*[4.0-1]*/
	lexeme_env.alloc.parity = 0;

	allocate alloc_1 in (expand_cobol_source_area);

	lexeme_env.token.string_cap = 512;
	lexeme_env.token.string_ptr = lexeme_env.alloc.ptr1;
	lexeme_env.source_table.size = j;

	call get_line;

     end;

find_copy:
     entry (lexeme_ptr);

	key_word = "copy";

	call seek_word;

	return;					/* scan to the word "replace" */

find_replace:
     entry (lexeme_ptr);				/* scan to the word "copy" */


	key_word = "replace";

	call seek_word;

	return;

/* scan to closing pseudo-text delimiter */

find_pseudo_text:
     entry (lexeme_ptr);

	lexeme_env.pseudo_text = 2;

	call get_token;

	if lexeme_env.error ^= 0
	then return;

	if lexeme_env.token.type = 4
	then do;
		if lexeme_env.token.string = "=="
		then do;
			lexeme_env.token.span = 0;
			return;
		     end;
	     end;
	else if lexeme_env.token.type = 1		/* space token */
	then do;
		lexeme_env.token.type = 6;
		b = lexeme_env.token;

		call get_token;

		if lexeme_env.error ^= 0
		then return;

		if lexeme_env.token.type = 4
		then if lexeme_env.token.string = "=="
		     then do;
			     lexeme_env.token = b;
			     return;
			end;
	     end;

	lexeme_env.token.type = 6;
	b = lexeme_env.token;

	do while ("1"b);

	     call get_token;

	     if lexeme_env.error ^= 0
	     then go to fpt_1;

	     e_offset = lexeme_env.token.offset;

	     if lexeme_env.token.type = 1
	     then do;
		     call get_token;

		     if lexeme_env.error ^= 0
		     then go to fpt_1;

		end;

	     if lexeme_env.token.type = 4
	     then if lexeme_env.token.string = "=="
		then go to fpt_2;
	end;

fpt_1:
	lexeme_env.token = b;
	return;

fpt_2:
	lexeme_env.token = b;
	lexeme_env.token.span = e_offset - b.offset;
	lexeme_env.pseudo_text = 1;

	return;

/* ignore space tokens */

text_word:
     entry (lexeme_ptr);

	call get_token;

	do while (lexeme_env.error = 0 & lexeme_env.token.type = 1);

	     call get_token;

	end;

	return;

/*
					find the next token
				*/

token:
     entry (lexeme_ptr);

	call get_token;

	return;

get_token:
     proc;

	if lexeme_env.current_line.length = 0
	then do;
		lexeme_env.error = 1;
		res = 1;
	     end;

	else do;

		lexeme_env.error = 0;


		dec_pt_count, sign_count = 0;
		lexeme_env.token.line = lexeme_env.source_table.line;
		lexeme_env.token.column = lexeme_env.current_line.column;
		lexeme_env.token.offset = lexeme_env.current_line.offset + lexeme_env.current_line.column - 1;
		lexeme_env.token.span, lexeme_env.token.string_size = 0;

		if lexeme_env.current_line.size >= 7
		then lexeme_env.token.col_7 = lexeme_env.current_line.loc -> sa (7);

		if lexeme_env.current_line.column < 8
		then do;
			lexeme_env.token.type = 1;

			if lexeme_env.current_line.length < 8
			then do;
				lexeme_env.token.span =
				     lexeme_env.current_line.length - lexeme_env.current_line.column;
				lexeme_env.current_line.column = lexeme_env.current_line.length;
			     end;
			else do;
				lexeme_env.token.span = 8 - lexeme_env.current_line.column;
				lexeme_env.current_line.column = 8;
			     end;

			call space;
			res = 1;
		     end;
		else do;

			ch = lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column);

			if ch = " " | ch = "
"
			then do;
				lexeme_env.token.type = 1;

				call space;

				res = 1;
			     end;
			else res = 2;

		     end;

	     end;

	go to st (res);

st (1):
	return;

st (2):
	go to l (x (fixed (unspec (ch), 15)));


/*
					cobol word
				*/

l (1):
	lexeme_env.token.type = 3;
word:
	mask = "1"b;

	call swm;

	call look;

	go to w (res);

w (1):
wd_1:
	if lexeme_env.token.string_ptr -> sa (lexeme_env.token.string_size) = "-"
	then lexeme_env.token.type = 5;

	if lexeme_env.indicators.lc
	then substr (lexeme_env.token.string_ptr -> ss, 1, lexeme_env.token.string_size) =
		translate (substr (lexeme_env.token.string_ptr -> ss, 1, lexeme_env.token.string_size),
		lower_case_alphabet);

ss1:
	if lexeme_env.token.string_size <= 32
	then lexeme_env.token.string = substr (lexeme_env.token.string_ptr -> ss, 1, lexeme_env.token.string_size);


	return;

w (2):
	if lexeme_env.current_line.column + 1 < lexeme_env.current_line.length
	then if substr (lexeme_env.current_line.loc -> ss, lexeme_env.current_line.column + 1, 2) = "=="
	     then go to wd_1;

	go to comm;
w (3):
	go to comm;


/*
					numeric literal
				*/

l (2):
	lexeme_env.token.type = 2;

num_lit:
	mask = "01"b;

	call swm;

	call look;

	go to nl1 (res);

nl1 (1):
	return;
nl1 (2):
	if dec_pt_count > 0
	then go to comm;

	if ch = ";"
	then go to comm;

	call move_char;

	dec_pt_count = 1;

	go to num_lit;

nl1 (3):
	if ch = "-" | ("1"b & mem_tab (fixed (unspec (ch), 15)))
	then if dec_pt_count = 0 & sign_count = 0
	     then do;
		     lexeme_env.token.type = 3;
		     go to word;
		end;
	go to comm;

/*
					"
				*/
l (3):
	lexeme_env.token.type = 2;

	call move_char;

	mask = "0000001"b;
al_1:
	call swnm;

	if lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column) = "
"
	then do;
		call cont_lit;

		go to al1 (res);

al1 (1):
al1 (2):
		go to comm;
al1 (3):
		lexeme_env.token.span = lexeme_env.token.span + 1;

		go to al_1;

	     end;

	call move_lit_char;

al_2:
	call look;

	go to al2 (res);

al2 (1):
	if ch = "
"
	then do;
		call cont_lit;

		go to al21 (res);

al21 (1):
al21 (2):
		go to ss1;

al21 (3):
		lexeme_env.token.span = lexeme_env.token.span + 1;
		go to al_2;

	     end;

	go to ss1;

al2 (2):
	go to ss1;

al2 (3):
al_3:
	call swnm;

	if lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column) = "
"
	then do;
		call cont_lit;
		go to al3 (res);

al3 (1):
al3 (2):
		go to comm;

al3 (3):
		go to al_3;

	     end;


	go to al_1;

/*
					,;
				*/
l (5):
	lexeme_env.token.type = 4;

	call move_char;

	call look;

	go to sep (res);

sep (1):
	go to ss1;
sep (2):
	if "01"b & mem_tab (fixed (unspec (ch), 15))
	then do;
		dec_pt_count = 1;
		lexeme_env.token.type = 2;
		go to num_lit;
	     end;

	go to comm;

sep (3):
	go to comm;

/*
					+-
				*/
l (6):
l (18):
	sign_count = 1;
	lexeme_env.token.type = 3;

	call move_char;

	call look;

	go to sgn (res);

sgn (1):
	lexeme_env.token.type = 3;
	go to ss1;
sgn (2):
	go to comm;

sgn (3):
	if "01"b & mem_tab (fixed (unspec (ch), 15))
	then do;
		lexeme_env.token.type = 2;
		go to num_lit;
	     end;

	go to comm;

/*
					*
				*/
l (7):
	lexeme_env.token.type = 3;

	call move_char;

	call look;

	go to ask (res);

ask (1):
	go to ss1;
ask (2):
	go to comm;

ask (3):
	if ch = "*"
	then do;
		call move_char;

		call look;

		go to exp (res);

exp (1):
		go to ss1;
exp (2):
exp (3):
		go to comm;

	     end;

	go to comm;

/*
					</>
				*/
l (9):
l (16):
l (17):
	lexeme_env.token.type = 3;

dlm:
	call move_char;

dlm_1:
	call look;

	go to wd (res);

wd (1):
	go to ss1;
wd (2):
wd (3):
	go to comm;

/*
					other characters
				*/
l (8):
l (10):
comm:
	lexeme_env.token.type = 5;
com_ent:
	mask = "00000001"b;

	call swnm;

	if new_line
	then do;
		call merge;

		if cont
		then do;
			cont = "0"b;
			go to com_ent;
		     end;
	     end;

	if lexeme_env.current_line.column >= 9
	then do;
		if lexeme_env.token.string_size > 2
		then do;

			if lexeme_env.indicators.copy_replace & lexeme_env.pseudo_text = 2
			then do;

				if substr (lexeme_env.current_line.loc -> ss, lexeme_env.current_line.column - 2,
				     2) = "=="
				then do;
					lexeme_env.token.span = lexeme_env.token.span - 2;
					lexeme_env.token.string_size = lexeme_env.token.string_size - 2;
					lexeme_env.current_line.column = lexeme_env.current_line.column - 2;
				     end;

			     end;

		     end;
	     end;

	return;

/*
					(
				*/
l (11):
	lexeme_env.token.type = 4;

	call move_char;

	go to ss1;

/*
					)
				*/
l (13):
	lexeme_env.token.type = 4;

	call move_char;

	go to ss1;


/*
					.
				*/
l (14):
	lexeme_env.token.type = 4;

	call move_char;

	call look;

	go to per (res);

per (1):
	go to ss1;
per (2):
	if "01"b & mem_tab (fixed (unspec (ch), 15))
	then do;
		dec_pt_count = 1;
		lexeme_env.token.type = 2;
		go to num_lit;
	     end;

	go to comm;

per (3):
	go to comm;

/*
					=
				*/
l (15):
	lexeme_env.token.type = 4;

	if lexeme_env.current_line.column < lexeme_env.current_line.size
	then do;
		call move_char;

		ch = lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column);

		if ch = "="
		then do;
			call move_char;

			if ^lexeme_env.indicators.copy_replace
			then go to dlm_1;

			go to ptxt (lexeme_env.pseudo_text);

ptxt (1):
			lexeme_env.pseudo_text = 2;
			go to ss1;

ptxt (2):
ptxt (3):
			lexeme_env.pseudo_text = 1;

			go to dlm_1;
		     end;

		go to dlm_1;

	     end;

	go to dlm;

     end;

cont_lit:
     proc;					/*	res = 1 not continuation card
			res = 2 first non blank character character not QUOTE
			res = 3 first non blank character character QUOTE not followed by CR
		*/
	call next_cont;

	if ^cont
	then do;
		res = 1;
		return;
	     end;

	call get_line;

	do while ("1"b);

	     if j >= 13
	     then do;

		     p = lexeme_env.current_line.loc;
		     j = 12;

		     do while (p -> sa (j) = " ");

			j = j + 1;

		     end;

		     if p -> sa (j) ^= """"
		     then do;
			     res = 2;
			     return;
			end;

		     if p -> sa (j + 1) ^= "
"
		     then do;
			     lexeme_env.token.span = lexeme_env.token.span + j;
			     lexeme_env.current_line.column = j + 1;
			     res = 3;

			     return;
			end;

		end;

	     call next_cont;

	     if ^cont
	     then do;
		     res = 1;
		     return;
		end;


	     lexeme_env.token.span = lexeme_env.token.span + lexeme_env.current_line.length;

	     call get_line;

	end;
     end;

space:
     proc;					/* form the space token */
	do while ("1"b);

	     i = lexeme_env.current_line.column;	/* find non-blank character */
	     p = lexeme_env.current_line.loc;

	     do while (p -> sa (i) = " ");

		i = i + 1;

	     end;

	     lexeme_env.token.span = lexeme_env.token.span + i - lexeme_env.current_line.column;
						/* adjust span */
	     lexeme_env.current_line.column = i;

	     if p -> sa (i) ^= "
"
	     then return;
	     lexeme_env.token.span = lexeme_env.token.span + 1;

	     more = "1"b;

	     do while (more);

		call get_line;

		if lexeme_env.current_line.length = 0
		then return;			/* card too small */
		if lexeme_env.current_line.length < 8
		then lexeme_env.token.span = lexeme_env.token.span + lexeme_env.current_line.length;

		else /* comment line */
		     if lexeme_env.current_line.loc -> sa (7) = "*"
		then lexeme_env.token.span = lexeme_env.token.span + lexeme_env.current_line.length;

		else /* continuation line */
		     if lexeme_env.current_line.loc -> sa (7) = "-"
		then if lexeme_env.current_line.length < 13
		     then lexeme_env.token.span = lexeme_env.token.span + lexeme_env.current_line.length;
		     else do;
			     lexeme_env.token.span = lexeme_env.token.span + 11;
			     lexeme_env.current_line.column = 12;
			     more = "0"b;
			end;
		else do;
			lexeme_env.token.span = lexeme_env.token.span + 7;
			lexeme_env.current_line.column = 8;
			more = "0"b;
		     end;
	     end;
	end;
     end;

look:
     proc;

/*	res = 1	space new_line )( EOF .,;-separator ==
					res = 2	.,;
					res = 3	other
				*/

	res = 1;
	ch = "";

	if lexeme_env.current_line.length = 0
	then return;

	ch = lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column);

	if ch = " " | ch = "
"
	then return;

	if ch = "." | ch = "," | ch = ";"
	then if lexeme_env.current_line.column = lexeme_env.current_line.size
	     then do;
		     call next_cont;

		     if cont
		     then do;
			     res = 2;
			     return;
			end;
		     else do;
			     res = 1;
			     return;
			end;
		end;

	     else do;
		     ch2 = substr (lexeme_env.current_line.loc -> ss, lexeme_env.current_line.column + 1, 2);

		     if substr (ch2, 1, 1) = " "
		     then do;
			     res = 1;
			     return;
			end;
		     else do;
			     res = 2;
			     if ch2 = "=="
			     then res = 1;
			     return;
			end;
		end;
	else if ch = "(" | ch = ")"
	then do;
		res = 1;
		return;
	     end;
	else do;
		res = 3;
		call p_test;
	     end;
     end;

p_test:
     proc;

	if ch = "=" & lexeme_env.current_line.column + 1 < lexeme_env.current_line.length
	then if lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column + 1) = "="
	     then res = 1;
     end;

merge:
     proc;

	call next_cont;

	if ^cont
	then return;

	lexeme_env.token.span =
	     lexeme_env.token.span + lexeme_env.current_line.length - lexeme_env.current_line.column + 1;

	do while (cont);

	     call get_line;

	     if lexeme_env.current_line.size ^= 7
	     then do;
		     i = 12;

		     do while (lexeme_env.current_line.loc -> sa (i) = " ");

			i = i + 1;

		     end;

		     lexeme_env.token.span = lexeme_env.token.span + i - 1;

		     lexeme_env.current_line.column = i;

		     return;
		end;

	     call next_cont;
	end;
     end;

next_cont:
     proc;

	cont = "0"b;

	if lexeme_env.next_line.length = 0
	then return;

	if lexeme_env.next_line.size < 12
	then return;

	if lexeme_env.next_line.loc -> sa (7) ^= "-"
	then return;

	cont = "1"b;
     end;

move_char:
     proc;

	scan_mode = "0"b;
	call m_c;

     end;

move_lit_char:
     proc;

	scan_mode = "1"b;
	call m_c;

     end;

m_c:
     proc;

	if lexeme_env.token.string_size = lexeme_env.token.string_cap
	then call alloc_lexeme;

	lexeme_env.token.string_size = lexeme_env.token.string_size + 1;

	lexeme_env.token.string_ptr -> sa (lexeme_env.token.string_size) =
	     lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column);

	lexeme_env.current_line.column = lexeme_env.current_line.column + 1;
	lexeme_env.token.span = lexeme_env.token.span + 1;

	if scan_mode | lexeme_env.current_line.column <= lexeme_env.current_line.size
	then return;

	call merge;

     end;


get_line:
     proc;


	if lexeme_env.current_line.loc = null ()
	then do;
		call fill_next_line;

		lexeme_env.current_line = lexeme_env.next_line;
		lexeme_env.source_table.line = lexeme_env.source_table.line + 1;

		if lexeme_env.current_line.size ^= 0
		then call fill_next_line;

		return;

	     end;

	else if lexeme_env.current_line.length = 0
	then return;

	lexeme_env.current_line = lexeme_env.next_line;
	lexeme_env.source_table.line = lexeme_env.source_table.line + 1;

	if lexeme_env.current_line.length = 0
	then return;

	call fill_next_line;

     end;

fill_next_line:
     proc;

declare	(sl, sz)		fixed bin;
declare	ch		char (1),
	p		ptr;

	if lexeme_env.source_table.offset > lexeme_env.source_table.size
	then do;
		lexeme_env.next_line.length = 0;
		lexeme_env.next_line.loc = addr (lexeme_env.source_table.loc -> sa (lexeme_env.source_table.size));

	     end;
	else do;
		p, lexeme_env.next_line.loc =
		     addr (lexeme_env.source_table.loc -> sa (lexeme_env.source_table.offset));

		sl = lexeme_env.source_table.size - lexeme_env.source_table.offset + 1;

		sz = index (substr (lexeme_env.next_line.loc -> ss, 1, sl), "
");

		lexeme_env.next_line.offset = lexeme_env.source_table.offset;
		lexeme_env.next_line.length = sz;
		lexeme_env.next_line.column = 1;
		lexeme_env.source_table.offset = lexeme_env.source_table.offset + sz;

		sz = sz - 1;

		if sz ^= 0
		then do;
			ch = p -> sa (sz);

			do while (ch = " ");

			     sz = sz - 1;

			     if sz = 0
			     then ch = "~";
			     else ch = p -> sa (sz);

			end;
		     end;

		lexeme_env.next_line.size = sz;
	     end;

     end;

/*

	Find a copy or replace statement not contained within a comment
	entry in the IDENTIFICATION DIVISION

	1: XT: eof, copy, replace
	    2: ed, dd, pd
	    3: id
	    1: otherwise

	2: find COPY/REPLACE

	3: XT: eof
	    2: ed, dd, pd
	    4: pn.
	    3: otherwise

	4: XT: eof, copy, replace
	    2: ed, dd, pd
	    5: otherwise

	5: XT: eof
	    2: ed, dd, pd
	    4: pn.
	    5: otherwise

*/

/*[5.3-1]*/
dcl	tf		bit (1),
	found		bit (1);			/*[5.3-1]*/
dcl	state		fixed bin static internal;	/*[5.3-1]*/
dcl	swexit		label;

/*[5.3-1]*/
dcl	ident		char (14) varying init ("identification");
						/*[5.3-1]*/
dcl	div		char (8) varying init ("division");
						/*[5.3-1]*/
dcl	env		char (11) varying init ("environment");
						/*[5.3-1]*/
dcl	dat		char (4) varying init ("data");
						/*[5.3-1]*/
dcl	proc		char (9) varying init ("procedure");
						/*[5.3-1]*/
dcl	cpy		char (4) varying init ("copy");
						/*[5.3-1]*/
dcl	rpl		char (7) varying init ("replace");

seek_word:
     proc;					/* find COPY or REPLACE */

/*[5.3-1]*/
	swexit = swx1;

/*[5.3-1]*/
	do while ("1"b);

/*[5.3-1]*/
	     go to sw (state);

sw (1):						/* initial state */
						/*[5.3-1]*/
	     call sw1;				/*[5.3-1]*/
	     go to swx;

sw (2):						/* ID, DD, PD found */
						/*[5.3-1]*/
	     call SW;				/*[5.3-1]*/
	     return;

sw (3):						/* ID found */
						/*[5.3-1]*/
	     call sw3;				/*[5.3-1]*/
	     go to swx;

sw (4):						/* proc-name found */
						/*[5.3-1]*/
	     call sw4;				/*[5.3-1]*/
	     go to swx;

sw (5):						/* COPY, REPLACE found */
						/*[5.3-1]*/
	     call sw5;				/*[5.3-1]*/
	     go to swx;

swx:						/*[5.3-1]*/
	end;

swx1:
     end;

sw1:
     proc;					/* initial state */

/*[5.3-1]*/
	do while ("1"b);

/*[5.3-1]*/
	     call GT;				/* get a token */

/*[5.3-1]*/
	     call test_hdr ("0"b, 3);			/* test for ID */
						/*[5.3-1]*/
	     if found
	     then return;

/*[5.3-1]*/
	     call test_hdr ("1"b, 2);			/* test for ED, DD, PD */
						/*[5.3-1]*/
	     if found
	     then return;

/*[5.3-1]*/
	     call test_word (addr (key_word));		/* COPY, REPLACE */
						/*[5.3-1]*/
	     if found
	     then go to swexit;			/*[5.3-1]*/
	end;
     end;

sw3:
     proc;					/* after ID */

/*[5.3-1]*/
	do while ("1"b);

/*[5.3-1]*/
	     call GT;				/* get a token */

/*[5.3-1]*/
	     call test_hdr ("1"b, 2);			/* test for ED, DD, PD */
						/*[5.3-1]*/
	     if found
	     then return;				/* get a token */

/*[5.3-1]*/
	     call test_pn (4);			/* test for proc-name. */
						/*[5.3-1]*/
	     if found
	     then return;

/*[5.3-1]*/
	     call test_word (addr (key_word));		/* COPY, REPLACE */
						/*[5.3-1]*/
	     if found
	     then go to swexit;

/*[5.3-1]*/
	end;
     end;

sw4:
     proc;					/* after proc-name. */

/*[5.3-1]*/
	call GT1;					/* get a token */

/*[5.3-1]*/
	call test_hdr ("1"b, 2);			/* test for ED, DD, PD */
						/*[5.3-1]*/
	if found
	then return;

/*[5.3-1]*/
	call test_word (addr (key_word));		/* COPY, REPLACE */
						/*[5.3-1]*/
	if found
	then go to swexit;

/*[5.3-1]*/
	tf = "1"b;				/*[5.3-1]*/
	state = 5;
     end;

sw5:
     proc;					/* after proc-name. */

/*[5.3-1]*/
	do while ("1"b);

/*[5.3-1]*/
	     call GT;				/* get a token */

/*[5.3-1]*/
	     call test_hdr ("1"b, 2);			/* test for ED, DD, PD */
						/*[5.3-1]*/
	     if found
	     then return;

/*[5.3-1]*/
	     call test_pn (4);			/* test for proc-name. */
						/*[5.3-1]*/
	     if found
	     then return;				/*[5.3-1]*/
	end;

     end;

test_hdr:
     proc (md, st);					/* test for division header  */

/*[5.3-1]*/
dcl	md		bit (1),
	st		fixed bin;

/*[5.3-1]*/
	if md					/*[5.3-1]*/
	then call tedp;				/* ED, DD, PD */
						/*[5.3-1]*/
	else call test_word (addr (ident));		/* ID */

/*[5.3-1]*/
	if ^found
	then return;

/*[5.3-1]*/
	call GT1;					/* get token */

/*[5.3-1]*/
	call test_word (addr (div));			/* DIVISION */
						/*[5.3-1]*/
	if ^found
	then go to test_id_xf;

/*[5.3-1]*/
	call gt;					/* get token */

/*[5.3-1]*/
	call per_test;				/* . */
						/*[5.3-1]*/
	if ^found
	then go to test_id_xf;

/*[5.3-1]*/
	state = st;				/*[5.3-1]*/
	return;					/* XT */

test_id_xf:					/* XF */
						/*[5.3-1]*/
	tf = "1"b;


     end;

tedp:
     proc;					/* test for ED, DD, PD */

/*[5.3-1]*/
	call test_word (addr (env));			/* ENVIRONMENT */
						/*[5.3-1]*/
	if found
	then return;

/*[5.3-1]*/
	call test_word (addr (dat));			/* DATA */
						/*[5.3-1]*/
	if found
	then return;

/*[5.3-1]*/
	call test_word (addr (proc));			/* PROCEDURE */

     end;

per_test:
     proc;					/* test for period */

/*[5.3-1]*/
	if lexeme_env.token.type = 4			/*[5.3-1]*/
	then if lexeme_env.token.string = "."		/*[5.3-1]*/
	     then found = "1"b;			/*[5.3-1]*/
	     else found = "0"b;

     end;

test_word:
     proc (p);					/* test for specified string */

/*[5.3-1]*/
dcl	p		ptr;			/*[5.3-1]*/
dcl	word		char (32) varying based (p);

/*[5.3-1]*/
	if lexeme_env.token.type = 3 & lexeme_env.token.string = word
	then found = "1"b;
	else found = "0"b;

     end;

test_pn:
     proc (st);					/* test for proc-name. */

/*[5.3-1]*/
dcl	st		fixed bin;

/*[5.3-1]*/
	call gt;					/* get a token */

/*[5.3-1]*/
	call per_test;				/* . */
						/*[5.3-1]*/
	if ^found
	then go to test_pn_xf;

/*[5.3-1]*/
	found = "1"b;				/*[5.3-1]*/
	state = st;				/*[5.3-1]*/
	return;					/* XT */

test_pn_xf:					/* XF */
						/*[5.3-1]*/
	tf = "1"b;


     end;

gt:
     proc;					/* get a token */

/*[5.3-1]*/
	if tf					/* token already read */
						/*[5.3-1]*/
	then do;
		tf = "0"b;			/*[5.3-1]*/
		return;				/*[5.3-1]*/
	     end;

/*[5.3-1]*/
	call get_token;				/* read a token */

/*[5.3-1]*/
	if lexeme_env.error ^= 0
	then go to swexit;				/* eof */

     end;

GT:
     proc;					/* find word in margin A */

/*[5.3-1]*/
	call gt;					/* get a token */

/*[5.3-1]*/
	do while (lexeme_env.token.column > 11 | lexeme_env.token.type ^= 3);

/*[5.3-1]*/
	     call gt;				/* get a token */

/*[5.3-1]*/
	end;

     end;

GT1:
     proc;					/* find next real token */

/*[5.3-1]*/
	call gt;					/* get a token */

/*[5.3-1]*/
	do while (lexeme_env.token.type = 1);

/*[5.3-1]*/
	     call gt;				/* get a token */

/*[5.3-1]*/
	end;

     end;

SW:
     proc;

	call get_token;

	do while (lexeme_env.error = 0
	     & ((lexeme_env.token.type ^= 3 & lexeme_env.token.type ^= 4)
	     | ((lexeme_env.token.type = 3 | lexeme_env.token.type = 4)
	     & substr (lexeme_env.token.string_ptr -> ss, 1, lexeme_env.token.string_size) ^= key_word)));

	     call get_token;
	end;

     end;

swm:
     proc;


declare	p		ptr;

swm_2:
	if lexeme_env.current_line.length = 0
	then return;

	old, new = lexeme_env.current_line.column;
	p = lexeme_env.current_line.loc;
	tok_size = lexeme_env.current_line.size;

swm_1:
	if new <= tok_size
	then if mask & mem_tab (fixed (unspec (p -> sa (new)), 35))
	     then do;
		     new = new + 1;
		     go to swm_1;
		end;

	call form_str;

	if new_line
	then do;
		call merge;

		if cont
		then do;
			cont = "0"b;
			go to swm_2;
		     end;
	     end;

     end;

swnm:
     proc;


declare	p		ptr;

	if lexeme_env.current_line.length = 0
	then return;

	old, new = lexeme_env.current_line.column;
	p = lexeme_env.current_line.loc;
	tok_size = lexeme_env.current_line.size;

swnm_1:
	if new <= tok_size
	then if mask & ^mem_tab (fixed (unspec (p -> sa (new)), 35))
	     then do;
		     new = new + 1;
		     go to swnm_1;
		end;

	call form_str;

     end swnm;

form_str:
     proc;

	size = new - old;

	if new > tok_size
	then new_line = "1"b;
	else new_line = "0"b;

	if size = 0
	then return;

	tok_size = size + lexeme_env.token.string_size;

	if tok_size > lexeme_env.token.string_cap
	then call alloc_lexeme;

	substr (lexeme_env.token.string_ptr -> ss, lexeme_env.token.string_size + 1, size) =
	     substr (lexeme_env.current_line.loc -> ss, old);

	lexeme_env.token.string_size = lexeme_env.token.string_size + size;
	lexeme_env.token.span = lexeme_env.token.span + size;
	lexeme_env.current_line.column = new;

     end;

alloc_lexeme:
     proc;

	if lexeme_env.alloc.parity = 0
	then do;
		lexeme_env.alloc.parity = 1;
		lexeme_env.alloc.cap2 = 2 * lexeme_env.alloc.cap1;

		allocate alloc_2 in (expand_cobol_source_area);

		if lexeme_env.token.string_size ^= 0
		then alloc_2 = substr (alloc_1, 1, lexeme_env.token.string_size);

		free alloc_1;

		lexeme_env.token.string_cap = lexeme_env.alloc.cap2;
		lexeme_env.token.string_ptr = lexeme_env.alloc.ptr2;
	     end;

	else do;
		lexeme_env.alloc.parity = 0;
		lexeme_env.alloc.cap1 = 2 * lexeme_env.alloc.cap2;

		allocate alloc_1 in (expand_cobol_source_area);

		if lexeme_env.token.string_size ^= 0
		then alloc_1 = substr (alloc_2, 1, lexeme_env.token.string_size);

		free alloc_2;

		lexeme_env.token.string_cap = lexeme_env.alloc.cap1;
		lexeme_env.token.string_ptr = lexeme_env.alloc.ptr1;
	     end;
     end;


/*
				 Membership table for scans and character look-ups 
 	column 1:  alphanumeric characters [0...9 a...z alloc...Z -] 
 	column 2:  digits [0...9] 
 	column 3:  picture characters [all printable characters except " ;] 
 	column 4:  binary characters [0 1] 
 	column 5:  delimiters [nl space " ( ) , . ;] 
 	column 6:  delimiters [. ; ,] 
 	column 7:  delimiters [nl "] 
 	column 8:  delimiters [nl sp . ; ,] 
*/

dcl	m_t		(0:127) bit (8)
			init ("00000000"b /* 	(NUL)	000	  0   */,
			"00000000"b /* 	(SOH)	001	  1   */,
			"00000000"b /* 	(STX)	002	  2   */,
			"00000000"b /* 	(ETX)	003	  3   */,
			"00000000"b /* 	(EOT)	004	  4   */,
			"00000000"b /* 	(ENQ)	005	  5   */,
			"00000000"b /* 	(ACK)	006	  6   */,
			"00000000"b /* 	BEL	007	  7   */,
			"00000000"b /* 	BS	010	  8   */,
			"00000000"b /* 	HT	011	  9   */,
			"00001011"b /* 	NL(LF)	012	 10   */,
			"00000000"b /* 	VT	013	 11   */,
			"00000000"b /* 	NP(FF)	014	 12   */,
			"00000000"b /* 	(CR)	015	 13   */,
			"00000000"b /* 	RRS(S0)	016	 14   */,
			"00000000"b /* 	BRS(S1)	017	 15   */,
			"00000000"b /* 	(DLE)	020	 16   */,
			"00000000"b /* 	(DC1)	021	 17   */,
			"00000000"b /* 	HLF(DC2)	022	 18   */,
			"00000000"b /* 	(DC3)	023	 19   */,
			"00000000"b /* 	HLR(DC4)	024	 20   */,
			"00000000"b /* 	(NAK)	025	 21   */,
			"00000000"b /* 	(SYN)	026	 22   */,
			"00000000"b /* 	(ETB)	027	 23   */,
			"00000000"b /* 	(CAN)	030	 24   */,
			"00000000"b /* 	(EM)	031	 25   */,
			"00000000"b /* 	(SUB)	032	 26   */,
			"00000000"b /* 	(ESC)	033	 27   */,
			"00000000"b /* 	(FS)	034	 28   */,
			"00000000"b /* 	(GS)	035	 29   */,
			"00000000"b /* 	(RS)	036	 30   */,
			"00000000"b /* 	(US)	037	 31   */,
			"00001001"b /* 	Space	040	 32   */,
			"00100000"b /* 	!	041	 33   */,
			"00001010"b /* 	"	042	 34   */,
			"00100000"b /* 	#	043	 35   */,
			"00100000"b /* 	$	044	 36   */,
			"00100000"b /* 	%	045	 37   */,
			"00100000"b /* 	&	046	 38   */,
			"00100000"b /* 	'	047	 39   */,
			"00101001"b /* 	(	050	 40   */,
			"00101001"b /* 	)	051	 41   */,
			"00100000"b /* 	*	052	 42   */,
			"00100000"b /* 	+	053	 43   */,
			"00101101"b /* 	,	054	 44   */,
			"10100000"b /* 	-	055	 45   */,
			"00101101"b /* 	.	056	 46   */,
			"00100000"b /* 	/	057	 47   */,
			"11110000"b /* 	0	060	 48   */,
			"11110000"b /* 	1	061	 49   */,
			"11100000"b /* 	2	062	 50   */,
			"11100000"b /* 	3	063	 51   */,
			"11100000"b /* 	4	064	 52   */,
			"11100000"b /* 	5	065	 53   */,
			"11100000"b /* 	6	066	 54   */,
			"11100000"b /* 	7	067	 55   */,
			"11100000"b /* 	8	070	 56   */,
			"11100000"b /* 	9	071	 57   */,
			"00100000"b /* 	:	072	 58   */,
			"00001101"b /* 	;	073	 59   */,
			"00100000"b /* 	<	074	 60   */,
			"00100000"b /* 	=	075	 61   */,
			"00100000"b /* 	>	076	 62   */,
			"00100000"b /* 	?	077	 63   */,
			"00100000"b /* 	@	100	 64   */,
			"10100000"b /* 	A	101	 65   */,
			"10100000"b /* 	B	102	 66   */,
			"10100000"b /* 	C	103	 67   */,
			"10100000"b /* 	D	104	 68   */,
			"10100000"b /* 	E	105	 69   */,
			"10100000"b /* 	F	106	 70   */,
			"10100000"b /* 	G	107	 71   */,
			"10100000"b /* 	H	110	 72   */,
			"10100000"b /* 	I	111	 73   */,
			"10100000"b /* 	J	112	 74   */,
			"10100000"b /* 	K	113	 75   */,
			"10100000"b /* 	L	114	 76   */,
			"10100000"b /* 	M	115	 77   */,
			"10100000"b /* 	N	116	 78   */,
			"10100000"b /* 	O	117	 79   */,
			"10100000"b /* 	P	120	 80   */,
			"10100000"b /* 	Q	121	 81   */,
			"10100000"b /* 	R	122	 82   */,
			"10100000"b /* 	S	123	 83   */,
			"10100000"b /* 	T	124	 84   */,
			"10100000"b /* 	U	125	 85   */,
			"10100000"b /* 	V	126	 86   */,
			"10100000"b /* 	W	127	 87   */,
			"10100000"b /* 	X	130	 88   */,
			"10100000"b /* 	Y	131	 89   */,
			"10100000"b /* 	Z	132	 90   */,
			"00100000"b /* 	[	133	 91   */,
			"00100000"b /* 	\	134	 92   */,
			"00100000"b /* 	]	135	 93   */,
			"00100000"b /* 	^	136	 94   */,
			"00100000"b /* 	_	137	 95   */,
			"00100000"b /* 	`	140	 96   */,
			"10100000"b /* 	a	141	 97   */,
			"10100000"b /* 	b	142	 98   */,
			"10100000"b /* 	c	143	 99   */,
			"10100000"b /* 	d	144	100   */,
			"10100000"b /* 	e	145	101   */,
			"10100000"b /* 	f	146	102   */,
			"10100000"b /* 	g	147	103   */,
			"10100000"b /* 	h	150	104   */,
			"10100000"b /* 	i	151	105   */,
			"10100000"b /* 	j	152	106   */,
			"10100000"b /* 	k	153	107   */,
			"10100000"b /* 	l	154	108   */,
			"10100000"b /* 	m	155	109   */,
			"10100000"b /* 	n	156	110   */,
			"10100000"b /* 	o	157	111   */,
			"10100000"b /* 	p	160	112   */,
			"10100000"b /* 	q	161	113   */,
			"10100000"b /* 	r	162	114   */,
			"10100000"b /* 	s	163	115   */,
			"10100000"b /* 	t	164	116   */,
			"10100000"b /* 	u	165	117   */,
			"10100000"b /* 	v	166	118   */,
			"10100000"b /* 	w	167	119   */,
			"10100000"b /* 	x	170	120   */,
			"10100000"b /* 	y	171	121   */,
			"10100000"b /* 	z	172	122   */,
			"00100000"b /* 	{	173	123   */,
			"00100000"b /* 	|	174	124   */,
			"00100000"b /* 	}	175	125   */,
			"00100000"b /* 	~	176	126   */,
			"00000000"b /* 	DEL	177	127   */);

/* character classes defined by the x table */

/*	1	A...Za...z
	2	0...9
	3	"
	4
	5	,;
	6	+
	7	*
	8	%
	9	/
	10	illegal
	11	(
	12	nl , SP
	13	)
	14	.
	15	=
	16	<
	17	>
	18	-
*/

dcl	x_i		(0:127) fixed bin (8)
			init (10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 12, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
			10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 12, 10, 3, 10, 10, 8, 10, 10, 11, 13, 7, 6, 5,
			18, 14, 9, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 10, 5, 16, 15, 17, 10, 10, 1, 1, 1, 1, 1, 1, 1, 1,
			1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 10, 10, 10, 10, 10, 10, 1, 1, 1, 1, 1,
			1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 10, 10, 10, 10, 10);

dcl	lower_case_alphabet char (128) static options (constant) init ("	
 !""#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");

%include cobol_lexeme_env;

     end;




		    cobol_operator_names_.alm       11/11/82  1550.1rew 11/11/82  1030.7       46629



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

"	Modified on 06/30/81 by FCH op 94 stop_cd_run added
"	Modified on 02/18/81 by FCH op 93 alt_rewrite added
"	Modified on 08/24/79 by PRP op 83 changed to alt_start_control
"	Modified on 05/09/77 by Bob Chang to add name for close_reel.
"	Modified on 04/14/77 by Bob Chang to add communication operator names.
"	Modified on 03/17/77 by Bob Chang to add new operator names.
"	Modified on 03/15/77 by Bob Chang to fix the bug for missing entry for operator 62.
"	Table of cobol operator names.
"
"	Created on 1/17/77 by Bob Chang
"
	name	cobol_operator_names_
	segdef	cobol_operator_names_

cobol_operator_names_:
	equ	first_n,0

first:
	zero	0,first_n
last:
	zero	0,first_n+last_normal-first_normal-1)
first_special:
	zero	0,0
last_special:
	zero	0,0
number_special:
	zero	0,0

	use 	text
first_normal:
	zero	s0,17
	zero	s1,12
	zero	s2,16
	zero	s3,10
	zero	s4,11
	zero	s5,17
	zero	s6,12
	zero	s7,4
	zero	s8,8
	zero	s9,8
	zero	s10,14
	zero	s11,12
	zero	s12,13
	zero	s13,11
	zero	s14,13
	zero	s15,12
	zero	s16,17
	zero	s17,14
	zero	s18,14
	zero	s19,9
	zero	s20,11
	zero	s21,10
	zero	s22,13
	zero	s23,13
	zero	s24,19
	zero	s25,15
	zero	s26,17
	zero	s27,10
	zero	s28,18
	zero	s29,13
	zero	s30,13
	zero	s31,13
	zero	s32,9
	zero	s33,12
	zero	s34,11
	zero	s35,9
	zero	s36,15
	zero	s37,10
	zero	s38,15
	zero	s39,10
	zero	s40,12
	zero	s41,8
	zero	s42,12
	zero	s43,12
	zero	s44,11
	zero	s45,10
	zero	s46,11
	zero	s47,18
	zero	s48,8
	zero	s49,6
	zero	s50,13
	zero	s51,15
	zero	s52,6
	zero	s53,6
	zero	s54,12
	zero	s55,8
	zero	s56,11
	zero	s57,14
	zero	s58,15
	zero	s59,7
	zero	s60,10
	zero	s61,10
	zero	s62,12
	zero	s63,9
	zero	s64,8
	zero	s65,11
	zero	s66,18
	zero	s67,13
	zero	s68,19
	zero	s69,17
	zero	s70,12
	zero	s71,11
	zero	s72,10
	zero	s73,9
	zero	s74,11
	zero	s75,12
	zero	s76,10
	zero	s77,7
	zero	s78,13
	zero	s79,9
	zero	s80,13
	zero	s81,15
	zero	s82,13
	zero	s83,16
	zero	s84,12
	zero	s85,18
	zero	s86,10
	zero	s87,14
	zero	s88,15
	zero	s89,14
	zero	s90,18
	zero	s91,18
	zero	s92,12
	zero	s93,11
	zero	s94,11
last_normal:
"
s0:	aci	"call_ent_var_desc"		0
s1:	aci	"call_ent_var"		1
s2:	aci	"call_ext_in_desc"		2
s3:	aci	"return_mac"		3
s4:	aci	"call_ext_in"		4
s5:	aci	"call_ext_out_desc"		5
s6:	aci	"call_ext_out"		6
s7:	aci	"opch"			7
s8:	aci	"enable"			8
s9:	aci	"enable_1"		9
s10:	aci	"sort_entry_seq"		10
s11:	aci	"sort_release"		11
s12:	aci	"runtime_check"		12
s13:	aci	"sort_return"		13
s14:	aci	"sort_initiate"		14
s15:	aci	"real_to_real"		15
s16:	aci	"establish_cleanup"		16
s17:	aci	"sort_terminate"		17
s18:	aci	"revert_cleanup"		18
s19:	aci	"sort_comp"		19
s20:	aci	"accept_line"		20
s21:	aci	"init_start"		21
s22:	aci	"sort_commence"		22
s23:	aci	"start_control"		23
s24:	aci	"set_lin_file_status"	24
s25:	aci	"set_file_status"		25
s26:	aci	"dsply_user_output"		26
s27:	aci	"close_file"		27
s28:	aci	"dsply_error_output"	28
s29:	aci	"close_op_file"		29
s30:	aci	"open_ext_file"		30
s31:	aci	"open_int_file"		31
s32:	aci	"find_iocb"		32
s33:	aci	"check_attach"		33
s34:	aci	"attach_iocb"		34
s35:	aci	"open_file"		35
s36:	aci	"open_close_file"		36
s37:	aci	"check_file"		37
s38:	aci	"close_file_only"		38
s39:	aci	"init_write"		39
s40:	aci	"write_stream"		40
s41:	aci	"seek_key"		41
s42:	aci	"write_record"		42
s43:	aci	"stop_literal"		43
s44:	aci	"accept_date"		44
s45:	aci	"accept_day"		45
s46:	aci	"accept_time"		46
s47:	aci	"accept_day_of_week"	47
s48:	aci	"stop_run"		48
s49:	aci	"cancel"			49
s50:	aci	"inspect_tally"		50
s51:	aci	"inspect_replace"		51
s52:	aci	"linage"			52
s53:	aci	"delete"			53
s54:	aci	"delete_error"		54
s55:	aci	"read_key"		55
s56:	aci	"init_delete"		56
s57:	aci	"special_delete"		57
s58:	aci	"special_rewrite"		58
s59:	aci	"rewrite"			59
s60:	aci	"merge_init"		60
s61:	aci	"merge_comp"		61
s62:	aci	"merge_return"		62
s63:	aci	"init_read"		63
s64:	aci	"get_line"		64
s65:	aci	"read_record"		65
s66:	aci	"nonseq_read_record"	66
s67:	aci	"read_seek_key"		67
s68:	aci	"write_stream_linage"	68
s69:	aci	"read_key_for_read"		69
s70:	aci	"receive_comm"		70
s71:	aci	"accept_comm"		71
s72:	aci	"purge_comm"		72
s73:	aci	"send_comm"		73
s74:	aci	"enable_comm"		74
s75:	aci	"disable_comm"		75
s76:	aci	"close_reel"		76
s77:	aci	"init_cd"			77
s78:	aci	"alt_open_file"		78
s79:	aci	"alt_start"		79
s80:	aci	"alt_read_next"		80
s81:	aci	"alt_read_record"		81
s82:	aci	"alt_key_check"		82
s83:	aci	"alt_start_control"		83
s84:	aci	"alt_read_key"		84
s85:	aci	"alt_special_delete"	85
s86:	aci	"alt_delete"		86
s87:	aci	"alt_key_delete"		87
s88:	aci	"alt_rewrite_add"		88
s89:	aci	"alt_close_file"		89
s90:	aci	"alt_add_write_keys"	90
s91: 	aci	"alt_write_seek_key"	91
s92:	aci	"alt_find_rec"		92
s93:	aci	"alt_rewrite"		93
s94:	aci	"stop_cd_run"		94
	end




		    cobol_operators_.alm            05/24/89  1048.6rew 05/24/89  0837.5      861471



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

" HISTORY COMMENTS:
"  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090),
"     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
"     MCR8090 cobol_operators_.alm Disallow duplicate prime keys in Indexed
"     Sequential files.
"                                                      END HISTORY COMMENTS


"Modified on 12/19/84 by FCH, [5.3-1], BUG573(phx16343), error detection can fail if ark used
"Modified on 10/29/82 by FCH, [5.1-1], set mcode ptr, BUG536(phx12688)
"Modified on 02/18/81 by FCH, [4.4-1], operator 93(alt_rewrite) added
"         Modified on 12/14/79 by PRP, cause ipr for bad overpunch data.
"Modified on 11/05/79 by PRP, prevent close if file previously open
"        Modified on 10/31/79 by PRP, pass more system error messages to user
"Modified on 09/06/79 by FCH, key of ref was being destroyed
"Modified on 08/24/79 by PrP, [4.0-3], alt_start_control added
"        Modified on 07/10/79 by MHD, [4.0-2], fix linage problem
"         Modified on 07/17/79 by PRP, [4.0-1], MPM standard for attach and detach files
"MODIFIED on 11/30/78 by FCH, [3.0-1], alternate record keys added
"Modified on 051678 by FCH, [3.0-1], save and restore $x6 
"        Modified on 09/20/77 by Peter Krupp to extend trace interface to COBOL programs
"Modified since Version 3.0 
"
"
"
"
"
"	/*{*/
"	cobol_operators_ segment
"	Bob Chang
"	March, 1976
"
" NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
"
"	To add a new operator:
"	(1). Insert the "tra" instruction before the line with the comment:
"	"	Please insert the next "tra" instruction before theis line.	
"	(2). Put the operator calling sequence number on "tra" instruction.
"	    The number is obtained by incrementing the last operator calling sequence
"	    number by 1.
"	(3). Insert the operator before the line with the comment:
"	"	Please insert the next operator before theis line.	
"	(4). Be sure that no "end" statement exists at the end of the operator segment
"	    which is to be inserted into cobol_operators_.
"	(5). Please put some comment before the operator.
"
" NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
"
	name	cobol_operators_
"	/*}*/

	use	text1
	use	text2
	use	text3
	use	text4
	use	text5
	join	/text/text1,text2,text3,text4,text5
	use	text1
	include	stack_header
	include	stack_frame
	include	eis_bits
"
	segdef	operator_table
	segdef	cobol_operators_
"
"	Definitions of variables used by operators.  Since all
"	of the operators execute using the stack frame of the
"	cobol program for their temporary storage, locations 32-61
"	of the cobol stack frame are reserved for operator use.
"
"	sp|6 has been reserved for probe.
"
	equ	cobol_code,1	code identifying cobol compiled prog
	equ	maxpr,71		max precision of double fixed
"
	equ	display_ptr,32
	equ	descriptor_ptr,34
	equ	linkage_ptr,36
	equ	on_unit_ptr,30
	equ	op_return_offset,31
	equ	text_base_ptr,38
	equ	text_base_off,39
	equ	mcode,40
	equ	icode,41
	equ	status12,42
	equ	status3,43
	equ	retrycode,44
	equ	return_to_main_ptr,64
	equ	return_to_main_off,65
	equ	rts_code_ptr,66
	equ	rts_code,72
	equ	cobol_error_code,89
"
"	Definitions for cobol linkage variables used by operators.
"
	equ	cobol_data_ptr,8
	equ	control_ptr,10
	equ	ind_mask,116
	equ	file_info_ptr,12
	equ	call_cnt,14
	equ	x6_save,100		[3.0-1]
	equ	subr_return_save,106
	equ	subr_return_save_off,107
	equ	pr4_save,108
	equ	rts_save,114
	equ	pr3_save,110
	equ	pr5_save,112
"
	equ	ap,0	TEMP
	equ	ab,1	TEMP
	equ	bp,2	TEMP
	equ	bb,3	TEMP
	equ	sp,6	TEMP
"
	bool	blank,40
"
cobol_operators_:
"
" THE FOLLOWING SECTION IS DIRECTLY REFERENCED FROM cobol PROGRAMS BY MEANS OF
" ap|offset.  FOR THIS REASON, THE ORDER OF THE FOLLOWING INSTRUCTIONS MUST
" NOT BE CHANGED.
"
	even
operator_table:
"
"	transfer vector for operators not referenced directly
"	by the cobol program.  new operators may be added at the
"	end of the list only.
"
op_vector:
entry_operators:
	tra	call_ent_var_desc	0
	tra	call_ent_var	1
	tra	call_ext_in_desc	2
	tra	return_mac	3
	tra	call_ext_in	4
	tra	call_ext_out_desc	5
	tra	call_ext_out	6
	tra	opch		7
	tra	enable		8
	tra	enable_1		9
	tra	sort_entry_seq	10
	tra	sort_release	11
	tra	runtime_check	12
	tra	sort_return	13
	tra	sort_initiate	14
	tra	real_to_real	15
	tra	establish_cleanup	16
	tra	sort_terminate	17
	tra	revert_cleanup	18
	tra	sort_comp		19
	tra	accept_line	20
	tra	init_start	21
	tra	sort_commence	22
	tra	start_control	23
	tra	set_lin_file_status	24
	tra	set_file_status	25
	tra	dsply_user_output	26
	tra	close_file	27
	tra	dsply_error_output	28
	tra	close_op_file	29
	tra	open_ext_file	30
	tra	open_int_file	31
	tra	find_iocb		32
	tra	check_attach	33
	tra	attach_iocb	34
	tra	open_file		35
	tra	open_close_file	36
	tra	check_file	37
	tra	close_file_only	38
	tra	init_write	39
	tra	write_stream	40
	tra	seek_key		41
	tra	write_record	42
	tra	stop_literal	43
	tra	accept_date	44
	tra	accept_day	45
	tra	accept_time	46
	tra	accept_day_of_week	47
	tra	stop_run		48
	tra	cancel		49
	tra	inspect_tally	50
	tra	inspect_replace	51
	tra	linage		52
	tra	delete		53
	tra	delete_error	54
	tra	read_key		55
	tra	init_delete	56
	tra	special_delete	57
	tra	special_rewrite	58
	tra	rewrite		59
	tra	merge_init	60
	tra	merge_comp	61
	tra	merge_return	62
	tra	init_read		63
	tra	get_line		64
	tra	read_record	65
	tra	nonseq_read_record	66
	tra	read_seek_key	67
	tra	write_stream_linage	68
	tra	read_key_for_read	69
	tra	receive_comm	70
	tra	accept_comm	71
	tra	purge_comm	72
	tra	send_comm		73
	tra	enable_comm	74
	tra	disable_comm	75
	tra	close_reel	76
	tra	init_cd		77
	tra	alt_open_file		78	[3.0-1]
	tra	alt_start			79	[3.0-1]
	tra	alt_read_next		80	[3.0-1]
	tra	alt_read_record		81	[3.0-1]
	tra	alt_seek_key		82	[3.0-1]
	tra	alt_start_control		83	[4.0-3]
	tra	alt_read_key		84	[3.0-1]
	tra	alt_special_delete		85	[3.0-1]
	tra	alt_delete		86	[3.0-1]
	tra	alt_key_delete		87	[3.0-1]
	tra	alt_rewrite_add		88	[3.0-1]
	tra	alt_close_file		89	[3.0-1]
	tra	alt_add_write_keys		90	[3.0-1]
	tra	alt_write_seek_key		91	[3.0-1]
	tra	alt_find_rec		92	[3.0-1]
	tra	alt_rewrite		93	[4.4-1]
	tra	stop_cd_run		94	[4.4-3]
"	Please insert the next tra instruction before this line.
"
"

"	****************************************
"
"	The following operators are high used operators.
"
"	****************************************
"


"	operators to call an entry variable
"	entered with pointer to entry in bp and number
"	of arguments in position in a, offset of arg list is in x0
"
call_ent_var_desc_from_op:
	eaq	0,au		there are descriptors
	tra	call_ent_var_from_op		do not use x0
call_ent_var_desc:
	eaq	0,au		there are descriptors
"
call_ent_var:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
call_ent_var_from_op:
	ora	4,dl		insert cobol code
	epbpsb	sp|0		get ptr to base of stack
	staq	sb|0,1		save at head of list
	eppbp	bp|0,*		and ptr to entry
save_display:
	eppap	sb|0,1		get ptr to arg list
var_call:
	sti	sp|stack_frame.return_ptr+1
	callsp	bp|0		and transfer to entry
"
"	operator to call an external procedure (same or diff seg).
"	entered with pointer to entry in bp and number of args
"	in position in a, offset of arg list is in x0
"
call_ext_in_desc_from_op:
call_ext_out_desc_from_op:
	eaq	0,au		there are descriptors
	tra	call_ext_in_from_op		do not use x0
call_ext_in_desc:
call_ext_out_desc:
	eaq	0,au		there are descriptors
"
call_ext_in:
call_ext_out:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
call_ext_in_from_op:
call_ext_out_from_op:
	epbpsb	sp|0		get ptr to base of stack
	ora	4,dl		insert cobol code (do this for now)
	staq	sb|0,1		save at head of list
	eppap	sb|0,1		get pointer to arg list
"
"	This label is 'segdef'ed but is never transfered to directly. The segdef is
"	merely to allow default_error_handler to see if a fault occured as a result
"	of this particular instruction so that it can print a more informative
"	error message.
"
forward_call:
	sti	sp|stack_frame.return_ptr+1
	callsp	bp|0		transfer to entry
"
"

" Macro to generate the calling sequence for <trace>|[catch_pl1_].  When
" invoked by the COBOL entry operator it will allow trace to monitor COBOL calls
" to external procedures. (P. Krupp 09/20/77)

          macro     trace
"         BEGIN MACRO trace
          ife       &1,trace_
          epaq      *                       get segment number of cobol_operators_
          lprp4     7|stack_header.lot_ptr,*au  cobol_operators_ linkage pointer
          sprp2     7|stack_header.stack_end_ptr,* save entry pointer
          tsp2      <trace>|[catch_pl1_]           invoke trace
          lprp2     7|stack_header.stack_end_ptr,* restore entry pointer
	ldx0	2|3 restore relocation offset
ifend
"         END MACRO trace
          &end

" Macro to generate code for the COBOL entry operator.  The macro will generate
" code for two entry operators.  One for normal use and the other for using trace
" in conjunction with COBOL programs.  (P. Krupp 09/20/77)
          macro     cobol_entry
"         BEGIN MACRO cobol_entry
"
"
"	entry for entry_version_1.
"	entry for setting up the pr0 for cobol operators_ and initializing
"	the stack frame and/or header.
	segdef	&1entry_version_1
&1entry_version_1:
	ldx0	bp|0		get the relocation offset
	eppbp	bp|-3		set pr2 to cobol entry location
          trace     &1
	epaq	bp|0		get segment number of text
	lprplp	sb|stack_header.lot_ptr,*au get seg no, offset of linkage from  packed ptr
	eppbb	sb|stack_header.stack_end_ptr,* get ptr to next stack frame
	sprisp	bb|stack_frame.prev_sp set back ptr of new frame
	spriap	bb|stack_frame.arg_ptr save arg pointer
	eppab	bb|0,7		get pointer to end of new frame
	spriab	bb|stack_frame.next_sp set next pointer of new frame
	spriab	sb|stack_header.stack_end_ptr set new stack end ptr
	eppsp	bb|0		update sp
"         END MACRO cobol_entry
          &end
          cobol_entry trace_
          tra       eed           trace has been invoked, finish rest of entry operator
          cobol_entry
eed:
	lda	ap|0		get 2*n_args in au, code in al
	cana	8,dl		is there an extra arg
	tze	2,ic		no
	ada	2,du		yes, allow for it
	eppbb	ap|2,au		get ptr to descriptors
	spribb	sp|descriptor_ptr	set ptr in stack frame
save_link:
	sprilp	sp|linkage_ptr	save ptr to linkage in stack head
	spribp	sp|stack_frame.entry_ptr save ptr to entry point
init_stack_join:
	spbpbp	sp|text_base_ptr	save ptr to base of text segment
	spbpbp	sp|return_to_main_ptr		set the segment number for cobol return location
	stz	sp|stack_frame.operator_ret_ptr init operator return offset
"
	eppap	operator_table	and pointer to operators
	spriap	sp|stack_frame.operator_ptr save pointer to operator segment
	spriab	sp|4		save pointer to end of frame for temp extensions
"		set the parameter for cobol_rts
"		pr6|68 and pr6|70 are reserved for cobol_rts_
	epp0	pr6|rts_code_ptr
	spri0	pr6|70		point to the storage for rts_code_ptr
	epp0	pr6|rts_code
	spri0	pr6|rts_code_ptr	point to the base of rts stack
	lda	pr2|6		get the cobol_rts_
	epp1	pr4|0,au*	obtain the link of cobol_rts_
	spri1	pr6|rts_save	store the rts_save
	fld	2048,dl
	ora	4,dl
	staq	pr6|68
	stz	pr6|73		set 0 for the use_code on error_stack
	epp4	pr4|0,0		get pr4 for operator
	spri2	pr6|return_to_main_ptr
	spri4	pr6|pr4_save	save for future use
	spri2	pr4|16		store stat.entry_ptr
	lda	pr4|call_cnt	get the call_cnt
	tpl	return_from_control	data already initialized
	spri4	pr6|74		store the parameter
	epp0	return_from_control	preset the return point
	spri0	pr6|stack_frame.return_ptr
	lda	2,dl		load rts_code for cobol_control
	sta	pr6|rts_code
	tra	call_rts_from_op		call cobol_control
	even
return_from_control:
	epp3	return_from_call	reset the return_ptr to cobol operators_
	spri3	pr6|stack_frame.return_ptr
	epp1	pr6|pr4_save,*	load pr4
	epp3	pr1|control_ptr,*
	lxl1	pr3|27
	anx1	1,du
	eaa	0,x1
	arl	7
	sta	pr6|ind_mask
	ldi	pr6|ind_mask
	epp3	pr1|cobol_data_ptr,*
	adwp3	16384,du
	spri3	pr6|pr3_save
	epp5	pr1|cobol_data_ptr,*
	adwp5	49152,du
	spri5	pr6|pr5_save
	epp0	pr6|stack_frame.operator_ptr,*
	spri0	pr6|subr_return_save set for subroutine calls within operators
	epp4	pr6|linkage_ptr,*
	epp2	pr6|stack_frame.entry_ptr,*
	aos	pr1|call_cnt	update the call_cnt
	lda	pr1|call_cnt	check the call_cnt
	tnz	bp|6		skip one instruction, data already initialized.
	tra	bp|5
"
"
"	The operator for saveing the pointer register pr0, pr3 and pr5
"
	even
return_from_pl1_op:
	epbp0	pr6|return_to_main_ptr,*		reset the text base ptr to normal
	spri0	pr6|text_base_ptr
	even
return_from_call:
	ldi	pr6|ind_mask
	epp4	pr6|linkage_ptr,*		reload pr4
	epp3	pr6|pr3_save,*		reload pr3
	epp5	pr6|pr5_save,*		reload pr5
	epp0	pr6|stack_frame.operator_ptr,*	reload pr0
	tra	pr6|return_to_main_ptr,*		return to the cobol program
"
"	The label for  io return.
"	It skip one instruction in cobol program and reset  return_ptr to normal
"
	even
io_return_to_reset:
	lda	1,du		skip one instruction for io return
	asa	pr6|return_to_main_off
"
"	The label for reset the return_ptr before return.
"
	even
return_to_reset:		
	epp0	return_from_call	reset return_ptr back to normal
	spri0	pr6|stack_frame.return_ptr
	tra	return_from_call
"
"
"
"
"	The operator for calling the cobol_rts_ routine.
"
"
call_rts:
	epp2	pr6|rts_code		get the  stack pointer for rts
call_rts_special:
	spri2	pr6|rts_code_ptr		sotre the cobol_rts parameter
call_rts_load_code:
	sta	pr6|rts_code
"		call from cobol operator  and the parameter is set already
call_rts_from_op:
	epp2	pr6|rts_save,*		get cobol_rts_
	epbp7	pr6|0	set the stack header pointer
	epp0	pr6|68		set the argument pointer
	callsp	bp|0
"
"
"
"
"
"
"	The operator for the DISPLAY.
"		PR5 set to display area info.
"
"
"		main line code tsx0	pr0|32 = dsply_user_output, and
"			     tsx0	pr0|34 = dsply_error_output.
dsply_error_output:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp4	pr6|pr4_save,*
	epp1	pr4|50		pointer to iox_$error_output
	lda	4,dl		use retrycode as error switch
	tra	display_op
dsply_user_output:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp4	pr6|pr4_save,*
	epp1	pr4|48		pointer to iox_$user_output
	lda	3,dl		use retrycode as error switch
display_op:
	tsx6	pr0|subr_put_chars
	szn	pr6|mcode
	tze	io_return_to_reset	display good, NO retry
	lda	pr6|retrycode
	sta	pr6|cobol_error_code
	tra	cobol_error_from_op	output error message, and retry
"
"
"
"	The sort entry for compare procedure.
"
sort_entry_seq:
	eppbp	bp|-4
	eppbb	sb|stack_header.stack_end_ptr,* get ptr to next stack frame
	sprisp	bb|stack_frame.prev_sp set back ptr of new frame
	spriap	bb|stack_frame.arg_ptr save arg pointer
	eppab	bb|0,7		get pointer to end of new frame
	spriab	bb|stack_frame.next_sp set next pointer of new frame
	spriab	sb|stack_header.stack_end_ptr set new stack end ptr
	eppsp	bb|0		update sp
	epp3	return_from_call	reset the return_ptr to cobol operators_
	spri3	pr6|stack_frame.return_ptr
	spri3	pr6|pr3_save	save any pointer in case of restoration
	spri3	pr6|pr5_save	save any pointer in case of restoration
	spri3	pr6|pr4_save	save any pointer in case of restoration
	spri3	pr6|linkage_ptr
	lda	ap|0		get 2*n_args in au, code in al
	cana	8,dl		is there an extra arg
	tze	2,ic		no
	ada	2,du		yes, allow for it
	eppbb	ap|2,au		get ptr to descriptors
	spribb	sp|descriptor_ptr	set ptr in stack frame
	spribp	sp|stack_frame.entry_ptr save ptr to entry point
	spbpbp	sp|text_base_ptr	save ptr to base of text segment
	eppap	operator_table	and pointer to operators
	spriap	sp|stack_frame.operator_ptr save pointer to operator segment
	tra	bp|5
"
"
"	init_write check file condition
"
"
init_write:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		set pr 1
	stz	pr6|icode		reset on each entry to zero
	szn	pr1|2		is file opened
	tnz	pr6|text_base_ptr,*0  YES,
"	set status
	lda	io30_con
	ldq	s4031con
	staq	pr6|status12
	ldx1	24,du		attempt to perform io on an unopened file
	tra	return_thru_text_base_pone
"
"
"	write_stream  call  iox_$put_chars	OPERATOR(40)**********
"
"
write_stream:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		set iocb_ptr
	tsx6	pr0|subr_put_chars
	szn	pr6|mcode
	tze	return_to_reset
	tra	write_stream_error
"
"				**********OPERATOR(68)**********
"
"
write_stream_linage:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		set iocb_ptr
	tsx6	pr0|subr_put_chars
	epp1	pr6|86,*		reset pr 1
	lda	pr6|47		load A with advancing value
	dtb	(pr),(pr)		store cobol_fsb.linage_counter into stack word
	desc9ns	pr1|88,6,0
	desc9a	pr6|46,4
"	lxl3 	0,dl
"	szn 	pr6|46		if linage counter  zero then set to one
"	tnz	8,ic		NOT zero then bypass
"	aos	pr6|46		set linage counter to one start of new page
"	lxl3	1,dl
"	stz	pr6|icode	reset, as linage counter is 1
"	btd	(pr),(pr)
"	desc9a	pr6|46,4
"	desc9ns	pr1|88,6,0
"	tra	8,ic
          szn       pr6|46              [4.0-2], by MHD
          tnz       2,ic                [4.0-2], by MHD
          lda       1,dl                [4.0-2], by MHD
	ada	pr6|46		increment linage counter by advancing value
	sta	pr6|46		store new linage_counter
	btd	(pr),(pr)		store stack word into cobol_fsb.linage_counter
	desc9a	pr6|46,4
	desc9ns	pr1|88,6,0
	cmpa	pr1|93		is new linage_counter >= footing
	tmi	cont_write_stream
	lda	pr6|41
	tze	return_to_reset
	tra	io_return_to_reset
cont_write_stream:
	szn	pr6|mcode
	tze	return_to_reset
"	set status
write_stream_error:
	lda	io30_con
	ldq	s4430con
	staq	pr6|status12
	ldx1	21,du		unable to write record
	tra	io_return_to_reset
"
"
"	seek_key	call iox_$seek_key	OPERATOR(67)**********
"
"
read_seek_key:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	1,dl
	sta	pr6|54
	tra	seek_common
"
"				**********OPERATOR(41)**********
"
"
seek_key:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	stz	pr6|54		for write
seek_common:
	spri1	pr6|86		set iocb_ptr
	epp2	pr1|7
	spri2	pr6|88		store pointer to key area
	epp2	pr6|62		work area not used as seek key returns length
	spri2	pr6|90		store pointer to key len
	lda	16,dl
	sta	pr6|rts_code	store rts code
	tsx6	pr0|subr_seek_op
	szn	pr6|mcode
	tze	return_to_reset
"	set status
	ldx1	26,du
	szn	pr6|54		read or write?
	tnz	io_return_to_reset	read.
	lda	io30_con
	ldq	s4632con
	staq	pr6|status12
	tra	io_return_to_reset
"
"
"	SUBROUTINE to iox_$seek_key
"
"
subr_seek_op:
	stx6	pr6|subr_return_save_off
	epp2	pr6|mcode
	spri2	pr6|92		store pointer to mcode
	spri2	pr6|76		mcode_ptr
	eax1	pr6|84
	fld	8192,dl		4 args
	epp2	pr1|0,*
	epp2	pr2|74		offset for iox_$seek_key
	epp0	return_seek_key
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op
return_seek_key:
	epp4	pr6|linkage_ptr,*	reset linkage pointer
"	rts code must be set by caller to this SUBROUTINE
	epp0	pr6|subr_return_save,* EXIT FROM SUBROUTINE
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op	handle seek errors
"
"
"	SUBROUTINE to set up for iox_$write_record and iox_$rewrite_record
"
"
subr_write_record:
	stx6	pr6|subr_return_save_off
	epp1	pr6|86,*		reset pr 1
	spri5	pr6|78		store_buff_ptr
	epp2	pr6|78
	spri2	pr6|88		store pointer to buffptr
	epp2	pr6|80
	spri2	pr6|90		store pointer to buff_len
	epp2	pr6|mcode
	spri2	pr6|92
	eax1	pr6|84
	fld	8192,dl		4 args
	epp2	pr1|0,*
	tra	pr6|subr_return_save,* EXIT FROM SUBROUTINE
"
"				**********OPERATOR(42)**********
"	write record op		call iox_$write_record
"
"
write_record:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	tsx6	pr0|subr_write_record
	epp2	pr2|62		offset for iox_$write_record
	epp0	return_write_record
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op
return_write_record:
	szn	pr6|mcode
	tze	return_to_reset
"	set status
	lda	io30_con
	ldq	s4432con
	staq	pr6|status12
	ldx1	41,du		Write is an invalid operatoin for current open mode
	tra	io_return_to_reset
"
"
"	SUBROUTINE to put_chars
"
"
subr_put_chars:
	stx6	pr6|subr_return_save_off
	sta 	pr6|retrycode
	spri1	pr6|86		set iocb_ptr
	spri5	pr6|78		store buff_ptr
	epp2	pr6|78
	spri2	pr6|88		store pointer to buff_ptr
	epp2	pr6|80
	spri2	pr6|90		store pointer to buff_len
	epp2	pr6|mcode
	spri2	pr6|92		store pointer to mcode
	eax1	pr6|84
	fld	8192,dl		4 args
	epp2	pr1|0,*		indirect thru fsb to iocb
	epp2	pr2|42		offset for iox_$put_chars
	epp0	pr6|subr_return_save,* EXIT FROM SUBROUTINE
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op	call iox_$put_chars
"
"
"	linage
"		A reg set with advancing value
"
"
linage:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
          lxl3      0,dl                [4.0-2], by MHD
	epp1	pr6|86,*		reset pr 1
	cmpa	1000,dl 		Is the PAGE  force value
	tze	force_page	YES,
	lda	pr6|47
	ldq	pr6|47
	sta	pr6|81		set advancing value
	adq	pr6|80		increment Q with buff length
	stq	pr6|81		= buff length +advancing value
	dtb	(pr),(pr)		store the linage_counter into a stack word
	desc9ns	pr1|88,6,0
	desc9a	pr6|46,4
	ada	pr6|46		increment A with current linage_counter
	cmpa	pr1|92		is linage_counter + advancing value > page_size
	tpnz	finish_curr_page	YES, do finish current page,include TOP, LC = 1
	lda	pr6|80		reset  A to buff length
	ldq	pr6|47		reset q to adv value
	btd	(pr),(pr)
	desc9a	pr6|46,4
	desc9ns	pr1|88,6,0
	tra	return_to_reset
force_page:
finish_curr_page:
	ldq	pr1|92		load Q with page_size
	sbq	pr6|46		subtract linage_counter from Q
	adq	1,dl
	adq	pr6|80		add advancing + buff length
	adq	pr1|94		add top_size to Q
	adq	pr1|95		add bottom_size to Q
	stq	pr6|81		= total amount from last write to new write on next page
	stz	pr6|46		initialize linage_counter to 0
	btd	(pr),(pr)		store the stack word back to the linage counter
	desc9a	pr6|46,4
	desc9ns	pr1|88,6,0
          lxl3      1,dl                [4.0-2],by MHD. shows page overflow occured
	lda 	pr6|80		reset A to length of buffer
	ldq	pr6|47		reset q to adv value
	tra	return_to_reset
"
"
"	Please insert the new highly used cobol operator before this line.
"
"

"	****************************************
"
"
"
"	This is the overpunch operator.
"
"	****************************************
"
"


"
"
cobol_opch_operator_:
opch:
"	Modified on 3/12/76 by Bob Chang for cobol operator.
"
"  This ALM procedure is the cobol_operator_ that does conversion
"  to and from overpunch sign decimal data.
"  For this first implementation some simplifying assumptions are made:
"	1.  Only three formats of data can be converted.
"		a. unpacked decimal, trailing sign.
"		b. overpunch decimal, leading sign.
"		c. overpunch decimal, trailing sign.
"
"	2.  Before this operator is called, any data, other than overpunch
"	    or unpacked decimal trailing sign, is converted to unpacked
"	    decimal trailing sign data in a temporary.
"
"  Subsequent implementations may provide for direct conversion by this
"  operator of the following data formats:
"	1. long fixed binary
"	2. short fixed binary
"	3. packed decimal, leading or trailing sign
"
"  ENTRY CONDITIONS
"
"  Data is passed to this operator in the following registers:
"
"  
"  1. pr1 points to the target of the conversion.
"  
"  2. pr2 points to the source of the conversion.
"  
"  3. pr5 points to a block of work space, at the top of the
"  stack.  This work space must be aligned on a double word
"  boundary.
"  
"  4. Q register contains the scale and precision of the source of
"  conversion.
"  
"  	a. bits 0-17 of the Q register contains the scale.
"  	Scale is obtained from data_name.places_right of a
"  	data name token.
"  
"  	b. Bits 18-36 of the Q contain precision.
"  	Precision is obtained from data_name.item_length of a
"  	data name token.
"  
"  5. A register contains the scale and precision of the target
"  of conversion.  Bits 0-17 contain the scale,
"  bits 18-36 contain the precision.  Scale and precision are obtained
"  as for the source of conversion.
"  
"  6. X7 contains a code that identifies the data type of the
"  source of conversion.  This code is defined in the following
"  table:
"  
"  	x7 contents	| type of source
"  	__________________________________________
"  	     1		| overpunch,leading sign
"  	     2		| overpunch, trailing sign
"  	     3		| unpacked decimal, trailing sign
"  
"  7. X6 contains a code that identifies the data type of the
"  target of conversion.  This code is the same as that described
"  above for X7.
"  
"  8. pr3 is used to store the location to which the cobol
"  overpunch conversion operator is to return.
"  
	segdef	cobol_opch_operator_


"  definition of offsets within the work space

	equ	scales,0
	equ	s_scale,1
	equ	t_scale,0
	equ	temp1,2
	equ	temp2,3
	equ	temp3,4
	equ	source_desc,5
	equ	target_desc,6
	equ	pr_store,8
	equ	x_store,10
	equ	save_t_scale,11
	equ	temp_source,12
	equ	udts_source_ret,32
	equ	opch_udts_ret,33
	equ	opch_opch_ret,34

"  definition of the names of pointer registers

	equ	work_pr,5
	equ	source_pr,2
	equ	target_pr,1
	equ	return_pr,3


" ***************************************
"				*
" *  ENTRY POINT			*
" *				*
" ***************************************


cobol_opch_operator_:
	spri3	pr6|return_to_main_ptr
	staq	work_pr|scales




	cmpx7	3,du	is source unpacked decimal?
	tnz	opch_source	no, must be overpunch
	tsx5	udts_source	yes
	tra	operator_exit

opch_source:

	cmpx6	3,du	Is destination unpacked decimal?
	tnz	opch_dest	no, must be overpunch

udts_dest:
	tsx5	opch_udts
	tra	operator_exit

opch_dest:
	tsx5	opch_opch

operator_exit:
	epp7	pr3|0
	epp4	pr6|linkage_ptr,*
	epp3	pr6|pr3_save,*
	epp5	pr6|pr5_save,*
	tra	pr7|0

" **************************************
" *     udts_source			*
" ***************************************

udts_source:

	stx5	work_pr|udts_source_ret  store return point

"  calculate the number of characters to move from the source, and the character
"  position in the source at which to start the move

	tsx5	calc_length

"  Set up to insert scale factors into the indirect descriptors

	lda	dec_ns_source_desc
	ldq	opch_target_desc
	tsx5	insert_scale_factor

"  Move the source to the target with scaling, but without moving the sign

	mvn	(pr,rl,id,x2),(pr,rl,id)
	arg	work_pr|source_desc
	arg	work_pr|target_desc

"  Get the character offset of the sign byte of the source

	lxl1	work_pr|s_scale
	adx1 	-1,du

"  Test to see if the sign is plus or minus

	cmpc	(pr,x1),(0,0),fill(000)
	desc9a	source_pr|0,1
	desc9a	plus_sign,1

	tze	trailing_dec_plus

"  Must be trailing minus sign

	ldx2	1,du	set to indicate trailing sign was negative

	tra	check_target_sign

trailing_dec_plus:

	ldx2	0,du	offset of plus overpunch characters in the dec_to_op_sign table

check_target_sign:

"  Determine whether target is leading or trailing sign overpunch.

	cmpx6	2,du	Is target trailing sign overpunch?
	tze	op_ts	yes

"  Must be leading sign overpunch

	ldx3	0,du
	tra	insert_op_sign

op_ts:

"  Calculate the offset of the last byte in the target

	lxl3	work_pr|t_scale
	adx3	-1,du

insert_op_sign:

"  Insert the overpunch character into the leading or trailing byte of the target.
	cmpx2	0,du
	tnz	insert_neg_op	trailing sign was negative

	mvt	(pr,x3),(pr,x3),(0,0),fill(000)
	desc9a	target_pr|0,1
	desc9a	target_pr|0,1
	arg	plus_dec_op_sign_table
	tra 	udts_source_exit
insert_neg_op:

	mvt	(pr,x3),(pr,x3),(0,0),fill(000)
	desc9a	target_pr|0,1
	desc9a	target_pr|0,1
	arg	minus_dec_op_sign_table


udts_source_exit:



"  Return to the entry sequence of this program

	ldx5	work_pr|udts_source_ret  restore return point
	tra	0,x5  return

" **************************************
" *     opch_udts			*
" ***************************************

opch_udts:

	stx5	work_pr|opch_udts_ret  store return point
"  Move the overpunch sign source into an unpacked decimal unsigned temporary.

	tsx5	unpack_opch

"  Move the sign from the sign table into the trailing sign byte of the temporary
"  Note that x1 contains the length of the source, which is the character position of 
"  the trailing sign byte.

	mlr	(x3),(pr,x1)
	desc9a	sign_table,1
	desc9a	work_pr|temp_source,1

"  Calculate the length of the temporary to move, and the character position at which 
"  to start the move.

	tsx5	calc_length

"  Increment length of source, because length was derived for overpunch source, and we 
" are moving an unpacked decimal, trailing sign temporary.

	adx1	1,du

"  Set up to insert the scale factor into the indirect descriptors.

	lda	dec_ts_temp_source_desc
	ldq	dec_ts_target_desc
	tsx5	insert_scale_factor

"  Move the unpacked dec, trailing sign temporary to the unpacked dec, target

	mvn	(pr,id,rl,x2),(pr,id,rl)
	nop	work_pr|source_desc
	nop	work_pr|target_desc

"  Return to the calling sequence

	ldx5	work_pr|opch_udts_ret
	tra	0,x5

" **************************************
" *     opch_opch			*
" ***************************************

opch_opch:

	stx5	work_pr|opch_opch_ret  store return point

"  Store the pointer to the target field and the type code of the target

	spri1	work_pr|pr_store
	stx6	work_pr|x_store

"  Set pointer to target to a temporary.  Set the target type code to unpacked decimal

	epp	target_pr,work_pr|temp_source
	ldx6	3,du

"  Save the scale and precision of the original target
	lda	work_pr|t_scale
	sta	work_pr|save_t_scale
"  Increment the precision of the target, since we are
"  adding a trailing sign byte when converting to unpacked decimal.
	lxl1	work_pr|t_scale
	adx1	1,du
	sxl1	work_pr|t_scale
"  Convert the overpunch source to an unpacked decimal into the temporary

	tsx5	opch_udts

"  Set the source pointer to the imal temporary, and the source type code to 
"  unpacked decimal.

	epp	source_pr,target_pr|0
	ldx7	3,du

"  unpacked decimal target now becomes the source
"  Set source scale and precision to the scale and precision of the
"  unpacked decimal temporary.
	lda	work_pr|t_scale
	sta	work_pr|s_scale

"	restore the target scale and precision
	lda	work_pr|save_t_scale
	sta	work_pr|t_scale


"  Restore the target pointer and type code to the overpunch target

	epp	target_pr,work_pr|pr_store,*
	ldx6	work_pr|x_store

"  Convert the unpacked dec temporary to the overpunch sign target

	tsx5	udts_source

	"  Return to the calling sequence

	ldx5	work_pr|opch_opch_ret  restore return point
	tra	0,x5  return



" ***************************************
" *     unpack_opch*
" ***************************************

unpack_opch:

"  Move the overpunch sign source into a temporary

	lxl1	work_pr|s_scale	get length of source

	mlr	(pr,rl),(pr,rl)
	desc9a	source_pr|0,x1
	desc9a	work_pr|temp_source,x1

"  Get the character position of the overpunch sign character into x2

	cmpx7	1,du	Is source leading overpunch sign?
	tnz	t_opch	no
	ldx2	0,du	Yes, overpunch character is in zeroth byte position
	tra	common1

t_opch:

	lxl2	work_pr|s_scale	get length of source
	adx2	-1,du  	Decrement by one to get char position of last byte

common1:

"  Translate the overpunch sign character into a subscript into the digit_table and sign_table

	stz	work_pr|temp1
	mvt	(pr,x2),(pr)
	desc9a	source_pr|0,1
	desc9a	work_pr|temp1(1),1
	arg	mvt_table

"  Load the subscript into x3

	ldx3	work_pr|temp1

"  Test to see if overpunch char is legal.
	adx3	-1,du
	tmi	bad_oph
"  Char OK keep going

"  Move the digit from the digit table into the leading or trailing byte of the temporary.

	mlr	(x3),(pr,x2)
	desc9a	digit_table,1
	desc9a	work_pr|temp_source,1

"  Return to the calling sequence

	tra	0,x5

"  Cause ipr for bad overpunch char.
bad_oph:
	stx3	work_pr|temp1
	cmpn	(pr),(pr)
	desc9a	work_pr|temp1(1),1
	desc9a	work_pr|temp1(1),1
" ***************************************
" *     calc_length			*
" ***************************************

calc_length:

"  This sequence of code calculates:
"  	1.  The length of the source field to be moved. (Returned in x1)
"	2. The character offset of the leftmost character of the source field
"	to be moved. (Returned in x2)
"	The length of the target field. (Returned ix x3)

"  	The calling sequence return point is contained in x5, so x5 must not be modified by
"	this code.  Also x4 is used as a work register.

"  Calculate source places left

	lxl2	work_pr|s_scale	precision (length) of source
	cmpx7	3,du	is source unpacked decimal?
	tnz	s_non_dec	no
	adx2	-1,du	decrement length to exclude the sign byte

s_non_dec:

	stx2	work_pr|temp1
	ldx1	work_pr|temp1	load length into x1
	sbx2	work_pr|s_scale	subtract scale to get source places left in x2.

"  Calculate destination places left

	lxl4	work_pr|t_scale	precision (length) of the target
	lxl3	work_pr|t_scale
	cmpx6	3,du	Is target unpacked decimal?
	tnz	t_non_dec	no
	adx4	-1,du	decrement by 1 to exclude the sign byte

t_non_dec:
	stz	work_pr|temp1
	stx4	work_pr|temp1

"  Subtract scale to get target places left

	sbx4	work_pr|t_scale
	stx4	work_pr|temp1	save places left

"  Subtrace target places left from source places left.

	ssx2	work_pr|temp1

	tmoz	target_big_enough

"  Target places left less than source places left,  must adjust source legnth.

"  Note that if the difference is positive, it contains the character position at which to start moving characters

	ldx2	work_pr|temp1
	sbx1	work_pr|temp1	adjust length
	tra	calc_length_return

target_big_enough:

"  It is not necessary to start the move at a characterhother than the first.  Set x2 to zero, so
"  that the first character in the source will be moved.

	ldx2	0,du

calc_length_return:

	tra	0,x5

" ***************************************
" *     insert_scale_factor		*
" ***************************************

insert_scale_factor:

"  This sequence of code inserts the scale factor of the source and target fields into indirect
"  descriptors.

"  ENTRY CONDITIONS
"	1. A register contains the source field indirect descriptor
"	2. Q register contains the target field indirect descriptor
"	3.  x5 conatins the return address.

"  Insert scale factor into the source indirect descriptor

	sta	work_pr|source_desc
	lda	work_pr|s_scale	scale factor in upper
	ars	18	extend sign
	neg
	als	6	shift to SF position
	ana	scale_factor_mask	and out junk
	orsa	work_pr|source_desc	insert SF inot indirect descriptor

"  Insert scale factor into the target indirect descriptor

	stq	work_pr|target_desc
	lda	work_pr|t_scale	scale factor in upper of a now
	ars	18	extend sign
	neg
	als 	6	shift to SF position
	ana	scale_factor_mask	mask out junk
	orsa	work_pr|target_desc	insert SF into indirect descriptor

"  Return to caller

	tra	0,x5

" ***************************************
" *     CONSTANTS AND TABLES		*
" ***************************************

dec_ts_temp_source_desc:
	desc9ts	work_pr|temp_source,x1,0

dec_ts_target_desc:
	desc9ts	target_pr|0,x3,0

dec_ns_source_desc:
	desc9ns	source_pr|0,x1,0

opch_target_desc:
	desc9ns	target_pr|0,x3,0

dec_ns_temp_source_desc:
	desc9ns	work_pr|temp_source,x1,0

scale_factor_mask:
	oct	000000007700

plus_sign:
	aci	/+/


plus_dec_op_sign_table:
empty1:
	oct	0
	oct	0
sign_table:
	aci	/++++/
minus_dec_op_sign_table:
	aci	/++++/
	aci	/++--/
	aci	/----/
	aci	/----/
digit_table:
	aci	/0123/
	aci	/4567/
	aci	/8901/
	aci	/2345/
	aci	/6789/
	aci	/{ABC/     PLUS OVERPUNCH DIGITS
	aci	/DEFG/     PLUS OVERPUNCH DIGITS
	aci	/HI  /     PLUS OVERPUNCH DIGITS
	aci	/}JKL/     MINUS OVERPUNCH DIGITS
	aci	/MNOP/     MINUS OVERPUNCH DIGITS
	aci	/QR  /     MINUS OVERPUNCH DIGITS
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
mvt_table:
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	001002003004
	oct	005006007010
	oct	011012000000
	oct	0
mvt_data1:
	oct	000002003004	maps overpunch digits into subscript into sign_table 
	oct	005006007010	and digit_table.
	oct	011012014015	   ditto
	oct	016017020021	   ditto
	oct	022023024000	   ditto
empty2:
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
mvt_data2:
	oct	000000000001	maps "{" into digit_table and sign_table
mvt_data3:
	oct	000013000000	maps "}" into digit_table and sign_table
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0
	oct	0

"
"
"
"  This  was added to get rid of a page of zeroes in the object segment
"  When the previos table reaches 2000 octal remove the following two statements
	org	1024
	nop	 1
	org	2048
	use	text2

	include	cobol_op_fix_con
"
"
"  This was  added to get rid of a page of zeroes in the object segment
"  When the previous table reaches  6030 octal remove the following two statements
	org	792
	nop	1
	org	1792
	use	text4

"	****************************************
"
"	This page is for the cobol_error. tra instruction.
"
"	****************************************
"
"
"
	tsx7	cobol_error_no_mcode	1
	tsx7	cobol_error_no_mcode	2
	tsx7	cobol_error		3
	tsx7	cobol_error		4
	tsx7	cobol_error_no_mcode	5
	tsx7	cobol_error		6
	tsx7	cobol_error		7
	tsx7	cobol_error_no_mcode	8
	tsx7	cobol_error_no_mcode	9
	tsx7	cobol_error_no_mcode	10
	tsx7	cobol_error		11
	tsx7	cobol_error		12
	tsx7	cobol_error		13
	tsx7	cobol_error		14
	tsx7	cobol_error		15
	tsx7	cobol_error		16
	tsx7	cobol_error_no_mcode	17
	tsx7	cobol_error		18
	tsx7	cobol_error		19
	tsx7	cobol_error_no_mcode	20
	tsx7	cobol_error		21
	tsx7	cobol_error		22
	tsx7	cobol_error_no_mcode	23
	tsx7	cobol_error_no_mcode	24
	tsx7	cobol_error		25
	tsx7	cobol_error		26
	tsx7	cobol_error		27
	tsx7	cobol_error_no_mcode	28
	tsx7	cobol_error		29
	tsx7	cobol_error		30
	tsx7	cobol_error		31
	tsx7	cobol_error		32
	tsx7	cobol_error_no_mcode	33
	tsx7	cobol_error_no_mcode	34
	tsx7	cobol_error_no_mcode	35
	tsx7	cobol_error_no_mcode	36
	tsx7	cobol_error		37
	tsx7	cobol_error		38
	tsx7	cobol_error_no_mcode	39
	tsx7	cobol_error_no_mcode	40
	tsx7	cobol_error         	41   [4.1-1]
	tsx7	cobol_error_no_mcode	42
	tsx7	cobol_error         	43  [4.1-1]
	tsx7	cobol_error_no_mcode	44
	tsx7	cobol_error_no_mcode	45
	tsx7	cobol_error_no_mcode	46
	tsx7	cobol_error_no_mcode	47
	tsx7	cobol_error_no_mcode	48
	tsx7	cobol_error_no_mcode	49
	tsx7	cobol_error		50
	tsx7	cobol_error		51
	tsx7	cobol_error		52
	tsx7	cobol_error_53		53
	tsx7	cobol_error		54
	tsx7	cobol_error		55
	tsx7	cobol_error		56
	tsx7	cobol_error		57
	tsx7	cobol_error		58
	tsx7	cobol_error_no_mcode	59
	tsx7	cobol_error_no_mcode	60
	tsx7	cobol_error_no_mcode	61
	tsx7	cobol_error_no_mcode	62
	tsx7	cobol_error_no_mcode	63
	tsx7	cobol_error_no_mcode	64
	tsx7	cobol_error_no_mcode	65
	tsx7	cobol_error_no_mcode	66
	tsx7	cobol_error_no_mcode	67
	tsx7	cobol_error_no_mcode	68
	tsx7	cobol_error_no_mcode	69
	tsx7	cobol_error_no_mcode	70
	tsx7	cobol_error_no_mcode	71
	tsx7	cobol_error_no_mcode	72
	tsx7	cobol_error_no_mcode	73
	tsx7	cobol_error_no_mcode	74
	tsx7	cobol_error_no_mcode	75
	tsx7	cobol_error_no_mcode	76
	tsx7	cobol_error_no_mcode	77
	tsx7	cobol_error_no_mcode	78
	tsx7	cobol_error_no_mcode	79
	tsx7	cobol_error_no_mcode	80
	tsx7	cobol_error_no_mcode	81
	tsx7	cobol_error_no_mcode	82
"
"
	org	1024
	use	text5

"
	include	cobol_op_var_con

"	****************************************
"
"	This page is for the cobol_error operator.
"
"	****************************************
"
"
cobol_error_no_mcode:
	stz	pr6|mcode
cobol_error:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	1,dl		Set the rts_code for cobol_error_
	sta	pr6|rts_code
	sbx7	4096,du		Get the cobol_error_code
	stz	pr6|89
	sxl7	pr6|89
	epp0	pr6|stack_frame.entry_ptr,*		Get the entry pointer
	stz	pr6|92		Zero out the line number
	stz	pr6|93
	ldx0	pr0|4		entry_seq for the symbol section
	tze	line_no_done
	epp4	pr6|pr4_save,*		load pr4
	epp0	pr4|0,0*		get the symbol section
	lxl0	pr0|14		get the area offset
	lxl1	pr0|6,0		get the upper bound offset
	stx1	pr6|76		store into temporary location
	ldx0	pr0|6,0		get the lower bound offset
	ldx1	pr0|0,0		start the loop
	cmpx1	pr6|return_to_main_off
	tze	7,ic		the current line number
	tpl	5,ic		the next line number
	cmpx0	pr6|76		check with the upper bound
	tpl	line_no_done	no line number obtainable
	adx0	2,du
	tra	-7,ic		back to loop
	sbx0	2,du
	lda	pr0|0,0		get_statement_map
	ldq	pr0|1,0		load seperately in case of odd loc.
	anaq	line_mask		mask the line number part.
	lrl	10		get the file number in a reg
	sta	pr6|93
	qrl	22		get the line number in q
	stq	pr6|92
line_no_done:
	epp0	pr6|return_to_main_ptr,*		get the error pointer
	spri0	pr6|94
	lda	1,dl		get the rts code 1
	sta	pr6|rts_code
	epp0	pr4|19		load the location of program name
	spri0	pr6|96
	lda	pr4|18		get program name length
	sta	pr6|98
	lda	pr6|mcode		get status code of multics
	sta	pr6|90
	tra	call_rts_from_op
"	constant for cobol_error
	even
line_mask:
	oct	000000777777
	oct	740000000000
"
"
"
"	******************************
"
"		cobol_error_53
"
cobol_error_53:
"	epp4	pr6|linkage_ptr,*		reload pr4 after call out
"	lda	6,dl		load rts code for sort_terminate
"	sta	pr6|rts_code
"	epp0	return_from_term		overset the return pointer
"	spri0	pr6|stack_frame.return_ptr
"	tra	call_rts_from_op
	even
return_from_term:
	lda	pr6|80		get the multics status code
	sta	pr6|mcode
cobol_error_from_op:
	ldx0	pr6|return_to_main_off	load x0 before transfer to cobol_error
	epp4	pr6|linkage_ptr,*		reload pr4 after call out
	epp0	return_from_call		reset the return pointer back to noraml
	spri0	pr6|stack_frame.return_ptr
	lxl7	pr6|89		get the cobol error code
	adx7	4096,du		put the adjust error  code into x7
	tra	cobol_error
"
"
"
"
"	Please insert the next cobol error operator before this line
"

"	****************************************
"
"	The following operators are low used operators.
"
"	****************************************


"
"	operator to do a procedure return
"
return_mac:
	epbpsb	sp|0		get ptr to base of stack
	inhibit	on
	sprisp	sb|stack_header.stack_end_ptr reset stack end pointer
	eppsp	sp|stack_frame.prev_sp,* pop stack
	inhibit	off
	epbpsb	sp|0		set sb up in case we just switched stacks
	eppap	sp|stack_frame.operator_ptr,* set up operator pointer
	ldi	sp|stack_frame.return_ptr+1
	rtcd	sp|stack_frame.return_ptr continue execution after call
"
"
"
"
"	operator to enable a condition.  calling sequence is:
"		eppbp	name
"		lxl6	name_size
"		tsx0	ap|enable
"		tra	on_unit_body
"		arg	on_unit	(snap & system flags in RHS if used)
"		tra	skip_around_body
"	body of on unit starts here
"
	include	on_unit
enable_1:

"
"
enable:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	sxl0	sp|stack_frame.operator_ret_ptr
	epp1	sp|text_base_ptr,*0
	lda	=o100,dl		is there a valid on_unit_list
	cana	sp|stack_frame.prev_sp check bit 29 of sp|stack_frame.prev_sp
	tnz	3,ic		non-zero means ok
	stz	sp|stack_frame.on_unit_rel_ptrs init ptr
	orsa	sp|stack_frame.prev_sp and set bit
"
	ldx1	sp|stack_frame.on_unit_rel_ptrs get rel ptr to first enabled unit
	tze	add_on		zero means chain empty
on_1:	cmpx1	pr1|0		is this the unit we want
	tze	have_on		yes, go process
	ldx1	sp|on_unit.next,1	no, get ptr to next on chain
	tnz	on_1		and repeat if end not reached
add_on:	ldx1	pr1|0		get rel ptr to new unit
	ldx0	sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit
	stx0	sp|on_unit.next,1	set next ptr of new unit
	stx1	sp|stack_frame.on_unit_rel_ptrs make new unit first on chain
have_on:	spribp	sp|on_unit.name,1	set name of new unit
	spri3	sp|on_unit.body,1	set ptr to body
	stz	sp|on_unit.size,1	clear size field
	sxl6	sp|on_unit.size,1	set size of unit name
	lxl0	pr1|0		get snap & system flags
	sxl0	sp|on_unit.flags,1	and save in on unit
	stz	sp|stack_frame.operator_ret_ptr
	epp3	pr6|pr3_save,*
	epp5	pr6|pr5_save,*
	tra	pr1|1		return to cobol program
"
"
"
"

"	****************************************
"
"	The following operators are used for sort interface.
"
"	****************************************
"


"
"	The operator for sort_commence
"						**********OPERATOR(22)**********
"
"
sort_commence:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
"						RTS(7)
	lda	7,dl		load  rts_code
	sta	pr6|rts_code
	epp0	return_from_sort_commence	set the return_ptr to special location
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op
	even
return_from_sort_commence:
	szn	pr6|80		check the status code	
	tze	sort_good		return to good sort label
	lda	56,dl		lda the error code and store
	sta	pr6|89
	tra	cobol_error_53
"
"	The operator for sort release
"		pr3 for the address od the data to be released
"		Q for the length of the data in bytes.
"						**********OPERATOR(11)**********
sort_release:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri3	pr6|74		store the data pointer
	stq	pr6|76		store the length of the data
"						RTS(4)
	lda	4,dl		store the rts_code
	sta	pr6|rts_code
	epp0	return_from_sort_release	set the return_ptr to special location
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op
	even
return_from_sort_release:
	szn	pr6|80		check the status code
	tze	sort_good		return to good sort label
	lda	52,dl		lda the error code and store
	sta	pr6|89
	tra	cobol_error_53
"
"
"						**********OPERATOR(13)**********
"
"		14 words in stack are needed
"
sort_return:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
"						RTS(5)
	lda	5,dl		load the rts_code
	sta	pr6|rts_code
	epp0	return_from_sort_return		lda the error code and store
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op
"
"
	even
return_from_sort_return:
	lda	pr6|80		check the status code
	tze	sort_good		return to good sort label
	lda	53,dl		load the error code
	sta	pr6|89
	tra	cobol_error_53
"
"
"
"
"	The operator for the sort initiate.
"	 It needs the following parameters:
"		pr3 for compare entry ptr
"		pr7 for sort_$noexit
"		x2 for the stack offset
"		14 word are used to set up parameter list for soit exit.
"
"						**********OPERATOR(14)**********
sort_initiate:
sort_exit:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	cmpx2	0,du		check same sort merge possibility
	tpl	5,ic
	epp0	pr6|pr4_save,*
	stx2	pr0|41		complement x2
	lcx2	pr0|41
	stz	pr0|41		for sort
	spri3	pr6|2,2		store the compare entry
	ldaq	null_con
	staq	pr6|4,2
	stz	pr6|0,2		store 1 in the version number
	aos	pr6|0,2
	epp3	pr6|0,2		get pointer for the exit ptr
"
sort_initiate_call:
	spri3	pr6|74		store the exit_ptr into  the argument
	epp0	return_from_sort_init	set the return_ptr to special location
	spri0	pr6|stack_frame.return_ptr
"						RTS(3)
	lda	3,dl		load the rts_code
	sta	pr6|rts_code
	epp0	pr6|pr4_save,*
	epp0	pr0|control_ptr,*
	spri0	pr6|76
	tra	call_rts_from_op
	even
return_from_sort_init:
	szn	pr6|80		check the status code
	tze	sort_good		return to good sort label
	lda	55,dl		lda the error code and store
	sta	pr6|89
	tra	cobol_error_53

"
"
"	For good sort result, skip the retry instruction.
"
sort_good:
	lda	1,du
	asa	pr6|return_to_main_off
	tra	return_to_reset
"
"
"	Establish the cleanup handler for sort.
"	The cobol_rts_handler_ is called to call sort_$terminate.
"
"						**********OPERATOR(16)**********
establish_cleanup:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp1	pr6|text_base_ptr,*0		get the return location
	lda	=o100,dl		check the condition bit
	cana	pr6|stack_frame.condition_word
	tnz	3,ic		some conditions are on
	stz	pr6|stack_frame.on_unit_rel_ptrs		zero out the condition offset
	orsa	pr6|stack_frame.condition_word		set the condition bit
	ldx0	pr6|stack_frame.on_unit_rel_ptrs		get the last condition
	tze	4,ic		no condition
	ldx1	pr6|stack_frame.on_unit_rel_ptrs		get the last condition
	adx1	10,ic		10 words for the last condition
	tra	2,ic
	ldx1	118,du		it is the 1st cond. Put it in pr6|118
	stx0	pr6|on_unit.next,1		reset this as the last cond
	stx1	pr6|stack_frame.on_unit_rel_ptrs
	epp2	sort_con+1		store the name cleanup
	spri2	pr6|on_unit.name,1
	epp4	pr6|pr4_save,*		load pr4
	epp3	pr4|control_ptr,*		get control_seg
	epp3	pr3|46,*		get cobol_rts_handler_
	spri3	pr6|on_unit.body,1		store into the condition body
	lda	7,dl		store the length
	sta	pr6|on_unit.size,1
	lxl0	0,dl		no  flag
	sxl0	pr6|on_unit.flags,1
	tra	return_cond
"
"	The operator for calling the sort_$terminate
"
"						**********OPERATOR(17)**********
sort_terminate:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	stz	pr6|74		zero out the status code. It is needed, unfortunately
"						RTS(6)
	lda	6,dl		load the rts_code
	sta	pr6|rts_code
	epp0	return_from_sort_term	set the return_ptr to special location
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op
	even
return_from_sort_term:
	lda	pr6|74		check the status code
	tze	return_to_reset
	sta	pr6|80
	lda	54,dl		lda the error code and store
	sta	pr6|89
	tra	return_from_term
"
"
"	The operator for reverting the cleanup condition.
"
"						**********OPERATOR(18)**********
revert_cleanup:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp1	pr6|text_base_ptr,*0		store the return_ptr in pr1
	epbp7	pr6|0		pr7 for stack header
	epp0	pr6|118		first condition start from pr6|118
	epp2	sort_con+1		get the cleanup  character string
	eax6	7		7 characters
	tsx7	find_unit
"		unit found null out the current condition
	stz	pr6|on_unit.size,1		start searching
	ldaq	null_con
	staq	pr6|on_unit.name,1
	staq	pr6|on_unit.body,1
"		If this is the first unit then reset pr6|stack_frame.on_unit_rel_ptrs
	eaa	0,1
	cmpa	pr6|stack_frame.on_unit_rel_ptrs
	tnz	return_cond
	ldx1	pr6|on_unit.next,1
	stx1	pr6|stack_frame.on_unit_rel_ptrs
"		restore pr0, pr3 and pr4
return_cond:
	epp0	pr6|stack_frame.operator_ptr,*
	epp4	pr6|linkage_ptr,*
	epp3	pr6|pr3_save,*
	tra	pr1|0
"	This subroutine tries to find the unit for the given condition.

find_unit:
	lda	stack_frame.condition_bit,dl		make sure this is a condition stack
	cana	sp|stack_frame.condition_word		..
	tnz	get_length			..
	stz	sp|stack_frame.on_unit_rel_ptrs	..
	orsa	sp|stack_frame.condition_word		..
get_length:
	eaa	0,6		get length of name in chars
	tze	return_cond		if zero then done
	lrs	20		convert to words
	eax6	0,al		place number of words in x6
	qrl	16		get extra chars
	eax5	1,qu		place extra chars in x5
previous_char:
	eax5	-1,5		reduce chars by 1
	tnz	next_word		have we gone over word boundary
	eax6	-1,6		if so reduce number of words
	tmi	return_cond		name of all blanks
	eax5	4		have four chars in new word
next_word:
	lda	bp|0,6		get word and check for blanks
	ldq	masks1-1,5	..
	cmk	blanks		..
	tze	previous_char	if blank reduce length by 1
	ldx1	sp|stack_frame.on_unit_rel_ptrs	get offset of first on unit
	tra	next_length	..
next_on_unit:
	ldx1	sp|on_unit.next,1	get offset of next on unit
next_length:
	tze	return_cond	cannot find unit
	eaa	0,6		compute length of name
	ars	16		..
	ada	char_count-1,5	..
	cmpa	sp|on_unit.size,1	are names the same length
	tnz	next_on_unit	if not go to next on unit
	epplp	sp|on_unit.name,1*	get pointer to name for this unit
	lda	bp|0,6		compare extra chars
	ldq	masks2-1,5	..
	cmk	lp|0,6		..
	tnz	next_on_unit	no match, try next
	eax4	0,6		compare rest of name
compare_next_word:
	eax4	-1,4		..
	tmi	0,7		match, we are done
	lda	bp|0,4		..
	cmpa	lp|0,4		..
	tze	compare_next_word	..
	tra	next_on_unit	no match, try next

blanks:	aci	"    "		word of blanks
masks1:	oct	000777777777	masks for lookin at individual chars
	oct	777000777777
	oct	777777000777
	oct	777777777000
masks2:	oct	000777777777	masks for comparing strings
	oct	000000777777
	oct	000000000777
	oct	000000000000
char_count:
	oct	1		number of chars in last word
	oct	2
	oct	3
	oct	4

"
"
"	This operator is called from sort_gen to set up parameter for compare
"	procedure.
"
"						**********OPERATOR(19)**********
sort_comp:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp7	pr6|stack_frame.arg_ptr,*		get the argument pointer
	epp2	pr7|4,*		pr2 for second operand
	epp1	pr7|2,*		pr1 for first operand
	epp2	pr2|0,*
	epp1	pr1|0,*
	stz	pr7|6,*		prestore  0 for equal compare
	tra	pr6|text_base_ptr,*0
"
"
"	The operator for calling the pl1 operator real_to_real.
"	This operator is used for exponential computation.
"
"
"						**********OPERATOR(15)**********
real_to_real:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp0	cobol_operators_	reset text_base_ptr to cobol_operators_
	spri0	pr6|text_base_ptr
	epbp0	pr6|0
	epp0	pr0|28,*
	eax0	return_from_pl1_op		rest  x0 befor transfer to pl1_operators_
	tra	pr0|684
"
"

"	****************************************
"
"	This page is for merge statement interface
"
"	****************************************
"
"	merge_init				**********OPERATOR(60)**********
"
"	Input:	x2	for merge stack offset
"		x3	for no of using files
"		pr3	for compare entry
merge_init:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	cmpx2	0,du		check same sort merge possibility
	tpl	4,ic
	epp0	pr6|pr4_save,*
	stx2	pr0|41		complement x2
	lcx2	pr0|41
	stz	pr6|80
	sxl2	pr6|80		merge stack offset
	stz	pr6|81
	sxl3	pr6|81		no of using files
	epp2	pr6|0,2		stack_off loaction
	spri2	pr6|82
	eaq	0,3
	qls	1		multiply by 2 and put into Q upper
	epp2	pr2|0,qu		tree loaction
	spri2	pr6|84
	epp2	pr2|0,qu		compare entry loaction
	spri2	pr6|86
	epp0	pr6|pr4_save,*
	epp0	pr0|control_ptr,*	get controlp for temp dir
	spri0	pr6|88
	spri3	pr2|0		strore the compare entry
	ldaq	null_con
	staq	pr2|2
	lda	30,dl
	tra	call_rts_load_code
"
"	merge_comp				**********OPERATOR(61)**********
"
"	Input:	none
"
merge_comp:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	31,dl
	tra	call_rts_load_code
"
"
"	merge_return				**********OPERATOR(62)**********
"
"Input:	none
"
merge_return:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	32,dl
	tra	call_rts_load_code
"

"					**********OPERATOR(24)**********
"	This page is for communication interface.
"
"	****************************************
"
"					**********OPERATOR(70)**********
receive_comm:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	40,dl
	tra	call_rts_load_code
"
"					**********OPERATOR(71)**********
accept_comm:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	41,dl
	tra	call_rts_load_code
"
"					**********OPERATOR(72)**********
purge_comm:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	42,dl
	tra	call_rts_load_code
"
"					**********OPERATOR(73)**********
send_comm:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	43,dl
	tra	call_rts_load_code
"
"					**********OPERATOR(74)**********
enable_comm:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	44,dl
	tra	call_rts_load_code
"
"						**********OPERATOR(75)**********
disable_comm:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	45,dl
	tra	call_rts_load_code
"

"	****************************************

"
"	This page is for low used general operators.
"
"	****************************************

"
"
"
"
"
"	The operator for managing the files within OPEN and CLOSE.
"		X5 set to  2*no_of_files
"		X6 set to  2*file_no
"
"
"						**********OPERATOR(24)**********
set_lin_file_status:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	stz	pr6|46		zero work area
	aos	pr6|46		set init linage counter to 1.
	btd	(pr),(pr)
	desc9a	pr6|46,4
	desc9ns	pr1|88,6,0
	lda	pr1|94		get TOP value
	mlr	(ic),(pr,rl),fill(012)
	desc9a	-1,0
	desc9a	pr5|0,al
	sta	pr6|80		set length value
	stx6	pr6|x6_save		[3.0-1]
	tsx6	pr0|subr_put_chars		[3.0-1]
	ldx6	pr6|x6_save		[3.0-1]
	epp1	pr6|86,*
	epp3	pr6|pr3_save,*
"
"				**********OPERATOR(25)**********
"
"
set_file_status:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp4	pr6|pr4_save,*	load static data pointer
	ldaq	pr4|file_info_ptr
	eraq	null_con
	anaq	mask_con
	tnz	19,ic
	epp2	pr4|control_ptr,*
	adwp2	100000,du
	szn	pr2|0
	tnz	4,ic
	spri2	pr2|0
	lda	2,du
	asa	pr2|1
	ldaq	pr2|0
	staq	pr4|file_info_ptr
	ldx4 	2,du
	asx4 	pr2|1
	asx5	pr2|1
	epp2	pr4|file_info_ptr,*
	sxl5	pr2|0
	ldaq	null_con
	staq	pr2|0,5
	sbx5	2,du
	tnz	-2,ic
	epp2	pr4|file_info_ptr,*
	spri1	pr2|0,6
	epp4	pr6|linkage_ptr,*
	tra	pr6|text_base_ptr,*0

"
"
"
"				**********OPERATOR(27)**********
"	This operator handles the FILE CLOSE and DETACH.
"
"
close_file:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		store iocb ptr
	tsx6	pr0|subr_close_file
	tra	return_to_reset
"[3.0-1]
"[3.0-1]	alt_close_file		**********OPERATOR(89)**********
"[3.0-1]
"[3.0-1]
alt_close_file:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri7 pr6|80				set file desc ptr
"
	lda 47,dl					RTS(47)
	sta pr6|rts_code				set fields in FSB
	epp0 return_from_alt_close
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_close:
	tra return_to_reset
"
"
"				**********OPERATOR(38)**********
"	This operator handles the FILE CLOSE only NO detach
"
"
close_file_only:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86
	tsx6	pr0|subr_close_file_only
	epp1	pr6|86,*		reset pr 1 to fsb
	stz	pr1|2		reset open mode
	tra	return_to_reset
"
"
"
"				**********OPERATOR(43)**********
"	This operator is for stop literal code to call cu_$cl
"
stop_literal:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
"						RTS(8)
	lda	8,dl
	sta	pr6|rts_code
	tra	call_rts_from_op
"
"				**********OPERATOR(48)**********
"	This operator is for "stop run" code to call cobol_stoprun_
"
stop_run:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp4	pr6|pr4_save,*	load pr4
	staq	pr4|36		store the line number
"						RTS(9)
	lda	9,dl		load the rts_code
	sta	pr6|rts_code
	tra	call_rts_from_op
"
"				**********OPERATOR(94)**********	[4.4-3]
"	This operator is for "stop run" code to call cobol_stoprun_ if CD INITIAL used
"
stop_cd_run:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit off
	epp4	pr6|pr4_save,*	load pr4
	staq	pr4|36		save the line number
"						RTS(62)
	lda	62,dl		load the rts code
	sta	pr6|rts_code
	tra	call_rts_from_op
"
"
"	the cancel operator  used to call cobol_cantrol_$cancel.
"
"						**********OPERATOR(49)**********
cancel:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri3	pr6|74		store the name
	sta	pr6|76		store the name length
"						RTS(10)
	lda	10,dl		load the rts_code
	sta	pr6|rts_code
	tra	call_rts_from_op
"
"	The operator for calling cobol_su_$tally and cobol_su_$replace.
"
"						**********OPERATOR(51)**********
inspect_replace:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	24,dl
	tra	3,ic
"
"						**********OPERATOR(50)**********
"
inspect_tally:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
"						RTS(23)
	lda	23,dl
	spri2	pr6|74		load tally pointer
	sta	pr6|rts_code	load the rts_code
	tra	call_rts_from_op
"
"						**********OPERATOR(12)**********
"
"
"				**********OPERATOR(77)**********
"	The operator for initialize cd token	(77)
"
init_cd:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp2	pr6|26,*
	ldx1	pr2|0
	tze	init_cd_space
	epp2	pr2|0,1*
	mlr	(pr),(pr)
	desc9a	pr2|0,48
	desc9a	pr1|0,48
	tra	pr6|text_base_ptr,*0
init_cd_space:
	mlr	(0),(pr),fill(040)
	desc9a	0,0
	desc9a	pr1|0,48
	tra	pr6|text_base_ptr,*0
"
"
"
"	The operator for the runtime_check option.
"
pack_mask:
	oct	775777777777
desc_mask:
	oct	000000100000
runtime_check:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp5	pr6|stack_frame.arg_ptr,*	get arg_ptr from the caller
	epp3	pr6|stack_frame.entry_ptr,*	get the stack_frame.entry for the callee
	stz	pr6|mcode			set the status code to 0.
	epp0	pr6|text_base_ptr,*		load the text_base into pr0
	lda	pr3|-1
	ana	desc_mask		check the descriptor bit
	tnz	3,ic
	ldx3	0,du
	tra	4,ic
	ldx1	pr3|-2			get the descr_relp_offset
	ldx3	pr0|0,1			obtain the number of arguments
	tnz	4,ic			there are arguments
	cmpx3	pr5|0			check caller
	tze	return_from_call		both have no argument
	tra	n_args_error		caller has some arguments, call error routine
	adx3	pr0|0,1			double x3 to get 2*n_args
	cmpx3	pr5|0			compare n_args with the caller's
	tze	3,ic			n_args equal, passed the first check
n_args_error:
	lxl7	4155,dl			load the error_code
	tra	cobol_error
	ldx2	pr5|1			load the desc_count
	cmpx2	0,du			Is there descriptor?
	tnz	2,ic			yes. check descriptors.
	tra	return_from_call		no. restore registers and back
	epp2	pr6|descriptor_ptr,*	load descriptor_ptr for the caller
	epp3	pr0|0,1			find parm_desc_ptr for the caller
	stx2	pr6|74
	ldx5	0,du			initialization for the loop
	ldx2	0,du
	ldx7	0,du
loop_compare:
	cmpx7	0,du
	tnz	upper_half
	lxl1	pr3|0,5
	tra	desc_join
upper_half:
	adx5	1,du			next desc_relp in next word
	ldx1	pr3|0,5			obtain the next desc_relp for the caller
desc_join:
	epp1	pr0|0,1
	epp5	pr2|0,2*
	lxl3	pr1|-1
desc_loop:
	sbx3	1,du
	tmi	desc_exit
	lda	pr1|0,3
	ana	pack_mask
	sta	pr6|75
	lda	pr5|0,3
	ana	pack_mask
	cmpa	pr6|75
	tnz	desc_error		not equal, call cobol_error_
	tra	desc_loop
desc_exit:
	adx2	2,du			yes. get the next one
	cmpx2	pr6|74			more descriptor?
	tpl	return_from_call		no. back to main procedure
	adx7	1,du
	anx7	1,du
	tra	loop_compare		back to loop
desc_error:
	ldx7	4156,du			load the error_code
	tra	cobol_error		call cobol_error_
"
"

"
"
"	open_ext_file				**********OPERATOR(30)**********
"
"
open_ext_file:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	pr1|90		if file LOCKed then don't OPEN.
	ana	8192,du
	tze	cont_open_ext
"		set status
	lda 	io30_con
	ldq	s1090con
	staq	pr6|status12
	ldx1	62,du		Attempt to OPEN a file closed with the LOCK option.
	adx0	1,du		force skip over tra instr
	tra	return_thru_text_base_pone
cont_open_ext:
	sta 	pr6|55		temp save A reg value
	lda	pr1|2
	tmoz	pr6|text_base_ptr,*0 minus or zero cont processing
	cmpa	pr6|55		do the cobol modes match
	tze	return_thru_text_base_pone YES
"		set status
	lda	io30_con
	ldq	s1032con
	staq	pr6|status12
	ldx1	8,du	attempt to open ext file already opened in inconsistent mode.
	adx0	1,du		force skip over tra instruction
return_thru_text_base_pone:
	adx0	1,du		skip one instruction
	tra	pr6|text_base_ptr,*0
"
"
"	open_int_file cobol 				**********OPERATOR(31)**********
"
"
open_int_file:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	pr1|90		if file LOCKed then don't OPEN.
	ana	8192,du
	tze	cont_open_int
"		set status
	lda 	io30_con
	ldq	s1090con
	staq	pr6|status12
	ldx1	62,du		Attempt to OPEN a file closed with the LOCK option.
	tra	return_thru_text_base_pone
cont_open_int:
	szn	pr1|2
	tze	pr6|text_base_ptr,*0
"		set status
	lda	io30_con
	ldq	s1036con
	staq	pr6|status12
	ldx1	9,du		attempt to open int file already opened.
	tra 	return_thru_text_base_pone
"
"
"	find_iocb cobol 				**********OPERATOR(32)**********
"		A reg = length of switch name
"		X5 = stack offset value for ioname
"
"
find_iocb:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri6	pr6|48		store stack_offset ptr for ioname
	spri6	pr6|50
	adx5	pr6|49		add base offset to x5
	stx5	pr6|49		set correct offset
	adx5	2,du
	stx5	pr6|51
	spri1	pr6|86		store pr1
	spri1	pr6|48,*		store fsb pointer
	sta	pr6|50,*		store switch length
	epp2	pr6|40
	spri2	pr6|76		store mcode_ptr
"
	lda	14,dl		RTS(14)
	sta	pr6|rts_code	store rts_code
	epp0	return_find_iocb
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op	iox_find_iocb
return_find_iocb:
	szn	pr6|40
	tze	return_to_reset
"		set status
	lda	io30_con
	ldq	s1193con
	staq	pr6|status12
	ldx1	7,du		unable to establish iocb
	tra	io_return_to_reset
"
"	check_attach cobol 				**********OPERATOR(33)**********
"
check_attach:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp1	pr6|86,*		reset pr1
	epp2	pr1|0,*
	ldaq	pr2|12
	eraq	null_con
	anaq	mask_con
"   [4.0-1]   The following 7 lines are used to set a bit in the fsb if the
"    file is already attched otherwise the bit is zero
          tnz       4,ic     transfer if already attached
          lda	atd_con     load zeroes
	stba	pr1|87,20     store a byte of a into fsb
	tra	return_thru_text_base_pone
	lda	=o000400000000   load bit to be set
	stba	pr1|87,20     store the set byte of a ino fsb
	tnz	pr6|text_base_ptr,*0

"
"
"	close_op_file cobol 				**********OPERATOR(29)**********
"
"
close_op_file:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	staq	pr6|44		save open mode & optional/opened bit
	stz	pr6|46
	sxl5	pr6|46		store open mode(multics_mode)
	epp1	pr6|86,*
	tsx6	pr0|subr_close_file_only
	epp1	pr6|86,*
	tsx6	pr0|subr_open_file
	tra	open_ok
"
"
"	attach_iocb cobol_				**********OPERATOR(34)**********
"		A reg = length of attach description
"		X5 = stack offset value for atd
"
"
attach_iocb:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp1	pr6|86,*
	spri6	pr6|48		store stack offset for atd
	adx5	pr6|49
	stx5	pr6|49
	adx5	2,du
	stx5	pr6|51
	sta	pr6|50,*		store atd length
	epp2	pr6|40
	spri2	pr6|76		store mcode_ptr
"						RTS(15)
	lda	15,dl
	sta	pr6|rts_code	store rts_code
	epp0	return_attach_iocb
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op  	iox_$attach_iocb
	even
return_attach_iocb:
	szn	pr6|40
	tze	return_to_reset
"	set status
	lda	io30_con
	ldq	s1293con
	staq	pr6|status12
	ldx1	13,du		unable to attach IO switch.
	tra	io_return_to_reset
"
"	open_file cobol 				**********OPERATOR(35)**********
"		A reg = open mode
"
open_file:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86
	staq	pr6|44		save open mode & optional/opened bit
	stz	pr6|46
	sxl5	pr6|46		store open mode(multics_mode)
	lda	pr1|90		 if file LOCKed then don't open , return
	tsx6	pr0|subr_open_file
	tra	open_ok
"[3.0-1]
"[3.0-1]	alt_open_file	**********OPERATOR 78**********
"[3.0-1]
"[3.0-1]
alt_open_file:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri7 pr6|80			set file desc ptr
	epp7 pr6|mcode				mcode_ptr
	spri7 pr6|76
	lda pr6|44			move cobol_open_mode to rts_ stack frame
	sta pr6|82
	lda pr6|46			move vfile_open_mode to rts_ stack frame
	sta pr6|84
"
	lda 46,dl				RTS(46)
	sta pr6|rts_code			set fields in FSB
	epp0 return_from_alt_open
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_open:
	tra return_to_reset
"
"
"						**********OPERATOR(36)**********
"	open close op  no. 36
"		A reg = open mode
"
"
open_close_file:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	9,dl					[3.0-1]
	sta	pr6|46					[3.0-1]
	spri1	pr6|74		iocb_ptr
	spri1	pr6|86			fsb_ptr
	tsx6	pr0|subr_open_file
	epp1	pr6|86,*
	tsx6	pr0|subr_close_file_only
	tra	return_to_reset
"
"				**********OPERATOR(37)**********
"	check non cobol no. 37
"
"
check_file:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp1	pr6|86,*		reset pr1
	epp2 	pr1|0,*
	ldaq	pr2|16		iocb, open_descrip_ptr
	eraq	null_con
	anaq	mask_con
	tze	return_thru_text_base_pone fall though to OPEN
	lda	-1,du		noncobol open status
	sta	pr1|2		set fsb open mode
	tra	pr6|text_base_ptr,*0
"
"
"    SUBROUTINE to open files
"
"
subr_open_file:
	stx6	pr6|subr_return_save_off  save return offset within operators
	epp2	pr6|46
	spri2	pr6|88		store pointer to open mode
	stz	pr6|47
	epp2	pr6|47
	spri2	pr6|90		unused
	epp2	pr6|40
	spri2	pr6|76		mcode_ptr
	spri2	pr6|92		store pointer to mcode
	eax1	pr6|84
	fld	8192,dl		4 args
	epp2	pr1|0,*		indirect thru fsb to iocb
	epp2	pr2|26		offset for iox_$open
	epp0	return_from_open
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op
return_from_open:
	epp4	pr6|linkage_ptr,*
	szn	pr6|40
	tze	pr6|subr_return_save,* EXIT FROM SUBROUTINE
	epp1	pr6|86,*
	stz	pr1|2
"	check if optional bit is on
	lda	pr6|45
	cmpa	optional_int
	tze	pr6|subr_return_save,* EXIT FROM SUBR
	cmpa	optional_ext
	tze	pr6|subr_return_save,* EXIT FROM SUBR
"		set status				RTS(13)
	lda	13,dl
	sta	pr6|rts_code 	store rts(13) call
	ldx1	15,du		set open error code
	epp0	return_from_open_rts
	spri0	pr6|stack_frame.return_ptr	exit to main line +1
	tra 	call_rts_from_op
return_from_open_rts:
	epp4	pr6|linkage_ptr,*	reset_linkage pointer
	ldx1	15,du
	ldq	s1295con
	cmpq	pr6|status12
	tnz	io_return_to_reset
	tra	pr6|subr_return_save,* EXIT FROM SUBROUTINE
open_ok:
	epp1	pr6|86,*		reset pr 1
	szn	pr6|40
	tze	set_open_mode
	lda	pr6|45
	cmpa	optional_int
	tze 	skip_open_mode
	cmpa	optional_ext
	tze	skip_open_mode
set_open_mode:
	lda	pr6|44
	sta	pr1|2		cobol open mode
skip_open_mode:
	epp4	pr6|pr4_save,*		load pr4
	lxl5	pr4|18		length of program name
	mlr	(pr,rl),(pr),fill(040)
	desc9a	pr4|19,x5		set name
	desc9a	pr1|71,65
	stz	pr1|6		set fsb.relkeylen to zero
	mlr	(pr),(pr),fill(060)	reset key on each open
	desc9a	0,0
	desc9a	pr1|7,16
	ldx5	high_con,du	set optional bit
	ansx5	pr1|90
	ldx5	pr6|45		set how opened bit 100000=ext 140000=int
	orsx5	pr1|90		opened bit
	tra	return_to_reset
"
"
"    SUBROUTINE to close files
"
"
subr_close_file:
	stx6	pr6|subr_return_save_off
	epp2	pr6|mcode					[5.1-1]
	spri2	pr6|88		store ptr to mcode_ptr	[5.1-1]
	spri2	pr6|76		mcode_ptr			[5.1-1]
"	check if optional bit is on
	lda	pr1|90
	cmpa	optional_int
	tze	check_if_open
	cmpa	optional_ext
	tnz	3,ic
check_if_open:
	szn	pr1|2
	tze	close_ok
	szn	pr6|retrycode		op retry code
	tnz	detach_op	
	szn	pr1|2
	tmi	detach_op		syn attachment don't close
	tnz	close_file_begin
"		set status 1,2,3	handle unopen error
	lda	io30_con
	ldq	s2036con
	staq	pr6|status12
	ldx1	17,du		set unopened error code to X1
	tra	io_return_to_reset
"	This section handles the close.
close_file_begin:
	eax1	pr6|84		argument list offset
	fld	4096,dl		2 args
	epp2	pr1|0,*		indirect thru fsb to iocb
	epp2	pr2|30		offset for close
	epp0	return_from_io_close
	spri0	pr6|stack_frame.return_ptr		adjust return from call_rts
	tra	call_ent_var_from_op	iox_$close
	even
return_from_io_close:
	epp4	pr6|linkage_ptr,*		reset linkage pointer
	szn	pr6|mcode
	tze	close_ok	
	lda	12,dl
	sta	pr6|rts_code		store rts_code
"						RTS(18)
	ldx1	18,du		set close error code to X1
	epp0	io_return_to_reset	exit to main line +1
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op	handle close error
"	This section handles the detach after a close.
close_ok:
	epp1	pr6|86,*		reset pr1 with fsb_ptr
	stz	pr1|2
detach_op:
	lda	pr1|87   load bit to see if file was previously attached
	ana	=o000400000000     isolate bit
	tnz	pr6|subr_return_save,*    do not detach if file was previously attached
	lda	space_con
	cmpa	pr1|71		is attach name spaces
	tze	pr6|subr_return_save,*	yes, then NO DETACH SUBR EXIT
	epp4	pr6|pr4_save,*		load pr4
	cmpc	(pr),(pr),fill(000)	attach name to program name
	desc9a	pr1|71,65
	desc9a	pr4|19,65
	tnz	pr6|subr_return_save,*	don't detach names differ SUBR EXIT
	eax1	pr6|84
	fld	4096,dl		2 args
	epp2	pr1|0,*
	epp2	pr2|22		offset for detach_iocb
	epp0	return_from_io_detach
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op	iox_$detach
	even
return_from_io_detach:
	szn	pr6|mcode
	tze 	detach_ok
"		set status 1,2,3	handle detach error
	aos	pr6|retrycode		set retry code to close complete
	lda	io30_con
	ldq	s2393con
	staq	pr6|status12
	ldx1	19,du		set detach error code to X1
	tra	io_return_to_reset
detach_ok:
	epp1	pr6|86,*		reset pr1 with fsb_ptr
	mlr	(pr),(pr),fill(040)	space fill attach name
	desc9a	0,0
	desc9a	pr1|71,65
	tra 	pr6|subr_return_save,* EXIT FROM SUBROUTINE
"
"
"     SUBROUTINE to  close files only, NO detach
"
"
subr_close_file_only:
	stx6	pr6|subr_return_save_off
	epp2	pr6|mcode
	spri2	pr6|88
          szn	pr1|2            [4.1-2]
	tmi	pr6|subr_return_save,*
	eax1	pr6|84		argument list offset
	fld	4096,dl		2 args
	epp2	pr1|0,*		indirect thru fsb to iocb
	epp2	pr2|30		offset for close
	epp0	return_from_io_close_only
	spri0	pr6|stack_frame.return_ptr		adjust return from call_rts
	tra	call_ent_var_from_op	iox_$close
	even
return_from_io_close_only:
	epp4	pr6|linkage_ptr,*		reset linkage pointer
	szn	pr6|mcode
	tze	pr6|subr_return_save,*	
	lda	12,dl
	sta	pr6|rts_code		store rts_code
"						RTS(18)
	ldx1	18,du		set close error code to X1
	epp0	io_return_to_reset	exit to main line +1
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op	handle close error
"
"
"
"	This operator is for accept the user's word.**********OPERATOR(20)**********
"
accept_line:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	sta	pr6|80		length of the buff
	spri2	pr6|78		buff_ptr
	epp2	pr6|0,5
	spri2	pr6|82		address of the buffer on the stack
	epp2	pr6|40
	spri2	pr6|76		store the mcode_ptr
"						RTS(18)
	lda	18,dl
	sta	pr6|rts_code	for accept in cobol_rts_
	epp0	return_from_accept	preset the return pointer
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op
	even
return_from_accept:
	szn	pr6|40
	tnz	accept_error	output the error message
	epp2	pr6|78,*		obtain the buff_ptr
	lxl5	pr6|81		load the actual record length
	tze	return_accept	return
	sbx5	1,du		get rid of the new line character
	sxl5	pr6|81		store the actual lengthwith new_line off
	lda	pr6|80		load the buffer length
	sba	pr6|81		get the length for the unfilled buffer
	mlr	(),(pr,rl,x5),fill(040)	fill the unfilled area with spaces
	desc9a	0,0
	desc9a	pr2|0,al
return_accept:
	lda	1,du
	asa	pr6|return_to_main_off	skip the retry error instruction
	tra	return_to_reset	return
accept_error:
	lda	6,dl
	sta	pr6|89		store the cobol error code
	tra	cobol_error_from_op	join the common error label to output the error message
"
"
"				**********OPERATOR(44)**********
"	This operator is for the use of "accept <id> from date.
"
"
accept_date:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
"						RTS(22)
	lda	22,dl
	sta	pr6|rts_code	save the rts_code
	tra	call_rts_from_op
"
"
"				**********OPERATOR(45)**********
"	This operator is for "accept <id> from day".
"
accept_day:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp0	return_from_day	reset the retunr point
	spri0	pr6|stack_frame.return_ptr
"						RTS(20)
	lda	20,dl
	sta	pr6|rts_code	save the rts_code
	tra	call_rts_from_op
	even
return_from_day:
	btd	(pr),(pr)
	desc9a	pr6|86,4
	desc9ns	pr6|80(2),3,0
	btd	(pr),(pr)
	desc9a	pr6|78,4
	desc9ns	pr6|79(2),4,0
	tra	return_to_reset	return
"
"			**********OPERATOR(46)**********
"	This operator is for accept <id> from time.
"
accept_time:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp0	return_from_time	reset the return point
	spri0	pr6|stack_frame.return_ptr
	lda	21,dl		load the rts_code
	sta	pr6|rts_code
	tra	call_rts_from_op
	even
return_from_time:
	ldaq	pr6|80		load the time of day(tod)
	dvf	5000,dl
	lrl	36
	div	6000,dl
	sta	pr6|91
	div	60,dl
	sta	pr6|90
	stq	pr6|87
	btd	(pr),(pr)
	desc9a	pr6|87,4
	desc9ns	pr6|88,2,0
	btd	(pr),(pr)
	desc9a	pr6|90,4
	desc9ns	pr6|88(2),2,0
	btd	(pr),(pr)
	desc9a	pr6|91,4
	desc9ns	pr6|89,4,0
	tra	return_to_reset
"
"			**********OPERATOR(47)**********
"	This operator is for accepr <id> from day of week.
"
accept_day_of_week:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp0	return_from_dow
	spri0	pr6|stack_frame.return_ptr	reset return pointer
"						RTS(21)
	lda	21,dl
	sta	pr6|rts_code
	tra	call_rts_from_op
	even
return_from_dow:
	lda	pr6|82		load the day of the week
	als	27		convert to decimal
	ora	24576,du
	sta	pr6|82	store the converted decimal back
	tra	return_to_reset	return
"
"
"	init_delete check file condition	**********OPERATOR(56)**********
"
"
init_delete:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		set fsb_ptr
	stz	pr6|icode			 each entry to zero
	szn	pr1|2		is file opened
	tnz	pr6|text_base_ptr,*0	YES,
"	set status
	lda	io30_con
	ldq	s7031con
	staq	pr6|status12
	ldx1	24,du		attempt to perform io on an unopened file
	tra	return_thru_text_base_pone
"
"
"	delete_error	**********OPERATOR(54)**********
"		X5 = error number for RTS interface
"
delete_error:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	sxl5	pr6|45		io_error_no
"						RTS(16)
	lda	16,dl
	sta	pr6|rts_code	store rts_code
	tra	call_rts_from_op
"
"			**********OPERATOR(55)**********
"	read_key		call iox_$read_key
"		A = offset for TEMP key storage
"		1st word = length of saved key
"		remainder = actual key
"
"
read_key:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		set iocb_ptr
	spri1	pr6|74		iocb_ptr
	spri6	pr6|52		get any pointer value in area
	ada	pr6|53
	sta 	pr6|53		insert correct value in pointer offset
	epp2	pr6|52,*		point to TEMP area
	spri2	pr6|90		store pointer to key length
	adwp2	1,du
read_delete_join:
	spri2	pr6|88		store pointer to key area
	epp2	pr6|mcode
	spri2	pr6|92		store pointer to mcode
	spri2	pr6|76		mcode_ptr
	eax1	pr6|84
	fld	8192,dl		4 args
	epp2	pr1|0,*
	epp2	pr2|78		offset for iox_$read_key
	epp0	return_read_key
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op
	even
return_read_key:
	stz	pr6|83		set read_key_eof to zero
	szn	pr6|mcode
	tze	return_to_reset
	epp4	pr6|linkage_ptr,*	reset linkage pointer
	epp2	pr6|mcode
	spri2	pr6|76
"						RTS(17)
	lda	17,dl
	sta	pr6|rts_code	store rts code
	epp0	return_rts_read_key
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op	handle read key errors
return_rts_read_key:
	szn	pr6|mcode
	tze	return_to_reset
	ldx1	27,du		set read error code
	tra	io_return_to_reset
"
"			**********OPERATOR(69)**********
"
"
read_key_for_read:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		set fsb_ptr
	spri1	pr6|74		iocb_ptr
	spri6	pr6|52		get any pointer value in area
	ada	pr6|53
	sta 	pr6|53		insert correct value in pointer offset
	epp2	pr6|52,*		point to TEMP area
	spri2	pr6|90		store pointer to key length
	epp2	pr1|7
	spri2	pr6|88		store pointer to key area
	epp2	pr6|mcode
	spri2	pr6|92		store pointer to mcode
	spri2	pr6|76		mcode_ptr
	eax1	pr6|84
	fld	8192,dl		4 args
	epp2	pr1|0,*
	epp2	pr2|78		offset for iox_$read_key
	epp0	return_for_read_key
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op
	even
return_for_read_key:
	szn	pr6|mcode
	tze	return_to_reset
	epp4	pr6|linkage_ptr,*	reset linkage pointer
	epp2	pr6|mcode
	spri2	pr6|76
"						RTS(26)
	lda	26,dl
	sta	pr6|rts_code	store rts code
	epp0	return_rts_for_read_key
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op	handle read key errors
return_rts_for_read_key:
	ldx1	27,du		set read error code
	tra	io_return_to_reset
"
"			**********OPERATOR(53)**********
"	delete		call iox_$delete_record
"
"
delete:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		set fsb_ptr
	tsx6	pr0|subr_delete
	szn	pr6|mcode
	tze	return_to_reset
"	set status
	lda	io30_con
	ldq	s7430con
	staq	pr6|status12
	ldx1	30,du		Unable to delete record
	tra	io_return_to_reset
"
"
"	SUBROUTINE  to iox_$delete_record
"
"
subr_delete:
	stx6	pr6|subr_return_save_off
	epp2	pr6|mcode
	spri2	pr6|88		store pointer to mcode
	eax1	pr6|84
	fld	4096,dl		2 args
	epp2	pr1|0,*
	epp2	pr2|70		offset for iox_$delete_record
	epp0	pr6|subr_return_save,* EXIT FROM SUBROUTINE
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op
"
"			**********OPERATOR(57)**********
"	special_delete	seek BUFF, delete, seek TEMP, if EOF position
"
"
special_delete:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	sta	pr6|53		save a for future use
	spri1 	pr6|86		set fsb_ptr
	epp2	pr1|7
	spri2	pr6|88
	epp2	pr6|62		work area not used as seek key returns length
	spri2	pr6|90
"						RTS(25)
	lda	25,dl
	sta	pr6|rts_code	store rts code
	tsx6	pr0|subr_seek_op	from BUFF area
	szn 	pr6|mcode
	tnz	io_return_to_reset
	epp1	pr6|86,*
	tsx6	pr0|subr_delete
	szn 	pr6|mcode
	tze	return_special_delete
"	set status
	lda	io30_con
	ldq	s7430con
	staq	pr6|status12
	ldx1	30,du		Unable to delete record
	tra 	io_return_to_reset
return_special_delete:
	epp1	pr6|86,*
	szn	pr6|83		is read_key_eof set
	tnz	eof_position
	lda	pr6|53		reset A  from previous save
	spri6	pr6|52		set any pointer value in area
	ada	pr6|53
	sta	pr6|53		insert correct value in pointer offset
	epp2	pr6|52,*		point to TEMP area
	spri2	pr6|90		store pointer to key length
	adwp2	1,du		increment pointer offset up by one
	spri2	pr6|88		store pointer to key area
	tsx6	pr0|subr_seek_op	from TEMP area
	tra	return_to_reset		
eof_position:
	stz 	pr6|52
	aos	pr6|52		set to +1
	stz	pr6|53
	epp2	pr6|52
	spri2	pr6|88		store pointer to type = +1
	epp2	pr6|53
	spri2	pr6|90		store pointer  for n = 0
	epp2	pr6|40
	spri2	pr6|92		store pointer to mcode
	eax1	pr6|84
	fld	8192,dl		4args
	epp2	pr1|0,*
	epp2	pr2|50		offset for iox_$position
	epp0	return_to_reset		
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op
"
"
"	special_rewrite	seek and position**********OPERATOR(58)**********
"
"
special_rewrite:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	sta	pr6|53		save offset to key area
	spri1	pr6|86		set fsb_ptr
	spri5	pr6|60		save pr 5 for rewrite
	epp2	pr1|7
	spri2	pr6|88
	epp2	pr6|62		work area not used as seek key returns length
	spri2	pr6|90
"						RTS(25)
	lda	25,dl
	sta	pr6|rts_code	store rts code
	tsx6	pr0|subr_seek_op	from BUFF area
	szn	pr6|mcode
	tnz	io_return_to_reset
	epp1	pr6|86,*
	epp5	pr6|60,*		save area points to buffer area
	tsx6	pr0|subr_write_record
	epp2	pr2|66			offset for iox_$rewrite_record
	epp0	return_special_rewrite
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op
return_special_rewrite:
	epp1	pr6|86,*
	szn	pr6|mcode
	tze	return_special_delete
"					set status
	lda	io30_con
	ldq	s5432con
	staq	pr6|status12
	ldx1	43,du		Attempt to rewrite a file not opened as i-o
	tra	io_return_to_reset
"
"
"	rewrite	**********OPERATOR(59)**********
"
"
rewrite:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		set fsb_ptr
	tsx6	pr0|subr_write_record
	epp2	pr2|66		offset for iox_$rewrite_record
"						RTS(64)
	lda	64,dl					[5.3-1]
	sta	pr6|rts_code				[5.3-1]
	epp0	return_rewrite_record
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op				[5.3-1]
return_rewrite_record:
	szn	pr6|mcode
	tze	return_to_reset
"	set status
"	lda	io30_con					[5.3-1]
"	ldq	s5432con					[5.3-1]
"	staq	pr6|status12				[5.3-1]
	ldx1	43,du		Attempt to rewrite a file not opened as i-o
	tra	io_return_to_reset
"
"
"	init_read check file condition	**********OPERATOR(63)**********
"
"
init_read:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	spri1	pr6|86		set fsb_ptr
	stz	pr6|icode		reset on each entry to zero
	stz	pr6|46
	szn	pr1|2		is file open
	tnz	pr6|text_base_ptr,*0  YES,
"	check if optional bit is on perform AT END condition
	lda	pr1|90
	cmpa	optional_int
	tze	read_optional
	cmpa	optional_ext
	tze	read_optional
"	set status
	lda 	io30_con
	ldq	s3031con
	staq	pr6|status12
	ldx1	40,du		attempt to perform io on unopened file
	tra	return_thru_text_base_pone
read_optional:
	lda	io10_con		set status for at end condition
	ldq	s3410con
	staq	pr6|status12
	aos	pr6|icode
	aos	pr6|46
	tra	io_return_to_reset
"
"			**********OPERATOR(64)**********
"	get_line used for cobol_read_gen
"
"
get_line:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp1	pr6|86,*		set iocb_ptr
	spri5	pr6|78		store buff_ptr
	epp2	pr6|78
	spri2	pr6|88		store pointer to buff_ptr
	epp2	pr6|80
	spri2	pr6|90		store pointer to buff_len
	stz	pr6|47
	epp2	pr6|47
	spri2	pr6|92	no of bytes read into buffer output
	epp2	pr6|mcode
	spri2	pr6|94		store pointer to mcode
	eax1	pr6|84
	fld	10240,dl		5 args
	epp2	pr1|0,*		indirect thru fsb to iocb
	epp2	pr2|34		offset for iox_$get_line
	epp0	return_get_line
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op 	iox_get_line
	even
return_get_line:
	szn	pr6|mcode
	tze	return_to_reset
	epp4	pr6|linkage_ptr,*
	epp2	pr6|mcode
	spri2	pr6|76
"						RTS(28)
	lda	28,dl
	sta	pr6|rts_code
	epp0	return_read_record_exit
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op
	even
"[3.0-1]
"[3.0-1]	alt_start			**********OPERATOR(79)**********
"[3.0-1]
"[3.0-1]
"
alt_start:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri7 pr6|80					set file descr ptr
"
	lda 48,dl					RTS(48)
	sta pr6|rts_code					set fields in FSB
	epp0 return_from_alt_start
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_start:
	tra return_to_reset
"
"[3.0-1]
"[3.0-1]	alt_read_next		**********OPERATOR(80)**********
"[3.0-1]
"[3.0-1]
"
alt_read_next:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri7 pr6|80					set file descr ptr
"
	lda 49,dl						RTS(49)
	sta pr6|rts_code					set fields in FSB
	epp0 return_from_alt_read
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_read:
	tra return_to_reset
"
"[3.0-1]
"[3.0-1]	alt_read_record		**********OPERATOR(81)**********
"[3.0-1]
"[3.0-1]
"
alt_read_record:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri7 pr6|80					set file descr ptr
"
	lda 50,dl						RTS(50)
	sta pr6|rts_code					set fields in FSB
	epp0 return_from_alt_key
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_key:
	tra return_to_reset
"
"[3.0-1]
"[3.0-1]	alt_seek_key		**********OPERATOR(82)**********
"[3.0-1]
"[3.0-1]
"
alt_seek_key:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri1 pr6|74				loc of file key for start
	spri7 pr6|80				set file descr ptr
	sta pr6|85				store key number
"
	lda 54,dl					RTS(54)
	sta pr6|rts_code				move key in FSB one position
	epp0 return_from_alt_seek			prefix by key number
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_seek:
	tra return_to_reset
"
"[4.0-3]
"
"
"	iox_$control  perform control order on io switch.**********OPERATOR(83)**********
"
"
alt_start_control:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	epp1	pr6|86,*		set iocb_ptr
	spri6	pr6|48		store stack_offset ptr for order name
	spri6	pr6|50
	adx5	pr6|49		add base offset to x5
	stx5	pr6|49		set correct offset
	adx5	2,du
	stx5	pr6|51
	spri1	pr6|48,*		store fsb pointer
	epp2	pr6|50,*
	adwp2	2,du
	spri2	pr6|50,*		store control pointer
	epp2	pr6|mcode
	spri2	pr6|76		store mcode_ptr
	lda	60,dl		RTS(60)
	sta	pr6|rts_code
	epp0	return_alt_start_control
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op	iox_control
return_alt_start_control:
	szn	pr6|mcode
	tze	return_to_reset
"	set status
	ldx1	38,du		unable to start a file with specified key
	tra	io_return_to_reset
"
"[3.0-1]
"[3.0-1]	alt_read_key		**********OPERATOR(84)**********
"[3.0-1]
"[3.0-1]
"
alt_read_key:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri1 pr6|74					loc of file key
	spri7 pr6|80					set file descr ptr
	sta pr6|85					store key number
"
	lda 59,dl						RTS(59)
	sta pr6|rts_code
"
	epp0 return_from_alt_read_key
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_read_key:
	tra return_to_reset
"[3.0-1]
"[3.0-1]	alt_special_delete		**********OPERATOR(85)**********
"[3.0-1]
"[3.0-1]
"
alt_special_delete:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri1 pr6|74				loc of file key [4.4-2]
	lda pr6|80				save rec length
	sta pr6|100
	spri7 pr6|80				set file descr ptr
	epp7 pr6|mcode				mcode_ptr
	spri7 pr6|76
"
	lda 55,dl						RTS(55)
	sta pr6|rts_code				move key in FSB one pos
	epp0 return_from_alt_spec			prefix by 511
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_spec:
	lda pr6|100				restore rec length
	sta pr6|80
	tra return_to_reset
"[3.0-1]
"[3.0-1]	alt_delete		**********OPERATOR(86)**********
"[3.0-1]
"[3.0-1]
"
alt_delete:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	lda 53,dl					RTS(53)
	sta pr6|rts_code				set fields in FSB after rewrite
	epp0 return_from_alt_fsb
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_fsb:
	tra  return_to_reset
"[3.0-1]
"[3.0-1]	alt_key_delete			**********OPERATOR(87)**********
"[3.0-1]
"[3.0-1]
"
alt_key_delete:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	stz pr6|mcode
	epp7 pr6|mcode				mcode_ptr
	spri7 pr6|76
"
	lda 52,dl					RTS(52)
	sta pr6|rts_code				$control("record_status")
	epp0 return_from_rew_del			delete alt key values
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_rew_del:
	szn pr6|mcode
	tze return_to_reset
"
	lda io9_con				status-key-1,2
	ldq s7430con		[5.3-1]		status-key-3
	staq pr6|status12
	ldx1 65,du				unable to delete keys
	tra io_return_to_reset
"[3.0-1]
"[3.0-1]	alt_rewrite_add		**********OPERATOR(88)**********
"[3.0-1]
"[3.0-1]
"
alt_rewrite_add:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	stz pr6|mcode
	epp7 pr6|mcode				mcode_ptr
	spri7 pr6|76
"
	lda 58,dl					RTS(58)
	sta pr6|rts_code				$control("record_status)
	epp0 return_from_rew_add			add alt key values
	spri0 pr6|stack_frame.return_ptr		set fields in FSB after rewrite
	tra call_rts_from_op
"
return_from_rew_add:
	szn pr6|mcode
	tze return_to_reset
"
	lda io9_con				status-key-1,2
	ldq s5730con				status-key-3
	staq pr6|status12
	ldx1 64,du				unable to add key
	tra io_return_to_reset
"[3.0-1]
"[3.0-1]	alt_add_write_keys		**********OPERATOR(90)**********
"[3.0-1]
"[3.0-1]
"
alt_add_write_keys:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri7 pr6|80				set file descr ptr
	stz pr6|mcode
	epp7 pr6|mcode				mcode_ptr
	spri7 pr6|76
"
	lda 56,dl					RTS(56)
	sta pr6|rts_code				add alt rec keys
	epp0 return_from_alt_add			set fields in FSB
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_add:
	szn pr6|mcode
	tze return_to_reset
"
	lda io9_con				status-key-1,2
	ldq s4730con				status-key-3
	staq pr6|status12
	ldx1 64,du				unable to add keys
	tra io_return_to_reset
"
"[3.0-1]
"[3.0-1]	alt_write_seek_key		**********OPERATOR(91)**********
"[3.0-1]
"[3.0-1]
"
alt_write_seek_key:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	lda pr6|80
	sta pr6|100			save record size
	spri7 pr6|80			set file descr ptr
	spri5 pr6|78			store buff ptr
	epp7 pr6|mcode				mcode_ptr
	spri7 pr6|76
	stz pr6|mcode
"
	lda 51,dl				RTS(51)
	sta pr6|rts_code			if necessary: test key order, SAVE_CRP
	epp0 return_from_write_seek		test alt key values for legality
	spri0 pr6|stack_frame.return_ptr	move key in FSB one pos to right
	tra call_rts_from_op
"
return_from_write_seek:
	lda pr6|100
	sta pr6|80				restore record size
	szn pr6|mcode
	tze return_to_reset
"
	lda io9_con			status-key-1,2
	ldq s4430con			status-key-3
	staq pr6|status12
	ldx1 21,du			unable to write record
	tra io_return_to_reset
"[3.0-1]
"[3.0-1]	alt_find_rec		**********OPERATOR(92)**********
"[3.0-1]
"[3.0-1]
"
alt_find_rec:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri7 pr6|80					set file descr ptr
	stz pr6|icode
	epp7 pr6|mcode				mcode_ptr
	spri7 pr6|76
"
	lda 57,dl					RTS(57)
	sta pr6|rts_code				if necessary then RESTORE_CRP
	epp0 return_from_alt_find
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
return_from_alt_find:
"
	szn pr6|mcode
	tze return_to_reset
"
	tra read_record_exit
"
"	alt_rewrite				**********OPERATOR(93)**********
"
alt_rewrite:
	inhibit on
	stx0 pr6|return_to_main_off
	inhibit off
"
	spri5 pr6|78				loc of buffer
	stz pr6|mcode				mcode ptr
	epp7 pr6|mcode
	spri7 pr6|76
"
	lda 61,dl					RTS(61)
	sta pr6|rts_code
	epp0 return_from_rew_del
	spri0 pr6|stack_frame.return_ptr
	tra call_rts_from_op
"
"
"	read_record used by cobol_read_gen	**********OPERATOR(66)**********
"
nonseq_read_record:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	1,dl
	sta	pr6|54
	tra	read_common
"
"					**********OPERATOR(65)**********
"
"
read_record:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	stz	pr6|54
read_common:
	epp1	pr6|86,*		set iocb_ptr
	spri5	pr6|78		store buff_ptr
	epp2      pr6|78
	spri2	pr6|88		store pointer to buff_ptr
	epp2 	pr6|80
	spri2	pr6|90		store pointer to buff_len
	stz	pr6|47
	epp2	pr6|47
	spri2	pr6|92		length of record in bytes output
	epp2	pr6|mcode
	spri2	pr6|94		store pointer to mcode
"						RTS(63)
	stz	pr6|mcode					[5.3-1]
	lda	63,dl					[5.3-1]
	sta	pr6|rts_code				[5.3-1]
	epp0	return_read_record
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op				[5.3-1]
	even
return_read_record:
	szn	pr6|mcode
	tze	return_to_reset
read_record_exit:
	epp4	pr6|linkage_ptr,*
	epp2	pr6|mcode
	spri2	pr6|76
"						RTS(27)
	lda	27,dl
	sta	pr6|rts_code
	epp0	return_read_record_exit
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op
	even
return_read_record_exit:
	szn	pr6|mcode
	tze	return_to_reset
	ldx1	25,du
	tra	io_return_to_reset
"
"
"	init_start check file condition**********OPERATOR(21)**********
"
"
init_start:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
"
	spri1	pr6|86		set fsb_ptr
	stz	pr6|icode
	szn	pr1|2		is file open
	tnz	pr6|text_base_ptr,*0  YES
"	set status
	lda	io30_con
	ldq	s6031con
	staq	pr6|status12
	ldx1	24,du		attempt to perform io on unopened file
	tra	io_return_to_reset
"
"
"	iox_$control  perform control order on io switch.**********OPERATOR(23)**********
"
"
start_control:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
"
	epp1	pr6|86,*		set iocb_ptr
	spri6	pr6|48		store stack_offset ptr for order name
	spri6	pr6|50
	adx5	pr6|49		add base offset to x5
	stx5	pr6|49		set correct offset
	adx5	2,du
	stx5	pr6|51
	spri1	pr6|48,*		store fsb pointer
	epp2	pr6|50,*
	adwp2	2,du
	spri2	pr6|50,*		store control pointer
	epp2	pr6|40
	spri2	pr6|76		store mcode_ptr
"						RTS(11)
	lda	11,dl
	sta	pr6|rts_code
	epp0	return_start_control
	spri0	pr6|stack_frame.return_ptr
	tra	call_rts_from_op	iox_control
"
return_start_control:
	szn	pr6|mcode
	tze	return_to_reset
"	set status
	ldx1	38,du		unable to start a file with specified key
	tra	io_return_to_reset
"
"	close_reel			**********OPERATOR(76)**********
"
close_reel:
	inhibit	on
	stx0	pr6|return_to_main_off
	inhibit	off
	lda	pr1|2		get open_mode
	tze	file_unopen	file not open yet, error
	epp0	ptr_desc
	spri0	pr6|100
	spri0	pr6|104
	epp0	fb35_desc
	spri0	pr6|106
	spri1	pr6|92		set parameter for iocb_ptr
	epp0	pr6|76		tvstat_ptr for input reel
	spri0	pr6|96
	epp0	pr6|mcode		mcode_ptr
	spri0	pr6|98
	cmpa	21,dl		input reel?
	tze	input_reel	yes
	cmpa	17,dl		input reel?
	tze	input_reel	yes
	ldaq	null_con
	staq	pr6|76		null info_ptr
	epp0	feov_desc
	spri0	pr6|102
	epp0	feov_con		char "feov"
	spri0	pr6|94
	eax1	pr6|90
	fld	8192,dl
	epp2	pr1|0,*		iocb_ptr
	epp2	pr2|54		entry iocb.control
	tra	call_ent_var_desc_from_op
input_reel:
	spri0	pr6|88		parameter mcode_ptr for position call
	spri1	pr6|82
	epp0	volume_desc
	spri0	pr6|102
	epp0	volume_con	char "volume_status"
	spri0	pr6|94
	epp0	zero_con		type 0
	spri0	pr6|84
	epp0	one_con		1 record for each position operation
	spri0	pr6|86
	stz	pr6|78		initialize volume no. for comparison
vol_call:
	eax1	pr6|90
	fld	8192,dl		4 parameters
	epp1	pr6|92,*		fsb_ptr
	epp2	pr1|0,*		iocb_ptr
	epp2	pr2|54		iocb.control
	epp0	return_from_vol_call
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_desc_from_op
return_from_vol_call:
	szn	pr6|mcode		check error code
	tnz	reel_exit
vol_call_ok:
	epp1	pr6|76,*		tvstat_ptr
	lda	pr1|3		volume sequence no.
	szn	pr6|78		first call?
	tnz	vol_comp		no, goto compare
	sta	pr6|78		yes. save vol seq no.
	tra	posi_call		call position operation
vol_comp:
	cmpa	pr6|78		comparing vol seq nos
	tnz	reel_exit	not equal, done.
posi_call:
	eax1	pr6|80
	fld	8192,dl
	epp1	pr6|82,*		fsb_ptr
	epp2	pr1|0,*		iocb_ptr
	epp2	pr2|50		position entry
	epp0	return_from_posi_call
	spri0	pr6|stack_frame.return_ptr
	tra	call_ent_var_from_op
return_from_posi_call:
	szn	pr6|mcode		check mocde
	tze	vol_call		next volume_status call
	tra	reel_exit		return
file_unopen:
	lda	pr1|90		optional bit
	cmpa	optional_int	optional internal
	tze	return_to_reset
	cmpa	optional_ext	optional external
	tze	return_to_reset
	lda	io30_con
	ldq	s2036con
	staq	pr6|status12
	ldx1	17,du
	tra	return_thru_text_base_pone
reel_exit:
	epp1	pr6|92,*
	tra	return_to_reset
"
"
"
"
"	Please insert the next operator before this line.
"
"
	segdef	cobol_operators_end
cobol_operators_end:
	oct	0
	include cobol_operators_info
	end




		    cobol_rts_.pl1                  10/19/90  1706.5rew 10/19/90  1655.1      540099



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8090 cobol_rts_.pl1 Disallow duplicate prime keys in Indexed Sequential
     files.
  2) change(90-10-03,Zimmerman), approve(90-10-03,MCR8218),
     audit(90-10-10,Gray), install(90-10-19,MR12.4-1048):
     Add check for pre-MR12.3 object segs to prevent attempts to access fields
     that do not exist.
                                                   END HISTORY COMMENTS */


/* Modified on 12/19/84 by FCH, [5.3-1], BUG573(phx16343), error checking fails for ark */
/* Modified on 07/17/82 by FCH, [5.1-1], REWRITE after ACCESS DYNAMIC can cause runtime abort, BUG532(phx13391) */
/* Modified on 09/18/81 by FCH, [5.0-1], WRITE with alt keys can abort in rts, BUG 506 */
/* Modified on 06/11/81 by FCH, [4.4-2], RTS(62) added for STOP RUN with CD INITIAL */
/* Modified on 02/19/81 by FCH, [4.4-1], REWRITE invalid detection not correct, RTS(61) added, BUG464 */
/* Modified on 12/13/79 by PRP, [4.1-1], day of year fixed for leap year */
/* Modified on 09/14/79 by FCH, [4.0-4], iox_$attach_ptr replaces iox_$attach_iocb */
/* Modified on 09/06/79 by FCH, [4.0-3], rewrite with alt rec keys */
/* Modified on 08/24/79 by PRP, [4.0-2], rts(60) added for alternate key start control */
/* Modified on 08/13/79 by FCH, [4.0-1], icode value changed in start statement */
/* Modified since Version 4.0	*/




/*	This is the cobol run time interface procedure.
	It is called by the cobol_operators_ with the parameters are set in the stack frame
	starting from the 68th word.
	From the 68th word up through the 107th word are reserved for this interfacinguse.
	From the 108th word up through the 137th word are reserved for the condition
	handling use.
	The 68th word up through the 73th word are used to set the parameter rts_stack_ptr.
	The rts_code is the 88th words of the stack frame, it is used to decide the run time
	procedure that cobol_rts_ is going to call.
Register Usage

	$pr0	cobol_operators_
	$pr1	fsb pointer
	$pr2	temporary
	$pr3	cobol_data_area
	$pr4	cobol_linkage_area
	$pr5	cobol_data_area(extension)
	$pr6	stack_prame pointer
	$pr7	temporary

	Run Time Stack Frame

  0   0
  1   1
  2   2
  3   3
  4   4
  5   5
  6   6
  7   7
  8  10
  9  11
 10  12
 11  13
 12  14
 13  15
 14  16
 15  17
 16  20	S.prev_sp, S.condition_word, S.flag_word
 17  21
 18  22	S.next_sp, S.signaller_word
 19  23
 20  24	S.return_ptr
 21  25
 22  26	S.entry_ptr
 23  27
 24  30	S.operator_ptr, S.lp_ptr
 25  31
 26  32	S.arg_ptr
 27  33
 28  34	S.static_ptr
 29  35	S.support_ptr
 30  36	S.on_unit_relptrs, on_unit_ptr
 31  37	S.operator_ret_ptr, S.translator_id, op_return_offset
 32  40	S.regs, display_ptr
 33  41
 34  42	descriptor_ptr
 35  43
 36  44	linkage_ptr
 37  45
 38  46	text_base_ptr
 39  47	text_base_off
 40  50	mcode
 41  51	icode
 42  52	status12
 43  53	status3
 44  54	retrycode, cobol_open_mode
 45  55
 46  56	multics_open_mode
 47  57
 48  60	S.min_length
 49  61
 50  62
 51  63
 52  64
 53  65
 54  66
 55  67
 56  70
 57  71
 58  72
 59  73
 60  74
 61  75
 62  76
 63  77
 64 100	return_to_main_ptr
 65 101	return_to_main_off
 66 102	rts_code_ptr
 67 103
 68 104
 69 105
 70 106
 71 107
 72 110	rts_code						args to cobol_rts
 73 111	use_code
 74 112	iocb_ptr
 75 113
 76 114	mcode_ptr
 77 115
 78 116	buff_ptr
 79 117
 80 120	buff_len
 81 121	actual_ptr
 82 122	stack_buff_ptr, cobol_open_mode
 83 123	cobol_options
 84 124	vfile_open_mode
 85 125	key of ref
 86 126	fsb_ptr			iox_, arg-1	args for iox_calls
 87 127
 88 130	file_desc_ptr		iox_, arg-2
 89 131	cobol_error_code
 90 132				iox_, arg-3
 91 133
 92 134				iox_, arg-4
 93 135
 94 136
 95 137
 96 140
 97 141
 98 142
 99 143
100 144	x6_save
101 145
102 145
103 147
104 150
105 151
106 152 	subr_return_save
107 153	subr_return_save_off
108 154	pr4_save
109 155
110 156	pr3_save
111 157
112 160	pr5_save
113 161
114 162	rts_save
115 163
116 164	ind_mask
117 165
		ENTRY OPTIONS

FUNCTION NAME			COBOL OPERATORS

(1)   cobol_error_
(2)   cobol_control_
(3)   sort_initiate
(4)   sort_release
(5)   sort_return
(6)   sort_terminate
(7)   sort_commence
(8)   stop_literal
(9)   stop_run
(10)  cancel
(11)  iox_$control		23
(129  check_close_error	27,29,36,38
(13)  check_open_error
(14)  iox_$find_iocb
(15)  iox_$attach_iocb	29,35,36
(16)  check_seek_errors	41,54,67
(17)  iox_$read_key		55
(18)  accept
(19)
(20)  accept_id
(21)  accept_id
(22)  accept_id
(23)  inspect
(24)  inspect
(25)  seek_for_delete	57,58
(26)  read_key_status_code	69
(27)  check_read_record	65,66
(28)  check_get_line	64
(29)
(30)  merge_init
(31)  merge_comp
(32)  merge_return
(33)
(34)
(35)
(36)
(37)
(38)
(39)
(40)  receive_comm
(41)  accept_comm
(42)  purge_comm
(43)  send_comm
(44)  enable_comm
(45)  disable_comm
(46)  alt_file_open
(47)  alt_read_record

		Status_Key_1 (Status_Key_2)

org = seq
	0(0)1(0)3(0,4)9
org = rel
	0(0)1(0)2(2,3,4)3(0)9
org=ind
	0(0,2)1(0)2(1,2,3,4)3(0)9

Status_Key_1 =	0 success
		1 at end
		2 invalid
		3 permanent error
		9 implementor defined

Status_Key_2 =	0 no more information
		1 sequence error
		2 duplicate key
		3 no record found
		4 boundary violation

Status_Key_3 pic 9999	wxyz

	w: cobol i/o statement
	x: vfile_command
	y: same as key_1
	z: specific cause of error

vfile_commands and error codes

	attach_ptr	(not_detached)
	close		(not_open)
	delete_record	(no_record)
	detach_iocb	(not_attached, not_closed)
	find_iocb		()
	get_chars		(short_record,end_of_info)
	get_line		(short_record,end_of_info)
	open		(not_attached,not_closed)
	position		(no_record,end_of_info)
	read_key		(end_of_info,no_record)
	read_length	(end_of_info,no_record)
	read_record	(end_of_info,no_record,long_record)
	record_status)	(no_room_for_lock,no_record,no_key)
	rewrite_record	(no_record)
	seek_head		(no_record)
	seek_key		(no_record,key_order)
	write_record	(no_key)

*/





/* format: style3 */
cobol_rts_:
     proc (rts_ptr);

dcl	1 rts_stack	based (rts_stack_ptr),
	  2 rts_code	fixed bin;

dcl	temp_mcode	fixed bin (35);
dcl	rts_stack_ptr	ptr;
dcl	rts_ptr		ptr;

	rts_stack_ptr = rts_ptr;
	goto rts (rts_stack.rts_code);

/*	*******************************
	*			*
	*	cobol_error_	*
	*			*
	*******************************/

rts (1):						/* This label is for cobol error	*/
						/* The declaration for the rts stack frame	*/
dcl	1 error_stack	based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 use_code	fixed bin,
	  2 filler1	char (60),
	  2 cobol_code	fixed bin,
	  2 multics_code	fixed bin (35),
	  2 filler2	fixed bin,
	  2 line_no1	fixed bin,
	  2 line_no2	fixed bin,
	  2 error_ptr	ptr,
	  2 progname_ptr	ptr,
	  2 progname_length fixed bin;

dcl	progname		char (65) based (progname_ptr);




	if error_stack.use_code = 0
	then call cobol_error_ (error_stack.cobol_code, error_stack.multics_code, error_stack.line_no1,
		error_stack.line_no2, substr (progname, 1, error_stack.progname_length), error_stack.error_ptr);
	else do;
		error_stack.use_code = 0;
		call cobol_error_$use (error_stack.cobol_code, error_stack.multics_code, error_stack.line_no1,
		     error_stack.line_no2, substr (progname, 1, error_stack.progname_length), error_stack.error_ptr);
	     end;
	return;



/*	*******************************
	*			*
	*	cobol_control_	*
	*			*
	*******************************/

rts (2):						/* This label is for cobol control	*/
						/* This stack frame is for cobol_contool_ rts stack frame.	*/
dcl	1 control_stack	based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 filler	char (4),
	  2 pr4_save_ptr	ptr;



	call cobol_control_$cobol_rts_control_ (control_stack.pr4_save_ptr);
	return;

/*	*******************************************************************************************/

/*		BEGIN SORT PACKAGE							*/

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



/*	*******************************
	*			*
	*	sort_initiate	*
	*			*
	*******************************/

rts (3):						/* This label is for sort_initiate	*/
						/* The declaration for the rts stack frame	*/
dcl	1 sort_initiate_stack
			based (rts_stack_ptr),
	  2 filler1	char (8),
	  2 exit_ptr	ptr,
	  2 control_ptr	ptr,
	  2 filler2	char (8),
	  2 status_code	fixed bin (35);

dcl	1 exits		based (sort_initiate_stack.exit_ptr),
	  2 version	fixed bin,
	  2 compare	entry,
	  2 input_record	entry,
	  2 output_record	entry;



	exits.input_record = sort_$noexit;
	exits.output_record = sort_$noexit;
	controlp = sort_initiate_stack.control_ptr;

	if sort_file_size = 0.0
	then sort_file_size = 1.0;
	if sort_dir_len = 0
	then call sort_$initiate ("", null (), sort_initiate_stack.exit_ptr, "-bf", sort_file_size,
		sort_initiate_stack.status_code);
	else call sort_$initiate (substr (sort_dir, 1, sort_dir_len), null (), sort_initiate_stack.exit_ptr, "-bf",
		sort_file_size, sort_initiate_stack.status_code);
	return;






/*	*******************************
	*			*
	*	sort_release	*
	*			*
	*******************************/

rts (4):						/* This label is for sort_release	*/
						/* The declaration for the rts stack frame	*/
dcl	1 sort_release_stack
			based (rts_stack_ptr),
	  2 filler1	char (8),
	  2 data_ptr	ptr,
	  2 data_length	fixed bin (21),
	  2 filler2	char (12),
	  2 status_code	fixed bin (35);

dcl	sort_$release	entry (ptr, fixed bin (21), fixed bin (35));



	call sort_$release (sort_release_stack.data_ptr, sort_release_stack.data_length, sort_release_stack.status_code)
	     ;
	return;





/*	*******************************
	*			*
	*	sort_return	*
	*			*
	*******************************/

rts (5):						/* This label is for sort_return	*/
						/* The declaration for the rts stack frame	*/
dcl	1 sort_return_stack based (rts_stack_ptr),
	  2 filler1	char (8),
	  2 buff_ptr	ptr,
	  2 record_length	fixed bin (21),
	  2 filler2	char (12),
	  2 status_code	fixed bin (35);



	call sort_$return (sort_return_stack.buff_ptr, sort_return_stack.record_length, sort_return_stack.status_code);
	if sort_return_stack.status_code = 0
	then return;
	else if sort_return_stack.status_code = error_table_$end_of_info
	then do;
		sort_return_stack.record_length = 0;
		sort_return_stack.status_code = 0;
	     end;
	return;




/*	*******************************
	*			*
	*	sort_terminate	*
	*			*
	*******************************/

rts (6):						/* This label is for sort_terminate	*/
						/* The declaration for the rts stack frame	*/
dcl	1 sort_terminate_stack
			based (rts_stack_ptr),
	  2 filler1	char (8),
	  2 status_code	fixed bin (35),
	  2 filler2	char (20),
	  2 prev_status_code
			fixed bin (35);



	call sort_$terminate (sort_terminate_stack.status_code);

	return;


/*	*******************************
	*			*
	*	sort_commence	*
	*			*
	*******************************/

rts (7):						/* This label is for sort_commence	*/
						/* The declaration for the rts stack frame	*/
dcl	1 sort_commence_stack
			based (rts_stack_ptr),
	  2 filler1	char (32),
	  2 status_code	fixed bin (35);




	call sort_$commence (sort_commence_stack.status_code);
	return;


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

/*		END SORT PACKAGE							*/

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


/*	*******************************
	*			*
	*	stop literal	*
	*			*
	*******************************/

rts (8):						/* This label is for "stop literal". It is used to eleminate the link for cu_$cl.*/
	call cu_$cl;
	return;





/*	*******************************
	*			*
	*	stop run		*
	*			*
	*******************************/

rts (9):						/* This label is for "stop run". It is used to eleminate the link for cobol_stoprun_. */
dcl	temp_ptr		ptr based;		/* temporary pointer. */

	stat_ptr = addrel (rts_stack_ptr, 36) -> temp_ptr;/* linkage section */
	stat_ptr = addrel (stat_ptr, 8);		/* static section */
	controlp = stat.control_ptr;

rts9:
	if control.main_prog_sw ^= 0
	then call signal_ ("stop_run", null (), stat_ptr);
	call cobol_stop_run_ (stat_ptr, 0, 0, 0);
	call signal_ ("command_abort_", null (), null ());
	return;

rts (62):						/*[4.4-2]*/
dcl	cobol_mcs_$stop_run entry;

/*[4.4-2]*/
	stat_ptr = addrel (rts_stack_ptr, 36) -> temp_ptr;/* linkage section */
						/*[4.4-2]*/
	stat_ptr = addrel (stat_ptr, 8);		/* static section */
						/*[4.4-2]*/
	controlp = stat.control_ptr;

/*[4.4-2]*/
	call cobol_mcs_$stop_run;

	go to rts9;








/*	*******************************
	*			*
	*	cancel		*
	*			*
	*******************************/


rts (10):						/* this label is for cancel code to call cobol_control_$cancel	*/
dcl	1 cancel_stack	based (rts_stack_ptr),
	  2 filler	char (8),
	  2 name_ptr	ptr,
	  2 name_length	fixed bin,
	  2 cancel_code	fixed bin;

dcl	cancel_name	char (65) based (cancel_stack.name_ptr);

	call cobol_control_$cancel (substr (cancel_name, 1, cancel_stack.name_length), 0, 0, cancel_code);
	return;

/*	*******************************************************************************************/

/*		BEGIN IO PACKAGE							*/

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


/******************************
	*			*
	*	iox_$control	*
	*			*
	*******************************/

rts (11):						/* This label is for iox_$control */
dcl	1 iox_control_stack based (error_block.offset_ptr),
	  2 iocb_ptr	ptr,
	  2 control_ptr	ptr;
dcl	1 struc		based (iox_control_stack.control_ptr),
	  2 relation	fixed bin,
	  2 keylen	fixed bin,
	  2 key		char (0 refer (keylen));

dcl	order_name	char (9) init ("seek_head");
dcl	control_iocb_ptr	ptr based (iox_control_stack.iocb_ptr);



	call iox_$control (control_iocb_ptr, order_name, iox_control_stack.control_ptr, mcode);

	if mcode ^= 0
	then do;
		if mcode = error_table_$no_record
		then do;
			error_block.status12 = "23";
			error_block.status3 = "6723"; /*[4.0-1] */
			icode = 4;
		     end;
		else do;
			error_block.status12 = "30";
			error_block.status3 = "6732";
		     end;
	     end;
	return;



/* The declaration for the rts stack frame	*/

dcl	1 io_stack_hdr	based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 use_code	fixed bin,
	  2 iocb_ptr	ptr,
	  2 mcode_ptr	ptr,
	  2 buff_ptr	ptr,
	  2 buff_len	fixed bin (21),
	  2 actual_len	fixed bin (21),
	  2 stack_buff_ptr	ptr;
dcl	1 read_key_based	based (addr (io_stack_hdr.stack_buff_ptr)),
	  2 filler	fixed bin,
	  2 read_key_eof	fixed bin;
dcl	1 error_block	based (io_stack_hdr.mcode_ptr),
	  2 mcode		fixed bin (35),
	  2 icode		fixed bin,
	  2 status12	char (2) aligned,
	  2 status3	char (4) aligned,
	  2 retrycode	fixed bin,
	  2 filler1	char (4),
	  2 option_flag	fixed bin,
	  2 filler2	char (4),
	  2 offset_ptr	ptr,
	  2 filler13	char (16),
	  2 temp_flag	fixed bin;


/*	*******************************
	*			*
	*	check close error	*
	*			*
	*******************************/

rts (12):						/* This label is for  check close error	*/
						/* The fields referenced are in dcl error_block. */
check_close_error:
	error_block.status12 = "30";
	if mcode = error_table_$no_operation
	then error_block.status3 = "2332";
	else if mcode = error_table_$bad_file
	then error_block.status3 = "2392";
	else error_block.status3 = "2390";
	return;






/******************************
	*			*
	*	check open error	*
	*			*
	*******************************/

rts (13):						/* This label is for  check open error */
						/* The fields referenced are in dcl error_block. */
check_open_error:
	error_block.status12 = "30";
	if mcode = error_table_$no_operation
	then error_block.status3 = "1232";
	else if mcode = error_table_$file_busy
	then error_block.status3 = "1291";
	else if mcode = error_table_$incompatible_attach
	then error_block.status3 = "1294";
	else if mcode = error_table_$bad_file
	then error_block.status3 = "1292";
	else if mcode = error_table_$noentry
	then error_block.status3 = "1295";
	else error_block.status3 = "1290";
	return;


/******************************
	*			*
	*	iox_$find_iocb	*
	*			*
	*******************************/

rts (14):						/* This label is for iox_$find_iocb */
dcl	1 find_iocb_stack	based (error_block.offset_ptr),
	  2 fsb_ptr	ptr,
	  2 switchlen	fixed bin,
	  2 filler2	char (4),
	  2 switchname	char (0 refer (find_iocb_stack.switchlen));

dcl	find_iocb_ptr	ptr based (find_iocb_stack.fsb_ptr);



	call iox_$find_iocb (find_iocb_stack.switchname, find_iocb_ptr, error_block.mcode);

	return;





/*******************************
	*			*
	*	iox_$attach_ptr	*
	*			*
	*******************************/

rts (15):						/* This labe is for iox_$attach_iocb */
dcl	1 attach_iocb_stack based (error_block.offset_ptr),
	  2 fsb_ptr	ptr,
	  2 atdlen	fixed bin,
	  2 filler2	char (4),
	  2 atd		char (0 refer (attach_iocb_stack.atdlen));

dcl	attach_iocb_ptr	ptr based (attach_iocb_stack.fsb_ptr);



/*[4.0-4]*/
	call iox_$attach_ptr (attach_iocb_ptr, attach_iocb_stack.atd, null (), error_block.mcode);

	return;




/******************************
	*			*
	*	check seek errors	*
	*			*
	*******************************/

rts (16):						/* This label is for  check seek key errors */
check_seek_error:
	if temp_flag = 1
	then do;
		if mcode = error_table_$key_order
		then do;
			icode = 1;
			error_block.status12 = "21";
			error_block.status3 = "3621";
		     end;
		else if mcode = error_table_$no_record
		then do;
			icode = 1;
			error_block.status12 = "23";
			error_block.status3 = "3623";
		     end;
		else do;
			error_block.status12 = "30";
			if mcode = error_table_$no_operation
			then error_block.status3 = "3632";
			else error_block.status3 = "3630";
		     end;
	     end;
	else do;
		if mcode = error_table_$no_record
		then do;
			error_block.status12 = "00";
			error_block.status3 = "0000";
			mcode = 0;
		     end;
		else if mcode = error_table_$key_order
		then do;
			error_block.status12 = "21";
			error_block.status3 = "4621";
		     end;
		else do;


			error_block.status12 = "21";
			error_block.status3 = "4622";
		     end;
	     end;


	return;



/*******************************
	*			*
	*	iox_$read_key	*
	*			*
	*******************************/

rts (17):						/* This label is for iox_$read_key errors */
read_key_error:					/* don't report EOF now, wait for seek */
	if mcode = error_table_$end_of_info
	then do;
		error_block.status12 = "00";
		error_block.status3 = "0000";
		read_key_based.read_key_eof = 1;
		mcode = 0;
	     end;
	else if mcode = error_table_$no_record
	then do;
		error_block.status12 = "10";
		error_block.status3 = "3830";
	     end;
	return;






/*	*******************************
	*			*
	*	accept		*
	*			*
	*******************************/

rts (18):						/* This label is interfacing with accept_gen for accpting user's word. */
	call iox_$get_line (iox_$user_input, io_stack_hdr.buff_ptr, io_stack_hdr.buff_len, io_stack_hdr.actual_len,
	     error_block.mcode);

	if error_block.mcode = error_table_$long_record
	then do while (error_block.mcode = error_table_$long_record);
		call iox_$get_line (iox_$user_input, io_stack_hdr.stack_buff_ptr, 64, io_stack_hdr.actual_len,
		     error_block.mcode);
		io_stack_hdr.actual_len = 0;
	     end;
	return;


rts (20):
rts (21):
rts (22):						/* These labels are for accept <id> from day (time,day of week, and date). */
dcl	1 time_stack	based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 use_code	fixed bin,
	  2 month		fixed bin,
	  2 filler1	char (4),
	  2 dom		fixed bin,		/* day of the month */
	  2 filler2	char (4),
	  2 year		fixed bin,
	  2 filler3	char (4),
	  2 tod		fixed bin (71),		/*time of the day */
	  2 dow		fixed bin,		/*day of the week */
	  2 zone		char (3) aligned,		/* time zone */
	  2 day_return	fixed bin,		/* day in the form yy||doy */
	  2 filler4	char (4),
	  2 doy		fixed bin,		/* day of the year */
	  2 filler5	char (4),
	  2 date		char (6);			/* day in the form yy||mm||dd */

dcl	date_time		fixed bin (71),
	d_array		(12) fixed bin static init (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334),
	day_temp		char (8);

	date_time = clock_ ();

	if time_stack.rts_code = 22
	then do;
		call date_time_ (date_time, day_temp);
		date = substr (day_temp, 7, 2) || substr (day_temp, 1, 2) || substr (day_temp, 4, 2);
		return;
	     end;

	call decode_clock_value_ (date_time, month, dom, year, tod, dow, zone);
	if time_stack.rts_code ^= 20
	then return;

	doy = d_array (month) + dom;

	if mod (year, 4) = 0 & month > 2		/* [4.1-1] */
	then doy = doy + 1;
	else /*do nothing */
	     ;
	return;



/*	*******************************
	*			*
	*	inspect		*
	*			*
	*******************************/

rts (23):
rts (24):						/* These labels are for inspect to call cobol_su_$tally and cobol_su_$replace. */
dcl	1 inspect_stack	based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 filler	char (4),
	  2 work_ptr	ptr,
	  2 output_length	fixed bin;

	if inspect_stack.rts_code = 24
	then call cobol_su_$replace (inspect_stack.work_ptr);
	else call cobol_su_$tally (inspect_stack.work_ptr, inspect_stack.output_length);
	return;






/*	*****************************************
	*			*
	*	seek for delete	*
	*			*
	*******************************/

rts (25):						/* This label is for delete seek and delete record. */
	if mcode = error_table_$no_record
	then do;
		error_block.status12 = "00";
		error_block.status3 = "0000";
		mcode = 0;
	     end;
	return;


/*******************************
	*			*
	*	check_read_key	*
	*			*
	*******************************/

rts (26):						/* This label is used to set up status code for read key	*/
						/* don't report EOF now, wait for seek */
	if mcode = error_table_$end_of_info
	then do;
		error_block.status12 = "10";
		error_block.status3 = "3810";
		icode = 1;
	     end;
	else if mcode = error_table_$no_record
	then do;
		icode = 1;
		error_block.status12 = "10";
		error_block.status3 = "3830";
	     end;
	else if mcode = error_table_$no_operation
	then do;
		error_block.status12 = "30";
		error_block.status3 = "3832";
	     end;
	else do;
		error_block.status12 = "30";
		error_block.status3 = "3830";
	     end;
	return;



/*******************************
	*			*
	*	check_read_record	*
	*			*
	*******************************/

rts (27):						/* This label is used to set up status code for read record	*/
	if mcode = error_table_$short_record
	then do;
		mcode = 0;
		error_block.status12 = "00";
		error_block.status3 = "3001";
	     end;
	else if mcode = error_table_$no_record
	then do;
		if temp_flag = 1
		then do;
			error_block.status12 = "23";
			error_block.status3 = "3423";
		     end;
		else do;
			error_block.status12 = "10";
			error_block.status3 = "3430";
		     end;
		icode = 1;
	     end;
	else if mcode = error_table_$end_of_info
	then do;
		icode = 1;
		if temp_flag = 0
		then do;
			error_block.status12 = "10";
			error_block.status3 = "3410";
		     end;
		else do;
			error_block.status12 = "30";
			error_block.status3 = "3430";
		     end;
	     end;
	else do;
		error_block.status12 = "30";
		if mcode = error_table_$no_operation
		then error_block.status3 = "3432";
		else do;
			error_block.status12 = "10";	/* force END OF FILE condition */
			error_block.status3 = "3410";
		     end;
	     end;
	return;



/*******************************
	*			*
	*	check_get_line	*
	*			*
	*******************************/

rts (28):						/* This label is used to set up status codes for get_line.	*/
	if mcode = error_table_$end_of_info
	then do;
		icode = 1;
		error_block.status12 = "10";
		error_block.status3 = "3510";
	     end;
	else if mcode = error_table_$long_record
	then do;
		error_block.status12 = "30";
		error_block.status3 = "3535";
	     end;
	else do;
		error_block.status12 = "30";
		error_block.status3 = "3535";
	     end;
	return;







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

/*		END IO PACKAGE							*/

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

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

/*		BEGIN MERGE PACKAGE							*/

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


/*	The declaration for the communication stack frame which is shared by all merge rts package.	*/

dcl	1 merge_comm_stack	based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 filler	char (28),
	  2 merge_stack_off_rts
			fixed bin,
	  2 file_n_rts	fixed bin,
	  2 merge_record_ptr_rts
			ptr,
	  2 tree_ptr_rts	ptr,
	  2 comp_ptr_rts	ptr,
	  2 merge_controlp	ptr;

/* static internal data for merge communication stack frame in case the
	merge_comm_stack is destoryed by other rts call.		*/

dcl	1 merge_comm_static static,
	  2 merge_stack_off fixed bin,		/* start offset for record ptr. */
	  2 file_n	fixed bin,		/* no of using file. */
	  2 merge_record_ptr
			ptr,			/* base of record (pointers) */
	  2 tree_ptr	ptr,			/* base of tree (fixed bin)	*/
	  2 comp_ptr	ptr,			/* base of compare entry. */
	  2 merge_seg_ptr	ptr;			/* pointer for cobol_temp_merge_file_. */

/* compare entry	*/

dcl	1 cmp_entry	based (merge_comm_static.comp_ptr),
	  2 merge_compare	entry (ptr, ptr, fixed bin);

/* pointers to the cra of each using file. */

dcl	1 merge_record	based (merge_comm_static.merge_record_ptr),
	  2 record	(merge_comm_static.file_n) ptr;

/* temporary locations for compare usage. */

dcl	1 merge_tree	based (merge_comm_static.tree_ptr),
	  2 tree		(2 * merge_comm_static.file_n - 1) fixed bin,
	  2 compare_code	fixed bin;

/* Automatic data for merge package.	*/

dcl	(i, j, k, w)	fixed bin;



/*	*******************************
	*			*
	*	merge_init	*
	*			*
	*******************************/

rts (30):						/* Initialize the stack frame for merge and trees.	*/
	merge_comm_static.file_n = merge_comm_stack.file_n_rts;
	merge_comm_static.merge_record_ptr = merge_comm_stack.merge_record_ptr_rts;
	merge_comm_static.tree_ptr = merge_comm_stack.tree_ptr_rts;
	merge_comm_static.comp_ptr = merge_comm_stack.comp_ptr_rts;
	controlp = merge_controlp;

	call hcs_$terminate_name ("cobol_temp_merge_file_", temp_mcode);

	if sort_dir_len = 0
	then do;
		sort_dir = get_pdir_ ();
		sort_dir_len = index (sort_dir, " ") - 1;
	     end;

	call hcs_$make_seg (substr (sort_dir, 1, sort_dir_len), "cobol_temp_merge_file_", "cobol_temp_merge_file_",
	     01011b, merge_seg_ptr, temp_mcode);
	call hcs_$truncate_seg (merge_seg_ptr, 0, temp_mcode);

	do i = 1 to merge_comm_static.file_n;
	     merge_tree.tree (i) = i;
	end;

	return;


/*	*******************************
	*			*
	*	merge_comp	*
	*			*
	*******************************/

rts (31):						/* Set up to call merge compare. */
	if merge_comm_static.file_n = 1
	then return;
	do i = 1 by 2 to (2 * merge_comm_static.file_n - 3);
	     call merge_call_compare (i, i + 1);
	end;
	return;



/*	*******************************
	*			*
	*	merge_return	*
	*			*
	*******************************/

rts (32):						/* handle return statement for merge. */
	k = 2 * merge_comm_static.file_n - 1;
	if k = 1
	then return;
	i = tree (k);
	do while (i < k);
	     if mod (i, 2) = 0
	     then j = i - 1;
	     else j = i + 1;
	     call merge_call_compare (i, j);
	     i = w;
	end;
	return;

/*	*******************************************************************************************/

/*		INTERNAL SUBROUTINE FOR MERGE COMPARE SET UP				*/

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

merge_call_compare:
     proc (i, j);

/* This subroutine is used to set up tree on the stack frame through the compare
	entry on the cobol object code.	*/

dcl	(i, j)		fixed bin;

	w = merge_comm_static.file_n + (i + 1) / 2;
	if merge_tree.tree (i) = 0
	then merge_tree.tree (w) = merge_tree.tree (j);	/* eof of file i */
	else if merge_tree.tree (j) = 0
	then merge_tree.tree (w) = merge_tree.tree (i);	/* eof of file j */
	else do;
		call merge_compare (merge_record.record (merge_tree.tree (i)),
		     merge_record.record (merge_tree.tree (j)), merge_tree.compare_code);
		if merge_tree.compare_code = -1
		then merge_tree.tree (w) = merge_tree.tree (i);
		else if merge_tree.compare_code = 1
		then merge_tree.tree (w) = merge_tree.tree (j);
		else if merge_tree.tree (i) < merge_tree.tree (j)
		then merge_tree.tree (w) = merge_tree.tree (i);
		else merge_tree.tree (w) = merge_tree.tree (j);
	     end;
	return;

     end merge_call_compare;



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

/*		END MERGE PACKAGE							*/

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

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

/*		BEGIN COMMUNICATION PACKAGE						*/

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


/*	*******************************
	*			*
	*	receive_comm	*
	*			*
	*******************************/

rts (40):
dcl	1 receive_comm_stack
			based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 filler	fixed bin,
	  2 mcs_icdp	ptr,
	  2 mesp		ptr,
	  2 type		fixed bin,
	  2 max_meslen	fixed bin,
	  2 filler1	fixed bin,
	  2 no_data	fixed bin,
	  2 filler2	char (8),
	  2 code		fixed bin (35);

	if receive_comm_stack.type >= 2
	then do;
		receive_comm_stack.type = receive_comm_stack.type - 2;
		call cobol_mcs_$receive (receive_comm_stack.mcs_icdp, receive_comm_stack.type,
		     receive_comm_stack.mesp, receive_comm_stack.max_meslen, receive_comm_stack.code);
		if receive_comm_stack.code = cmcs_error_table_$no_message
		then do;
			receive_comm_stack.code = 0;
			receive_comm_stack.no_data = 1;
		     end;
		else receive_comm_stack.no_data = 0;
	     end;
	else do;
		call cobol_mcs_$receive_wait (receive_comm_stack.mcs_icdp, receive_comm_stack.type,
		     receive_comm_stack.mesp, receive_comm_stack.max_meslen, receive_comm_stack.code);
	     end;
	return;





/*	*******************************
	*			*
	*	accept_comm	*
	*			*
	*******************************/


rts (41):
dcl	1 accept_comm_stack based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 filler	fixed bin,
	  2 mcs_icdp	ptr,
	  2 filler1	char (32),
	  2 code		fixed bin (35);

	call cobol_mcs_$accept (accept_comm_stack.mcs_icdp, accept_comm_stack.code);
	return;


/*	*******************************
	*			*
	*	purge_comm	*
	*			*
	*******************************/







rts (42):
dcl	1 purge_comm_stack	based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 filler	fixed bin,
	  2 mcs_icdp	ptr,
	  2 filler1	char (32),
	  2 code		fixed bin (35);

	call cobol_mcs_$purge (purge_comm_stack.mcs_icdp, purge_comm_stack.code);
	return;







/*	*******************************
	*			*
	*	send_comm		*
	*			*
	*******************************/

rts (43):
dcl	1 send_comm_stack	based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 filler	fixed bin,
	  2 mcs_ocdp	ptr,
	  2 mesp		ptr,
	  2 max_meslen	char (4),
	  2 end_indicator	char (1),
	  2 filler2	char (3),
	  2 line_control	bit (36),
	  2 filler1	char (12),
	  2 code		fixed bin (35);

	call cobol_mcs_$send (send_comm_stack.mcs_ocdp, send_comm_stack.mesp, send_comm_stack.max_meslen,
	     send_comm_stack.end_indicator, send_comm_stack.line_control, send_comm_stack.code);
	return;




/*	*******************************
	*			*
	*	enable_comm	*
	*			*
	*******************************/

rts (44):
dcl	1 enable_comm_stack based (rts_stack_ptr),
	  2 rts_code	fixed bin,
	  2 filler	fixed bin,
	  2 mcs_icdp	ptr,
	  2 password_ptr	ptr,
	  2 password_length fixed bin,
	  2 in_or_out	fixed bin,
	  2 terminal_flag	fixed bin,
	  2 filler1	char (12),
	  2 code		fixed bin (35);

dcl	password		char (30) based (enable_comm_stack.password_ptr);

	if enable_comm_stack.in_or_out = 0
	then do;
		if enable_comm_stack.terminal_flag = 1
		then call cobol_mcs_$enable_input_terminal (enable_comm_stack.mcs_icdp,
			substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code);
		else call cobol_mcs_$enable_input_queue (enable_comm_stack.mcs_icdp,
			substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code);
	     end;
	else call cobol_mcs_$enable_output (enable_comm_stack.mcs_icdp,
		substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code);
	return;

rts (45):						/* Disable use the same stack as enable.	*/
	if enable_comm_stack.in_or_out = 0
	then do;
		if enable_comm_stack.terminal_flag = 1
		then call cobol_mcs_$disable_input_terminal (enable_comm_stack.mcs_icdp,
			substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code);
		else call cobol_mcs_$disable_input_queue (enable_comm_stack.mcs_icdp,
			substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code);
	     end;
	else call cobol_mcs_$disable_output (enable_comm_stack.mcs_icdp,
		substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code);
	return;



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

/*		BEGIN ALTERNATE RECORD KEY PACKAGE					*/

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




dcl	1 alt_stack_hdr	based (rts_stack_ptr),
	  2 rts_code	fixed bin (35),
	  2 use_code	fixed bin (35),
	  2 iocb_ptr	ptr,
	  2 mcode_ptr	ptr,
	  2 file_rec_buf_ptr
			ptr,
	  2 file_desc_ptr	ptr,
	  2 cobol_open_mode fixed bin (35),
	  2 cobol_options	fixed bin (35),
	  2 vfile_open_mode fixed bin (35),
	  2 key_of_ref	fixed bin (35),
	  2 fsb_ptr	ptr,			/*[5.3-1]*/
	  2 arg2_ptr	ptr,			/*[5.3-1]*/
	  2 arg3_ptr	ptr,			/*[5.3-1]*/
	  2 arg4_ptr	ptr,			/*[5.3-1]*/
	  2 arg5_ptr	ptr;

dcl	1 seek_info,
	  2 relation_type	fixed bin,
	  2 n		fixed bin,
	  2 search_key	char (256);

declare	mode		fixed bin;

/*
	where:

	relation_type	0 =  search_key
			1 >= search_key
			2 >  search_key

	n is the length of the search_key

	search_key is the character string used to match indeies

*/

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

/*		 AUTOMATIC VARIABLES FOR ALTERNATE RECORD KEYS				*/

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


declare	file_record_buffer	char (1000000) based (buff_ptr);
declare	rs_record_buffer	char (1000000) based (rs_info.record_ptr);

dcl	dummy_buffer	char (1);
dcl	char1		char (1);

dcl	rec_len		fixed bin (21);
dcl	save_sw		bit (1);

declare	key_num		fixed bin (35);
declare	(buff_ptr, alt_key_desc_ptr)
			ptr;
declare	KEY_OF_REF	fixed bin static internal;
declare	(CODE, KEY_NUM)	fixed bin (35);
declare	REC_LEN		fixed bin (21);
declare	READ_KEY		char (256) varying;

declare	1 status_info,
	  2 info		aligned like rs_info;

declare	1 GK_INFO,
	  2 HDR		like gk_header,
	  2 KEY		char (256);
declare	1 AK_INFO,
	  2 HDR		like ak_header,
	  2 KEY		char (256);

declare	MCODE		fixed bin (35) based (alt_stack_hdr.mcode_ptr);
						/*[5.3-1]*/
dcl	BUFF_LEN		fixed bin (21) based;	/*[5.3-1]*/
dcl	REC_LGT		fixed bin (21) based;	/*[5.3-1]*/
dcl	BUFF_PTR		ptr;			/*[4.4-1]*/
declare	key_status	(512) bit (1) static internal;

/*	*******************************
	*			*
	*	open		*
	*			*
	*******************************/

rts (46):						/* This label is for the OPEN statement with alternate record keys */
	fsb_ptr = alt_stack_hdr.fsb_ptr;
	fsb.file_desc_ptr = alt_stack_hdr.file_desc_ptr;
	file_desc_1_ptr = fsb.file_desc_ptr;
	fsb.vfile_open_mode = alt_stack_hdr.vfile_open_mode;
	fsb.cobol_open_mode = alt_stack_hdr.cobol_open_mode;
	fsb.last_cobol_op = 1;			/* open */
	alt_stack_hdr.fsb_ptr -> fsb.key_of_ref = 511;	/* prime key */
	fsb.crp.prime_key = "";

/*[5.3-1]*/
	if fsb.fsb_skel.mod1
	then fsb.last_key_read = "";

	if fsb.cobol_open_mode = 29 | /* input(seq) */ fsb.cobol_open_mode = 30
	     | /* input(ran) */ fsb.cobol_open_mode = 31 | /* input(dyn) */ fsb.cobol_open_mode = 45
	     | /* i-o(seq) */ fsb.cobol_open_mode = 46 | /* i-o(ran */ fsb.cobol_open_mode = 47
						/* i-o(dyn) */
	then do;					/* position the file */
		seek_info.relation_type = 0;
		seek_info.n = 1;			/*[4.4-1]*/
		unspec (char1) = "111111111"b;	/*[4.4-1]*/
		seek_info.search_key = char1;

		call iox_$control (fsb.iocb_ptr, "seek_head", addr (seek_info), MCODE);
	     end;
	return;




/*	*******************************
	*			*
	*	close		*
	*			*
	*******************************/


rts (47):						/* This label is for the CLOSE statement with alternate record keys */
						/*[4.4-1]*/
	call set_up;

	fsb.last_cobol_op = 2;			/* close */
						/*[5.3-1]*/
	if fsb.fsb_skel.mod1
	then fsb.last_key_read = "";
	return;



/*	*******************************
	*			*
	*	start		*
	*			*
	*******************************/


rts (48):						/* OP79(start) */
						/*[4.4-1]*/
	call set_up;

	fsb.last_cobol_op = 3;			/* start */
	fsb.key_of_ref = KEY_OF_REF;
	return;




/*	*******************************
	*			*
	*	read next		*
	*			*
	*******************************/


rts (49):						/* OP80(read next) */
						/*[4.4-1]*/
	call set_up;

	fsb.last_cobol_op = 4;			/* read next */
	return;




/*	*******************************
	*			*
	*	read key		*
	*			*
	*******************************/


rts (50):						/* OP(1(read key) */
						/*[4.4-1]*/
	call set_up;

	fsb.last_cobol_op = 5;			/* read key */

	if fsb.cobol_open_mode = 31 /* ind-dyn(i) */ | fsb.cobol_open_mode = 63 /* ind-dyn(o) */
	     | fsb.cobol_open_mode = 47		/* ind-dyn(io) */
	then fsb.key_of_ref = KEY_OF_REF;
	return;



/*	*******************************
	*			*
	*	write		*
	*			*
	*******************************/


rts (51):						/* OP91(write) */
						/*[4.4-1]*/
	call set_up;

	unspec (char1) = "111111111"b;
	buff_ptr = alt_stack_hdr.file_rec_buf_ptr;
	rs_info_ptr = addr (status_info);
	alt_key_desc_ptr = addr (file_desc_1.alt_key (1));

	if fsb.cobol_open_mode = 61			/* output seq */
	then if char1 || substr (fsb.key, 1, fsb.keylen_sw) /* keys not sequential */ <= fsb.crp.prime_key
	     then do;
		     MCODE = error_table_$key_order;
		     return;
		end;

	save_sw = "0"b;

	call save_NRP;

	if fsb.vfile_open_mode ^= 9			/* keyed sequential output */
	then /*[4.4-1]*/
	     do;
		key_len_ptr = addr (vfile_key.size);
		key_ptr = addr (vfile_key.key);

		do key_num = 1 to file_desc_1.alt_key_count;

/*[5.0-1]*/
		     call set_off_sz;

/*[4.4-1]*/
		     call form_alt_key (buff_ptr);	/*[4.4-1]*/
		     call iox_$seek_key (fsb.iocb_ptr, substr (vfile_key.key, 1, vfile_key.size), rec_len, MCODE);

		     if MCODE = 0			/* duplicate exists */
		     then if file_desc_1.alt_key (key_num).size >= 0
			then do;			/* duplicate exists and not legal */
				if save_sw
				then call restore_NRP;

				MCODE = error_table_$key_duplication;
				return;
			     end;

		end;				/*[4.4-1]*/
	     end;
	fsb.key = char1 || substr (fsb.key, 1, fsb.keylen_sw);
	fsb.keylen_sw = fsb.keylen_sw + 1;

	MCODE = 0;

	return;




rts (52):						/* OP87(delete) */
						/*[4.4-1]*/
	call set_up;				/*[4.4-1]*/
	call rec_status;

/*[4.4-1]*/
	if MCODE ^= 0
	then return;

/*[5.3-1]*/
	if fsb.cobol_open_mode = 45			/*[5.3-1]*/
	then if fsb.last_cobol_op ^= 4		/* read */
						/*[5.3-1]*/
	     then do;
		     error_block.status12 = "30";	/*[5.3-1]*/
		     error_block.status3 = "7033";	/*[5.3-1]*/
		     MCODE = error_table_$no_record;	/*[5.3-1]*/
		     return;			/*[5.3-1]*/
		end;


/*[4.4-1]*/
	call init_ak_info ("delete_key");

/*[4.4-1]*/
	do key_num = 1 by 1 to file_desc_1.alt_key_count;

/*[4.4-1]*/
	     call set_off_sz;

/*[4.4-1]*/
	     call process_key (rs_info.record_ptr);

/*[4.4-1]*/
	end;

	MCODE = 0;

	return;



/*	*******************************
	*			*
	*	rewrite		*
	*			*
	*******************************/

rts (61):						/* OP93(rewrite) */
						/*[4.4-1]*/
	call set_up;				/*[4.4-1]*/
	call rec_status;

/*[4.4-1]*/
	if MCODE ^= 0
	then return;

/*[4.4-1]*/
	buff_ptr = alt_stack_hdr.file_rec_buf_ptr;	/*[4.4-1]*/
	alt_key_desc_ptr = addr (file_desc_1.alt_key (1));

/*[4.4-1]*/
	call init_gk_info;
	gk_info.header.reset_pos = "1"b;
	string (key_status) = "0"b;

/*[4.4-1]*/
	do key_num = 1 by 1 to file_desc_1.alt_key_count;

/*[4.4-1]*/
	     call set_off_sz;
	     call keys_unequal;

/*[4.4-1]*/
	     if sz >= 0				/*[4.4-1]*/
	     then if key_comp			/*[4.4-1]*/
		then do;				/*[4.4-1]*/
			call process_key (buff_ptr);	/*[4.4-1]*/
			if MCODE = 0		/*[4.4-1]*/
			then do;
				MCODE = error_table_$key_duplication;
						/*[4.4-1]*/
				return;		/*[4.4-1]*/
			     end;			/*[4.4-1]*/
		     end;

/*[4.4-1]*/
	end;

/*[4.4-1]*/
	call init_ak_info ("delete_key");

/*[4.4-1]*/
	do key_num = 1 by 1 to file_desc_1.alt_key_count;

/*[4.4-1]*/
	     call set_off_sz;

/*[4.4-1]*/
	     if key_status (key_num)
	     then call process_key (rs_info.record_ptr);

/*[4.4-1]*/
	end;

/*[4.4-1]*/
	return;

/*[4.4-1]*/
declare	(sz_abs, sz, off)	fixed bin;		/*[4.4-1]*/
declare	(key_len_ptr, key_ptr, info_ptr)
			ptr;			/*[4.4-1]*/
declare	key_op		char (10);

/*[4.4-1]*/
declare	1 vfile_key,				/*[4.4-1]*/
	  2 size		fixed bin,		/*[4.4-1]*/
	  2 key		char (256);

set_off_sz:
     proc;

/*[4.4-1]*/
	off = file_desc_1.alt_key.offset (key_num) + 1;	/*[4.4-1]*/
	sz = file_desc_1.alt_key.size (key_num);

/*[4.4-1]*/
	sz_abs = abs (sz);

     end;						/*[4.4-1]*/
declare	key_comp		bit (1);
keys_unequal:
     proc;

/*[4.4-1]*/
	if substr (rs_record_buffer, off, sz_abs) ^= substr (file_record_buffer, off, sz_abs)
						/*[4.4-1]*/
	then do;
		key_comp = "1"b;
		key_status (key_num) = "1"b;
	     end;					/*[4.4-1]*/
	else key_comp = "0"b;

     end;

process_key:
     proc (loc);					/* add_key, delete_key, get_key */
						/*[4.4-1]*/
declare	loc		ptr;

/*[4.4-1]*/
	call form_alt_key (loc);			/*[4.4-1]*/
	call iox_$control (fsb.iocb_ptr, key_op, info_ptr, MCODE);

     end;

form_alt_key:
     proc (rec_ptr);

/*[4.4-1]*/
declare	rec_ptr		ptr;			/*[4.4-1]*/
declare	alt_key_num	char (1);

/*[4.4-1]*/
declare	key_len		fixed bin based (key_len_ptr);/*[4.4-1]*/
declare	key		char (256) based (key_ptr);	/*[4.4-1]*/
declare	record		char (1000000) based (rec_ptr);

/*[4.4-1]*/
	key_len = sz_abs + 1;			/*[4.4-1]*/
	unspec (alt_key_num) = substr (unspec (key_num), 28, 9);

/*[4.4-1]*/
	substr (key, 1, key_len) = alt_key_num || substr (record, off, key_len);

     end;

set_up:
     proc;

/*[4.4-1]*/
	fsb_ptr = alt_stack_hdr.fsb_ptr;		/*[4.4-1]*/
	if fsb.fsb_skel.mod1 then
	     file_desc_1_ptr = fsb.file_desc_ptr;
	else if unspec (fsb.file_desc_ptr) = (2) "040040040040"b3 then           /* pre [5.3-1] initialization */
	     file_desc_1_ptr = null ();
	else file_desc_1_ptr = fsb.file_desc_ptr;
     


     end;

rec_status:
     proc;

/*[4.4-1]*/
	call init_rs_info;				/*[4.4-1]*/
	call iox_$control (fsb.iocb_ptr, "record_status", rs_info_ptr, MCODE);

     end;




/*	*******************************
	*			*
	*	delete		*
	*			*
	*******************************/

rts (53):						/* OP86(delete) */
						/*[4.4-1]*/
	call set_up;

	fsb.last_cobol_op = 7;

	return;




/*	*******************************
	*			*
	*	make key read	*
	*			*
	*******************************/

rts (54):						/* OP82(start) */
	mode = 0;

rts54:						/*[4.4-1]*/
	call set_up;

	unspec (char1) = substr (unspec (alt_stack_hdr.key_of_ref), 28, 9);
	call make_key (char1, mode);

	KEY_OF_REF = alt_stack_hdr.key_of_ref;
	return;





/*	*******************************
	*			*
	*	make key write	*
	*			*
	*******************************/


rts (55):						/* OP85(delete,rewrite) */
						/*[4.4-1]*/
	call set_up;

	unspec (char1) = "111111111"b;

	call save_NRP;

/*[4.0-3]*/
	call make_key (char1, 1);

	return;



/*	*******************************
	*			*
	*	add keys		*
	*			*
	*******************************/

rts (56):						/* OP90(write) */
						/*[4.4-1]*/
	call set_up;

	buff_ptr = alt_stack_hdr.file_rec_buf_ptr;

	if fsb.cobol_open_mode = 61
	then fsb.crp.prime_key = substr (fsb.key, 1, fsb.keylen_sw);

/*[4.4-1]*/
	call init_ak_info ("add_key");

/*[4.4-1]*/
	do key_num = 1 by 1 to file_desc_1.alt_key_count;

/*[4.4-1]*/
	     call set_off_sz;

/*[4.4-1]*/
	     call process_key (buff_ptr);

/*[4.4-1]*/
	end;

	fsb.last_cobol_op = 8;			/* write */
	return;




/*	*******************************
	*			*
	*	read restore	*
	*			*
	*******************************/

rts (57):						/* OP92(read) */
						/*[4.4-1]*/
	call set_up;

	rs_info_ptr = addr (status_info);

	if fsb.last_cobol_op = 6 | /* rewrite */ fsb.last_cobol_op = 7 | /* delete */ fsb.last_cobol_op = 8
						/* write */
	then call restore_NRP;

/*[5.1-1]*/
	if MCODE ^= 0
	then return;
	call iox_$read_key (fsb.iocb_ptr, READ_KEY, REC_LEN, CODE);

/*[5.1-1]*/
	if CODE ^= 0				/*[5.1-1]*/
	then MCODE = CODE;				/*[5.1-1]*/
	else call eof_test (addr (READ_KEY));

/*[5.1-1]*/
	return;










/*





/*	*******************************
	*			*
	*	rewrite add keys	*
	*			*
	*******************************/

rts (58):						/* OP88(rewrite) */
						/*[4.4-1]*/
	call set_up;
	buff_ptr = alt_stack_hdr.file_rec_buf_ptr;	/*[4.4-1]*/
	call rec_status;

	if MCODE ^= 0
	then return;

/*[4.4-1]*/
	call init_ak_info ("add_key");

/*[4.4-1]*/
	do key_num = 1 by 1 to file_desc_1.alt_key_count;

/*[4.4-1]*/
	     call set_off_sz;

/*[4.4-1]*/
	     if key_status (key_num)
	     then call process_key (buff_ptr);

/*[4.4-1]*/
	end;

	fsb.last_cobol_op = 6;			/* rewrite */

	return;

rts (59):						/* OP84(read) */
	mode = 1;

	go to rts54;


/*[4.0-2]*/
rts (60):
dcl	rlen		fixed bin (21, 0);
dcl	new_key		char (256) varying;

	call iox_$control (control_iocb_ptr, order_name, iox_control_stack.control_ptr, mcode);

	if mcode = 0
	then call iox_$read_key (control_iocb_ptr, new_key, rlen, mcode);

	if mcode ^= 0
	then do;
		if mcode = error_table_$no_record
		then do;
			error_block.status12 = "23";
			error_block.status3 = "6723"; /*[4.0-1] */
			icode = 4;
		     end;
		else do;
			error_block.status12 = "30";
			error_block.status3 = "6732";
		     end;
		return;
	     end;


	if substr (struc.key, 1, 1) ^= substr (new_key, 1, 1)
	then do;
		mcode = error_table_$no_record;
		error_block.status12 = "23";
		error_block.status3 = "6723";
	     end;

	return;

rts (63):						/* OP65(read) */
						/*[5.3-1]*/
	call set_up;

/*[5.3-1]*/
	BUFF_PTR = alt_stack_hdr.arg2_ptr -> temp_ptr;

/*[5.3-1]*/
	call iox_$read_record /*[5.3-1]*/ (alt_stack_hdr.fsb_ptr -> temp_ptr,
						/* iocb ptr */
						/*[5.3-1]*/
	     BUFF_PTR,				/* buffer ptr */
						/*[5.3-1]*/
	     alt_stack_hdr.arg3_ptr -> BUFF_LEN,	/* buffer length */
						/*[5.3-1]*/
	     alt_stack_hdr.arg4_ptr -> REC_LGT,		/* record length */
						/*[5.3-1]*/
	     alt_stack_hdr.arg5_ptr -> MCODE /* error code */ /*[5.3-1]*/);

/*[5.3-1]*/
	if ^fsb.fsb_skel.mod1 | alt_stack_hdr.arg5_ptr -> MCODE ^= 0
	then return;				/*[5.3-1]*/
	if fsb.cobol_open_mode = 45			/*[5.3-1]*/
	then fsb.last_key_read /*[5.3-1]*/ = substr (BUFF_PTR -> file_record_buffer,
						/*[5.3-1]*/
		file_desc_1.prime_key.offset + 1,	/*[5.3-1]*/
		file_desc_1.prime_key.size /*[5.3-1]*/);

/*[5.3-1]*/
	return;

rts (64):						/* OP59(rewrite) */
						/*[5.3-1]*/
	call set_up;

/*[5.3-1]*/
	if fsb.cobol_open_mode = 45			/* i/o,ind,seq */
						/*[5.3-1]*/
	then do;
		if fsb.last_cobol_op ^= 4		/* must be read */
						/*[5.3-1]*/
		then do;
			error_block.status12 = "30";	/*[5.3-1]*/
			error_block.status3 = "5033";

/*[5.3-1]*/
			return;			/*[5.3-1]*/
		     end;

/*[5.3-1]*/
		BUFF_PTR = alt_stack_hdr.arg2_ptr -> temp_ptr;

/*[5.3-1]*/
		if fsb.fsb_skel.mod1 then  /*[5.3-1]*/ 
		     if /*[5.3-1]*/ fsb.last_key_read /*[5.3-1]*/
		     ^= substr /*[5.3-1]*/ (BUFF_PTR -> file_record_buffer,
						/*[5.3-1]*/
		     file_desc_1.prime_key.offset + 1,	/*[5.3-1]*/
		     file_desc_1.prime_key.size /*[5.3-1]*/)
						/*[5.3-1]*/
		then do;
			error_block.status12 = "30";	/*[5.3-1]*/
			error_block.status3 = "5024";

/*[5.3-1]*/
			alt_stack_hdr.arg5_ptr -> MCODE = error_table_$no_record;

/*[5.3-1]*/
			return;			/*[5.3-1]*/
		     end;				/*[5.3-1]*/
	     end;

/*[5.3-1]*/
	call iox_$rewrite_record /*[5.3-1]*/ (alt_stack_hdr.fsb_ptr -> temp_ptr,
						/* iocb ptr */
						/*[5.3-1]*/
	     BUFF_PTR,				/* buffer ptr */
						/*[5.3-1]*/
	     alt_stack_hdr.arg3_ptr -> REC_LGT,		/* record length */
						/*[5.3-1]*/
	     alt_stack_hdr.arg4_ptr -> MCODE /* error code */ /*[5.3-1]*/);

/*[5.3-1]*/
	return;



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

/*		 ALTERNATE RECORD KEY PACKAGE INTERNAL SUBROUTINES			*/

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

/*[5.1-1]*/
dcl	res		bit (1);

make_key:
     proc (char1, mode);

dcl	p		ptr,
	mode		fixed bin,
	char1		char (1);

dcl	1 SEEK_KEY	based (p),
	  2 rel		fixed bin,
	  2 n		fixed bin,
	  2 seek_key	char (256);

declare	1 SK		based (p),
	  2 n		fixed bin,
	  2 seek_key	char (256);

	p = alt_stack_hdr.iocb_ptr;

	if mode = 0
	then do;
		substr (SEEK_KEY.seek_key, 1, SEEK_KEY.n + 1) = char1 || substr (SEEK_KEY.seek_key, 1, SEEK_KEY.n);
		SEEK_KEY.n = SEEK_KEY.n + 1;
	     end;
	else do;
		substr (SK.seek_key, 1, SK.n + 1) = char1 || substr (SK.seek_key, 1, SK.n);
		SK.n = SK.n + 1;
	     end;

     end make_key;


/*[4.4-1]*/
declare	read_key_key	char (256) varying;

save_NRP:
     proc;


	if (fsb.cobol_open_mode = 45 | /* i-o(seq) */ fsb.cobol_open_mode = 46
	     | /* i-o(ran) */ fsb.cobol_open_mode = 47 /* i-o(dyn ) */)
	     &
	     /*[5.1-1]*/ (fsb.last_cobol_op = 1 | /* open */ fsb.last_cobol_op = 3 | /* start */ fsb.last_cobol_op = 4
	     | /* read next */ fsb.last_cobol_op = 5 /* read key */ /*[5.1-1]*/)
	then do;					/* save the keys for the next record */
		call iox_$read_key (fsb.iocb_ptr, read_key_key, rec_len, MCODE);
		save_sw = "1"b;

		if MCODE = error_table_$end_of_info
		then fsb.crp.prime_key = "";
		else if MCODE = error_table_$no_record
		then fsb.crp.prime_key = "";
		else do;

/*[5.1-1]*/
			call eof_test (addr (read_key_key));
						/*[5.1-1]*/
			if MCODE ^= 0		/*[5.1-1]*/
			then do;
				fsb.crp.prime_key = "";
						/*[5.1-1]*/
				return;		/*[5.1-1]*/
			     end;

/*[4.4-1]*/
			call rec_status;		/*[4.4-1]*/
			if MCODE ^= 0
			then return;

			fsb.crp.prime_key =
			     substr (rs_record_buffer, (file_desc_1.prime_key.offset + 1),
			     file_desc_1.prime_key.size);

/*[4.4-1]*/
			key_num = fsb.key_of_ref;
			call set_off_sz;

/*[4.4-1]*/
			if key_num ^= 511
			then do;

				fsb.crp.alt_key = substr (rs_record_buffer,
						/*[4.4-1]*/
				     off,		/*[4.4-1]*/
				     sz_abs);

			     end;

			fsb.crp.descriptor = rs_info.descriptor;
		     end;

	     end;

     end save_NRP;

restore_NRP:
     proc;

declare	key_len		fixed bin,
	key_ptr		ptr;			/*[4.0-3]*/
declare	key_string	char (512) varying based (key_ptr);

	if fsb.crp.prime_key = ""
	then do;
		MCODE = error_table_$end_of_info;
		return;
	     end;

	if fsb.key_of_ref = 511
	then do;
		key_len = length (fsb.prime_key) + 1;
		key_ptr = addr (fsb.prime_key);
	     end;
	else do;
		key_len = length (fsb.alt_key) + 1;
		key_ptr = addr (fsb.alt_key);
	     end;

	unspec (char1) = substr (unspec (fsb.key_of_ref), 28, 9);

/*[5.1-1]*/
	if fsb.key_of_ref = 511 /* prime key */ /*[5.1-1]*/ | /*[5.1-1]*/ file_desc_1.alt_key.size (fsb.key_of_ref) >= 0
						/* dupl illeg */
						/*[5.1-1]*/
	then res = "1"b;				/*[5.1-1]*/
	else res = "0"b;

/*[5.1-1]*/
	if res					/*[5.1-1]*/
	then do;

		call init_gk_info;

		gk_info.header.descrip = fsb.crp.descriptor;
		gk_info.header.key_len = key_len + 1;
		gk_info.key = char1 || substr (key_string, 1, key_len);


		gk_info.flags.position_specification.head_size = gk_info.header.key_len;

		call iox_$control (fsb.iocb_ptr, "get_key", gk_info_ptr, MCODE);

		if MCODE = 0
		then return;

	     end;

	seek_info.relation_type = 1;			/* >= */
	seek_info.n = key_len + 1;
	seek_info.search_key = char1 || substr (key_string, 1, key_len);

/*[5.1-1]*/
	call iox_sh;

	if MCODE ^= 0
	then do;
		MCODE = error_table_$end_of_info;
		return;
	     end;

	if res
	then return;

/*[4.4-1]*/
	call rec_status;

/*[5.1-1]*/
	if MCODE ^= 0
	then return;





/*[5.1-1]*/
	call key_compare;

/*[5.1-1]*/
	if res
	then return;


	i = 1;

	do while ("1"b);

/*[5.1-1]*/
	     call iox_rr;

	     if MCODE = error_table_$long_record
	     then MCODE = 0;
	     else if MCODE ^= 0
	     then return;

/*[4.4-1]*/
	     call rec_status;

	     if MCODE ^= 0
	     then return;










/*[5.1-1]*/
	     call key_compare;

/*[5.1-1]*/
	     if res
	     then do;

/*[5.1-1]*/
		     call iox_sh;

		     if MCODE ^= 0
		     then return;


		     do j = 1 to i - 1 by 1;

/*[5.1-1]*/
			call iox_rr;


			if MCODE = error_table_$long_record
			then MCODE = 0;
			else if MCODE ^= 0
			then return;

		     end;

		     return;

		end;

	     i = i + 1;

	end;

     end restore_NRP;




init_rs_info:
     proc;					/* record_status */
						/*[4.4-1]*/
	rs_info_ptr = addr (status_info);

	rs_info.version = rs_info_version_2;
	rs_info.lock_sw = "0"b;
	rs_info.unlock_sw = "0"b;
	rs_info.create_sw = "0"b;
	rs_info.locate_sw = "0"b;
	rs_info.inc_ref_count = "0"b;
	rs_info.dec_ref_count = "0"b;
	rs_info.locate_pos_sw = "0"b;
	rs_info.mbz1 = "0"b;
	rs_info.mbz2 = 0;
	rs_info.descriptor = 0;

     end init_rs_info;

init_gk_info:
     proc;

/*[4.4-1]*/
	gk_info_ptr = addr (GK_INFO);

/*[4.4-1]*/
	key_len_ptr = addr (gk_info.header.key_len);	/*[4.4-1]*/
	key_ptr = addr (gk_info.key);			/*[4.4-1]*/
	key_op = "get_key";				/*[4.4-1]*/
	info_ptr = gk_info_ptr;

	gk_info.header.flags.input_key = "1"b;
	gk_info.header.flags.input_desc = "1"b;
	gk_info.header.version = gk_info_version_0;
	gk_info.header.flags.position_specification.rel_type = 0;
						/* = */
	gk_info.header.flags.reset_pos = "0"b;
	gk_info.header.pad = "0"b;

     end;

init_ak_info:
     proc (op);					/* add_key, delete_key */
						/*[4.4-1]*/
declare	op		char (*);

/*[4.4-1]*/
	ak_info_ptr = addr (AK_INFO);

/*[4.4-1]*/
	key_len_ptr = addr (ak_info.header.key_len);	/*[4.4-1]*/
	key_ptr = addr (ak_info.key);			/*[4.4-1]*/
	key_op = op;				/*[4.4-1]*/
	info_ptr = ak_info_ptr;

/*[4.4-1]*/
	ak_info.header.input_key = "1"b;		/*[4.4-1]*/
	ak_info.header.descrip = 0b;			/*[4.4-1]*/
	ak_info.header.mbz = "0"b;

     end;

key_compare:
     proc;

/*[5.1-1]*/
	if substr /*[5.1-1]*/ (rs_record_buffer,	/*[5.1-1]*/
	     file_desc_1.alt_key.offset (fsb.key_of_ref) + 1,
						/*[5.1-1]*/
	     abs (file_desc_1.alt_key.size (fsb.key_of_ref)) /*[5.1-1]*/) /*[5.1-1]*/ ^= fsb.crp.alt_key /*[5.1-1]*/
	     | /*[5.1-1]*/ substr /*[5.1-1]*/ (rs_record_buffer,
						/*[5.1-1]*/
	     file_desc_1.prime_key.offset + 1,		/*[5.1-1]*/
	     file_desc_1.prime_key.size /*[5.1-1]*/) /*[5.1-1]*/ = fsb.crp.prime_key
						/*[5.1-1]*/
	then res = "1"b;				/*[5.1-1]*/
	else res = "0"b;

     end;

iox_sh:
     proc;

/*[5.1-1]*/
	call iox_$control (fsb.iocb_ptr, "seek_head", addr (seek_info), MCODE);

     end;

iox_rr:
     proc;

/*[5.1-1]*/
	call iox_$read_record (fsb.iocb_ptr, addr (dummy_buffer), 1, rec_len, MCODE);

     end;

eof_test:
     proc (key_loc);

/*[5.1-1]*/
dcl	key_loc		ptr;			/*[5.1-1]*/
dcl	key_str		char (256) varying based (key_loc);

/*[5.1-1]*/
	KEY_NUM = 0;				/*[5.1-1]*/
	substr (unspec (KEY_NUM), 28, 9) = unspec (substr (key_str, 1, 1));

/*[5.1-1]*/
	if KEY_NUM ^= fsb.key_of_ref
	then MCODE = error_table_$end_of_info;
	else MCODE = 0;

     end;



/*	Please insert the next run time package before this line.	*/





/* EXTERNAL_NAMES */

dcl	iox_$user_input	ptr ext;


dcl	cobol_error_	entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (*), ptr);
dcl	cobol_error_$use	entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (*), ptr);
dcl	cobol_control_$cobol_rts_control_
			entry (ptr);

dcl	sort_$initiate	entry (char (*), ptr, ptr, char (*), float bin (27), fixed bin (35));
dcl	sort_$noexit	entry ext;


dcl	error_table_$end_of_info
			fixed bin (35) ext;
dcl	error_table_$key_duplication
			fixed bin (35) ext;
dcl	error_table_$long_record
			fixed bin (35) ext;
dcl	error_table_$short_record
			fixed bin (35) ext;
dcl	error_table_$no_record
			fixed bin (35) external;
dcl	error_table_$key_order
			fixed bin (35) external;
dcl	error_table_$incompatible_attach
			fixed bin (35) external;
dcl	error_table_$noentry
			fixed bin (35) external;
dcl	error_table_$file_busy
			fixed bin (35) external;
dcl	error_table_$no_operation
			fixed bin (35) external;
dcl	error_table_$bad_file
			fixed bin (35) external;

dcl	sort_$return	entry (ptr, fixed bin (21), fixed bin (35));

dcl	sort_$terminate	entry (fixed bin (35));

dcl	sort_$commence	entry (fixed bin (35));

dcl	cu_$cl		entry;

dcl	cobol_stop_run_	entry (ptr, fixed bin, fixed bin, fixed bin),
	signal_		entry (char (*), ptr, ptr);
declare	iox_$attach_ptr	entry (ptr, char (*), ptr, fixed bin (35));
declare	iox_$control	entry (ptr, char (*), ptr, fixed bin (35));
declare	iox_$find_iocb	entry (char (*), ptr, fixed bin (35));
declare	iox_$get_line	entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
declare	iox_$read_key	entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));
declare	iox_$read_record	entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
declare	iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35));
declare	iox_$seek_key	entry (ptr, char (256) varying, fixed bin (21), fixed bin (35));

dcl	cobol_control_$cancel
			entry (char (*), fixed bin, fixed bin, fixed bin);


dcl	clock_		entry returns (fixed bin (71)),
	date_time_	entry (fixed bin (71), char (*)),
	decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin,
			char (3) aligned);

dcl	cobol_su_$tally	entry (ptr, fixed bin),
	cobol_su_$replace	entry (ptr);

dcl	hcs_$terminate_name entry (char (*), fixed bin (35));
dcl	get_pdir_		entry returns (char (168));
dcl	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl	hcs_$truncate_seg	entry (ptr, fixed bin (18), fixed bin (35));

dcl	cobol_mcs_$receive	entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35)),
	cobol_mcs_$receive_wait
			entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35));

dcl	cmcs_error_table_$no_message
			fixed bin (35) ext;

dcl	cobol_mcs_$accept	entry (ptr, fixed bin (35));

dcl	cobol_mcs_$purge	entry (ptr, fixed bin (35));

dcl	cobol_mcs_$send	entry (ptr, ptr, char (4), char (1), bit (36), fixed bin (35));

dcl	cobol_mcs_$enable_input_terminal
			entry (ptr, char (*), fixed bin (35)),
	cobol_mcs_$enable_input_queue
			entry (ptr, char (*), fixed bin (35)),
	cobol_mcs_$enable_output
			entry (ptr, char (*), fixed bin (35));


dcl	cobol_mcs_$disable_input_terminal
			entry (ptr, char (*), fixed bin (35)),
	cobol_mcs_$disable_input_queue
			entry (ptr, char (*), fixed bin (35)),
	cobol_mcs_$disable_output
			entry (ptr, char (*), fixed bin (35));

/* BUILTIN FUNCTIONS */

dcl	(substr, mod, abs, addr, addrel, length, string, unspec, null, index)
			builtin;

%include cobol_stack_frame;
%include cobol_control;
%include cobol_fixed_static;
%include cobol_fsb_type_1;
%include cobol_fsbskel;
%include cobol_file_desc_1;
%include rs_info;
%include ak_info;
     end cobol_rts_;




		    cobol_rts_handler_.pl1          05/24/89  1048.6rew 05/24/89  0836.8       66132



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_rts_handler_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 8/18/76 by Bob Chang to change ext data name cobol_sort_  into cobol_SM_. */
/* Modified on 6/30/76 by Bob Chang to implement cleanup condition for sort. */
/*{*/
/* format: style3 */
cobol_rts_handler_:
     proc (mcp, cond_name, wc_cobol_ptr, info_ptr, continue_sw);


dcl	sort_$terminate	entry (fixed bin (35)),
	mcode		fixed bin (35);		/*
This procedure is the fixedoverflow handler for object
programs compiled by the Multics Cobol compiler.
This procedure looks at a flag in the static data portion of
the linkage section of the Cobol program in which the
fixedoverflow was detected, to determine how to respond to the
fixedoverflow.

	1.  If the flag is zero, then this handler sets its
	parameter "continue_sw" ON, and returns.  Setting
	this parameter ON results in the signalling of
	the next most recently established handler for fixedoverflow,
	after this procedure exits.  (  The effect of this
	type of return is that the execution of this procedure
	has no effect.)
	2.  If the flag is non-zero, then the machine state
	saved at the time the fixedoverflow was detected are
	modified slightly,  (see details below) and this
	procedure returns with parameter "continue_sw" set
	to "0"b.  The effect of this type of return is that
	control returns to the Cobol program in which the
	fixedoverflow condition was detected.
*/

/*  DECLARATION OF THE PARAMETERS  */

/*  dcl mcp ptr;  */
/*  THIS PARAMETER IS DECLARED BELOW
	IN AN INCLUDE FILE  */
dcl	cond_name		char (32);
dcl	cobol_SM_$ec	fixed bin (35) ext,
	cobol_SM_$stat_ptr	ptr ext,
	cobol_SM_$error_ptr ptr ext,
	cobol_SM_$RETbl	fixed bin (35) ext;
dcl	wc_cobol_ptr	ptr;
dcl	info_ptr		ptr;
dcl	continue_sw	bit (1);

dcl	cobol_error_	entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (65) varying, ptr) ext;

/*  DESCRIPTION OF THE PARAMETERS  */

/*  NOTE:  The following information was obtained from the
MPM, section 6.2.  */

/*
PARAMETER		DESCRIPTION

mcp		Pointer to information describing the
		state of the processor at the time the
		fixedoverflow was detected.  (input)
cond_name		Not used by this procedure.
wc_cobol_ptr		Not used by this procedure.
info_ptr		Not used by this procedure.
continue_sw	A binary switch indicating the action to
		be taken when the handler returns to the
		condition mechanism.  Normally, when a
		handler returns, control returns to the
		point at whcih the condiion was raised, and
		that operation is re-tried.  This is the case
		when "continue_sw" is set to "0"b.
		However, if we do want to return
		to the Cobol program in which fixedoverflow
		was detected, we want to return to some
		point OTHER THAN THE POINT WHERE THE
		FIXED OVERFLOW WAS DETECTED.  This is done
		by modifying two entries in the saved
		machine conditions, setting "continue_sw"
		to "0"b, and then returning.  The two entries
		in the saved machine conditions that must
		be modified are:

		1.  The value of the IC at which the
		fixedoverflow was detected.  This value is
		incremented (or decremented) so that when
		this procedure returns, return is to the
		desired point, rather than the point at
		which the fixedoverflow was detected.

		2.  The multi-instruction format
		INDICATOR bit in the saved machine
		conditions is set to "0"b.

		If control is not to return to the Cobol
		program, then the continue_sw" is set to
		"1"b, and this procedure returns.  Under
		these conditions, the condition mechanism
		behaves as though this handler,
		cobol_rts_handler_, had not been established
		and invokes the next most recently established
		handler for the fixedoverflow conditon.

*/

/*}*/

dcl	vprog_id		char (65) varying;

/**************************************************/
/*	START OF EXECUTION			*/
/*	EXTERNAL PROCEDURE			*/
/*	cobol_rts_handler_			*/
/**************************************************/



/* THE CODE FOR HANDLING fixedoverflow IS NOW OBSOLETE */

/*   if cond_name = "fixedoverflow" then do;
/* /*  Base the stack frame template on the stack frame of the procedure in which the fixedoverflow was
/* 	detected.  */
/* 	stack_frame_ptr = mc.prs(6);
/* /*  Get the pointer to the linkage section of the procedure in which the fixedoverflow was detected.  */
/* 	stat_ptr = addrel(stack_frame.link_ptr,8);
/* if stat.fo_flag = 0
/* 	then continue_sw = "1"b;  /*  Return to the most recently previously established
/* 	fixedoverflow handler  */
/* 	else do;  /*  Increment the IC value saved in the machine conditions, and return
/* 		to the Cobol object program in which the overflow was detected.  */
/* 		continue_sw = "0"b;
/* 		/*  Increment the IC by the value contained in the Cobol program's static data area.  */
/* 		scup = addr(mc.scu(0));
/* 		scu.ilc = fixed (unspec(scu.ilc) + stat.fo_disp,18);
/* 		/*  Turn off the multi-instruction format INDICATOR register bit in the
/* 		saved machine conditions for the objcet program in which fixedoverflow was detected.  */
/* 		scu.ir.mif = "0"b;
/* 		end;  /*  Increment the IC value saved in the machine conditions, and return
/* 		to the Cobol object program in whcih the overflow was detected.  */
/*   end;
/* else
*/
	if substr (cond_name, 1, 10) ^= "SORTM_STOP"
	then do;
		call sort_$terminate (mcode);
		return;
	     end;
	else do;					/* temporary. */
		cobol_SM_$RETbl = 0;		/* tell the SORT package  rap up sorting*/
		if cobol_SM_$ec = 8 | cobol_SM_$ec = 9 | cobol_SM_$ec = 11
		then return;
		else do;
			stat_ptr = cobol_SM_$stat_ptr;/* set by appropriate cobol SORT statement. */
			vprog_id = prog_id;
			call cobol_error_ (50, 0, line_no (1), 0, vprog_id, cobol_SM_$error_ptr);
			return;
		     end;
	     end;
	return;					/* shouldn't have gotten here anyhow */



/**************************************************/
/*	INCLUDE FILES USED IN THIS PROCEDURE	*/
/**************************************************/


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

/* %include mc;  OBSOLETE */
dcl	mcp		ptr;
%include cobol_fixed_static;
/* %include cobol_stack_frame;  OBSOLETE */
/**************************************************/
/*	END OF EXTERNAL PROCEDURE		*/
/*	cobol_rts_handler_			*/
/**************************************************/

     end cobol_rts_handler_;




		    cobol_set_pdir.pl1              05/24/89  1048.6rew 05/24/89  0836.8        8946



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1989   *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_set_pdir.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* format: style3 */
cobol_set_pdir:
     proc (N);
dcl	M		char (168);
dcl	get_pdir_		entry returns (char (168));
dcl	N		char (256) var;
	M = get_pdir_ ();
	N = substr (M, 1, (index (M, " ") - 1));
	return;
     end;




		    cobol_source_formatter_.pl1     05/24/89  1048.6rew 05/24/89  0837.3      131355



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_source_formatter_.pl1 Reformatted code to new Cobol
     standard.
                                                   END HISTORY COMMENTS */


/* Modified on 07/20/81 by FCH, reformatted to improve readability, phx10605(BUG495) */
/* Modified on 03/06/81 by FCH, [4.4-2], last line not processed unless it ends in c.r. char, BUG469(TR9264) */
/* Modified on 09/22/80 by FCH, [4.4-1], tabs not handled properly (BUG444) */
/* Modified since Version 4.4 */




/* format: style3 */
cobol_source_formatter_:
     proc (inp, outp, bc, ctype, mtype);

dcl	inp		ptr;
dcl	outp		ptr;
dcl	bc		fixed bin (24);
dcl	ctype		fixed bin;		/* -1=lower_case; +1=upper_case */
dcl	mtype		fixed bin;		/* 0=ignore leading blanks; 1=take leading blanks into account within areas */
dcl	shift		bit (1);
dcl	(identsw, datasw, procsw)
			bit (1);
dcl	contsw		bit (1);
dcl	periodsw		bit (1);
dcl	last_periodsw	bit (1);
dcl	char_count	fixed bin (35);
dcl	code		fixed bin (35);
dcl	source_length	fixed bin;
dcl	inoff		fixed bin;
dcl	outoff		fixed bin;
dcl	cct		fixed bin;
dcl	nl		char (1) static options (constant) init ("
");
dcl	tab		char (1) static options (constant) init ("	");
dcl	blank		char (1) static options (constant) init (" ");
dcl	spaces		char (256) static options (constant) init ("");
dcl	period		char (1) static options (constant) init (".");
dcl	quote		char (1) static options (constant) init ("""");
dcl	chars		char (256) based;
dcl	char_array	(300) char (1) based;
dcl	(ini, outi, nli, tabj, quotei, quotej)
			fixed bin;
dcl	(blanki, periodi)	fixed bin;
dcl	(i, j, len, n)	fixed bin;
dcl	first_quote	fixed bin;
dcl	tline		char (300);
dcl	line		char (300) varying;
dcl	spec_name		(20) char (16) varying static
			init ("01", "77", "1", "fd", "sd", "cd", "rd", "program-id", "author", "installation",
			"date-written", "date-compiled", "security", "source-computer", "object-computer",
			"special-names", "file-control", "i-o-control", "declaratives", "end");

dcl	(addr, index, substr, length, divide)
			builtin;


/*************************************/
start:
	shift = "1"b;
	go to join;

/*************************************/
no_shift:
     entry (inp, outp, bc, ctype);
	shift = "0"b;
/*************************************/
join:
	char_count = 0;
	identsw, datasw, procsw = "0"b;
	contsw = "0"b;
	last_periodsw = "1"b;
	nli = index (inp -> chars, nl);		/*[4.4-2]*/
	cct = divide (bc, 9, 31, 0);

	do while ("1"b);

/*[4.4-2]*/
	     if nli <= 0
	     then nli = cct + 1;

	     if substr (inp -> chars, 1, 1) = "*" | substr (inp -> chars, 1, 1) = "/"
		| substr (inp -> chars, 1, 7) = "      *" | substr (inp -> chars, 1, 7) = "      /"
	     then do;

		     if substr (inp -> chars, 1, 1) = blank
		     then inoff = 7;
		     else inoff = 1;

		     tline = substr (inp -> chars, 1, nli);
		     substr (outp -> chars, 1, 6) = "";
		     outoff = 7;

		     do i = nli - 1 to inoff by -1 while (substr (tline, i, 1) = blank);
		     end;

		     outi = i + 1;
		     substr (tline, outi, 1) = nl;
		     go to skip_shift;

		end;

convert_tabs_and_case:
	     tline = "";				/* convert tabs and case if necessary */
	     ini, outi = 1;

	     do while (ini < nli);

		quotej = index (substr (inp -> chars, ini, nli - ini), quote);
		if quotej = 0
		then quotej = nli - ini + 1;

		quotei = ini + quotej - 1;
		first_quote = quotej;

		do while (ini < quotei);

		     tabj = index (substr (inp -> chars, ini, quotei - ini), tab);

		     if tabj = 0
		     then do;

			     tabj = quotei - ini + 1;
			     n = 0;
			end;
		     else do;

			     n = 10 - mod (outi + tabj - 1, 10);
			     if n = 0
			     then n = 10;
			end;

		     if ctype = 0
		     then substr (tline, outi, tabj - 1) = substr (inp -> chars, ini, tabj - 1);
		     else do;

			     if ctype > 0
			     then line = upper_case (substr (inp -> chars, ini, tabj - 1));
			     else line = lower_case (substr (inp -> chars, ini, tabj - 1));

			     substr (tline, outi, tabj - 1) = line;

			end;

		     ini = ini + tabj;
		     outi = outi + tabj + n - 1;



		end;

		if quotei < nli
		then do;

			quotej = index (substr (inp -> chars, quotei + 1, nli - quotei), quote);


			if quotej = 0
			then do;			/* a continued nonnumeric literal */

				quotej = nli - ini + 1;
				contsw = "1"b;
			     end;
			else quotej = quotej + 1;	/* include both quotes */

			substr (tline, outi, quotej) = substr (inp -> chars, quotei, quotej);
			ini = quotei + quotej;
			outi = outi + quotej;

		     end;

	     end;

check_empty_line:
	     if outi = 1 | tline = ""
	     then do;				/* an empty line */

		     outi = 1;
		     outoff = 1;
		     inoff = 1;
		     substr (tline, 1, 1) = nl;
		     go to skip_shift;
		end;

	     if ^shift
	     then do;

		     substr (tline, outi, 1) = nl;
		     outoff = 1;
		     inoff = 1;
		     go to skip_shift;

		end;

strip_trailing_blanks:
	     substr (outp -> chars, 1, 256) = "";

/* strip trailing blanks and convert to lower case */

	     periodsw = last_periodsw;

	     if ^contsw
	     then do;

		     do i = outi - 1 to 1 by -1 while (substr (tline, i, 1) = blank);
		     end;

		     if substr (tline, i, 1) = period
		     then last_periodsw = "1"b;
		     else last_periodsw = "0"b;

		     outi = i + 1;

		end;
	     else do;

		     contsw = "0"b;
		     last_periodsw = "0"b;
		end;

	     substr (tline, outi, 1) = nl;
	     line = lower_case (substr (tline, 1, outi));

explicit_check:
	     if substr (line, 1, 2) = "a*"
	     then do;				/* check for explicit area specification */

		     substr (line, 1, 2) = "";
		     call division_check;
		     outoff = 8;

		     do inoff = 3 to outi while (substr (line, inoff, 1) = blank);
		     end;

		     if substr (line, inoff, 2) = "1 " | substr (line, inoff, 2) = "1" || nl
		     then do;

			     if inoff = 3 | inoff > 6 | mtype = 0
			     then outoff = 9;
			     else inoff = 3;

			end;
		     else if inoff < 7
		     then inoff = 3;

/* maintain A area indentation */

		end;

	     else if substr (line, 1, 1) = "-" | substr (line, 1, 7) = "      -"
	     then do;

		     if substr (line, 1, 1) = "-"
		     then inoff = 2;
		     else inoff = 8;

		     do inoff = inoff to outi while (substr (line, inoff, 1) = blank);
		     end;

		     substr (outp -> chars, 7, 1) = "-";
		     outoff = 12;

		end;
	     else if substr (line, 1, 2) = "d*"
	     then do;

		     substr (outp -> chars, 7, 1) = "d";
		     inoff = 3;
		     substr (line, 1, 2) = "";

		     go to implicit_check;

		end;
	     else if substr (line, 1, 3) = "da*"
	     then do;

		     substr (outp -> chars, 7, 1) = "d";
		     outoff = 8;

		     do inoff = 4 to outi while (substr (line, inoff, 1) = blank);
		     end;

		     if substr (line, inoff, 2) = "1 " | substr (line, inoff, 2) = "1" || nl
		     then do;

			     if inoff = 4 | inoff > 7 | mtype = 0
			     then outoff = 9;
			     else inoff = 4;
			end;
		     else if inoff < 8
		     then inoff = 4;

		end;
	     else do;				/* no explicit specification - must figure it out */

		     inoff = 1;

implicit_check:
		     outoff = 0;			/* until we know */

		     if ^identsw
		     then do;			/* check for section names and section headers */

section_check:
			     n = index (line, " section");

			     if n > 0 & n < first_quote
			     then if substr (line, n + 8, 1) = period | substr (line, n + 8, 1) = blank
				     | substr (line, n + 8, 1) = nl
				then outoff = 8;

			end;

		     if outoff = 0
		     then call division_check;	/* check for division headers */

		     if outoff = 0 & procsw
		     then do;			/* check for user-defined paragraph names */

paragraph_check:					/*[4.4-1]*/
			     do i = inoff to outi while (substr (line, i, 1) = blank);
			     end;

/* position to first non-blank */

			     blanki = index (substr (line, i, nli - i), blank);

/*[4.4-1]*/
			     if blanki = 0
			     then blanki = outi;
			     else blanki = blanki + i - 1;
						/* set relative to beginning of line */

			     periodi = index (line, period);

			     if periodi > 1
			     then if substr (line, periodi + 1, 1) = nl | substr (line, periodi + 1, 1) = blank
				then do;

					if periodi > blanki
					then do;	/* ignore blanks immediately preceding period */

						do j = periodi - 1 to blanki by -1
						     while (substr (line, j, 1) = blank);
						end;

						periodi = j + 1;

					     end;
					else j = periodi - 1;

					j = j - i + 1;

					if periodi <= blanki & periodsw
					then if (substr (line, i, j) ^= "exit")
						& (substr (line, i, j) ^= "suppress")
					     then outoff = 8;

/* paragraph name */

				     end;

			end;
		     else if outoff = 0 & ^procsw & periodsw
		     then do;			/* check for level indicators */

level_number_check:
			     if mtype = 0
			     then do i = inoff to nli while (substr (line, i, 1) = blank);
				end;
			     else i = inoff;

/* don't adjust B area level numbers already indented */

			     blanki = index (substr (line, i, nli - i), blank);

			     if blanki = 2
			     then do;

				     if substr (line, i, 1) >= "2" & substr (line, i, 1) <= "9"
				     then outoff = 8 + fixed (substr (line, i, 1));


				end;

			     else if blanki = 3 & substr (line, i + 1, 1) ^= "d"
			     then do;		/* FD, CD, RD, or SD */

				     if substr (line, i, 1) >= "0" & substr (line, i, 1) <= "8"
				     then if substr (line, i + 1, 1) >= "0" & substr (line, i + 1, 1) <= "9"
					then outoff = 7 + fixed (substr (line, i, 2));

				     if outoff = 8 | outoff = 84
				     then outoff = 0;
						/* catch 01 and 77 as reserved words */
				     else if outoff = 7 | outoff > 56
				     then outoff = 12;
						/* illegal and 66 and 88 */

				end;

			end;

reserved_word_check:
		     if procsw
		     then i = 20;			/* include "end cobol" only */
		     else if periodsw
		     then i = 1;			/* include level numbers */
		     else i = 4;

		     do i = i to 20 while (outoff = 0); /* check for other Area A reserved words */

			n = index (line, spec_name (i));

			if n > 0
			then if n = 1 | substr (line, 1, n - 1) = substr (spaces, 1, n - 1)
			     then if substr (line, n + length (spec_name (i)), 1) = blank
				     | (substr (line, n + length (spec_name (i)), 1) = period & i > 3)
				     | substr (line, n + length (spec_name (i)), 1) = nl
				then do;

					if i = 3
					then do;	/* "1" */

						outoff = 9;

						do i = inoff to outi while (substr (line, i, 1) = blank);
						end;

						if i < inoff + 4 & i ^= inoff
						then inoff = inoff + 1;
						else inoff = i;

					     end;
					else if i = 20
						/*"end" */
					then if procsw
					     then outoff = 8;
						/* end cobol */
					     else outoff = 12;
						/* end key */

					else outoff = 8;

				     end;

		     end;

		     if outoff = 0			/* nothing special - shift to Area B */
		     then if procsw & ^periodsw & mtype = 0
			then outoff = 16;
			else outoff = 12;


		     else if outoff = 8
		     then do;			/* get rid of leading blanks */

			     do i = inoff to outi while (substr (line, i, 1) = blank);
			     end;

			     if i ^< inoff + 4
			     then inoff = i;

			end;

		end;				/* eliminate existing margins unless -lm specified */

	     if mtype = 0
	     then do inoff = inoff to outi while (substr (line, inoff, 1) = blank);
		end;

skip_shift:					/* output this line and look at next */
	     source_length = outi - inoff + 1;
	     substr (outp -> chars, outoff, source_length) = substr (tline, inoff, source_length);
	     inp = addr (inp -> char_array (nli + 1));
	     char_count = char_count + source_length + outoff - 1;
	     outp = addr (outp -> char_array (source_length + outoff));

/*[4.4-2]*/
	     cct = cct - nli;

/*[4.4-2]*/
	     if cct <= 0				/*[4.4-2]*/
	     then do;
		     bc = 9 * char_count;		/*[4.4-2]*/
		     return;			/*[4.4-2]*/
		end;

	     nli = index (inp -> chars, nl);

	end;

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

division_check:
     proc;
start_division_check:
	n = index (line, " division");

	if n > 0 & n < first_quote
	then if substr (line, n + 9, 1) = period | substr (line, n + 9, 1) = blank | substr (line, n + 9, 1) = nl
	     then do;

		     if identsw
		     then do;

			     n = index (line, "environment ");

			     if n = 0
			     then n = index (line, "data ");

			     if n = 0
			     then n = index (line, "procedure ");

			     if n > 0
			     then if n = 1 | substr (line, 1, n - 1) = substr (spaces, 1, n - 1)
				then do;
					identsw = "0"b;
					outoff = 8;
				     end;

			end;

		     else do;
			     outoff = 8;


			     if index (line, "identification") > 0
			     then identsw = "1"b;

			end;

		     if index (line, "procedure") > 0
		     then do;

			     procsw = "1"b;
			     identsw, datasw = "0"b;	/* just for consistency in weird cases */
			end;
		     else if index (line, "data") > 0
		     then do;

			     datasw = "1"b;
			     identsw, procsw = "0"b;
			end;

		end;

     end division_check;


/*************************************/
lower_case:
     proc (str) returns (char (300) varying);
dcl	str		char (*);
dcl	lc_alphabet	char (128) static options (constant) init ("	
 !""#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\]^_`abcdefghijklmnopqrstuvwxyz{|}~");
dcl	translate		builtin;
	return (translate (str, lc_alphabet));
     end lower_case;

upper_case:
     proc (str) returns (char (300) varying);
dcl	str		char (*);
dcl	lc_alphabet	char (128) static options (constant) init ("	
 !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~");
dcl	translate		builtin;
	return (translate (str, lc_alphabet));
     end upper_case;

     end cobol_source_formatter_;




		    cobol_su_.pl1                   05/24/89  1048.6rew 05/24/89  0836.8       58473



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_su_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 03/31/77 by Bob Chang to fix the bug for tally count.	*/
/* Modified 03/27/76 by ORN to avoid initializing the tally parameter (tout) to zero. */
/* Modified since Version 2.0	*/

/* format: style3 */
cobol_su_:
     proc;

dcl	i		fixed bin;
dcl	k		fixed bin;
dcl	newk		fixed bin;

dcl	str		char (100000) based;


/*************************************/
tally:
     entry (tptr);

dcl	tptr		ptr;
dcl	tout_ptr		ptr;
dcl	tout		(512) fixed bin based (tout_ptr);

dcl	1 t		based (tptr),
	  2 ssp		ptr,
	  2 slen		fixed bin,
	  2 n		fixed bin,
	  2 tally		(0 refer (t.n)),
	    3 ccode	fixed bin,		/* 0=CHARACTERS, 1=LEADING, 2=ALL */
	    3 lcode	fixed bin,		/* 0=unspecified(enabled), 1=BEFORE, 2=AFTER, 3=disabled */
	    3 lpos	fixed bin,		/* char pos to enable after's or disable before's */
	    3 llen	fixed bin,		/* length of BEFORE/AFTER string */
	    3 lsp		ptr,			/* ptr to BEFORE/AFTER string (if lcode ^= 0) */
	    3 csp		ptr,			/* ptr to LEADING/ALL string (if ccode > 0) */
	    3 clen	fixed bin,		/* length of LEADING/ALL string */
	    3 tally_ind	fixed bin;		/* tally count	*/

start_tally:
	tout_ptr = addrel (tptr, t.n * 10 + 4);
	do i = 1 to t.n;
	     if t.lcode (i) ^= 0
	     then do;
		     k = index (substr (t.ssp -> str, 1, t.slen), substr (t.lsp (i) -> str, 1, t.llen (i)));
		     if k = 0
		     then t.lpos (i) = t.slen + 1;
		     else do;
			     if t.lcode (i) = 2
			     then t.lpos (i) = k + t.llen (i);
						/* AFTER */
			     else do;		/* BEFORE */
				     if t.ccode (i) ^= 0
				     then k = k - t.clen (i) + 1;
				     t.lpos (i) = k;
				end;
			end;
		end;
	end;

	do k = 1 to t.slen;
	     newk = k;
	     do i = 1 to t.n;
		if t.lcode (i) = 2
		then if k >= t.lpos (i)
		     then t.lcode (i) = 0;		/* enable AFTER tally */
		     else ;
		else if t.lcode (i) = 1
		then if k >= t.lpos (i)
		     then t.lcode (i) = 3;		/* disable BEFORE tally */
		if t.lcode (i) < 2
		then do;				/* if this tally is enabled */
			if t.ccode (i) = 0
			then do;			/* CHARACTERS */
				tout (t.tally_ind (i)) = tout (t.tally_ind (i)) + 1;
				do i = i + 1 to t.n;/* scrap any eligible LEADING's and discontinue search */
				     if t.lcode (i) < 2
				     then if t.ccode (i) = 1
					then t.lcode (i) = 3;
				end;
			     end;
			else do;
				if k + t.clen (i) - 1 ^> t.slen
				then do;		/* enough string left to compare */
					if substr (t.ssp -> str, k, t.clen (i))
					     = substr (t.csp (i) -> str, 1, t.clen (i))
					then do;
						tout (t.tally_ind (i)) = tout (t.tally_ind (i)) + 1;
						newk = k + t.clen (i) - 1;
						do i = i + 1 to t.n;
						     if t.lcode (i) < 2
						     then if t.ccode (i) = 1
							then t.lcode (i) = 3;
						end;
					     end;
					else if t.ccode (i) = 1
					then t.lcode (i) = 3;
						/* disable LEADING */
				     end;
				else if t.ccode (i) = 1
				then t.lcode (i) = 3;
			     end;
		     end;
	     end;
	     k = newk;
	end;
	return;


/*************************************/
replace:
     entry (rptr);

dcl	rptr		ptr;

dcl	1 r		based (rptr),
	  2 ssp		ptr,
	  2 slen		fixed bin,
	  2 n		fixed bin,
	  2 repl		(0 refer (r.n)),
	    3 ccode	fixed bin,		/* 3=FIRST */
	    3 lcode	fixed bin,
	    3 lpos	fixed bin,
	    3 llen	fixed bin,
	    3 lsp		ptr,
	    3 csp		ptr,
	    3 clen	fixed bin,
	    3 bsp		ptr;			/* ptr to BY string (length must = clen) */

start_replace:
	do i = 1 to r.n;
	     if r.lcode (i) ^= 0
	     then do;
		     k = index (substr (r.ssp -> str, 1, r.slen), substr (r.lsp (i) -> str, 1, r.llen (i)));
		     if k = 0
		     then r.lpos (i) = r.slen + 1;
		     else do;
			     if r.lcode (i) = 2
			     then r.lpos (i) = k + r.llen (i);
						/* AFTER */
			     else do;		/* BEFORE */
				     if r.ccode (i) ^= 0
				     then k = k - r.clen (i) + 1;
				     r.lpos (i) = k;
				end;
			end;
		end;
	end;

	do k = 1 to r.slen;
	     newk = k;
	     do i = 1 to r.n;
		if r.lcode (i) = 2
		then if k >= r.lpos (i)
		     then r.lcode (i) = 0;		/* enable AFTER tally */
		     else ;
		else if r.lcode (i) = 1
		then if k >= r.lpos (i)
		     then r.lcode (i) = 3;		/* disable BEFORE tally */
		if r.lcode (i) < 2
		then do;				/* if this tally enabled */
			if r.ccode (i) = 0
			then do;			/* CHARACTERS */
				substr (r.ssp -> str, k, 1) = substr (r.bsp (i) -> str, 1, 1);
				do i = i + 1 to r.n;/* scrap any eligible LEADING's and discontinue search */
				     if r.lcode (i) < 2
				     then if r.ccode (i) = 1
					then r.lcode = 3;
				end;
			     end;
			else do;
				if k + r.clen (i) - 1 ^> r.slen
				then do;		/* enought string left? */
					if substr (r.ssp -> str, k, r.clen (i))
					     = substr (r.csp (i) -> str, 1, r.clen (i))
					then do;
						substr (r.ssp -> str, k, r.clen (i)) =
						     substr (r.bsp (i) -> str, 1, r.clen (i));
						if r.ccode (i) = 3
						then r.lcode (i) = 3;
						/* FIRST - disable it now */
						newk = k + r.clen (i) - 1;
						do i = i + 1 to r.n;
						     if r.lcode (i) < 2
						     then if r.ccode (i) = 1
							then r.lcode (i) = 3;
						end;
					     end;
					else if r.ccode (i) = 1
					then r.lcode (i) = 3;
						/* disable LEADING */
				     end;
				else if r.ccode (i) = 1
				then r.lcode (i) = 3;
			     end;
		     end;
	     end;
	     k = newk;
	end;
	return;


/*****	Declaration for builtin function	*****/

dcl	(substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index)
			builtin;

/*****	End of declaration for builtin function	*****/

     end cobol_su_;




		    display_cobol_run_unit.pl1      05/24/89  1048.6rew 05/24/89  0837.3       76761



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 display_cobol_run_unit.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 10/24/79 by PRP [4.1-1] added bad_arg error check */
/* Modified on 10/08/77 by GM to fix spacing when dcr -lg was issued */
/* Modified on 10/25/76 by ORN to eliminate cobol_iocb include file and comply with error message standards */
/* Modified on 07/17/76 by ORN to support display of external switchs */
/* Recompiled on 7/14/76 by George Mercuri to utilize the new include files. */
/* format: style3 */
display_cobol_run_unit:
dcr:
     proc;

dcl	(i, j, k, n, nargs, arglen, len, code)
			fixed bin;
dcl	(count, icount)	fixed bin;
dcl	(mode, org, acc)	fixed bin;

dcl	(asw, lsw, fsw)	bit (1);

dcl	mode_con		(0:3) char (6) static init ("extend", "input", "i-o", "output");
dcl	org_con		(0:3) char (10) static init ("stream", "sequential", "relative", "indexed");
dcl	acc_con		(3) char (10) static init ("sequential", "random", "dynamic");

dcl	(acon, dcon)	char (6);
dcl	eicon		char (8);
dcl	fname		char (32);
dcl	programs		char (8);
dcl	times		char (5);

dcl	argptr		ptr;
dcl	arg		char (16) based (argptr);

dcl	get_pdir_		entry returns (char (168) aligned);
dcl	cu_$arg_count	entry (fixed bin);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin);
dcl	com_err_		entry options (variable);
dcl	ioa_		entry options (variable);
dcl	ioa_$nnl		entry options (variable);
dcl	hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin);

dcl	error_table_$badopt fixed bin (35) ext static;
dcl	error_table_$bad_arg
			fixed bin (35) ext static;
dcl	cobol_control_$get_pointer
			entry returns (pointer);


/* *********************************** */
start:
	asw, lsw, fsw = "0"b;
	call cu_$arg_count (nargs);
	if nargs > 0
	then do i = 1 to nargs;
		call cu_$arg_ptr (i, argptr, arglen, code);
		if code ^= 0
		then go to multics_error;


/*[4.1-1]*/
		if substr (arg, 1, 1) ^= "-"
		then go to bad_arg_error;
		if (arglen = 3 & substr (arg, 1, 3) = "-lg") | (arglen = 5 & substr (arg, 1, 5) = "-long")
		then lsw = "1"b;
		else if (arglen = 2 & substr (arg, 1, 2) = "-a") | (arglen = 4 & substr (arg, 1, 4) = "-all")
		then asw = "1"b;
		else if arglen = 6 & substr (arg, 1, 6) = "-files"
		then fsw = "1"b;
		else go to invalid_arg_error;
	     end;


	controlp = cobol_control_$get_pointer ();
	if controlp = null ()
	then go to no_run_error;
	if control.no_of_segs < 1
	then if control.mpname = ""
	     then go to no_run_error;
	count, icount = 0;
	do i = 1 to control.no_of_segs;
	     stat_ptr = control.statptr (i);
	     if stat_ptr = null ()
	     then icount = icount + 1;
	     else if stat.call_cnt = -1
	     then icount = icount + 1;
	     else count = count + 1;
	end;
	if count = 1
	then programs = "program";
	else programs = "programs";
	call ioa_ ("^/Run-unit ^a contains ^d cobol ^a", control.name, count, programs);
	if control.mpname ^= ""
	then call ioa_ ("Main program: ^a", control.mpname);
	if asw
	then do;
		if icount = 1
		then programs = "program";
		else programs = "programs";
		call ioa_ ("Control segment at ^p^/^d inactive ^a^/", controlp, icount, programs);
	     end;
	else do;
		call ioa_ ("");
		if count = 0
		then return;
	     end;

	do i = 1 to control.no_of_segs;
	     stat_ptr = control.statptr (i);
	     if asw
	     then call ioa_$nnl ("^2d ", i);
	     if stat_ptr = null ()
	     then do;
		     if asw
		     then do;
			     call ioa_ ("***Permanently inactive");
			     if lsw
			     then call ioa_ ("");
			end;
		end;
	     else if stat.call_cnt = -1
	     then do;
		     if asw
		     then do;
			     if lsw
			     then call ioa_ ("Name: ^a  (inactive)^/  at ^p^/  data at ^p for ^d words",
				     substr (stat.prog_id, 1, stat.prog_id_len), stat.entry_pt_ptr, stat.data_ptr,
				     stat.data_len);
			     else call ioa_ ("^a   (inactive)", substr (stat.prog_id, 1, stat.prog_id_len));
			end;
		end;
	     else do;
		     if lsw
		     then do;
			     if stat.call_cnt = 1
			     then times = "time";
			     else times = "times";
			     call ioa_ (
				"Name: ^a^/  at ^p^/  invoked ^d ^a^/  data at ^p for ^d words^/  file_info at ^p",
				substr (stat.prog_id, 1, stat.prog_id_len), stat.entry_pt_ptr, stat.call_cnt,
				times, stat.data_ptr, stat.data_len, stat.file_info_ptr);
			end;
		     else call ioa_ ("^a	(^d)", substr (stat.prog_id, 1, stat.prog_id_len), stat.call_cnt);
		end;
	     if fsw
	     then do;
		     if stat_ptr = null ()
		     then if asw
			then call ioa_ ("  No active files");
			else ;
		     else if stat.call_cnt = -1
		     then if asw
			then call ioa_ ("  No active files");
			else ;
		     else if stat.file_info_ptr = null ()
		     then call ioa_ ("  No active files");
		     else do;
			     file_info_ptr = stat.file_info_ptr;
			     k = 0;
			     j = divide (file_info.n, 2, 17, 0);
			     do n = 1 to j;
				fsb_ptr = file_info.pt (n);
				if fsb_ptr ^= null ()
				then if fsb.iocb_ptr ^= null ()
				     then k = k + 1;
			     end;
			     if k = 1
			     then acon = "file";
			     else acon = "files";
			     if j = 1
			     then dcon = "file";
			     else dcon = "files";
			     call ioa_ ("  ^d ^a active, ^d ^a declared", k, acon, j, dcon);
			     do n = 1 to j;
				fsb_ptr = file_info.pt (n);
				if fsb_ptr ^= null ()
				then if fsb.iocb_ptr ^= null ()
				     then do;
					     if fsb.internal
					     then do;
						     eicon = "Internal";
						     len = index (fsb.iocb_ptr -> iocb.name, " ") - 17;
						     if len < 0
						     then len = 16;
						     fname = substr (fsb.iocb_ptr -> iocb.name, 1, len);
						end;
					     else do;
						     eicon = "External";
						     fname = fsb.iocb_ptr -> iocb.name;
						end;
					     if fsb.open_mode = 0
					     then call ioa_ ("     ^a file ^a at ^p^/      closed by ^a", eicon,
						     fname, fsb_ptr, fsb.open_close_name);
					     else do;
						     mode = fixed (substr (unspec (fsb.open_mode), 31, 2), 2);
						     org = fixed (substr (unspec (fsb.open_mode), 33, 2), 2);
						     acc = fixed (substr (unspec (fsb.open_mode), 35, 2), 2);
						     call ioa_ (
							"     ^a file ^a at ^p^/      opened by ^a for ^a with ^a organization and ^a access",
							eicon, fname, fsb_ptr, fsb.open_close_name,
							mode_con (mode), org_con (org), acc_con (acc));
						end;
					end;
			     end;
			end;
		end;
	     if lsw & stat_ptr ^= null ()
	     then call ioa_ ("");
	end;
	call ioa_ ("");
	k = 0;
	do i = 1 to 8;
	     if control.sense_sw (i) ^= 0
	     then do;
		     if k = 0
		     then do;
			     call ioa_$nnl (
				"External-switch status:   1   2   3   4   5   6   7   8^/                          "
				);
			     if i > 1
			     then do j = 1 to i - 1;
				     call ioa_$nnl ("OFF ");
				end;
			     k = 1;
			end;
		     call ioa_$nnl ("ON  ");
		end;
	     else if k ^= 0
	     then call ioa_$nnl ("OFF ");
	end;
	if k = 0
	then call ioa_ ("All external-switches off^/");
	else call ioa_ ("^/");
	return;


/* *********************************** */
multics_error:
	call com_err_ (code, "display_cobol_run_unit");
	return;

invalid_arg_error:
	call com_err_ (error_table_$badopt, "display_cobol_run_unit", substr (arg, 1, arglen));
	return;

no_run_error:
	call com_err_ (0, "display_cobol_run_unit", "There is no cobol run-unit currently active.");
	return;

/*[4.1-1]*/
bad_arg_error:
	call com_err_ (error_table_$bad_arg, "display_cobol_run_unit", substr (arg, 1, arglen));
	return;


/* *********************************** */
%include cobol_fixed_static;
%include cobol_control;
%include cobol_fsb;
%include iocb;
%include cobol_file_info;
     end display_cobol_run_unit;




		    expand_cobol_source.pl1         05/24/89  1048.6rew 05/24/89  0836.8      150984



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 expand_cobol_source.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 02/08/82 by FCH, [5.1-3], cobol$copy_file_size defined, phx11819(BUG517) */
/* Modified on 01/04/81 by FCH, [5.1-2], let cobol_expand_source know if called by command, phx11818(BUG519) */
/* Modified on 10/27/81 by FCH, [5.1-1], issue diag if long line found, phx11819(BUG517) */
/* Modified on 07/20/81 by FCH, [4.4-2], bit count not computed correctly, phx10605(BUG495) */
/* Modified on 03/06/81 by FCH, [4.4-1], test for zero length seg, release areas if error */
/* Modified on 10/09/79 by FCH, [4.0-4], new control arguments */
/* Modified on 10/03/79 by FCH, [4.0-3], new control arguments */
/* Modified on 03/08/79 by FCH, [4.0-2], -strip blanks option */
/* Modified on 02/23/79 by FCH, [4.0-1], copy library name qualification */
/* Created on 09/16/78 by FCH */








/*	expand_cobol_source  path1 {path2} {-control_args}

	where
		path1	name of input segment, ".cobol" suffix  implied

		control_args

			one of the following

		-lower_case, -lc	lower case conversion, implies formatting

		-upper_case, -uc	upper case conversion, implies formatting

		-card			card image format, strip trailing blanks

		-expand, -exp		expand source

		-no_expand, -no_exp		do not expand source

		-format,-fmt		format cobol source

*/





/* format: style3 */
expand_cobol_source:
ecs:
     proc;

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

	call cu_$arg_count (nargs);
	command = "1"b;
	etype = 1;				/*[4.4-1]*/
	tssi_ind = "0"b;
	ecs_info_ptr = addr (ecs_info_table);

	if nargs = 0
	then do;

		call ioa_ ("^a^/^a^/^a^/^a^/", "expand_cobol_source: Expected argument missing",
		     "Usage: expand_cobol_source path1 path2 {control_args}",
		     "Control Arguments: -format(-fmt) -lower_case(-lc) -upper_case(-uc)",
						/*[4.0-2]*/
		     "Control Arguments: -card -expand(-exp) -no_expand(-no_exp)" /*[4.0-3]*/);

		return;
	     end;

	on cleanup call cl;
	on command_abort_ call cl;
	call init;

	if code ^= 0
	then go to multics_error;

/* path1 */



	call cu_$arg_ptr (1, argptr, arglen, code);

	if code ^= 0
	then go to multics_error;

	call expand_pathname_$add_suffix (arg, "cobol", dn_1, en_1, code);

	if code ^= 0
	then go to multics_error;

	if nargs = 1
	then do;
		call gen_path2;
		if code ^= 0
		then go to multics_error;
	     end;

/*[4.0-3]*/
	else do;

		i = 2;

		do while (i <= nargs);

		     call cu_$arg_ptr (i, argptr, arglen, code);

		     if code ^= 0
		     then go to multics_error;

/*[4.0-3]*/
		     if i = 2			/*[4.0-3]*/
		     then do;
			     if substr (arg, 1, 1) = "-"
						/*[4.0-3]*/
			     then do;
				     call gen_path2;/*[4.0-3]*/
				     call process_control_arg;
						/*[4.0-3]*/
				end;		/*[4.0-3]*/
			     else call expand_pathname_$add_suffix (arg, "cobol", dn_2, en_2, code);
						/*[4.0-3]*/
			end;			/*[4.0-4]*/
		     else if substr (arg, 1, 1) = "-"	/*[4.0-4]*/
		     then call process_control_arg;	/*[4.0-4]*/
		     else go to too_many_args_error;

		     i = i + 1;

		end;

/*[4.0-3]*/
	     end;

	call hcs_$initiate_count (dn_1, en_1, "", bc, 1, s1_ptr, code);

	if s1_ptr = null ()
	then do;
		en = en_1;
		go to multics_arg_error;
	     end;					/*[4.4-1]*/
	if bc = 0					/*[4.4-1]*/
	then do;
		code = error_table_$zero_length_seg;	/*[4.4-1]*/
		en = en_1;

/*[4.4-1]*/
		go to multics_arg_error;		/*[4.4-1]*/
	     end;

	en = en_2;

/*[4.0-4]*/
	call hcs_$initiate_count (dn_2, en_2, "", bc_temp, 1, s2_ptr, code);

/*[4.0-4]*/
	if s1_ptr ^= s2_ptr				/*[4.0-4]*/
	then do;
		call tssi_$get_segment (dn_2, en_2, s2_ptr, aclinfo_ptr, code);

/*[4.4-1]*/
		tssi_ind = "1"b;

/*[4.0-4]*/
		if code ^= 0
		then go to multics_arg_error;		/*[4.0-4]*/
	     end;

	ecs_info_table_.format_indicator = "1"b;

	call finish;

	if code ^= 0
	then go to multics_error;

	goto exp_end_1;

expand:
     entry (ecs_ptr, e_code);

	on cleanup call cl;
	on command_abort_ call cl;

	ecs_info_ptr = ecs_ptr;
	command = "0"b;

	call init;

	if code ^= 0
	then go to exp_end;

	call hcs_$fs_get_path_name (ecs_info_table_.input_ptr, dn_1, ldn, en_1, code);

	if code ^= 0
	then go to exp_end;

	call hcs_$initiate_count (dn_1, en_1, "", bc, 1, s1_ptr, code);

	if s1_ptr = null ()
	then go to exp_end;

	call tssi_$get_segment (ecs_info_table_.dir, ecs_info_table_.ent, ecs_info_table_.output_ptr, aclinfo_ptr, code)
	     ;

	if code ^= 0
	then go to exp_end;

/*[4.4-1]*/
	tssi_ind = "1"b;

	s1_ptr = ecs_info_table_.input_ptr;
	s2_ptr = ecs_info_table_.output_ptr;

/*[4.0-4]*/
	if ecs_info_table_.exp_indicator
	then etype = 1;
	else etype = -1;

	if ecs_info_table_.format_indicator
	then ftype = 1;

/*[4.0-4]*/
	if ecs_info_table_.card_indicator
	then ftype = 2;

	ecs_info_table_.format_indicator = "0"b;	/*[4.0-4]*/
	ecs_info_table_.card_indicator = "0"b;

	call finish;

/* Used to reinitialize the new *.ex.cobol (expanded version) and return */
/* the pointer to COBOL */

	call hcs_$initiate_count (ecs_info_table_.dir, ecs_info_table_.ent, "", bc, 01b, ecs_info_table_.output_ptr,
	     code);

	if ^(code = 0 | code = error_table_$segknown)
	then go to exp_end;

	e_code = 0;				/*[5.1-1]*/
	ecs_info_table_.bc = bc;

	goto exp_end_1;

exp_end:
	e_code = code;

exp_end_1:
	if area_info_area.areap ^= null ()
	then call release_area_ (area_info_area.areap);
	call release_temp_segments_ ("expand_cobol_source", temp_ptr, code);

	return;

/*[4.0-1]*/

find_incl_file:
     entry (file_name, lib_name, source_ptr, file_ptr, e_code);

/*[4.0-1]*/
	if lib_name ^= ""				/*[4.0-1]*/
	then do;
		call expand_pathname_$add_suffix
		     /*[4.0-1]*/ (lib_name || ">" || file_name, "incl.cobol", dn_1, en_1, e_code);

/*[4.0-1]*/
		if e_code ^= 0
		then return;

/*[4.0-2]*/
		call hcs_$initiate_count (dn_1, en_1, "", bc, 1, file_ptr, e_code);

/*[4.0-1]*/
		if e_code = error_table_$segknown
		then e_code = 0;

/*[4.0-1]*/
	     end;					/*[4.0-1]*/
	else do;
		call find_include_file_$initiate_count
		     /*[4.0-1]*/ ("cobol", source_ptr, file_name || ".incl.cobol", bc, file_ptr, e_code);

/*[4.0-1]*/
	     end;

/*[5.1-3]*/
	call cobol$copy_file_size (bc);

/*[4.0-1]*/
	return;

/* Error Handling */

badopt_error:
	call com_err_ (error_table_$badopt, "expand_cobol_source", arg);
						/*[4.4-1]*/
	call cl;
	return;

too_many_args_error:
	code = error_table_$too_many_args;
	go to multics_error;

sameseg_error:
	code = error_table_$sameseg;
	go to multics_error;

multics_error:
	call com_err_ (code, "expand_cobol_source");	/*[4.4-1]*/
	call cl;
	return;

multics_arg_error:
	call com_err_ (code, "expand_cobol_source", "^a", en);
						/*[4.4-1]*/
	call cl;
	return;

cl:
     proc;


	if area_info_area.areap ^= null ()
	then call release_area_ (area_info_area.areap);

/*[4.4-1]*/
	if tssi_ind
	then call tssi_$clean_up_segment (aclinfo_ptr);

	call release_temp_segments_ ("expand_cobol_source", temp_ptr, code);

     end;

init:
     proc;

	call get_temp_segments_ ("expand_cobol_source", temp_ptr, code);

	if code ^= 0
	then return;

	area_infop = addr (area_info_area);

	area_info_area.version = area_info_version_1;
	area_info_area.owner = "expand_cobol_source";
	area_info_area.areap = temp_ptr (3);
	area_info_area.size = sys_info$max_seg_size;
	string (area_info_area.control) = "0"b;

/*[4.4-1]*/
	area_info_area.extend /* , area_info_area.zero_on_alloc*/ = "1"b;


	call define_area_ (area_infop, code);

	if code ^= 0
	then return;

	comp_lev = 5;				/*[4.0-2]*/
	ctype, ftype, etype = 0;

     end;

finish:
     proc;

/*	ctype	-1	lc
		 0	no change
		+1	uc

	ftype	0	expand
		1	fmt, lc, uc
		2	card

	etype	-1	no_exp
		 0	exp
		+1	exp


	(I)	fmt/card	(T1)	move	(I)
			(O)

	(I)	copy	(T2)	replace	(T1)	move	(I)
					(O)

	(I)	fmt/card	(T1)	copy	(T2)	replace	(T1)	move	(I)
							(O)

*/

/*[4.0-4]*/
declare	o_ptr		ptr;

/*[4.0-4]*/
	if s1_ptr = s2_ptr
	then o_ptr = temp_ptr (1);
	else o_ptr = s2_ptr;

/*[4.0-4]*/
	go to FT (ftype);

FT (0):						/* expand */
						/*[4.0-4]*/
	call CR (s1_ptr, temp_ptr (2), o_ptr);

	go to FT_END;

FT (1):						/* format */
FT (2):						/* card */
						/*[4.0-4]*/
	if etype < 0				/*[4.0-4]*/
	then call TRANS (s1_ptr, o_ptr);		/*[4.0-4]*/
	else do;
		call TRANS (s1_ptr, temp_ptr (1));	/*[4.0-4]*/
		call CR (temp_ptr (1), temp_ptr (2), o_ptr);
						/*[4.0-4]*/
	     end;

FT_END:						/*[4.0-4]*/
	call MOVE (o_ptr, s1_ptr);

/*[4.0-4]*/
	ecs_info_table_.output_ptr = o_ptr;

/*[4.0-4]*/
	return;

CR:
     proc (in_ptr, t_p, out_ptr);

/*[4.0-4]*/
declare	(in_ptr, t_p, out_ptr)
			ptr;

/*[4.0-4]*/
	ecs_info_table_.input_ptr = in_ptr;		/*[4.0-4]*/
	ecs_info_table_.output_ptr = t_p;

/*[4.0-4]*/
	call SET (t_p, null ());

/*[5.1-2]*/
	ecs_info_table_.command = command;

/*[4.0-4]*/
	call cobol_expand_source_$copy (ecs_info_ptr, bc, command, temp_ptr (3));

/*[4.0-4]*/
	call SET (out_ptr, t_p);

/*[4.0-4]*/
	ecs_info_table_.input_ptr = t_p;		/*[4.0-4]*/
	ecs_info_table_.output_ptr = out_ptr;

/*[4.0-4]*/
	call cobol_expand_source_$replace (ecs_info_ptr, bc, command, temp_ptr (3));

/*[4.0-4]*/
	call SET (t_p, out_ptr);

     end;

SET:
     proc (tr_ptr, set_ptr);

/*[4.0-4]*/
declare	(tr_ptr, set_ptr)	ptr;

/*[4.0-4]*/
	call hcs_$truncate_seg (tr_ptr, 0, code);

/*[4.0-4]*/
	if code ^= 0
	then go to multics_error;

/*[4.0-4]*/
	if set_ptr = null ()
	then return;

/*[4.0-4]*/
	call hcs_$set_bc_seg (set_ptr, bc, code);

/*[4.0-4]*/
	if code ^= 0
	then go to multics_error;

     end;

TRANS:
     proc (in_ptr, out_ptr);

/*[4.0-4]*/
declare	(in_ptr, IP, out_ptr, OP)
			ptr;

/*[4.0-4]*/
	IP = in_ptr;
	OP = out_ptr;

/*[4.0-4]*/
	call SET (OP, IP);

/*[4.0-4]*/
	go to TRAN (ftype);

TRAN (1):						/* format */
	call cobol_source_formatter_ (IP, OP, bc, ctype, 0);

	go to TRAN_END;

TRAN (2):						/* card */
						/*[4.0-4]*/
	call cobol_blank_stripper_ (IP, OP, bc);

TRAN_END:						/*[4.0-4]*/
	call hcs_$set_bc_seg (OP, bc, code);

/*[4.0-4]*/
	if code ^= 0
	then go to multics_error;

     end;

MOVE:
     proc (in_ptr, out_ptr);

/*[4.0-4]*/
declare	(in_ptr, out_ptr)	ptr;			/*[4.4-2]*/
declare	cc		fixed bin;		/*[4.0-4]*/
declare	seg		char (500000) based;

/*[4.0-4]*/
	if s1_ptr = s2_ptr				/*[4.0-4]*/
	then do;
		call hcs_$truncate_seg (out_ptr, 0, code);
						/*[4.0-4]*/
		if code ^= 0
		then go to multics_error;

/*[4.4-2]*/
		cc = divide (bc, 9, 31, 0);		/*[4.4-2]*/
		substr (out_ptr -> seg, 1, cc) = substr (in_ptr -> seg, 1, cc);

/*[4.4-2]*/
		call hcs_$set_bc_seg (out_ptr, bc, code);
						/*[4.4-2]*/
		if code ^= 0
		then go to multics_error;

/*[4.0-4]*/
	     end;					/*[4.0-4]*/
	else do;
		call tssi_$finish_segment (in_ptr, bc, "101"b, aclinfo_ptr, code);

/*[4.0-4]*/
		if code ^= 0
		then go to multics_error;

/*[4.0-4]*/
	     end;

     end;

     end;

cobol_strip:
     proc (p);

declare	p		ptr,
	sz		fixed bin;

declare	name		char (32) based (p);

	call get_length (p);

	if j > 9
	then do;
		if substr (name, j - 8, 9) = ".ex.cobol"
		then do;
			name = substr (name, 1, j - 9);
			return;
		     end;
	     end;

	if j > 6
	then if substr (name, j - 5, 6) = ".cobol"
	     then name = substr (name, 1, j - 6);

     end;

gen_path2:
     proc;

	dn_2 = get_wdir_ ();
	en_2 = en_1;
	code = 0;

	call cobol_strip (addr (en_2));

	call get_length (addr (en_2));

	if j <= 23
	then en_2 = substr (en_2, 1, j) || ".ex.cobol";
	else code = error_table_$entlong;
     end;

process_control_arg:
     proc;

	if arg = "-upper_case" | arg = "-uc"		/*[4.0-2]*/
	then do;
		call test_arg (ctype, 1);		/*[4.0-3]*/
		call test_arg (ftype, 1);		/*[4.0-3]*/
	     end;
	else if arg = "-lower_case" | arg = "-lc"	/*[4.0-2]*/
	then do;
		call test_arg (ctype, -1);		/*[4.0-4]*/
		call test_arg (ftype, 1);		/*[4.0-4]*/
	     end;

	else if arg = "-format" | arg = "-fmt"
	then call test_arg (ftype, 1);

	else /*[4.0-3]*/
	     if arg = "-card"			/*[4.0-3]*/
	then call test_arg (ftype, 2);		/*[4.0-3]*/
	else /*[4.0-3]*/
	     if arg = "-expand" | arg = "-exp"		/*[4.0-3]*/
	then call test_arg (etype, 1);		/*[4.0-3]*/
	else /*[4.0-3]*/
	     if arg = "-no_expand" | arg = "-no_exp"	/*[4.0-3]*/
	then call test_arg (etype, -1);
	else if arg = ""
	then return;
	else go to badopt_error;

     end;

test_arg:
     proc (type, val);				/*[4.0-2]*/

/*[4.0-2]*/
dcl	(type, val)	fixed bin;

/*[4.0-2]*/
	if type = 0				/*[4.0-2]*/
	then type = val;				/*[4.0-2]*/
	else /*[4.0-2]*/
	     call com_err_ (error_table_$arg_ignored, "expand_cobol_source", arg);

     end;						/*[4.0-2]*/

get_length:
     proc (p);

declare	p		ptr;
declare	name		char (32) based (p);

	j = index (name, " ");

	if j = 0
	then j = 32;
	else j = j - 1;

     end;

dcl	(file_name, lib_name)
			char (*),
	(source_ptr, file_ptr)
			ptr;			/*[4.0-1]*/

dcl	command		bit (1);
dcl	dir_ptr		ptr;
dcl	(aclinfo_ptr, ecs_ptr)
			ptr;
dcl	(e1_ptr, e2_ptr)	ptr;
dcl	final_ptr		ptr;
dcl	argptr		ptr;
dcl	(s1_ptr, s2_ptr, sf_ptr)
			ptr;
dcl	tssi_ind		bit (1);
dcl	(nargs, comp_lev)	fixed bin;
dcl	arglen		fixed bin;
dcl	arg		char (arglen) based (argptr);
dcl	1 area_info_area	aligned automatic structure like area_info;
dcl	1 ecs_info_table	automatic structure like ecs_info_table_;
dcl	(code, e_code, abc) fixed bin (35);
dcl	(bc, bc_temp)	fixed bin (24);
dcl	(i, j, ldn)	fixed bin;
dcl	(ctype, etype, ftype)
			fixed bin;		/*[4.0-2]*/
dcl	(dn_1, dn_2)	char (168);
dcl	(en, en_1, en_2)	char (32);
dcl	tn		char (32);

dcl	error_table_$segknown
			fixed bin (35) ext;
dcl	error_table_$sameseg
			fixed bin (35) ext;
dcl	error_table_$noarg	fixed bin (35) ext;
dcl	error_table_$badopt fixed bin (35) ext;
dcl	error_table_$arg_ignored
			fixed bin (35) ext;
dcl	error_table_$too_many_args
			fixed bin (35) ext;
dcl	error_table_$entlong
			fixed bin (35) ext;
dcl	error_table_$zero_length_seg
			fixed bin (35) ext;
dcl	sys_info$max_seg_size
			fixed bin (35) ext;

dcl	cobol_source_formatter_
			entry (ptr, ptr, fixed bin (24), fixed bin, fixed bin);
dcl	hcs_$truncate_seg	entry (ptr, fixed bin, fixed bin (35));
dcl	cobol_source_formatter_$no_shift
			entry (ptr, ptr, fixed bin (24), fixed bin);
dcl	com_err_		entry options (variable);
dcl	cobol_expand_source_$copy
			entry (ptr, fixed bin (24), bit (1), ptr);
dcl	cobol_expand_source_$replace
			entry (ptr, fixed bin (24), bit (1), ptr);
dcl	get_temp_segments_	entry (char (*), (*) ptr, fixed bin (35));
dcl	release_temp_segments_
			entry (char (*), (*) ptr, fixed bin (35));
dcl	hcs_$set_bc_seg	entry (ptr, fixed bin (24), fixed bin (35));
dcl	hcs_$fs_get_path_name
			entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl	get_system_free_area_
			entry returns (ptr);
dcl	get_wdir_		entry returns (char (168));
dcl	define_area_	entry (ptr, fixed bin (35));
dcl	release_area_	entry (ptr);
dcl	expand_pathname_$add_suffix
			entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl	cu_$arg_count	entry (fixed bin);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
						/*[4.0-2]*/
dcl	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl	ioa_		entry options (variable);

dcl	tssi_$get_segment	entry (char (*), char (*), ptr, ptr, fixed bin (35));

dcl	find_include_file_$initiate_count
			entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35));
						/*[4.0-1]*/
dcl	tssi_$finish_segment
			entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));
dcl	tssi_$clean_up_segment
			entry (ptr);
dcl	cobol_blank_stripper_
			entry (ptr, ptr, fixed bin (24));
						/*[4.0-2]*/

/*[5.1-3]*/
declare	cobol$copy_file_size
			entry (fixed bin (24));

dcl	(addr, index, null, substr, divide)
			builtin;

dcl	temp_ptr		(3) ptr;

dcl	(cleanup, command_abort_)
			condition;

%include area_info;
%include cobol_ecs_info;

     end expand_cobol_source;




		    format_cobol_source.pl1         05/24/89  1048.6rew 05/24/89  0836.8       53334



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 format_cobol_source.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Last modified on 02/01/77 by ORN to support the -lmargin control argument */
/* Last modified on 11/24/76 by ORN to fix bug in which input seg is truncated if same as output seg */
/* Last modified on 08/16/76 by ORN to support -uc and -lc control arguments */

/* format: style3 */
format_cobol_source:
fcs:
     proc;

dcl	dir_ptr		ptr;
dcl	ename_ptr		(2) ptr;
dcl	final_ptr		ptr;
dcl	argptr		ptr;
dcl	segptr		(2) ptr;
dcl	1 i_o		based (addr (segptr (1))),
	  2 inptr		ptr,
	  2 outptr	ptr;
dcl	nargs		fixed bin;
dcl	arglen		fixed bin;
dcl	arg		char (arglen) based (argptr);
dcl	code		fixed bin (35);
dcl	bc		fixed bin (24);
dcl	(i, j)		fixed bin;
dcl	(ctype, mtype)	fixed bin;
dcl	shift		bit (1);
dcl	dir		char (168);
dcl	ename		(2) char (32);
dcl	equalname		char (32);

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

dcl	cobol_source_formatter_
			entry (ptr, ptr, fixed bin (24), fixed bin, fixed bin);
dcl	hcs_$truncate_seg	entry (ptr, fixed bin, fixed bin (35));
dcl	cobol_source_formatter_$no_shift
			entry (ptr, ptr, fixed bin (24), fixed bin);
dcl	com_err_		entry options (variable);
dcl	equal_		entry (ptr, ptr, ptr, fixed bin (35));
dcl	expand_path_	entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
dcl	cu_$arg_count	entry (fixed bin);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	hcs_$initiate	entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl	hcs_$set_bc_seg	entry (ptr, fixed bin (24), fixed bin (35));

dcl	addr		builtin;
dcl	index		builtin;
dcl	null		builtin;
dcl	substr		builtin;


/*************************************/
start:
	shift = "1"b;
	go to join;

no_shift:
     entry;
	shift = "0"b;

join:
	dir_ptr = addr (dir);
	ename_ptr (1) = addr (ename (1));
	ename_ptr (2) = addr (equalname);
	call cu_$arg_count (nargs);
	if nargs > 4
	then go to too_many_args_error;
	if nargs < 2
	then go to noarg_error;

/* Process arguments */
	do i = 1 to 2;
	     call cu_$arg_ptr (i, argptr, arglen, code);
	     if code ^= 0
	     then go to multics_error;
	     call expand_path_ (argptr, arglen, dir_ptr, ename_ptr (i), code);
	     if code ^= 0
	     then go to multics_error;
	     if i = 2
	     then do;
		     final_ptr = addr (ename (2));
		     call equal_ (ename_ptr (1), ename_ptr (2), final_ptr, code);
		     if code ^= 0
		     then go to multics_error;
		     ename_ptr (2) = final_ptr;
		end;
	     j = index (ename (i), " ");
	     if j = 0
	     then j = 33;
	     if substr (ename (i), j - 6, 6) ^= ".cobol"
	     then substr (ename (i), j, 6) = ".cobol";
	     call hcs_$initiate (dir, ename (i), "", 0, 1, segptr (i), code);
	     if i = 2
	     then do;
		     if inptr = outptr
		     then go to sameseg_error;
		     if segptr (2) = null ()
		     then do;			/* output segment doesn't exist; create it */
			     call hcs_$make_seg (dir, ename (2), "", 10, segptr (2), code);
			     if code ^= 0
			     then go to multics_arg_error;
			end;
		     else do;
			     call hcs_$truncate_seg (segptr (2), 0, code);
			     if code ^= 0
			     then go to multics_arg_error;
			end;
		end;
	     else if segptr (1) = null ()
	     then go to multics_arg_error;
	end;

	ctype, mtype = 0;
	if nargs > 2
	then do i = 3 to nargs;
		call cu_$arg_ptr (i, argptr, arglen, code);
		if code ^= 0
		then go to multics_error;
		if arg = "-upper_case" | arg = "-uc"
		then do;
			if ctype = 0
			then ctype = 1;
			else call com_err_ (error_table_$arg_ignored, "format_cobol_source", arg);
		     end;
		else if arg = "-lower_case" | arg = "-lc"
		then do;
			if ctype = 0
			then ctype = -1;
			else call com_err_ (error_table_$arg_ignored, "format_cobol_source", arg);
		     end;
		else if arg = "-lmargin" | arg = "-lm"
		then mtype = 1;
		else go to badopt_error;
	     end;


/* Call routine which actually does reformatting. */

	if ^shift
	then call cobol_source_formatter_$no_shift ((inptr), (outptr), bc, ctype);
	else call cobol_source_formatter_ ((inptr), (outptr), bc, ctype, mtype);
						/* pass by value so offsets remain 0 */

	call hcs_$set_bc_seg (outptr, bc, code);
	if code ^= 0
	then go to multics_error;

	return;

/* Error Handling */

noarg_error:
	code = error_table_$noarg;
	go to multics_error;

badopt_error:
	call com_err_ (error_table_$badopt, "format_cobol_source", arg);
	return;

too_many_args_error:
	code = error_table_$too_many_args;
	go to multics_error;

sameseg_error:
	code = error_table_$sameseg;
	go to multics_error;

multics_error:
	call com_err_ (code, "format_cobol_source");
	return;

multics_arg_error:
	call com_err_ (code, "format_cobol_source", "^a", ename (i));
	return;

     end format_cobol_source;




		    stop_cobol_run.pl1              05/24/89  1048.6rew 05/24/89  0836.8       23382



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 stop_cobol_run.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified on 10/25/76 by ORN to comply with error message standards */
/* Modified on 03/26/76 by ORN to call cobol_cancel_ instead of cancel_.
	Change made in conjunction with cobol_control_ modification. */

/* format: style3 */
stop_cobol_run:
scr:
     proc;

dcl	nargs		fixed bin;
dcl	code		fixed bin;
dcl	arglen		fixed bin;
dcl	rdsw		fixed bin;
dcl	rfsw		fixed bin;
dcl	mcode		fixed bin (35);
dcl	i		fixed bin;

dcl	arg		char (arglen) based (argptr);

dcl	argptr		ptr;

dcl	cobol_control_$cobol_stop_run_command_
			entry (ptr, fixed bin, fixed bin, fixed bin);
dcl	com_err_		entry options (variable);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	cu_$arg_count	entry (fixed bin);

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


/*************************************/
start:
	rfsw = 0;
	rdsw = 0;
	call cu_$arg_count (nargs);
	do i = 1 to nargs;
	     call cu_$arg_ptr (i, argptr, arglen, mcode);
	     if mcode ^= 0
	     then go to merror;
	     if arg = "-retd" | arg = "-retain_data"
	     then rdsw = 1;
	     else if arg = "-rf" | arg = "-retain_files"
	     then rfsw = 1;
	     else go to bad_arg_error;
	end;
	code = 0;
	call cobol_control_$cobol_stop_run_command_ (null (), rdsw, rfsw, code);
	if code ^= 0
	then go to no_run_error;
	return;


/*************************************/
bad_arg_error:
	call com_err_ (error_table_$badopt, "stop_cobol_run", arg);
	return;

merror:
	call com_err_ (mcode, "stop_cobol_run");
	return;

no_run_error:
	call com_err_ (0, "stop_cobol_run", "There is no cobol run-unit currently active.");
	return;

     end stop_cobol_run;




		    cobol_rwcs_.pl1                 05/24/89  1048.6rew 05/24/89  0836.8       10269



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




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8060 cobol_rwcs_.pl1 Reformatted code to new Cobol standard.
                                                   END HISTORY COMMENTS */


/* Modified since Version 4.2 */

/* format: style3 */
cobol_rwcs_:
     proc;


/* Initial Version of the module for binding purposes */

     end cobol_rwcs_;




		    process_cobol_report.pl1        05/24/89  1048.6rew 05/24/89  0828.1      160992



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright,(C) Honeywell Information Systems Inc.,1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8081),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8081 process_cobol_report.pl1 Change behavior to prevent creation of
     zero or incorrect length output files.
  2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8084),
     audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048):
     MCR8084 process_cobol_report.pl1 Correct problem with adding to MSF
     components.
                                                   END HISTORY COMMENTS */


/* Modified on 11/28/84 by FCH, [5.3-2], BUG570(phx16601), MSFs give out of bounds */
/* Modified on 89/03/10 by LVZ, bug572(phx16632) delete null output file. */
/* Modified on 11/17/84 by FCH, {5.3-1], BUG572(phx16632),initialize bit count */
/* Modified since Version 5.0 */

/* format: style3 */
process_cobol_report:
pcr:
     proc;

dcl	SZ_OF_INPUT_STRING	fixed bin (35) static internal options (constant) init (1048576);
dcl	SZ_OF_INPUT_ARRAY	fixed bin (35) static internal options (constant) init (1048576);
dcl	SZ_OF_OUT_STRING	fixed bin (35) static internal options (constant) init (1048576);
dcl	SZ_OF_OUT_ARRAY	fixed bin (35) static internal options (constant) init (1048576);
dcl	SZ_OF_DATA	fixed bin (35) static internal options (constant) init (32768);


dcl	input_string	char (SZ_OF_INPUT_STRING) based (in_ptr);
dcl	input_array	(SZ_OF_INPUT_ARRAY) char (1) based (in_base_ptr);
dcl	sys_info$max_seg_size
			fixed bin (35) ext static;	/*[5.3-2]*/
dcl	(max_size, maxer_size)
			fixed bin (35);		/*[5.3-2]*/
dcl	(old_size, new_size)
			fixed bin;
dcl	character_offset	fixed bin (35);
dcl	next_offset	fixed bin (35);

dcl	01 text_line_in	based (in_ptr) unal,
	  02 size		fixed bin (35) unal,
	  02 report_code	char (2),
	  02 control	char (1),
	  02 filler	char (1),
	  02 data		char (SZ_OF_DATA);

dcl	01 skip_line_in	based (in_ptr) unal,
	  02 size		fixed bin (35) unal,
	  02 report_code	char (2),
	  02 control	char (1),
	  02 filler	char (1),
	  02 number_of_skips
			fixed bin (35) unal;

dcl	skip_length	fixed bin (21);
dcl	report_codes_in	char (255) varying;
dcl	requested_code	char (2);
dcl	cch		char (1);

dcl	in_ptr		pointer;
dcl	in_base_ptr	pointer;

dcl	cu_$arg_count	entry (fixed bin);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	num_of_args	fixed bin;
dcl	arg_no		fixed bin;
dcl	arg_ptr		pointer;
dcl	arg_len		fixed bin;
dcl	code		fixed bin (35);
dcl	arg		char (arg_len) based (arg_ptr);

dcl	reply		char (40);
dcl	iox_$get_line	entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl	iox_$put_chars	entry (ptr, ptr, fixed bin (21), fixed bin (35));
dcl	iox_$user_output	pointer external;
dcl	user_out		ptr init (null ());

dcl	msf_manager_$open	entry (char (*), char (*), pointer, fixed bin (35));
dcl	msf_manager_$get_ptr
			entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24), fixed bin (35));
dcl	msf_manager_$close	entry (pointer);

dcl	delete_$path	entry (char (*), char (*), bit (6), char (*), fixed bin (35));
dcl	expand_pathname_	entry (char (*), char (*), char (*), fixed bin (35));
dcl	in_dirname	char (168);
dcl	in_entryname	char (32);

dcl	who_am_i		char (20) init ("process_cobol_report");
dcl	com_err_		entry options (variable);

dcl	i		fixed bin;

dcl	error_table_$badopt fixed bin (35) ext static;
dcl	error_table_$noentry
			fixed bin (35) ext static;
dcl	error_table_$badpath
			fixed bin (35) ext static;

dcl	file_output	bit (1);
dcl	fcb_ptr		pointer;
dcl	component_of_msf	fixed bin;
dcl	in_bit_count	fixed bin (24);
dcl	previous_in_ptr	pointer;
dcl	data_ptr		pointer;

dcl	all_codes		bit (1);
dcl	true		bit (1) static internal options (constant) init ("1"b);
dcl	false		bit (1) static internal options (constant) init ("0"b);

dcl	length_of_data	fixed bin (35);
dcl	newline_buffer	char (254) init ((254)"
");
dcl	eof		bit (1);
dcl	in_seg_size	fixed bin (35);

dcl	out_dirname	char (168);
dcl	out_entryname	char (32);

dcl	out_fcb_ptr	pointer;
dcl	aclinfo_ptr	pointer;
dcl	out_base_ptr	pointer;
dcl	out_ptr		pointer;

dcl	out_string	char (SZ_OF_OUT_STRING) based (out_ptr);
dcl	out_array		(SZ_OF_OUT_ARRAY) char (1) based (out_base_ptr);
dcl	out_bit_count	fixed bin (24);
dcl	out_char_offset	fixed bin (35);
dcl	new_line		char (1) init ("
");

dcl	tssi_$get_file	entry (char (*), char (*), ptr, ptr, ptr, fixed bin (35));
dcl	tssi_$finish_file	entry (ptr, fixed bin, fixed bin (24), bit (36) aligned, ptr, fixed bin (35));

dcl	data_length	fixed bin (21);
dcl	rcd_arg		bit (1);

dcl	1 component_list	(0:15),
	  02 base_seg_ptr	pointer,
	  02 character_count
			fixed bin (35);

dcl	report_code_list	(64) char (2);
dcl	num_of_reports	fixed bin;
dcl	position		fixed bin (35);
dcl	last_component	bit (1);
dcl	report_index	fixed bin;
dcl	list_index	fixed bin;
dcl	found		bit;
dcl	num_of_components	fixed bin;
dcl	rest_of_segment	fixed bin;
dcl	buffer		char (266);
dcl	next_out_char_off	fixed bin;
dcl	out_component	fixed bin;
dcl	out_bc		fixed bin (24);		/*[5.3-2]*/
dcl	max_line_size	fixed bin init (256);	/*[5.3-2]*/
dcl	max_rec_size	fixed bin init (266);	/*[5.3-2]*/
dcl	cd_size		fixed bin init (10);	/*[5.3-2]*/
dcl	(segres, recsize)	fixed bin;
dcl	newpage_flag	bit (1);
dcl	stop_flag		bit (1);
dcl	newpage		char (1) init ("");

/*[5.3-1]*/
	out_bit_count = 0;

	newpage_flag = true;
	stop_flag = false;
	user_out = iox_$user_output;
	max_size = sys_info$max_seg_size * 4;		/*[5.3-2]*/
	maxer_size = max_size + 1;
	all_codes = false;
	rcd_arg = false;
	num_of_reports = 1;
	report_code_list (1) = "  ";
	out_component = 0;
	file_output = false;

	call cu_$arg_ptr (1, arg_ptr, arg_len, code);

	if code ^= 0
	then go to error_and_out;

	if arg_len = 0
	then call comerr (0, 1, "^R""""^B");		/* null pathname */

	call expand_pathname_ (arg, in_dirname, in_entryname, code);

	if code ^= 0
	then call comerr (code, 1, arg);

	call cu_$arg_count (num_of_args);

	do i = 2 to num_of_args;

	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if code ^= 0
	     then go to error_and_out;

	     if arg = "-of" | arg = "-output_file"
	     then do;

		     file_output = "1"b;
		     i = i + 1;

		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

		     if code ^= 0
		     then go to error_and_out;
		     else do;

			     call expand_pathname_ (arg, out_dirname, out_entryname, code);
			     if code ^= 0
			     then go to error_and_out;

			end;
		end;
	     else if arg = "-rcd" | arg = "-report_code"
	     then do;

		     if all_codes
		     then call comerr (0, 1, "The arguments -a and -rcd are incompatible");
		     else rcd_arg = true;

		     i = i + 1;

		     call cu_$arg_ptr (i, arg_ptr, arg_len, code);

		     if code ^= 0
		     then go to error_and_out;
		     else do;

			     num_of_reports = 0;

			     do position = 3 to arg_len by 3;

				if substr (arg, position, 1) = ","
				then do;

					num_of_reports = num_of_reports + 1;
					report_code_list (num_of_reports) = substr (arg, position - 2, 2);

				     end;
				else call comerr (0, 1, "Illegal report code list");

			     end;

			     if position - 1 = arg_len
			     then do;

				     num_of_reports = num_of_reports + 1;
				     report_code_list (num_of_reports) = substr (arg, position - 2, 2);

				end;
			     else call comerr (0, 1, "Illegal report code list.");

			end;
		end;
	     else if arg = "-a" | arg = "-all"
	     then if rcd_arg
		then call comerr (0, 1, "The options -rcd and -a are incompatible");
		else all_codes = true;
	     else if arg = "-nnp" | arg = "-no_newpage"
	     then newpage_flag = false;
	     else if arg = "-sp" | arg = "-stop"
	     then stop_flag = true;
	     else call comerr (error_table_$badopt, 1, arg);
	end;

	call msf_manager_$open (in_dirname, in_entryname, fcb_ptr, code);

	if code ^= 0
	then call comerr2 (code, 1, "^a>^a", in_dirname, in_entryname);

	do component_of_msf = 0 to 15;
	     component_list.base_seg_ptr (component_of_msf) = null ();
	end;

	last_component = false;
	component_of_msf = -1;

	do while (^last_component);			/* component table for report file */

	     component_of_msf = component_of_msf + 1;

	     call msf_manager_$get_ptr (fcb_ptr, component_of_msf, "0"b, in_base_ptr, in_bit_count, code);

	     if code = error_table_$noentry
	     then last_component = true;
	     else if code ^= 0
	     then call comerr2 (code, 2, "^a>^a", in_dirname, out_dirname);
	     else do;

		     component_list.base_seg_ptr (component_of_msf) = in_base_ptr;
		     component_list.character_count (component_of_msf) = divide (in_bit_count, 9, 35, 0);

		end;

	end;

	num_of_components = component_of_msf - 1;

	if all_codes
	then call fill_code_list;

	if file_output
	then do;					/*output file specified */

		call tssi_$get_file (out_dirname, out_entryname, out_base_ptr, aclinfo_ptr, out_fcb_ptr, code);

		if code ^= 0
		then call comerr2 (code, 2, "^a>^a", out_dirname, out_entryname);

		out_ptr = out_base_ptr;
		out_char_offset = 1;

	     end;

	do report_index = 1 to num_of_reports;		/* for each report */

	     requested_code = report_code_list (report_index);

	     call set_comp0;

	     eof = false;

	     call get_line;

	     if eof
	     then call comerr2 (0, 3, "Requested report code,^a,not found or format error in ^a", requested_code,
		     in_dirname || ">" || in_entryname);

	     if file_output
	     then do;				/* output file specified */

		     do while (^eof);		/* for each report record */

			data_length = text_line_in.size;

			if cch = ":"
			then do;

				next_out_char_off = out_char_offset + 1 + data_length;

/*[5.3-2]*/
				if next_out_char_off > maxer_size
				then do;		/* record does not fit */

/*[5.3-2]*/
					call set_sizes;

/*[5.3-2]*/
					substr (out_string, 1, old_size) =
					     substr (text_line_in.data, 1, old_size);

					call msf;

/*[5.3-2]*/
					if new_size > 1
						/*[5.3-2]*/
					then substr (out_string, 1, new_size - 1) =
						substr (text_line_in.data, old_size + 1);

/*[5.3-2]*/
					substr (out_string, new_size, 1) = new_line;

				     end;
				else do;		/* record fits */

					substr (out_string, 1, data_length) =
					     substr (text_line_in.data, 1, data_length);
					substr (out_string, data_length + 1, 1) = new_line;

				     end;

				out_char_offset = next_out_char_off;

			     end;
			else if cch = "r"
			then do;

				skip_length = skip_line_in.number_of_skips;

				if skip_length <= 254
				then do;

					next_out_char_off = out_char_offset + skip_length;

/*[5.3-2]*/
					if next_out_char_off > maxer_size
					then do;	/* record does not fit */

/*[5.3-2]*/
						call set_sizes;

/*[5.3-2]*/
						substr (out_string, 1, old_size) =
						     substr (newline_buffer, 1, old_size);

						call msf;

/*[5.3-2]*/
						substr (out_string, 1, new_size) =
						     substr (newline_buffer, 1, new_size);

					     end;
					else substr (out_string, 1, skip_length) =
						substr (newline_buffer, 1, skip_length);

					out_char_offset = next_out_char_off;

				     end;
				else call comerr (0, 3, "Too many successive new lines for output. Limit is 254.")
					;

			     end;
			else if cch = "n"
			then if newpage_flag
			     then do;		/* emit newpage */

				     substr (out_string, 1, 1) = newpage;
				     out_char_offset = out_char_offset + 1;

				end;
			     else ;
			else call comerr2 (0, 3, "Format error in input file. ^a>^a", in_dirname, in_entryname);

			out_ptr = addr (out_array (out_char_offset));

			call get_line;

		     end;

		     out_bit_count = (out_char_offset - 1) * 9;

		end;
	     else do;				/* terminal output specified */

		     if stop_flag
		     then call iox_$get_line (user_out, addr (reply), length (reply), 0, 0);

		     do while (^eof);

			if text_line_in.control = ":"
			then do;

				data_length = text_line_in.size;
				call iox_$put_chars (user_out, addr (text_line_in.data), data_length, code);
				call iox_$put_chars (user_out, addr (newline_buffer), 1, code);

			     end;
			else if cch = "r"
			then do;

				skip_length = skip_line_in.number_of_skips;

				if skip_length <= 254
				then call iox_$put_chars (user_out, addr (newline_buffer), skip_length, code);
				else call comerr (0, 2, "Too many successive new lines for output. Limit is 254.")
					;

			     end;
			else if cch = "n"
			then if stop_flag
			     then call iox_$get_line (user_out, addr (reply), length (reply), 0, 0);
			     else ;
			else call comerr2 (0, 2, "Format error in input file. ^a>^a", in_dirname, in_entryname);

			call get_line;
		     end;
		end;
	end;

fill_code_list:
     proc;

	call set_comp0;

	num_of_reports = 0;
	eof = false;

	do while (^eof);

	     call getl;

	     found = false;

	     do list_index = 1 to num_of_reports while (^found);
		if text_line_in.report_code = report_code_list (list_index)
		then found = true;
	     end;

	     if ^found
	     then do;
		     num_of_reports = num_of_reports + 1;
		     report_code_list (num_of_reports) = text_line_in.report_code;
		end;

	end;

     end fill_code_list;

get_line:
     proc;

	do while (^eof);

	     call getl;

	     if text_line_in.report_code = requested_code
	     then return;

	end;
     end get_line;

getl:
     proc;					/* get the nest record */



/*[5.3-2]*/
	segres = in_seg_size - next_offset + 1;		/* size of remaining data */
						/*[5.3-2]*/
	in_ptr = addr (input_array (next_offset + 2));

/*[5.3-2]*/
	if segres >= max_rec_size			/*[5.3-2]*/
	then do;					/* next record in component */
						/*[5.3-2]*/
		next_offset = next_offset + cd_size + text_line_in.size;
						/*[5.3-2]*/
		go to srx;			/*[5.3-2]*/
	     end;

/*[5.3-2]*/
	if segres > 6				/*[5.3-2]*/
	then do;					/* size control word in component */
						/*[5.3-2]*/
		recsize = cd_size + text_line_in.size;

/*[5.3-2]*/
		if segres >= recsize		/*[5.3-2]*/
		then do;
			next_offset = next_offset + recsize;
						/* next rec in comp */
						/*[5.3-2]*/
			go to srx;		/*[5.3-2]*/
		     end;

/*[5.3-2]*/
		segres = segres - 2;
		recsize = recsize - 2;		/*[5.3-2]*/
		call set_buff (segres, recsize - segres);
						/* split record */
						/*[5.3-2]*/
		next_offset = recsize - segres + 1;	/*[5.3-2]*/
		go to srx;			/*[5.3-2]*/
	     end;

/*[5.3-2]*/
	go to sr (segres);				/* size control word not completely in record */

sr (0):
sr (1):
sr (2):						/*[5.3-2]*/
	if segres = 1				/*[5.3-2]*/
	then if component_of_msf = num_of_components	/*[5.3-2]*/
	     then do;
		     eof = true;			/*[5.3-2]*/
		     return;			/*[5.3-2]*/
		end;

/*[5.3-2]*/
	call set_comp;				/* get next component */
						/*[5.3-2]*/
	next_offset = 3 - segres;			/*[5.3-2]*/
	in_ptr = addr (input_array (next_offset));	/*[5.3-2]*/
	next_offset = next_offset + 8 + text_line_in.size;/*[5.3-2]*/
	go to srx;

sr (3):
sr (4):
sr (5):
sr (6):						/* split size control word */
						/*[5.3-2]*/
	segres = 6 - segres;			/*[5.3-2]*/
	call set_buff (segres, 256 + 8 - segres);	/* split record */
						/*[5.3-2]*/
	next_offset = 4 + text_line_in.size - segres;	/*[5.3-2]*/
	go to srx;

srx:						/*[5.3-2]*/
	if text_line_in.size > max_line_size
	then go to format_error;

/*[5.3-2]*/
	cch = text_line_in.control;

     end;

set_buff:
     proc (lsz, rsz);				/* assemble split record */

/*[5.3-2]*/
dcl	(lsz, rsz, sz)	fixed bin;

/*[5.3-2]*/
	if lsz > 0
	then substr (buffer, 1, lsz) = substr (input_string, 1, lsz);

/*[5.3-2]*/
	call set_comp;				/*[5.3-2]*/
	in_ptr = in_base_ptr;			/*[5.3-2]*/
	sz = min (rsz, 256 - lsz);

/*[5.3-2]*/
	if rsz > 0
	then substr (buffer, lsz + 1, sz) = substr (input_string, 1, sz);

/*[5.3-2]*/
	in_ptr = addr (buffer);

     end;

msf:
     proc;

	out_component = out_component + 1;
	call msf_manager_$get_ptr (out_fcb_ptr, out_component, "1"b, out_base_ptr, out_bc, code);
	out_ptr = out_base_ptr;

     end;

set_sizes:
     proc;

	old_size = maxer_size - out_char_offset;
	new_size = next_out_char_off - max_size;
	next_out_char_off = new_size + 1;

     end;

set_comp0:
     proc;

	component_of_msf = 0;
	in_base_ptr = component_list.base_seg_ptr (0);
	in_seg_size = component_list.character_count (0);
	next_offset = 0;

     end;

set_comp:
     proc;

	if component_of_msf = num_of_components
	then go to format_error;

	component_of_msf = component_of_msf + 1;
	in_base_ptr = component_list.base_seg_ptr (component_of_msf);
	in_seg_size = component_list.character_count (component_of_msf);

     end;

comerr:
     proc (code, labnum, message);

dcl	code		fixed bin (35),
	labnum		fixed bin,
	message		char (*);

	call com_err_ (code, who_am_i, message);

	go to lab (labnum);

lab (1):
	go to the_end;
lab (2):
	go to close_and_end;
lab (3):
	go to close_both_and_end;

     end;

comerr2:
     proc (code, labnum, message, arg1, arg2);

dcl	code		fixed bin (35),
	labnum		fixed bin,
	message		char (*);
dcl	(arg1, arg2)	char (*);

	call com_err_ (code, who_am_i, message, arg1, arg2);

	go to lab (labnum);

lab (1):
	go to the_end;
lab (2):
	go to close_and_end;
lab (3):
	go to close_both_and_end;

     end;

close_both_and_end:
	if file_output
	then call tssi_$finish_file (out_fcb_ptr, out_component, out_bit_count, "110"b, aclinfo_ptr, code);

close_and_end:
	call msf_manager_$close (fcb_ptr);
	if out_bit_count = 0
	then call delete_$path (out_dirname, out_entryname, "011110"b, who_am_i, code);

	go to the_end;

format_error:
	call comerr (0, 3, "format error");

error_and_out:
	call com_err_ (code, who_am_i);

the_end:
     end;



		    bull_copyright_notice.txt       08/30/05  1008.4r   08/30/05  1007.3    00020025

                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved
