bound_.alm                      10/24/83  1358.6r w 10/24/83  1336.5       10980



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1983 *
" *                                                         *
" ***********************************************************
" procedure to return array bounds|dimension to pl/1 program
"
" Barry Wolman, 20 January 1970
"
" Usage:
"	n = bound_(array,dim,n_dims,code);
"
" where:
"	array is the array about which info is desired
"	dim is the dimension in question
"	n_dims is the total number of dimensions
"	code is 	1 for lbound
"		2 for hbound
"		3 for dim
"
	entry	bound_
"
	equ	array,2
	equ	dim,4
	equ	number,6
	equ	code,8
	equ	bound,10
	equ	array_desc,12
"
bound_:	lxl0	ap|code,*		get what to do
	ldq	ap|number,*	get number of dimensions
	sbq	ap|dim,*		get dimension desired
	mpy	3,dl		multiply by info size
	eppbp	ap|array_desc,*	get ptr to array descriptor
	xec	table-1,0		execute instruction to fetch info
done:	sta	ap|bound,*	store answer
	short_return
"
table:	lda	bp|1,ql		1, get lower bound
	lda	bp|2,ql		2, get upper bound
	tra	*+1		3, get dimension
	lda	bp|2,ql		which is
	sba	bp|1,ql
	ada	1,dl		hb-lb+1
	tra	done
"
	end




		    complex_binary_op_.pl1          10/24/83  1358.6r w 10/24/83  1331.9      100692



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


complex_binary_op_:	proc(poperation,pop3,pdesc3,pop1,pdesc1,pop2,pdesc2);

/* Program to implement PL/I Version II runtime complex binary operators.

	Modified:	June 9, 1978 by RAB for better complex floating abs
	Modified:	March 2, 1978 by RAB for better complex floating divide
   Written by Richard A. Barnes October 16, 1972.  */


dcl	poperation fixed bin(17),
	pop3 bit(144) unaligned,
	pdesc3 bit(36) aligned,
	pop1 bit(144) unaligned,
	pdesc1 bit(36) aligned,
	pop2 bit(144) unaligned,
	pdesc2 bit(36) aligned;

dcl	operation fixed bin(17);

dcl	1 desc1 aligned,
		2 flag bit(1) unal,
		2 type bit(6) unal,
		2 packed bit(1) unal,
		2 number_dims bit(4) unal,
		2 scale bit(12) unal,
		2 precision bit(12) unal;

dcl	1 desc2 like desc1 aligned;
dcl	1 desc3 like desc1 aligned;

dcl  (	sa based(addr(a)),
	sb based(addr(b)),
	sc based(addr(c)),
	sd based(addr(d)),
	se based(addr(e)),
	sf based(addr(f))) bit(72) aligned;

dcl	(a,b,c,d,e,f) float bin(63);

dcl	length fixed bin(17);

dcl  (	ia based(addr(a)),
	ib based(addr(b)),
	ic based(addr(c)),
	id based(addr(d)),
	ie based(addr(e)),
	if based(addr(f))) fixed bin(71);

dcl  (	comparison	init(0),
	addition		init(1),
	subtraction	init(2),
	multiplication	init(3),
	division		init(4),
	negate		init(5),
	real_fun		init(6),
	imag_fun		init(7),
	round_fun		init(8),
	complex_fun	init(9),
	abs_fun		init(10),
	conjg_fun		init(11)) fixed bin(17) internal static;

dcl	based_fb based fixed bin(17);
dcl	comp fixed bin(17);

dcl	(ac,bd,ad,bc,cd,denom) float bin(63);

dcl	1 dop1,
		2 scale1 fixed bin(17),
		2 prec1 fixed bin(17),
		2 p ptr,
		2 q ptr;
dcl	1 dop2,
		2 scale2 fixed bin(17),
		2 prec2 fixed bin(17),
		2 r ptr,
		2 s ptr;
dcl	1 dop3,
		2 scale3 fixed bin(17),
		2 prec3 fixed bin(17),
		2 t ptr,
		2 u ptr;

dcl	(d1_scale,d2_scale) fixed bin(17);

dcl	rtype fixed bin(17);
dcl	(t1,t2,t3,t4,t5,t6) fixed bin(71);
dcl	dscale fixed bin(17);
dcl	rscale fixed bin(17);	/* scale of result of our operations */
dcl	ifloat bit(1) aligned;
dcl	code fixed bin(17);

/* Function Definitions */

dcl	fixed_divide_ entry(fixed bin(71),fixed bin(71),fixed bin,fixed bin,fixed bin,fixed bin) returns (fixed bin(71));
dcl	fixed_round_ entry(fixed bin(71),fixed bin,fixed bin) returns(fixed bin(71));
dcl	float_round_ entry(float bin(63),fixed bin) returns(float bin(63));
dcl	scaler_ entry(fixed bin(71),fixed bin,fixed bin);
dcl	size_check_ entry(fixed bin(71),fixed bin) returns(fixed bin);
dcl	pl1_signal_$help_plio2_signal_ entry (char(*),ptr,fixed bin(15),
		char(256) varying,fixed bin(15));

dcl	(addr,fixed,float,index,max,mod,null,round,sqrt,substr,string) builtin;
/*  */


/*
	(e + fi) = pop3
	(a + bi) = pop1
	(c + di) = pop2

	(a + bi) + (c + di) = ((a+c) + (b+d)i)
	(a + bi) - (c + di) = ((a-c) + (b-d)i)
	(a + bi) * (c + di) = ((a*c - b*d) + (a*d + b*c)i)

	(a + bi) / (c + di) = ((__a*__c_+___b*__d)_ + (__b*__c_-___a*__d)_i)
			   (c*c + d*d)   (c*c + d*d)

	abs((a+bi)) = sqrt(a*a + b*b)

	round((a+bi),pdesc2) = (round(a,pdesc2) + round(b,pdesc2)i)

	- (a + bi) = (-a - bi)
							*/

/*  */
/*  Internal procedure to get an operand into our work area */

getrand:	proc(rand,pdesc,struct);

dcl	rand bit(144) unal,
	1 desc like desc1 aligned;
dcl	1 pdesc like desc1 aligned;

dcl	1 struct,
		2 pscale fixed bin(17),
		2 pprec fixed bin(17),
		2 pp ptr,
		2 qq ptr;

dcl	prec fixed bin(17);
dcl	(p,q) pointer;

dcl  (	a based(p),
	b based(q)) float bin(63);

dcl  (	sa based(p),
	sb based(q)) bit(72) aligned;

dcl  (	ia based(p),
	ib based(q)) fixed bin(71);

dcl	float bit(1) aligned defined(ifloat);
dcl	short bit(1) aligned;
dcl	itype fixed bin(17);

dcl	rp pointer init(addr(rand));

dcl	rshort(2) float bin(27) based(rp);
dcl	rlong(2) float bin(63) based(rp);
dcl	ishort(2) fixed bin(35) based(rp);
dcl	ilong(2) fixed bin(71) based(rp);

dcl	ones bit(72) aligned internal static init((72)"1"b);

begin:
	string(desc) = string(pdesc);
	short = substr(desc.type,6,1);
	itype = fixed(desc.type,6);
	prec = pprec;
	p = pp;
	q = qq;

	if float then
	do;
		if desc.packed then
		do;
			length = prec + 9;
			substr(sa,1,length) = substr(rand,1,length);
			if itype < 5 then b = 0;	/* real */
			else substr(sb,1,length) = substr(rand,length+1,length);	/* complex */
		end;
		else
		do;
			b = 0;
			if short then	/* short */
			do;
				a = rshort(1);
				if itype > 4 then b = rshort(2);	/* complex */
			end;
			else			/* long  */
			do;
				a = rlong(1);
				if itype > 4 then b = rlong(2);	/* complex */
			end;
		end;
	end;
	else					/* fixed */
	do;
		if desc.packed then
		do;
			length = prec + 1;
			substr(sa,72-length+1,length) = substr(rand,1,length);
			if substr(rand,1,1) then substr(sa,1,72-length) = ones;
			if itype < 5 then ib = 0;
			else
			do;
				substr(sb,72-length+1,length) = substr(rand,length+1,length);
				if substr(rand,length+1,1) then substr(sb,1,72-length) = ones;
			end;
		end;
		else
		do;
			ib = 0;
			if short then		/* short */
			do;
				ia = ishort(1);
				if itype > 4 then ib = ishort(2);
			end;
			else
			do;
				ia = ilong(1);
				if itype > 4 then ib = ilong(2);
			end;
		end;
	end;
end;

/*  */

begin:
	dop1.p = addr(a);
	dop1.q = addr(b);
	dop2.r = addr(c);
	dop2.s = addr(d);
	dop3.t = addr(e);
	dop3.u = addr(f);

	ia,ib,ic,id,ie,if = 0;
	string(desc1) = pdesc1;
	string(desc3) = pdesc3;
	prec1 = fixed(desc1.precision,12);
	prec3 = fixed(desc3.precision,12);
	operation = poperation;
	rtype = mod(fixed(desc1.type,6),4);
	ifloat = rtype=0|rtype=3;
	call getrand(pop1,desc1,dop1);
	if operation < negate | operation = complex_fun then
	do;
		string(desc2) = pdesc2;
		prec2 = fixed(desc2.precision,12);
		call getrand(pop2,desc2,dop2);
	end;

	if ifloat then		/* float */
	do;
		length = prec3 + 9;
		if ^desc3.packed then if length > 36 then length = 72;
					       else length = 36;
		go to float_op(operation);

/* comparison */

float_op(0):
		comp = 1;		/* ^= */
		if a = c then if b = d then comp = 0;		/* = */
		addr(pop3)->based_fb = comp;
		return;

/* addition */

float_op(1):
		e = a + c;
		f = b + d;
		go to return_float;

/* subtraction */

float_op(2):
		e = a - c;
		f = b - d;
		go to return_float;

/* multiplication or division */

float_op(3):	float_op(4):
		ac = a*c;
		bd = b*d;
		ad = a*d;
		bc = b*c;
		if operation = multiplication then
		do;
			e = ac - bd;
			f = ad + bc;
			go to return_float;
		end;
		else	/* division */
		do;
			if abs(d) < abs(c)
			then do;
			     cd = d/c;
			     denom = c + d*cd;
			     e = (a + b*cd) / denom;
			     f = (b - a*cd) / denom;
			     end;

			else do;
			     cd = c/d;
			     denom = c*cd + d;
			     e = (a*cd + b) / denom;
			     f = (b*cd - a) / denom;
			     end;

			go to return_float;
		end;

/* negate */

float_op(5):
		e = -a;
		f = -b;
		go to return_float;

/* real */

float_op(6):
		e = a;
		go to return_real;

/* imag */

float_op(7):
		e = b;
		go to return_real;

/* round */

float_op(8):
		e = float_round_(a,prec2);
		f = float_round_(b,prec2);
		go to return_float;

/* complex */

float_op(9):
		e = a;
		f = c;
		go to return_float;

/* abs */

float_op(10):
		a = abs(a);
		b = abs(b);

		if a ^= 0.0e0
		then if b ^= 0.0e0
		     then if a > b
			then e = a * sqrt(1.0e0b + (b/a)*(b/a));
			else e = b * sqrt(1.0e0b + (a/b)*(a/b));
		     else e = a;
		else e = b;

		go to return_real;

/* conjg */

float_op(11):
		e = a;
		f = -b;

return_float:
		substr(pop3,length+1,length) = substr(sf,1,length);
return_real:
		substr(pop3,1,length) = substr(se,1,length);
		return;
	end;
/*  */
	else				/* fixed point */
	do;
		scale1 = fixed(desc1.scale,12);
		if scale1 > 2047 then scale1 = scale1 - 4096;
		scale3 = fixed(desc3.scale,12);
		if scale3 > 2047 then scale3 = scale3 - 4096;
		if operation < negate | operation = complex_fun then
		do;
			scale2 = fixed(desc2.scale,12);
			if scale2 > 2047 then scale2 = scale2 - 4096;
		end;
		length = prec3 + 1;
		if ^desc3.packed then if length > 36 then length = 72;
					       else length = 36;

		code = 0;
		rscale = scale1;
		go to fixed_op(operation);

/* comparison, addition, or subtraction */

fixed_op(0):	fixed_op(1):	fixed_op(2):	fixed_op(9):

		rscale = max(scale1,scale2);
		dscale = scale1 - scale2;
		if dscale > 0 then
		do;
			call scaler_(ic,dscale,code);
			call scaler_(id,dscale,code);
		end;
		else if dscale < 0 then
		do;
			dscale = -dscale;
			call scaler_(ia,dscale,code);
			call scaler_(ib,dscale,code);
		end;

		if operation = comparison then
		do;
			comp = 1;		/* ^= */
			if ia = ic then if ib = id then comp = 0;	/* = */
			addr(pop3)->based_fb = comp;
			return;
		end;

		if operation = addition then
		do;
			ie = ia + ic;
			if = ib + id;
			go to return_fixed;
		end;

		if operation = subtraction then
		do;
			ie = ia - ic;
			if = ib - id;
			go to return_fixed;
		end;

		if operation = complex_fun then
		do;
			ie = ia;
			if = ic;
			go to return_fixed;
		end;

/* multiplication or division */

fixed_op(3):	fixed_op(4):
		t1 = ia*ic;
		t2 = ib*id;
		t3 = ia*id;
		t4 = ib*ic;
		if operation = multiplication then
		do;
			ie = t1 - t2;
			if = t3 + t4;
			rscale = scale1 + scale2;
			go to return_fixed;
		end;
		else		/* division */
		do;
			d1_scale = scale1 + scale2;
			d2_scale = scale2 + scale2;
			t5 = ic*ic;
			t6 = id*id;
			t5 = t5 + t6;
			t1 = t1 + t2;
			t3 = t4 - t3;
			ie = fixed_divide_(t1,t5,d1_scale,d2_scale,scale3,code);
			if = fixed_divide_(t3,t5,d1_scale,d2_scale,scale3,code);
			rscale = scale3;
			go to return_fixed;
		end;

/* negate */

fixed_op(5):
		ie = -ia;
		if = -ib;
		go to return_fixed;

/* real */

fixed_op(6):
		ie = ia;
		go to return_fixed_real;

/* imag */

fixed_op(7):
		ie = ib;
		go to return_fixed_real;

/* round */

fixed_op(8):
		ie = fixed_round_(ia,prec2,scale1);
		if = fixed_round_(ib,prec2,scale1);
		rscale = prec2;
		go to return_fixed;

/* abs */

fixed_op(10):
		ie = fixed(sqrt(float(ia*ia + ib*ib,63)),71);
		go to return_fixed_real;

/* conjg */

fixed_op(11):
		ie = ia;
		if = -ib;
return_fixed:
		dscale = scale3 - rscale;
		if dscale ^= 0 then call scaler_(if,dscale,code);
		if code ^= 0 then go to signal;
		substr(pop3,length+1,length) = substr(sf,72-length+1,length);
		if size_check_(if,length) ^= 0 then go to signal;

return_fixed_real_1:
		if dscale ^= 0 then
		do;
			call scaler_(ie,dscale,code);
			if code ^= 0 then go to signal;
		end;
		substr(pop3,1,length) = substr(se,72-length+1,length);
		if size_check_(ie,length) ^= 0 then go to signal;
		return;

return_fixed_real:
		dscale = scale3 - rscale;
		go to return_fixed_real_1;
	end;

/* Signal SIZE condition */

signal:	call pl1_signal_$help_plio2_signal_("size",null,243,"",0);

end;




		    complex_decimal_op_.pl1         10/24/83  1358.6r w 10/24/83  1332.0       63090



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


complex_decimal_op_: procedure(poperation, pop3, pdesc3, pop1, pdesc1, pop2, pdesc2);

/*	Program to implement PL/I Version II runtime complex decimal operators

	Initial Version:	28 April 1972 by Paul Green
	Modified:		19 October 1972 by Richard A. Barnes
*/

dcl	poperation fixed bin,
	pop3	char(1) unal,
	pdesc3	bit(36) aligned,
	pop1	char(1) unal,
	pdesc1	bit(36) aligned,
	pop2	char(1) unal,
	pdesc2	bit(36) aligned;

dcl (	desc1,desc2,desc3) bit(36) aligned;
dcl	operation fixed bin;
dcl	based_fb based fixed bin;
dcl	based_ch based char(1) unal;
dcl (	a based(p),
	b based(q),
	c based(r),
	d based(s),
	e based(t),
	f based(u)) char(1) unal;
dcl (	p,q,r,s,t,u) ptr;
dcl	zero char(65) internal static initial("+000000000000000000000000000000000000000000000000000000000000000");
dcl	adj(0:l1) char(1) based unal;
dcl (	l1,l2,l3) fixed bin;
dcl (	binary, substr, addr) builtin;
dcl	desc_fix bit(36) aligned int static init("100100100000000000000000000000000000"b);
dcl	desc_flt bit(36) aligned int static init("100101000000000000000000000000000000"b);
dcl	desc bit(36) aligned;
dcl	d1 bit(36) aligned defined(desc);
dcl	(d2,d3,d4) bit(36) aligned;
dcl	decimal_op_ entry(fixed bin,char(1)unal,bit(36)aligned,char(1)unal,bit(36)aligned,char(1)unal,bit(36)aligned);
dcl	decimal_sqrt_ entry(char(1),bit(36) aligned,char(1),bit(36) aligned);
dcl (	t1 defined (t11),
	t2 defined (t22),
	t3 defined (t33),
	t4 defined (t44),
	t5 defined (t55),
	t6 defined (t66)) char(1) unaligned;
dcl (	t11,t22,t33,t44,t55,t66) char(65) unaligned;
dcl	azero defined(zero) char(1) unal;
dcl (	comparision	initial(0),
	addition		initial(1),
	subtraction	initial(2),
	multiplication	initial(3),
	division		initial(4),
	negate		initial(5),
	real_fun		initial(6),
	imag_fun		initial(7),
	round_fun		initial(8),
	complex_fun	initial(9),
	abs_fun		initial(10),
	conjg_fun		initial(11)) fixed binary internal static;

/*	(e + fi) = pop3
	(a + bi) = pop1
	(c + di) = pop2

	(a + bi) + (c + di) = ((a + c) + (b + d)i)
	(a + bi) - (c + di) = ((a - c) + (b - d)i)
	(a + bi) * (c + di) = ((a*c - b*d) + (a*d + b*c)i)
	(a + bi) / (c + di) = ((__a*__c_+___b*__d)_ + (__b*__c_-___a*__d)__i)
			   (c*c + d*d)   (c*c + d*d)
	abs((a + bi)) = sqrt(a*a + b*b)
	round((a + bi),pdesc2) = (round(a,pdesc2) + (round(b,pdesc2)i)
	- (a + bi) = (-a - bi)
*/
begin:
	operation = poperation;
	desc3 = pdesc3;
	l3 = binary(substr(desc3,25,12),12) + 1;

	if substr(desc3,5,3) = "011"b		/* complex fixed dec */
	then do;
		substr(desc3,5,3) = "001"b;	/* real fixed decimal */
		desc = desc_fix;
	     end;
	else do;
		substr(desc3,5,3) = "010"b;	/* real float dec */
		desc = desc_flt;
		l3 = l3 + 1;
	     end;
	t = addr(pop3);
	u = addr(t->adj(l3));

	desc1 = pdesc1;
	l1 = binary(substr(desc1,25,12),12) + 1;
	if substr(desc1,5,3) = "011"b		/* complex fixed dec */
	then substr(desc1,5,3) = "001"b;	/* real fixed dec */
	else if substr(desc1,5,3) = "100"b	/* complex float dec */
	     then do;
		substr(desc1,5,3) = "010"b;	/* real float decimal */
		l1 = l1 + 1;
		end;
	     else if substr(desc1,5,3) = "001"b | substr(desc1,5,3) = "010"b	/* real (fixed|float) decimal */
		then do;
			p = addr(pop1);
			q = addr(zero);
			go to check_opnd2;
		     end;
	p = addr(pop1);
	q = addr(p->adj(l1));

check_opnd2:
	if operation < negate | operation = complex_fun
	then do;
		desc2 = pdesc2;
		l2 = binary(substr(desc2,25,12),12) + 1;
		if substr(desc2,5,3) = "011"b		/* complex fixed decimal */
		then substr(desc2,5,3) = "001"b;	/* real fixed decimal */
		else if substr(desc2,5,3) = "100"b	/* complex float dec */
		     then do;
			substr(desc2,5,3) = "010"b;	/* real float decimal */
			l2 = l2 + 1;
			end;
		     else if substr(desc2,5,3) = "001"b | substr(desc2,5,3) = "010"b /* real (fixed|float) dec */
			then do;
				r = addr(pop2);
				s = addr(zero);
				go to operate;
			     end;
		r = addr(pop2);
		s = addr(r->adj(l2));
	     end;

operate:
	if operation = negate
	then do;
		call decimal_op_(operation,e,desc3,a,desc1,a,desc1);
		call decimal_op_(operation,f,desc3,b,desc1,b,desc1);
		return;
	     end;

	if operation = addition | operation = subtraction
	then do;
		call decimal_op_(operation,e,desc3,a,desc1,c,desc2);
		call decimal_op_(operation,f,desc3,b,desc1,d,desc2);
		return;
	     end;

	if operation = multiplication | operation = division
	then do;
		d2 = d1;
		call decimal_op_(multiplication,t1,d1,a,desc1,c,desc2);
		call decimal_op_(multiplication,t2,d1,b,desc1,d,desc2);
		call decimal_op_(multiplication,t3,d1,a,desc1,d,desc2);
		call decimal_op_(multiplication,t4,d1,b,desc1,c,desc2);
	     end;

	if operation = multiplication
	then do;
		call decimal_op_(subtraction,e,desc3,t1,d1,t2,d1);
		call decimal_op_(addition,f,desc3,t3,d1,t4,d1);
		return;
	     end;

	if operation = division
	then do;
		d3,d4 = d2;
		call decimal_op_(multiplication,t5,d2,c,desc2,c,desc2);
		call decimal_op_(multiplication,t6,d2,d,desc2,d,desc2);
		call decimal_op_(addition,t5,d3,t5,d2,t6,d2);
		call decimal_op_(addition,t1,d4,t1,d1,t2,d1);
		call decimal_op_(subtraction,t3,d4,t4,d1,t3,d1);
		call decimal_op_(division,e,desc3,t1,d4,t5,d3);
		call decimal_op_(division,f,desc3,t3,d4,t5,d3);
		return;
	     end;

	if operation = round_fun
	then do;
		call decimal_op_(operation,e,desc3,a,desc1,a,pdesc2);
		call decimal_op_(operation,f,desc3,b,desc1,a,pdesc2);
		return;
	     end;

	if operation = real_fun then
	do;
		call decimal_op_(addition,e,desc3,a,desc1,azero,desc1);
		return;
	end;

	if operation = imag_fun then
	do;
		call decimal_op_(addition,e,desc3,b,desc1,azero,desc1);
		return;
	end;

	if operation = complex_fun then
	do;
		call decimal_op_(addition,e,desc3,a,desc1,azero,desc1);
		call decimal_op_(addition,f,desc3,c,desc2,azero,desc2);
		return;
	end;

	if operation = abs_fun
	then do;
		d2 = d1;
		call decimal_op_(multiplication,t1,d1,a,desc1,a,desc1);
		call decimal_op_(multiplication,t2,d1,b,desc1,b,desc1);
		call decimal_op_(addition,t1,d2,t1,d1,t2,d1);
		call decimal_sqrt_(e,desc3,t1,d2);
		return;
	     end;

	if operation = conjg_fun then
	do;
		call decimal_op_(addition,e,desc3,a,desc1,azero,desc1);
		call decimal_op_(negate,f,desc3,b,desc1,b,desc1);
		return;
	end;

	if operation = comparision
	then do;
		call decimal_op_(operation,addr(l1)->based_ch,desc1,a,desc1,c,desc2);
		call decimal_op_(operation,addr(l2)->based_ch,desc1,b,desc1,d,desc2);
		if l1 = 0 & l2 = 0
		then l3 = 0;		/* = */
		else l3 = 1;		/* /= */
		t -> based_fb = l3;
		return;
	     end;
end;




		    decimal_exp2_.pl1               10/24/83  1358.6r w 10/24/83  1332.0       11007



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


decimal_exp2_:	proc(number,exponent) returns(float dec(59));

dcl	(number,result) float dec(59),

	i fixed bin(35),
	(exp,exponent) fixed bin(71),

	negative bit(1) aligned;

dcl	(abs,index,sign,substr,unspec) builtin;

dcl	code_ entry(fixed bin(15));

	if number=0.0e0
	then	if exponent>0
		then	return(number);
		else do;
			call  code_(17-sign(exponent));

			return(number);
		end;

	if exponent=0
	then	return(1.0e0);

	negative = exponent<0;
	exp = abs(exponent);

	result = number;

	do i = index(unspec(exp),"1"b)+1 to 72;
		result = result * result;

		if substr(unspec(exp),i,1)
		then	result = result * number;
	end;

	if ^negative
	then	return(result);
	else	return(1.0e0/result);

	end decimal_exp2_;




		    decimal_exp_.pl1                10/24/83  1358.6r w 10/24/83  1332.1       10845



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


decimal_exp_:	proc(number,exponent) returns(float dec(59));

dcl	(number,result) float dec(59),

	(i,exp,exponent) fixed bin(35),

	negative bit(1) aligned;

dcl	(abs,index,sign,substr,unspec) builtin;

dcl	code_ entry(fixed bin(15));

	if number=0.0e0
	then	if exponent>0
		then	return(number);
		else do;
			call  code_(17-sign(exponent));

			return(number);
		end;

	if exponent=0
	then	return(1.0e0);

	negative = exponent<0;
	exp = abs(exponent);

	result = number;

	do i = index(unspec(exp),"1"b)+1 to 36;
		result = result * result;

		if substr(unspec(exp),i,1)
		then	result = result * number;
	end;

	if ^negative
	then	return(result);
	else	return(1.0e0/result);

	end decimal_exp_;




		    decimal_op_.pl1                 10/24/83  1358.6r w 10/24/83  1332.1      229032



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


/* Decimal arithmetic runtime routines for Version II PL/1
   These routines operate on floating decimal or fixed scaled decimal numbers
   with a maximum precision of 63 digits.  The length of the number as determined
   by the input descriptor does not include the leading sign or the trailing
   exponent character in the case of floating point numbers.

   Initial Version: 16 July 1971 by PG
	Modified: 19 October 1972 by RAB */

decimal_op_: proc(poperation,pop3,pdesc3,pop1,pdesc1,pop2,pdesc2);

dcl	poperation	fixed bin,	/* operation to perform
					   0 = comparsion of op1 and op2
					   1 is op3 = op1 + op2
					   2 is op3 = op1 - op2
					   3 is op3 = op1 * op2
					   4 is op3 = op1 / op2
					   5 is op3 = - op1
					   6 is op3 = ceil(op1)
					   7 is op3 = floor(op1)
					   8 is op3 = round(op1,desc2)
					   9 is op3 = sign(op1)
					  10 is op3 = abs(op1)
					  11 is op3 = trunc(op1)
					  12 is op3 = mod(op1,op2)
					  13 is op3 = min(op1,op2)
					  14 is op3 = max(op1,op2) */
	pop3		char(1) unal,	/* result if operation is not comparsion */
	pdesc3		bit(36) aligned,	/* descriptor of op3, result if comparison */
	pop1		char(1) unal,	/* left operand */
	pdesc1		bit(36) aligned,	/* descriptor */
	pop2		char(1) unal,	/* right operand */
	pdesc2		bit(36) aligned;	/* descriptor of op2, 2nd arg of round bif */

dcl (	ans,op1,op2,product(9),remainder) char(64) aligned;
dcl (	desc1,desc2,desc3) bit(36) aligned;
dcl	max_desc bit(36) aligned int static init("100101000000000000000000000000111111"b);
dcl	decimal_op_ entry(fixed bin,char(1) unal,bit(36) aligned,char(1) unal,bit(36) aligned,char(1) unal,bit(36) aligned);
dcl	c char(1) unal based(p);
dcl	p ptr;
dcl (	sch,ch,ci,sign,sign1,sign2) char(1) aligned;
dcl (	big,carry,col1,col2,exp,i,j,k,l0,l1,l2,l3,lg3,len1,len2,n,p1,p2,
	s1,s2,scale1,scale2,scale3,sc3,st(9),sum) fixed bin;
dcl (	addr,binary,bit,divide,fixed,length,max,min,null,substr,unspec) builtin;
dcl	info bit(36) initial("111011011100010010110010000101001001"b) internal static;
dcl (	zero_op1 init(13),zero_op2 init(22)) fixed bin int static;
dcl	bit3 bit(3) aligned;
dcl (	add,float,negate,no_round,product_calculated(9),signal_ufl) bit(1) aligned;
dcl	operation fixed bin;
dcl	based_fb based fixed bin;
dcl	negabs bit(1) aligned init("0"b);

dcl (	comparison	init(0),
	addition		init(1),
	subtraction	init(2),
	multiplication	init(3),
	division		init(4),
	negation		init(5),
	ceil_fun		init(6),
	floor_fun		init(7),
	round_fun		init(8),
	sign_fun		init(9),
	abs_fun		init(10),
	trunc_fun		init(11),
	mod_fun		init(12),
	min_fun		init(13),
	max_fun		init(14)) fixed bin int static;


dcl	plio2_signal_$s_ entry(ptr,char(*) aligned,char(*) aligned,fixed bin);
dcl	condition(5) char(13) aligned internal static
	initial("SIZE","OVERFLOW","UNDERFLOW","ZERODIVIDE","FIXEDOVERFLOW");
dcl	error_number(5) fixed bin internal static initial(158,159,160,120,121);

begin:
	desc3 = pdesc3;
	desc1 = pdesc1;
	negate,
	signal_ufl = "0"b;
	operation = poperation;
	if operation = min_fun then operation = comparison;
	if operation = max_fun then operation = comparison;
	if operation = negation | operation = abs_fun
	then do;

	     /* we use the fact that op3 will have the same attributes as op1 */

	     l1 = fixed(substr(desc1,25,12),12);
	     sch = substr(pop1,1,1);
	     if operation = negation
	     then if sch = "-"
		then sch = "+";
		else sch = "-";
	     else sch = "+";
	     if substr(desc1,13,12) = substr(desc3,13,12) then /* check for equal scales */
	     do;
		if substr(desc1,7,1) = "0"b then l1 = l1 + 1;	/* floating pt */
		substr(pop3,1,1) = sch;
		substr(pop3,2,l1) = substr(pop1,2,l1);
		return;
	     end;
	     else negabs = "1"b;
	     end;

	desc2 = pdesc2;
	float = ^ substr(desc3,7,1);

	l0 = fixed(substr(desc3,25,12),12);
	if l0 = 0 then call setdesc;
	lg3 = l0 + 1;


	if float then lg3 = lg3 + 1;
	else do;
	     sc3 = fixed(substr(desc3,13,12),12);
	     if sc3 > 2047 then sc3 = sc3 - 4096;
	     end;

	l1 = fixed(substr(desc1,25,12),12) + 1;

	if substr(desc1,7,1)
	then do;

	     /* fixed decimal */

	     scale1 = fixed(substr(desc1,13,12),12);
	     if scale1 > 2047 then scale1 = scale1 - 4096;
	     end;
	else do;

	     /* float decimal */

	     ch = substr(pop1,l1+1,1);
	     exp = fixed(unspec(ch),9);
	     if exp >= 128 then exp = exp - 256;
	     scale1 = -exp;
	     end;

	if operation >= negation & operation < mod_fun
	then go to skip_opnd_two;

	l2 = fixed(substr(desc2,25,12),12) + 1;

	if substr(desc2,7,1)
	then do;

	     /* fixed decimal */

	     scale2 = fixed(substr(desc2,13,12),12);
	     if scale2 > 2047 then scale2 = scale2 - 4096;
	     end;
	else do;

	     /* float decimal */

	     ch = substr(pop2,l2+1,1);
	     exp = fixed(unspec(ch),9);
	     if exp >= 128 then exp = exp - 256;
	     scale2 = -exp;
	     end;

	op2 = (64)"0";
	sign2 = substr(pop2,1,1);
	s2 = 66-l2;
	substr(op2,s2,l2-1) = substr(pop2,2,l2-1);

	do j = s2 to 64 while( substr(op2,j,1) = "0");
	end;
	s2 = j-1;					/* s2 = verify(op2,"0") - 1;	 */
	p2 = 65-j;				/* # digits */

skip_opnd_two:
	ans, op1 = (64)"0";
	sum, carry = 0;
	sign1 = substr(pop1,1,1);
	s1 = 66-l1;
	substr(op1,s1,l1-1) = substr(pop1,2,l1-1);

	do j = s1 to 64 while( substr(op1,j,1) = "0" );	/* find true number of digits */
	end;
	s1 = j-1;					/* s1 = position to left of first non-zero digit */
	p1 = 65 - j;

	if negabs then
	do;
		sign1 = sch;
		go to assign_op1;
	end;

	if operation = division then go to divide_op;

	if operation = ceil_fun
	then do;
ceil:
		if sign1 = "-"
		then do;
			negate = "1"b;
			sign1 = "+";
			go to floor;
		     end;

		if test_fractional() > 0		/* if fractional part ^= 0 */
		then do;
			l2 = s1 + len1;
ceil_loop:		ch = substr(ans,l2,1);
			sum = fixed(unspec(ch) & "00001111"b,17);
			sum = sum + 1;
			if sum < 10 then go to ceil_out;
			sum = sum - 10;
			unspec(ch) = substr(unspec(sum),28,9) | "000110000"b;
			substr(ans,l2,1) = ch;
			l2 = l2 - 1;
			go to ceil_loop;
ceil_out:			unspec(ch) = substr(unspec(sum),28,9) | "000110000"b;
			substr(ans,l2,1) = ch;
			if substr(ans,l3,1) ^= "0"	/* carry made it longer */
			then l3 = l3 - 1;
		     end;
neg_ck:
		if negate
		then if sign1 = "-"
		     then sign = "+";
		     else sign = "-";
		go to normalize;
	     end;

	if operation = floor_fun
	then do;
floor:
		if sign1 = "-"
		then do;
			negate = "1"b;
			sign1 = "+";
			go to ceil;
		     end;

		i = test_fractional();		/* just drop fractional part */
		go to neg_ck;

	     end;

	if operation = trunc_fun
	then do;
		if sign1 = "-"
		then go to ceil;
		else go to floor;
	     end;

test_fractional: procedure returns(fixed bin);	/* VERSION II needs () */

/* This procedure assigns the non-fractional (integer) part of op into ans.
   It then returns a code indicating whether or not
   the fractional part of op1 was > 0 or = 0. */


	i = min(scale1,p1);			/* # of fractional digits */
	if i < 0
	then i = 0;

	len1 = p1 - i;			/* # of integer digits */
	ans = (64)"0";
	substr(ans,s1+1,len1) = substr(op1,s1+1,len1);
	l3 = s1;
	scale3 = scale1;
	do k = 65-i to 64 while(substr(op1,k,1) = "0");
	end;
	if k = 65
	then return(0);			/* fractional part is zero */
	else return(1);			/* fractional part non-zero */

end test_fractional;

	if operation = round_fun
	then do;
		n = addr(pdesc2)->based_fb;		/* 2nd operand of round */
		sign = sign1;
		i = min(scale1,p1);			/* # of fractional digits */
		if i < 0
		then i = 0;
		len1 = p1 - i + n + 1;		/* number of digits to move (includes column to add .5) */
		if len1 <= 0 then go to assign_zero2;
		if len1 > 65-s1
		then do;
			no_round = "1"b;
			len1 = 65-s1;
		     end;
		l3 = s1;
		scale3 = scale1;
		s1 = s1 + 1;
		ans = (64)"0";
		substr(ans,s1,len1) = substr(op1,s1,len1);
		j,k = s1 + len1 - 1;		/* column to add .5 */

		if no_round then go to normalize;
		carry = 5;
		sum = 0;

		if substr(ans,k,1) >= "5"
		then do;
round_loop:		ch = substr(ans,k,1);
			sum = fixed(unspec(ch) & "00001111"b,17);
			sum = sum + carry;
			if sum < 10 then go to round_out;
			sum = sum - 10;
			unspec(ch) = substr(unspec(sum),28,9) | "000110000"b;
			substr(ans,k,1) = ch;
			k = k - 1;
			carry = 1;
			go to round_loop;
round_out:		unspec(ch) = substr(unspec(sum),28,9) | "000110000"b;
			substr(ans,k,1) = ch;
		     end;
		substr(ans,j,1) = "0";		/* zap down digit from +.5 */
		go to normalize;
	     end;

	if operation = sign_fun
	then do;
		if sign1 = "-"
		then i = -1;
		else if p1 = 0
		     then if substr(desc1,7,1)	/* fixed point zero */
			then i = 0;
			else if scale1 = -127	/* floating point zero */
			     then i = 0;
			     else i = 1;
		     else i = 1;
		addr(pop3)->based_fb = i;
		return;
	     end;

	if operation = mod_fun
	then do;
		p = addr(ans);
		call decimal_op_(division,c,max_desc,pop1,pdesc1,pop2,pdesc2);
		call decimal_op_(floor_fun,c,max_desc,c,max_desc,pop2,pdesc2);
		call decimal_op_(multiplication,c,max_desc,c,max_desc,pop2,pdesc2);
		call decimal_op_(subtraction,pop3,pdesc3,pop1,pdesc1,c,max_desc);
		return;
	     end;

	i = scale1;
	j = scale2;

	if operation ^= comparison
	then do;
		if p1 = 0
		then do;
			if operation = multiplication then go to assign_zero2;
			if p2 = 0 then go to assign_zero2;
			go to assign_op2;
		     end;
		if p2 = 0
		then do;
			if operation = multiplication then go to assign_zero2;
			go to assign_op1;
		     end;

		if operation = multiplication then go to multiply_op;
		if operation = addition then add = "1"b; else add = "0"b;
	     end;

	scale3 = max(scale1,scale2);				/* pl1 language rules for scale of result */
	col1 = s1 - scale3 + scale1 + 1;			/* re-align operands to account for scales */
	col2 = s2 - scale3 + scale2 + 1;
	len1 = min(65-col1,p1);
	len2 = min(65-col2,p2);

	if float 						/* force number to start in at least column 2 */
	then do;
		if col1 < 2
		then do;
			k = 2-col1;
again:			col1 = col1 + k;
			col2 = col2 + k;
			scale1 = scale1 - k;
			scale2 = scale2 - k;
			scale3 = scale3 - k;
		     end;
		if col2 < 2
		then do;
			k = 2-col2;
			go to again;
		     end;
	     end;
	else if operation ^= comparison
	     then do;
		if col1 < 2 then go to signal_size;
		if col2 < 2 then go to signal_size;
		end;

	if operation ^= comparison
	then do;
		if len1 < 1				/* operand one was zero */
		then do;
			if len2 < 1 then go to assign_zero2;	/* both are zero */
assign_op2:
			ans = (64)"0";
			substr(ans,s2+1,p2) = substr(pop2,l2-p2+1,p2);
			if operation = subtraction then if sign2 = "+" then sign2 = "-";
							else sign2 = "+";
			sign = sign2;
			l3 = s2;
			scale3 = j;
			go to normalize;
		     end;
		if len2 < 1				/* operand two was zero */
		then do;
assign_op1:
			ans = (64)"0";
			substr(ans,s1+1,p1) = substr(pop1,l1-p1+1,p1);
			sign = sign1;
			l3 = s1;
			scale3 = i;
			go to normalize;
		     end;
	     end;
	else do;
		if col1 ^= col2 then go to test;
		if col1 < 2
		then do;
			n = l1 - p1 + 1;
			k = l2 - p2 + 1;
compare_long_fixed_loop:
			ch = substr(op1,n,1);
			ci = substr(op2,k,1);
			if ch > ci			/* op1 > op2 */
			then do;
				big = 1;
				go to compare;
			     end;
			if ch < ci			/* op1 < op2 */
			then do;
				big = -1;
				go to compare;
			     end;
			if n = 64
			then do;				/* op1 is shorter */
				do n = k+1 to 64 while(substr(op2,n,1) = "0");
				end;
				if n = 65
				then do;			/* op1 = op2 */
compare_equal:				big = 0;
					go to compare;
				     end;
				big = -1;			/* op1 < op2 */
				go to compare;
			     end;
			if k = 64
			then do;				/* op2 shorter */
				do k = n+1 to 64 while(substr(op1,k,1) = "0");
				end;
				if k = 65 then go to compare_equal;	/* op1 = op2 */
				big = 1;			/* op1 > op2 */
				go to compare;
			     end;
			k = k + 1;
			n = n + 1;
			go to compare_long_fixed_loop;
		     end;
	     end;
	op1,op2 = (64)"0";
	substr(op1,col1,len1) = substr(pop1,l1-p1+1,len1);	/* final alignment prior to operation */
	substr(op2,col2,len2) = substr(pop2,l2-p2+1,len2);	/* takes care of lengths and scale.   */
	p1 = 65-col1;
	p2 = 65-col2;

/* Now determine which operand has the larger magnitude, and make it operand one. */

test:
	if len1 > len2
	then big = 1;
	else if len2 > len1
	     then big = -1;
	     else do;
		do n = col1 to 64 while(substr(op1,n,1) = substr(op2,n,1));
		end;
		if n = 65
		then big = 0;
		else if substr(op2,n,1) < substr(op1,n,1)
		     then big = 1;
		     else big = -1;
		end;

	if operation = comparison
	then do;
compare:
		if big ^= 0
		     then if sign1 = "+"
			     then if sign2 = "-"
				     then big = 1;
				     else;
			     else if sign2 = "+"
				     then big = -1;
				     else big = -big;

		if poperation = min_fun
		then if big <= 0
		     then go to assign_op1;
		     else go to assign_op2;
		if poperation = max_fun
		then if big <= 0
		     then go to assign_op2;
		     else go to assign_op1;

		addr(pdesc3)->based_fb = big;
		return;
	     end;

/* Simulate a 3-dimensional array, and use "info" to determine whether the operands
   must be switched, what the operation will be, and the sign of the result.	*/

	s1 = col1-1;
	s2 = col2-1;
	j = 1;
	if ^add
	then if sign2 = "-"
	     then sign2 = "+";
	     else sign2 = "-";
	if sign1 = "-" then j = j + 18;
	if sign2 = "-" then j = j + 9;
	if big = 0 then j = j + 3;
	else if big = 1 then j = j + 6;
	if j = zero_op1 | j = zero_op2 then go to assign_zero2;
	bit3 = substr(info,j,3);
	add = substr(bit3,3,1);
	if substr(bit3,1,1)					/* switch bit */
	then do;
		ans = op1;
		op1 = op2;
		op2 = ans;
		ans = (64)"0";
		k = s1;
		s1 = s2;
		s2 = k;
	     end;
	if substr(bit3,2,1)					/* sign bit */
	then sign = "+";
	else sign = "-";
	l1,l2,l3 = 64;

/* Loop to perform addition or subtraction. op2 <= op1 */

loop1:
	ch = substr(op2,l2,1);
	k = fixed(unspec(ch) & "000001111"b);		/* convert ASCII to BINARY */

loop2:
	ch = substr(op1,l1,1);
	i = fixed(unspec(ch) & "000001111"b,15,0);

	if add
	then do;
		sum = i + k + carry;
		carry = 0;
		if sum >= 10
		then do;
			sum = sum - 10;
			carry = 1;
		     end;
	     end;
	else do;
		sum = i - k - carry;
		carry = 0;
		if sum < 0
		then do;
			sum = sum + 10;
			carry = 1;			/* really borrow! */
		     end;
	     end;
	unspec(ch) = substr(unspec(sum),28,9) | "000110000"b;
	substr(ans,l3,1) = ch;

	l3 = l3-1;
	l2 = l2-1;
	l1 = l1-1;

	if s2 < l2 then go to loop1;
	k = 0;
	if s1 < l1 then go to loop2;
	if carry ^= 0
	then do;
		unspec(ch) = substr(unspec(carry),28,9) | "000110000"b;
		substr(ans,l3,1) = ch;
		l3 = l3 - 1;
		if l3 < 1 & ^float then go to signal_fixedoverflow;	/* result has > 63 digits */
	     end;
	go to normalize;

multiply_op:
	if sign1 = sign2
	then sign = "+";
	else sign = "-";
	l3 = 128 - s1 - s2;					/* precision of result. */

	if l3 >= 64
	then if ^float
	     then do;					/* product will have > 63 digits */
signal_fixedoverflow:
		i = 5;					/* fixedoverflow */
		go to signal;
		end;
	     else do;
		if s1 < 33
		then if s2 < 33
		     then do;
			k = 33 - s1;			/* truncate op1 & op2 */
			j = 33 - s2;
			end;
		     else do;
			k = 64 - s1 - s2;			/* truncate op1 */
			j = 0;
			end;
		else do;
			k = 0;				/* truncate op2 */
			j = 64 - s2 - s1;
		     end;

		if k ^= 0
		then do;
			col1 = s1 + 1 + k;
			len1 = 64 - s1 - k;
			scale1 = scale1 - k;
			op1 = (64)"0";
			substr(op1,col1,len1) = substr(pop1,l1+s1-63,len1);
			s1 = s1 + k;
		     end;
		if j ^= 0
		then do;
			col2 = s2 + 1 + j;
			len2 = 64 - s2 - j;
			scale2 = scale2 - j;
			op2 = (64)"0";
			substr(op2,col2,len2) = substr(pop2,l2+s2-63,len2);
			s2 = s2 + j;
		     end;
		end;

	scale3 = scale1 + scale2;
	ans = (64)"";					/* \000 */

	do l2 = 64 to s2+1 by -1;
	     ch = substr(op2,l2,1);
	     k = fixed(unspec(ch) & "000001111"b,15,0);

	     do l1 = 64 to s1+1 by -1;
		ch = substr(op1,l1,1);
		i = fixed(unspec(ch) & "000001111"b,15,0);

		l3 = l1 + l2 - 64;
		ch = substr(ans,l3,1);
		j = fixed(unspec(ch),15,0);			/* stored as fixed bin(8) until addition finished. */

		sum = i*k + j + carry;
		carry = 0;
loop_carry:
		if sum >= 10
		then do;
			sum = sum - 10;
			carry = carry + 1;
			go to loop_carry;
		     end;

		unspec(ch) = substr(unspec(sum),28,9);
		substr(ans,l3,1) = ch;
	     end;

	     if carry ^= 0
	     then do;
		l3 = l3 - 1;
		sum = carry;
		carry = 0;
		unspec(ch) = substr(unspec(sum),28,9);
		substr(ans,l3,1) = ch;
		end;
	end;

	do i = 1 to 61 by 4;
	unspec(substr(ans,i,4)) = unspec(substr(ans,i,4)) | (4)"000110000"b;
	end;

	l3 = l3 - 1;					/* = l1 + l2 - 65 */
	go to normalize;

divide_op:
	if s2 = 64
	then do;
		i = 4;					/* zerodivide */
		go to signal;
	     end;
	if s1 = 64 then go to assign_zero2;
	if sign1 = sign2
	then sign = "+";
	else sign = "-";
	if float
	then l1 = lg3 - 2;
	else l1 = lg3 - 1;

	scale3 = s1 + scale1 - scale2;			/* scale of quotient */
	remainder = (64)"0";
	substr(remainder,1,64-s1) = substr(op1,s1+1,64-s1);	/* dividend */
	product(1) = op2;					/* divisor */
	product_calculated(1) = "1"b;
	do i = 2 to 9;
	product_calculated(i) = "0"b;
	end;
	substr(product(1),s2,1) = "0";			/* erase sign */
	st(1) = s2;
	j = 0;
	len2 = 64 - s2;					/* # digits in rem */
	if float
	then do;
		l3 = 1;
		scale3 = scale3 + len2 - 1;
	     end;
	else l3 = len2;

divide_estimate:
	col1 = 1;
	col2 = s2+1;
	i = 64-s2;					/* # digits in divisor */
	if len2 < i
	then do;
		l3 = l3 + i - len2;				/* zeros in result */
		if l3 >= l1
		then do;
			l3 = l1;
			go to divide_finish;
		     end;
		len2 = i;					/* make rem same length as divisor */
	     end;
	else if i < len2 then go to divide_est3;		/* rem is greater than divisor */
divide_est2:
	ch = substr(remainder,col1,1);
	ci = substr(op2,col2,1);

	if ch = ci					/* can't tell */
	then do;
		col1 = col1+1;
		col2 = col2+1;
		if 64 >= col1 & 64 >= col2 then go to divide_est2;
	     end;

	if ch < ci					/* won't divide */
	then do;
		if l3 >= l1 then go to divide_finish;
		l3 = l3 + 1;				/* digit = "0" */
		len2 = len2 + 1;				/* incr remainder length */
divide_est3:
		ch = substr(remainder,1,1);
		i = fixed(unspec(ch) & "000001111"b,15,0);
		ch = substr(remainder,2,1);
		i = 10*i + fixed(unspec(ch) & "000001111"b,15,0);
	     end;
	else do;
		ch = substr(remainder,1,1);
		i = fixed(unspec(ch) & "000001111"b,15,0);
	     end;

	ci = substr(op2,s2+1,1);
	k = fixed(unspec(ci) & "000001111"b,15,0);
	j = divide(i,k,15,0);
	if j >= 10 then j = 9;				/* it can happen! 1/11 for instance */

/* j is the guess for how many times the divisor will go into the dividend */
/* Now calculate the product of j and op2 */

divide_product:
	if ^product_calculated(j)
	then do;
		carry, sum = 0;
		product(j) = (64)"0";
		do l2 = 64 to s2+1 by -1;
			ch = substr(op2,l2,1);
			k = fixed(unspec(ch) & "000001111"b,15,0);
			sum = j*k + carry;
			carry = 0;
divide_carry_loop:
			if sum >= 10
			then do;
				sum = sum - 10;
				carry = carry + 1;
				go to divide_carry_loop;
			     end;
			unspec(ch) = substr(unspec(sum),28,9) | "0001100000"b;
			substr(product(j),l2,1) = ch;
		end;
		if carry ^= 0
		then do;
			sum = carry;
			carry = 0;
			unspec(ch) = substr(unspec(sum),28,9) | "000110000"b;
			substr(product(j),l2,1) = ch;
			l2 = l2 - 1;
		     end;
		st(j) = l2;
		product_calculated(j) = "1"b;
	     end;

/* test to see if we can subtract the partial product from the remainder. */

	i = 64 - st(j);
	if i < len2 then go to divide_subtract;			/* if # digits in partial product < # digits in rem. */
	if len2 < i then go to divide_fail;			/* partial product too big */
	l2 = 1;
divide_magnitude:
	ch = substr(remainder,l2,1);
	ci = substr(product(j),st(j)+l2,1);

	if ch = ci
	then do;
		l2 = l2+1;
		if 64 >= l2 & 64 >= st(j)+l2 then go to divide_magnitude;
	     end;

	if ch < ci
	then do;
divide_fail:
		j = j-1;
		go to divide_product;
	     end;

/* it will subtract, j is correct quotient digit. */

divide_subtract:
	sum = j;
	unspec(ch) = substr(unspec(sum),28,9) | "000110000"b;
	substr(ans,l3,1) = ch;
	sum,carry = 0;
	col2 = 64;

	do l2 = len2 to 1 by -1;
		ch = substr(remainder,l2,1);
		i = fixed(unspec(ch) & "000001111"b,15,0);
		ci = substr(product(j),col2,1);
		col2 = col2-1;
		k = fixed(unspec(ci) & "000001111"b,15,0);
		sum = i - k - carry;
		carry = 0;
		if sum < 0
		then do;
			sum = sum + 10;
			carry = 1;
		     end;

		unspec(ch) = substr(unspec(sum),28,9) | "000110000"b;
		substr(remainder,l2,1) = ch;
	end;

	do l2 = 1 to 64 while( substr(remainder,l2,1) = "0" );
	end;

	if l2 = 65					/* if remainder = 0 */
	then do;
		i = 64 - scale3;
		if l3 < i then l3 = i;			/* get minimum precision */
		go to divide_finish;
	     end;
	if l3 >= l1
	then do;
divide_finish:
		op1 = (64)"0";
		if float
		then do;
			col1 = 65 - l3;
			len1 = l3;
			scale3 = scale3 - 64 + l3;
		     end;
		else do;
			col1 = scale3 - sc3 + 1;		/* align to scale of answer */
			len1 = min(65-col1,64);
			if col1 < 1 then go to signal_size;
			if col1 >= 65 then go to assign_zero2;
			scale3 = sc3;
		     end;
		substr(op1,col1,len1) = ans;
		ans = op1;
		l3 = col1 - 1;
		go to normalize;
	     end;
	else do;
		remainder = substr(remainder,l2);
		substr(remainder,66-l2,l2-1) = (64)"0";
		l2 = l2 - 1;
		l3 = l3 + 1;
		len2 = len2 - l2;
		len2 = len2 + 1;				/* "bring down next digit" */
		go to divide_estimate;
	     end;

/* At this point, the answer is sitting in "ans". However, it still needs to be normalized,
   if it is floating point, and checked for overflow and underflow. If it is fixed point,
   it is only checked for exceeding the precision of the target (size condition). */

normalize:
	if float
	then do;
		i = max(66-l3-lg3,0);			/* difference in precisions */
		k = 64 - i;

		do j = k to l3+1 by -1 while(substr(ans,j,1) = "0");
		end;
		exp = -scale3;
		if j = l3
		then exp = 127;				/* normalize the zero */
		else do;
			k = 64 - j;
			exp = exp + k;
			col1 = l3 + k;			/* save last column for exp */
			len1 = 64 - l3 - k;
			op1 = (64)"0";
			substr(op1,col1,len1) = substr(ans,l3+1,len1);
			ans = op1;
		     end;

		if exp >= 128
		then do;
			i = 2;				/* overflow */
			go to signal;
		     end;
		if exp < -128
		then do;
			i = 3;				/* underflow */
			signal_ufl = "1"b;
			go to assign_zero;
		     end;
		if exp < 0 then exp = exp + 256;		/* 9 bit to 8 bit */
	     end;
	else
		if lg3 < 65-l3
		then do;
signal_size:		i = 1;				/* size */
			go to signal;
		     end;

/* Section to scale result if requested result scale is different from the one
		normally expected		*/

		else if sc3 < scale3 then
			do;
				col1 = l3 + 1 + scale3 - sc3;
				len1 = 64 - col1;
scale_fixed:			op1 = (64)"0";
				substr(op1,col1,len1) = substr(ans,l3+1,len1);
				ans = op1;
			end;
			else if sc3 > scale3 then
				do;
					col1 = l3 + 1 + scale3 - sc3;
					len1 = 64 - l3 - 1;
					if lg3 >= 64 - col1 then go to scale_fixed;
					go to signal_size;
				end;

assign:
	substr(pop3,1,lg3) = substr(ans,65-lg3,lg3);
	if float
	then do;
		unspec(ch) = substr(unspec(exp),28,9);
		substr(pop3,lg3,1) = ch;
	     end;
	substr(pop3,1,1) = sign;
	if ^signal_ufl then return;

signal:

/* Signal the relevant condition. The default handler will print a message
    indicating that the program is in error (except for underflow), and so
    if he returns, we will, too. (although we could really do anything we
    please!) */

	call plio2_signal_$s_(null,condition(i),"",error_number(i));

	return;

assign_zero:
	ans = (64)"0";

assign_zero2:
	sign = "+";
	exp = 127;
	go to assign;


/* BIG REL BITS SIGNS (definition of "info" bit string)
   -1   <   111  ++
    0   =   011  ++
    1   >   011  ++
   -1   <   100  +-
    0   =   010  +- Zero_op1
    1   >   010  +-
   -1   <   110  -+
    0   =   010  -+ Zero_op2
    1   >   000  -+
   -1   <   101  --
    0   =   001  --
    1   >   001  --

bit(1) = 1 if switch operands to make op1 > op2,
bit(2) = 1 if result is +,
bit(3) = 1 if operation is add. */



/* setdesc follows PL/I rules to calculate the precision and scale of the result
   when this has not been provided by the calling program */

setdesc:	proc;
	if operation = comparison then return;
	if operation > division then return;
	p1 = fixed(substr(desc1,25,12),12);
	p2 = fixed(substr(desc2,25,12),12);
	if float then
	do;
		l0 = max(p1,p2);
	end;
	else
	do;
		scale1 = fixed(substr(desc1,13,12),12);
		if scale1 > 2047 then scale1 = scale1 - 4096;
		scale2 = fixed(substr(desc2,13,12),12);
		if scale2 > 2047 then scale2 = scale2 - 4096;
		go to case(operation);

/* addition|subtraction */

case(1): case(2):	scale3 = max(scale1,scale2);
		l0 = min(63,max(p1-scale1,p2-scale2)+scale3+1);
		go to set_scale;

/* multiplication */

case(3):		l0 = min(63,p1+p2+1);
		scale3 = scale1 + scale2;
		go to set_scale;

/* division */

case(4):		l0 = 63;
		scale3 = 63 - p1 + scale1 - scale2;

set_scale:	if scale3 < 0 then scale3 = scale3 + 4096;
		substr(desc3,13,12) = bit(binary(scale3,12),12);
	end;

	substr(desc3,25,12) = bit(binary(l0,12),12);
	pdesc3 = desc3;
	return;
end;

	end;




		    decimal_sqrt_.pl1               10/24/83  1358.6r w 10/24/83  1332.2       44208



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


decimal_sqrt_:	procedure(presult,prdesc,parg,padesc);

/* procedure to get sqrt(parg) using decimal arithmetic */

dcl	presult char(1) unal,
	prdesc bit(36) aligned,
	parg char(1) unal,
	padesc bit(36) aligned;

dcl	1 adesc aligned,	/* argument descriptor */
		2 flag bit(1) unal,
		2 type bit(6) unal,
		2 packed bit(1) unal,
		2 number_dims bit(4) unal,
		2 scale bit(12) unal,
		2 precision bit(12) unal;

dcl	1 rdesc like adesc aligned;		/* result descriptor (full) */

dcl	desc_fix bit(36) aligned int static init("100100100000000000000000000000000000"b);

dcl	zero char(64)  internal static init("+000000000000000000000000000000000000000000000000000000000000000");
dcl	azero char(1) unal defined(zero);

dcl  (	addition 		init(1),
	subtraction	init(2)) fixed bin(17) int static;

dcl	(exp,scale,length,j,n2move) fixed bin(17);
dcl	aprec	fixed bin(17);	/* precision of argument */
dcl	iprec 	fixed bin(17);	/* precision of i */
dcl	rprec	fixed bin(17);	/* precision of result */
dcl	ip1	fixed bin(17);	/* short precision of i */
dcl	rp1	fixed bin(17);	/* short precision of result */

dcl	ch char(1) aligned;

dcl	(arg,atemp,istring,result) char(64) ;

dcl  (	a defined (arg),
	at defined (atemp),
	i defined (istring),
	r defined (result)) char(1) unal;

dcl	1 idesc like adesc aligned;
dcl	1 idesc1 like adesc aligned;
dcl 	1 rdesc1 like adesc aligned;

dcl  (	ad based(addr(adesc)),
	rd based(addr(rdesc)),
	id based(addr(idesc)),
	rd1 based(addr(rdesc1)),
	id1 based(addr(idesc1))) bit(36) aligned;

dcl  (	one init("+1"),
	two init("+2"),
	nine init("+9")) char(2) ;

dcl  (	c1 defined(one),
	c2 defined(two),
	c9 defined(nine)) char(1) unal;

dcl	cdesc bit(36) aligned int static init("100100100000000000000000000000000001"b);

/* Function definitions */

dcl 	code_ entry(fixed bin);
dcl	decimal_op_ entry(fixed bin,char(1),bit(36) aligned,char(1),bit(36) aligned,
			char(1),bit(36) aligned);

dcl	(addr,bit,divide,fixed,min,mod,substr,unspec) builtin;

/*  */

begin:
	ad = padesc;

/* Set up argument and descriptors */

	aprec = fixed(adesc.precision,12);
	length = aprec + 1;
	if substr(adesc.type,6,1) then
	do;	/* fixed decimal */
		scale = fixed(adesc.scale,12);
		if scale > 2047 then scale = scale - 4096;
		exp = -scale;
		adesc.scale = (12)"0"b;
	end;
	else
	do;	/* float decimal */
		ch = substr(parg,length+1,1);
		exp = fixed(unspec(ch),9);
		if exp >= 128 then exp = exp - 256;
		substr(adesc.type,5,2) = "01"b;
	end;

/* Move decimal point to left end of string */

	exp = exp + aprec;

/* Set up precisions and descriptors */

	rprec = aprec;
	aprec = min(aprec+2,63);
	adesc.precision = bit(fixed(aprec,12),12);
	result, arg = zero;
	rd = desc_fix;
	rdesc.precision = bit(fixed(rprec,12),12);

/* Normalize arg as we move it over */

	do j = 2 to length while (substr(parg,j,1) = "0");
	end;
	n2move = length + 1 - j;
	exp = exp - (j-2);
	if n2move > 0 then substr(arg,2,n2move) = substr(parg,j,n2move);
	else go to return;
	if substr(parg,1,1) = "-" then call code_(22);

/* Finish setting up descriptors */

	length = aprec + 1;
	iprec = aprec;
	id = ad;
	rd1 = rd;
	rdesc1.precision = "000000000001"b;
	rp1 = 1;
	id1 = id;
	idesc1.precision = "000000000010"b;
	ip1 = 2;

/* Initialize istring to +01000...0 */

	istring = zero;
	substr(istring,3,1) = "1";

/* Adjust if exponent is odd */

	if mod(exp,2) ^= 0 then
	do;
		exp = exp + 1;
		idesc1.precision = "000000000001"b;
		ip1 = 1;
		substr(istring,2,2) = "10";
	end;

/* Set exponent */

	exp = divide(exp,2,17,0);

/* Subtract-loop */

sloop:
	call decimal_op_(subtraction,at,ad,a,ad,i,id);
	if at = "+" then
do;
		substr(arg,1,length) = substr(atemp,1,length);
		call decimal_op_(addition,i,id1,i,id1,c2,cdesc);
		call decimal_op_(addition,r,rd1,r,rd1,c1,cdesc);
		go to sloop;
	end;

/* Shift precisions for next round */

	rp1 = rp1 + 1;
	if rp1 <= rprec then
	do;
		ip1 = ip1 + 1;
		idesc1.precision = bit(fixed(ip1,12),12);
		rdesc1.precision = bit(fixed(rp1,12),12);
		call decimal_op_(subtraction,i,id1,i,id1,c9,cdesc);
		iprec = iprec - 1;
		idesc.precision = bit(fixed(iprec,12),12);
		go to sloop;
	end;

	else

/* Return the result */

return:	do;
		exp = exp - rprec;	/* Move decimal point back to right end of string */
		scale = -exp;
		if scale < 0 then scale = scale + 4096;
		rdesc.scale = bit(fixed(scale,12),12);
		call decimal_op_(addition,presult,prdesc,r,rd,azero,rd);
		return;
	end;
end;




		    fixed_ops_.alm                  10/24/83  1358.6r w 10/24/83  1336.4       33048



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

	name	fixed_ops_
	entry	scaler_
	entry	fixed_divide_
	entry	fixed_round_
	entry	float_round_
	entry	size_check_
"
"	scaler_(var fixed bin(71),nbits fixed bin(17),code fixed bin(17))
"
"	(nbits is the amount of shifting to be done)
"
scaler_:	lxl0	ap|4,*	get nbits
	tmi	scale_down
	ldaq	ap|2,*	get var
	lls	0,0	shift the appropriate amount
	tnc	2,ic
	aos	ap|6,*	set code if hi-order bits lost
	staq	ap|2,*	store result back
	short_return
"
scale_down:
	lcq	ap|4,*	amount to shift is -nbits
	eax0	0,ql	"
	ldaq	ap|2,*	get var
	tmi	scale_down_neg
"
	lrs	0,0	shift appropriate amount
	staq	ap|2,*	store result back
	short_return
"
scale_down_neg:
	negl	0	make positive
	lrs	0,0	shift appropriate amount
	negl	0	restore sign
	staq	ap|2,*	store result
	short_return
"
"
"	result fixed bin(71) = fixed_divide_((var1,var2) fixed bin(71),
"				(scale1,scale2,scale3,code) fixed bin(17))
"
	bool	op_vec,551	from assembly of pl1_operators_
	equ	tbp,38		""
	tempd	dtemp(12)		NECESSARY TO SIMULATE PL/I STACK FRAME
fixed_divide_:	
	push
	eppbp	*	save ptr to base of text segment
	spbpbp	sp|tbp
"
	ldq	ap|6,*		calculate scale1 - (scale2 - scale3) for shifting
	sbq	ap|8,*
	adq	ap|10,*
	eax1	0,ql		save in index register for pl1_operators_
"
	ldaq	ap|2,*		load dividend
	eppbp	ap|4,*		point to divisor
	eppbb	ap|14,*		save ptr to result
	eppap	sb|stack_header.pl1_operators_ptr,*
	tsx0	ap|op_vec+402	call divide operator
"
	staq	bb|0		save result
	return
"
"
"	result fixed bin(71) = fixed_round_(var fixed bin(71),nplace fixed bin(17),
"					inscale fixed bin(17))
"
fixed_round_:
"
"	assumption:	inscale > nplace
"
	ldq	ap|6,*	get inscale
	sbq	ap|4,*	get inscale-nplace
	eax0	0,ql	save it
	ldaq	ap|2,*	get the variable
	tmi	round_neg
"
	lrs	-1,0	shift out unnecessary bits
	adl	1,dl	add rounding factor
	lrs	1	truncate
	staq	ap|8,*	store result
	short_return
"
round_neg:
	negl	0	get absolute value
	lrs	-1,0	shift out unnecessary bits
	adl	1,dl	add rounding factor
	lrs	1	truncate
	negl	0	restore sign
	staq	ap|8,*	store result
	short_return
"
"
"	result float bin(63) = float_round_(var float bin(63),nplace fixed bin(17))
"
float_round_:
	lcq	ap|4,*	amount to shift is 70 - nplace
	eax0	70,ql	"
	dfld	ap|2,*	get the variable
	tmi	float_neg
"
	lrs	0,0	shift out unnecessary bits
	adl	1,dl	add in rounding factor
	lrs	1	truncate
	lls	1,0	normalize
	tnc	3,ic	transfer if no carry into sign bit
	ade	1024,du	add one to exponent
	lrl	1	shift aq back one bit
	dfst	ap|6,*	store result
	short_return
"
float_neg:
	fneg	0	get abs(var)
	lrs	0,0	shift out unnecessary bits
	adl	1,dl	add rounding factor
	lrs	1	truncate
	lls	1,0	normalize
	tnc	3,ic	transfer if no carry into sign bit
	ade	1024,du	add one to exponent
	lrl	1	shift aq back one bit
	fneg	0	restore sign
	dfst	ap|6,*	store result
	short_return
"
"
"	code fixed bin(17) = size_check_(var fixed bin(71),length fixed bin(17))
"
size_check_:
	ldq	72,dl	amount to shift is 72 - length.
	sbq	ap|4,*	""
	tze	size_good
"
	eax0	0,ql
	ldaq	ap|2,*	get var
	lls	0,0	shift
	trc	size_bad	if there is a carry, signal size.
"
size_good:
	stz	ap|6,*	code = 0
	short_return
"
size_bad:
	sxl0	ap|6,*	code ^= 0
	short_return
"
	include	stack_header
	end




		    get_onchar.pl1                  10/24/83  1358.6r w 10/24/83  1332.3        5850



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


get_onchar:	proc() returns(char(1)) options(support);

%include on_data_;

	return(substr(ondata_$onsource,ondata_$oncharindex-3,1));

	end;




		    get_oncode.pl1                  10/24/83  1358.6r w 10/24/83  1332.4       19413



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


get_oncode:	proc() returns(fixed bin(35)) options(support);

/* recoded by M. Weaver 1/14/74 for new pl1 signalling discipline */
/* BIM 10/82 to compile again */

dcl  code fixed bin(35);
dcl  err_count fixed bin;
dcl (sp, nsp) ptr;
dcl (addr, null) builtin;
dcl  find_condition_frame_ entry(ptr) returns(ptr);
dcl  find_condition_info_ entry (ptr, ptr, fixed bin(35));

%include pl1_info;
%include condition_info_header;
%include condition_info;
declare 1 CI aligned like condition_info;

/* */
/* There is a valid oncode for each condition.  If the oncode for the most
   recent condition on the stack has been explicitly set in a pl1 info structure
   then we return that value.  Otherwise we return 0. */

	sp, nsp = null;				/* initialize; start with most recent frame */
	err_count = 0;				/* count of error frames */

find_frame:
	nsp = find_condition_frame_ (sp);		/* get ptr to next condition frame */
	if nsp = null then return (0);		/* give up */

	call find_condition_info_ (nsp, addr(CI), code);
						/* get info for most recent condition */
	if code ^= 0 then return (0);			/* give up; can't really find anything */
	if CI.info_ptr ^= null
	then if CI.info_ptr -> pl1_info.id = "pliocond"
	then if CI.info_ptr -> pl1_info.oncode_sw
	then return (CI.info_ptr -> pl1_info.oncode);

/* if error was signalled because of some other condition (i.e. has no info structure)
   return oncode for other condition */

	if CI.condition_name = "error" then if err_count = 0 then do; /* skip first error frame */
	     err_count = 1;
	     sp = nsp;
	     go to find_frame;
	end;

	return (0);				/* no explicit oncode set */

	end get_oncode;




		    getonsource.pl1                 10/24/83  1358.6r w 10/24/83  1332.5       24435



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


getonsource:	proc() returns(char(*)) options(support);

%include on_data_;


	return(ondata_$onsource);

get_onfield:	entry() returns(char(*));

	return(ondata_$datafield);

get_onfile:	entry() returns(char(*));

	return(ondata_$onfile);

get_onkey:	entry() returns(char(*));

	return(ondata_$onkey);

/**/
get_onloc:	entry() returns(char(*));


dcl  i fixed bin;
dcl  segno fixed bin(18);
dcl  code fixed bin(35);

dcl  spno bit(18) aligned;

dcl  ename char(256) aligned;
dcl  lang char(8) aligned;

dcl  nsp ptr;

dcl (baseno, addr, null, index, substr) builtin;
dcl  find_condition_info_ entry(ptr, ptr, fixed bin(35));
dcl  find_condition_frame_ entry(ptr) returns(ptr);
dcl  get_entry_name_ entry(ptr, char(*) aligned, fixed bin(18), char(8) aligned, fixed bin(35));
dcl  error_table_$begin_block fixed bin(35) external;

%include condition_info;
declare 1 CI aligned like condition_info;

%include pl1_info;
%include condition_info_header;

/**/

%include stack_frame;


/**/
/* onloc is valid for all conditions.  This procedure looks for the  stack frame
   belonging to the most recent non-support procedure before the most recent condition
   and returns the entry name associated with the frame */

	sp = find_condition_frame_(null);		/* get ptr to stack frame */
	if sp = null then return ("");

	call find_condition_info_(sp, addr(CI), code);
	if code ^= 0 then return ("");

	nsp = sp;					/* initialize ptr to be used */
	if CI.loc_ptr ^= CI.user_loc_ptr then do;		/* look for non-support frame */
	     spno = baseno (sp);
	     do while (baseno(nsp -> stack_frame.prev_sp) = spno); /* look thru current stack */
		nsp = nsp -> stack_frame.prev_sp;
		if ^nsp -> stack_frame_flags.support then go to get_name; /* found one */
	     end;
	     nsp = sp;				/* can't find non-support; use condition frame */
	end;

get_name:
	call get_entry_name_(nsp -> stack_frame.entry_ptr, ename, segno, lang, code);
	if code ^= 0 then if code = error_table_$begin_block
	     then do;
		nsp = nsp -> stack_frame.prev_sp;
		go to get_name;
	     end;
	     else ename = " ";
	i = index(ename, " ") - 1;			/* need exact length for return */
	if i = -1 then i = 0;

	return (substr(ename, 1, i));

	end;




		    multi_decimal_op_.pl1           10/24/83  1358.6r w 10/24/83  1332.6       18072



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


multi_decimal_op_:
	procedure(poperation,pop3,pdesc3,pop1,pdesc1);

dcl	poperation fixed bin,
	(pop3,pop1)	char(1) unal,
	(pdesc1,pdesc3)	bit(36) aligned;

dcl	cu_$arg_count entry(fixed bin),
	cu_$arg_ptr entry(fixed bin,ptr,fixed bin,fixed bin),
	decimal_op_ entry(fixed bin,char(1) unal, bit(36) aligned,
		char(1) unal, bit(36) aligned, char(1) unal, bit(36) aligned);

dcl	desc bit(36) aligned,
	desc_fix bit(36) aligned static init("100101000000000000000000000000111111"b),
	desc_flt bit(36) aligned static init("100100100000000000000000000000111111"b);

dcl	t char(1) unal defined(t1),
	t1 char(65) unaligned static init((65)"0");

dcl	op2 char(1) unal based(op2_ptr),
	desc2 bit(36) aligned based(desc2_ptr),
	(op2_ptr,desc2_ptr) ptr;

dcl	(code,i,junk,n) fixed bin;

dcl	addition fixed bin static init(1);

dcl	zero char(1) unal defined(z),
	z char(3) unal static init("+0"),
	zero_desc bit(36) aligned static init("100100100000000000000000000000000001"b);

	call cu_$arg_count(n);

	if substr(pdesc3,5,3) = "001"b		/* real fixed dec */
	then desc = desc_fix;
	else desc = desc_flt;

	call cu_$arg_ptr(6,op2_ptr,junk,code);
	call cu_$arg_ptr(7,desc2_ptr,junk,code);

	call decimal_op_(poperation,t,desc,pop1,pdesc1,op2,desc2);

	do i = 8 to n-1 by 2;

		call cu_$arg_ptr(i,op2_ptr,junk,code);
		call cu_$arg_ptr(i+1,desc2_ptr,junk,code);

		call decimal_op_(poperation,t,desc,t,desc,op2,desc2);

	end;

	call decimal_op_(addition,pop3,pdesc3,t,desc,zero,zero_desc);

end multi_decimal_op_;




		    picture_edit_.pl1               10/24/83  1358.6r w 10/24/83  1332.8       12915



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
picture_edit_: proc(picture,target_pt,target_length,source_pt,source_type,source_length);

dcl	picture		char(*) aligned,
	target_pt		ptr,
	target_length	fixed bin,
	source_pt		ptr,
	source_type	fixed bin,
	source_length	fixed bin;

dcl	buff(20) fixed binary,
	temp(128) char(1) unaligned,
	temp_length fixed binary;

dcl	bit1 bit(1) unaligned based;

dcl	picture_info_ entry(char(*) aligned,ptr,fixed bin),
	assign_ entry(ptr,fixed bin,fixed bin,ptr,fixed bin,fixed bin),
	pack_picture_ options(variable);

dcl	map_type(24:28) fixed bin int static
	init(	42,	/* character */
		18,	/* real fixed dec */
		22,	/* cplx fixed dec */
		20,	/* real float dec */
		24	/* cplx float dec */);

dcl	1 info aligned based(addr(buff)) like picture_image;

%include picture_image;

	call picture_info_(picture,addr(buff),target_length);

	if target_length ^= 0 then return;

	temp_length = info.prec + 262144 * (info.scale - info.scalefactor);

	call assign_(addr(temp),map_type(info.type),temp_length,source_pt,source_type,source_length);

	call pack_picture_(target_pt -> bit1,buff,temp);

	target_length = info.varlength;
	end;




		    pl1_after_bit_.pl1              10/24/83  1358.6r w 10/24/83  1333.2        6075



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


pl1_after_bit_:	proc(s,c) returns(bit(*));

/*	Modified:	21 March 1978 by RAB to use after builtin */

dcl	(s,c) bit(*),
	after builtin;

	return(after(s,c));

	end;




		    pl1_after_char_.pl1             10/24/83  1358.6r w 10/24/83  1333.3        6102



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


pl1_after_char_:	proc(s,c) returns(char(*));

/*	Modified:	21 March 1978 by RAB to use after builtin */

dcl	(s,c) char(*),
	after builtin;

	return(after(s,c));

	end;




		    pl1_before_bit_.pl1             10/24/83  1358.6r w 10/24/83  1333.4        6156



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


pl1_before_bit_:	proc(s,c) returns(bit(*));

	/* Modified:	21 March 1978 by RAB to use before builtin */

declare	(s,c) bit(*),
	before builtin;

	return(before(s,c));

	end;




		    pl1_before_char_.pl1            10/24/83  1358.6r w 10/24/83  1333.5        6228



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


pl1_before_char_:	procedure(s,c) returns(char(*));

	/* Modified:	21 March 1978 by RAB to use before builtin */

declare	(s,c) char(*),
	before builtin;

	return(before(s,c));

	end;




		    pl1_date_.pl1                   10/24/83  1358.6r w 10/24/83  1333.7       10692



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


/* This procedure returns a string of form YYMMDD
   where	YY	is current year
   MM	is current month
   DD	is current day	*/

/* Rewritten Paril 1980 by C. Hornig */

pl1_date_:
     procedure returns (char (6));

dcl decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3));

dcl (year, month, day) fixed bin;

dcl 1 date_picture unaligned,
      2 (year, month, day) pic "99";

dcl (clock, string) builtin;

	call decode_clock_value_ (clock (), month, day, year, 0, 0, (""));
	date_picture.year = mod (year, 100);
	date_picture.month = month;
	date_picture.day = day;
	return (string (date_picture));
     end pl1_date_;




		    pl1_decat_bit_.pl1              10/24/83  1358.6r w 10/24/83  1333.8        9945



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


pl1_decat_bit_:	proc(s,c,t) returns(bit(*));

declare	(s,c) bit(*),
	t bit(3),
	(i,l) fixed bin(15),
	(bin,index,length,substr) builtin;

	l = length(c);
	if l=0
	then	if substr(t,3,1)
		 then	goto case(7);
		 else	goto case(0);

	i = index(s,c);
	if i=0
	then	if substr(t,1,1)
		 then	goto case(7);
		 else	goto case(0);

	goto case(bin(t));

case(0):	return(""b);
case(1):	return(substr(s,i+l));
case(2):	return(c);
case(3):	return(substr(s,i));
case(4):	return(substr(s,1,i-1));
case(5):	return(substr(s,1,i-1) || substr(s,i+l));
case(6):	return(substr(s,1,i+l-1));
case(7):	return(s);

	end;




		    pl1_decat_char_.pl1             06/01/84  1543.7r w 06/01/84  1108.3       18648



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

pl1_decat_char_:	proc(s,c,t) returns(char(*));
%page;

/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*							*
*  W A R N I N G	W A R N I N G    W A R N I N G    W A R N I N G	*
*							*
*	T h e   f o l l o w i n g   p r o g r a m   i s	a	*
*	       b c e / M u l t i c s	 p r o g r a m.		*
*							*
*  It must be tested in both bce and the service Multics environment. *
*							*
*  This one source is known as bound_pl1_runtime_::pl1_decat_char_ in	*
*  sss and bound_multics_bce_::pl1_decate_char__b in hardcore.	*
*							*
*  It must be compiled twice, by each of its two names, and tested	*
*  and installed in both libraries by the corresponding name.	*
*							*
*  If problems occur when testing any changes to this program in	*
*  bce, refer to the guidelines for bce within the Initialization	*
*  SDN.							*
*							*
*  W A R N I N G	W A R N I N G    W A R N I N G    W A R N I N G	*
*							*
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
%page;
dcl	(s,c) char(*),
	t bit(3),
	(i,l) fixed bin(15),
	(bin,index,length,substr) builtin;

	l = length(c);
	if l=0
	then	if substr(t,3,1)
		 then	goto case(7);
		 else	goto case(0);

	i = index(s,c);
	if i = 0
	then	if substr(t,1,1)
		 then	goto case(7);
		 else	goto case(0);

	goto case(bin(t));

case(0):	return("");
case(1):	return(substr(s,i+l));
case(2):	return(c);
case(3):	return(substr(s,i));
case(4):	return(substr(s,1,i-1));
case(5):	return(substr(s,1,i-1) || substr(s,i+l));
case(6):	return(substr(s,1,i+l-1));
case(7):	return(s);

	end;




		    pl1_snap_.pl1                   10/24/83  1358.6r w 10/24/83  1334.2       47142



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


pl1_snap_: proc(conname);


		/* This procedure is invoked by the standard system default handler when a quit occurs */

/* Last Modified: (Date and reason):
	15 July 1977 by SHW to correctly reestablish the standard attachments, use iox_ entries
	     and to change snap routine from debug to probe.
          10/82 BIM to compile for 10.1 
*/


dcl	conname char(32);
dcl	absin_seg char(168) aligned;

dcl	null builtin;

dcl	code fixed bin(35);


dcl	ioa_ entry options(variable),
	user_info_$absin entry(char(*) aligned),
	(probe, trace_stack) entry(),
	iox_$modes entry(ptr,char(*),char(*),fixed bin(35)),
	iox_$attach_iocb entry(ptr,char(*),fixed bin(35)),
	iox_$control entry(ptr,char(*),ptr,fixed bin(35)),
	iox_$close entry (ptr,fixed bin (35)),
	iox_$detach_iocb entry (ptr,fixed bin (35));
/*  */

dcl  default_inhibits (3) int static bit (36) aligned init (
     "0"b,
     "0"b,
     "0"b
     );
dcl 1 old_info (3) aligned,
						/* first structure of information is for user_input;
						   the second is for user_output;
						   the third is for error_output */
    2 device ptr,
    2 mode bit (36) aligned;
dcl (new_uio_mode, old_uio_mode) char (256);

dcl  i fixed bin,
     iox_code fixed bin (35);

dcl  iocbp (4) ptr init (	 iox_$user_input,
			 iox_$user_output,
			 iox_$error_output,
			 iox_$user_io)	pointer;	/* MUST be automatic for this init to work */	

dcl iocbp_names(4) char(12) aligned int static options(constant) init(
	"user_input",
	"user_output",
	"error_output",
	"user_i/o"	);

dcl iox_$user_io ext static ptr;
dcl iox_$user_input ext static ptr;
dcl iox_$user_output ext static ptr;
dcl iox_$error_output ext static ptr;
						/*  */
%include iocbx;




		/* This entry is invoked by signal_ to implement pl1 snap */
		/* i/o code is stolen from get_to_cl_ */



		/* Save attachments of user_input, user_output and error_output, and restore them
		   to the standard attachments */
	call save_io_;

		/* find out whether we are interactive or absentee */
	call user_info_$absin(absin_seg);
	if absin_seg = " " then do;		/* no absin seg; interactive */
	     call iox_$control(iox_$user_io, "resetread", null, code);	/* throw away any read ahead data */
	     call ioa_("PL/I snap for condition ^a; you are entering probe", conname);
	     call probe();
	end;
	else do;					/* we are in absentee */
	     call ioa_("PL/I snap for condition ^a; trace_stack is being called", conname);
	     call trace_stack();
	end;
	
		/* If control returns here, a "start" command has been typed.
		   The first thing we must do is restart any previously stopped io.  Then
		   we must restore the attachments of user_input, user_output and error_output to
		   what they were at the time of the quit or unclaimed signal. */
	call iox_$control(iox_$user_io, "start", null, code);
	call restore_io_;
	
		/* Return to procedure being "started" */
	return;
/*  */
/* Internal procedure to save attachments of user_input, user_output and error_output
   and restore them to the standard attachment. It is
   called after a quit or unclaimed signal */


save_io_:	proc;





/* save attachments */
	     do i = 1 to 3;
		if iocbp (i) -> iocb.actual_iocb_ptr = iocbp (i) then /* not a syn */
		     do;
		     old_info (i).device = iocbp (4);	/* ptr to iocb for user_i/o */
		     old_info (i).mode = default_inhibits (i); /* store default inhibits */
		end;
		else do;				/* it was syn */
		     old_info (i).device = iocbp (i) -> iocb.syn_father;
		     old_info (i).mode = iocbp (i) -> iocb.syn_inhibits; /* copy mode */
		end;
	     end;

/* restore user_input, user_output, and error_output to standard attachments */
	     do i = 1 to 3;
		if iocbp (i) -> iocb.actual_iocb_ptr = iocbp (i) then
		     call iox_$close (iocbp (i), iox_code);
		call iox_$detach_iocb (iocbp (i), iox_code);
		call iox_$attach_iocb(iocbp(i),"syn_ user_i/o", iox_code);
	     end;
	     old_uio_mode = " ";			/* init */
	     new_uio_mode = "default.";
	     call iox_$modes (iox_$user_io, new_uio_mode, old_uio_mode, iox_code);
	     call iox_$control (iox_$user_io, "printer_on", null, iox_code);

	     return;
	end save_io_;

/*  */

/* Internal procedure which restores user_input, error_output and user output to the values
   they had at the time of a quit or unclaimed signal. It is meant
   to be called in conjunction with save_io_ */

restore_io_: proc;


/* Restore attachments */
	     do i = 1 to 3;
		call iox_$detach_iocb (iocbp (i), iox_code);
		call iox_$attach_iocb(iocbp(i),"syn_ "||iocbp_names(i), iox_code);
	     end;


/* Restore mode of user_i/o to what it was at time of quit */
	     call iox_$modes (iox_$user_io, old_uio_mode, new_uio_mode, iox_code);

	     return;

	end restore_io_;

end;




		    pl1_time_.pl1                   10/24/83  1358.6r w 10/24/83  1334.3       12474



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


/* This procedure returns a string of the form HHMMSSFFFFFF
   where	HH	is hours
   MM	is minutes
   SS	is seconds
   FFFFFF	is microseconds */

/* Rewritten April 1980 by C. Hornig */

pl1_time_:
     procedure returns (char (12));

dcl decode_clock_value_$time
         entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), char (3), fixed bin (35));

dcl (hour, minute, second) fixed bin;
dcl microsecond fixed bin (71);
dcl code fixed bin (35);

dcl 1 time_picture unaligned,
      2 (hour, minute, second) pic "99",
      2 microsecond pic "999999";

dcl (clock, string) builtin;

	call decode_clock_value_$time (clock (), hour, minute, second, microsecond, (""), code);
	time_picture.hour = hour;
	time_picture.minute = minute;
	time_picture.second = second;
	time_picture.microsecond = microsecond;
	return (string (time_picture));
     end pl1_time_;




		    setonsource.pl1                 10/24/83  1358.6r w 10/24/83  1334.4       22788



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
setonsource:	proc(str) options(support);

/* recoded by M. Weaver 1/14/74 for new pl1 signalling discipline */

dcl  str char(256) var;

dcl  type fixed bin;

dcl (addr, null, substr) builtin;
dcl  pl1_signal_$help_plio2_signal_ entry(char(*), ptr, fixed bin(35), char(256) var, fixed bin);

%include on_data_;

%include condition_info;
declare 1 CI aligned like condition_info;

%include pl1_info;
%include condition_info_header;

/**/
/* This procedure must change the onsource string in both the old ondata_
   segment and in the relevant structure.
   If there is no relevant structure to change, the calling procedure is in error */

	type = 1;					/* indicate onsource */
	if find_struc() then do;			/* true if relevant struc()ture found */
	     ondata_$onsource = str;			/* set in old way */
	     pl1_info.onsource = str;			/* set in new way */
	     return;
	end;

sig_err:					/* no relevant structure found */
	call pl1_signal_$help_plio2_signal_("error", null, 170, "", 0);
	return;


set_onchar:	entry(ch);

dcl  ch char(1);

	type = 2;					/* indicate onchar */
	if find_struc() then do;
	     substr(ondata_$onsource, ondata_$oncharindex-3, 1) = ch;
	     substr(pl1_info.onsource, pl1_info.oncharindex, 1) = ch;
	     return;
	end;

	go to sig_err;

/**/
find_struc:	proc() returns(bit(1) aligned);

/* internal procedure to find  the info structure associated with the
   most recent condition to set onsource/onchar */

dcl  code fixed bin(35);
dcl (nsp, sp) ptr;
dcl find_condition_frame_ entry(ptr) returns(ptr);
dcl find_condition_info_ entry(ptr, ptr, fixed bin(35));

	nsp, sp = null;
next_frame:
	nsp = find_condition_frame_(sp);		/* look for the next condition frame */
	if nsp = null then return("0"b);		/* can't even find frame */
	call find_condition_info_(nsp, addr(CI), code);
	if code ^= 0 then return("0"b);		/* something must be wrong; stop here */

	pl1_info_ptr = CI.info_ptr;
	if pl1_info_ptr ^= null
	then if pl1_info.id = "pliocond" then do;	/* have a pl1 structure */
	     if type = 1 then if pl1_info.onsource_sw then return("1"b);
	     if type = 2 then if pl1_info.onchar_sw then return("1"b);
	end;

	sp = nsp;
	go to next_frame;				/* look for next */

	end;

	end;




		    translate_.alm                  10/24/83  1358.6r w 10/24/83  1336.5       39528



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

" Procedure to implement PL/1 translate builtin function
"
"
" The PL/1 statement
"	R = translate(S,T);
" is compiled as
"	call trans_2_(R,Rdesc,S,Sdesc,T,Tdesc);
" where Rdesc, Sdesc, Tdesc are Version II descriptors, but the call is non-standard.
"
" The PL/1 statement
"	R = translate(S,T,C);
" is compiled as
"	call trans_3_(R,Rdesc,S,Sdesc,T,Tdesc,C,Cdesc);
" where all args are as above
"
	name	translate_
	entry	trans_2_
	entry	trans_3_

	bool	varying,010000
	equ	r_arg,2
	equ	r_desc,4
	equ	s_arg,6
	equ	s_desc,8
	equ	t_arg,10
	equ	t_desc,12
	equ	c_arg,14
	equ	c_desc,16

	temp	s_length,t_length,t_offset,c_length,c_mask,long
	temp	count,temp
	tempd	s_pt,c_pt

trans_2_:
	push
	stz	long		this is short form

join:	epp2	ap|s_arg,*	get ptr to s
	lda	ap|s_desc,*	get desc(s)
	cana	varying,du	is it varying?
	tze	2,ic		no
	lda	bp|-1		yes, get current length
	ana	=o77777777	mask to 24 bits
	neg	0		and save - length
	tze	done		return if zero length input
	sta	s_length
	spri2	s_pt		save ptr to s
	lda	ap|s_arg+1	extract bit offset of s
	ars	9
	ana	=o77,dl
	eax2	0,al		and save in x2

	epp2	ap|t_arg,*	get ptr to t
	lda	ap|t_desc,*	get desc(t)
	cana	varying,du	is it varying
	tze	2,ic		no
	lda	bp|-1		yes, get current length
	ana	=o77777777	mask to 24 bits
	sta	t_length
	ldq	ap|t_arg+1	get bit offset of t
	qrs	9
	anq	=o77,dl
	div	9,dl		convert to char offset
	stq	t_offset		and save

	epp4	ap|r_arg,*	get ptr to r
	ldq	ap|r_arg+1	extract bit offset of r
	qrs	9
	anq	=o77,dl
	div	9,dl		convert to char offset
	eax3	0,al		and save in x3

	epp0	s_pt,*		get ptr to s

loop:	ldq	ap|0		get current character of s
	lls	9,2		into al
	ana	=o177,dl

	szn	long		is this long form?
	tze	check		no, use current char as index

	sta	temp		yes, must do index(c), so form
	als	9		word containing current character
	ora	temp		in each character position
	sta	temp
	als	18
	ora	temp		now have CCCC in a register

	lcq	c_length		init loop
	stq	count
	ldq	c_mask		get initial mask
	eax4	0

index:	cmk	c_pt,*4		check character
	tze	succ		zero means we found it

	aos	count		update counter
	tze	use_same		use this character if index failed

	qlr	27		shift mask right 9 bits
	tmi	index		and repeat if not done with word

	adx4	1,du		update for next word
	tra	index		and continue search

use_same:
	ana	=o177000,du	use input character
	tra	use_ch

succ:	lda	count		compute position in c
	ada	c_length

check:	cmpa	t_length		should we select char from t
	tpl	use_bl		no, use blank
	ada	t_offset		add char offset of t
	lrs	2		form word and char offset
	qrl	16
	lda	bp|0,al		get replacement char
	lls	shift,qu*
	tra	2,ic		and join common section

use_bl:	lda	=o040000,du

use_ch:
	arl	shift,3*		shift character to position for r
	xec	stba,3		store new character

	aos	s_length		bump length counter
	tze	done		zero means we're done

	adx2	9,du		update bit offset of s
	cmpx2	36,du		do we need another word
	tmi	3,ic		no
	epp0	ap|1		yes, update ptr
	eax2	0		and reset count

	adx3	1,du		update char offset of r
	cmpx3	4,du		do we need another word
	tmi	loop		no, repeat loop
	epp4	lp|1		yes, update ptr
	eax3	0		reset shift
	tra	loop		and then loop

done:	return

"	this entry is called with another argument specifying a string
"	to be searched.
"
trans_3_:
	push
	stc1	long		is this is the long case

	epp2	ap|c_arg,*	get ptr to c
	spri2	c_pt		save
	ldq	ap|c_arg+1	get char offset of c
	qrs	9
	anq	=o7,dl		only legal char offsets are 11,22,33,0 bits
	ldq	index_mask,ql	get initial mask for index operation
	stq	c_mask		and save
	lda	ap|c_desc,*	get desc(c)
	cana	varying,du	is it varying
	tze	2,ic		no
	lda	bp|-1		yes, get current length
	ana	=o77777777	mask to 24 bits
	sta	c_length		save length of c
	tra	join		join common section

shift:	dec	0b17,9b17,18b17,27b17

stba:	stba	lp|0,40
	stba	lp|0,20
	stba	lp|0,10
	stba	lp|0,04

index_mask:
	oct	000777777777
	oct	777000777777
	oct	777777000777
	oct	777777777000

	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