



		    apl_monadic_.pl1                11/29/83  1638.6r w 11/29/83  1346.8      956511



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

/* All scalar monadic and dyadic operators are implemented in this module,
   including reduction, outer and inner product, and scan.

	Created by G. Gordon Benedict on 06/23/73
	Modified on 740508 by PG to fix bug in 0!0
	Modified on 740614 by PG and GGB to fix bug in 10*^3 (was wrong data type)
	Modified on 741115 by PG to fix logarithm to check for errors properly,
		and fix (and, or, nand, nor) to work with vectors.
	Modified 750331 by PG to fix inner product to call do_many subroutine properly
		for each operator.
	Modified 750714 by PG to fix residue to use special apl_floor_ operator.
	Modified 760901 by PG to get 0*0 to work, to make trig operator validate left arg in
		all cases, and to fix = and /= of chars not to overlay the operands.
	Modified 760902 by PG to redo handling of data types so that all results are numeric except
		when reduction or scan just drops a dimension. Bug fixed that caused result of operating
		on null vectors when one arg is numeric and the other character to have no type bits.
	Modified 780210 by PG to use apl_push_stack_ (bug 278), and to fix 310
		(scanning with a non-commutative operator overlayed result on input operand and clobbered it).
	Modified 780303 by PG to fix bug 189 by making 0-:0 be 1, and to signal a zerodivide domain error
		if the divisor is equal to zero.
	Modified 780510 by William York to fix bug 322 by un-special-casing scalar operands to the scan
		operator that are on the value stack.
	Modified 781011 by WMY to fix bugs 311, 338, and 341.
	Modified 781101 by PG to fix bug 348 (reducing dimensions of unity extent fails),
		which was introduced 781011 when bug 338 was fixed.
	Modified 790122 by PG to use apl_error_table_$invalid_circular_fcn.
	Modified 790124 by PG to fix bug 360 (or-scan and and-scan of Booleans fail) and 359 (+/'' is not
		double-word aligned).
	Modified 790326 by PG to add monadic not equal, and to call apl_display_bead_.
	Modified 790618 by PG to fix 327 (binomial coefficients fails for negative args).
	Modified 790713 by PG to fix 407 (1-,'A' worked because type of operand
		was tested after overlayed result type was set!)
	Modified 790717 by PG for sugg 405 to change computation of the gamma
		function to use a more accurate algorithm.
	Modified 790727 by PG to put divide-reduction back into assembly language subroutine.
	Modified 800131 by BIM and PG to use new apl_monadic_not_appendage_ alm procedure.
	Modified 800302 by BIM to use new apl_dyadic_bool_appendage_ alm procedure.
	Modified 820429 by JRG to allow 50 choose 0 (0 ! 50). Used to give domain errors.
*/

apl_monadic_:
     procedure (operators_argument);		/* procedure to handle monadic type operators */

/* automatic */

declare
	copy_up_needed bit (1) aligned,	/* ON if a stack operand could not be overlayed */
	left_chars bit (1) aligned,		/* ON if left opnd is character */
	right_chars bit (1) aligned,		/* ON if right opnd is character */
	swapped_flag bit (1) aligned;		/* ON if order of operands was exchanged */

dcl	(
	copy_rho_vb,			/* ptr to value bead to take rho from for result */
	right_vb,				/* pointer to value bead for operand to right of operator */
	right_array,			/* ptr to right operand itself (data ptr from right v.b.) */
	left_vb,				/* ptr to v.b. to left of operator */
	left_array,			/* ptr to left operand */
	result_vb,			/* ptr to result v.b. */
	result_array			/* where result array will be stored */
			) pointer aligned;

dcl	(
	subscript,
	right_data_elements,		/* number of elements in right array */
	left_data_elements,			/* number of elements in left array */
	plane_base,			/* used in reduction; base of plane in operand array */
	column_base,			/* base of column in reduction currently being reduced */
	interval_between_elements,		/* interval between elements in same column being reduced */
	column_skip_interval,		/* how many times column_base is to be incremented by 1 before plane_base is */
	highest_column_element,		/* subscript into right operand array of highest subscript element in
					   column referenced during reduction -- first referenced */
	column_skip_interval_minus_1,		/* just to save subtracting 1 in a loop */
	rho_sub_dimension,			/* the extent of that dimension (copied for efficiency) */
	last_column_on_this_plane,		/* in reduction, last column base address + 1 */
	data_elements			/* used to tell stack_allocate_known how many elements are needed */
			) fixed binary precision (21);

declare	(data_words_needed,			/* to tell stack_allocate_known how many words needed */
	number_to_copy,			/* number of words in word_copy_overlay for copying */
	words_needed,			/* words needed to get from value stack. set by stack_allocate_known */
	words_needed_in_bead		/* words needed in value bead to be allocated. */
			) fixed binary precision (19);	/* for word counts */

dcl	(left_rhorho,			/* no of dimensions of left operand */
	dimension,			/* the dimension to reduce along (for reduction) */
	right_rhorho,			/* same for right */
	rhorho,				/* used to tell stack_allocate_known how much space needed in value bead */
	rho_subscript,			/* steps thru rho arrays, and as a temp in monadic */
	trig_integer,			/* integer which is left arg to circle functions */
	dyadic_action_place,		/* for dyadic routines */
	many_action_place,			/* which complicated operation to do (log, exp, binomial coefficients, etc.) */
	special_case,			/* added to many_action_place to get label - either 0 or 1 */
	action_place,			/* label array subscript identifying action routine in subroutines */
	op1				/* copy of operator code */
			) fixed binary;

dcl	(single_element_fl_1,		/* used to hold one arg if it is a scalar and the other an array */
	single_element_fl_2,		/* used if both operands are scalars (holds right element) */
	fuzz,				/* copy of fuzz in ws_info for efficiency */
	integer_fuzz,			/* copy of integer_fuzz */
	float_temp,			/* temporary for float -> integer conversions */
	boolean_both,			/* set to 1 for and/nand 0 for or/nor */
	set_on_equal,			/* used in char compare; what result is set to on equal compare */
	dyadic_set_on_equal,		/* value of set_on_equal for dyadic operations */
	dyadic_set_on_not_equal,		/* value of set_on_not_equal for dyadic operations */
	dyadic_boolean_both,		/* value of boolean_both for dyadic operations */
	dyadic_boolean_neither,		/* value of boolean_neither for dyadic operations */
	reduction_set_on_equal,		/* value of set_on_equal for reduction operations */
	reduction_set_on_not_equal,		/* value of set_on_not_equal for reduction operations */
	reduction_boolean_both,		/* value of boolean_both for reduction operations */
	reduction_boolean_neither,		/* value of boolean_neither for reduction operations */
	result_accumulator) float;		/* steps 1 by 1 to fill in iota array */

declare	1 reduction_type aligned like general_bead.type;	/* so reduction knows what type of operand it's getting */
declare	1 free_type aligned like general_bead.type;
declare	1 save_free_type aligned like general_bead.type;

/* entries */

declare	apl_display_bead_ entry (ptr, bit (1) aligned),
	apl_monadic_not_appendage_ entry (ptr, fixed bin (21), ptr, fixed bin),
          apl_monadic_not_appendage_$in_place entry (ptr, fixed bin (21)),
	(apl_dyadic_bool_appendage_$and,
           apl_dyadic_bool_appendage_$nand,
	 apl_dyadic_bool_appendage_$or,
	 apl_dyadic_bool_appendage_$nor,
	 apl_dyadic_bool_appendage_$eq,
	 apl_dyadic_bool_appendage_$neq)
	      entry (ptr, ptr, ptr, fixed bin (21)),
	apl_reduction_appendage_ entry (pointer, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, float bin (63)),
	apl_reduction_appendage_$divide entry (pointer, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, float bin (63),
	     label);

/* external static */

declare	(apl_error_table_$compatibility_error,
	apl_error_table_$display_disabled,
	apl_error_table_$domain,
	apl_error_table_$invalid_circular_fcn,
	apl_error_table_$length,
	apl_error_table_$no_identity,
	apl_error_table_$rank,
	apl_error_table_$zerodivide) fixed bin (35) external static;

/* builtins */

declare	(abs, addr, addrel, binary, ceil, complex, divide, exp, fixed, floor, imag, log,
	max, min, mod, real, rel, sign, substr, size, string, unspec) builtin;

/* based */

dcl	unal_fl_bit_ovly bit (72) aligned based;	/* for copying either a char on a word boundary
						or a floating pt number, without knowing which */
dcl	word_copy_overlay based dimension (number_to_copy) fixed bin (35);	/* for aggregate array copies */

/* internal static */

dcl	pi static internal float init		/* a bit string rendering of pi */
	( .110010010000111111011010101000100010000101101000110000100011010e+2b);

declare	booleans (11 : 14) static internal float initial
		(1, 0, 1, 0);

dcl	identity (0 : 20) float static internal init	/* identity for this operator */
		((2) 0, (2) 1,
		- .1701411834604692317e+39,
		.1701411834604692317e+39,
		1, (2) 0, 1, 0, 1,
		(2) 0, 1, 0,  (3) 1, (2) 0);

dcl	1 operator_info (0:20) static internal aligned,	/* gives info about operators */
	  2 identity_type bit (18) unal init	/* the type of the identity -- an error if ""b (no ident for this op) */
		((4)("001000000011100000"b),(2)("001000000010000000"b), (1) ("001000000011100000"b), (1) (""b),
		(2)("001000000011100000"b), (1) (""b),(2)("001000000011100000"b),(2)(""b),(6)("001000000011100000"b)),
	  2 eq_or_not_eq bit (1) unal init ((17) ("0"b), "1"b, (2) ("0"b), "1"b),
	  2 padding bit (17) unal;

dcl	(scalar init (0),			/* when added to 4 * op1 gives label subscript for routine to handle it */
	vector init (1),			/* similarly when added this is for vector routines */
	scalar_vector init (2),		/* for scalar on left, vector on right */
	vector_scalar init (3),		/* for vector on left, scalar on right */
	char_compare init (-4))		/* when subtracted from 1 of the above values gives subscript into
					   label array in dyadic_operate subr. of char comparison routines */
		static internal fixed bin;

/* include files */

%include apl_number_data;
%include apl_operators_argument;
%include apl_bead_format;
%include apl_value_bead;
%include apl_ws_info;
%include apl_operator_codes;

/* procedure to handle monadic operators. first copy info from argument structure for efficiency */

	call monadic_extract ();
	go to monadic_common;

/* this entry is called only for monadic not. it is not with the other monadic operators because it cannot be
   use dyadically (thus cannot participate in reduction, inner product, etc). Therefore its operator code
   is not contiguous with the others, making the monadic_do label array hard to use. In order to use common code,
   since monadic not otherwise acts like all the other monadic operators, it is given an operator code contiguous
   to the others (16) solely for use within this program */

apl_monadic_not_:
	entry (operators_argument);

	call monadic_extract ();
	op1 = 16;				/* assign dummy operation code */

monadic_common:
	rhorho = right_rhorho;			/* will want result to conform with arg operand */
	data_elements = right_data_elements;

	if operators_argument.operands (2).on_stack then do;	/* can overlay result on operand completely */
	     operators_argument.result,		/* parse wants address of result too */
	     result_vb = right_vb;			/* overlay result v.b. on operand v.b. */
	     result_array = right_array;		/* and result array on operand array */
	end;
	else do;					/* not such good luck, operand not on stack */
	     if right_chars
	     then call stack_allocate_char ();
	     else call stack_allocate_numeric ();

	     if right_vb -> value_bead.rhorho > 0
	     then result_vb -> value_bead.rho (*) = right_vb -> value_bead.rho (*);

	     string (result_vb -> value_bead.header.type) = string (free_type);
	end;

	if right_data_elements = 0			/* nothing to do */
	then if (op1 ^= equal_code) & (op1 ^= not_equal_code) /* unless debugging operators */
	     then return;

/* note all monadic operators must not have a character operand -- check this */

	if right_chars
	then if (op1 ^= equal_code) & (op1 ^= not_equal_code) /* let debugging operators thru */
	     then go to domain_error_right;

	goto monadic_do (op1);			/* go to action code for this operator */

/* Here begins the actual monadic operator action routines */

monadic_do (0):					/* PLUS. just return */
	if operators_argument.operands (2).on_stack then return;	/* with same thing as called with */
	result_array -> numeric_datum =
	     right_array -> numeric_datum;		/* copy data because operand was not on the stack */
	return;

monadic_do (1):					/* MINUS. negate each element of argument */
	result_vb -> value_bead.header.type.zero_or_one_value = "0"b;	/* probably will not make just 0s or 1s */

	result_array -> numeric_datum = - right_array -> numeric_datum;
	return;

monadic_do (2):					/* SIGNUM. 0 if 0, -1 if <0, 1 if >0 */
	result_vb -> value_bead.header.type.integral_value = "1"b;

	do subscript = 0 by 1 while (subscript < data_elements);
	     if abs (right_array -> numeric_datum (subscript)) < integer_fuzz then
		result_array -> numeric_datum (subscript) = 0;	/* equal to zero within integer_fuzz */
	     else if  right_array -> numeric_datum (subscript) < 0 then	/* negative, set result element to -1 */
		result_array -> numeric_datum (subscript) = -1;
		else result_array -> numeric_datum (subscript) = 1;
	end;
	return;

monadic_do (3):					/* INVERT. invert each element of arg operand */
	string (result_vb -> value_bead.header.type) = numeric_value_type;
	do subscript = 0 by 1 while (subscript < data_elements);
	     if right_array -> numeric_datum (subscript) = 0e0
	     then go to zerodivide_error_right;
	     else result_array -> numeric_datum (subscript) = 1e0 / right_array -> numeric_datum (subscript);
	end;
	return;

	/* N.B. For both ceiling and floor, if the input argument is
	   within "integer fuzz" of its integer value, the result
	   is this integer value.  Otherwise, the result is the value
	   of the respective function. */

monadic_do (4):					/* CEILING. smallest integer greater than arg. */
	string (result_vb -> value_bead.header.type) = integral_value_type;
 	do subscript = 0 by 1 while (subscript < data_elements);
	     single_element_fl_1 = right_array -> numeric_datum (subscript);
	     result_accumulator = floor (single_element_fl_1 + .5e0);

	     if abs (result_accumulator - single_element_fl_1) >= integer_fuzz
	     then result_accumulator = ceil (single_element_fl_1);

	     result_array -> numeric_datum (subscript) = result_accumulator;
	end;
	return;

monadic_do (5):					/* FLOOR. greatest integer smaller than arg. */
	string (result_vb -> value_bead.header.type) = integral_value_type;
 	do subscript = 0 by 1 while (subscript < data_elements);
	     single_element_fl_1 = right_array -> numeric_datum (subscript);
	     result_accumulator = apl_floor_ (single_element_fl_1);
	     result_array -> numeric_datum (subscript) = result_accumulator;
	end;
	return;


monadic_do (6):					/* EXPONENTIATION. raise to e'th power */
	string (result_vb -> value_bead.header.type) = numeric_value_type;
 	do subscript = 0 by 1 while (subscript < data_elements);

	      result_array -> numeric_datum (subscript) =		/* exponentiate it */
		exp (right_array -> numeric_datum (subscript));
	end;
	return;

monadic_do (7):					/* BASE E LOGARITHM. */
	string (result_vb -> value_bead.header.type) = numeric_value_type;
 	do subscript = 0 by 1 while (subscript < data_elements);
	     if right_array -> numeric_datum (subscript) < integer_fuzz then
		goto domain_error;
	     result_array -> numeric_datum (subscript) =
		log (right_array -> numeric_datum (subscript));
	end;
	return;

monadic_do (8):					/* ABSOLUTE VALUE. */
	if right_vb -> value_bead.zero_or_one_value
	then go to monadic_do (0);			/* treat like monadic plus */

	result_array -> numeric_datum =
	     abs (right_array -> numeric_datum);
	return;

monadic_do (9):					/* FACTORIAL. */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		gamma (right_array -> numeric_datum (subscript) + 1e0);
	end;
	return;

monadic_do (10):					/* PI TIMES. */
	string (result_vb -> value_bead.header.type) = numeric_value_type;
	result_array -> numeric_datum =
	     pi * right_array -> numeric_datum;
	return;

monadic_do (16):					/* MONADIC NOT. */
	if right_vb -> value_bead.header.type.zero_or_one_value then do;	/* known is 0 or 1, optimize */
	     if operators_argument.operands (2).on_stack
	     then call apl_monadic_not_appendage_$in_place (right_array, right_data_elements);
	     else call apl_monadic_not_appendage_ (right_array, right_data_elements, result_array, rho_subscript);

/* The following statement is the old PL/I code that the above subroutine calls replaced.
   It is retained here to make it easy to revert the ALM version.

	     result_array -> numeric_datum (*) = 1 - right_array -> numeric_datum (*); */

	     return;
	end;

	string (result_vb -> value_bead.header.type) = zero_or_one_value_type;

 	do subscript = 0 by 1 while (subscript < data_elements);
	     if abs (right_array -> numeric_datum (subscript)) < integer_fuzz then	/* = 0, return 1 */
		result_array -> numeric_datum (subscript) = 1;	/* set to 1 */
	     else
		if abs (right_array -> numeric_datum (subscript) - 1) < integer_fuzz then	/* = 1, return 0 */
		     result_array -> numeric_datum (subscript) = 0;	/* set to 0 */
		else goto domain_error;	/* monadic not must have either 0 or 1 */
	end;
	return;

monadic_do (17):					/* MONADIC EQUAL. (display long) */
monadic_do (20):					/* MONADIC NOT EQUAL. (display brief) */
	if ^ws_info.debug_mode			/* Don't let random users trip over this...got to know the secret */
	then go to display_disabled;

	call apl_display_bead_ (right_vb, (op1 = not_equal_code));	/* brief if op is not equal */

	if ^operators_argument.operands (2).on_stack
	then result_array -> numeric_datum (*) = right_array -> numeric_datum (*);

	return;

/* The following entry point handles all dyadic operators */

apl_dyadic_:
	entry (operators_argument);

	call dyadic_extract ();
	call dyadic_result_lowest ();		/* point result_vb at operand lowest in stack */

/* check conformity of operands. either one (or both) must be effective scalars, i.e., have only
   one element, or they must have the same number of dimensions (rank error if not true) and each dimension
   must have the same length (length error if not) */

	if left_data_elements ^= 1 then do;		/* left is not scalar; check right */     
	     data_elements = left_data_elements;	/* since left is not scalar, result must be equal to it in size */

	     if right_data_elements ^= 1 then do;
		if left_rhorho ^= right_rhorho then goto rank_error;	/* loses */
		do subscript = 0 by 1 while (subscript < left_rhorho);	/* make sure each element of rho vectors are equal */
		     if left_vb -> value_bead.rho (subscript + 1) ^= right_vb -> value_bead.rho (subscript + 1) then
			goto length_error;			/* same no of dims but bounds don't match */
		end;
		dyadic_action_place = vector;		/* routine for vectors (or scalars) as both operands */
	     end;
	     else do;
		unspec (single_element_fl_1) = right_array -> unal_fl_bit_ovly;
		right_array = left_array;		/* reverse order of arrays; action routines use right_array as
						  operand pointers when one arg is scalar */
		swapped_flag = "1"b;		/* indicate swap for error handlers */
		dyadic_action_place = vector_scalar;	/* action routine for left vector, right scalar */
	     end;
copy_left:
	     rhorho = left_rhorho;			/* use dimensionality of left operand */
	     copy_rho_vb = left_vb;			/* .. */
	end;
	else do;					/* left scalar, right vector */
	     data_elements = right_data_elements;	/* since left is scalar, result has length of right */
	     if right_data_elements = 1 then do;	/* both scalar */
		dyadic_action_place = scalar;		/* action routine if both are scalars */
		unspec (single_element_fl_2) = right_array -> unal_fl_bit_ovly;	/* copy right scalar */
		unspec (single_element_fl_1) = left_array -> unal_fl_bit_ovly;	/* copy left scalar */
		if left_rhorho > right_rhorho then
		     goto copy_left;			/* both have 1 element, but use left rhorho */
	     end;
	     else do;			/* right is not scalar */
		dyadic_action_place = scalar_vector;		/* scalar on left, vector on right */
		unspec (single_element_fl_1) = left_array -> unal_fl_bit_ovly;	/* copy left scalar */
	     end;
	     rhorho = right_rhorho;
	     copy_rho_vb = right_vb;
	end;

	call stack_allocate_numeric ();

	if copy_rho_vb -> value_bead.rhorho > 0
	then result_vb -> value_bead.rho (*) = copy_rho_vb -> value_bead.rho (*);

	call fill_type ();			/* fill type field of result operand */

	if data_elements = 0 then return;		/* both operands null, return null vector */

	dyadic_set_on_equal = set_on_equal;
	dyadic_set_on_not_equal = 1 - set_on_equal;

	dyadic_boolean_both = boolean_both;
	dyadic_boolean_neither = 1 - boolean_both;

	if left_chars | right_chars
	then do;
		if ^ operator_info (op1).eq_or_not_eq then do;	/* only = and /= can take chars */
		     if left_chars then
			goto domain_error_left;
		     goto domain_error_right;
		end;
		if left_chars ^= right_chars
		then do;				/* chars on one side, numbers on other */
		     result_array -> numeric_datum = dyadic_set_on_not_equal;	/* 1s if /=, 0s if = */
		     return;
		end;
		dyadic_action_place = dyadic_action_place +
		     char_compare;	/* transform to label subscript of char compares in dyadic subr. */
	     end;
	else dyadic_action_place = dyadic_action_place + (4 * op1);	/* transform to correct label subscript */

	call dyadic_operate ();

	if copy_up_needed
	then go to copy_up_stack;

	return;

apl_reduction_:
	entry (operators_argument);

	call monadic_extract ();

/* Scalars need special treatment. */

	if right_rhorho = 0
	then do;
		if dimension > 1
		then go to rank_error;

		if operators_argument.operands (2).on_stack	/* try to special-case scalars on the stack */
		then do;
			operators_argument.result = right_vb;	/* still protected; just return it */
			return;
		     end;

		rhorho = 0;
		rho_sub_dimension = 1;
	     end;
	else do;
		rhorho = right_rhorho - 1;
		if dimension > right_rhorho then goto rank_error;	/* dimension is out of bounds */
		rho_sub_dimension = right_vb -> value_bead.rho (dimension);	/* the dimension which is to be deleted */
	     end;

 	call monadic_result_lowest ();		/* try to overlay result on right operand */
	string (reduction_type) = string (free_type);	/* copy type field so reduction subroutine knows type */

/* Check for null operands here. */

	if right_data_elements = 0 then do;	/* operand was null, return either identities or null array */
	     if rho_sub_dimension = 0 then do;	/* dropping null dimension; find out how many elements in result */
		data_elements = 1;	/* multiply all other dimensions except one to be dropped */
		do rho_subscript = 0 to dimension - 2, dimension by 1 while (rho_subscript < right_rhorho);
		     data_elements = data_elements * right_vb -> value_bead.rho (rho_subscript + 1);
		end;
	     end;
	     else			/* not dropping null dimension */
		data_elements = divide (right_data_elements, rho_sub_dimension, 21, 0);	/* drop a dimension */

	     call stack_allocate_numeric ();	/* get a value bead plus data_elements number of identities */
	     call fill_rho ();		/* fill rho vector from operand, leaving out rho (dimension) */
identity_fill:			/* inner product comes to here if inner dim is 0 */
	     string (result_vb -> value_bead.header.type) =
		operator_info (op1).identity_type;	/* assign result value bead correct type */
	     if data_elements = 0 then return;	/* return a null vector */
	     if operator_info (op1).identity_type = "0"b then
		goto no_identity_error;		/* this operator cannot operate on a null vector */
	     result_array -> numeric_datum = identity (op1);	/* assign identity */
	     return;

	end;

/* Check for scalars and dimensions of unity extent here. */

	if rho_sub_dimension = 1 then do;	/* just return operand with this rho dropped out */
	     data_elements = right_data_elements;	/* as many elements as in operand */
	     if right_chars then
		call stack_allocate_char ();
	     else				/* numeric type */
		call stack_allocate_numeric ();

	     call fill_rho ();		/* fill rho vector from operand, leaving out rho (dimension) */

	     /* Recover proper data type...free_type is never character, but right operand might have been. */

	     string (result_vb -> value_bead.type) = string (right_vb -> value_bead.type);
	     number_to_copy = data_words_needed;	/* copy data */
	     if number_to_copy > 0 then		/* avoid zero length array (illegal PL/I) */
		result_array -> word_copy_overlay =	/* copy arrays word by word */
		     right_array -> word_copy_overlay;
	     return;
	end;

/* Not a strange case. Calculate how many elements there will be in result by dividing number in operand
   by length of dimension to be reduced */

	data_elements = divide (right_data_elements, rho_sub_dimension, 21, 0);

/* calculate various intervals in operand array */

	interval_between_elements = 1;		/* the interval between elements within a column
						   being reduced is the product of all dimensions after the
						   one being reduced */
	do rho_subscript = dimension by 1 while (rho_subscript < right_rhorho);	/* multiply them */
	     interval_between_elements = interval_between_elements *
		right_vb -> value_bead.rho (rho_subscript + 1);
	end;

	column_skip_interval = interval_between_elements * rho_sub_dimension;
	column_skip_interval_minus_1 = column_skip_interval - interval_between_elements -
		interval_between_elements;	/* to save subtracting in loop */

	call stack_allocate_numeric ();
	call fill_rho ();
	call fill_type ();				/* subroutine to copy type field with exceptions */

/* if operator is = or /=, can take chars */

/* if operand is character type, must special case it */

	if right_chars
	then do;
	     if  ^ operator_info (op1).eq_or_not_eq then
		goto domain_error_right;			/* only = and /= can take chars */
	     if rho_sub_dimension > 2 then do;	/* can optimize heavily */
		result_array -> numeric_datum = 1 - set_on_equal;	/* = always returns 0 for more than 2
						chars, /= always returns 1 */
		return;
	     end;     

/* must be just 2 chars in dimension to reduce; 1 or 0 were special-cased before */     

	     element_size = 1;			/* one char per element */
	     action_place = -1;			 /* label subscript in reduction_operate routine for chars */
	end;     
	else				 /* not character, numeric */
	     element_size = NumberSize;	/* that many chars per number (for assignments with variable length) */

	reduction_set_on_equal = set_on_equal;
	reduction_set_on_not_equal = 1 - set_on_equal;

	reduction_boolean_both = boolean_both;
	reduction_boolean_neither = 1 - boolean_both;

/* Perform the reduction */

	subscript = 0;		/* initialize to first result element */
	do plane_base = 0 repeat (plane_base + column_skip_interval) while (plane_base < right_data_elements);
	     last_column_on_this_plane = plane_base + interval_between_elements;
	     do column_base = plane_base by 1 while (column_base < last_column_on_this_plane);

		highest_column_element = column_base + column_skip_interval_minus_1;
		addr (result_accumulator) -> char_string_overlay =
		     substr (right_array -> character_string_overlay, (highest_column_element +
		     interval_between_elements) * element_size + 1, element_size);
		call reduction_operate ();		/* reduce one column of this vector or array */

		result_array -> numeric_datum (subscript) = result_accumulator;
		subscript = subscript + 1;
	     end;
	end;
	if copy_up_needed
	then go to copy_up_stack;

	return;

/* the following module implements the outer product construct in APL.  This consists of applying the
   basic operator (in op1) to each pair of elements in the left and right arguments. Thus the total number
   of elements in the result equals the product of the numbers in the operands, the rho vector is the
   concatenation of the operand rho vectors, and the dimensionality (rank) is the sum of the operand ranks.
   The operation is performed by stepping thru each element of the left vector and storing it in the variable
   single_element_fl_1. The dyadic scalar_vector routine is then called */

apl_outer_product_:
	entry (operators_argument);

	call dyadic_extract ();			/* copy info from operands */
	data_elements = right_data_elements * left_data_elements;	/* result size = prod of operand sizes */
	rhorho = right_rhorho + left_rhorho;		/* result rhorho is sum of operand rhorho's */
						/* cannot overlay result on operands */
	call stack_allocate_numeric ();		/* get a result operand bead and value space */
	call fill_type ();			/* fill in result type, set other goodies */
	dyadic_set_on_equal = set_on_equal;
	dyadic_set_on_not_equal = 1 - set_on_equal;

	dyadic_boolean_both = boolean_both;
	dyadic_boolean_neither = 1 - boolean_both;

	dyadic_action_place = 4 * op1 + scalar_vector;		/* to which label to transfer in dyadic_operate */

/* now fill the rho vector of result. this will be the left rho vector concatenated
   with the right rho vector */

	number_to_copy = left_rhorho;	/* copy left rhorho */
	if number_to_copy > 0 then		/* avoid zero length array (illegal PL/I) */
	     addr (result_vb -> value_bead.rho (1)) -> word_copy_overlay =
		addr (left_vb -> value_bead.rho (1)) -> word_copy_overlay;

	number_to_copy = right_rhorho;	/* copy right rho after left rho */
	if number_to_copy > 0 then		/* avoid zero length array (illegal PL/I) */
	     addr (result_vb -> value_bead.rho (left_rhorho + 1)) -> word_copy_overlay =
		addr (right_vb -> value_bead.rho (1)) -> word_copy_overlay;

	if data_words_needed = 0 then		/* null operands */
	     goto copy_up_stack;		/* copy up stack */

	if left_chars | right_chars
	then do;
		if ^ operator_info (op1).eq_or_not_eq then do;	/* only = and /= can take chars */
		     if left_chars then
			goto domain_error_left;
		     goto domain_error_right;
		end;
		if left_chars ^= right_chars
		then do;				/* chars on one side, numbers on other */
			result_array -> numeric_datum = dyadic_set_on_not_equal;	/* 1s if /=, 0s if = */
			goto copy_up_stack;		/* copy result up stack */
		     end;
		dyadic_action_place =
		     scalar_vector + char_compare;	/* subscript of char scalar-vector compare in dyadic_operate */
		element_size = 1;	/* one char per element */
	end;
	else do;					/* not character, numeric */
	     element_size = NumberSize;	/* that many chars per number, for variable length assignments */
	     left_data_elements = left_data_elements * NumberSize;
	end;

	data_elements = right_data_elements;	/* use right for inner loop */
	do column_base = 0 repeat (column_base + element_size)
	     while (column_base < left_data_elements);	/* step thru left array */
		addr (single_element_fl_1) -> char_string_overlay =	/* extract a left element */
		     substr (left_array -> character_string_overlay, column_base + 1, element_size);
		call dyadic_operate ();		/* perform a scalar/ vector operation */
		result_array = addr (result_array -> numeric_datum (data_elements));	/* move to next result vector */
	end;
	goto copy_up_stack;			/* copy words up stack into operands */
/* This module implements the APL inner product construct.  The general algorithm is to copy into a
   temporary a row of the right array, then apply each row of the left array using a dyadic op1 operation.
   The result vector of this is then reduced, using op2 */

apl_inner_product_:
	entry (operators_argument);

dcl	(ip_subscript,			/* just another subscript, for inner product's use */
	left_total_chars,			/* total number of chars in left operand...for my kludgy overlays */
	right_move_count,			/* number of elements in each row of right operand */
	right_count,			/* number of rows on right */
	left_count,			/* number of rows on left */
	op2) fixed bin (21);		/* 2nd operator (user typed op2.op1) */

dcl	element_size fixed bin (4);		/* used in char string overlay hack */

dcl	(actual_left_array,			/* saves left array for recopying in loops */
	actual_right_array,			/* same for right array */
	actual_result_array,		/* same for result */
	temp_right_array,			/* points to temp right array, used for dyadic routines */
	recover_right_array,		/* this points at which pointer right_array should be loaded with */
	recover_single_element) ptr;		/* this points at which pointer points at the element single_element_fl_1 gets */

dcl	based_pointer ptr based;		/* used as dummy for recover_ pointers to point at */

dcl	char_string_overlay char (element_size) based unal;	/* can process either double-words or chars */

	call dyadic_extract ();			/* copy info from operands. */
						/* cannot overlay result on operands */
	column_base,		/* lower subscript bound used by reduction */
	rhorho = 0;			/* start off with 0 result rhorho */
	interval_between_elements,			/* reduction will always get contiguous arrays */
	right_count = 1;

	do rho_subscript = 2 by 1 while (rho_subscript <= right_rhorho);	/* same for right but drop 1st dim */
	     right_count = right_count *
		right_vb -> value_bead.rho (rho_subscript);
	     rhorho = rhorho + 1;		/* rhorho of result is sum of rhorho's of operands, minus dropped dimension */
	end;

	data_elements = right_count;		/* now multiply by same for left operand, giving result size */

	do rho_subscript = 1 by 1 while (rho_subscript < left_rhorho);
	     data_elements = data_elements *
		left_vb -> value_bead.rho (rho_subscript);	/* mpy all dimensions but last */
	     rhorho = rhorho + 1;		/* for each dim, add 1 to result dims */
	end;
	data_words_needed = size (numeric_datum);	/* words for stack_allocate_known and copy_up_stack */

/* check conformity of operands. The conformity rules for inner product are as follows: A scalar
   operand conforms to any other operand. A left operand with an inner (i.e., last) dimension of 1 conforms with
   any right operand. A right operand with an inner (i.e., first) dimension of 1 conforms with any left operand.
   Otherwise, the two inner dimensions must be the same.  There is no constraint on the rank of the operans */

	if left_data_elements ^= 1 then		/* not effective scalar */
	     left_count = left_vb -> value_bead.rho (left_rhorho);	/* number of elements in a left row */
	else
	     left_count = left_data_elements;	/* set to 1 because it is a scalar */

	if right_data_elements = 1 then		/* scalar */
	     right_move_count = right_data_elements;	/* set to 1, a scalar */
	else
	     right_move_count = right_vb -> value_bead.rho (1);	/* inner dimension of right operand */

/* now test conformity */

	if right_move_count ^= 1 then do;		/* neither an effective scalar, nor is inner dim 1 */
	     rho_sub_dimension = right_move_count;	/* take number of elements dyadic will process from right */
	     recover_right_array = addr (temp_right_array);	/* we will want right array to point here */
	     recover_single_element = addr (left_array);	/* single element will come from left */

	     if left_count ^= 1 then do;		/* also not scalar nor inner dim 1 */

		if left_count ^= right_move_count then	/* inner dims must agree if not 1 or scalar */
		     goto length_error;

		dyadic_action_place = vector;		/* since both inner dims are not 1 */
	     end;
	     else				/* left inner = 1 (or is a scalar), right vector */
		dyadic_action_place = scalar_vector;	/* left scalar, right vector */
	end;

	else do;					/* right is scalar or inner dim = 1 */
	     rho_sub_dimension = left_count;		/* left operand dominates, as right is scalar or inner dim 1 */
	     dyadic_action_place = vector_scalar;
	     recover_right_array = addr (left_array);	/* point right array at left in loop */
	     recover_single_element = addr (temp_right_array);	/* take scalar from right */
	     swapped_flag = "1"b;
	end;

	if rho_sub_dimension = 0 then do;	/* a null vector, return identities */
	     op1 = op2;				/* return identity of left operator */
	     call dyadic_result_lowest ();		/* put result_vb lowest on stack */
	end;
	else do;		/* test if a character operand */
		if left_chars | right_chars
		then do;
		     if ^ operator_info (op1).eq_or_not_eq then do;	/* only = and /= can take chars */
			if left_chars then
			     goto domain_error_left;
			goto domain_error_right;
		     end;
		     if left_chars & right_chars
		     then do;
			element_size = 1;		/* for certain overlay hacks */
			dyadic_action_place = dyadic_action_place + char_compare;
			if right_rhorho = 1 then	/* right is also vector, result will be scalar */
			     if op1 = equal_code then	/* for special case op2 must be and */
				if op2 = and_code then goto inner_product_compare_strings;
				else;
			     else			/* is not_equal_code, op2 must be or */
				if op2 = or_code then do; 	/* is or.not_equals */

inner_product_compare_strings:
				     call stack_allocate_numeric ();	/* get storage */
				     string (result_vb -> value_bead.header.type) = zero_or_one_value_type;
				     dyadic_set_on_equal = identity (op1);

				     dyadic_set_on_not_equal = 1 - dyadic_set_on_equal;
				     subscript = 0;
				     do ip_subscript = 0 repeat (ip_subscript + right_data_elements)
					while (ip_subscript < left_data_elements);

					if substr (left_array -> character_string_overlay, ip_subscript + 1, right_data_elements) =
					     substr (right_array -> character_string_overlay, 1, right_data_elements) then
					     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
					else
					     result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;

					subscript = subscript + 1;	/* next result element */
				     end;
			     /* now copy rho vector into result array value bead */
			     
				     subscript,
				     number_to_copy = max (left_rhorho - 1, 0);	/* if negative or 0, no rho elements to copy */
				     if number_to_copy > 0 then		/* copy, > 0 */
					addr (result_vb -> value_bead.rho) -> word_copy_overlay =
					     addr (left_vb -> value_bead.rho) -> word_copy_overlay;
				     number_to_copy = right_rhorho - 1;	/* if negative or 0, no rho elements to copy */
				     if number_to_copy > 0 then		/* copy, > 0 */
					addr (result_vb -> value_bead.rho (subscript + 1)) -> word_copy_overlay =
					     addr (right_vb -> value_bead.rho (2)) -> word_copy_overlay;
				     goto copy_up_stack;


				end;
		     end;

		     data_words_needed =
			data_words_needed + divide (right_move_count + 3, 4, 21, 0);
	     end;
	     else do;			/* not chars, set counts and flags appropriately */
		data_words_needed =		/* for temporary result array */
		     (size (result_accumulator) * right_move_count) + data_words_needed;
		dyadic_action_place = dyadic_action_place + (4 * op1);	/* add in operator to label subscript */
		element_size = NumberSize;
	     end;
	     data_words_needed = data_words_needed +	/* add more for temporaries needed */
		(size (result_accumulator) * rho_sub_dimension);	/* temporary result array */
	end;

	call stack_allocate_known ();		/* get storage for result and temps */

/* insert correct type into result */

	call fill_type ();		/* insert type after dyadic operator */
	dyadic_set_on_equal = set_on_equal;
	dyadic_set_on_not_equal = 1 - set_on_equal;

	dyadic_boolean_both = boolean_both;
	dyadic_boolean_neither = 1 - boolean_both;

	string (save_free_type) = string (free_type);
	string (reduction_type),		/* set for reduction to be type going into reduction */
	     string (free_type) =
	     string (result_vb -> value_bead.type);	/* copy out for next operator */
	action_place = op2;
	call fill_type ();
	string (free_type) = string (save_free_type);
	reduction_set_on_equal = set_on_equal;
	reduction_set_on_not_equal = 1 - set_on_equal;

	reduction_boolean_both = boolean_both;
	reduction_boolean_neither = 1 - boolean_both;

/* now copy rho vector into result array value bead */

	subscript,
	number_to_copy = max (left_rhorho - 1, 0);	/* if negative or 0, no rho elements to copy */
	if number_to_copy > 0 then		/* copy, > 0 */
	     addr (result_vb -> value_bead.rho) -> word_copy_overlay =
		addr (left_vb -> value_bead.rho) -> word_copy_overlay;

	number_to_copy = right_rhorho - 1;	/* if negative or 0, no rho elements to copy */
	if number_to_copy > 0 then		/* copy, > 0 */
	     addr (result_vb -> value_bead.rho (subscript + 1)) -> word_copy_overlay =
		addr (right_vb -> value_bead.rho (2)) -> word_copy_overlay;

	if rho_sub_dimension = 0 then			/* null array, return identities */
	     goto identity_fill;			/* same place reduction returns identities */

/* save ptrs to the operands and to the temporaries I have allocated on the stack because the dyadic and reduction
   routines expect these ptrs to be loaded with various things that will force them to be smashed */

	actual_result_array = result_array;		/* ptr to block allocated */
	result_array = addr (actual_result_array ->
	     numeric_datum (data_elements));	/* ptr to first temp block after; where dyadic will store result */

	data_elements = rho_sub_dimension;		/* so dyadic knows how much to do */
	temp_right_array = addr (result_array -> numeric_datum (data_elements));	/* ptr to 2nd temp block; where right row is built */
	actual_left_array = left_array;
	actual_right_array = right_array;

	highest_column_element = rho_sub_dimension - 2;	/* subtract 2 because reduction starts at next to last element */
	column_skip_interval = right_count * element_size;	/* offsets between right rows in characters */
	left_count = left_count * element_size;		/* length of a left row in characters */
	left_total_chars = left_data_elements * element_size;	/* total size of left array in characters */
	right_move_count = right_move_count * element_size;

/* Now comes the main loop */

	do plane_base = 0 by 1 while (plane_base < right_count);
	     subscript = plane_base * element_size;	/* copy an entire (not-contiguous, generally) right row */
	     do ip_subscript = 0 repeat (ip_subscript + element_size)
		while (ip_subscript < right_move_count);	/* into temp right array */

		     addr (temp_right_array -> character_data_structure.character_datum (ip_subscript))
   			-> char_string_overlay  =	/* copy an element */
		     addr (actual_right_array -> character_data_structure.character_datum (subscript))
			-> char_string_overlay;

		subscript = subscript + column_skip_interval;		/* offset to next element in right operand */
	     end;

	     ip_subscript = plane_base;		/* go thru each row of left, dyadicing it with temp right */

	     do subscript = 0 repeat (subscript + left_count) while (subscript < left_total_chars);

		left_array =
		     addr (actual_left_array -> character_data_structure.character_datum (subscript));	/* a left row */
		right_array =		/* point right_array at vector argument (if both vector, right one) */
		     recover_right_array -> based_pointer;
		addr (single_element_fl_1) -> char_string_overlay =	/* copy a scalar */
		     recover_single_element -> based_pointer -> char_string_overlay;

		call dyadic_operate ();		/* do dyadic operator */

		right_array = result_array;	/* now reduce result by op2 returned by dyadic */
		result_accumulator = result_array ->
		     numeric_datum (highest_column_element + 1);	/* initialize first reduction result */

		call reduction_operate ();

		actual_result_array -> numeric_datum (ip_subscript) =
		     result_accumulator;		/* put away result */
		ip_subscript = ip_subscript + right_count;	/* an element further on */
	     end;
	end;


	data_words_needed = size (result_accumulator) *
	     result_vb -> value_bead.total_data_elements;
	goto copy_up_stack;

/* The following module implements the scan construct in apl.  This is
   essentially a repeated application of reduction to its operand.  Thus result (1)
   = operand (1), result (2) = operand (1) <op> operand (2), etc.  Note that as
   usual in this losing language the reductions are applied right to left and thus except
   for commutative operators (such as plus, times, or, and, max, min) the result of scan
   is not the intermediate results from a reduction. Scan returns a result conforming with
   operand */

apl_scan_operator_:
	entry (operators_argument);

declare	actual_highest_column_element fixed binary precision (21, 0);	/* last element in column to reduce */
declare	flip_flag bit (1) aligned;	/* indicates whether processing even or odd element */

	call monadic_extract ();		/* pull information from right (and only) operand */

	if op1 <= min_code			/* plus thru min are commutative, and so it is */
	then call monadic_result_lowest ();	/* OK to overlay result completely on operand */
	else copy_up_needed = operators_argument.operands (2).on_stack;

	string (reduction_type) = string (free_type);	/* extract type to here for reduction_operate's sake */

/* result will conform with operand  -- make result that large and of those dimensions */

	rhorho = right_rhorho;		/* result has same number of dimensions as operand */
	data_elements = right_data_elements;	/* and same array elements */

	if data_elements = 0 then		/* null operand, return it */
	     goto return_right_scan;

	if rhorho = 0 then			/* scalar, return it */
	     goto return_right_scan;

	rho_sub_dimension = right_vb -> value_bead.rho (dimension);
	if rho_sub_dimension = 1 then do;	/* dimension to scan is 1, return operand */
return_right_scan:
	     if right_chars
	     then call stack_allocate_char ();
	     else call stack_allocate_numeric ();

	     if right_vb -> value_bead.rhorho > 0
	     then result_vb -> value_bead.rho (*) = right_vb -> value_bead.rho (*);

	     number_to_copy = data_words_needed;	/* copy data */
	     if number_to_copy > 0 then
		result_array -> word_copy_overlay =
		     right_array -> word_copy_overlay;

	     /* Recover proper data type...free_type is never character, but right operand might have been. */

	     string (result_vb -> value_bead.type) = string (right_vb -> value_bead.type);
	     return;			/* have made copy of operand, return it */
	end;

	if right_chars
	then go to domain_error_right;		/* can't scan character data */

/* get an array and bead of numeric type but conforming with operand */

	call stack_allocate_numeric ();	/* numeric type */
	call fill_type ();

	reduction_boolean_both = boolean_both;
	reduction_boolean_neither = 1 - boolean_both;

	reduction_set_on_equal = set_on_equal;
	reduction_set_on_not_equal = 1 - set_on_equal;

	if right_vb -> value_bead.rhorho > 0
	then result_vb -> value_bead.rho (*) = right_vb -> value_bead.rho (*);

/* calculate various intervals in operand array */

	interval_between_elements = 1;		/* the interval between elements within a column
						   being reduced is the product of all dimensions after the
						   one being reduced */
	do rho_subscript = dimension by 1 while (rho_subscript < right_rhorho);	/* multiply them */
	     interval_between_elements = interval_between_elements *
		right_vb -> value_bead.rho (rho_subscript + 1);
	end;

	column_skip_interval = interval_between_elements * rho_sub_dimension;
	column_skip_interval_minus_1 = column_skip_interval - interval_between_elements;

/* go thru actual scan loop now. note similarity to reduction */

	do  plane_base = 0 repeat (plane_base + column_skip_interval)
	     while (plane_base < right_data_elements);

	     last_column_on_this_plane = plane_base + interval_between_elements;

	     do column_base = plane_base by 1 while (column_base < last_column_on_this_plane);

		actual_highest_column_element = column_base + column_skip_interval_minus_1;

		result_accumulator,		/* set this so can be referenced as previous element */
		result_array -> numeric_datum (column_base) =	/* set first element of result to be first of operand */
		     right_array -> numeric_datum (column_base);

		goto scan_do (action_place);		/* perform actual operation */

scan_do (0):					/* scan plus */
		do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements)
		     while (subscript <= actual_highest_column_element);

			result_accumulator,
			result_array -> numeric_datum (subscript) =
			     right_array -> numeric_datum (subscript) +	/* add operand element */
			     result_accumulator;	/* to previous result */
		end;
		goto next_scan;

scan_do (1):					/* scan minus */
		flip_flag = "0"b;			/* indicate on even one */
		do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements)
		     while (subscript <= actual_highest_column_element);

			if flip_flag then
			     result_accumulator,
			     result_array -> numeric_datum (subscript) =
				right_array -> numeric_datum (subscript) +
				result_accumulator;

			else			/* even, subtract */
			     result_accumulator,
			     result_array -> numeric_datum (subscript) =
				result_accumulator -
				right_array -> numeric_datum (subscript);
			flip_flag = ^ flip_flag;		/* so reverse operation for next time */
		end;
		goto next_scan;

scan_do (2):					/* scan multiply */
		do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements)
		     while (subscript <= actual_highest_column_element);

			result_accumulator,
			result_array -> numeric_datum (subscript) =
			     right_array -> numeric_datum (subscript) *	/* multiply operand element */
			     result_accumulator;	/* to previous result */
		end;
		goto next_scan;

scan_do (3):					/* scan divide */
		flip_flag = "0"b;			/* indicate on even one */
		do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements)
		     while (subscript <= actual_highest_column_element);

			if flip_flag
			then result_accumulator = right_array -> numeric_datum (subscript) * result_accumulator;
			else			/* even, divide */
			     if right_array -> numeric_datum (subscript) = 0e0 /* divisor = 0? */
			     then if result_accumulator = 0e0 /* dividend = 0? */
				then result_accumulator = 1e0;
				else go to zerodivide_error_right;
			     else result_accumulator = result_accumulator / right_array -> numeric_datum (subscript);
			result_array -> numeric_datum (subscript) = result_accumulator;
			flip_flag = ^ flip_flag;		/* so reverse operation for next time */
		end;
		goto next_scan;

scan_do (4):			/* scan max */
		do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements)
		     while (subscript <= actual_highest_column_element);

			result_accumulator,
			result_array -> numeric_datum (subscript) =
			     max (right_array -> numeric_datum (subscript),	/* max operand element */
			     result_accumulator);	/* to previous result */
		end;
		goto next_scan;

scan_do (5):			/* scan min */
		do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements)
		     while (subscript <= actual_highest_column_element);

			result_accumulator,
			result_array -> numeric_datum (subscript) =
			     min (right_array -> numeric_datum (subscript),	/* min operand element */
			     result_accumulator);	/* to previous result */
		end;
		goto next_scan;

/* ones for all other operators follow. Will just call reduction repeatedly */

scan_do (6):	/* power */
scan_do (7):	/* log */
scan_do (8):	/* residue */
scan_do (9):	/* factorial */
scan_do (10):	/* circle */
scan_do (11):	/* and */
scan_do (12):	/* or */
scan_do (13):	/* nand */
scan_do (14):	/* nor */
scan_do (15):	/* < */
scan_do (16):	/* <_ */
scan_do (17):	/* /= */
scan_do (18):	/* >_ */
scan_do (19):	/* > */
scan_do (20):	/* = */
		do highest_column_element = column_base repeat (highest_column_element + interval_between_elements)
		     while (highest_column_element < actual_highest_column_element);

			result_accumulator = right_array -> numeric_datum
			     (highest_column_element + interval_between_elements);

			call reduction_operate ();

			result_array -> numeric_datum
			     (highest_column_element + interval_between_elements) =
			     result_accumulator;
		end;

next_scan:
	     end;
	end;
	if copy_up_needed
	then go to copy_up_stack;

	return;

/* procedure to copy garbage up stack. assumes variable words_needed_in_bead contains number of words
   in bead, data_words_needed contains words in data */

copy_up_stack:		/* not really a subroutine, just gone to */
	if ^ operators_argument.operands (2).on_stack then do;	/* right is not on stack */
	     if ^ operators_argument.operands (1).on_stack then do;	/* left is not on stack */
		operators_argument.result = result_vb;	/* leave answer where it is */
		return;
	     end;
	     right_vb = left_vb;		/* left is on stack and right is not -- overlay on left operand */
	end;
	if binary (rel (right_vb), 18, 0) + words_needed > ws_info.maximum_value_stack_size then do;
	     operators_argument.result = result_vb;		/* result will be where it is */
	     return;
	end;

/* the following kludges are used to copy the result operand lowest in the stack. Kludgy code using overlays
   and unspecs will be used until such time as the PL/I compiler can generate structure assignments
   without moving one bit at a time.  Note that previous code has set the right_vb ptr to point to the operand
   lowest in the stack; thus it may not still be pointing at the right value bead. */

/* now find the next doubleword boundary on which to put the result data. Note that if decimal data is
   someday used, alignment will not be necessary; in that case both the bead and data can be copied in one move */

	number_to_copy = words_needed_in_bead;	/* the words in the bead for the result, from stack_allocate */
	right_vb -> word_copy_overlay =	/* copy words from bead to end bead */
	     result_vb -> word_copy_overlay;
	right_array = addrel (right_vb, words_needed_in_bead);	/* try next word after bead */
	if substr (rel (right_array), 18, 1) then	/* if a 1 in low order bit, odd aligned */
	     right_array = addrel (right_array, 1);
	right_vb -> value_bead.data_pointer = right_array;	/* pointer to data */
	number_to_copy = data_words_needed;			/* number of data words to move */
	if number_to_copy > 0 then				/* zero length arrays are illegal PL/I */
	     right_array -> word_copy_overlay =		/* move in data */
		result_vb -> value_bead.data_pointer -> word_copy_overlay;
	result_array = addr (result_vb -> value_bead.rho (rhorho + 1));	/* word after value bead */
	ws_info.value_stack_ptr = addrel (right_array, data_words_needed);
	operators_argument.result = right_vb;
	return;

/* places to go to when an error is found */

compatibility_error_left:
	operators_argument.error_code = apl_error_table_$compatibility_error;
	operators_argument.where_error = operators_argument.where_error + 1;
	return;

display_disabled:					/* CONTEXT ERROR in brief mode */
	operators_argument.error_code = apl_error_table_$display_disabled;
	return;

domain_error_left_maybe:
	if swapped_flag then
	     goto domain_error_right;
	goto domain_error_left;

domain_error_right_maybe:
	if swapped_flag then
	     goto domain_error_left;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 2;

domain_error_left:
	operators_argument.where_error = operators_argument.where_error + 1;

domain_error:
	operators_argument.error_code = apl_error_table_$domain;
	return;

invalid_circular_fcn_left:				/* DOMAIN ERROR in brief mode */
	operators_argument.where_error = operators_argument.where_error + 1;
	operators_argument.error_code = apl_error_table_$invalid_circular_fcn;
	return;

length_error:
	operators_argument.error_code = apl_error_table_$length;
	return;

no_identity_error:					/* DOMAIN ERROR in brief mode */
	operators_argument.error_code = apl_error_table_$no_identity;
	return;

rank_error:
	operators_argument.error_code = apl_error_table_$rank;
	return;

zerodivide_error_right:				/* DOMAIN ERROR in brief mode */
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$zerodivide;
	return;

/* The following subroutine is used to allocate a result value bead and a result array on the value stack.
   The rhorho of the result v.b. is given in variable rhorho, and the number of data elements in the result array
   is given in data_elements.  It sets result_vb to point to allocated value_bead and result_array to point to the
   array.  All fields in the value bead are filled in except value_bead.header.type and value_bead.rho.
   The bead is allocated on such a boundary that the next word after it (the first word of the result array) is
   doubleword aligned. */

stack_allocate_numeric:
	procedure ();

/* automatic */

declare	numeric bit (1) aligned;

/* program */

	data_words_needed = size (numeric_datum);	/* get result length from data_elements */
	numeric = "1"b;
	goto stack_allocate_known_common;		/* common code */

stack_allocate_char:				/* entry to assume thing to alloc is char */
	entry ();

	data_words_needed = size (character_string_overlay);	/* no. of chars */
	numeric = "0"b;
	go to stack_allocate_known_common;

stack_allocate_known:
	entry ();					/* caller has set data_words_needed */

	numeric = "1"b;

stack_allocate_known_common:				/* to transfer from above */
	number_of_dimensions = rhorho;
	words_needed_in_bead = size (value_bead);
	words_needed = words_needed_in_bead + data_words_needed + 1;	/* addition of 1 to doubleword align */
	result_vb = apl_push_stack_ (words_needed);
	result_array = addr (result_vb -> value_bead.rho (rhorho + 1));	/* word after value bead */
	if numeric
	then if substr (rel (result_array), 18, 1)
	     then result_array = addrel (result_array, 1);	/* if next word is odd-aligned, bump by 1 word */

	result_vb -> value_bead.total_data_elements = data_elements;
	result_vb -> value_bead.rhorho = rhorho;		/* make result conform with original operand */
	result_vb -> value_bead.data_pointer = result_array;	/* pointer to actual array */
	operators_argument.result = result_vb;		/* let parse know where I put result when I return */

end stack_allocate_numeric;

%include apl_push_stack_fcn;

/* The folowing subroutine is used to return a type field for a given scalar dyadic function. The variable op1
   must contain the operator code. The variable free_type must contain the AND of the types the operands */

fill_type:
	procedure ();

	goto get_type (action_place);		/* goto label array */

/* the following ones return the same type as the AND of the operands */

get_type (8):				/* residue */
	if ws_info.compatibility_check_mode then	/* check for negative left arg */
	     special_case = 1;		/* will cause do_many subroutine to check */

get_type (2):				/* multiply */
get_type (4):				/* max */
get_type (5):				/* min */
get_type (9):				/* binomial coefficients */
	string (result_vb -> value_bead.header.type) = string (free_type);	/* fill in result type */
	return;

/* the following ones can return non-Booleans and non-integers, no matter what the input type is. */

get_type (7):				/* log */
get_type (10):				/* trig functions */
	string (result_vb -> value_bead.header.type) = numeric_value_type;
	return;

/* the following one preserves integralness but not zero-or-one-ness */

get_type (0):				/* plus */
get_type (1):				/* subtract */
	string (result_vb -> value_bead.header.type)
	     = string (free_type) & not_zero_or_one_mask;	/* fill in result type */
	return;

/* the following one preserves booleanness but not integrallness (that is, result is guaranteed to be an
   integer and boolean only if operand(s) is (are), but not guaranteed to produce even an integer is
   the operand is integral but not boolean */

get_type (3):				/* divide */
get_type (6):				/* power */
	if free_type.data_type.zero_or_one_value then	/* preserves booleanness */
	     string (result_vb -> value_bead.header.type) = string (free_type);	/* fill in result type */
	else
	     string (result_vb -> value_bead.header.type) = numeric_value_type;	/* otherwise preserves nothing */
	return;

/* boolean operations. set boolean_both to be the value (either 0 or 1) to which the operands will be compared.
   If both operands are equal to this value, answer will be set to set_on_equal, otherwise set to set_on_not_equal.
   set_on_equal will have the identity of operator (if and or or) or 1 - identity (for nand, inverse of and; for
   nor, inverse of or). */

get_type (11):				/* and */
get_type (12):				/* or */
get_type (13):				/* nand */
get_type (14):				/* nor */
	boolean_both = booleans (action_place);

/* the following comparisons can only return boolean values */

get_type (15):					/* < */
get_type (16):					/* <_ */
get_type (17):					/* = */
get_type (18):					/* >_ */
get_type (19):					/* > */
get_type (20):					/*  /= */
	set_on_equal = identity (action_place);	/* identity for this operator */
	string (result_vb -> value_bead.header.type) = zero_or_one_value_type;
	return;

end fill_type;

/* subroutine to fill rho vector of newly created value bead from reduction.  The rho vector is merely copied from
   the right operand except that the dimension indicated by the variable dimension is not copied.  Note that if
   the result rho rho is to be 0 nothing need be copied; if it is to be 1, then the right operand rhorho was 2.
   Therefore if dimension = 1 then rho (2) is to copied, if dimension = 2 then rho (1) is to be copied */

fill_rho:
	procedure ();

	if rhorho = 0 then return;		/* result is scalar, no rho anyway */
	if rhorho = 1 then do;
	     result_vb -> value_bead.rho (1) =	/* copy 1 if dimension = 2, 2 if dimension = 1 */
	     right_vb -> value_bead.rho (3 - dimension);
	     return;
	end;

	number_to_copy = dimension - 1;	/* copy all dimensions before one to reduce */
	if number_to_copy > 0 then	/* check if zero length array (illegal PL/I) */
	     addr (result_vb -> value_bead.rho) -> word_copy_overlay =
		addr (right_vb -> value_bead.rho) -> word_copy_overlay;

	number_to_copy = rhorho - number_to_copy;	/* copy all after dimension to reduce */
	if number_to_copy > 0 then
	     addr (result_vb -> value_bead.rho (dimension)) -> word_copy_overlay =
		addr (right_vb -> value_bead.rho (dimension + 1)) -> word_copy_overlay;
	return;

end fill_rho;

/* procedure to extract information from operators_argument */

dyadic_extract:
	procedure ();

declare	dyadic bit (1) aligned init ("0"b);

/* copy information from argument structure */

	dyadic = "1"b;
	left_vb = operators_argument.operands (1).value;
	left_array = left_vb -> value_bead.data_pointer;
	left_data_elements = left_vb -> value_bead.total_data_elements;
	left_rhorho = left_vb -> value_bead.rhorho;
	left_chars = left_vb -> value_bead.character_value;

monadic_extract:			/* repeat for right operand */
	entry ();

	right_vb = operators_argument.operands (2).value;
	right_array = right_vb -> value_bead.data_pointer;
	right_data_elements = right_vb -> value_bead.total_data_elements;
	right_rhorho = right_vb -> value_bead.rhorho;
	right_chars = right_vb -> value_bead.character_value;

	if dyadic
	then do;
		string (free_type) = string (left_vb -> value_bead.type) & string (right_vb -> value_bead.type);
		if string (free_type.data_type) = ""b		/* aarghh!  mixed char and numeric operands */
		     | string (free_type) = character_value_type	/* both args are character */
		then string (free_type) = numeric_value_type;	/* just happens that all scalar ops return numbers */
	     end;
	else string (free_type) = string (right_vb -> value_bead.type);

	action_place,
	op1 = operators_argument.operator.op1;		/* copy out primary operator code */
	many_action_place = 2 * action_place;	/* for do_many subroutine */
	op2 = operators_argument.operator.op2;	/* 2nd operator for inner product (user typed op2.op1) */
	dimension = operators_argument.operator.dimension;	/* dimension over which to apply reduction */

	fuzz = ws_info.fuzz;		/* extract for efficiency */
	integer_fuzz = ws_info.integer_fuzz;
	special_case = 0;			/* not known to be a special case for do_many yet */
	swapped_flag = "0"b;

end dyadic_extract;

/* Subroutine to compute whether result can overlay one or more of the operands */

dyadic_result_lowest:
	procedure ();

	if left_chars & right_chars
	then copy_up_needed = "1"b;			/* can't overlay because result is numeric */
	else do;
		copy_up_needed = "0"b;
		if operators_argument.operands (2).on_stack	/* can overlay totally */
		then ws_info.value_stack_ptr = right_vb;			/* overlay on right value bead */
		else if operators_argument.operands (1).on_stack
		     then ws_info.value_stack_ptr = left_vb;		/* overlay on left value bead */
	     end;

end dyadic_result_lowest;

/* the same, for monadic routines */

monadic_result_lowest:
	procedure ();

	if ^right_chars & operators_argument.operands (2).on_stack
	then do;
		ws_info.value_stack_ptr = right_vb;		/* Overlay numeric right operand if it is on stack */
		copy_up_needed = "0"b;
	     end;
	else copy_up_needed = operators_argument.operands (2).on_stack;	/* copy if arg is on stack */

end monadic_result_lowest;

/* the following subroutine does dyadic operations. it expects result_array to point to
   the result array, action_place to contain the appropriate label for which operation to do, and data_elements
   to contain the number of result elements. if scalars are involved they must be in single_element_fl_1 and
   single_element_fl_2 */

/* The following is a short lecture on relative and integer fuzz. Despite what you might think, a fair amount
   of time and effort has gone into making sure that this program correctly handles the two types of fuzz.
   Relative fuzz is "how close" two numbers must be before they can be considered equal.  If we were
   in assembly language, we might do this test with a "test under mask" instruction.  But we aren't,
   and so we've devised a simple arithmetic scheme which works despite the magnitude of the numbers.
   When you look at the code, you may wonder why we actually test to see that two numbers are really equal before
   we actually test to see if they are "fuzz equal." Well, besides perhaps being faster,
   it seems that  zero does not compare fuzz equal to itself!  So, assuming A and B are both not zero,
   they are equal within relative fuzz iff:
		|A-B|
		----- < fuzz
		|A+B|
   As for integer fuzz (which is how close a floating-point number must be to an integer before it can be
   considered an integer; and note that there is no requirement that integer fuzz = relative fuzz),
   a number F is considered to be the integer floor(F+0.5) iff:
		abs(floor(F+0.5) - F) < integer_fuzz
   For testing F to be within integer fuzz of zero, this simplifies to:
		abs(F) < integer_fuzz

   For testing F to be equal to a specific integer I,
		abs (F - I) < integer_fuzz

   Class dismissed. */

dyadic_operate:
	procedure ();

dcl	subscript fixed bin (21);		/* provides a random subscript... don't use one in outer block,
					   in order to avoid naming conflicts */

	goto dyadic_do (dyadic_action_place);	/* select correct action routine depending upon variable action_place */


/* actual action routines for various operators.  note that those that are commutative have the same routine for
   <vector> <op1> <scalar> and <scalar> <op1> <vector>. Note that this includes the comparison operators
   which are not commutative (< <_ > >_); merely the results have been changed.(ie., set_on_equal is opposite, etc.). */

dyadic_do (0):				/* both scalar, + */
	result_array -> numeric_datum (0) =
	     single_element_fl_1 +
	     single_element_fl_2;
	return;

dyadic_do (1):			/* vector handler for PLUS */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		left_array -> numeric_datum (subscript) +
		right_array -> numeric_datum (subscript);
	end;
	return;

dyadic_do (2):					/* left sc, right vc */
dyadic_do (3):					/* left vc, right sc */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		single_element_fl_1 /* the scalar */ +
		right_array -> numeric_datum (subscript);	/* the vector */
	end;
	return;

dyadic_do (4):			/* both scalar, - */
	result_array -> numeric_datum (0) =
	     single_element_fl_1 -
	     single_element_fl_2;
	return;

dyadic_do (5):			/* vector handler for MINUS */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		left_array -> numeric_datum (subscript) -
		right_array -> numeric_datum (subscript);
	end;
	return;

dyadic_do (6):			/* left sc, right vc */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		single_element_fl_1 /* the scalar */ -
		right_array -> numeric_datum (subscript);	/* the vector */
	end;
	return;

dyadic_do (7):			/* left vc, right sc */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		right_array -> numeric_datum (subscript) -
		single_element_fl_1;
	end;
	return;

dyadic_do (8):				/* both scalar, * */
	result_array -> numeric_datum (0) =
	     single_element_fl_1 *
	     single_element_fl_2;
	return;

dyadic_do (9):			/* both vector, times */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		left_array -> numeric_datum (subscript) *
		right_array -> numeric_datum (subscript);
	end;
	return;

dyadic_do (10):			/* left sc, right vc */
dyadic_do (11):			/* but multiplication is commutative */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		single_element_fl_1 /* the scalar */ *
		right_array -> numeric_datum (subscript);	/* the vector */
	end;
	return;

dyadic_do (12):			/* both scalar, divide */
	if single_element_fl_2 = 0e0
	then if single_element_fl_1 = 0e0	/* dividend =0? */
	     then result_array -> numeric_datum (0) = 1e0;
	     else go to zerodivide_error_right;
	else result_array -> numeric_datum (0) = single_element_fl_1 / single_element_fl_2;
	return;

dyadic_do (13):			/* both vectors, divide */
	do subscript = 0 by 1 while (subscript < data_elements);
	     if right_array -> numeric_datum (subscript) = 0e0 /* divisor =0? */
	     then if left_array -> numeric_datum (subscript) = 0e0 /* dividend =0? */
		then result_array -> numeric_datum (subscript) = 1e0;
		else go to zerodivide_error_right;
	     else result_array -> numeric_datum (subscript) =
		     left_array -> numeric_datum (subscript) /
		     right_array -> numeric_datum (subscript);
	end;
	return;

dyadic_do (14):			/* left sc, right vc, divide */
	do subscript = 0 by 1 while (subscript < data_elements);
	     if right_array -> numeric_datum (subscript) = 0e0 /* divisor =0? */
	     then if single_element_fl_1 = 0e0	/* dividend =0? */
		then result_array -> numeric_datum (subscript) = 1e0;
		else go to zerodivide_error_right;
	     else result_array -> numeric_datum (subscript) =
		     single_element_fl_1 / right_array -> numeric_datum (subscript);
	end;
	return;

dyadic_do (15):			/* left vector, right scalar, divide */
	do subscript = 0 by 1 while (subscript < data_elements);
	     if single_element_fl_1 = 0e0	/* divisor 0? */
	     then if right_array -> numeric_datum (subscript) = 0e0 /* dividend =0? */
		then result_array -> numeric_datum (subscript) = 1e0;
		else go to zerodivide_error_right;
	     else result_array -> numeric_datum (subscript) =
		     right_array -> numeric_datum (subscript) / single_element_fl_1;
	end;
	return;

dyadic_do (16):			/* both scalar, max */
	result_array -> numeric_datum (0) = max (single_element_fl_1, single_element_fl_2);
	return;

dyadic_do (17):			/* both vector, max */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		max (left_array -> numeric_datum (subscript), right_array -> numeric_datum (subscript));
	end;
	return;

dyadic_do (18):			/* left sc, right vc, max */
dyadic_do (19):			/* right sc, left vc, max */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		max (single_element_fl_1, right_array -> numeric_datum (subscript));
	end;
	return;

dyadic_do (20):			/* both scalar, min */
	result_array -> numeric_datum (0) = min (single_element_fl_1, single_element_fl_2);
	return;

dyadic_do (21):			/* both vector, min */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		min (left_array -> numeric_datum (subscript), right_array -> numeric_datum (subscript));
	end;
	return;

dyadic_do (22):			/* left sc, right vc, min */
dyadic_do (23):			/* right sc, left vc, min */
	do subscript = 0 by 1 while (subscript < data_elements);
	     result_array -> numeric_datum (subscript) =
		min (single_element_fl_1, right_array -> numeric_datum (subscript));
	end;
	return;

dyadic_do (24):			/* both scalar, exponentiate */
dyadic_do (28):			/* both scalar, log */
dyadic_do (32):			/* both scalar, residue */
dyadic_do (36):			/* both scalar, binomial coefficients */
dyadic_do (40):			/* both scalar, trig */
	call do_many ();			/* perform operation depending on many_action_place */
	result_array -> numeric_datum (0) = result_accumulator;
	return;

dyadic_do (25):				/* both vector, exp */
dyadic_do (29):			/* both vectors, log */
dyadic_do (33):			/* both vectors, residue */
dyadic_do (37):			/* both vectors, binomial coefficients */
dyadic_do (41):				/* both vector, trig */
	do subscript = 0 by 1 while (subscript < data_elements);
	     single_element_fl_1 = left_array -> numeric_datum (subscript);
	     single_element_fl_2 = right_array -> numeric_datum (subscript);
	     call do_many ();
	     result_array -> numeric_datum (subscript) =
		result_accumulator;
	end;
	return;

dyadic_do (42):			/* left scalar, right vector, trig */
	float_temp = floor(single_element_fl_1 + 0.5);	/* convert arg to fixed */
	if abs(float_temp - single_element_fl_1) > integer_fuzz then goto domain_error_left;
	if abs(float_temp) > 7 then goto domain_error_left;
	trig_integer = fixed(float_temp, 3);	/* convert to integer between -7 and +7 */
	special_case = 1;			/* is special case because we know left is integral */

dyadic_do (26):				/* left scalar, right vector, exp */
dyadic_do (30):			/* left scalar, right vector, log */
dyadic_do (34):			/* left scalar, right vector, residue */
dyadic_do (38):			/* left scalar, right vector, binomial coefficients */
	do subscript = 0 by 1 while (subscript < data_elements);
	     single_element_fl_2 = right_array -> numeric_datum (subscript);
	     call do_many ();
	     result_array -> numeric_datum (subscript) =
		result_accumulator;
	end;
	return;

dyadic_do (27):			/* left vector, right scalar, exp */
	float_temp = floor(single_element_fl_1 + 0.5);
	if abs(float_temp - single_element_fl_1) <= integer_fuzz then
	     if abs(float_temp) < 1e17b then do;	/* integer */
		trig_integer = fixed(float_temp, 17);		/* yes, it is integer exponent */
		special_case = 1;
	     end;

dyadic_do (31):			/* right scalar, left vector, log */
dyadic_do (35):			/* right scalar, left vector, residue */
dyadic_do (39):			/* right scalar, left vector, binomial coefficients */
dyadic_do (43):			/* left vector, right scalar, trig */
	single_element_fl_2 = single_element_fl_1;
	do subscript = 0 by 1 while (subscript < data_elements);
	     single_element_fl_1 = right_array -> numeric_datum (subscript);
	     call do_many ();
	     result_array -> numeric_datum (subscript) =
		result_accumulator;
	end;
	return;

dyadic_do (44):			/* both scalar, and */
dyadic_do (48):			/* both scalar, or */
dyadic_do (52):			/* both scalar, nand */
dyadic_do (56):			/* both scalar, nor */
	if abs (single_element_fl_1 - dyadic_boolean_both) < integer_fuzz then do;
	     if abs (single_element_fl_2 - dyadic_boolean_both) < integer_fuzz then do;
		result_array -> numeric_datum (0) = dyadic_set_on_equal;
		return;
	     end;
	     if abs (single_element_fl_2 - dyadic_boolean_neither) >= integer_fuzz then goto domain_error_right;
	end;
	else
	     if abs (single_element_fl_1 - dyadic_boolean_neither) >= integer_fuzz then goto domain_error_left;

	if abs (single_element_fl_2 - dyadic_boolean_both) >= integer_fuzz then	/* check 2nd operand */
	     if abs (single_element_fl_2 - dyadic_boolean_neither) >= integer_fuzz then	/* doom */
		goto domain_error_right;		/* neither 0 nor 1 */

	result_array -> numeric_datum (0) = dyadic_set_on_not_equal;
	return;

dyadic_do (45):			/* both vector, and */
	if free_type.zero_or_one_value then do;
	     call apl_dyadic_bool_appendage_$and (left_array, right_array, result_array, data_elements);
	     return;
	end;
	else goto dyadic_do_bool_vector;

dyadic_do (49):			/* both vector, or */
	if free_type.zero_or_one_value then do;
	     call apl_dyadic_bool_appendage_$or (left_array, right_array, result_array, data_elements);
	     return;
	end;
	else goto dyadic_do_bool_vector;

dyadic_do (53):			/* both vector, nand */
	if free_type.zero_or_one_value then do;
	     call apl_dyadic_bool_appendage_$nand (left_array, right_array, result_array, data_elements);
	     return;
	end;
	else goto dyadic_do_bool_vector;

dyadic_do (57):			/* both vector, nor */
	if free_type.zero_or_one_value then do;
	     call apl_dyadic_bool_appendage_$nor (left_array, right_array, result_array, data_elements);
	     return;
	end;

/* The following block of code has now been replaced by apl_dyadic_bool_appendage_.
   It is retained here to make it easy to revert the ALM procedure.

dyadic_do (45):					!* both vector, and *!
dyadic_do (49):					!* both vector, or *!
dyadic_do (53):					!* both vector, nand *!
dyadic_do (57):					!* both vector, nor *!
	if free_type.zero_or_one_value then do;
	     do subscript = 0 by 1 while (subscript < data_elements);
		if left_array -> numeric_datum (subscript) = dyadic_boolean_both then
		     if right_array -> numeric_datum (subscript) = dyadic_boolean_both then
			result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
		     else
			result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
		else
		     result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
	     end;
	     return;
	end;
*/

dyadic_do_bool_vector:
	do subscript = 0 by 1 while (subscript < data_elements);
	     if abs (left_array -> numeric_datum (subscript) - dyadic_boolean_both) < integer_fuzz then do;
		if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_both) < integer_fuzz then do;
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
		     goto get_next_element_45;
		end;
		if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_neither) >= integer_fuzz then
		     goto domain_error_right;
	     end;
	     else
		if abs (left_array -> numeric_datum (subscript) - dyadic_boolean_neither) >= integer_fuzz then
		     goto domain_error_left;

	     if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_both) >= integer_fuzz
	     then if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_neither) >= integer_fuzz
		then go to domain_error_right;	/* opnd 2 is neither 0 nor 1 */

	     result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
get_next_element_45:
	end;
	return;

dyadic_do (54):			/* left sc, right vc, nand */
dyadic_do (58):			/* left sc, right vc, nor */
dyadic_do (55):			/* left vc, right sc, nand */
dyadic_do (59):			/* left vc, right sc, nor */
	if free_type.zero_or_one_value then do;	/* known that both are zero or one */
     	     if single_element_fl_1 = dyadic_boolean_both then do;
		result_array -> numeric_datum =
		     1 - right_array -> numeric_datum;	/* invert each one */
		return;
	     end;

	     result_array -> numeric_datum = dyadic_set_on_not_equal;
	     return;
	end;

	single_element_fl_1 = 1 - single_element_fl_1;	/* invert for not types */
dyadic_do (46):			/* left sc, right vc, and */
dyadic_do (50):			/* left sc, right vc, or */
dyadic_do (47):			/* left vc, right sc, and */
dyadic_do (51):			/* left vc, right sc, or */
	if free_type.zero_or_one_value then do;	/* must be and  | or, because of test above */
	     if single_element_fl_1 = dyadic_boolean_neither then do;	/* 0 clears and, 1 sets or */
		result_array -> numeric_datum = dyadic_set_on_not_equal;	/* set whole array */
		return;
	     end;

	     if result_array ^= right_array then	/* 1 and X is X; 0 or X is X */
		result_array -> numeric_datum =
		     right_array -> numeric_datum;	/* move whole array, pointers not same */
	     return;
	end;

	if abs (single_element_fl_1 - dyadic_boolean_both) > integer_fuzz then
	     if abs (single_element_fl_1 - dyadic_boolean_neither) > integer_fuzz
	     then goto domain_error_left_maybe;			/* neither 0 nor 1 */
	do subscript = 0 by 1 while (subscript < data_elements);
	     if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_both) < integer_fuzz then
		result_array -> numeric_datum (subscript) = single_element_fl_1;
	     else if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_neither) < integer_fuzz then
		result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
		else goto domain_error_right_maybe;
	end;
	return;

dyadic_do (80):				/* scalar /= */
dyadic_do (68):				/* scalar = */
	if single_element_fl_1 = single_element_fl_2 then
	     result_array -> numeric_datum (0) = dyadic_set_on_equal;
	else
	     if abs (single_element_fl_2 - single_element_fl_1) <
			abs(fuzz * (single_element_fl_1 + single_element_fl_2)) then
			result_array -> numeric_datum (0) = dyadic_set_on_equal;
		else
		     result_array -> numeric_datum (0) = dyadic_set_on_not_equal;
	return;

dyadic_do (81):			/* /= for vectors */
	if free_type.zero_or_one_value then do;
	     call apl_dyadic_bool_appendage_$neq (left_array, right_array, result_array, data_elements);
	     return;
	end;
	else goto dyadic_do_eq_neq_vector;

dyadic_do (69):			/* = for vectors */
	if free_type.zero_or_one_value then do;
	     call apl_dyadic_bool_appendage_$eq (left_array, right_array, result_array, data_elements);
	     return;
	end;

dyadic_do_eq_neq_vector:
	do subscript = 0 by 1 while (subscript < data_elements);
	     if left_array -> numeric_datum (subscript) =
		right_array -> numeric_datum (subscript) then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else
		if abs(left_array -> numeric_datum(subscript) - right_array -> numeric_datum(subscript)) <
		     abs(fuzz * (left_array -> numeric_datum(subscript) + right_array -> numeric_datum(subscript))) then
			result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
		else
		     result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
	end;
	return;

dyadic_do (82):				/* left sc, right vc, /= */
dyadic_do (83):				/* left vc, right sc, /= */
dyadic_do (70):				/* left sc, right vc, = */
dyadic_do (71):				/* right sc, left vc, = */
	do subscript = 0 by 1 while (subscript < data_elements);
	     if single_element_fl_1 = right_array -> numeric_datum (subscript) then
		result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else
		if abs (single_element_fl_1 -
		     right_array -> numeric_datum (subscript) ) <
		     abs(fuzz * (single_element_fl_1 + right_array -> numeric_datum(subscript))) then
			result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
		else
		     result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
	end;
	return;

dyadic_do (64):				/* scalar <_ */
dyadic_do (76):				/* scalar > */
	if single_element_fl_1 <=
	     single_element_fl_2  then
		     result_array -> numeric_datum (0) = dyadic_set_on_equal;
	     else if abs(single_element_fl_1 - single_element_fl_2) <
		abs(fuzz * (single_element_fl_1 + single_element_fl_2)) then
		     result_array -> numeric_datum (0) = dyadic_set_on_equal;
	     else
		result_array -> numeric_datum (0) = dyadic_set_on_not_equal;
	return;

dyadic_do (65):			/* <_ for vectors */
dyadic_do (77):			/* > for vectors */
	do subscript = 0 by 1 while (subscript < data_elements);
	     if left_array -> numeric_datum (subscript) <=
		right_array -> numeric_datum (subscript)  then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else if abs(left_array -> numeric_datum(subscript) - right_array -> numeric_datum(subscript)) <
		abs(fuzz * (left_array -> numeric_datum(subscript) + right_array -> numeric_datum(subscript))) then
		     result_array -> numeric_datum(subscript) = dyadic_set_on_equal;
	     else
		result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
	end;
	return;

dyadic_do (63):			/* left vc, right sc, < */
dyadic_do (75):			/* left vc, right sc, >_ */
dyadic_do (66):			/* left sc, right vc, <_ */
dyadic_do (78):			/* left sc, right vc, > */
	do subscript = 0 by 1 while (subscript < data_elements);
	     if single_element_fl_1 <=
		right_array -> numeric_datum (subscript)  then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else if abs(single_element_fl_1 - right_array -> numeric_datum(subscript)) <
		abs(fuzz * (single_element_fl_1 + right_array -> numeric_datum(subscript))) then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else
		result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
	end;
	return;

dyadic_do (60):				/* scalar < */
dyadic_do (72):				/* scalar >_ */
	if single_element_fl_1 >=
	     single_element_fl_2  then
		     result_array -> numeric_datum (0) = dyadic_set_on_equal;
	     else if abs(single_element_fl_1 - single_element_fl_2) <
		abs(fuzz * (single_element_fl_1 + single_element_fl_2)) then
		     result_array -> numeric_datum (0) = dyadic_set_on_equal;
	     else
		result_array -> numeric_datum (0) = dyadic_set_on_not_equal;
	return;

dyadic_do (61):			/* < for vectors */
dyadic_do (73):			/* >_ for vectors */
	do subscript = 0 by 1 while (subscript < data_elements);
	     if left_array -> numeric_datum (subscript) >=
		right_array -> numeric_datum (subscript)  then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else if abs(left_array -> numeric_datum(subscript) - right_array -> numeric_datum(subscript)) <
		abs(fuzz * (left_array -> numeric_datum(subscript) + right_array -> numeric_datum(subscript))) then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else
		result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
	end;
	return;

dyadic_do (67):			/* left vc, right sc, <_ */
dyadic_do (79):			/* left vc, right sc, > */
dyadic_do (62):			/* left sc, right vc, < */
dyadic_do (74):			/* left sc, right vc, >_ */
	do subscript = 0 by 1 while (subscript < data_elements);
	     if single_element_fl_1 >=
		right_array -> numeric_datum (subscript)  then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else if abs(single_element_fl_1 - right_array -> numeric_datum(subscript)) <
		abs(fuzz * (single_element_fl_1 + right_array -> numeric_datum(subscript))) then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else
		result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
	end;
	return;

dyadic_do (-4):			/* both scalar, character, = */
	if addr (single_element_fl_1) -> character_data_structure.character_datum (0) =
	     addr (single_element_fl_2) -> character_data_structure.character_datum (0) then
		result_array -> numeric_datum (0) = dyadic_set_on_equal;
	else
	     result_array -> numeric_datum (0) = dyadic_set_on_not_equal;
	return;

dyadic_do (-3):			/* both vector, character, = (and /=) */
	do subscript = data_elements - 1 to 0 by -1;
	     if left_array -> character_data_structure.character_datum (subscript) =
		right_array -> character_data_structure.character_datum (subscript) then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
	     else
		result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
	end;
	return;

dyadic_do (-1):			/* left vector, right scalar, characters, = and /= */
dyadic_do (-2):			/* left scalar, right vector, characters, = and /= */
	do subscript = data_elements - 1 to 0 by -1;
	     if addr (single_element_fl_1) -> character_data_structure.character_datum (0) =
		right_array -> character_data_structure.character_datum (subscript) then
		     result_array -> numeric_datum (subscript) = dyadic_set_on_equal;
		else
		     result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal;
	end;
	return;

end dyadic_operate;
/* Subroutine to perform reductions. Called by reduction and scan. All parameters are global variables. */

reduction_operate:
	procedure;

/* pseudo-parameters */

/* dcl	right_array ptr,			ptr to result array.
	column_base fixed bin (21),		subscript (0 origin) of first element in vector.
	highest_column_element fixed bin (21),	subscript (0 origin) of next to last element.
	interval_between_elements fixed bin (21),	number of elements between each element of the vector.
	action_place fixed bin (8),		which operator to perform.
	result_accumulator float,		the result of the reduction.
	(reduction_boolean_both, reduction_boolean_neither, reduction_set_on_equal, reduction_set_on_not_equal)
		float;			inputs to comparison operators. */

/* The rest of the global variables this routine references are not really parameters...just ordinary global vars. */

/* automatic */

dcl	subscript fixed bin (21);		/* provides a random subscript... don't use one in outer block,
					   in order to avoid naming conflicts */
declare	save_special_case fixed binary;	/* if we must call do_many, we must set special_case
					   to zero. therefore we must save it and restore
					   it because others may depend on it being saved */
declare	save_many_action_place fixed binary;	/* .. */

/* program */

	goto reduction_do (action_place);

reduction_do (0):					/* reduction add */
reduction_do (1):					/* reduction subtract. note alternating signs */
reduction_do (2):					/* reduction multiply */
reduction_do (4):					/* reduction max */
reduction_do (5):					/* reduction min */
	call apl_reduction_appendage_ (right_array, column_base, highest_column_element + interval_between_elements,
	     interval_between_elements, action_place, result_accumulator);
	return;

reduction_do (3):					/* reduction divide */
	call apl_reduction_appendage_$divide (right_array, column_base, highest_column_element + interval_between_elements,
	     interval_between_elements, action_place, result_accumulator, zerodivide_error_right);
	return;

reduction_do (6):					/* power reduction */
reduction_do (7):					/* logarithm reduction */
reduction_do (8):					/* residue reduction */
reduction_do (9):					/* binomial coefficients reduction */
reduction_do (10):				/* one of the truly worthless things in this language, circle reduction */
	save_special_case = special_case;	/* so we can restore this later */
	save_many_action_place = many_action_place;	/* .. */
	many_action_place = 2 * action_place;		/* done here mainly for inner product's benefit */
	special_case = 0;			/* reduction itself will not use this */
	do subscript = highest_column_element repeat (subscript - interval_between_elements)
	     while (subscript >= column_base);

	     single_element_fl_2 = result_accumulator;
	     single_element_fl_1 = right_array -> numeric_datum (subscript);

	     call do_many ();
	end;
	special_case = save_special_case;	/* restore cause others may need it (cf. dyadic in inner_product) */
	many_action_place = save_many_action_place;	/* .. */
	return;

reduction_do (13):					/* nand */
reduction_do (14):					/* nor */
	result_accumulator = 1 - result_accumulator;
reduction_do (11):					/* and */
reduction_do (12):					/* or */
	if reduction_type.data_type.zero_or_one_value
	then do;
		call apl_reduction_appendage_ (right_array, column_base,
		     highest_column_element + interval_between_elements, interval_between_elements, action_place,
		     result_accumulator);
		return;
	     end;

	if abs (result_accumulator - reduction_boolean_both) > integer_fuzz then
	     if abs (result_accumulator - reduction_boolean_neither) > integer_fuzz
	     then goto domain_error;			/* neither 0 nor 1 */
	do subscript = highest_column_element repeat (subscript - interval_between_elements)
	     while (subscript >= column_base);

	     if abs (right_array -> numeric_datum (subscript) - reduction_boolean_both) > integer_fuzz then do;
		if abs (right_array -> numeric_datum (subscript) - reduction_boolean_neither) > integer_fuzz then
		     goto domain_error;

		result_accumulator = reduction_set_on_not_equal;
	     end;
	end;
	return;

reduction_do (15):					/* another winner, < reduction */
reduction_do (18):					/* >_ reduction */
	do subscript = highest_column_element repeat (subscript - interval_between_elements)
	     while (subscript >= column_base);

	     if right_array -> numeric_datum (subscript) >= result_accumulator then
		result_accumulator = reduction_set_on_equal;
	     else if abs(right_array -> numeric_datum(subscript) - result_accumulator) <
		abs(fuzz * (right_array -> numeric_datum(subscript) + result_accumulator)) then
		result_accumulator = reduction_set_on_equal;
	     else
		result_accumulator = reduction_set_on_not_equal;
	end;
	return;

reduction_do (16):					/* <_ reduction */
reduction_do (19):					/* > reduction */
	do subscript = highest_column_element repeat (subscript - interval_between_elements)
	     while (subscript >= column_base);

	     if right_array -> numeric_datum (subscript) <= result_accumulator then
		result_accumulator = reduction_set_on_equal;
	     else if abs(right_array -> numeric_datum(subscript) - result_accumulator) <
		abs(fuzz * (right_array -> numeric_datum(subscript) + result_accumulator)) then
		result_accumulator = reduction_set_on_equal;
	     else
		result_accumulator = reduction_set_on_not_equal;
	end;
	return;

reduction_do (17):					/* /= */
reduction_do (20):					/* = */
	do subscript = highest_column_element repeat (subscript - interval_between_elements)
	     while (subscript >= column_base);

	     if right_array -> numeric_datum (subscript) = result_accumulator
	     then result_accumulator = reduction_set_on_equal;
	     else if abs (result_accumulator - right_array -> numeric_datum (subscript)) <
		     abs(fuzz * (result_accumulator + right_array -> numeric_datum(subscript))) then
		     result_accumulator = reduction_set_on_equal;
		else
		     result_accumulator = reduction_set_on_not_equal;
	end;
	return;

reduction_do (-1):					/* = and /= for characters */
	if right_array -> character_data_structure.character_datum (column_base) =
	     right_array -> character_data_structure.character_datum (column_base + interval_between_elements) then
		result_accumulator = reduction_set_on_equal;	/* comparison succeeded */
	else
	     result_accumulator = reduction_set_on_not_equal;
	return;

end reduction_operate;
/* many subroutine. will do operation signified by many_action_place + special_case */

do_many:
	procedure ();

/* automatic */

declare	(b, c, d, left_arg, right_arg, sign_result) float,
	casex fixed bin,
	resultc complex float;

/* builtins */

declare	(acos, asin, atan, atanh, cos, cosh, sin, sinh, sqrt, tan, tanh) builtin;

/* constants */

declare	(POSITIVE init (+1),
	NEGATIVE init (-1)) fixed bin internal static options (constant);

/* program */

	goto many_actions (many_action_place + special_case);

/* subroutine to do trig operations. entered with single_element_fl_1 being left arg and single_element_fl_2
   being right arg.  Left will be checked for integerness and being >= -7 and <= 7.  If this is already known,
   trig_integer can be set equal to left arg and do_trig_integral called instead */

/* No domain errors are checked for here; instead we will let each trigonometric builtin function
   signal the "error" condition, and the default handler in apl_parse_ will transform "error"
   (with oncodes between 1 and 100, indicating math errors) into a domain error. */

many_actions (20):					/* TRIG: left arg is floating */
	result_accumulator = floor (single_element_fl_1 + 0.5);
	if abs (result_accumulator - single_element_fl_1) > integer_fuzz | abs (result_accumulator) >= 1e17b
	then go to invalid_circular_fcn_left;

	trig_integer = fixed (result_accumulator, 35);
	if abs (trig_integer) > 7
	then go to invalid_circular_fcn_left;

many_actions (21):					/* TRIG: left is integral and from -7 to 7 */
	goto trig_array (trig_integer);

trig_array (-7):					/* hyperbolic arctangent */
	result_accumulator = atanh(single_element_fl_2);
	return;

trig_array (-6):					/* hyperbolic arccosine */
	result_accumulator = atanh(sqrt(single_element_fl_2*single_element_fl_2 - 1.0e0)/single_element_fl_2);
	return;

trig_array (-5):					/* hyperbolic arcsine */
	result_accumulator = atanh(single_element_fl_2/sqrt(1.0e0 + single_element_fl_2*single_element_fl_2));
	return;

trig_array (-4):					/* sqrt (X**2 - 1) */
	result_accumulator = sqrt(-1.0e0 + single_element_fl_2*single_element_fl_2);
	return;

trig_array (-3):					/* arctangent */
	result_accumulator = atan(single_element_fl_2);
	return;

trig_array (-2):					/* arccosine */
	result_accumulator = acos (single_element_fl_2);
	return;

trig_array (-1):					/* arcsine */
	result_accumulator = asin (single_element_fl_2);
	return;

trig_array (0):					/* sqrt (1 - X**2) */
	result_accumulator = sqrt(1.0e0 - single_element_fl_2*single_element_fl_2);
	return;

trig_array (1):					/* sine */
	result_accumulator = sin(single_element_fl_2);
	return;

trig_array (2):					/* cosine */
	result_accumulator = cos(single_element_fl_2);
	return;

trig_array (3):					/* tangent */
	result_accumulator = tan(single_element_fl_2);
	return;

trig_array (4):					/* sqrt (X**2 + 1) */
	result_accumulator = sqrt(1.0e0 + single_element_fl_2*single_element_fl_2);
	return;

trig_array (5):					/* hyperbolic sine */
	result_accumulator = sinh(single_element_fl_2);
	return;

trig_array (6):					/* hyperbolic cosine */
	result_accumulator = cosh(single_element_fl_2);
	return;

trig_array (7):					/* hyperbolic tangent */
	result_accumulator = tanh(single_element_fl_2);
	return;

many_actions (17):				/* RESIDUE:	 check for compatibility error */
	if single_element_fl_1 <= 0 then	/* neg or zero */
	     goto compatibility_error_left;

many_actions (16):				/* RESIDUE */
	if abs (single_element_fl_1) > fuzz then do;	/* not equal to zero */
	     result_accumulator = single_element_fl_2 -
		apl_floor_ (single_element_fl_2 / single_element_fl_1) * single_element_fl_1;
	     return;
	end;
	result_accumulator = single_element_fl_2;
	return;

many_actions (14):					/* LOGARITHM: log (right arg) to base (left arg) */
many_actions (15):
	if single_element_fl_1 < 0e0 then do;
	     if single_element_fl_2 = 1e0 then do;
		result_accumulator = 0e0;
		return;
	     end;

	     if single_element_fl_2 ^= single_element_fl_1 then
		goto domain_error;
	     result_accumulator = 1e0;
	     return;
	end;

	if single_element_fl_1 = 1e0			/* avoid zerodivide, below */
	then go to domain_error_left;
	else if single_element_fl_1 = 0e0
	     then go to domain_error_left;
	     else if single_element_fl_2 <= 0e0
		then go to domain_error_right;

	result_accumulator = log (single_element_fl_2) / log (single_element_fl_1);
	return;

many_actions (12):					/* EXPONENTIATION: right arg (exponent) floating */
	result_accumulator = floor (single_element_fl_2 + 0.5);
	if (abs (result_accumulator - single_element_fl_2) > integer_fuzz)
	     | (abs (result_accumulator) > 1e17b)
	then do;

		/* exponent is not integral. */

		if single_element_fl_1 > 0
		then result_accumulator = single_element_fl_1 ** single_element_fl_2;		/* (+F)**F */
		else if single_element_fl_1 = 0
		     then do;
			     if single_element_fl_2 < 0
			     then go to domain_error;					/* 0**(-F) */

			     result_accumulator = 0;					/* 0**(+F) */
			end;
		     else do;							/* (-F)**F */
			     resultc = complex (single_element_fl_1, 0) ** single_element_fl_2;
			     result_accumulator = real (resultc);
			     if result_accumulator < 100 * imag (resultc)
			     then go to domain_error;
			end;
		return;
	     end;

	trig_integer = fixed (result_accumulator, 35);

many_actions (13):					/* EXPONENTIATION: right arg (exponent) integral */
	if single_element_fl_1 = 0
	then do;
		if trig_integer < 0
		then goto domain_error;				/* 0**(-I) */
		else if trig_integer = 0
		     then result_accumulator = 1;			/* 0**0 */
		     else result_accumulator = 0;			/* 0**(+I) */
		return;
	     end;

	result_accumulator = single_element_fl_1 ** trig_integer;		/* I**I */
	return;

many_actions (18):					/* BINOMIAL COEFFICIENTS */
many_actions (19):
	if integer (single_element_fl_1, NEGATIVE)
	then casex = 4;
	else casex = 0;

	if integer (single_element_fl_2, NEGATIVE)
	then casex = casex + 2;

	if integer (single_element_fl_2 - single_element_fl_1, NEGATIVE)
	then casex = casex + 1;

	go to case (casex);

						/* A B B-A (1 --> negative integer, 0 otherwise */
						/* ------- */
case (1):						/* 0 0 1  -> 0e0 */
case (4):						/* 1 0 0  -> 0e0 */
case (7):						/* 1 1 1  -> 0e0 */
	result_accumulator = 0e0;
	return;

case (2):						/* 0 1 0 -> DOMAIN ERROR */
case (5):						/* 1 0 1 -> Impossible */
	go to domain_error;

case (0):						/* 0 0 0 -> (!B)-:(!A)x!B-A */
	sign_result = 1;
	left_arg = single_element_fl_1;
	right_arg = single_element_fl_2;
	go to combinations_common;

case (3):						/* 0 1 1 -> (^1*A)xA!A-B+1 */
	left_arg = single_element_fl_1;
	right_arg = single_element_fl_1 - (single_element_fl_2 + 1e0);
	if mod (single_element_fl_1, 2) = 0		/* even */
	then sign_result = 1;
	else sign_result = -1;
	go to combinations_common;

case (6):						/* 1 1 0 -> (^1*B-A)x(|B+1)!|A+1 */
	left_arg = abs (single_element_fl_2 + 1e0);
	right_arg = abs (single_element_fl_1 + 1e0);
	if mod (single_element_fl_2 - single_element_fl_1, 2) = 0 /* even */
	then sign_result = 1;
	else sign_result = -1;

combinations_common:
	if (integer (left_arg, POSITIVE) | (abs(left_arg) < integer_fuzz) ) & (integer (right_arg, POSITIVE))
	then do;
		if right_arg - left_arg > left_arg
		then c = right_arg - left_arg;
		else c = left_arg;

		b = -(c - right_arg);
		c = c + 1e0;
		result_accumulator = 1e0;

		do d = result_accumulator by 1e0 while (d <= b);
		     result_accumulator = (result_accumulator * c) / d;
		     c = c + 1e0;
		end;
		result_accumulator = sign_result * result_accumulator;
		return;
	     end;

	result_accumulator = sign_result * gamma (right_arg + 1) / (gamma (left_arg + 1) * gamma (right_arg - left_arg + 1))
	     ;
	return;

/* Function to determine whether its argument is an integer, positive or negative */

integer:
	procedure (P_arg, P_sign) returns (bit (1) aligned);

/* parameters */

declare 	(P_arg float,
	P_sign fixed bin) parameter;

/* automatic */

declare	trial_val float;

/* program */

	trial_val = floor (P_arg + .5e0);

	if (abs (trial_val - P_arg) < ws_info.integer_fuzz) & sign (trial_val) = P_sign
	then return ("1"b);
	else return ("0"b);

     end integer;

end do_many;

/* ALGORITHM 80
   [RECIPROCAL] GAMMA FUNCTION OF REAL ARGUMENT.
   Published March, 1962 by William Holsten, in CACM
   Modified 790716 by PG to return gamma(x), rather than reciprocal.

   This function computes the Gamma function for all real values of x, using the identities:
	Gamma(x-1) = Gamma(x)/(x-1)	for x < -1
	Gamma(x+1) = x*Gamma(x)	for x > 1

   I have tested this algorithm versus a 12-place table and have found that is
   accurate to 11 decimal places between 0 and 1. It is also more accurate over
   the entire interval than the Taylor series expansion given in the Handbook
   of Mathematical Functions, Abramowitz and Stegun editors, Dover Publications,
   New York, 1972, page 256.

   The reference for the 12-place table is British Association for the
   Advancement of Science, Mathematical Tables, Volume 1, University Press,
   Cambridge, England, 1951, page 40. */

gamma:
     procedure (P_x) returns (float);

/* parameters */

declare	P_x		float parameter;

/* automatic */

declare	(result, x, y)	float;

/* program */

	x = P_x;

	if x = 0
	then go to domain_error;

	else if x = 1
	then result = 1;

	else if x >= 1
	then do;
		y = 1;
aa:		x = x - 1;
		y = y * x;
		if x > 1
		then go to aa;

		if x = 1
		then result = y;
		else result = y / rgamma_int (x);
	     end;

	else if x = -1
	then go to domain_error;

	else if x > -1
	then result = 1 / rgamma_int (x);

	else do;
		y = x;
cc:		x = x + 1;
		if x < -1
		then do;
			y = y * x;
			go to cc;
		     end;

		if x = -1
		then go to domain_error;

		result = 1 / (rgamma_int (x) * y);
	     end;
	return (result);

/* This function computes the real reciprocal Gamma function of real x for -1 < x < 1,
   utilizing Horner's method for polynomial evaluation of the approximation polynomial. */

rgamma_int:
     procedure (P_x) returns (float);

/* parameter */

declare	P_x		float parameter;

/* automatic */

declare	(x, y)		float;

/* program */

	x = P_x;
	y = x + 1e0;
	return (y * (x * (1e0 + x * (-.422784335092 + x * (-.233093736365 + x *
	     (+.191091101162 + x * (-.024552490887 + x * (-.017645242118 + x * (+.008023278113 + x *
	     (-.000804341335 + x * (-.000360851496 + x * (+.000145624324 + x * (-.000017527917 + x *
	     (-.000002625721 + x * (+.000001328554 + x * -.000000181220)))))))))))))));

     end rgamma_int;

     end gamma;

%include apl_floor_fcn;
end /* apl_monadic_ */;




		    apl_monadic_format_.pl1         11/29/83  1638.6r w 11/29/83  1346.9      354384



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

/* Program to implement monadic and dyadic APL format operators.
   Written November 1978 by PG.
   Modified 780312 by PG to fix 366 (monadic format miscalculates the number of columns required if one of
	the elements rounds to zero, and some other element is nonzero.) The fix was to always reserve a
	column for a possible leading zero. Bug 372 was fixed (format reserves a column for a negative sign
	based on the sign of the unrounded value). Bug 371 (empty right args cause format to blow up) was
	lessened by having format temporarily reject empty right arguments. Additionally, SCIENTIFIC_FMT was
	modified to suppress the leading zero of an exponent.
   Modified 790607 by PG to fix 400 (format should use same width for each column if a single format pair is used).
   Modified 790809 by PG to fix 373 (format is supposed to return a result having the same rank as
	the argument, for nonscalars).
   Modified 790815 by PG to fix 371 (not handling empty arrays).
   Modified 790913 by PG to add apl_print_value_ functions. All formatted output now goes thru this routine.
   Modified 791127 by PG to recode scientific picture conversion so that it is inline.
   Modified 800201 by PG to fix 444 (apl_print_value_ entry could reference beyond end of output buffer
	if a vector_overflow occured, because the end-of-the-buffer test was skipped).
   Modified 811210 by TO to make 'apl_print_value_' print integers of more
	than qPP digits in scientific.
   Modified 811210 by TO to use integer format if a column is fuzz-integral.
*/

/* Known differences between this program and the IBM implementation:
   1. We always print a leading zero for FIXED_DEC format. IBM always
      prints one for monadic format; never prints one for dyadic format.
   2. We keep leading whitespace after a vector_overflow, IBM does not.
   3. We use either one or two digits in the exponent for SCIENTIFIC.
      IBM always uses two.
   4. We return empty results if given empty arguments. I'm not sure what
      IBM does.
   5. IBM assumes that each character occupies one print position (even BS).
      We calculate the effect of each character separately.
*/

/* format: style3 */
apl_monadic_format_:
     procedure (operators_argument);

/* automatic */

declare	fmt_info_ptr	ptr,
	check_if_column_fuzz_integral bit (1),
	column_base	fixed bin,
	column_length	fixed bin,
	column_top	fixed bin,
	colx		fixed bin,
	current_rho_value	fixed bin (21),
	data_elements	fixed bin (21),
	dyadic		bit (1) aligned,
	float_temp	float,
	format		bit (1) aligned,		/* ON if format, OFF if print_value */
	interval_between_elements
			fixed bin,
	interval_between_planes
			fixed bin,
	largest_possible_value
			float,
	left_pos		fixed bin,
	left		ptr,
	left_data_elements	fixed bin (21),
	left_vb		ptr,
	listx		fixed bin,		/* subscript of current member in list bead */
	n_cols		fixed bin,
	n_lines		fixed bin,
	n_words		fixed bin (19),
	plane_base	fixed bin,
	pseudo_column_length
			fixed bin,
	result		ptr,
	result_cols	fixed bin (21),
	result_data_elements
			fixed bin (21),
	result_pos	fixed bin (21),
	result_vb		ptr,
	rhox		fixed bin,
	right		ptr,
	right_data_elements fixed bin (21),
	right_rho_ptr	ptr,
	right_rhorho	fixed bin,
	right_vb		ptr,
	round_buffer	char (21),
	temp_result	ptr,
	valx		fixed bin;

/* based */

declare	1 fmt_info	aligned based (fmt_info_ptr),
	  2 global_max_value
			float,			/* template value for entire array */
	  2 global_negative_element
			bit (1) aligned,		/* ON if any elements in array negative */
	  2 col		(n_cols),
	    3 max_value	float,			/* maximum absolute value */
	    3 min_value	float,			/* minimum absolute value */
	    3 max_abs_value float,			/* template value */
	    3 negative_element
			bit (1) aligned,		/* ON if any elements in column negative */
	    3 fuzz_integral bit (1) aligned,		/* ON if all elements of column fuzz-integral */
	    3 field_width	fixed bin,		/* number of columns total */
	    3 precision	fixed bin,		/* number of digits (varies with type) */
	    3 type	fixed bin;		/* which output format to use */

declare	left_numeric_datum	(0:left_data_elements - 1) float based (left),
	right_numeric_datum (0:right_data_elements - 1) float based (right),
	right_rho		(right_rhorho) fixed bin (21) based (right_rho_ptr),
	word_copy_overlay	(n_words) fixed bin (35) based;

/* builtins */

declare	(abs, addrel, binary, copy, currentsize, divide, floor, hbound, lbound, length, max, min, mod, null, rank, rtrim,
	sign, size, string, substr, sum, trunc, verify)
			builtin;

/* conditions */

declare	cleanup		condition;

/* entries */

declare	apl_system_error_	entry (fixed bin (35));

/* external static */

declare	(
	apl_error_table_$domain,
	apl_error_table_$length,
	apl_error_table_$no_type_bits,
	apl_error_table_$not_within_int_fuzz,
	apl_error_table_$rank
	)		fixed bin (35) external static;

/* internal static */

declare	(
	SCIENTIFIC_FMT	initial (0),		/* use exponential form */
	INTEGER_FMT	initial (1),		/* use integer form */
	FIXED_DEC_FMT	initial (2)
	)		fixed bin internal static;	/* use decimal form */

declare	one_e		(0:38) float internal static
			initial (1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, 1e10, 1e11, 1e12, 1e13, 1e14, 1e15,
			1e16, 1e17, 1e18, 1e19, 1e20, 1e21, 1e22, 1e23, 1e24, 1e25, 1e26, 1e27, 1e28, 1e29, 1e30, 1e31,
			1e32, 1e33, 1e34, 1e35, 1e36, 1e37, 1e38);

/* include files */

%include apl_number_data;
%include apl_bead_format;
%include apl_characters;
%include apl_list_bead;
%include apl_operator_bead;
%include apl_operators_argument;
%include apl_value_bead;
%include apl_ws_info;

/* program */

/* apl_monadic_format_:
     entry (operators_argument); */

/* Perform argument validation and special-casing unique to the entry of invocation */

	dyadic = "0"b;
	go to join;

apl_dyadic_format_:
     entry (operators_argument);

	left_vb = operators_argument.operands (1).value;
	left = left_vb -> value_bead.data_pointer;
	left_data_elements = left_vb -> value_bead.total_data_elements;

	if ^left_vb -> value_bead.numeric_value
	then go to domain_error_left;

	if left_vb -> value_bead.rhorho > 1
	then go to rank_error_left;

	dyadic = "1"b;

/* Monadic and Dyadic Format merge here */

join:
	format = "1"b;
	right_vb = operators_argument.operands (2).value;
	right = right_vb -> value_bead.data_pointer;
	right_data_elements = right_vb -> value_bead.total_data_elements;

	if right_vb -> value_bead.character_value
	then if dyadic
	     then go to domain_error_right;
	     else do;
		     if operators_argument.operands (2).on_stack
		     then do;
			     operators_argument.result = right_vb;
			     return;
			end;

		     n_words = binary (right_vb -> value_bead.size, 18);
		     result_vb = apl_push_stack_ (n_words);
		     result = addrel (result_vb, currentsize (right_vb -> value_bead));
		     result_vb -> word_copy_overlay (*) = right_vb -> word_copy_overlay (*);
		     result_vb -> value_bead.data_pointer = result;
		     operators_argument.result = result_vb;
		     return;
		end;
	else if ^right_vb -> value_bead.numeric_value
	then go to domain_error_right;		/* neither chars nor numbers */

	if dyadic
	then if (left_data_elements ^= 1) & (left_data_elements ^= 2)
	     then if right_vb -> value_bead.rhorho > 0
		then if (left_data_elements ^= 2 * right_vb -> value_bead.rho (right_vb -> value_bead.rhorho))
			| (left_data_elements = 0)
		     then go to length_error;		/* right nonscalar */
		     else ;
		else go to length_error;		/* right scalar */

	go to join2;

apl_print_value_:
     entry (P_bead_ptr, P_add_nl, P_flush_buffer);

/* parameters */

declare	(
	P_bead_ptr	ptr unal,
	P_add_nl		bit (1) aligned,
	P_flush_buffer	bit (1) aligned
	)		parameter;

/* automatic */

declare	need_nl		bit (1) aligned;		/* ON if previous element was last one in the row */

/* based */

declare	right_chars	char (right_data_elements) based (right);

/* program */

	right_vb = P_bead_ptr;

	if right_vb = null
	then return;

	if right_vb -> general_bead.list_value
	then do;
		do listx = lbound (right_vb -> list_bead.member_ptr, 1) to hbound (right_vb -> list_bead.member_ptr, 1);
		     call apl_print_value_ (right_vb -> list_bead.member_ptr (listx), "0"b, "0"b);
		end;

		call print_value_epilogue;
		return;
	     end;

	if ^right_vb -> general_bead.value
	then call apl_system_error_ (apl_error_table_$no_type_bits);

	if ^right_vb -> value_bead.character_value & ^right_vb -> value_bead.numeric_value
	then call apl_system_error_ (apl_error_table_$no_type_bits);

	right = right_vb -> value_bead.data_pointer;
	right_data_elements = right_vb -> value_bead.total_data_elements;

	on cleanup call clean_up;

	if right_vb -> value_bead.character_value
	then do;
		if right_vb -> value_bead.rhorho = 0	/* scalar */
		then call append_any_char (substr (right_chars, 1, 1));
		else if right_vb -> value_bead.rhorho = 1
		then do;				/* vector */
			do valx = 1 to right_data_elements;
			     call append_any_char (substr (right_chars, valx, 1));
			end;
		     end;
		else do;				/* array */
			column_length = right_vb -> value_bead.rho (right_vb -> value_bead.rhorho - 1);
			n_cols, interval_between_elements = right_vb -> value_bead.rho (right_vb -> value_bead.rhorho);
			interval_between_planes = interval_between_elements * column_length;

/* walk through planes, then rows of right arg, then columns */

			colx = 1;
			need_nl = "0"b;
			do plane_base = 0 repeat (plane_base + interval_between_planes)
			     while (plane_base < right_data_elements);
			     do valx = plane_base repeat (valx + 1) while (valx < plane_base + interval_between_planes);
				if need_nl
				then do;
					call append_newline;
					need_nl = "0"b;
				     end;

				call append_any_char (substr (right_chars, valx + 1, 1));
				colx = colx + 1;

				if colx > n_cols
				then do;
					colx = 1;
					need_nl = "1"b;
				     end;
			     end;

/* We have just finished one plane. Compute number of blank rows to put out. */

			     call compute_blank_rows;

			     do rhox = 1 to n_lines;
				call append_newline;
			     end;
			end;
		     end;

		call print_value_epilogue;
		return;
	     end;

	format = "0"b;
	dyadic = "0"b;

/* join format function to handle numeric cases */

/* The format function and the numeric cases of print_value merge here.

   Compute number of columns, and number of 'rows'  (hyper-rows in the
   case of a multi-dimensional array */

join2:
	if right_vb -> value_bead.rhorho = 0
	then n_cols, interval_between_elements = 1;
	else n_cols, interval_between_elements = right_vb -> value_bead.rho (right_vb -> value_bead.rhorho);

	pseudo_column_length = 1;

	do rhox = 1 to right_vb -> value_bead.rhorho - 1;
	     pseudo_column_length = pseudo_column_length * right_vb -> value_bead.rho (rhox);
	end;

/* Note: either n_cols or pseudo_column_length, or both, can be zero; this indicates a null array */

	n_words = size (fmt_info);
	fmt_info_ptr = apl_push_stack_ (n_words);

/* Save a copy of the right rho vector if right value_bead is on the stack,
   because the right vb will get popped before the result is built, and we
   want to be able to fill in the result bead completely, even though in one case
   the result rho will be in exactly the same location as the right rho. It's easier
   to make a copy than to figure it all out... */

	if format
	then do;
		right_rhorho = right_vb -> value_bead.rhorho;

		if operators_argument.operands (2).on_stack & right_rhorho > 0
		then do;
			n_words = size (right_rho);
			right_rho_ptr = apl_push_stack_ (n_words);
			right_rho (*) = right_vb -> value_bead.rho (*);
		     end;
		else right_rho_ptr = null;
	     end;

/* Scan the right argument one column at a time, computing the maximum absolute value,
   the minimum absolute value, and the template value. Also determine if the column
   is fuzz-integral.  */

	if right_vb -> value_bead.zero_or_one_value
	then do;
		fmt_info.global_max_value = 1e0;	/* safe assumption */
		fmt_info.global_negative_element = "0"b;

		do colx = 1 to n_cols;
		     fmt_info.col (colx).max_value = 1e0;
						/* we assume... */
		     fmt_info.col (colx).min_value = 0e0;
						/* .. */
		     fmt_info.col (colx).max_abs_value = 1e0;
						/* .. */
		     fmt_info.col (colx).negative_element = "0"b;
						/* this one we are sure of  */
		     fmt_info.col (colx).fuzz_integral = "1"b;
		end;
	     end;
	else do;
		fmt_info.global_max_value = -TheBiggestNumberWeveGot;
		fmt_info.global_negative_element = "0"b;

		do colx = 1 to n_cols;
		     fmt_info.col (colx).max_value = -TheBiggestNumberWeveGot;
		     fmt_info.col (colx).min_value = TheBiggestNumberWeveGot;
		     fmt_info.col (colx).negative_element = "0"b;
		     fmt_info.col (colx).fuzz_integral = "1"b;
		     check_if_column_fuzz_integral = ^right_vb -> value_bead.integral_value;
		     column_base = colx - 1;
		     column_top = column_base + interval_between_elements * pseudo_column_length;

		     do valx = column_base repeat (valx + interval_between_elements) while (valx < column_top);
			if right_numeric_datum (valx) < 0e0
			then fmt_info.col (colx).negative_element = "1"b;

			fmt_info.col (colx).max_value =
			     max (fmt_info.col (colx).max_value, abs (right_numeric_datum (valx)));
			fmt_info.col (colx).min_value =
			     min (fmt_info.col (colx).min_value, abs (right_numeric_datum (valx)));
			if check_if_column_fuzz_integral
			then if abs (right_numeric_datum (valx) -
			     floor (right_numeric_datum (valx) + 0.5)) > ws_info.integer_fuzz
			     then check_if_column_fuzz_integral, fmt_info.col (colx).fuzz_integral = "0"b;
		     end;

		     fmt_info.col (colx).max_abs_value = fmt_info.col (colx).max_value;
		     fmt_info.global_max_value = max (fmt_info.global_max_value, fmt_info.col (colx).max_value);

		     if fmt_info.col (colx).negative_element = "1"b
		     then fmt_info.col (colx).max_abs_value = -abs (fmt_info.col (colx).max_abs_value);

		     fmt_info.global_negative_element =
			fmt_info.global_negative_element | fmt_info.col (colx).negative_element;
		end;
	     end;

	if fmt_info.global_negative_element = "1"b
	then fmt_info.global_max_value = -abs (fmt_info.global_max_value);

/* Convert the user-specified formatting parameters (in the left argument) into field width,
   precision, and type. If the user did not specify a field width, compute the default width. */

	if dyadic
	then if left_vb -> value_bead.total_data_elements <= 2
						/* scalar, 1, or 2 elements */
	     then begin;

/* automatic temps */

declare	(precision_temp, type_temp, width_temp)
			fixed bin,
	(precision_temp_fl, width_temp_fl)
			float;

		     if left_vb -> value_bead.total_data_elements = 1
		     then do;
			     width_temp_fl = 0e0;
			     precision_temp_fl = left_numeric_datum (0);
			end;
		     else do;
			     width_temp_fl = left_numeric_datum (0);
			     precision_temp_fl = left_numeric_datum (1);
			end;

		     type_temp = 1 + sign (integerize (precision_temp_fl));
		     precision_temp = abs (integerize (precision_temp_fl));

		     if (type_temp = SCIENTIFIC_FMT & precision_temp > 19)
			| (type_temp = FIXED_DEC_FMT & precision_temp > 57)
		     then go to domain_error_left;

		     width_temp = integerize (width_temp_fl);

		     if (width_temp < 0) | (width_temp > 255)
		     then go to domain_error_left;

		     if width_temp = 0
		     then width_temp = 1 + min_field_width (fmt_info.global_max_value, precision_temp, type_temp);

		     do colx = 1 to n_cols;
			fmt_info.col (colx).type = type_temp;
			fmt_info.col (colx).precision = precision_temp;
			fmt_info.col (colx).field_width = width_temp;
		     end;
		end;
	     else do;
		     left_pos = 0;
		     do colx = 1 to n_cols;
			float_temp = left_numeric_datum (left_pos + 1);
			fmt_info.col (colx).type = 1 + sign (integerize (float_temp));
			fmt_info.col (colx).precision = abs (integerize (float_temp));

			if (fmt_info.col (colx).type = SCIENTIFIC_FMT & fmt_info.col (colx).precision > 19)
			     | (fmt_info.col (colx).type = FIXED_DEC_FMT & fmt_info.col (colx).precision > 57)
			then go to domain_error_left;

			fmt_info.col (colx).field_width = integerize (left_numeric_datum (left_pos));

			if (fmt_info.col (colx).field_width < 0) | (fmt_info.col (colx).field_width > 255)
			then go to domain_error_left;

			if fmt_info.col (colx).field_width = 0
						/* user wants us to choose */
			then fmt_info.col (colx).field_width =
				1
				+
				min_field_width (fmt_info.col (colx).max_abs_value, fmt_info.col (colx).precision,
				fmt_info.col (colx).type);

			left_pos = left_pos + 2;
		     end;
		end;
	else if ^right_vb -> value_bead.zero_or_one_value
	then do;
		largest_possible_value = one_e (ws_info.digits);
						/* = 10 ** ws_info.digits */
		do colx = 1 to n_cols;
		     if (largest_possible_value <= fmt_info.col (colx).max_value)
			| (fmt_info.col (colx).min_value < 1e-4 & fmt_info.col (colx).min_value > 0e0)
			| (simple_log10 (fmt_info.col (colx).max_value) - simple_log10 (fmt_info.col (colx).min_value)
			> 4)
		     then do;
			     fmt_info.col (colx).type = SCIENTIFIC_FMT;
			     fmt_info.col (colx).precision = ws_info.digits;
			end;
		     else if fmt_info.col (colx).fuzz_integral
		     then do;
			     fmt_info.col (colx).type = INTEGER_FMT;
			     fmt_info.col (colx).precision = 0;
			end;
		     else do;
			     fmt_info.col (colx).type = FIXED_DEC_FMT;
			     fmt_info.col (colx).precision = ws_info.digits;
			end;

		     fmt_info.col (colx).field_width =
			1
			+
			min_field_width (fmt_info.col (colx).max_abs_value, fmt_info.col (colx).precision,
			fmt_info.col (colx).type);
		end;
	     end;
	else do colx = 1 to n_cols;
		fmt_info.col (colx).type = INTEGER_FMT;
		fmt_info.col (colx).precision = 0;
		fmt_info.col (colx).field_width = 2;
	     end;

/* Compute the size of the result character matrix. We cannot overlay the
   input operands, so it will be placed at the end of the stack. The size we
   compute is correct for all dyadic cases, and for monadic arrays.
   It is a little too large for monadic scalars and vectors, since they do
   not include any leading white space (and dyadic does). The size of the
   temporary is not that critical, and the result size will be corrected later. */

	if (n_cols = 0) | (pseudo_column_length = 0)
	then result_cols = 0;
	else result_cols = sum (fmt_info.col (*).field_width);

	if format
	then do;
		data_elements, result_data_elements = pseudo_column_length * result_cols;
		n_words = size (character_data_structure);
		temp_result = apl_push_stack_ (n_words);
		result_pos = 1;
	     end;

/* Perform the conversion */

	if right_vb -> value_bead.rhorho = 0		/* scalar */
	then do;
		colx = 1;
		valx = 0;
		call format_value (colx, valx, ^dyadic, ^dyadic, ^dyadic);

		if format
		then result_cols = result_pos - 1;	/* fixup for monadic case, noop for dyadic */
	     end;
	else if right_vb -> value_bead.rhorho = 1	/* vector */
	then do;
		do valx = 0 by 1 while (valx < right_data_elements);
		     colx = valx + 1;
		     call format_value (colx, valx, ^dyadic & (colx = 1), ^dyadic, ^dyadic & (colx = n_cols));
		end;

		if format
		then result_cols = result_pos - 1;	/* fixup for monadic case, noop for dyadic */
	     end;
	else do;					/* array */
		column_length = right_vb -> value_bead.rho (right_vb -> value_bead.rhorho - 1);
		interval_between_planes = interval_between_elements * column_length;

/* walk through planes, then rows of right arg, then columns */

		colx = 1;
		need_nl = "0"b;
		do plane_base = 0 repeat (plane_base + interval_between_planes) while (plane_base < right_data_elements);
		     do valx = plane_base repeat (valx + 1) while (valx < plane_base + interval_between_planes);
			if need_nl
			then do;
				call append_newline;
				need_nl = "0"b;
			     end;

			call format_value (colx, valx, "0"b, ^dyadic, "0"b);

			colx = colx + 1;
			if colx > n_cols
			then do;
				colx = 1;
				need_nl = ^format;
			     end;
		     end;

/* We have just finished one plane. Compute number of blank rows to put out in the print_value case. */

		     if ^format
		     then do;
			     call compute_blank_rows;

			     do rhox = 1 to n_lines;
				call append_newline;
			     end;
			end;
		end;
	     end;

/* Pop input operands and temporary working space */

	if ^format
	then do;
		call print_value_epilogue;
		ws_info.value_stack_ptr = fmt_info_ptr;
		return;
	     end;

	if operators_argument.operands (2).on_stack
	then ws_info.value_stack_ptr = right_vb;
	else if operators_argument.operands (1).on_stack
	then ws_info.value_stack_ptr = left_vb;
	else ws_info.value_stack_ptr = fmt_info_ptr;	/* Well, pop stuff we put there */

/* Allocate result bead. Value_bead header is guaranteed not to overlay temp_result because fmt_info
   is in between, and has at least one element of 10 words. */

	if right_rhorho = 0
	then number_of_dimensions = 1;
	else number_of_dimensions = right_rhorho;

	data_elements = result_pos - 1;
	n_words = size (value_bead) + size (character_data_structure);
	result_vb = apl_push_stack_ (n_words);
	string (result_vb -> value_bead.type) = character_value_type;
	result_vb -> value_bead.rhorho = number_of_dimensions;

	if right_rhorho > 0
	then if right_rho_ptr = null
	     then result_vb -> value_bead.rho (*) = right_vb -> value_bead.rho (*);
	     else result_vb -> value_bead.rho (*) = right_rho (*);

	result_vb -> value_bead.rho (number_of_dimensions) = result_cols;

	result_vb -> value_bead.total_data_elements = data_elements;
	result = addrel (result_vb, size (value_bead));
	result_vb -> value_bead.data_pointer = result;
	result -> character_string_overlay = temp_result -> character_string_overlay;

	operators_argument.result = result_vb;
	return;

/* Entrypoint to write out the current contents of the output buffer */

apl_flush_buffer_:
     entry ();

	on cleanup call clean_up;

	call flush_buffer;
	return;

/* Entrypoint to append a newline to the output buffer, and then write it out */

apl_flush_buffer_nl_:
     entry ();

	on cleanup call clean_up;

	call append_newline;
	call flush_buffer;
	return;

/* Entrypoint to append a newline to the output buffer */

apl_print_newline_:
     entry ();

	on cleanup call clean_up;

	call append_newline;
	return;

/* Entrypoint to print character data mixed in with normal APL output.
   When called multiple times before apl_print_newline_, each additional
   string is tabbed to the next margin. Assumptions: tabbing wanted, every char
   takes one column to print (no BS, HT, NL in argument). */

apl_print_string_:
     entry (P_string);

/* parameters */

declare	P_string		char (*);

/* automatic */

declare	n_pads		fixed bin (21);		/* number of blanks to insert to get to margin */

/* program */

	on cleanup call clean_up;

	if ws_info.output_buffer_ll > 0		/* already stuff on line? */
	then do;
		n_pads = 8 - mod (ws_info.output_buffer_ll, 8);

		if ws_info.output_buffer_ll + n_pads + length (P_string) > ws_info.width
		then call append_newline;
		else do;
			if ws_info.output_buffer_pos + n_pads > length (output_buffer)
			then call flush_buffer;

			substr (output_buffer, ws_info.output_buffer_pos, n_pads) = "";
			ws_info.output_buffer_pos = ws_info.output_buffer_pos + n_pads;
			ws_info.output_buffer_ll = ws_info.output_buffer_ll + n_pads;
		     end;
	     end;

	if ws_info.output_buffer_pos + length (P_string) > length (output_buffer)
	then call flush_buffer;

	substr (output_buffer, ws_info.output_buffer_pos, length (P_string)) = P_string;
	ws_info.output_buffer_pos = ws_info.output_buffer_pos + length (P_string);
	ws_info.output_buffer_ll = ws_info.output_buffer_ll + length (P_string);
	return;

/* Error exits. These actions are for the use of the format function
   only...this mechanism does not work for apl_print_value_. */

domain_error_left:
	operators_argument.where_error = operators_argument.where_error + 2;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$domain;
	return;

length_error:
	operators_argument.error_code = apl_error_table_$length;
	return;

not_within_int_fuzz_left:
	operators_argument.where_error = operators_argument.where_error + 1;
	operators_argument.error_code = apl_error_table_$not_within_int_fuzz;
	return;

rank_error_left:
	operators_argument.where_error = operators_argument.where_error + 1;
	operators_argument.error_code = apl_error_table_$rank;
	return;

/* Internal procedures */

/* Subroutine to append a single character to the output buffer, incrementing output_buffer_ll appropriately */

append_any_char:
     procedure (P_char);

/* parameters */

declare	P_char		char (1) parameter;

/* automatic */

declare	delta		fixed bin;

/* internal static */

declare	width		(0:511) fixed bin (8) unal internal static init ((6) 4, 0, 0, -1, -2, 0, 4, 0, -3, (2) 0,
						/* 000-017 */
			(5) 4, 0, (10) 4,		/* 020-037 */
			(2) 1, (2) 4, 1, (2) 4, (9) 1,/* 040-057 */
			(16) 1,			/* 060-077 */
			4, (15) 1,		/* 100-117 */
			(14) 1, 4, 1,		/* 120-137 */
			4, (15) 1,		/* 140-157 */
			(15) 1, 0,		/* 160-177 */
			(48) 1,			/* 200-257 */
			(11) 1, 0, (4) 1,		/* 260-277 */
			0, 0, 1, (13) 4,		/* 300-317 */
			(48) 4,			/* 320-377 */
			(256) 4);			/* 400-777 */

/* program */

	if P_char = QNewLine
	then do;
		call append_newline;
		return;
	     end;

	delta = width (rank (P_char));

	if delta = -2				/* HT */
	then delta = ws_info.tab_width - mod (ws_info.output_buffer_ll, ws_info.tab_width);
						/* NB: should be ws_info.tab_width */
	else if delta = -3				/* CR */
	then delta = -ws_info.output_buffer_ll;

	if ws_info.output_buffer_ll + delta > ws_info.width
	then call vector_overflow;

	if ws_info.output_buffer_pos > length (output_buffer)
	then call flush_buffer;

	substr (output_buffer, ws_info.output_buffer_pos, 1) = P_char;
	ws_info.output_buffer_pos = ws_info.output_buffer_pos + 1;
	ws_info.output_buffer_ll = ws_info.output_buffer_ll + delta;
	return;

     end /* append_any_char */;

/* Subroutine to append a newline to the output buffer */

append_newline:
     procedure ();

	if ws_info.output_buffer_pos > length (output_buffer)
	then call flush_buffer;

	substr (output_buffer, ws_info.output_buffer_pos, 1) = QNewLine;
	ws_info.output_buffer_pos = ws_info.output_buffer_pos + 1;
	ws_info.output_buffer_ll = 0;
	return;

     end /* append_newline */;

/* Subroutine to cancel any pending (unwritten) output if a nonlocal
   goto is performed around us. Happens if user hits ATTN during output. */

clean_up:
     procedure ();

	ws_info.output_buffer_pos = 1;
	ws_info.output_buffer_ll = 0;

     end /* clean_up */;

/* Macro-subroutine to compute the number of blank rows to put
   out between the planes of a multi-dimensional array. */

compute_blank_rows:
     procedure ();

	current_rho_value = divide (valx, interval_between_planes, 21, 0);
	n_lines = 1;
	do rhox = right_vb -> value_bead.rhorho - 2 to 1 by -1
	     while (mod (current_rho_value, right_vb -> value_bead.rho (rhox)) = 0);

	     current_rho_value = divide (current_rho_value, right_vb -> value_bead.rho (rhox), 21, 0);
	     n_lines = n_lines + 1;
	end;

	if rhox < 1				/* no blank lines after last row */
	then n_lines = 0;

     end /* compute_blank_rows */;

/* Subroutine to write out the output buffer. Called when buffer fills
   up, or when all output has been copied into the buffer */

flush_buffer:
     procedure ();

/* automatic */

declare	code		fixed bin (35);

/* entries */

declare	iox_$put_chars	entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* internal static */

declare	apl_static_$apl_output
			ptr external static;

/* program */

	call iox_$put_chars (apl_static_$apl_output, (ws_info.output_buffer_ptr), ws_info.output_buffer_pos - 1, code);
	ws_info.output_buffer_pos = 1;

	return;

     end /* flush_buffer */;

/* Subroutine to convert a single float bin (63) number to one of three character forms. */

format_value:
     procedure (bv_colx, bv_valx, bv_suppress_leading_blanks, bv_blank_trailing_zeroes, bv_suppress_trailing_blanks);

/* parameters */

declare	(
	bv_colx		fixed bin,
	bv_valx		fixed bin,
	bv_suppress_leading_blanks
			bit (1) aligned,
	bv_blank_trailing_zeroes
			bit (1) aligned,
	bv_suppress_trailing_blanks
			bit (1) aligned
	)		parameter;

/* automatic */

declare	char_value	char (60) varying,
	decimal_value	float decimal (19),
	exponent		fixed bin,
	exponent_picture	picture "z9",
	field_width	fixed bin,
	1 fixed_picture,
	  2 whole_part	picture "(38)z9v",
	  2 dot		char (1),
	  2 fractional_part picture "(57)9",
	integer_picture	picture "-(38)z9",
	integer_value	fixed dec (19),
	n_leading_blanks	fixed bin (21),
	new_value_width	fixed bin (21),		/* also used to hold n trailing blanks */
	precision		fixed bin,
	scientific_picture	picture "9.(18)9",
	start_pos		fixed bin (21),
	type		fixed bin,
	value_width	fixed bin (21);

/* entries */

declare	apl_format_util_$round
			entry (float decimal (19), fixed bin, char (21)),
	apl_format_util_$round_fixed
			entry (float decimal (19), fixed bin, char (21)),
	apl_format_util_$split
			entry (float decimal (19), fixed decimal (19), fixed bin, char (21));

/* program */

	field_width = fmt_info.col (bv_colx).field_width;
	precision = fmt_info.col (bv_colx).precision;
	type = fmt_info.col (bv_colx).type;

	decimal_value = right_numeric_datum (bv_valx);

	go to case (type);

case (0):						/* SCIENTIFIC FORMAT */
	if precision < 19			/* it is already rounded to 19 places... */
	then call apl_format_util_$round (decimal_value, precision, round_buffer);

	call apl_format_util_$split (decimal_value, integer_value, exponent, round_buffer);

	scientific_picture = integer_value;
	exponent_picture = exponent;

	if integer_value < 0
	then char_value = QUpperMinus;
	else char_value = "";

	if precision = 1
	then do;
		char_value = char_value || substr (scientific_picture, 1, 1);
		new_value_width = 0;
	     end;
	else if bv_blank_trailing_zeroes
	then do;
		new_value_width = length (rtrim (scientific_picture, "0"));

		if substr (scientific_picture, new_value_width, 1) = "."
		then new_value_width = new_value_width - 1;

		char_value = char_value || substr (scientific_picture, 1, new_value_width);
		new_value_width = precision + 1 - new_value_width;
						/* compute number of trailing blanks */
	     end;
	else do;
		char_value = char_value || substr (scientific_picture, 1, precision + 1);
		new_value_width = 0;
	     end;

	char_value = char_value || QLetterE;

	if exponent < 0
	then char_value = char_value || QUpperMinus;
	else new_value_width = new_value_width + 1;	/* remember to pad char_value later. */

	if substr (exponent_picture, 1, 1) = " "
	then do;
		char_value = char_value || substr (exponent_picture, 2, 1);
		new_value_width = new_value_width + 1;	/* remember to pad char_value later. */
	     end;
	else char_value = char_value || exponent_picture;

	if ^bv_suppress_trailing_blanks
	then if new_value_width > 0
	     then char_value = char_value || copy (" ", new_value_width);
	     else ;
	else field_width = field_width - new_value_width; /* shorten field by the missing blanks */

	go to end_case;

case (1):						/* INTEGER FORMAT */
	if ^right_vb -> value_bead.integral_value
	then call apl_format_util_$round_fixed (decimal_value, 0, round_buffer);

	integer_picture = decimal_value;

	if substr (integer_picture, 1, 1) = "-"
	then char_value = QUpperMinus;
	else char_value = "";

	n_leading_blanks = verify (substr (integer_picture, 2), " ") - 1;
	start_pos = 2 + n_leading_blanks;
	char_value = char_value || substr (integer_picture, start_pos);

	go to end_case;

case (2):						/* FIXED_DEC FORMAT */
	if ^right_vb -> value_bead.integral_value
	then call apl_format_util_$round_fixed (decimal_value, precision, round_buffer);

	if decimal_value < 0e0
	then char_value = QUpperMinus;
	else char_value = "";

	fixed_picture.whole_part = decimal_value;

	if ^right_vb -> value_bead.integral_value
	then /* rescale fractional part to be an integer (a little extra hair here is worth
		   it to be able to use a simpler picture and get inline code). */
	     fixed_picture.fractional_part = (decimal_value - trunc (decimal_value)) * 1e57;
	else string (fixed_picture.fractional_part) = (57)"0";

	fixed_picture.dot = ".";

	n_leading_blanks = verify (string (fixed_picture), " ") - 1;
	start_pos = n_leading_blanks + 1;		/* step over leading blanks */

/* Number of characters in result is #whole_digits + decimal point + #fractional_digits */

	value_width = (length (fixed_picture.whole_part) - n_leading_blanks) + 1 + precision;

	if bv_blank_trailing_zeroes
	then do;
		new_value_width = length (rtrim (substr (string (fixed_picture), start_pos, value_width), "0"));
		if substr (string (fixed_picture), start_pos + new_value_width - 1, 1) = "."
		then new_value_width = new_value_width - 1;

		char_value = char_value || substr (string (fixed_picture), start_pos, new_value_width);

		new_value_width = value_width - new_value_width;
						/* compute n trailing blanks */

		if ^bv_suppress_trailing_blanks
		then if new_value_width > 0
		     then char_value = char_value || copy (" ", new_value_width);
		     else ;
		else field_width = field_width - new_value_width;
						/* shorten field by the missing blanks */
	     end;
	else char_value = char_value || substr (string (fixed_picture), start_pos, value_width);

end_case:
	value_width = length (char_value);

	if value_width > field_width
	then go to domain_error_right;

	if bv_suppress_leading_blanks
	then field_width = value_width;

	n_leading_blanks = field_width - value_width;

	if ^format
	then do;
		if ws_info.output_buffer_ll + (n_leading_blanks + value_width) > ws_info.width
						/* Room on output line? */
		then call vector_overflow;

		if ws_info.output_buffer_pos + (n_leading_blanks + value_width) > length (output_buffer)
						/* Room in buffer? */
		then call flush_buffer;

		if n_leading_blanks > 0
		then do;
			substr (output_buffer, ws_info.output_buffer_pos, n_leading_blanks) = "";
			ws_info.output_buffer_pos = ws_info.output_buffer_pos + n_leading_blanks;
		     end;

		substr (output_buffer, ws_info.output_buffer_pos, value_width) = char_value;
		ws_info.output_buffer_pos = ws_info.output_buffer_pos + value_width;

		ws_info.output_buffer_ll = ws_info.output_buffer_ll + (n_leading_blanks + value_width);
	     end;
	else do;
		if n_leading_blanks > 0
		then do;
			substr (temp_result -> character_string_overlay, result_pos, n_leading_blanks) = "";
			result_pos = result_pos + n_leading_blanks;
		     end;

		substr (temp_result -> character_string_overlay, result_pos, value_width) = char_value;
		result_pos = result_pos + value_width;
	     end;

	return;

     end /* format_value */;

/* Function to convert a floating-point value to a floating-point representation
   of an integer, in the usual APL way, or complain if it can't. */

integerize:
     procedure (bv_value) reducible returns (float);

/* parameters */

declare	bv_value		float;

/* automatic */

declare	trial_val		float;

/* program */

	trial_val = floor (bv_value + .5e0);
	if abs (bv_value - trial_val) < ws_info.integer_fuzz
	then return (trial_val);

	go to not_within_int_fuzz_left;

     end /* integerize */;

/* Function to compute the minimum number of columns it would take to represent
   a floating point argument in APL decimal format. */

min_field_width:
     procedure (bv_value, bv_digits, bv_type) returns (fixed bin);

/* parameters */

declare	(
	bv_value		float,
	bv_digits		fixed bin,
	bv_type		fixed bin
	)		parameter;

/* automatic */

declare	decimal_value	float dec (19),
	min_width		fixed bin,
	rounded_value	float;

/* entries */

declare	apl_format_util_$round_fixed
			entry (float decimal (19), fixed bin, char (21));

/* program */

	if (bv_digits ^= 0) & ^(bv_digits = 1 & bv_type = SCIENTIFIC_FMT)
	then min_width = 1;				/* account for decimal point */
	else min_width = 0;				/* no decimal point */

	min_width = min_width + bv_digits;		/* account for fractional digits */

	if bv_type = SCIENTIFIC_FMT
	then do;
		min_width = min_width + 4;		/* account for E+00 */

		if bv_value < 0e0			/* account for sign; */
		then min_width = min_width + 1;	/* it cannot be rounded away */
	     end;
	else do;
		decimal_value = bv_value;		/* perform rounding in decimal to avoid overflows */
		call apl_format_util_$round_fixed (decimal_value, bv_digits, round_buffer);

		if decimal_value > 1.701411834604692317e38
		then rounded_value = TheBiggestNumberWeveGot;
		else if decimal_value < -1.701411834604692317e38
		then rounded_value = -TheBiggestNumberWeveGot;
		else if (decimal_value < 1.469367938527859385e-39) & (decimal_value > 0e0)
		then rounded_value = TheSmallestNumberWeveGot;
		else if (decimal_value > -1.469367938527859385e-39) & (decimal_value < 0e0)
		then rounded_value = -TheSmallestNumberWeveGot;
		else rounded_value = decimal_value;

/* account for digits in integer part...reserve one column for a possible leading zero,
   in case any elements in the column round to zero. Currently, we cannot tell if this
   will happen, so we are forced to assume it will. */

		min_width = min_width + 1 + simple_log10 (abs (rounded_value));

/* account for the sign. We know that if the sign rounds away on the template value,
   then it will round away on all values in the column, so it is proper (and necessary)
   to check the sign on the rounded value. */

		if rounded_value < 0e0
		then min_width = min_width + 1;
	     end;

	return (min_width);

     end /* min_field_width */;

/* Subroutine to perform actions common to the end of the apl_print_value_ cases. */

print_value_epilogue:
     procedure;

	if P_add_nl
	then call append_newline;

	if P_flush_buffer
	then call flush_buffer;

     end /* print_value_epilogue */;

/* Internal procedure to return (max (0, floor (log10 (value)))) */

simple_log10:
     procedure (bv_value) returns (fixed bin);

/* parameters */

declare	bv_value		float parameter;

/* automatic */

declare	result		fixed bin,
	value		float;

/* program */

	value = bv_value;

	if value < 1e0				/* would result be negative? */
	then return (0);				/* yes */

	do result = lbound (one_e, 1) to hbound (one_e, 1) - 1 while (value >= one_e (result + 1));
	end;

	return (result);

     end /* simple_log10 */;

/* Subroutine to perform the actions necessary when a line of (numeric)
   output exceeds the line length */

vector_overflow:
     procedure ();

	call append_newline;

	if ws_info.output_buffer_pos + 6 > length (output_buffer)
	then call flush_buffer;

	substr (output_buffer, ws_info.output_buffer_pos, 6) = "";
	ws_info.output_buffer_pos = ws_info.output_buffer_pos + 6;
	ws_info.output_buffer_ll = ws_info.output_buffer_ll + 6;
	return;

     end /* vector_overflow */;

%include apl_push_stack_fcn;
     end /* apl_monadic_format_ */;




		    apl_monadic_not_appendage_.alm  11/29/83  1638.6r w 11/29/83  1346.9       37323



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

"
"	apl_monadic_not_appendage_ uses a fast algorithm to change
"	a float bin (63) 0 to a 1 or vice versa
"
"	Written 800131 by B. Margulies
"	Modified 800227 by PG to work
"
	name 	apl_monadic_not_appendage_
	segdef	apl_monadic_not_appendage_
	segdef	in_place
"	
"
"	call apl_monadic_not_appendage_ (right_values_ptr, count, result_values_ptr, temp)
"	call apl_monadic_not_appendage_$in_place (right_values_ptr, count)
"	     
" declare right_values_ptr ptr /* pointer to operand array of float bin (63) */;
" declare count fixed bin (21) aligned /* number of values to count */;
" declare result_values_ptr ptr /* ptr to result array of float bin (63)'s */;
" declare temp fixed bin /* word to be used as a temporary */;
"
	equ	right_values_ptr,2		" parameter 1
	equ	count,4			" parameter 2
	equ	result_values_ptr,6		" parameter 3
	equ	temp,8			" parameter 4
"
	bool	A,001000		" rpd A flag
	bool	B,000400		" rpd B flag
"
"
"	This entrypoint takes an operand that is not on the stack,
"	computes the result, and stores it in the result array.
apl_monadic_not_appendage_:
	epp4	pr0|count,*	" get pointer to count
	ldq	pr4|0		" get count
	tze	go_home		" zero-length array, nothing to do
	epp1	pr0|result_values_ptr,*	" get pointer to pointer to result values
	epp1	pr1|0,*		" get pointer to result values
	epp3	pr0|right_values_ptr,*	" ..
	epp3	pr3|0,*		" ..
	epp5	pr0|temp,*	" get ptr to temp word
	lda	0,dl
	eax4	0
	lls	34		" get count/4 in A
	als	3+18		" get 1+offset of last word of last element, in AU
	sta	pr5|0		" save in temp word
	qrl	34		" get remainder of count/4 in Q
	eax1	0,ql		" and move it to X1
	cmpa	0,dl		" any elements in first group?
	tze	copy_last_group	" no, check remainder
"
copy_group_loop:
	ldaq	pr3|0,x4		" double-word 1
	eraq	flip_bits
	staq	pr1|0,x4
	ldaq	pr3|2,x4		" double-word 2
	eraq	flip_bits
	staq	pr1|2,x4
	ldaq	pr3|4,x4		" double-word 3
	eraq	flip_bits
	staq	pr1|4,x4
	ldaq	pr3|6,x4		" double-word 4
	eraq	flip_bits
	staq	pr1|6,x4
	adlx4	8,du		" step over words just processed
	cmpx4	pr5|0		" done with groups?
	tmi	copy_group_loop	" no, do it again
"
copy_last_group:
	cmpx1	0,du		" last group empty?
	tze	go_home		" yes
"
copy_last_loop:
	ldaq	pr3|0,x4
	eraq	flip_bits
	staq	pr1|0,x4
	adlx4	2,du		" step over words just processed
	sblx1	1,du		" count down remainder
	tpnz	copy_last_loop
	short_return
" 
"
"	This entrypoint takes an operand that is on the stack,
"	and overwrites it with the result.
"
in_place:
	epp4	pr0|count,*	" get pointer to count
	ldq	pr4|0		" get number of elements to process
	tze	go_home		" nothing to do?
	epp3	pr0|right_values_ptr,*	" get pointer to pointer to values
	epp3	pr3|0,*		" get pointer to values
	lda	0,dl		" initialize A
	qrs	1		" make count even
	lls	28		" make A have number of 512-element groups
				" now Q(0:7) has number of pairs in last group
	eax2	0,qu		" number of pairs in last group in X2
	eax3	0		" initialize
	eax4	2		" ..
	ldq	=o402400,du	" mask that turns 0 to 1 or back
	cmpa	0,dl		" any full groups?
	tze	last_group	" no, check last group
top:
	eax0	A+B		" count=256, A=1, B=1
	odd			" the rpd arguments must be a Y-pair
	rpdx	,4		" delta=4
	ersq	pr3|0,x3
	ersq	pr3|0,x4
	sbla	1,dl		" onto the next 256-element group
	tpnz	top		" if any
last_group:
	cmpx2	0,du		" any pairs in last group?
	tze	last_element	" no, see if one element left
	eax0	A+B,x2		" count=X2, A=1, B=1
	odd
	rpdx	,4		" delta=4
	ersq	pr3|0,x3		" X3 continues from last value
	ersq	pr3|0,x4		" ..
last_element:
	lda	pr4|0		" get back count
	cana	=o000001,dl	" odd?
	tze	go_home		" it was even all along
	ersq	pr3|0,x3		" rpd leaves it pointing to next
go_home:	short_return
"
	even
flip_bits:
	oct	402400000000,0
	end




		    apl_monadic_rho_.pl1            11/29/83  1638.6r w 11/29/83  1346.9      142632



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

/* This module implements monadic iota, monadic rho, and dyadic rho

   Created by G. Gordon Benedict on 06/23/73
   Modified 740910 by PG for error marker.
   Modified 780210 by PG to fix bug 278 by calling apl_push_stack_.
   Modified 780214 by PG to fix bug 312 (iEXPR, where expr is boolean, failed). Bug was introduced 780210.
   Modified 790313 by William M. York to fix bug 311 (some programs are
	double-word aligning character data, bug 364 (reshape does not check
	for negative args), and bug 332 (reshape computes number of elements
	in result before rounding left arguments).
   Modified 790316 by WMY to fix the last fix.
   Modified 790321 by WMY to fix bug 383 (reshape does not always re-protect very
	large result values).
*/

apl_monadic_rho_:
	procedure (operators_argument);

/* based */

declare	1 value_bead_overlay aligned based,	/* overlay so I can pass descriptor to procedure */
	  2 header aligned like general_bead,
	  2 total_data_elements fixed binary (21),
	  2 rhorho fixed binary,
	  2 data_pointer pointer unaligned,
	  2 rho_sub_1 fixed binary (21);

dcl	saved_left_arg (left_data_elements) fixed binary(21) based (saved_left_arg_ptr);
dcl	saved_left_arg_ptr pointer aligned init (null());

/* automatic */

dcl	(
	right_vb,				/* pointer to value bead for operand to right of operator */
	right_array,			/* ptr to right operand itself (data ptr from right v.b.) */
	left_vb,				/* ptr to v.b. to left of operator */
	left_array,			/* ptr to left operand */
	result_vb,			/* ptr to result v.b. */
	result_array			/* where result array will be stored */
			) pointer aligned;

dcl	(
	data_elements,			/* number of elements in result */
	right_data_elements,		/* number of elements in right array */
	left_data_elements			/* number of elements in left array */
			) fixed binary precision (21);

declare (	data_words_needed,			/* to tell stack_allocate_known how many words needed */
	number_to_copy,			/* number of words in word_copy_overlay for copying */
	words_needed,			/* words needed to get from value stack. set by stack_allocate_known */
	words_needed_in_bead		/* words needed in value bead to be allocated. */
			) fixed bin (19);

declare	(left_rhorho,			/* copy of value_bead.rhorho for left arg */
	right_rhorho,			/* same for right */
	rhorho,				/* used to tell stack_allocate_known how much space needed in value bead */
	rho_subscript,			/* steps thru rho arrays */
	count				/* random counter */
			) fixed binary;

dcl	numeric_result bit(1);

dcl	(single_element_fl_1,		/* used to hold one arg if it is a scalar and the other an array */
	fuzz,				/* copy of fuzz in ws_info for efficiency */
	integer_fuzz,			/* copy of integer_fuzz */
	result_accumulator,			/* another random temp */
	float_temp			/* temporary for float -> integer conversions */
		) float;

dcl	1 free_type aligned like general_bead.type;

/* entries */

declare	apl_iota_appendage_ entry (float bin (63), float bin (63), fixed bin (21), pointer);
declare	apl_rho_appendage_ entry (1 aligned like value_bead_overlay, 1 aligned like value_bead_overlay,
	     (8) fixed binary (35));
/* external static */

dcl	(apl_error_table_$rank,
	apl_error_table_$length,
	apl_error_table_$domain
	) fixed bin (35) ext static;			/* error codes */

/* builtins */

dcl	(
	abs,
	addrel,
	divide,
	fixed,
	float,
	floor,
	prod,
	rel,
	substr,
	size,
	string	) builtin;

declare	automatic_storage dimension (8) fixed binary (35);	/* temps for rho_appendage */

dcl	word_copy_overlay based dimension (number_to_copy) fixed bin (35);	/* for aggregate array copies */

dcl	numeric_datum_or1 (data_elements) based float;	/* numeric data but with an origin of 1 */

/* include files */

%include apl_number_data;
%include apl_operators_argument;
%include apl_bead_format;
%include apl_value_bead;
%include apl_ws_info;

/* The following subroutine is used to allocate a result value bead and a result array on the value stack.
   The rhorho of the result v.b. is given in variable rhorho, and the number of data elements in the result array
   is given in data_elements.  It sets result_vb to point to allocated value_bead and result_array to point to the
   array.  All fields in the value bead are filled in except value_bead.header.type and value_bead.rho.
   The bead is allocated on such a boundary that the next word after it (the first word of the result array) is
   doubleword aligned. */

stack_allocate_numeric:
	procedure ();

	numeric_result = "1"b;
	data_words_needed = size (numeric_datum_or1);	/* get result length from data_elements */
	goto stack_allocate_known_common;	/* common code */

stack_allocate_char:			/* entry to assume thing to alloc is char */
	entry ();

	numeric_result = "0"b;
	data_words_needed = size (character_string_overlay);


stack_allocate_known:
	entry ();				/* if caller has already loaded data_words_needed with number needed */

stack_allocate_known_common:		/* to transfer from above */
	number_of_dimensions = rhorho;
	words_needed_in_bead = size (value_bead);
	words_needed = words_needed_in_bead + data_words_needed + 1;	/* addition of 1 to doubleword align */
	result_vb = apl_push_stack_ (words_needed);
	result_array = addrel (result_vb, words_needed_in_bead);
	if numeric_result
	     then if substr (rel (result_array), 18, 1)
		then result_array = addrel (result_array, 1);		/* if next word is odd-aligned, bump by 1 word */

	result_vb -> value_bead.total_data_elements = data_elements;
	result_vb -> value_bead.rhorho = rhorho;		/* make result conform with original operand */
	result_vb -> value_bead.data_pointer = result_array;	/* pointer to actual array */
	operators_argument.result = result_vb;		/* let parse know where I put result when I return */

end stack_allocate_numeric;

/* procedure to extract information from operators_argument */

dyadic_extract:
	procedure ();

/* copy information from argument structure */

	left_vb = operators_argument.operands (1).value;
	left_array = left_vb -> value_bead.data_pointer;
	left_data_elements = left_vb -> value_bead.total_data_elements;
	left_rhorho = left_vb -> value_bead.rhorho;

monadic_extract:			/* repeat for right operand */
	entry ();

	right_vb = operators_argument.operands (2).value;
	right_array = right_vb -> value_bead.data_pointer;
	right_data_elements = right_vb -> value_bead.total_data_elements;
	right_rhorho = right_vb -> value_bead.rhorho;

	fuzz = ws_info.fuzz;		/* extract for efficiency */
	integer_fuzz = ws_info.integer_fuzz;
end dyadic_extract;

/* procedure to implement monadic rho */

	call monadic_extract ();

	if operators_argument.operands (2).on_stack	/* pop right arg so it can be overlayed */
	then ws_info.value_stack_ptr = right_vb;

	rhorho = 1;				/* rho operator always returns a vector */
	data_elements = right_rhorho;		/* as many elements as dimensions in argument */
	call stack_allocate_numeric ();			/* get storage for result */     
	do rho_subscript = right_rhorho - 1 to 0 by -1;	/* backwards because operands may overlay each other */
	     result_array -> numeric_datum (rho_subscript)	/* change each rho vector element in operand to a data element */
		= float (right_vb -> value_bead.rho (rho_subscript + 1), 63);
	end;
	result_vb -> value_bead.rho (1)		/* set vector bound */
	     = right_rhorho;
	string (result_vb -> value_bead.header.type) = integral_value_type;	/* always numeric */
	return;

/* this module implements the monadic iota operator in apl */

apl_monadic_iota_:
	entry (operators_argument);

	call monadic_extract ();
	string (free_type) = string (right_vb -> value_bead.header.type);	/* cpy type field for efficiency */

	if operators_argument.operands (2).on_stack /* pop right arg so it can be overlayed */
	then ws_info.value_stack_ptr = right_vb;

	if right_data_elements ^= 1 then goto length_error_right;	/* must be effective scalar */
	rhorho = right_data_elements;			/* as with rho, iota produces a vector always */
	if free_type.zero_or_one_value then do;	/* either 0 or 1, optimize */     
	     if right_array -> numeric_datum (0) = 0 then do;	/* iota 0 */
		data_elements,
		data_words_needed = 0;	/* nothing for null vector */
	     end;     
	     else do;			/* must be iota 1 */
		data_elements = 1;
		data_words_needed = size (numeric_datum_or1);
	     end;     
	     call stack_allocate_known ();     
	     string (result_vb -> value_bead.header.type) = zero_or_one_value_type;
	     result_vb -> value_bead.rho (1) = data_elements;
	     if data_elements = 0 then return;	/* none to fill in */
	     result_array -> numeric_datum (0) = 	/* put in index origin */
		ws_info.values.float_index_origin;
	     return;
	end;     
	if free_type.data_type.character_value then
	     goto domain_error_right;     
	result_accumulator = right_array -> numeric_datum (0);	/* put in temp for efficiency */
	if result_accumulator < 0 then goto domain_error_right;		/* cannot be negative */
	single_element_fl_1 = floor (result_accumulator + 0.5);	/* generate fixed number */
	if ^ free_type.data_type.integral_value then	/* check if integer */
	     if abs(single_element_fl_1 - result_accumulator) > integer_fuzz then	/* not integer */
		goto domain_error_right;
	if abs(single_element_fl_1) >= 1e21b then go to domain_error_right;
	data_elements = fixed (single_element_fl_1, 21, 0);	/* fix it to index easily */
	call stack_allocate_numeric ();		/* get storage for result */
	result_vb -> value_bead.rho (1) = data_elements;
	string (result_vb -> value_bead.header.type) = integral_value_type;	/* iota always returns integers */     
	call apl_iota_appendage_ (ws_info.values.float_index_origin, 1, data_elements, result_array);
	return;
/* This module implements the dyadic rho operator in apl */

apl_dyadic_rho_:
	entry (operators_argument);

/* extract data from args */
	call dyadic_extract ();

	if left_rhorho > 1 then
	     goto rank_error_left;

	data_elements,		/* set this so prod builtin below will work (dimension of numeric_datum_or1) */
	rhorho =			/* number of elements in left operand will be number of elements in result */
	     left_data_elements;

	saved_left_arg_ptr = null();

	if rhorho = 0 then
	     data_elements = 1;		/* null left vector means return first element of right */
	else do;
	     if ^ left_vb -> value_bead.header.type.data_type.numeric_value then
		goto domain_error_left;

	     saved_left_arg_ptr = apl_push_stack_ ((left_data_elements));

	     do count = lbound (left_array -> numeric_datum_or1, 1) to hbound (left_array -> numeric_datum_or1, 1);

	     /* Round and fix each element of the left argument. */

		if left_array -> numeric_datum_or1(count) + integer_fuzz < 0
		     then goto domain_error_left;	/* no negative args allowed */

		float_temp = floor (left_array -> numeric_datum_or1(count) + 0.5);
		if abs (float_temp - (left_array -> numeric_datum_or1(count))) > integer_fuzz
		     then goto domain_error_left;
		if abs (float_temp) >= 1e21b
		     then goto domain_error_left;
	     
		saved_left_arg(count) = fixed (float_temp, 21);
	     end;

	     data_elements = prod (saved_left_arg);

	end;

	/* get storage for bead and result at end of stack */

	if right_vb -> value_bead.header.type.data_type.character_value	/* char operand */
	     then call stack_allocate_char ();
	     else call stack_allocate_numeric ();

/* now copy rho vector from data in left operand */

	do rho_subscript = 1 to rhorho;

	     result_vb -> value_bead.rho (rho_subscript) = saved_left_arg(rho_subscript);
	end;

	string (result_vb -> value_bead.header.type) =	/* copy type from right hand arg */
	     string (right_vb -> value_bead.header.type);

	if data_elements = 0 then
	     goto copy_up_stack;			/* return null vector */

	if right_data_elements = 0 then
	     goto domain_error_right;		/* attempt to create a vector out of nothing (null right operand) */

	/* program to actually do rho */

	call apl_rho_appendage_ (right_vb -> value_bead_overlay, result_vb -> value_bead_overlay, automatic_storage);

	goto copy_up_stack;		/* goto routine to copy stuff up stack */

/* procedure to copy garbage up stack. assumes variable words_needed_in_bead contains number of words
   in bead, data_words_needed contains words in data */

copy_up_stack:		/* not really a subroutine, just gone to */

	if ^(operators_argument.operands (2).on_stack)	/* right is not on stack */
	     then if ^(operators_argument.operands (1).on_stack)	/* left is not on stack */
		then if saved_left_arg_ptr = null()	/* no temp storage */
		     then do;			/* nothing is above result on stack */
			operators_argument.result = result_vb;	/* leave answer where it is */
			return;
		     end;
		     else result_array = saved_left_arg_ptr; /* use result_array as temp ptr */
		else result_array = left_vb;	/* left is on stack and right is not -- overlay on left operand */
	     else result_array = right_vb;	/* right and left on stack */

	/* If result will not fit in current value stack, leave it where it
	   is, as it will just end up back where it started. */

	if fixed (rel (result_array), 18, 0) + words_needed > maximum_value_stack_size
	     then do;
		operators_argument.result = result_vb;	/* result will be where it is */
		return;
	     end;

	     /* otherwise unprotect all of the stack values */

	     else ws_info.value_stack_ptr = result_array;

/* the following kludges are used to copy the result operand lowest in the stack. Kludgy code using overlays
   and unspecs will be used until such time as the PL/I compiler can generate structure assignments
   without moving one bit at a time. */

/* now find the next doubleword boundary on which to put the result data. Note that if decimal data is
   someday used, alignment will not be necessary; in that case both the bead and data can be copied in one move */

	result_array = result_vb -> value_bead.data_pointer;

	right_vb = apl_push_stack_ (words_needed);
	number_to_copy = words_needed_in_bead;	/* the words in the bead for the result, from stack_allocate */
	right_vb -> word_copy_overlay =	/* copy words from bead to end bead */
	     result_vb -> word_copy_overlay;

	right_array = addrel (right_vb, words_needed_in_bead);	/* try next word after bead */
	if right_vb -> value_bead.numeric_value
	     then if substr (rel (right_array), 18, 1)		/* if a 1 in low order bit, odd aligned */
		then right_array = addrel (right_array, 1);
	right_vb -> value_bead.data_pointer = right_array;	/* pointer to data */

	number_to_copy = data_words_needed;			/* number of data words to move */
	if number_to_copy > 0 then				/* zero length arrays are illegal PL/I */
	     right_array -> word_copy_overlay =		/* move in data */
		result_array -> word_copy_overlay;
	operators_argument.result = right_vb;
	return;

/* places to go to when an error is found */

rank_error_left:
	operators_argument.error_code = apl_error_table_$rank;
	operators_argument.where_error = operators_argument.where_error + 1;
	return;

domain_error_left:
	operators_argument.where_error = operators_argument.where_error + 2;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$domain;
	return;

length_error_right:
	operators_argument.error_code = apl_error_table_$length;
	operators_argument.where_error = operators_argument.where_error - 1;
	return;

%include apl_push_stack_fcn;
end apl_monadic_rho_;




		    apl_operator_table_.alm         11/29/83  1638.6r w 11/29/83  1346.9      854091



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

	name	apl_operator_table_

" this is a read-only, shared data base which contains operator_bead's
" pointers to these beads are output as lexemes by apl_lex_.

" this file generated by make_apl_operator_table_.teco, written 7.4.73 by DAM
"	and modified 7.13.73 by DAM to change codes for reduction
"	and modified 8.23.73 by DAM for stop-trace control
"	Modified 790208 by WMY to add file system functions
"	Modified 790323 by PG to add CommaHyphen (catenate-first) operator
"	Modified 790327 by PG to add monadic not-equal for debugging interfaces
"	Modified 800129 by PG to fix 416 by turning on ignores_assignment flag
"		for qFNAMES and qFNUMS.
"	Modified 811210 by TO to add QuadCALL & QuadCALLSemicolon.
" 
" The following information can be used by the teco macro
" make_apl_operator_table_.teco to build a new alm source segment.
"
" Note that monadic equal and not-equal are nonstandard operators that
" interface to the apl debugging tools. They are undocumented.
"
" The fields are as follows:
" Name parse-type op1 op2 bits_for_lex,bits_for_parse
"
" LeftParen 4 0 0 0,0
" LeftBracket 6 1 0 0,0
" RightParen 5 1 0 0,0
" RightBracket 7 2 0 0,0
" RightOprBracket 8 3 0 0,0
" SDelta 2 100 0 special_assignment,stop_trace_control+semantics_valid_bit
" TDelta 2 101 0 special_assignment,stop_trace_control+semantics_valid_bit
" Diamond 10 0 0 0,0
" SemiColon 9 4 0 0,0
" NewLine 1 0 0 0,0
" LeftArrow 3 102 0 0,dyadic
" AssignSub 3 103 0 0,dyadic
" AssignIgnore 3 114 0 0,monadic
" Quad 2 0 0 special_assignment,quad+system_variable
" QuadQuote 2 1 0 special_assignment,quad+system_variable
" QuadCT 2 2 0 special_assignment,system_variable
" QuadIO 2 3 0 special_assignment,system_variable
" QuadLX 2 4 0 special_assignment,system_variable
" QuadPP 2 5 0 special_assignment,system_variable
" QuadPW 2 6 0 special_assignment,system_variable
" QuadRL 2 7 0 special_assignment,system_variable
" QuadAI 2 8 0 ignores_assignment,system_variable
" QuadLC 2 9 0 ignores_assignment,system_variable
" QuadTS 2 10 0 ignores_assignment,system_variable
" QuadTT 2 11 0 ignores_assignment,system_variable
" QuadUL 2 12 0 ignores_assignment,system_variable
" QuadWA 2 13 0 ignores_assignment,system_variable
" QuadWU 2 14 0 ignores_assignment,system_variable
" QuadCS 2 15 0 ignores_assignment,system_variable
" QuadIT 2 16 0 special_assignment,system_variable
" Plus 3 0 0 allow_product+allow_reduction,dyadic+monadic
" Minus 3 1 0 allow_product+allow_reduction,dyadic+monadic
" Times 3 2 0 allow_product+allow_reduction,dyadic+monadic
" Division 3 3 0 allow_product+allow_reduction,dyadic+monadic
" Ceiling 3 4 0 allow_product+allow_reduction,dyadic+monadic
" Floor 3 5 0 allow_product+allow_reduction,dyadic+monadic
" Star 3 6 0 allow_product+allow_reduction,dyadic+monadic
" CircleStar 3 7 0 allow_product+allow_reduction,dyadic+monadic
" VerticalBar 3 8 0 allow_product+allow_reduction,dyadic+monadic
" Exclamation 3 9 0 allow_product+allow_reduction,dyadic+monadic
" Circle 3 10 0 allow_product+allow_reduction,dyadic+monadic
" AndSign 3 11 0 allow_product+allow_reduction,dyadic
" OrSign 3 12 0 allow_product+allow_reduction,dyadic
" NandSign 3 13 0 allow_product+allow_reduction,dyadic
" NorSign 3 14 0 allow_product+allow_reduction,dyadic
" LessThan 3 15 0 allow_product+allow_reduction,dyadic
" LessOrEqual 3 16 0 allow_product+allow_reduction,dyadic
" Equal 3 17 0 allow_product+allow_reduction,dyadic+monadic
" GreaterOrEqual 3 18 0 allow_product+allow_reduction,dyadic
" GreaterThan 3 19 0 allow_product+allow_reduction,dyadic
" NotEqual 3 20 0 allow_product+allow_reduction,dyadic+monadic
" Rho 3 36 0 0,dyadic+monadic
" Comma 3 37 0 allow_brackets,dyadic+monadic
" Iota 3 38 0 0,dyadic+monadic
" UpArrow 3 39 0 allow_brackets,dyadic
" DownArrow 3 40 0 allow_brackets,dyadic
" GradeUp 3 41 0 allow_brackets,monadic
" GradeDown 3 42 0 allow_brackets,monadic
" Slash 3 43 0 allow_brackets,dyadic
" BackSlash 3 44 0 allow_brackets,dyadic
" CircleBar 3 45 0 allow_brackets,dyadic+monadic
" SlashHyphen 3 46 0 allow_brackets,dyadic
" BackSlashHyphen 3 47 0 allow_brackets,dyadic
" CircleHyphen 3 48 0 allow_brackets,monadic+dyadic
" CircleBackSlash 3 49 0 allow_brackets,dyadic+monadic
" Epsilon 3 50 0 0,dyadic
" DeCode 3 51 0 0,dyadic
" EnCode 3 52 0 0,dyadic
" ExecuteSign 3 53 0 0,monadic
" FormatSign 3 54 0 0,dyadic+monadic
" IBeam 3 55 0 0,monadic+dyadic
" Tilde 3 56 0 0,monadic
" Question 3 57 0 0,dyadic+monadic
" QuadCR 3 58 0 0,monadic
" QuadFX 3 59 0 0,monadic
" QuadEX 3 60 0 0,monadic
" QuadNL 3 61 0 0,monadic+dyadic
" QuadNC 3 62 0 0,monadic
" QuadDL 3 63 0 0,monadic
" QuadSVO 3 64 0 0,monadic+dyadic
" QuadSVC 3 65 0 0,monadic+dyadic
" QuadSVQ 3 66 0 0,monadic
" RightArrow 3 67 0 0,monadic
" Domino 3 68 0 0,monadic+dyadic
" QuadSVR 3 69 0 0,monadic
" QuadEC 3 70 0 0,monadic
" QuadAF 3 71 0 0,monadic
" SemiColonCons 3 72 0 0,dyadic
" QuadFADDACL 3 73 0 0,dyadic
" QuadFAPPEND 3 74 0 0,dyadic
" QuadFCREATE 3 75 0 0,dyadic
" QuadFDELETEACL 3 76 0 0,dyadic
" QuadFDROP 3 77 0 0,monadic
" QuadFERASE 3 78 0 0,dyadic
" QuadFHOLD 3 79 0 0,monadic
" QuadFLIB 3 80 0 0,monadic
" QuadFLIM 3 81 0 0,monadic
" QuadFLISTACL 3 82 0 0,monadic
" QuadFNAMES 3 83 0 ignores_assignment,system_variable
" QuadFNUMS 3 84 0 ignores_assignment,system_variable
" QuadFRDCI 3 85 0 0,monadic
" QuadFREAD 3 86 0 0,monadic
" QuadFRENAME 3 87 0 0,dyadic
" QuadFREPLACE 3 88 0 0,dyadic
" QuadFSETACL 3 89 0 0,dyadic
" QuadFSIZE 3 90 0 0,monadic
" QuadFSTIE 3 91 0 0,dyadic
" QuadFTIE 3 92 0 0,dyadic
" QuadFUNTIE 3 121 0 0,monadic
" CommaHyphen 3 122 0 allow_brackets,dyadic
" QuadCALL    3 123 0 0 monadic
" QuadCALLSemicolon 3 124 0 0,dyadic
" 
	use	op_index
	segdef	apl_operator_table_
"
apl_operator_table_:
op_index_0:

	bss	,512		space for operator indices for all chars, init 0.


	use	op_bead_table

	segdef	operator_bead_table
operator_bead_table:

	" operator beads begin here, indices into this table are in the preceding section


	use	inner_prod_tbl

	segdef	inner_product_table		operator beads for all possible inner products
inner_product_table:

	zero	0,inner_product_max_code	maximum index in square array following (generated later on)


"" this concludes initial setup of location counters, now
"" we get some handy include files.

	include	apl_operator_bead_bits
	include	apl_character_codes
	include	apl_lex_pseudo_chars

"" 
"" now we are ready to do the real table generation.
"" the source file apl_operator_table_.src is munged to generate all the operator beads.

	use	op_index
	org	LeftParen
	zero	0,(.LeftParen-operator_bead_table)/3
	use	op_bead_table
.LeftParen:	vfd	18/operator_bead_type,18/0,18/0,9/0,9/0
	dec	4

	use	op_index
	org	LeftBracket
	zero	0,(.LeftBracket-operator_bead_table)/3
	use	op_bead_table
.LeftBracket:	vfd	18/operator_bead_type,18/0,18/0,9/0,9/1
	dec	6

	use	op_index
	org	RightParen
	zero	0,(.RightParen-operator_bead_table)/3
	use	op_bead_table
.RightParen:	vfd	18/operator_bead_type,18/0,18/0,9/0,9/1
	dec	5

	use	op_index
	org	RightBracket
	zero	0,(.RightBracket-operator_bead_table)/3
	use	op_bead_table
.RightBracket:	vfd	18/operator_bead_type,18/0,18/0,9/0,9/2
	dec	7

	use	op_index
	org	RightOprBracket
	zero	0,(.RightOprBracket-operator_bead_table)/3
	use	op_bead_table
.RightOprBracket:	vfd	18/operator_bead_type,18/0,18/0,9/0,9/3
	dec	8

	use	op_index
	org	SDelta
	zero	0,(.SDelta-operator_bead_table)/3
	use	op_bead_table
.SDelta:	vfd	18/operator_bead_type,18/special_assignment,18/stop_trace_control+semantics_valid_bit,9/0,9/100
	dec	2
	vfd	18/operator_bead_type,18/0,18/stop_trace_control+semantics_valid_bit+monadic,9/0,9/112	assignment
	dec	3

	use	op_index
	org	TDelta
	zero	0,(.TDelta-operator_bead_table)/3
	use	op_bead_table
.TDelta:	vfd	18/operator_bead_type,18/special_assignment,18/stop_trace_control+semantics_valid_bit,9/0,9/101
	dec	2
	vfd	18/operator_bead_type,18/0,18/stop_trace_control+semantics_valid_bit+monadic,9/0,9/113	assignment
	dec	3

	use	op_index
	org	Diamond
	zero	0,(.Diamond-operator_bead_table)/3
	use	op_bead_table
.Diamond:	vfd	18/operator_bead_type,18/0,18/0,9/0,9/0
	dec	10

	use	op_index
	org	SemiColon
	zero	0,(.SemiColon-operator_bead_table)/3
	use	op_bead_table
.SemiColon:	vfd	18/operator_bead_type,18/0,18/0,9/0,9/4
	dec	9

	use	op_index
	org	NewLine
	zero	0,(.NewLine-operator_bead_table)/3
	use	op_bead_table
.NewLine:	vfd	18/operator_bead_type,18/0,18/0,9/0,9/0
	dec	1

	use	op_index
	org	LeftArrow
	zero	0,(.LeftArrow-operator_bead_table)/3
	use	op_bead_table
.LeftArrow:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/102
	dec	3

	use	op_index
	org	AssignSub
	zero	0,(.AssignSub-operator_bead_table)/3
	use	op_bead_table
.AssignSub:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/103
	dec	3

	use	op_index
	org	AssignIgnore
	zero	0,(.AssignIgnore-operator_bead_table)/3
	use	op_bead_table
.AssignIgnore:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/114
	dec	3

	use	op_index
	org	Quad
	zero	0,(.Quad-operator_bead_table)/3
	use	op_bead_table
.Quad:	vfd	18/operator_bead_type,18/special_assignment,18/quad+system_variable,9/0,9/0
	dec	2
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/104	assignment
	dec	3

	use	op_index
	org	QuadQuote
	zero	0,(.QuadQuote-operator_bead_table)/3
	use	op_bead_table
.QuadQuote:	vfd	18/operator_bead_type,18/special_assignment,18/quad+system_variable,9/0,9/1
	dec	2
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/105	assignment
	dec	3

	use	op_index
	org	QuadCT
	zero	0,(.QuadCT-operator_bead_table)/3
	use	op_bead_table
.QuadCT:	vfd	18/operator_bead_type,18/special_assignment,18/system_variable,9/0,9/2
	dec	2
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/106	assignment
	dec	3

	use	op_index
	org	QuadIO
	zero	0,(.QuadIO-operator_bead_table)/3
	use	op_bead_table
.QuadIO:	vfd	18/operator_bead_type,18/special_assignment,18/system_variable,9/0,9/3
	dec	2
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/107	assignment
	dec	3

	use	op_index
	org	QuadLX
	zero	0,(.QuadLX-operator_bead_table)/3
	use	op_bead_table
.QuadLX:	vfd	18/operator_bead_type,18/special_assignment,18/system_variable,9/0,9/4
	dec	2
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/108	assignment
	dec	3

	use	op_index
	org	QuadPP
	zero	0,(.QuadPP-operator_bead_table)/3
	use	op_bead_table
.QuadPP:	vfd	18/operator_bead_type,18/special_assignment,18/system_variable,9/0,9/5
	dec	2
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/109	assignment
	dec	3

	use	op_index
	org	QuadPW
	zero	0,(.QuadPW-operator_bead_table)/3
	use	op_bead_table
.QuadPW:	vfd	18/operator_bead_type,18/special_assignment,18/system_variable,9/0,9/6
	dec	2
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/110	assignment
	dec	3

	use	op_index
	org	QuadRL
	zero	0,(.QuadRL-operator_bead_table)/3
	use	op_bead_table
.QuadRL:	vfd	18/operator_bead_type,18/special_assignment,18/system_variable,9/0,9/7
	dec	2
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/111	assignment
	dec	3

	use	op_index
	org	QuadAI
	zero	0,(.QuadAI-operator_bead_table)/3
	use	op_bead_table
.QuadAI:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/8
	dec	2

	use	op_index
	org	QuadLC
	zero	0,(.QuadLC-operator_bead_table)/3
	use	op_bead_table
.QuadLC:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/9
	dec	2

	use	op_index
	org	QuadTS
	zero	0,(.QuadTS-operator_bead_table)/3
	use	op_bead_table
.QuadTS:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/10
	dec	2

	use	op_index
	org	QuadTT
	zero	0,(.QuadTT-operator_bead_table)/3
	use	op_bead_table
.QuadTT:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/11
	dec	2

	use	op_index
	org	QuadUL
	zero	0,(.QuadUL-operator_bead_table)/3
	use	op_bead_table
.QuadUL:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/12
	dec	2

	use	op_index
	org	QuadWA
	zero	0,(.QuadWA-operator_bead_table)/3
	use	op_bead_table
.QuadWA:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/13
	dec	2

	use	op_index
	org	QuadWU
	zero	0,(.QuadWU-operator_bead_table)/3
	use	op_bead_table
.QuadWU:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/14
	dec	2

	use	op_index
	org	QuadCS
	zero	0,(.QuadCS-operator_bead_table)/3
	use	op_bead_table
.QuadCS:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/15
	dec	2

	use	op_index
	org	QuadIT
	zero	0,(.QuadIT-operator_bead_table)/3
	use	op_bead_table
.QuadIT:	vfd	18/operator_bead_type,18/special_assignment,18/system_variable,9/0,9/16
	dec	2
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/120	assignment
	dec	3

	use	op_index
	org	Plus
	zero	0,(.Plus-operator_bead_table)/3
	use	op_bead_table
.Plus:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/0
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/0,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/0,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/0,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/0,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/98
	dec	3

	use	op_index
	org	Minus
	zero	0,(.Minus-operator_bead_table)/3
	use	op_bead_table
.Minus:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/1
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/1,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/1,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/1,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/1,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/1,9/98
	dec	3

	use	op_index
	org	Times
	zero	0,(.Times-operator_bead_table)/3
	use	op_bead_table
.Times:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/2
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/2,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/2,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/2,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/2,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/2,9/98
	dec	3

	use	op_index
	org	Division
	zero	0,(.Division-operator_bead_table)/3
	use	op_bead_table
.Division:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/3
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/3,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/3,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/3,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/3,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/3,9/98
	dec	3

	use	op_index
	org	Ceiling
	zero	0,(.Ceiling-operator_bead_table)/3
	use	op_bead_table
.Ceiling:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/4
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/4,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/4,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/4,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/4,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/4,9/98
	dec	3

	use	op_index
	org	Floor
	zero	0,(.Floor-operator_bead_table)/3
	use	op_bead_table
.Floor:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/5
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/5,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/5,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/5,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/5,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/5,9/98
	dec	3

	use	op_index
	org	Star
	zero	0,(.Star-operator_bead_table)/3
	use	op_bead_table
.Star:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/6
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/6,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/6,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/6,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/6,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/6,9/98
	dec	3

	use	op_index
	org	CircleStar
	zero	0,(.CircleStar-operator_bead_table)/3
	use	op_bead_table
.CircleStar:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/7
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/7,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/7,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/7,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/7,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/7,9/98
	dec	3

	use	op_index
	org	VerticalBar
	zero	0,(.VerticalBar-operator_bead_table)/3
	use	op_bead_table
.VerticalBar:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/8
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/8,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/8,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/8,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/8,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/8,9/98
	dec	3

	use	op_index
	org	Exclamation
	zero	0,(.Exclamation-operator_bead_table)/3
	use	op_bead_table
.Exclamation:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/9
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/9,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/9,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/9,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/9,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/9,9/98
	dec	3

	use	op_index
	org	Circle
	zero	0,(.Circle-operator_bead_table)/3
	use	op_bead_table
.Circle:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/10
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/10,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/10,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/10,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/10,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/10,9/98
	dec	3

	use	op_index
	org	AndSign
	zero	0,(.AndSign-operator_bead_table)/3
	use	op_bead_table
.AndSign:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic,9/0,9/11
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/11,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/11,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/11,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/11,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/11,9/98
	dec	3

	use	op_index
	org	OrSign
	zero	0,(.OrSign-operator_bead_table)/3
	use	op_bead_table
.OrSign:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic,9/0,9/12
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/12,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/12,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/12,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/12,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/12,9/98
	dec	3

	use	op_index
	org	NandSign
	zero	0,(.NandSign-operator_bead_table)/3
	use	op_bead_table
.NandSign:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic,9/0,9/13
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/13,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/13,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/13,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/13,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/13,9/98
	dec	3

	use	op_index
	org	NorSign
	zero	0,(.NorSign-operator_bead_table)/3
	use	op_bead_table
.NorSign:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic,9/0,9/14
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/14,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/14,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/14,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/14,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/14,9/98
	dec	3

	use	op_index
	org	LessThan
	zero	0,(.LessThan-operator_bead_table)/3
	use	op_bead_table
.LessThan:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic,9/0,9/15
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/15,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/15,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/15,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/15,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/15,9/98
	dec	3

	use	op_index
	org	LessOrEqual
	zero	0,(.LessOrEqual-operator_bead_table)/3
	use	op_bead_table
.LessOrEqual:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic,9/0,9/16
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/16,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/16,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/16,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/16,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/16,9/98
	dec	3

	use	op_index
	org	Equal
	zero	0,(.Equal-operator_bead_table)/3
	use	op_bead_table
.Equal:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/17
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/17,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/17,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/17,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/17,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/17,9/98
	dec	3

	use	op_index
	org	GreaterOrEqual
	zero	0,(.GreaterOrEqual-operator_bead_table)/3
	use	op_bead_table
.GreaterOrEqual:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic,9/0,9/18
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/18,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/18,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/18,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/18,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/18,9/98
	dec	3

	use	op_index
	org	GreaterThan
	zero	0,(.GreaterThan-operator_bead_table)/3
	use	op_bead_table
.GreaterThan:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic,9/0,9/19
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/19,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/19,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/19,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/19,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/19,9/98
	dec	3

	use	op_index
	org	NotEqual
	zero	0,(.NotEqual-operator_bead_table)/3
	use	op_bead_table
.NotEqual:	vfd	18/operator_bead_type,18/allow_product+allow_reduction,18/dyadic+monadic,9/0,9/20
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/20,9/94
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/20,9/95
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/20,9/96
	dec	3
	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/20,9/97
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/20,9/98
	dec	3

	use	op_index
	org	Rho
	zero	0,(.Rho-operator_bead_table)/3
	use	op_bead_table
.Rho:	vfd	18/operator_bead_type,18/0,18/dyadic+monadic,9/0,9/36
	dec	3

	use	op_index
	org	Comma
	zero	0,(.Comma-operator_bead_table)/3
	use	op_bead_table
.Comma:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic+monadic,9/0,9/37
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic+monadic,9/0,9/37
	dec	3

	use	op_index
	org	Iota
	zero	0,(.Iota-operator_bead_table)/3
	use	op_bead_table
.Iota:	vfd	18/operator_bead_type,18/0,18/dyadic+monadic,9/0,9/38
	dec	3

	use	op_index
	org	UpArrow
	zero	0,(.UpArrow-operator_bead_table)/3
	use	op_bead_table
.UpArrow:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic,9/0,9/39
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/39
	dec	3

	use	op_index
	org	DownArrow
	zero	0,(.DownArrow-operator_bead_table)/3
	use	op_bead_table
.DownArrow:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic,9/0,9/40
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/40
	dec	3

	use	op_index
	org	GradeUp
	zero	0,(.GradeUp-operator_bead_table)/3
	use	op_bead_table
.GradeUp:	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/0,9/41
	dec	3
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/41
	dec	3

	use	op_index
	org	GradeDown
	zero	0,(.GradeDown-operator_bead_table)/3
	use	op_bead_table
.GradeDown:	vfd	18/operator_bead_type,18/allow_brackets,18/monadic,9/0,9/42
	dec	3
	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/42
	dec	3

	use	op_index
	org	Slash
	zero	0,(.Slash-operator_bead_table)/3
	use	op_bead_table
.Slash:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic,9/0,9/43
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/43
	dec	3

	use	op_index
	org	BackSlash
	zero	0,(.BackSlash-operator_bead_table)/3
	use	op_bead_table
.BackSlash:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic,9/0,9/44
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/44
	dec	3

	use	op_index
	org	CircleBar
	zero	0,(.CircleBar-operator_bead_table)/3
	use	op_bead_table
.CircleBar:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic+monadic,9/0,9/45
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic+monadic,9/0,9/45
	dec	3

	use	op_index
	org	SlashHyphen
	zero	0,(.SlashHyphen-operator_bead_table)/3
	use	op_bead_table
.SlashHyphen:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic,9/0,9/46
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/46
	dec	3

	use	op_index
	org	BackSlashHyphen
	zero	0,(.BackSlashHyphen-operator_bead_table)/3
	use	op_bead_table
.BackSlashHyphen:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic,9/0,9/47
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/47
	dec	3

	use	op_index
	org	CircleHyphen
	zero	0,(.CircleHyphen-operator_bead_table)/3
	use	op_bead_table
.CircleHyphen:	vfd	18/operator_bead_type,18/allow_brackets,18/monadic+dyadic,9/0,9/48
	dec	3
	vfd	18/operator_bead_type,18/0,18/monadic+dyadic,9/0,9/48
	dec	3

	use	op_index
	org	CircleBackSlash
	zero	0,(.CircleBackSlash-operator_bead_table)/3
	use	op_bead_table
.CircleBackSlash:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic+monadic,9/0,9/49
	dec	3
	vfd	18/operator_bead_type,18/0,18/dyadic+monadic,9/0,9/49
	dec	3

	use	op_index
	org	Epsilon
	zero	0,(.Epsilon-operator_bead_table)/3
	use	op_bead_table
.Epsilon:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/50
	dec	3

	use	op_index
	org	DeCode
	zero	0,(.DeCode-operator_bead_table)/3
	use	op_bead_table
.DeCode:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/51
	dec	3

	use	op_index
	org	EnCode
	zero	0,(.EnCode-operator_bead_table)/3
	use	op_bead_table
.EnCode:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/52
	dec	3

	use	op_index
	org	ExecuteSign
	zero	0,(.ExecuteSign-operator_bead_table)/3
	use	op_bead_table
.ExecuteSign:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/53
	dec	3

	use	op_index
	org	FormatSign
	zero	0,(.FormatSign-operator_bead_table)/3
	use	op_bead_table
.FormatSign:	vfd	18/operator_bead_type,18/0,18/dyadic+monadic,9/0,9/54
	dec	3

	use	op_index
	org	IBeam
	zero	0,(.IBeam-operator_bead_table)/3
	use	op_bead_table
.IBeam:	vfd	18/operator_bead_type,18/0,18/monadic+dyadic,9/0,9/55
	dec	3

	use	op_index
	org	Tilde
	zero	0,(.Tilde-operator_bead_table)/3
	use	op_bead_table
.Tilde:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/56
	dec	3

	use	op_index
	org	Question
	zero	0,(.Question-operator_bead_table)/3
	use	op_bead_table
.Question:	vfd	18/operator_bead_type,18/0,18/dyadic+monadic,9/0,9/57
	dec	3

	use	op_index
	org	QuadCR
	zero	0,(.QuadCR-operator_bead_table)/3
	use	op_bead_table
.QuadCR:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/58
	dec	3

	use	op_index
	org	QuadFX
	zero	0,(.QuadFX-operator_bead_table)/3
	use	op_bead_table
.QuadFX:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/59
	dec	3

	use	op_index
	org	QuadEX
	zero	0,(.QuadEX-operator_bead_table)/3
	use	op_bead_table
.QuadEX:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/60
	dec	3

	use	op_index
	org	QuadNL
	zero	0,(.QuadNL-operator_bead_table)/3
	use	op_bead_table
.QuadNL:	vfd	18/operator_bead_type,18/0,18/monadic+dyadic,9/0,9/61
	dec	3

	use	op_index
	org	QuadNC
	zero	0,(.QuadNC-operator_bead_table)/3
	use	op_bead_table
.QuadNC:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/62
	dec	3

	use	op_index
	org	QuadDL
	zero	0,(.QuadDL-operator_bead_table)/3
	use	op_bead_table
.QuadDL:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/63
	dec	3

	use	op_index
	org	QuadSVO
	zero	0,(.QuadSVO-operator_bead_table)/3
	use	op_bead_table
.QuadSVO:	vfd	18/operator_bead_type,18/0,18/monadic+dyadic,9/0,9/64
	dec	3

	use	op_index
	org	QuadSVC
	zero	0,(.QuadSVC-operator_bead_table)/3
	use	op_bead_table
.QuadSVC:	vfd	18/operator_bead_type,18/0,18/monadic+dyadic,9/0,9/65
	dec	3

	use	op_index
	org	QuadSVQ
	zero	0,(.QuadSVQ-operator_bead_table)/3
	use	op_bead_table
.QuadSVQ:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/66
	dec	3

	use	op_index
	org	RightArrow
	zero	0,(.RightArrow-operator_bead_table)/3
	use	op_bead_table
.RightArrow:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/67
	dec	3

	use	op_index
	org	Domino
	zero	0,(.Domino-operator_bead_table)/3
	use	op_bead_table
.Domino:	vfd	18/operator_bead_type,18/0,18/monadic+dyadic,9/0,9/68
	dec	3

	use	op_index
	org	QuadSVR
	zero	0,(.QuadSVR-operator_bead_table)/3
	use	op_bead_table
.QuadSVR:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/69
	dec	3

	use	op_index
	org	QuadEC
	zero	0,(.QuadEC-operator_bead_table)/3
	use	op_bead_table
.QuadEC:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/70
	dec	3

	use	op_index
	org	QuadAF
	zero	0,(.QuadAF-operator_bead_table)/3
	use	op_bead_table
.QuadAF:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/71
	dec	3

	use	op_index
	org	SemiColonCons
	zero	0,(.SemiColonCons-operator_bead_table)/3
	use	op_bead_table
.SemiColonCons:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/72
	dec	3

	use	op_index
	org	QuadFADDACL
	zero	0,(.QuadFADDACL-operator_bead_table)/3
	use	op_bead_table
.QuadFADDACL:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/73
	dec	3

	use	op_index
	org	QuadFAPPEND
	zero	0,(.QuadFAPPEND-operator_bead_table)/3
	use	op_bead_table
.QuadFAPPEND:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/74
	dec	3

	use	op_index
	org	QuadFCREATE
	zero	0,(.QuadFCREATE-operator_bead_table)/3
	use	op_bead_table
.QuadFCREATE:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/75
	dec	3

	use	op_index
	org	QuadFDELETEACL
	zero	0,(.QuadFDELETEACL-operator_bead_table)/3
	use	op_bead_table
.QuadFDELETEACL:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/76
	dec	3

	use	op_index
	org	QuadFDROP
	zero	0,(.QuadFDROP-operator_bead_table)/3
	use	op_bead_table
.QuadFDROP:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/77
	dec	3

	use	op_index
	org	QuadFERASE
	zero	0,(.QuadFERASE-operator_bead_table)/3
	use	op_bead_table
.QuadFERASE:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/78
	dec	3

	use	op_index
	org	QuadFHOLD
	zero	0,(.QuadFHOLD-operator_bead_table)/3
	use	op_bead_table
.QuadFHOLD:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/79
	dec	3

	use	op_index
	org	QuadFLIB
	zero	0,(.QuadFLIB-operator_bead_table)/3
	use	op_bead_table
.QuadFLIB:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/80
	dec	3

	use	op_index
	org	QuadFLIM
	zero	0,(.QuadFLIM-operator_bead_table)/3
	use	op_bead_table
.QuadFLIM:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/81
	dec	3

	use	op_index
	org	QuadFLISTACL
	zero	0,(.QuadFLISTACL-operator_bead_table)/3
	use	op_bead_table
.QuadFLISTACL:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/82
	dec	3

	use	op_index
	org	QuadFNAMES
	zero	0,(.QuadFNAMES-operator_bead_table)/3
	use	op_bead_table
.QuadFNAMES:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/83
	dec	3

	use	op_index
	org	QuadFNUMS
	zero	0,(.QuadFNUMS-operator_bead_table)/3
	use	op_bead_table
.QuadFNUMS:	vfd	18/operator_bead_type,18/ignores_assignment,18/system_variable,9/0,9/84
	dec	3

	use	op_index
	org	QuadFRDCI
	zero	0,(.QuadFRDCI-operator_bead_table)/3
	use	op_bead_table
.QuadFRDCI:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/85
	dec	3

	use	op_index
	org	QuadFREAD
	zero	0,(.QuadFREAD-operator_bead_table)/3
	use	op_bead_table
.QuadFREAD:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/86
	dec	3

	use	op_index
	org	QuadFRENAME
	zero	0,(.QuadFRENAME-operator_bead_table)/3
	use	op_bead_table
.QuadFRENAME:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/87
	dec	3

	use	op_index
	org	QuadFREPLACE
	zero	0,(.QuadFREPLACE-operator_bead_table)/3
	use	op_bead_table
.QuadFREPLACE:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/88
	dec	3

	use	op_index
	org	QuadFSETACL
	zero	0,(.QuadFSETACL-operator_bead_table)/3
	use	op_bead_table
.QuadFSETACL:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/89
	dec	3

	use	op_index
	org	QuadFSIZE
	zero	0,(.QuadFSIZE-operator_bead_table)/3
	use	op_bead_table
.QuadFSIZE:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/90
	dec	3

	use	op_index
	org	QuadFSTIE
	zero	0,(.QuadFSTIE-operator_bead_table)/3
	use	op_bead_table
.QuadFSTIE:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/91
	dec	3

	use	op_index
	org	QuadFTIE
	zero	0,(.QuadFTIE-operator_bead_table)/3
	use	op_bead_table
.QuadFTIE:	vfd	18/operator_bead_type,18/0,18/dyadic,9/0,9/92
	dec	3

	use	op_index
	org	QuadFUNTIE
	zero	0,(.QuadFUNTIE-operator_bead_table)/3
	use	op_bead_table
.QuadFUNTIE:	vfd	18/operator_bead_type,18/0,18/monadic,9/0,9/121
	dec	3

	use	op_index
	org	CommaHyphen
	zero	0,(.CommaHyphen-operator_bead_table)/3
	use	op_bead_table
.CommaHyphen:	vfd	18/operator_bead_type,18/allow_brackets,18/dyadic,9/0,9/122
	dec	3

	use	op_index
	org	QuadCALL
	zero	0,(.QuadCALL-operator_bead_table)/3
	use	op_bead_table
.QuadCALL:	vfd 18/operator_bead_type,18/0,18/monadic,9/0,9/123
	dec	3

	use	op_index
	org	QuadCALLSemicolon
	zero	0,(.QuadCALLSemicolon-operator_bead_table)/3
	use	op_bead_table
.QuadCALLSemicolon:	vfd 18/operator_bead_type,18/0,18/dyadic,9/0,9/124
	dec	3


"" 
"" Now generate the inner product table, which has lexemes for
"" all possible pairs of operators possessing the allow_product attribute

	equ	inner_product_max_code,20

	use	inner_prod_tbl

	equ	z,*-inner_product_table	origin of array to be built up
					"non-relocatable for kludgey org pseudo-op

	org	z+(0*(inner_product_max_code+1)+0)*3	Plus.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/0
	dec 	3

	org	z+(0*(inner_product_max_code+1)+1)*3	Plus.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/1
	dec 	3

	org	z+(0*(inner_product_max_code+1)+2)*3	Plus.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/2
	dec 	3

	org	z+(0*(inner_product_max_code+1)+3)*3	Plus.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/3
	dec 	3

	org	z+(0*(inner_product_max_code+1)+4)*3	Plus.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/4
	dec 	3

	org	z+(0*(inner_product_max_code+1)+5)*3	Plus.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/5
	dec 	3

	org	z+(0*(inner_product_max_code+1)+6)*3	Plus.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/6
	dec 	3

	org	z+(0*(inner_product_max_code+1)+7)*3	Plus.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/7
	dec 	3

	org	z+(0*(inner_product_max_code+1)+8)*3	Plus.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/8
	dec 	3

	org	z+(0*(inner_product_max_code+1)+9)*3	Plus.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/9
	dec 	3

	org	z+(0*(inner_product_max_code+1)+10)*3	Plus.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/10
	dec 	3

	org	z+(0*(inner_product_max_code+1)+11)*3	Plus.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/11
	dec 	3

	org	z+(0*(inner_product_max_code+1)+12)*3	Plus.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/12
	dec 	3

	org	z+(0*(inner_product_max_code+1)+13)*3	Plus.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/13
	dec 	3

	org	z+(0*(inner_product_max_code+1)+14)*3	Plus.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/14
	dec 	3

	org	z+(0*(inner_product_max_code+1)+15)*3	Plus.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/15
	dec 	3

	org	z+(0*(inner_product_max_code+1)+16)*3	Plus.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/16
	dec 	3

	org	z+(0*(inner_product_max_code+1)+17)*3	Plus.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/17
	dec 	3

	org	z+(0*(inner_product_max_code+1)+18)*3	Plus.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/18
	dec 	3

	org	z+(0*(inner_product_max_code+1)+19)*3	Plus.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/19
	dec 	3

	org	z+(0*(inner_product_max_code+1)+20)*3	Plus.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/0,9/20
	dec 	3

	org	z+(1*(inner_product_max_code+1)+0)*3	Minus.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/0
	dec 	3

	org	z+(1*(inner_product_max_code+1)+1)*3	Minus.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/1
	dec 	3

	org	z+(1*(inner_product_max_code+1)+2)*3	Minus.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/2
	dec 	3

	org	z+(1*(inner_product_max_code+1)+3)*3	Minus.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/3
	dec 	3

	org	z+(1*(inner_product_max_code+1)+4)*3	Minus.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/4
	dec 	3

	org	z+(1*(inner_product_max_code+1)+5)*3	Minus.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/5
	dec 	3

	org	z+(1*(inner_product_max_code+1)+6)*3	Minus.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/6
	dec 	3

	org	z+(1*(inner_product_max_code+1)+7)*3	Minus.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/7
	dec 	3

	org	z+(1*(inner_product_max_code+1)+8)*3	Minus.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/8
	dec 	3

	org	z+(1*(inner_product_max_code+1)+9)*3	Minus.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/9
	dec 	3

	org	z+(1*(inner_product_max_code+1)+10)*3	Minus.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/10
	dec 	3

	org	z+(1*(inner_product_max_code+1)+11)*3	Minus.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/11
	dec 	3

	org	z+(1*(inner_product_max_code+1)+12)*3	Minus.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/12
	dec 	3

	org	z+(1*(inner_product_max_code+1)+13)*3	Minus.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/13
	dec 	3

	org	z+(1*(inner_product_max_code+1)+14)*3	Minus.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/14
	dec 	3

	org	z+(1*(inner_product_max_code+1)+15)*3	Minus.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/15
	dec 	3

	org	z+(1*(inner_product_max_code+1)+16)*3	Minus.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/16
	dec 	3

	org	z+(1*(inner_product_max_code+1)+17)*3	Minus.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/17
	dec 	3

	org	z+(1*(inner_product_max_code+1)+18)*3	Minus.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/18
	dec 	3

	org	z+(1*(inner_product_max_code+1)+19)*3	Minus.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/19
	dec 	3

	org	z+(1*(inner_product_max_code+1)+20)*3	Minus.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/1,9/20
	dec 	3

	org	z+(2*(inner_product_max_code+1)+0)*3	Times.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/0
	dec 	3

	org	z+(2*(inner_product_max_code+1)+1)*3	Times.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/1
	dec 	3

	org	z+(2*(inner_product_max_code+1)+2)*3	Times.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/2
	dec 	3

	org	z+(2*(inner_product_max_code+1)+3)*3	Times.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/3
	dec 	3

	org	z+(2*(inner_product_max_code+1)+4)*3	Times.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/4
	dec 	3

	org	z+(2*(inner_product_max_code+1)+5)*3	Times.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/5
	dec 	3

	org	z+(2*(inner_product_max_code+1)+6)*3	Times.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/6
	dec 	3

	org	z+(2*(inner_product_max_code+1)+7)*3	Times.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/7
	dec 	3

	org	z+(2*(inner_product_max_code+1)+8)*3	Times.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/8
	dec 	3

	org	z+(2*(inner_product_max_code+1)+9)*3	Times.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/9
	dec 	3

	org	z+(2*(inner_product_max_code+1)+10)*3	Times.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/10
	dec 	3

	org	z+(2*(inner_product_max_code+1)+11)*3	Times.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/11
	dec 	3

	org	z+(2*(inner_product_max_code+1)+12)*3	Times.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/12
	dec 	3

	org	z+(2*(inner_product_max_code+1)+13)*3	Times.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/13
	dec 	3

	org	z+(2*(inner_product_max_code+1)+14)*3	Times.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/14
	dec 	3

	org	z+(2*(inner_product_max_code+1)+15)*3	Times.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/15
	dec 	3

	org	z+(2*(inner_product_max_code+1)+16)*3	Times.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/16
	dec 	3

	org	z+(2*(inner_product_max_code+1)+17)*3	Times.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/17
	dec 	3

	org	z+(2*(inner_product_max_code+1)+18)*3	Times.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/18
	dec 	3

	org	z+(2*(inner_product_max_code+1)+19)*3	Times.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/19
	dec 	3

	org	z+(2*(inner_product_max_code+1)+20)*3	Times.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/2,9/20
	dec 	3

	org	z+(3*(inner_product_max_code+1)+0)*3	Division.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/0
	dec 	3

	org	z+(3*(inner_product_max_code+1)+1)*3	Division.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/1
	dec 	3

	org	z+(3*(inner_product_max_code+1)+2)*3	Division.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/2
	dec 	3

	org	z+(3*(inner_product_max_code+1)+3)*3	Division.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/3
	dec 	3

	org	z+(3*(inner_product_max_code+1)+4)*3	Division.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/4
	dec 	3

	org	z+(3*(inner_product_max_code+1)+5)*3	Division.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/5
	dec 	3

	org	z+(3*(inner_product_max_code+1)+6)*3	Division.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/6
	dec 	3

	org	z+(3*(inner_product_max_code+1)+7)*3	Division.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/7
	dec 	3

	org	z+(3*(inner_product_max_code+1)+8)*3	Division.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/8
	dec 	3

	org	z+(3*(inner_product_max_code+1)+9)*3	Division.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/9
	dec 	3

	org	z+(3*(inner_product_max_code+1)+10)*3	Division.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/10
	dec 	3

	org	z+(3*(inner_product_max_code+1)+11)*3	Division.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/11
	dec 	3

	org	z+(3*(inner_product_max_code+1)+12)*3	Division.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/12
	dec 	3

	org	z+(3*(inner_product_max_code+1)+13)*3	Division.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/13
	dec 	3

	org	z+(3*(inner_product_max_code+1)+14)*3	Division.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/14
	dec 	3

	org	z+(3*(inner_product_max_code+1)+15)*3	Division.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/15
	dec 	3

	org	z+(3*(inner_product_max_code+1)+16)*3	Division.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/16
	dec 	3

	org	z+(3*(inner_product_max_code+1)+17)*3	Division.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/17
	dec 	3

	org	z+(3*(inner_product_max_code+1)+18)*3	Division.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/18
	dec 	3

	org	z+(3*(inner_product_max_code+1)+19)*3	Division.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/19
	dec 	3

	org	z+(3*(inner_product_max_code+1)+20)*3	Division.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/3,9/20
	dec 	3

	org	z+(4*(inner_product_max_code+1)+0)*3	Ceiling.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/0
	dec 	3

	org	z+(4*(inner_product_max_code+1)+1)*3	Ceiling.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/1
	dec 	3

	org	z+(4*(inner_product_max_code+1)+2)*3	Ceiling.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/2
	dec 	3

	org	z+(4*(inner_product_max_code+1)+3)*3	Ceiling.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/3
	dec 	3

	org	z+(4*(inner_product_max_code+1)+4)*3	Ceiling.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/4
	dec 	3

	org	z+(4*(inner_product_max_code+1)+5)*3	Ceiling.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/5
	dec 	3

	org	z+(4*(inner_product_max_code+1)+6)*3	Ceiling.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/6
	dec 	3

	org	z+(4*(inner_product_max_code+1)+7)*3	Ceiling.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/7
	dec 	3

	org	z+(4*(inner_product_max_code+1)+8)*3	Ceiling.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/8
	dec 	3

	org	z+(4*(inner_product_max_code+1)+9)*3	Ceiling.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/9
	dec 	3

	org	z+(4*(inner_product_max_code+1)+10)*3	Ceiling.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/10
	dec 	3

	org	z+(4*(inner_product_max_code+1)+11)*3	Ceiling.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/11
	dec 	3

	org	z+(4*(inner_product_max_code+1)+12)*3	Ceiling.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/12
	dec 	3

	org	z+(4*(inner_product_max_code+1)+13)*3	Ceiling.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/13
	dec 	3

	org	z+(4*(inner_product_max_code+1)+14)*3	Ceiling.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/14
	dec 	3

	org	z+(4*(inner_product_max_code+1)+15)*3	Ceiling.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/15
	dec 	3

	org	z+(4*(inner_product_max_code+1)+16)*3	Ceiling.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/16
	dec 	3

	org	z+(4*(inner_product_max_code+1)+17)*3	Ceiling.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/17
	dec 	3

	org	z+(4*(inner_product_max_code+1)+18)*3	Ceiling.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/18
	dec 	3

	org	z+(4*(inner_product_max_code+1)+19)*3	Ceiling.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/19
	dec 	3

	org	z+(4*(inner_product_max_code+1)+20)*3	Ceiling.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/4,9/20
	dec 	3

	org	z+(5*(inner_product_max_code+1)+0)*3	Floor.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/0
	dec 	3

	org	z+(5*(inner_product_max_code+1)+1)*3	Floor.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/1
	dec 	3

	org	z+(5*(inner_product_max_code+1)+2)*3	Floor.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/2
	dec 	3

	org	z+(5*(inner_product_max_code+1)+3)*3	Floor.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/3
	dec 	3

	org	z+(5*(inner_product_max_code+1)+4)*3	Floor.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/4
	dec 	3

	org	z+(5*(inner_product_max_code+1)+5)*3	Floor.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/5
	dec 	3

	org	z+(5*(inner_product_max_code+1)+6)*3	Floor.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/6
	dec 	3

	org	z+(5*(inner_product_max_code+1)+7)*3	Floor.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/7
	dec 	3

	org	z+(5*(inner_product_max_code+1)+8)*3	Floor.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/8
	dec 	3

	org	z+(5*(inner_product_max_code+1)+9)*3	Floor.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/9
	dec 	3

	org	z+(5*(inner_product_max_code+1)+10)*3	Floor.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/10
	dec 	3

	org	z+(5*(inner_product_max_code+1)+11)*3	Floor.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/11
	dec 	3

	org	z+(5*(inner_product_max_code+1)+12)*3	Floor.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/12
	dec 	3

	org	z+(5*(inner_product_max_code+1)+13)*3	Floor.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/13
	dec 	3

	org	z+(5*(inner_product_max_code+1)+14)*3	Floor.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/14
	dec 	3

	org	z+(5*(inner_product_max_code+1)+15)*3	Floor.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/15
	dec 	3

	org	z+(5*(inner_product_max_code+1)+16)*3	Floor.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/16
	dec 	3

	org	z+(5*(inner_product_max_code+1)+17)*3	Floor.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/17
	dec 	3

	org	z+(5*(inner_product_max_code+1)+18)*3	Floor.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/18
	dec 	3

	org	z+(5*(inner_product_max_code+1)+19)*3	Floor.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/19
	dec 	3

	org	z+(5*(inner_product_max_code+1)+20)*3	Floor.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/5,9/20
	dec 	3

	org	z+(6*(inner_product_max_code+1)+0)*3	Star.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/0
	dec 	3

	org	z+(6*(inner_product_max_code+1)+1)*3	Star.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/1
	dec 	3

	org	z+(6*(inner_product_max_code+1)+2)*3	Star.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/2
	dec 	3

	org	z+(6*(inner_product_max_code+1)+3)*3	Star.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/3
	dec 	3

	org	z+(6*(inner_product_max_code+1)+4)*3	Star.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/4
	dec 	3

	org	z+(6*(inner_product_max_code+1)+5)*3	Star.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/5
	dec 	3

	org	z+(6*(inner_product_max_code+1)+6)*3	Star.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/6
	dec 	3

	org	z+(6*(inner_product_max_code+1)+7)*3	Star.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/7
	dec 	3

	org	z+(6*(inner_product_max_code+1)+8)*3	Star.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/8
	dec 	3

	org	z+(6*(inner_product_max_code+1)+9)*3	Star.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/9
	dec 	3

	org	z+(6*(inner_product_max_code+1)+10)*3	Star.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/10
	dec 	3

	org	z+(6*(inner_product_max_code+1)+11)*3	Star.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/11
	dec 	3

	org	z+(6*(inner_product_max_code+1)+12)*3	Star.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/12
	dec 	3

	org	z+(6*(inner_product_max_code+1)+13)*3	Star.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/13
	dec 	3

	org	z+(6*(inner_product_max_code+1)+14)*3	Star.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/14
	dec 	3

	org	z+(6*(inner_product_max_code+1)+15)*3	Star.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/15
	dec 	3

	org	z+(6*(inner_product_max_code+1)+16)*3	Star.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/16
	dec 	3

	org	z+(6*(inner_product_max_code+1)+17)*3	Star.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/17
	dec 	3

	org	z+(6*(inner_product_max_code+1)+18)*3	Star.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/18
	dec 	3

	org	z+(6*(inner_product_max_code+1)+19)*3	Star.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/19
	dec 	3

	org	z+(6*(inner_product_max_code+1)+20)*3	Star.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/6,9/20
	dec 	3

	org	z+(7*(inner_product_max_code+1)+0)*3	CircleStar.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/0
	dec 	3

	org	z+(7*(inner_product_max_code+1)+1)*3	CircleStar.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/1
	dec 	3

	org	z+(7*(inner_product_max_code+1)+2)*3	CircleStar.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/2
	dec 	3

	org	z+(7*(inner_product_max_code+1)+3)*3	CircleStar.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/3
	dec 	3

	org	z+(7*(inner_product_max_code+1)+4)*3	CircleStar.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/4
	dec 	3

	org	z+(7*(inner_product_max_code+1)+5)*3	CircleStar.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/5
	dec 	3

	org	z+(7*(inner_product_max_code+1)+6)*3	CircleStar.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/6
	dec 	3

	org	z+(7*(inner_product_max_code+1)+7)*3	CircleStar.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/7
	dec 	3

	org	z+(7*(inner_product_max_code+1)+8)*3	CircleStar.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/8
	dec 	3

	org	z+(7*(inner_product_max_code+1)+9)*3	CircleStar.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/9
	dec 	3

	org	z+(7*(inner_product_max_code+1)+10)*3	CircleStar.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/10
	dec 	3

	org	z+(7*(inner_product_max_code+1)+11)*3	CircleStar.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/11
	dec 	3

	org	z+(7*(inner_product_max_code+1)+12)*3	CircleStar.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/12
	dec 	3

	org	z+(7*(inner_product_max_code+1)+13)*3	CircleStar.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/13
	dec 	3

	org	z+(7*(inner_product_max_code+1)+14)*3	CircleStar.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/14
	dec 	3

	org	z+(7*(inner_product_max_code+1)+15)*3	CircleStar.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/15
	dec 	3

	org	z+(7*(inner_product_max_code+1)+16)*3	CircleStar.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/16
	dec 	3

	org	z+(7*(inner_product_max_code+1)+17)*3	CircleStar.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/17
	dec 	3

	org	z+(7*(inner_product_max_code+1)+18)*3	CircleStar.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/18
	dec 	3

	org	z+(7*(inner_product_max_code+1)+19)*3	CircleStar.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/19
	dec 	3

	org	z+(7*(inner_product_max_code+1)+20)*3	CircleStar.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/7,9/20
	dec 	3

	org	z+(8*(inner_product_max_code+1)+0)*3	VerticalBar.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/0
	dec 	3

	org	z+(8*(inner_product_max_code+1)+1)*3	VerticalBar.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/1
	dec 	3

	org	z+(8*(inner_product_max_code+1)+2)*3	VerticalBar.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/2
	dec 	3

	org	z+(8*(inner_product_max_code+1)+3)*3	VerticalBar.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/3
	dec 	3

	org	z+(8*(inner_product_max_code+1)+4)*3	VerticalBar.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/4
	dec 	3

	org	z+(8*(inner_product_max_code+1)+5)*3	VerticalBar.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/5
	dec 	3

	org	z+(8*(inner_product_max_code+1)+6)*3	VerticalBar.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/6
	dec 	3

	org	z+(8*(inner_product_max_code+1)+7)*3	VerticalBar.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/7
	dec 	3

	org	z+(8*(inner_product_max_code+1)+8)*3	VerticalBar.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/8
	dec 	3

	org	z+(8*(inner_product_max_code+1)+9)*3	VerticalBar.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/9
	dec 	3

	org	z+(8*(inner_product_max_code+1)+10)*3	VerticalBar.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/10
	dec 	3

	org	z+(8*(inner_product_max_code+1)+11)*3	VerticalBar.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/11
	dec 	3

	org	z+(8*(inner_product_max_code+1)+12)*3	VerticalBar.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/12
	dec 	3

	org	z+(8*(inner_product_max_code+1)+13)*3	VerticalBar.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/13
	dec 	3

	org	z+(8*(inner_product_max_code+1)+14)*3	VerticalBar.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/14
	dec 	3

	org	z+(8*(inner_product_max_code+1)+15)*3	VerticalBar.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/15
	dec 	3

	org	z+(8*(inner_product_max_code+1)+16)*3	VerticalBar.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/16
	dec 	3

	org	z+(8*(inner_product_max_code+1)+17)*3	VerticalBar.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/17
	dec 	3

	org	z+(8*(inner_product_max_code+1)+18)*3	VerticalBar.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/18
	dec 	3

	org	z+(8*(inner_product_max_code+1)+19)*3	VerticalBar.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/19
	dec 	3

	org	z+(8*(inner_product_max_code+1)+20)*3	VerticalBar.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/8,9/20
	dec 	3

	org	z+(9*(inner_product_max_code+1)+0)*3	Exclamation.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/0
	dec 	3

	org	z+(9*(inner_product_max_code+1)+1)*3	Exclamation.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/1
	dec 	3

	org	z+(9*(inner_product_max_code+1)+2)*3	Exclamation.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/2
	dec 	3

	org	z+(9*(inner_product_max_code+1)+3)*3	Exclamation.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/3
	dec 	3

	org	z+(9*(inner_product_max_code+1)+4)*3	Exclamation.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/4
	dec 	3

	org	z+(9*(inner_product_max_code+1)+5)*3	Exclamation.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/5
	dec 	3

	org	z+(9*(inner_product_max_code+1)+6)*3	Exclamation.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/6
	dec 	3

	org	z+(9*(inner_product_max_code+1)+7)*3	Exclamation.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/7
	dec 	3

	org	z+(9*(inner_product_max_code+1)+8)*3	Exclamation.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/8
	dec 	3

	org	z+(9*(inner_product_max_code+1)+9)*3	Exclamation.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/9
	dec 	3

	org	z+(9*(inner_product_max_code+1)+10)*3	Exclamation.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/10
	dec 	3

	org	z+(9*(inner_product_max_code+1)+11)*3	Exclamation.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/11
	dec 	3

	org	z+(9*(inner_product_max_code+1)+12)*3	Exclamation.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/12
	dec 	3

	org	z+(9*(inner_product_max_code+1)+13)*3	Exclamation.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/13
	dec 	3

	org	z+(9*(inner_product_max_code+1)+14)*3	Exclamation.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/14
	dec 	3

	org	z+(9*(inner_product_max_code+1)+15)*3	Exclamation.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/15
	dec 	3

	org	z+(9*(inner_product_max_code+1)+16)*3	Exclamation.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/16
	dec 	3

	org	z+(9*(inner_product_max_code+1)+17)*3	Exclamation.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/17
	dec 	3

	org	z+(9*(inner_product_max_code+1)+18)*3	Exclamation.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/18
	dec 	3

	org	z+(9*(inner_product_max_code+1)+19)*3	Exclamation.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/19
	dec 	3

	org	z+(9*(inner_product_max_code+1)+20)*3	Exclamation.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/9,9/20
	dec 	3

	org	z+(10*(inner_product_max_code+1)+0)*3	Circle.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/0
	dec 	3

	org	z+(10*(inner_product_max_code+1)+1)*3	Circle.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/1
	dec 	3

	org	z+(10*(inner_product_max_code+1)+2)*3	Circle.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/2
	dec 	3

	org	z+(10*(inner_product_max_code+1)+3)*3	Circle.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/3
	dec 	3

	org	z+(10*(inner_product_max_code+1)+4)*3	Circle.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/4
	dec 	3

	org	z+(10*(inner_product_max_code+1)+5)*3	Circle.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/5
	dec 	3

	org	z+(10*(inner_product_max_code+1)+6)*3	Circle.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/6
	dec 	3

	org	z+(10*(inner_product_max_code+1)+7)*3	Circle.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/7
	dec 	3

	org	z+(10*(inner_product_max_code+1)+8)*3	Circle.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/8
	dec 	3

	org	z+(10*(inner_product_max_code+1)+9)*3	Circle.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/9
	dec 	3

	org	z+(10*(inner_product_max_code+1)+10)*3	Circle.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/10
	dec 	3

	org	z+(10*(inner_product_max_code+1)+11)*3	Circle.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/11
	dec 	3

	org	z+(10*(inner_product_max_code+1)+12)*3	Circle.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/12
	dec 	3

	org	z+(10*(inner_product_max_code+1)+13)*3	Circle.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/13
	dec 	3

	org	z+(10*(inner_product_max_code+1)+14)*3	Circle.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/14
	dec 	3

	org	z+(10*(inner_product_max_code+1)+15)*3	Circle.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/15
	dec 	3

	org	z+(10*(inner_product_max_code+1)+16)*3	Circle.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/16
	dec 	3

	org	z+(10*(inner_product_max_code+1)+17)*3	Circle.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/17
	dec 	3

	org	z+(10*(inner_product_max_code+1)+18)*3	Circle.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/18
	dec 	3

	org	z+(10*(inner_product_max_code+1)+19)*3	Circle.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/19
	dec 	3

	org	z+(10*(inner_product_max_code+1)+20)*3	Circle.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/10,9/20
	dec 	3

	org	z+(11*(inner_product_max_code+1)+0)*3	AndSign.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/0
	dec 	3

	org	z+(11*(inner_product_max_code+1)+1)*3	AndSign.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/1
	dec 	3

	org	z+(11*(inner_product_max_code+1)+2)*3	AndSign.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/2
	dec 	3

	org	z+(11*(inner_product_max_code+1)+3)*3	AndSign.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/3
	dec 	3

	org	z+(11*(inner_product_max_code+1)+4)*3	AndSign.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/4
	dec 	3

	org	z+(11*(inner_product_max_code+1)+5)*3	AndSign.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/5
	dec 	3

	org	z+(11*(inner_product_max_code+1)+6)*3	AndSign.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/6
	dec 	3

	org	z+(11*(inner_product_max_code+1)+7)*3	AndSign.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/7
	dec 	3

	org	z+(11*(inner_product_max_code+1)+8)*3	AndSign.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/8
	dec 	3

	org	z+(11*(inner_product_max_code+1)+9)*3	AndSign.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/9
	dec 	3

	org	z+(11*(inner_product_max_code+1)+10)*3	AndSign.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/10
	dec 	3

	org	z+(11*(inner_product_max_code+1)+11)*3	AndSign.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/11
	dec 	3

	org	z+(11*(inner_product_max_code+1)+12)*3	AndSign.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/12
	dec 	3

	org	z+(11*(inner_product_max_code+1)+13)*3	AndSign.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/13
	dec 	3

	org	z+(11*(inner_product_max_code+1)+14)*3	AndSign.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/14
	dec 	3

	org	z+(11*(inner_product_max_code+1)+15)*3	AndSign.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/15
	dec 	3

	org	z+(11*(inner_product_max_code+1)+16)*3	AndSign.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/16
	dec 	3

	org	z+(11*(inner_product_max_code+1)+17)*3	AndSign.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/17
	dec 	3

	org	z+(11*(inner_product_max_code+1)+18)*3	AndSign.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/18
	dec 	3

	org	z+(11*(inner_product_max_code+1)+19)*3	AndSign.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/19
	dec 	3

	org	z+(11*(inner_product_max_code+1)+20)*3	AndSign.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/11,9/20
	dec 	3

	org	z+(12*(inner_product_max_code+1)+0)*3	OrSign.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/0
	dec 	3

	org	z+(12*(inner_product_max_code+1)+1)*3	OrSign.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/1
	dec 	3

	org	z+(12*(inner_product_max_code+1)+2)*3	OrSign.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/2
	dec 	3

	org	z+(12*(inner_product_max_code+1)+3)*3	OrSign.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/3
	dec 	3

	org	z+(12*(inner_product_max_code+1)+4)*3	OrSign.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/4
	dec 	3

	org	z+(12*(inner_product_max_code+1)+5)*3	OrSign.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/5
	dec 	3

	org	z+(12*(inner_product_max_code+1)+6)*3	OrSign.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/6
	dec 	3

	org	z+(12*(inner_product_max_code+1)+7)*3	OrSign.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/7
	dec 	3

	org	z+(12*(inner_product_max_code+1)+8)*3	OrSign.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/8
	dec 	3

	org	z+(12*(inner_product_max_code+1)+9)*3	OrSign.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/9
	dec 	3

	org	z+(12*(inner_product_max_code+1)+10)*3	OrSign.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/10
	dec 	3

	org	z+(12*(inner_product_max_code+1)+11)*3	OrSign.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/11
	dec 	3

	org	z+(12*(inner_product_max_code+1)+12)*3	OrSign.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/12
	dec 	3

	org	z+(12*(inner_product_max_code+1)+13)*3	OrSign.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/13
	dec 	3

	org	z+(12*(inner_product_max_code+1)+14)*3	OrSign.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/14
	dec 	3

	org	z+(12*(inner_product_max_code+1)+15)*3	OrSign.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/15
	dec 	3

	org	z+(12*(inner_product_max_code+1)+16)*3	OrSign.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/16
	dec 	3

	org	z+(12*(inner_product_max_code+1)+17)*3	OrSign.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/17
	dec 	3

	org	z+(12*(inner_product_max_code+1)+18)*3	OrSign.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/18
	dec 	3

	org	z+(12*(inner_product_max_code+1)+19)*3	OrSign.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/19
	dec 	3

	org	z+(12*(inner_product_max_code+1)+20)*3	OrSign.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/12,9/20
	dec 	3

	org	z+(13*(inner_product_max_code+1)+0)*3	NandSign.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/0
	dec 	3

	org	z+(13*(inner_product_max_code+1)+1)*3	NandSign.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/1
	dec 	3

	org	z+(13*(inner_product_max_code+1)+2)*3	NandSign.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/2
	dec 	3

	org	z+(13*(inner_product_max_code+1)+3)*3	NandSign.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/3
	dec 	3

	org	z+(13*(inner_product_max_code+1)+4)*3	NandSign.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/4
	dec 	3

	org	z+(13*(inner_product_max_code+1)+5)*3	NandSign.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/5
	dec 	3

	org	z+(13*(inner_product_max_code+1)+6)*3	NandSign.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/6
	dec 	3

	org	z+(13*(inner_product_max_code+1)+7)*3	NandSign.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/7
	dec 	3

	org	z+(13*(inner_product_max_code+1)+8)*3	NandSign.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/8
	dec 	3

	org	z+(13*(inner_product_max_code+1)+9)*3	NandSign.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/9
	dec 	3

	org	z+(13*(inner_product_max_code+1)+10)*3	NandSign.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/10
	dec 	3

	org	z+(13*(inner_product_max_code+1)+11)*3	NandSign.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/11
	dec 	3

	org	z+(13*(inner_product_max_code+1)+12)*3	NandSign.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/12
	dec 	3

	org	z+(13*(inner_product_max_code+1)+13)*3	NandSign.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/13
	dec 	3

	org	z+(13*(inner_product_max_code+1)+14)*3	NandSign.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/14
	dec 	3

	org	z+(13*(inner_product_max_code+1)+15)*3	NandSign.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/15
	dec 	3

	org	z+(13*(inner_product_max_code+1)+16)*3	NandSign.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/16
	dec 	3

	org	z+(13*(inner_product_max_code+1)+17)*3	NandSign.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/17
	dec 	3

	org	z+(13*(inner_product_max_code+1)+18)*3	NandSign.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/18
	dec 	3

	org	z+(13*(inner_product_max_code+1)+19)*3	NandSign.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/19
	dec 	3

	org	z+(13*(inner_product_max_code+1)+20)*3	NandSign.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/13,9/20
	dec 	3

	org	z+(14*(inner_product_max_code+1)+0)*3	NorSign.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/0
	dec 	3

	org	z+(14*(inner_product_max_code+1)+1)*3	NorSign.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/1
	dec 	3

	org	z+(14*(inner_product_max_code+1)+2)*3	NorSign.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/2
	dec 	3

	org	z+(14*(inner_product_max_code+1)+3)*3	NorSign.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/3
	dec 	3

	org	z+(14*(inner_product_max_code+1)+4)*3	NorSign.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/4
	dec 	3

	org	z+(14*(inner_product_max_code+1)+5)*3	NorSign.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/5
	dec 	3

	org	z+(14*(inner_product_max_code+1)+6)*3	NorSign.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/6
	dec 	3

	org	z+(14*(inner_product_max_code+1)+7)*3	NorSign.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/7
	dec 	3

	org	z+(14*(inner_product_max_code+1)+8)*3	NorSign.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/8
	dec 	3

	org	z+(14*(inner_product_max_code+1)+9)*3	NorSign.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/9
	dec 	3

	org	z+(14*(inner_product_max_code+1)+10)*3	NorSign.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/10
	dec 	3

	org	z+(14*(inner_product_max_code+1)+11)*3	NorSign.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/11
	dec 	3

	org	z+(14*(inner_product_max_code+1)+12)*3	NorSign.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/12
	dec 	3

	org	z+(14*(inner_product_max_code+1)+13)*3	NorSign.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/13
	dec 	3

	org	z+(14*(inner_product_max_code+1)+14)*3	NorSign.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/14
	dec 	3

	org	z+(14*(inner_product_max_code+1)+15)*3	NorSign.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/15
	dec 	3

	org	z+(14*(inner_product_max_code+1)+16)*3	NorSign.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/16
	dec 	3

	org	z+(14*(inner_product_max_code+1)+17)*3	NorSign.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/17
	dec 	3

	org	z+(14*(inner_product_max_code+1)+18)*3	NorSign.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/18
	dec 	3

	org	z+(14*(inner_product_max_code+1)+19)*3	NorSign.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/19
	dec 	3

	org	z+(14*(inner_product_max_code+1)+20)*3	NorSign.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/14,9/20
	dec 	3

	org	z+(15*(inner_product_max_code+1)+0)*3	LessThan.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/0
	dec 	3

	org	z+(15*(inner_product_max_code+1)+1)*3	LessThan.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/1
	dec 	3

	org	z+(15*(inner_product_max_code+1)+2)*3	LessThan.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/2
	dec 	3

	org	z+(15*(inner_product_max_code+1)+3)*3	LessThan.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/3
	dec 	3

	org	z+(15*(inner_product_max_code+1)+4)*3	LessThan.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/4
	dec 	3

	org	z+(15*(inner_product_max_code+1)+5)*3	LessThan.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/5
	dec 	3

	org	z+(15*(inner_product_max_code+1)+6)*3	LessThan.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/6
	dec 	3

	org	z+(15*(inner_product_max_code+1)+7)*3	LessThan.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/7
	dec 	3

	org	z+(15*(inner_product_max_code+1)+8)*3	LessThan.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/8
	dec 	3

	org	z+(15*(inner_product_max_code+1)+9)*3	LessThan.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/9
	dec 	3

	org	z+(15*(inner_product_max_code+1)+10)*3	LessThan.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/10
	dec 	3

	org	z+(15*(inner_product_max_code+1)+11)*3	LessThan.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/11
	dec 	3

	org	z+(15*(inner_product_max_code+1)+12)*3	LessThan.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/12
	dec 	3

	org	z+(15*(inner_product_max_code+1)+13)*3	LessThan.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/13
	dec 	3

	org	z+(15*(inner_product_max_code+1)+14)*3	LessThan.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/14
	dec 	3

	org	z+(15*(inner_product_max_code+1)+15)*3	LessThan.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/15
	dec 	3

	org	z+(15*(inner_product_max_code+1)+16)*3	LessThan.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/16
	dec 	3

	org	z+(15*(inner_product_max_code+1)+17)*3	LessThan.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/17
	dec 	3

	org	z+(15*(inner_product_max_code+1)+18)*3	LessThan.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/18
	dec 	3

	org	z+(15*(inner_product_max_code+1)+19)*3	LessThan.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/19
	dec 	3

	org	z+(15*(inner_product_max_code+1)+20)*3	LessThan.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/15,9/20
	dec 	3

	org	z+(16*(inner_product_max_code+1)+0)*3	LessOrEqual.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/0
	dec 	3

	org	z+(16*(inner_product_max_code+1)+1)*3	LessOrEqual.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/1
	dec 	3

	org	z+(16*(inner_product_max_code+1)+2)*3	LessOrEqual.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/2
	dec 	3

	org	z+(16*(inner_product_max_code+1)+3)*3	LessOrEqual.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/3
	dec 	3

	org	z+(16*(inner_product_max_code+1)+4)*3	LessOrEqual.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/4
	dec 	3

	org	z+(16*(inner_product_max_code+1)+5)*3	LessOrEqual.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/5
	dec 	3

	org	z+(16*(inner_product_max_code+1)+6)*3	LessOrEqual.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/6
	dec 	3

	org	z+(16*(inner_product_max_code+1)+7)*3	LessOrEqual.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/7
	dec 	3

	org	z+(16*(inner_product_max_code+1)+8)*3	LessOrEqual.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/8
	dec 	3

	org	z+(16*(inner_product_max_code+1)+9)*3	LessOrEqual.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/9
	dec 	3

	org	z+(16*(inner_product_max_code+1)+10)*3	LessOrEqual.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/10
	dec 	3

	org	z+(16*(inner_product_max_code+1)+11)*3	LessOrEqual.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/11
	dec 	3

	org	z+(16*(inner_product_max_code+1)+12)*3	LessOrEqual.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/12
	dec 	3

	org	z+(16*(inner_product_max_code+1)+13)*3	LessOrEqual.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/13
	dec 	3

	org	z+(16*(inner_product_max_code+1)+14)*3	LessOrEqual.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/14
	dec 	3

	org	z+(16*(inner_product_max_code+1)+15)*3	LessOrEqual.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/15
	dec 	3

	org	z+(16*(inner_product_max_code+1)+16)*3	LessOrEqual.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/16
	dec 	3

	org	z+(16*(inner_product_max_code+1)+17)*3	LessOrEqual.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/17
	dec 	3

	org	z+(16*(inner_product_max_code+1)+18)*3	LessOrEqual.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/18
	dec 	3

	org	z+(16*(inner_product_max_code+1)+19)*3	LessOrEqual.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/19
	dec 	3

	org	z+(16*(inner_product_max_code+1)+20)*3	LessOrEqual.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/16,9/20
	dec 	3

	org	z+(17*(inner_product_max_code+1)+0)*3	Equal.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/0
	dec 	3

	org	z+(17*(inner_product_max_code+1)+1)*3	Equal.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/1
	dec 	3

	org	z+(17*(inner_product_max_code+1)+2)*3	Equal.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/2
	dec 	3

	org	z+(17*(inner_product_max_code+1)+3)*3	Equal.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/3
	dec 	3

	org	z+(17*(inner_product_max_code+1)+4)*3	Equal.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/4
	dec 	3

	org	z+(17*(inner_product_max_code+1)+5)*3	Equal.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/5
	dec 	3

	org	z+(17*(inner_product_max_code+1)+6)*3	Equal.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/6
	dec 	3

	org	z+(17*(inner_product_max_code+1)+7)*3	Equal.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/7
	dec 	3

	org	z+(17*(inner_product_max_code+1)+8)*3	Equal.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/8
	dec 	3

	org	z+(17*(inner_product_max_code+1)+9)*3	Equal.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/9
	dec 	3

	org	z+(17*(inner_product_max_code+1)+10)*3	Equal.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/10
	dec 	3

	org	z+(17*(inner_product_max_code+1)+11)*3	Equal.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/11
	dec 	3

	org	z+(17*(inner_product_max_code+1)+12)*3	Equal.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/12
	dec 	3

	org	z+(17*(inner_product_max_code+1)+13)*3	Equal.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/13
	dec 	3

	org	z+(17*(inner_product_max_code+1)+14)*3	Equal.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/14
	dec 	3

	org	z+(17*(inner_product_max_code+1)+15)*3	Equal.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/15
	dec 	3

	org	z+(17*(inner_product_max_code+1)+16)*3	Equal.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/16
	dec 	3

	org	z+(17*(inner_product_max_code+1)+17)*3	Equal.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/17
	dec 	3

	org	z+(17*(inner_product_max_code+1)+18)*3	Equal.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/18
	dec 	3

	org	z+(17*(inner_product_max_code+1)+19)*3	Equal.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/19
	dec 	3

	org	z+(17*(inner_product_max_code+1)+20)*3	Equal.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/17,9/20
	dec 	3

	org	z+(18*(inner_product_max_code+1)+0)*3	GreaterOrEqual.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/0
	dec 	3

	org	z+(18*(inner_product_max_code+1)+1)*3	GreaterOrEqual.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/1
	dec 	3

	org	z+(18*(inner_product_max_code+1)+2)*3	GreaterOrEqual.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/2
	dec 	3

	org	z+(18*(inner_product_max_code+1)+3)*3	GreaterOrEqual.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/3
	dec 	3

	org	z+(18*(inner_product_max_code+1)+4)*3	GreaterOrEqual.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/4
	dec 	3

	org	z+(18*(inner_product_max_code+1)+5)*3	GreaterOrEqual.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/5
	dec 	3

	org	z+(18*(inner_product_max_code+1)+6)*3	GreaterOrEqual.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/6
	dec 	3

	org	z+(18*(inner_product_max_code+1)+7)*3	GreaterOrEqual.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/7
	dec 	3

	org	z+(18*(inner_product_max_code+1)+8)*3	GreaterOrEqual.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/8
	dec 	3

	org	z+(18*(inner_product_max_code+1)+9)*3	GreaterOrEqual.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/9
	dec 	3

	org	z+(18*(inner_product_max_code+1)+10)*3	GreaterOrEqual.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/10
	dec 	3

	org	z+(18*(inner_product_max_code+1)+11)*3	GreaterOrEqual.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/11
	dec 	3

	org	z+(18*(inner_product_max_code+1)+12)*3	GreaterOrEqual.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/12
	dec 	3

	org	z+(18*(inner_product_max_code+1)+13)*3	GreaterOrEqual.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/13
	dec 	3

	org	z+(18*(inner_product_max_code+1)+14)*3	GreaterOrEqual.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/14
	dec 	3

	org	z+(18*(inner_product_max_code+1)+15)*3	GreaterOrEqual.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/15
	dec 	3

	org	z+(18*(inner_product_max_code+1)+16)*3	GreaterOrEqual.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/16
	dec 	3

	org	z+(18*(inner_product_max_code+1)+17)*3	GreaterOrEqual.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/17
	dec 	3

	org	z+(18*(inner_product_max_code+1)+18)*3	GreaterOrEqual.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/18
	dec 	3

	org	z+(18*(inner_product_max_code+1)+19)*3	GreaterOrEqual.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/19
	dec 	3

	org	z+(18*(inner_product_max_code+1)+20)*3	GreaterOrEqual.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/18,9/20
	dec 	3

	org	z+(19*(inner_product_max_code+1)+0)*3	GreaterThan.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/0
	dec 	3

	org	z+(19*(inner_product_max_code+1)+1)*3	GreaterThan.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/1
	dec 	3

	org	z+(19*(inner_product_max_code+1)+2)*3	GreaterThan.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/2
	dec 	3

	org	z+(19*(inner_product_max_code+1)+3)*3	GreaterThan.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/3
	dec 	3

	org	z+(19*(inner_product_max_code+1)+4)*3	GreaterThan.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/4
	dec 	3

	org	z+(19*(inner_product_max_code+1)+5)*3	GreaterThan.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/5
	dec 	3

	org	z+(19*(inner_product_max_code+1)+6)*3	GreaterThan.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/6
	dec 	3

	org	z+(19*(inner_product_max_code+1)+7)*3	GreaterThan.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/7
	dec 	3

	org	z+(19*(inner_product_max_code+1)+8)*3	GreaterThan.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/8
	dec 	3

	org	z+(19*(inner_product_max_code+1)+9)*3	GreaterThan.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/9
	dec 	3

	org	z+(19*(inner_product_max_code+1)+10)*3	GreaterThan.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/10
	dec 	3

	org	z+(19*(inner_product_max_code+1)+11)*3	GreaterThan.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/11
	dec 	3

	org	z+(19*(inner_product_max_code+1)+12)*3	GreaterThan.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/12
	dec 	3

	org	z+(19*(inner_product_max_code+1)+13)*3	GreaterThan.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/13
	dec 	3

	org	z+(19*(inner_product_max_code+1)+14)*3	GreaterThan.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/14
	dec 	3

	org	z+(19*(inner_product_max_code+1)+15)*3	GreaterThan.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/15
	dec 	3

	org	z+(19*(inner_product_max_code+1)+16)*3	GreaterThan.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/16
	dec 	3

	org	z+(19*(inner_product_max_code+1)+17)*3	GreaterThan.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/17
	dec 	3

	org	z+(19*(inner_product_max_code+1)+18)*3	GreaterThan.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/18
	dec 	3

	org	z+(19*(inner_product_max_code+1)+19)*3	GreaterThan.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/19
	dec 	3

	org	z+(19*(inner_product_max_code+1)+20)*3	GreaterThan.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/19,9/20
	dec 	3

	org	z+(20*(inner_product_max_code+1)+0)*3	NotEqual.Plus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/0
	dec 	3

	org	z+(20*(inner_product_max_code+1)+1)*3	NotEqual.Minus
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/1
	dec 	3

	org	z+(20*(inner_product_max_code+1)+2)*3	NotEqual.Times
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/2
	dec 	3

	org	z+(20*(inner_product_max_code+1)+3)*3	NotEqual.Division
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/3
	dec 	3

	org	z+(20*(inner_product_max_code+1)+4)*3	NotEqual.Ceiling
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/4
	dec 	3

	org	z+(20*(inner_product_max_code+1)+5)*3	NotEqual.Floor
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/5
	dec 	3

	org	z+(20*(inner_product_max_code+1)+6)*3	NotEqual.Star
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/6
	dec 	3

	org	z+(20*(inner_product_max_code+1)+7)*3	NotEqual.CircleStar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/7
	dec 	3

	org	z+(20*(inner_product_max_code+1)+8)*3	NotEqual.VerticalBar
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/8
	dec 	3

	org	z+(20*(inner_product_max_code+1)+9)*3	NotEqual.Exclamation
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/9
	dec 	3

	org	z+(20*(inner_product_max_code+1)+10)*3	NotEqual.Circle
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/10
	dec 	3

	org	z+(20*(inner_product_max_code+1)+11)*3	NotEqual.AndSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/11
	dec 	3

	org	z+(20*(inner_product_max_code+1)+12)*3	NotEqual.OrSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/12
	dec 	3

	org	z+(20*(inner_product_max_code+1)+13)*3	NotEqual.NandSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/13
	dec 	3

	org	z+(20*(inner_product_max_code+1)+14)*3	NotEqual.NorSign
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/14
	dec 	3

	org	z+(20*(inner_product_max_code+1)+15)*3	NotEqual.LessThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/15
	dec 	3

	org	z+(20*(inner_product_max_code+1)+16)*3	NotEqual.LessOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/16
	dec 	3

	org	z+(20*(inner_product_max_code+1)+17)*3	NotEqual.Equal
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/17
	dec 	3

	org	z+(20*(inner_product_max_code+1)+18)*3	NotEqual.GreaterOrEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/18
	dec 	3

	org	z+(20*(inner_product_max_code+1)+19)*3	NotEqual.GreaterThan
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/19
	dec 	3

	org	z+(20*(inner_product_max_code+1)+20)*3	NotEqual.NotEqual
	vfd	18/operator_bead_type,18/0,18/dyadic+inner_product,9/20,9/20
	dec 	3




"" join the three parts of this data base and put them in the text section

	join	/text/op_index
	join	/text/op_bead_table
	join	/text/inner_prod_tbl

	end




		    apl_parse_.pl1                  02/06/85  1135.9r w 02/06/85  1130.1     1070442



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

/* format: style3 */
apl_parse_:
     procedure;

/* This routine sets up a suspended frame on the parse stack, and
   runs apl.

	Initially written July 1973 by Dan Bricklin */

/* Modified 26 January 1974 by PG to handle "finish" and "error" conditions.
   Modified 740131 by PG to fix bugs.
   Modified 740226 by PG to add QuadIT, QuadEC, and QuadAF.
   Modified 740307 by PG to change call to apl_editor_, and to validate number of args in function calls.
   Modified 740624 by PG to fix assign to copy rho vector in inline case, fix stop/trace to not bomb out
	if given bad function name, initialize operators_argument before calling external functions,
	fix niladic external functions to work, to do a resetread & resetwrite after a quit,
	and to call the format operator.
   Modified 740829 by PG to fix assign to not copy rho vector if rhorho is zero, move resetread & resetwrite
	into the dim, and trap the record_quota_overflow condition.
   Modified 751231 by PG to fix setup_monadic to clear the left opnd on_stack bit so lazy operators won't get confused.
   Modified 760413 by PG to fix "(OP VAL RE" reduction to stop marking return value as being on the value stack,
	so "(FCN VAL RE" would work (return value is in heap).
   Modified 760914 by PG to make setup_(monadic dyadic)_operator_routine_call quick, and to fix bug 241
	that had caused trace output to be surpressed for lines that contained function calls.
   Modified 761011 by PG for new parse_frame declaration (first step in flushing excessive use of addr).
   Modified 770120 by PG to experiment with reverting user_input back to user_i/o if user quits.
   Modified 770121 by PG to get QUITs to work if user is &attached to an exec_com.
   Modified 770204 by PG to get all cases of assignment to handle reference counts properly, fixing bug
	264 (RQO during case 3 of assignment gives ref count errors), and an unnumbered bug that
	left the values of labels around after the function was freed.
   Modified 770222 by PG to fix bug 232 (ref count of params too high) that was caused by the function
	call/return code forgetting to wash the rs.semantics ptr(s) that pointed to the arguments.
   Modified 770225 by PG to allow operators and external functions to just return with operators_argument.error_code
	set to a non-zero value, instead of forcing them to signal apl_operator_error_.
   Modified 770310 by PG to fix bug 251 ('FOO';A-<1 wouldn't cause mixed output).
   Modified 770315 by PG to cleanup handling of buffer for input line.
   Modified 770317 by PG to get latent expression executed when ws is auto-loaded (bug 156),
	and handle multi-line input correctly (bug 148).
   Modified 770322 by PG to fix bug in handling of depth error (bug 223).
   Modified 771104 by PG to fix decrement_reference_count to null its argument in all cases, thus fixing (I hope)
	bug 290 and all of the reference count errors that happen after a RQO.  Also changed all calls
	to apl_copy_value_ so that dont_interrupt_parse flag is off during the call.
   Modified 771121 by PG to cleanup handling of system errors generated by the parse itself, and to change the
	underflow handler to work with the current fim.
   Modified 780403 by PG to fix bug 239 (permit _ei0), and to fix bug 296 whereby latent expression could not
	always be executed if the SI was left uninitialized by )LOAD.
   Modified 780426 by Bill York to fix bug 283 (Assigning to a function causes a non_in_read_bracket fault)
	by initializing some rs state bits.
   Modified 780504 by PG to add diamond processing
   Modified 780927 by PG to fix default handler to pull current instruction out of executing segment,
	instead of trusting unreliable SCU data, to cleanup diamond implementation, to implement
	branches out of diamond lines and mixed-output lines (bug 333), and to reattach user_input to
	user_i/o if EOF is discovered while reading input lines.
   Modified 781102 by PG to fix 349 (branch out of diamond-lines was always taken!),
	and to eliminate the prompt for multi-line quoted strings (sugg 350).
   Modified 781106 by PG to add argument list processing.
   Modified 781108 by PG to perform read_back_spaces order on user_i/o, to
	fix problem whereby using &attach caused apl to run in read_back_input mode forever.
   Modified 781118 by PG to have successful branch abort mixed output for the
	containing line, unless the line is being traced.
   Modified 790209 by WMY to add (monadic dyadic)_action (9) for file system functions.
   Modified 790212 by WMY to add separate call for niladic file system functions.
   Modified 790305 by WMY to check for the monadic laminate case, and cause a
	context error if it occurs.
   Modified 790326 by WMY to handle functions with no body, just a header (bug 388).
   Modified 790523 by WMY to fix bug 88 (!), automatic saving of continue workspaces
	on a hangup doesn't work.  Bug was put on list 731013!!
   Modified 790917 by PG to eliminate handling of apl_operator_error_ (obsolete), and to interface
	to new apl_print_value_.
   Modified 791023 by PG to let the FIM perform all of the modifications to the machine conditions for
	underflow, since the 34-9 (MR8.0) FIM does it right.
   Modified 800129 by PG to implement localized system variables.
   Modified 800204 by PG to change execute of an assignment print nothing.
   Modified 800206 by BIM to make branches inside of execute(s) work (bug 452).
   Modified 800226 by PG to switch to iox_.
   Modified 810125 by WMY to fix bug 480, depending on order of evaluation in
	a statement can cause a reference through a null pointer.
   Modified 810528 by WMY to fix the above fix (misplaced end statement)
   Modified 811211 by HH to add 'qCALL' system function.
   Modified 811211 by HH to correctly handle expressions left of argument list semicolons.
   Modified 841022 by WAAnderson to fix diamond line storage cleanup.
*/

/* automatic */

declare	assignment_done	bit (1) aligned,
	branch_pf_ptr	ptr,			/* ptr to "parent" of execute frame, used by branch */
	input_buffer_ptr	ptr,
	input_line_position fixed bin (21),
	max_input_line	fixed bin (21),
	n_underflows	fixed bin,
	scan_token_type	fixed bin,
	temp18		bit (18) aligned,
	trace_branch_line	bit (1) aligned,		/* ON when result of branch is traced */
	was_branch	bit (1) aligned,		/* ON if branch seen on this line */
	was_branch_value	bit (1) aligned,		/* ON if branch had non-null operand */
	(x, xx)		float;			/* temporaries for fuzz computations */

/* based */

declare	1 input_buffer	aligned based (input_buffer_ptr),
	  2 n_read	fixed bin (21),
	  2 line		char (max_input_line refer (input_buffer.n_read)) unaligned;

/* internal static initial */

declare	read_back_spaces_order
			char (16) initial ("read_back_spaces") internal static options (constant);

/* conditions */

declare	(apl_dirty_stop_, apl_quit_)
			condition;

/* builtins */

declare	(abs, addr, addrel, binary, divide, fixed, floor, length, max, null, rel, size, string, substr, unspec, verify)
			builtin;

/* Multics entries */

declare	timer_manager_$alarm_call
			entry (fixed bin (71), bit (2), entry),
	timer_manager_$reset_alarm_call
			entry (entry),
	condition_	entry (char (*), entry),
	cu_$ptr_call	entry (ptr, 1 aligned like operators_argument),
	iox_$attach_ptr	entry (ptr, char (*), ptr, fixed bin (35)),
	iox_$close	entry (ptr, fixed bin (35)),
	iox_$control	entry (ptr, char (*), ptr, fixed bin (35)),
	iox_$detach_iocb	entry (ptr, fixed bin (35)),
	iox_$get_line	entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
	iox_$put_chars	entry (ptr, ptr, fixed bin (21), fixed bin (35));

/* APL entries */

declare	(apl_dyadic_, apl_dyadic_format_, apl_inner_product_, apl_monadic_, apl_monadic_format_, apl_monadic_not_,
	apl_outer_product_, apl_reduction_, apl_scan_operator_, apl_subscript_a_value_)
			entry (1 aligned like operators_argument);

declare	apl_editor_	entry (char (*), fixed bin (21), fixed bin (35)),
	apl_flush_buffer_nl_
			entry (),
	apl_print_value_	entry (ptr unal, bit (1) aligned, bit (1) aligned),
	apl_print_string_	entry (char (*)),
	apl_scan_		entry (char (*), fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, unaligned pointer),
	apl_subscripted_assignment_
			entry (1 aligned like operators_argument, ptr);

/* external static */

declare	(
	apl_static_$apl_input,
	apl_static_$apl_output,
	iox_$user_input,
	iox_$user_io
	)		ptr external static;

declare	(
	apl_error_table_$not_end_with_value,
	apl_error_table_$cant_read_input,
	apl_error_table_$pull_system_error,
	apl_error_table_$pull_assign_system_error,
	apl_error_table_$report_error_system_error,
	apl_error_table_$done_line_system_error,
	apl_error_table_$ws_full_no_quota,
	apl_error_table_$improper_niladic_usage,
	apl_error_table_$too_much_input,
	apl_error_table_$locked_function_error,
	apl_error_table_$assign_to_value,
	apl_error_table_$super_dirty_stop,
	apl_error_table_$interrupt,
	apl_error_table_$cant_get_stop_trace,
	apl_error_table_$depth,
	apl_error_table_$ws_cleared,
	apl_error_table_$ws_loaded,
	apl_error_table_$return_from_apl,
	apl_error_table_$execute,
	apl_error_table_$bad_execute,
	apl_error_table_$bad_evaluated_input,
	apl_error_table_$assign_to_label,
	apl_error_table_$bad_assignment,
	apl_error_table_$rank,
	apl_error_table_$operator_subscript_range,
	apl_error_table_$context,
	apl_error_table_$improper_monadic_usage,
	apl_error_table_$improper_dyadic_usage,
	apl_error_table_$domain,
	apl_error_table_$value,
	error_table_$end_of_info,
	error_table_$not_closed,
	error_table_$short_record
	)		fixed bin (35) external static;

/* declarations */

dcl	parse_frame_ptr	ptr,
          diamond_temp        fixed bin init(0),
          tmp_parseme         fixed bin,
	rsp		ptr,
	have_a_line	bit (1),			/* "1"b means OK to print line in error message */
	in_printer	bit (1),			/* "1"b means interrupt terminates printing */
	current_parseme	fixed bin,
	current_lexeme	fixed bin,
	lexed_function_bead_ptr
			ptr,
	based_unaligned_ptr based unaligned ptr,
	operator_ptr	ptr,
	execute_value_ptr	ptr,
	where_execute_error fixed bin,
	apl_error_	entry (fixed bin (35), bit (36) aligned, fixed bin, char (*), ptr unaligned, fixed bin),
	was_error		bit (1) aligned,
	apl_line_lex_	entry (char (*), ptr unaligned, bit (1) aligned, fixed bin, ptr),
	apl_execute_lex_	entry (char (*) aligned, ptr unaligned, bit (1) aligned, fixed bin, ptr),
	apl_function_lex_	entry (char (*) aligned, ptr unaligned, bit (1) aligned, fixed bin, ptr),
	apl_function_lex_no_messages_
			entry (char (*) aligned, ptr unaligned, bit (1) aligned, fixed bin, ptr, fixed bin),
	apl_command_	entry (char (*), fixed bin (21), fixed bin (35)),
	apl_monadic_iota_	entry (1 aligned like operators_argument),
	apl_monadic_rho_	entry (1 aligned like operators_argument),
	apl_copy_value_	entry (ptr unaligned, ptr unaligned),
	apl_dyadic_epsilon_ entry (1 aligned like operators_argument),
	apl_encode_	entry (1 aligned like operators_argument),
	apl_decode_	entry (1 aligned like operators_argument),
	apl_ibeam_	entry (1 aligned like operators_argument),
	apl_dyadic_ibeam_	entry (1 aligned like operators_argument),
	apl_system_variables_
			entry (1 aligned like operators_argument),
	apl_system_functions_
			entry (1 aligned like operators_argument),
	apl_file_system_	entry (1 aligned like operators_argument),
	apl_file_system_$niladic_functions
			entry (1 aligned like operators_argument),
	apl_dyadic_iota_	entry (1 aligned like operators_argument),
	apl_take_		entry (1 aligned like operators_argument),
	apl_drop_		entry (1 aligned like operators_argument),
	apl_ravel_	entry (1 aligned like operators_argument),
	apl_catenate_	entry (1 aligned like operators_argument),
	apl_laminate_	entry (1 aligned like operators_argument),
	apl_dyadic_rho_	entry (1 aligned like operators_argument),
	apl_domino_operator_
			entry (1 aligned like operators_argument),
	apl_compression_	entry (1 aligned like operators_argument),
	apl_expansion_	entry (1 aligned like operators_argument),
	apl_reverse_	entry (1 aligned like operators_argument),
	apl_rotate_	entry (1 aligned like operators_argument),
	apl_transpose_	entry (1 aligned like operators_argument),
	apl_random_	entry (1 aligned like operators_argument),
	apl_grade_up_	entry (1 aligned like operators_argument),
	apl_grade_down_	entry (1 aligned like operators_argument),
          apl_quadcall_       entry (1 aligned like operators_argument),
	apl_external_fcn_addr_
			entry (char (*) aligned, ptr unaligned),
	external_function_ptr
			ptr,
	symbol_ptr_unal	ptr unaligned,
	meaning_ptr_unal	ptr unaligned,
	temp_ptr		ptr,
	value_bead_ptr	ptr,
	data_elements	fixed bin,
	start		fixed bin,
	put_result	fixed bin,
	return_point	fixed bin,
	number_of_arguments fixed bin,
	print_final_value	bit (1) aligned,
	code		fixed bin (35),
	error_mark_structure_ptr
			ptr unaligned,
	ok_to_stop_control	bit (1),
	apl_free_bead_	entry (ptr unaligned),
	i		fixed bin,
	packed_temp_ptr	ptr unaligned,
	ptr_to_returned_value
			ptr,
	bits_for_returned_value
			bit (36) aligned,
	number_of_non_labels
			fixed bin,
	monadic_table	(0:124) fixed bin int static init ((21) 1,
						/* 0-20 monadic scalar operators */
			(15) 1,			/* 21-35 unused */
			24,			/* 36 rho */
			4,			/* 37 comma */
			23,			/* 38 iota */
			(2) 1,			/* 39-40 take, drop (not monadic) */
			27,			/* 41 grade up */
			28,			/* 42 grade down */
			(2) 1,			/* 43-44 compress, expand last (not monadic) */
			11,			/* 45 reverse-last */
			(2) 1,			/* 46-47 compress, expand first (not monadic) */
			12,			/* 48 reverse-first */
			13,			/* 49 transpose */
			(3) 1,			/* 50-52 epsilon, decode, encode (not monadic) */
			14,			/* 53 execute */
			15,			/* 54 format */
			16,			/* 55 i-beam */
			10,			/* 56 not */
			26,			/* 57 roll */
			(9) 21,			/* 58-66 system functions */
			3,			/* 67 branch */
			25,			/* 68 domino */
			21,			/* 69 QuadSVR system function */
			21,			/* 70 QuadEC system function */
			21,			/* 71 QuadAF system function */
			1,			/* 72 semicolon cons (dyadic only) */
			(4) 1,			/* 73-76 dyadic file system functions */
			9,			/* 77 qFDROP file system function */
			1,			/* 78 qFERASE dyadic file system function */
			9,			/* 79 qFHOLD file system function */
			9,			/* 80 qFLIB file system function */
			9,			/* 81 qFLIM file system function */
			9,			/* 82 qFLISTACL file system function */
			(2) 1,			/* 83-84 niladic file system functions */
			9,			/* 85 qFRDCI file system function */
			9,			/* 86 qFREAD file system function */
			(3) 1,			/* 87-89 dyadic file system functions */
			9,			/* 90 qFSIZE */
			(2) 1,			/* 91-92 dyadic file system functions */
			29,			/* 93 laminate (dyadic only) */
			5,			/* 94 reduction last */
			6,			/* 95 reduction first */
			7,			/* 96 scan last */
			8,			/* 97 scan first */
			1,			/* 98 outer product */
			2,			/* 99 invoke function */
			1,			/* 100 stop control */
			1,			/* 101 trace control */
			1,			/* 102 assignment */
			1,			/* 103 subscripted assignment */
			17,			/* 104 quad gets */
			18,			/* 105 quad-quote gets */
			(6) 19,			/* 106-111 assign to system variable */
			(2) 22,			/* 112-113 assign to stop/trace */
			20,			/* 114 assign to system variable which ignores assignment */
			(5) 1,			/* 115-119 ignore */
			19,			/* 120 QuadIT system variable */
			9,			/* 121 qFUNTIE file system function */
			1,			/* 122 catenate first (dyadic only) */
                              30,                           /* 123 qCALL system function */
                              1),                           /* 124 qCALL semicolon (dyadic only) */
	dyadic_table	(0:124) fixed bin int static init ((21) 1,
						/* 0-20 dyadic scalar operators */
			(15) 1,			/* 21-35 unused */
			10,			/* 36 rho */
			6,			/* 37 comma */
			4,			/* 38 iota */
			15,			/* 39 take */
			16,			/* 40 drop */
			(2) 1,			/* 41-42 (grade up, grade down; not dyadic) */
			7,			/* 43 compress last */
			8,			/* 44 expand last */
			17,			/* 45 rotate-last */
			12,			/* 46 compress first */
			13,			/* 47 expand first */
			18,			/* 48 rotate-first */
			19,			/* 49 transpose */
			3,			/* 50 epsilon */
			20,			/* 51 decode */
			21,			/* 52 encode */
			1,			/* 53 execute (not dyadic) */
			23,			/* 54 format */
			29,			/* 55 dyadic i-beam */
			1,			/* 56 not (not dyadic) */
			25,			/* 57 deal */
			(9) 26,			/* 58-66 system functions */
			1,			/* 67 branch (not dyadic) */
			27,			/* 68 domino */
			(3) 1,			/* 69-71 monadic system functions */
			24,			/* 72 semicolon cons */
			9,			/* 73 qFADDACL file system function */
			9,			/* 74 qFAPPEND file system function */
			9,			/* 75 qFCREATE file system function */
			9,			/* 76 qFDELETEACL file system function */
			1,			/* 77 qFDROP monadic file system function */
			9,			/* 78 qFERASE file system function */
			(4) 1,			/* 79-82 monadic file system functions */
			(2) 1,			/* 83-84 niladic file system functions */
			(2) 1,			/* 85-86 monadic file system functions */
			9,			/* 87 qFRENAME file system function */
			9,			/* 88 qFREPLACE file system function */
			9,			/* 89 qFSETACL file system function */
			1,			/* 90 qFSIZE monadic file system function */
			9,			/* 91 qFSTIE file system function */
			9,			/* 92 qFTIE file system function */
			11,			/* 93 laminate */
			(4) 1,			/* 94-97 (reduction, scan; not dyadic) */
			14,			/* 98 outer product */
			5,			/* 99 invoke function */
			(2) 1,			/* 100-101 (stop, trace; not dyadic) */
			2,			/* 102 simple assignment */
			28,			/* 103 subscripted assignment */
			(18) 1,			/* 104-121 (various; not dyadic) */
			22,			/* 122 catenate first */
                              1,                            /* 123 qCALL system function (monadic only) */
                              24),                          /* 124 qCALL semicolon */
	value_bits	bit (36) aligned int static init ("0000001"b),
	computed_value_bits bit (36) aligned int static init ("0000001001"b),
	external_function_bits
			(2:4) bit (36) aligned int static
			init ("000001000010000000000000000001100011"b, "000011000010000000000000000001100011"b,
			"000101000010000000000000000001100011"b),
	1 rs		(1000) aligned based (rsp),
	  2 type		fixed bin,
	  2 bits		unaligned like operator_bead.bits_for_parse,
	  2 semantics	ptr unaligned,
	  2 lexeme	fixed bin,
	1 rs_for_op	(1000) aligned based (rsp),
	  2 type		fixed bin,
	  2 bits		unaligned like operator_bead.bits_for_parse,
	  2 semantics	fixed bin,
	  2 lexeme	fixed bin,
	1 rs_overlay	aligned based,
	  2 type		fixed bin,
	  2 bits		unaligned like operator_bead.bits_for_parse,
	  2 semantics	ptr unaligned,
	  2 lexeme	fixed bin,
	1 error_mark_structure
			aligned based (error_mark_structure_ptr),
	  2 error_line_number
			fixed bin,
	  2 error_line_index
			fixed bin (21),
	  2 error_index_within_line
			fixed bin,
	  2 length_of_line	fixed bin;

/* include files */

%include apl_number_data;
%include apl_characters;
%include apl_ws_info;
%include apl_bead_format;
%include apl_function_bead;
%include apl_lexed_function_bead;
%include apl_operator_bead;
%include apl_operators_argument;
%include apl_parse_frame;
%include apl_symbol_bead;
%include apl_value_bead;
%include apl_list_bead;
%include apl_operator_codes;

/* Initialize interrupt masking bits and mask parse against interrupts. Actually, there is
   a very small window between the time we turn on the bits and the time we establish the default
   handler. If the user sneaks in a quit in the window, he'd better type start and not program_interrupt... */

	call reset_interrupt_info;
	call condition_ ("any_other", apl_default_handler_);

/* We should really do the following order on user_input, and check the
   status code if it fails. (Which it would in &attach mode in an ec).
   Probably we should not use read_back_spaces at all... */

	call iox_$control (iox_$user_io, read_back_spaces_order, null, (0));
	n_underflows = 0;

start_anew:
	ws_info.current_parse_frame_ptr -> parse_frame.last_parse_frame_ptr = null;
						/* sb in other pgm */
	parse_frame_ptr = ws_info.current_parse_frame_ptr;/* copy frame ptr into auto */
	call initialize_suspended_frame;

ws_just_loaded:
	if parse_frame.parse_frame_type = evaluated_frame_type
	then go to read_and_lex_line;

	if ws_info.wsid = "clear ws"			/* skip latent expression */
	then go to read_and_lex_line;

	number_of_ptrs = 1;				/* so size builtin will work, below. */
	input_buffer_ptr = addrel (parse_frame_ptr, size (parse_frame) - 1);
	input_buffer.n_read = 5;
	input_buffer.line = QExecuteSign || QQuad || "lx" || QNewLine;
						/* _eqLX */
	parse_frame.current_line_number = 1;
	call lex_input_line (code);
	go to start_line;

next_line:
	if parse_frame.lexed_function_bead_ptr ^= null
	then call decrement_reference_count (parse_frame.lexed_function_bead_ptr);

read_and_lex_line:
	code = 1;
	do while (code ^= 0);
	     call read_executable_input_line;
	     call lex_input_line (code);
	end;

start_line:
	lexed_function_bead_ptr = parse_frame.lexed_function_bead_ptr;
						/* copy into auto */
						/* If there are no statements, this is an empty function and we are done. */

	if lexed_function_bead_ptr -> lexed_function_bead.number_of_statements = 0
	then go to function_return;

	current_lexeme = lexed_function_bead_ptr -> statement_map (parse_frame.current_line_number) + 1;
						/* end of line is after line */
	have_a_line = "1"b;				/* if interrupt, we now have a line to print */
	if parse_frame_type = function_frame_type
	then if parse_frame.function_bead_ptr -> stop_control_pointer ^= null
	     then if this_statement_is_one (parse_frame.current_line_number,
		     parse_frame.function_bead_ptr -> stop_control_pointer)
		then if ok_to_stop_control
		     then do;
			     call print_where_I_am (parse_frame_ptr, "0"b, "1"b);
			     call save_state;
			     call push_new_frame;
			     call initialize_suspended_frame;
			     go to read_and_lex_line;
			end;

	ok_to_stop_control = "1"b;
	print_final_value = "1"b;
	was_branch = "0"b;
	was_branch_value = "0"b;
	trace_branch_line = "0"b;
	current_parseme = 1;			/* fill in first parseme - end of line */
	parse_frame.initial_value_stack_ptr = ws_info.value_stack_ptr;
	rs (current_parseme).type = eol_type;		/* fill in first parseme on reduction stack */
	unspec (rs (current_parseme).bits) = ""b;
	if clean_interrupt_pending
	then do;
		dont_interrupt_parse = "0"b;
		current_lexeme = current_lexeme - 1;
		go to dirty_stop;
	     end;

	go to re;					/* get into reductions at re (right end) */

/*		A P L    R E D U C T I O N S

   These reductions are the heart of the APL interpreter.  Using the lexeme array
   produced by apl_lex_, the following code determines the next action to be
   performed, calls the necessary operator routines, and "reduces" the stack
   by the work just done, putting the result in place of the operator and
   input arguments. */

re:
	return_point = 8;
	go to pull;
operator_return (8):
	go to x_re (rs (current_parseme).type);		/* dispatch on what it was */

x_re (1):						/* BOL RE */
bol_re:
	if parse_frame_type = evaluated_frame_type
	then if rs (current_parseme - 1).semantics_valid
	     then go to bad_evaluated_input;
	     else go to next_line;

	if parse_frame_type = execute_frame_type
	then if rs (current_parseme - 1).semantics_valid
	     then go to bad_execute;
	     else do;
		     ptr_to_returned_value = null;
		     bits_for_returned_value = value_bits;
		     go to eval_execute_return;
		end;

	go to done_line;

x_re (2):						/* VAL RE */
val_re:
	return_point = 9;
	go to pull;
operator_return (9):
	go to x_val_re (rs (current_parseme).type);

x_re (3):						/* OP  RE */
	if rs (current_parseme).op1 ^= branch_code	/* allow only -> here */
	then go to not_end_with_value;

pop_stack:
	call clean_up_rs;
	if last_parse_frame_ptr = null
	then go to next_line;
	if parse_frame.lexed_function_bead_ptr ^= null
	then do;
		lexed_function_bead_ptr = parse_frame.lexed_function_bead_ptr;
		call restore_old_meanings;
		call decrement_reference_count (parse_frame.lexed_function_bead_ptr);
		if parse_frame.parse_frame_type = function_frame_type
		then call decrement_reference_count (parse_frame.function_bead_ptr);
	     end;
	parse_frame_ptr = last_parse_frame_ptr;
	call restore_state;
	if parse_frame_type ^= suspended_frame_type
	then go to pop_stack;
	else go to next_line;

x_re (4):						/* (   RE */
	go to context_error_0;

x_re (5):						/* )   RE */
	go to re;

x_re (6):						/* [   RE */
	call append_to_list_bead (addr (rs (current_parseme - 1)) -> rs_overlay);
	rs (current_parseme - 1).semantics -> list_bead.member_ptr (1) = null;
	unspec (rs (current_parseme - 1).semantics -> list_bead.bits (1)) = ""b;
	rs (current_parseme - 1).lexeme = rs (current_parseme).lexeme;
	current_parseme = current_parseme - 1;
	rs (current_parseme).type = subscript_type;
	go to sub;

x_re (7):						/* ]SB RE */
	go to re;

x_re (8):						/* ]RK RE */
	go to context_error_0;

x_re (9):						/* ;   RE */
	print_final_value = "1"b;
	call append_to_list_bead (addr (rs (current_parseme - 1)) -> rs_overlay);
	rs (current_parseme - 1).semantics -> list_bead.member_ptr (1) = null;
	unspec (rs (current_parseme - 1).semantics -> list_bead.bits (1)) = ""b;
						/* bits.op1 = 0 means print value */
	current_parseme = current_parseme - 1;
	go to re;

x_re (10):					/* <>   RE */
	call print_value;
	current_parseme = current_parseme - 1;
	print_final_value = "1"b;
	go to re;

x_val_re (1):					/* BOL VAL RE */
bol_val_re:
	if rs (current_parseme - 2).semantics_valid
	then do;					/* if line had any mixed-output semicolons */
		call append_to_list_bead (addr (rs (current_parseme - 2)) -> rs_overlay);
		if print_final_value		/* set up bits.op1 for whether to print value */
		then rs (current_parseme - 1).bits.op1 = 0;
		else rs (current_parseme - 1).bits.op1 = 1;
		unspec (rs (current_parseme - 2).semantics -> list_bead.bits (1)) =
		     unspec (rs (current_parseme - 1).bits);
		rs (current_parseme - 2).semantics -> list_bead.member_ptr (1) = rs (current_parseme - 1).semantics;
		rs (current_parseme - 1) = rs (current_parseme);
		current_parseme = current_parseme - 1;
		go to bol_re;
	     end;

	if parse_frame.parse_frame_type = evaluated_frame_type | parse_frame.parse_frame_type = execute_frame_type
	then do;
		ptr_to_returned_value = rs (current_parseme - 1).semantics;
		bits_for_returned_value = unspec (rs (current_parseme - 1).bits);

eval_execute_return:
		call decrement_reference_count (parse_frame.lexed_function_bead_ptr);
		parse_frame_ptr = last_parse_frame_ptr;
		call restore_state_after_execute;
		rs (put_result).type = val_type;
		rs (put_result).semantics = ptr_to_returned_value;
		unspec (rs (put_result).bits) = bits_for_returned_value;
		go to operator_return (return_point);
	     end;

	go to done_line;

x_val_re (2):					/* VAL VAL RE */
	go to context_error_0;

x_val_re (3):					/* OP  VAL RE */
op_val_re:
          if rs (current_parseme).op1 = semicolon_cons_code | rs (current_parseme).op1 = quadcall_semicolon_code
          then if rs (current_parseme-2).op1 = semicolon_cons_code | rs (current_parseme-2).op1 = quadcall_semicolon_code
               then do;                                     /* Do previously deferred semicolon. */
                    current_parseme = current_parseme - 1;
                    current_lexeme = current_lexeme + 1;
                    goto val_op_val_re;
               end;
               else do;                                     /* Defer semicolon until its left arg is evaluated. */
                    rs (current_parseme).type = close_paren_type; /* Evaluation deferred by pretending it's a ')'. */
                    goto re;
               end;
	return_point = 10;

	if (rs (current_parseme).op1 = assignment_code) | (rs (current_parseme).op1 = subscripted_assignment_code)
	then go to pull_assignment_variable;

	go to pull;
operator_return (10):
	go to x_op_val_re (rs (current_parseme).type);

x_val_re (4):					/* (   VAL RE */
          if rs (current_parseme-2).op1 = semicolon_cons_code | rs (current_parseme-2).op1 = quadcall_semicolon_code
          then do;                                          /* Do previously deferred semicolon. */
               current_parseme = current_parseme - 1;
               current_lexeme = current_lexeme + 1;
               goto val_op_val_re;
          end;
	print_final_value = "1"b;
	rs (current_parseme - 2) = rs (current_parseme - 1);
	current_parseme = current_parseme - 2;
	if rs (current_parseme - 1).type = op_type
	then go to val_op_val_re;
	else if rs (current_parseme - 1).type = subscript_type
	then go to val_sub;
	else go to val_re;

x_val_re (5):					/* )   VAL RE */
	go to context_error_0;

x_val_re (6):					/* [   VAL RE */
open_bracket_val_re:
	rs (current_parseme - 2).type = subscript_type;
	call append_to_list_bead (addr (rs (current_parseme - 2)) -> rs_overlay);
	unspec (rs (current_parseme - 2).semantics -> list_bead.bits (1)) = unspec (rs (current_parseme - 1).bits);
	rs (current_parseme - 2).semantics -> list_bead.member_ptr (1) = rs (current_parseme - 1).semantics;
	rs (current_parseme - 2).lexeme = rs (current_parseme).lexeme;
	current_parseme = current_parseme - 2;
	go to sub;

x_val_re (7):					/* ]SB VAL RE */
	go to context_error_0;

x_val_re (8):					/* ]RK VAL RE */
	go to re;

x_val_re (9):					/* ;   VAL RE */
semi_colon_val_re:
	call append_to_list_bead (addr (rs (current_parseme - 2)) -> rs_overlay);
	rs (current_parseme - 1).bits.op1 = binary (^print_final_value, 1);
						/* 1 if assignment, else 0 */
	unspec (rs (current_parseme - 2).semantics -> list_bead.bits (1)) = unspec (rs (current_parseme - 1).bits);
	rs (current_parseme - 2).semantics -> list_bead.member_ptr (1) = rs (current_parseme - 1).semantics;
	current_parseme = current_parseme - 2;
	print_final_value = "1"b;
	go to re;

x_val_re (10):					/* <>   VAL RE */
diamond_val_re:
          diamond_temp = current_parseme;
          tmp_parseme  = parse_frame.current_parseme;
	call print_value;
          call clean_up_rs;
          current_parseme = diamond_temp;
          parse_frame.current_parseme = tmp_parseme;
	print_final_value = "1"b;
	go to re;

x_op_val_re (1):					/* BOL OP  VAL RE */
	start = current_parseme - 1;
	put_result = current_parseme - 2;
	return_point = 1;
	go to do_monadic;
operator_return (1):
	rs (put_result).lexeme = rs (current_parseme - 1).lexeme;
	rs (current_parseme - 1).type = bol_type;
	current_parseme = current_parseme - 1;
	go to bol_val_re;

x_op_val_re (2):					/* VAL OP  VAL RE */
val_op_val_re:
	start = current_parseme;
	put_result = current_parseme - 2;
	return_point = 2;
	go to do_dyadic;
operator_return (2):
	rs (put_result).lexeme = rs (current_parseme).lexeme;
	current_parseme = current_parseme - 2;
	go to val_re;

x_op_val_re (3):					/* OP  OP  VAL RE */
	start = current_parseme - 1;
	put_result = current_parseme - 2;
	return_point = 3;
	go to do_monadic;
operator_return (3):
	rs (put_result).lexeme = rs (current_parseme - 1).lexeme;
	rs (current_parseme - 1) = rs (current_parseme);
	current_parseme = current_parseme - 1;
	go to op_val_re;

x_op_val_re (4):					/* (   OP  VAL RE */
          if rs (current_parseme-3).op1 = semicolon_cons_code | rs (current_parseme-3).op1 = quadcall_semicolon_code
          then do;                                          /* Change from (OP VAL1;VAL2)... TO (OP VAL1);VAL2... */
               rs (current_parseme-5) = rs (current_parseme-4);
               rs (current_parseme-4) = rs (current_parseme-3);
               rs (current_parseme-4).type = op_type;       /* Remember we pretended the ';' was a ')'. */
          end;
	start = current_parseme - 1;
	put_result = current_parseme - 3;
	return_point = 4;
	go to do_monadic;
operator_return (4):
	print_final_value = "1"b;
	rs (current_parseme - 3).lexeme = rs (current_parseme - 2).lexeme;
	current_parseme = current_parseme - 3;
	if rs (current_parseme - 1).type = op_type
	then go to val_op_val_re;
	else if rs (current_parseme - 1).type = subscript_type
	then go to val_sub;
	else go to val_re;

x_op_val_re (5):					/* )   OP  VAL RE */
	go to re;

x_op_val_re (6):					/* [   OP  VAL RE */
	start = current_parseme - 1;
	put_result = current_parseme - 2;
	return_point = 5;
	go to do_monadic;
operator_return (5):
	rs (current_parseme - 1) = rs (current_parseme);
	current_parseme = current_parseme - 1;
	go to open_bracket_val_re;

x_op_val_re (7):					/* ]SB OP  VAL RE */
	go to re;

x_op_val_re (8):					/* ]RK OP  VAL RE */
	start = current_parseme - 1;
	put_result = current_parseme - 2;
	return_point = 6;
	go to do_monadic;
operator_return (6):
	rs (current_parseme - 1) = rs (current_parseme);
	current_parseme = current_parseme - 1;
	go to re;

x_op_val_re (9):					/* ;   OP  VAL RE */
	start = current_parseme - 1;
	put_result = current_parseme - 2;
	return_point = 7;
	go to do_monadic;
operator_return (7):
	rs (current_parseme - 1) = rs (current_parseme);
	current_parseme = current_parseme - 1;
	if was_branch_value
	then go to bol_val_re;
	go to semi_colon_val_re;

x_op_val_re (10):					/* <>   OP VAL RE */
	start = current_parseme - 1;
	put_result = current_parseme - 2;
	return_point = 12;
	go to do_monadic;
operator_return (12):
	rs (current_parseme - 1) = rs (current_parseme);
	current_parseme = current_parseme - 1;
	if was_branch_value
	then go to bol_val_re;
	go to diamond_val_re;

sub:
	return_point = 11;
	go to pull;
operator_return (11):
	go to x_sub (rs (current_parseme).type);

x_sub (1):					/* BOL SUB */
	go to context_error_0;

x_sub (2):					/* VAL SUB */
val_sub:
	if rs (current_parseme).semantics = null
	then call value_error_reporter (current_lexeme);

	operators_argument.value (1) = rs (current_parseme).semantics;
	operators_argument.value (2) = rs (current_parseme - 1).semantics;
	operators_argument.on_stack (1) = rs (current_parseme).bits.semantics_on_stack;
	operators_argument.where_error = current_parseme - 1;
	operators_argument.error_code = 0;

	call apl_subscript_a_value_ (operators_argument);

	if operators_argument.error_code ^= 0
	then go to report_error_from_operator;

	if ^operators_argument.on_stack (1)
	then call decrement_reference_count (rs (current_parseme).semantics);
	rs (current_parseme - 1).semantics = operators_argument.result;
	unspec (rs (current_parseme - 1).bits) = computed_value_bits;
	rs (current_parseme - 1).type = val_type;
	rs (current_parseme - 1).lexeme = rs (current_parseme).lexeme;
	print_final_value = "1"b;
	current_parseme = current_parseme - 1;
	if rs (current_parseme - 1).type = op_type
	then go to val_op_val_re;
	else if rs (current_parseme - 1).type = subscript_type
	then go to val_sub;
	else go to val_re;

x_sub (3):					/* OP  SUB */
	if ^rs (current_parseme - 1).semantics_valid
	then go to value_error_1;
	if rs (current_parseme).op1 = subscripted_assignment_code
	then do;
		rs (current_parseme).semantics = rs (current_parseme - 1).semantics;
		rs (current_parseme).semantics_valid = "1"b;
		rs (current_parseme).semantics_on_stack = "1"b;
		rs (current_parseme).has_list = "1"b;
		rs (current_parseme - 1) = rs (current_parseme);
		current_parseme = current_parseme - 1;
		go to op_val_re;
	     end;
	temp_ptr = rs (current_parseme - 1).semantics;
	if temp_ptr -> list_bead.number_of_members ^= 1
	then go to rank_error_1;
	temp_ptr = temp_ptr -> list_bead.member_ptr (1);
	if temp_ptr = null
	then go to value_error_1;
	if temp_ptr -> value_bead.total_data_elements ^= 1
	then go to rank_error_1;
	if ^temp_ptr -> value_bead.numeric_value
	then go to domain_error_1;
	x = temp_ptr -> value_bead.data_pointer -> numeric_datum (0);

/* make sure the rank-subscript is an integer */

	xx = floor (x + 0.5);
	if abs (xx - x) >= integer_fuzz
	then do;					/* not an integer - allow if laminate */
		if rs (current_parseme).op1 ^= ravel_code
		then go to rank_error_1;

		rs (current_parseme).op1 = laminate_code;
		xx = floor (x);			/* set up value to pass to laminate routine */
	     end;					/* fix the rank-subscript */

	if abs (xx) > 100000
	then go to rank_error_1;
	i = fixed (xx, 17) + 1 - index_origin;		/* convert to 1-origin for operators */
	if i <= 0
	then if rs (current_parseme).op1 ^= laminate_code /* if not laminate, which is special, */
	     then go to rank_error_1;			/* then barf if not a good number */
	     else if i ^= 0
	     then go to rank_error_1;			/* if laminate, then barf if negative, but */
	     else ;				/* laminate on zero'th dimension is allowed. */
	rs_for_op (current_parseme).semantics = i;
	rs (current_parseme).semantics_valid = "1"b;
	if ^rs (current_parseme - 1).semantics -> list_bead.semantics_on_stack (1)
	then call decrement_reference_count (rs (current_parseme - 1).semantics -> list_bead.member_ptr (1));
	rs (current_parseme - 1) = rs (current_parseme);
	current_parseme = current_parseme - 1;
	go to op_val_re;

x_sub (4):					/* (   SUB */
	go to context_error_0;

x_sub (5):					/* )   SUB */
	go to re;

x_sub (6):					/* [   SUB */
	go to context_error_0;

x_sub (7):					/* ]SB SUB */
	go to re;

x_sub (8):					/* ]RK SUB */
	go to context_error_0;

x_sub (9):					/* ;   SUB */
	go to context_error_0;

x_sub (10):					/* <>   SUB */
	go to context_error_0;

done_line:
	if parse_frame.parse_frame_type = function_frame_type
	then if parse_frame.function_bead_ptr -> function_bead.trace_control_pointer ^= null
	     then call check_trace_vector;

	print_final_value = print_final_value | trace_branch_line;

	if ^was_branch_value | trace_branch_line	/* branch aborts mixed output, unless traced */
	then call print_value;

	call clean_up_rs;

	if parse_frame.parse_frame_type = suspended_frame_type
	then do;
		if ^was_branch
		then go to next_line;

		if last_parse_frame_ptr = null
		then go to next_line;

		if was_branch_value
		then last_parse_frame_ptr -> parse_frame.current_line_number = parse_frame.current_line_number;

		call decrement_reference_count (parse_frame.lexed_function_bead_ptr);
		ok_to_stop_control = "0"b;
		parse_frame_ptr = last_parse_frame_ptr;
		call restore_state;
		go to increment_function_line_number;
	     end;

	if parse_frame_type = function_frame_type
	then do;
increment_function_line_number:
		parse_frame.current_line_number = parse_frame.current_line_number + 1;
		if parse_frame.current_line_number < 1
		     | parse_frame.current_line_number > lexed_function_bead_ptr -> number_of_statements
		then go to function_return;
		go to start_line;
	     end;

	go to done_line_system_error;			/* workspace is screwed up */

function_return:
	ptr_to_returned_value = lexed_function_bead_ptr -> localized_symbols (ReturnSymbol);
	if ptr_to_returned_value ^= null
	then do;
		ptr_to_returned_value = ptr_to_returned_value -> meaning_pointer;
		if ptr_to_returned_value ^= null
		then ptr_to_returned_value -> general_bead.reference_count =
			ptr_to_returned_value -> general_bead.reference_count + 1;
	     end;

	call restore_old_meanings;
	call decrement_reference_count (parse_frame.lexed_function_bead_ptr);
	call decrement_reference_count (parse_frame.function_bead_ptr);
	parse_frame_ptr = last_parse_frame_ptr;
	call restore_state;

	if number_of_arguments = 2
	then do;					/* dyadic case */

/* arguments are known to be in the heap, not on the stack. */

		call decrement_reference_count (rs (start).semantics);
		call decrement_reference_count (rs (start - 2).semantics);
	     end;
	else if number_of_arguments = 1
	then call decrement_reference_count (rs (start - 1).semantics);
						/* monadic case */
	else ;					/* niladic...no arguments */


	rs (put_result).semantics = ptr_to_returned_value;
	rs (put_result).type = val_type;
	unspec (rs (put_result).bits) = value_bits;
	go to operator_return (return_point);

return_statement:
	return;

context_error_0:
	operators_argument.error_code = apl_error_table_$context;
	go to report_error;

value_error_1:
	operators_argument.error_code = apl_error_table_$value;
	current_lexeme = rs (current_parseme - 1).lexeme;
	go to report_error;

domain_error:
	operators_argument.error_code = apl_error_table_$domain;
	current_lexeme = rs (operators_argument.where_error).lexeme;
	go to report_error;

domain_error_1:
	operators_argument.error_code = apl_error_table_$domain;
	current_lexeme = rs (current_parseme - 1).lexeme;
	go to report_error;

value_error_s2:
	operators_argument.error_code = apl_error_table_$value;
	current_lexeme = rs (start - 2).lexeme;
	go to report_error;

value_error_s0:
	operators_argument.error_code = apl_error_table_$value;
	current_lexeme = rs (start).lexeme;
	go to report_error;

value_error_s1:
	operators_argument.error_code = apl_error_table_$value;
	current_lexeme = rs (start - 1).lexeme;
	go to report_error;

improper_dyadic_usage:
	operators_argument.error_code = apl_error_table_$improper_dyadic_usage;
	current_lexeme = rs (start - 1).lexeme;
	go to report_error;

improper_monadic_usage:
	operators_argument.error_code = apl_error_table_$improper_monadic_usage;
	current_lexeme = rs (start).lexeme;
	go to report_error;

improper_niladic_usage:
	operators_argument.error_code = apl_error_table_$improper_niladic_usage;
	current_lexeme = rs (start + 1).lexeme;
	go to report_error;

rank_error_1:
	operators_argument.error_code = apl_error_table_$operator_subscript_range;
	current_lexeme = rs (current_parseme - 1).lexeme;
	go to report_error;

bad_assignment:
	operators_argument.error_code = apl_error_table_$bad_assignment;
	current_lexeme = rs (operators_argument.where_error).lexeme;
	go to report_error;

bad_assign_to_label:
	operators_argument.error_code = apl_error_table_$assign_to_label;
	current_lexeme = rs (operators_argument.where_error).lexeme;
	go to report_error;

bad_evaluated_input:
	operators_argument.error_code = apl_error_table_$bad_evaluated_input;
	current_lexeme = current_lexeme + 1;		/* assumes only called from bol_re */
	go to report_error;

bad_execute:
	operators_argument.error_code = apl_error_table_$bad_execute;
	call clean_up_rs;
	parse_frame_ptr = last_parse_frame_ptr;
	call restore_state;
	current_lexeme = 2;
	go to report_error;

domain_error_s1:
	operators_argument.error_code = apl_error_table_$domain;
	current_lexeme = rs (start - 1).lexeme;
	go to report_error;

rank_error_s1:
	operators_argument.error_code = apl_error_table_$rank;
	current_lexeme = rs (start - 1).lexeme;
	go to report_error;

execute_error_s0:
	parse_frame_ptr = last_parse_frame_ptr;
	call restore_state;
	operators_argument.error_code = apl_error_table_$execute;
	current_lexeme = rs (current_parseme - 1).lexeme;
	go to report_error;

depth_error:
	operators_argument.error_code = apl_error_table_$depth;
						/* depth errors get special handling. */

join_depth_handler:
	call apl_error_ (operators_argument.error_code, ""b, 0, "", null, 0);
	call reset_interrupt_info;
	call initialize_suspended_frame;
	go to read_and_lex_line;

cant_get_stop_trace:
	operators_argument.error_code = apl_error_table_$cant_get_stop_trace;
	go to report_error;

not_end_with_value:
	operators_argument.error_code = apl_error_table_$not_end_with_value;
	go to report_error;

ws_full_no_quota_error:
	ws_info.dont_interrupt_parse = "1"b;
	operators_argument.error_code = apl_error_table_$ws_full_no_quota;

/* because the apl_lex_ routine which is used to help position the error marker uses
   several pages of free storage (on the various stacks), we would probably take a
   fatal process error if the quota fault is on the process directory. Until this
   code can be upgraded to check the pdir quota, or to check the quota on the directory
   containing the segment on which we faulted, we will just play it safe and not
   call the lex. (thus avoiding recursive RQO faults). sigh. */

	have_a_line = "0"b;
	go to report_error;

dirty_stop:
	call reset_interrupt_info;
	operators_argument.error_code = apl_error_table_$interrupt;
	go to report_error;

pull_system_error:
	operators_argument.error_code = apl_error_table_$pull_system_error;
	go to report_error;

pull_assign_system_error:
	operators_argument.error_code = apl_error_table_$pull_assign_system_error;
	go to report_error;

report_error_system_error:
	operators_argument.error_code = apl_error_table_$report_error_system_error;
	go to join_depth_handler;			/* special action to avoid loop */

done_line_system_error:
	operators_argument.error_code = apl_error_table_$done_line_system_error;
	go to report_error;

report_error_from_operator:
	current_lexeme = rs (operators_argument.where_error).lexeme;

report_error:
	if (parse_frame.parse_frame_type = suspended_frame_type) | (parse_frame.parse_frame_type = evaluated_frame_type)
	then do;
		if have_a_line
		then call apl_line_lex_ (input_buffer.line, error_mark_structure_ptr, was_error, current_lexeme,
			addr (rs (current_parseme + 1)));
		else do;
			n_read = 0;		/* if no line, pass a null string to apl_error_ */
			error_mark_structure_ptr = parse_frame_ptr;
						/* (KLUDGE) values won't be used, can point anywhere. */
		     end;

		packed_temp_ptr = null;
		call apl_error_ (operators_argument.error_code, ""b, error_index_within_line, input_buffer.line,
		     packed_temp_ptr, 0);
	     end;
	else if parse_frame_type = function_frame_type
	then do;
		symbol_ptr_unal = parse_frame.lexed_function_bead_ptr -> lexed_function_bead.name;
		meaning_ptr_unal = parse_frame.function_bead_ptr;
		if meaning_ptr_unal -> function_bead.class ^= 0
		then do;

/* error while executing in locked function - cause domain error in caller */

			operators_argument.error_code = apl_error_table_$locked_function_error;
			parse_frame_ptr = parse_frame.last_parse_frame_ptr;
						/* unwind */
			call restore_state;
			go to report_error;
		     end;

		call apl_function_lex_ (meaning_ptr_unal -> function_bead.text, error_mark_structure_ptr, was_error,
		     current_lexeme, addr (rs (current_parseme + 1)));
		call apl_error_ (operators_argument.error_code, ""b, error_index_within_line,
		     substr (meaning_ptr_unal -> function_bead.text, error_line_index, length_of_line), symbol_ptr_unal,
		     parse_frame.current_line_number);

	     end;
	else if parse_frame.parse_frame_type = execute_frame_type
	then do;
		call clean_up_rs;
		where_execute_error = current_lexeme;
		if parse_frame.lexed_function_bead_ptr ^= null
		then call decrement_reference_count (parse_frame.lexed_function_bead_ptr);
		parse_frame_ptr = last_parse_frame_ptr;
		call restore_state;

		if ws_info.long_error_mode
		then do;
			execute_value_ptr = rs (current_parseme - 2).semantics;
			data_elements = execute_value_ptr -> value_bead.total_data_elements;
			call apl_execute_lex_ (execute_value_ptr -> value_bead.data_pointer -> character_string_overlay,
			     error_mark_structure_ptr, was_error, where_execute_error, addr (rs (current_parseme + 1)));
			packed_temp_ptr = null;
			call apl_error_ (operators_argument.error_code, ""b, error_index_within_line,
			     substr (execute_value_ptr -> value_bead.data_pointer -> character_string_overlay, 1),
			     packed_temp_ptr, 0);
		     end;

		current_lexeme = rs (current_parseme - 1).lexeme;
		operators_argument.error_code = apl_error_table_$execute;
		go to report_error;
	     end;
	else go to report_error_system_error;		/* workspace is screwed up */

recover_from_error:
	call reset_interrupt_info;
	call clean_up_rs;

	if parse_frame_type = suspended_frame_type
	then go to next_line;
	if parse_frame_type = evaluated_frame_type
	then go to next_line;

	call save_state;
	call push_new_frame;
	call initialize_suspended_frame;
	go to read_and_lex_line;

/* Called on simple assignmnet and subscripted assignment to get the variable being assigned to. */

pull_assignment_variable:
	current_parseme = current_parseme + 1;		/* bump parseme number */
	current_lexeme = current_lexeme - 1;		/* and move to the left to get next lexeme */
	rs (current_parseme).lexeme = current_lexeme;	/* remember where we got it */
	unspec (rs (current_parseme).bits) = ""b;	/* initialize state bits */
	operator_ptr = lexed_function_bead_ptr -> lexeme_array_ptr -> lexed_function_lexeme_array (current_lexeme);

	if ^operator_ptr -> general_bead.type.symbol
	then go to pull_assign_system_error;		/* lex is supposed to check */

	rs (current_parseme).semantics = operator_ptr -> symbol_bead.meaning_pointer;
	if rs (current_parseme).semantics = null
	then go to pull_null_var;			/* not yet assigned */
	if rs (current_parseme).semantics -> general_bead.type.value
	then do;					/* pull variable action - has value that will be replaced */
		rs (current_parseme).type = val_type;
		unspec (rs (current_parseme).bits) = value_bits;
		rs (current_parseme).semantics -> general_bead.reference_count =
		     rs (current_parseme).semantics -> general_bead.reference_count + 1;
		go to operator_return (return_point);
	     end;

/* assign to a function or something - barf */

	operators_argument.error_code = apl_error_table_$assign_to_value;
	go to report_error;

pull:
	current_parseme = current_parseme + 1;		/* bump parseme number */
	current_lexeme = current_lexeme - 1;		/* and move to the left to get next lexeme */
	rs (current_parseme).lexeme = current_lexeme;	/* remember where we got it */
	operator_ptr = lexed_function_bead_ptr -> lexeme_array_ptr -> lexed_function_lexeme_array (current_lexeme);

/* Until the compiler optimizes repeated references to bits in the same word, we'll do it by hand
   in the following case statement. (We really just want to check general_bead.type.operator, etc). */

	temp18 = string (operator_ptr -> general_bead.type);
						/* copy for speed */

	if temp18 = operator_type			/* is it an operator? */
	then do;
		rs (current_parseme).type = operator_ptr -> operator_bead.type_code;
		unspec (rs (current_parseme).bits) = unspec (operator_ptr -> operator_bead.bits_for_parse);

/* Until compiler combines tests before it combines common subexpressions, the
   following kludgy code is the only way to test both the system_variable and stop_trace bits */

		if (unspec (rs (current_parseme).bits) & "101000000000000000"b) ^= ""b
		then if rs (current_parseme).stop_trace_control
		     then go to pull_stop_trace;
		     else go to pull_system_variable;
		else go to operator_return (return_point);
	     end;
	else if temp18 = symbol_type			/* is it a symbol? */
	then do;
	     if current_lexeme > 1
	     & current_lexeme < lexed_function_bead_ptr -> statement_map (parse_frame.current_line_number)
	     then do;				/*  Check if symbol should be passed by name.  */
		temp_ptr = operator_ptr -> symbol_bead.meaning_pointer;
		if temp_ptr ^= null
		then if ^temp_ptr -> general_bead.value
		     then goto not_by_name;		/*  Must be undefined or a value.  */
		temp_ptr = lexed_function_bead_ptr -> lexeme_array_ptr
		     -> lexed_function_lexeme_array (current_lexeme - 1);
		if string (temp_ptr -> general_bead.type) ^= operator_type
		then goto not_by_name;		/*  Must be preceded by a 'qCALL' ";".  */
		if temp_ptr -> operator_bead.op1 ^= quadcall_semicolon_code
		then goto not_by_name;		/*  Must be preceded by a 'qCALL' ";".  */
		temp_ptr = lexed_function_bead_ptr -> lexeme_array_ptr
		     -> lexed_function_lexeme_array (current_lexeme + 1);
		if string (temp_ptr -> general_bead.type) ^= operator_type
		then goto not_by_name;		/*  Must be followed by a 'qCALL' ";" or ")".  */
		if temp_ptr -> operator_bead.op1 ^= quadcall_semicolon_code
		& temp_ptr -> operator_bead.type_code ^= close_paren_type
		then goto not_by_name;		/*  Must be followed by a 'qCALL' ";" or ")".  */
		rs (current_parseme).semantics = operator_ptr; /*  semantics is symbol itself  */
		rs (current_parseme).type = val_type;
		unspec (rs (current_parseme).bits) = value_bits;
		rs (current_parseme).semantics -> general_bead.reference_count = rs (current_parseme).
		     semantics -> general_bead.reference_count + 1;
		go to operator_return (return_point);
not_by_name:
	     end;
		rs (current_parseme).semantics = operator_ptr -> symbol_bead.meaning_pointer;
						/* semantics is where symbol pts */
		if rs (current_parseme).semantics = null/* no value yet */
		then do;

pull_null_var:
			rs (current_parseme).type = val_type;
			unspec (rs (current_parseme).bits) = ""b;
			if rs (current_parseme - 1).type ^= op_type
			then call value_error_reporter (current_lexeme);
			if rs (current_parseme - 1).op1 ^= assignment_code
			then call value_error_reporter (current_lexeme);

			unspec (rs (current_parseme).bits) = value_bits;
			go to operator_return (return_point);
		     end;

		if rs (current_parseme).semantics -> general_bead.type.value
		then do;
			rs (current_parseme).type = val_type;
			unspec (rs (current_parseme).bits) = value_bits;
			rs (current_parseme).semantics -> general_bead.reference_count =
			     rs (current_parseme).semantics -> general_bead.reference_count + 1;
			go to operator_return (return_point);
		     end;

		if rs (current_parseme).semantics -> general_bead.type.function
		then do;
			temp_ptr = rs (current_parseme).semantics -> function_bead.lexed_function_bead_pointer;
			rs (current_parseme).type = op_type;
			unspec (rs (current_parseme).bits) = ""b;
			if temp_ptr = null		/* unlexed function */
			then do;
				temp_ptr = rs (current_parseme).semantics;

				if temp_ptr -> function_bead.class > 1
						/* external function */
				then do;
					call apl_external_fcn_addr_ (temp_ptr -> function_bead.text,
					     temp_ptr -> function_bead.lexed_function_bead_pointer);
					if temp_ptr -> function_bead.lexed_function_bead_pointer = null
					then go to recover_from_error;
				     end;
				else do;
					call apl_function_lex_no_messages_ (operator_ptr
					     -> symbol_bead.meaning_pointer -> function_bead.text,
					     temp_ptr -> function_bead.lexed_function_bead_pointer, was_error, 0,
					     addr (rs (current_parseme + 1)), (0));
					if was_error
					then go to recover_from_error;
				     end;
				temp_ptr = temp_ptr -> function_bead.lexed_function_bead_pointer;
			     end;
			rs (current_parseme).semantics -> general_bead.reference_count =
			     rs (current_parseme).semantics -> general_bead.reference_count + 1;

			if rs (current_parseme).semantics -> function_bead.class > 1
			then unspec (rs (current_parseme).bits) =
				external_function_bits (rs (current_parseme).semantics -> function_bead.class);
			else unspec (rs (current_parseme).bits) =
				unspec (temp_ptr -> lexed_function_bead.bits_for_parse);
			rs (current_parseme).semantics_valid = "1"b;

			if ^rs (current_parseme).bits.monadic
			then if ^rs (current_parseme).bits.dyadic
			     then do;
				     number_of_arguments = 0;
				     put_result = current_parseme;
				     start = current_parseme - 1;
				     go to invoke_niladic_function;
				end;
			go to operator_return (return_point);
		     end;

		rs (current_parseme).type = val_type;	/* get here if symbol isn't bound to a value */
		unspec (rs (current_parseme).bits) = ""b;
						/* or function...make rs consistent */
		rs (current_parseme).semantics = null;	/* again so we can keep running. */
	     end;
	else if (temp18 & value_type) = value_type	/* is it a value? */
	then do;
		operator_ptr -> general_bead.reference_count = operator_ptr -> general_bead.reference_count + 1;
		rs (current_parseme).semantics = operator_ptr;
		rs (current_parseme).type = val_type;
		unspec (rs (current_parseme).bits) = value_bits;
		go to operator_return (return_point);
	     end;

	go to pull_system_error;			/* invalid lexeme or invalid meaning for name */

pull_system_variable:
	if rs (current_parseme).op1 ^= 0
	then do;
		operators_argument.op1 = rs (current_parseme).op1;
		operators_argument.where_error = current_parseme;
		operators_argument.error_code = 0;

/* If op1 is code for niladic file system functions qFNAMES
   or qFNUMS, call the file system. */

		if (operators_argument.op1 = fnames_code) | (operators_argument.op1 = fnums_code)
		then call apl_file_system_$niladic_functions (operators_argument);
		else call apl_system_variables_ (operators_argument);
		if operators_argument.error_code ^= 0
		then go to report_error_from_operator;

		rs (current_parseme).semantics = operators_argument.result;
		unspec (rs (current_parseme).bits) = computed_value_bits;
						/* force the right bits on */
		rs (current_parseme).type = val_type;
		go to operator_return (return_point);
	     end;

	put_result = current_parseme;
	call save_state;
	call push_new_frame;
	parse_frame_type = evaluated_frame_type;
	parse_frame.number_of_ptrs, number_of_ptrs = 3;
	go to read_and_lex_line;

pull_stop_trace:
	current_lexeme = current_lexeme - 1;
	temp_ptr = operator_ptr;
	operator_ptr = lexed_function_bead_ptr -> lexeme_array_ptr -> lexed_function_lexeme_array (current_lexeme);
	rs (current_parseme).semantics = null;
	if operator_ptr -> meaning_pointer = null
	then go to cant_get_stop_trace;
	operator_ptr = operator_ptr -> meaning_pointer;
	if ^operator_ptr -> general_bead.function
	then go to cant_get_stop_trace;

	if temp_ptr -> operator_bead.op1 = stop_code
	then rs (current_parseme).semantics = operator_ptr -> function_bead.stop_control_pointer;
	else if temp_ptr -> operator_bead.op1 = trace_code
	then rs (current_parseme).semantics = operator_ptr -> function_bead.trace_control_pointer;
	else if temp_ptr -> operator_bead.op1 = assign_to_stop_code
	then rs (current_parseme).semantics = operator_ptr;
	else rs (current_parseme).semantics = operator_ptr;

	if rs (current_parseme).semantics = null
	then go to cant_get_stop_trace;

	rs (current_parseme).semantics -> general_bead.reference_count =
	     rs (current_parseme).semantics -> general_bead.reference_count + 1;

	go to operator_return (return_point);

do_dyadic:
	print_final_value = "1"b;
	operators_argument.where_error = start - 1;
	if ^rs (start - 1).bits.dyadic
	then go to improper_dyadic_usage;
	if rs (start - 1).bits.inner_product
	then go to do_inner_product;
	go to dyadic_action (dyadic_table (rs (start - 1).bits.op1));

dyadic_action (1):					/* scalar dyadic operators */
	call setup_dyadic_operator_routine_call;
	call apl_dyadic_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (2):					/* (non-subscripted) assignment */
	print_final_value = "0"b;

	if rs (start - 2).semantics = null		/* rhs */
	then go to value_error_s2;

	if rs (start).semantics_valid			/* lhs was pulled onto rs, but we don't */
	then if ^rs (start).semantics_on_stack		/* need it ... wash the ptr to it. */
	     then if rs (start).semantics ^= null
		then call decrement_reference_count (rs (start).semantics);

	temp_ptr =
	     lexed_function_bead_ptr -> lexed_function_bead.lexeme_array_ptr
	     -> lexed_function_lexeme_array (rs (start).lexeme);
						/* get ptr to symbol_bead for lhs */

	if ^temp_ptr -> general_bead.symbol		/* lhs must be a symbol */
	then go to bad_assignment;

	if temp_ptr -> symbol_bead.meaning_pointer ^= null
	then if temp_ptr -> symbol_bead.meaning_pointer -> general_bead.label
	     then go to bad_assign_to_label;		/* lhs cannot be a label */

/* CASE 1: If the rhs is already in the heap (and isn't a label) we can assign it by reference.
	 The reference count of the rhs is bumped by 2 because both the meaning_pointer
	 and rs (put_result).semantics point to it.  The fact that rs (start-2).semantics also
	 also points to it is already counted for...it will be washed away, below. */

	if ^rs (start - 2).semantics_on_stack /* if rhs on heap */ & ^rs (start - 2).semantics -> value_bead.label
						/* if rhs is not a label */
	then do;
		if temp_ptr -> symbol_bead.meaning_pointer ^= null
		then call decrement_reference_count (temp_ptr -> symbol_bead.meaning_pointer);
						/* drop lhs ref ct */

		rs (start - 2).semantics -> general_bead.reference_count =
		     rs (start - 2).semantics -> general_bead.reference_count + 2;

		temp_ptr -> symbol_bead.meaning_pointer = rs (start - 2).semantics;
						/* assign it */
	     end;

	else if temp_ptr -> symbol_bead.meaning_pointer ^= null /* lhs has meaning */
	     then if temp_ptr -> symbol_bead.meaning_pointer -> general_bead.reference_count = 1
		& string (rs (start - 2).semantics -> general_bead.bead_type)
		= string (temp_ptr -> symbol_bead.meaning_pointer -> general_bead.bead_type)
		& substr (string (rs (start - 2).semantics -> general_bead.data_type), 1, 3)
		= substr (string (temp_ptr -> symbol_bead.meaning_pointer -> general_bead.data_type), 1, 3)
		& rs (start - 2).semantics -> value_bead.total_data_elements
		= temp_ptr -> symbol_bead.meaning_pointer -> value_bead.total_data_elements
		& rs (start - 2).semantics -> value_bead.rhorho
		= temp_ptr -> symbol_bead.meaning_pointer -> value_bead.rhorho
	then do;

/* CASE 2: lhs has a value, it is unshared, and it occupies
   the same number of words as the rhs.  The rhs is just copied over the lhs */

		string (temp_ptr -> symbol_bead.meaning_pointer -> value_bead.data_type) =
		     string (rs (start - 2).semantics -> value_bead.data_type);

		data_elements = temp_ptr -> symbol_bead.meaning_pointer -> value_bead.total_data_elements;

		if temp_ptr -> symbol_bead.meaning_pointer -> value_bead.character_value
		then temp_ptr -> symbol_bead.meaning_pointer -> value_bead.data_pointer -> character_string_overlay =
			rs (start - 2).semantics -> value_bead.data_pointer -> character_string_overlay;
		else temp_ptr -> symbol_bead.meaning_pointer -> value_bead.data_pointer -> numeric_datum (*) =
			rs (start - 2).semantics -> value_bead.data_pointer -> numeric_datum (*);

		if temp_ptr -> symbol_bead.meaning_pointer -> value_bead.rhorho ^= 0
						/* make check 'cause PL/I won't */
		then temp_ptr -> symbol_bead.meaning_pointer -> value_bead.rho (*) =
			rs (start - 2).semantics -> value_bead.rho (*);

/* The reference count is 2 because both the meaning_pointer and rs (put_result).semantics
		        point to the bead. */

		temp_ptr -> symbol_bead.meaning_pointer -> value_bead.reference_count = 2;
		temp_ptr -> symbol_bead.meaning_pointer -> value_bead.label = "0"b;
	     end;

	else goto case_3;	/* else clause for multiple "and" clause test above */

	else do;	/* else clause for null pointer test */

/* CASE 3: Everything else comes here. We have to copy the rhs into the heap
   and make the lhs point to it.  The reference count of the lhs is bumped by 1
   because both the meaning_pointer and rs (put_result).semantics point to it. */

case_3:
		if temp_ptr -> symbol_bead.meaning_pointer ^= null
						/* drop old meaning */
		then call decrement_reference_count (temp_ptr -> symbol_bead.meaning_pointer);

		ws_info.dont_interrupt_parse = "0"b;	/* unmask so RQO handler can get control */
		call apl_copy_value_ (rs (start - 2).semantics, temp_ptr -> symbol_bead.meaning_pointer);
		ws_info.dont_interrupt_parse = "1"b;	/* remask */
		temp_ptr -> symbol_bead.meaning_pointer -> value_bead.label = "0"b;
		temp_ptr -> symbol_bead.meaning_pointer -> value_bead.reference_count =
		     temp_ptr -> symbol_bead.meaning_pointer -> value_bead.reference_count + 1;
	     end;

	if rs (start - 2).semantics_on_stack
	then ws_info.value_stack_ptr = rs (start - 2).semantics;
	else call decrement_reference_count (rs (start - 2).semantics);
						/* wash rs ptr to rhs */

	rs (put_result).semantics = temp_ptr -> symbol_bead.meaning_pointer;
	unspec (rs (put_result).bits) = value_bits;
	go to operator_return (return_point);

dyadic_action (3):					/* dyadic epsilon */
	call setup_dyadic_operator_routine_call;
	call apl_dyadic_epsilon_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (4):					/* index */
	call setup_dyadic_operator_routine_call;
	call apl_dyadic_iota_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (5):					/* invoke dyadic function */
	number_of_arguments = 2;

	if ^rs (start - 2).semantics_valid
	then call value_error_reporter (start - 2);
	if rs (start - 2).semantics = null
	then call value_error_reporter (start - 2);
	if ^rs (start).semantics_valid
	then call value_error_reporter (start);
	if rs (start).semantics = null
	then call value_error_reporter (start);

invoke_niladic_function:
invoke_monadic_function:
	temp_ptr = rs (start - number_of_arguments + 1).semantics;

	if temp_ptr -> function_bead.class > 1
	then go to invoke_external_function;

	temp_ptr = temp_ptr -> function_bead.lexed_function_bead_pointer;

	if number_of_arguments = 2
	then if ^temp_ptr -> lexed_function_bead.bits_for_parse.dyadic
	     then go to improper_dyadic_usage;
	     else ;
	else if number_of_arguments = 1
	then if ^temp_ptr -> lexed_function_bead.bits_for_parse.monadic
	     then go to improper_monadic_usage;
	     else ;
	else if temp_ptr -> lexed_function_bead.bits_for_parse.monadic
		| temp_ptr -> lexed_function_bead.bits_for_parse.dyadic
	then go to improper_niladic_usage;

	call save_state;
	call push_new_frame;

/* Initialize the new function frame. */

	parse_frame.parse_frame_type = function_frame_type;
	parse_frame.current_line_number = 1;
	parse_frame.initial_value_stack_ptr = ws_info.value_stack_ptr;

	parse_frame.function_bead_ptr = rs (start - number_of_arguments + 1).semantics;
	lexed_function_bead_ptr,
	     parse_frame.lexed_function_bead_ptr =
	     parse_frame.function_bead_ptr -> function_bead.lexed_function_bead_pointer;
	lexed_function_bead_ptr -> general_bead.reference_count =
	     lexed_function_bead_ptr -> general_bead.reference_count + 1;

/* Localize local names and labels. */

	parse_frame.number_of_ptrs,
	     number_of_ptrs = lexed_function_bead_ptr -> lexed_function_bead.number_of_localized_symbols;
	do i = 1 to lexed_function_bead_ptr -> lexed_function_bead.number_of_localized_symbols;
	     temp_ptr = lexed_function_bead_ptr -> lexed_function_bead.localized_symbols (i);
	     if temp_ptr ^= null
	     then if temp_ptr -> general_bead.symbol
		then do;
			parse_frame.old_meaning_ptrs (i) = temp_ptr -> symbol_bead.meaning_pointer;
			temp_ptr -> symbol_bead.meaning_pointer = null;
		     end;
		else do;				/* must be operator bead for localized system variable */
			parse_frame.old_meaning_ptrs (i) = save_system_variable_value (temp_ptr);
		     end;
	     else parse_frame.old_meaning_ptrs (i) = null;
	end;

	number_of_non_labels =
	     lexed_function_bead_ptr -> number_of_localized_symbols - lexed_function_bead_ptr -> number_of_labels;

	do i = lexed_function_bead_ptr -> number_of_localized_symbols to number_of_non_labels + 1 by -1;
	     temp_ptr = lexed_function_bead_ptr -> localized_symbols (i);
	     temp_ptr -> meaning_pointer =
		lexed_function_bead_ptr -> label_values_ptr -> lexed_function_label_values (i - number_of_non_labels);
	     temp_ptr -> meaning_pointer -> general_bead.reference_count =
		temp_ptr -> meaning_pointer -> general_bead.reference_count + 1;
	end;

/* Copy the arguments into the heap...arguments must look like real values, not stack temps. */

	temp_ptr = rsp;
	rsp, reduction_stack_ptr = addrel (parse_frame_ptr, size (parse_frame));

	if number_of_arguments = 2
	then do;
		call fill_in_arguments (temp_ptr, start - 2, (RightArgSymbol));
		call fill_in_arguments (temp_ptr, start, (LeftArgSymbol));
	     end;
	else if number_of_arguments = 1
	then call fill_in_arguments (temp_ptr, start - 1, (RightArgSymbol));

	go to start_line;

invoke_external_function:
	external_function_ptr = rs (start - number_of_arguments + 1).semantics;

	if number_of_arguments + 2 ^= external_function_ptr -> function_bead.class
	then go to context_error_0;

	operators_argument.result = null;

	if number_of_arguments = 0
	then do;
		operators_argument.value (1) = null;
		operators_argument.value (2) = null;
		operators_argument.on_stack (1) = "0"b;
		operators_argument.on_stack (2) = "0"b;
		operators_argument.error_code = 0;
		dont_interrupt_parse = "0"b;
		if dirty_interrupt_pending
		then go to dirty_stop;
	     end;
	else if number_of_arguments = 1
	then call setup_monadic_operator_routine_call;
	else call setup_dyadic_operator_routine_call;

	call cu_$ptr_call ((external_function_ptr -> function_bead.lexed_function_bead_pointer), operators_argument);
	call decrement_reference_count (rs (start - number_of_arguments + 1).semantics);

	if number_of_arguments = 0
	then do;
		if operators_argument.error_code ^= 0
		then go to report_error_from_operator;

		dont_interrupt_parse = "1"b;
		rs (put_result).semantics = operators_argument.result;
		unspec (rs (put_result).bits) = computed_value_bits;
	     end;
	else if number_of_arguments = 1
	then call finish_monadic_operator_routine_call;
	else call finish_dyadic_operator_routine_call;

	rs (put_result).type = val_type;
	go to operator_return (return_point);

dyadic_action (6):					/* catenate */
	call setup_dyadic_operator_routine_call;

	if rs (start - 1).bits.semantics_valid
	then operators_argument.dimension = rs_for_op (start - 1).semantics;
	else operators_argument.dimension =
		max (rs (start).semantics -> value_bead.rhorho, rs (start - 2).semantics -> value_bead.rhorho);

join_catenate:
	call apl_catenate_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (7):					/* compression last */
	call setup_dyadic_operator_routine_call;
	operators_argument.dimension = rs (start - 2).semantics -> value_bead.rhorho;

join_compression:
	if rs (start - 1).semantics_valid
	then operators_argument.dimension = rs_for_op (start - 1).semantics;

	call apl_compression_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (8):					/* expansion last */
	call setup_dyadic_operator_routine_call;
	operators_argument.dimension = rs (start - 2).semantics -> value_bead.rhorho;

join_expansion:
	if rs (start - 1).semantics_valid
	then operators_argument.dimension = rs_for_op (start - 1).semantics;

	call apl_expansion_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (9):					/* dyadic file system functions */
	call setup_dyadic_operator_routine_call;
	call apl_file_system_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (10):					/* dyadic rho */
	call setup_dyadic_operator_routine_call;
	call apl_dyadic_rho_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (11):					/* laminate */
	call setup_dyadic_operator_routine_call;
	operators_argument.dimension = rs_for_op (start - 1).semantics;
	call apl_laminate_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (12):					/* compression first */
	call setup_dyadic_operator_routine_call;
	operators_argument.dimension = 1;
	go to join_compression;

dyadic_action (13):					/* expansion first */
	call setup_dyadic_operator_routine_call;
	operators_argument.dimension = 1;
	go to join_expansion;

dyadic_action (14):					/* outer product */
	call setup_dyadic_operator_routine_call;
	operators_argument.op1 = rs (start - 1).bits.op2;
	call apl_outer_product_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (15):					/* take */
	call setup_dyadic_operator_routine_call;
	call apl_take_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (16):					/* drop */
	call setup_dyadic_operator_routine_call;
	call apl_drop_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (17):					/* rotate last */
	call setup_dyadic_operator_routine_call;
	if rs (start - 1).semantics_valid
	then operators_argument.dimension = rs_for_op (start - 1).semantics;
	else operators_argument.dimension = rs (start - 2).semantics -> value_bead.rhorho;

rotate_either:
	call apl_rotate_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (18):					/* rotate first */
	call setup_dyadic_operator_routine_call;
	if rs (start - 1).semantics_valid
	then operators_argument.dimension = rs_for_op (start - 1).semantics;
	else operators_argument.dimension = 1;
	go to rotate_either;

dyadic_action (19):					/* dyadic transpose */
	call setup_dyadic_operator_routine_call;
	call apl_transpose_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (20):					/* decode */
	call setup_dyadic_operator_routine_call;
	call apl_decode_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (21):					/* encode */
	call setup_dyadic_operator_routine_call;
	call apl_encode_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (22):					/* catenate first */
	call setup_dyadic_operator_routine_call;
	operators_argument.dimension = 1;
	go to join_catenate;

dyadic_action (23):					/* format */
	call setup_dyadic_operator_routine_call;
	call apl_dyadic_format_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (24):					/* semicolon cons */
	if rs (start).semantics = null
	then go to value_error_s0;

	if rs (start - 2).semantics = null
	then go to value_error_s2;

	call append_to_list_bead (addr (rs (start - 2)) -> rs_overlay);
	rs (start - 2).semantics -> list_bead.member_ptr (1) = rs (start).semantics;
	unspec (rs (start - 2).semantics -> list_bead.bits (1)) = unspec (rs (start).bits);

/* the reference counts are OK... */

	rs (put_result).semantics = rs (start - 2).semantics;
	unspec (rs (put_result).bits) = unspec (rs (start - 2).bits);
	go to operator_return (return_point);

dyadic_action (25):					/* deal */
	call setup_dyadic_operator_routine_call;
	call apl_random_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (26):					/* system functions */
	call setup_dyadic_operator_routine_call;
	parse_frame.current_parseme = current_parseme;
	call apl_system_functions_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (27):					/* dyadic domino */
	call setup_dyadic_operator_routine_call;
	call apl_domino_operator_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

dyadic_action (28):					/* subscripted assignment */
	print_final_value = "0"b;
	operators_argument.error_code = 0;
	call apl_subscripted_assignment_ (operators_argument, addr (rs (start)));

	if operators_argument.error_code ^= 0
	then go to report_error_from_operator;

	rs (put_result).semantics = rs (start - 2).semantics;
	unspec (rs (put_result).bits) = unspec (rs (start - 2).bits);
	go to operator_return (return_point);

dyadic_action (29):					/* dyadic ibeam */
	call setup_dyadic_operator_routine_call;
	call apl_dyadic_ibeam_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

do_inner_product:
	call setup_dyadic_operator_routine_call;
	operators_argument.op2 = rs (start - 1).bits.op2;
	call apl_inner_product_ (operators_argument);
	call finish_dyadic_operator_routine_call;
	go to operator_return (return_point);

do_monadic:
	print_final_value = "1"b;
	operators_argument.where_error = start;
	if ^rs (start).bits.monadic
	then go to improper_monadic_usage;
	go to monadic_action (monadic_table (rs (start).bits.op1));

monadic_action (1):					/* monadic scalar operators */
	call setup_monadic_operator_routine_call;
	call apl_monadic_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (2):					/* monadic functions */
	number_of_arguments = 1;

	if ^rs (start - 1).semantics_valid
	then call value_error_reporter (start - 1);
	if rs (start - 1).semantics = null
	then call value_error_reporter (start - 1);

	go to invoke_monadic_function;

monadic_action (3):					/* branch */
	print_final_value = "0"b;
	if rs (start - 1).semantics = null
	then go to value_error_s0;

/* Get out of any execute frame(s) we are in, and back to the last function frame. */

	do branch_pf_ptr = parse_frame_ptr repeat (branch_pf_ptr -> parse_frame.last_parse_frame_ptr)
	     while (branch_pf_ptr -> parse_frame.parse_frame_type = execute_frame_type);
	end;

	if branch_pf_ptr -> parse_frame.parse_frame_type = function_frame_type
	then if branch_pf_ptr -> parse_frame.function_bead_ptr -> function_bead.trace_control_pointer ^= null
	     then if this_statement_is_one (branch_pf_ptr -> parse_frame.current_line_number,
		     branch_pf_ptr -> parse_frame.function_bead_ptr -> function_bead.trace_control_pointer)
		then do;
			call print_where_I_am (branch_pf_ptr, "1"b, "0"b);
			trace_branch_line = "1"b;
		     end;
	if rs (start - 1).semantics -> value_bead.total_data_elements > 0
	then do;
		if ^rs (start - 1).semantics -> value_bead.numeric_value
		then go to domain_error;
		x = rs (start - 1).semantics -> value_bead.data_pointer -> numeric_datum (0);
		xx = floor (x + 0.5);
		if abs (xx - x) > integer_fuzz
		then go to domain_error;
		if abs (xx) > 131071
		then go to domain_error;		/* check if integer & fixable in parse_frame.current_line_number */

		branch_pf_ptr -> parse_frame.current_line_number = fixed (xx, 17) - 1;
						/* subtract 1 so that adding 1 later will cancel out */
		was_branch_value = "1"b;
	     end;
	else was_branch_value = "0"b;
	was_branch = "1"b;
	rs (put_result).semantics = rs (start - 1).semantics;
	unspec (rs (put_result).bits) = unspec (rs (start - 1).bits);
	go to operator_return (return_point);

monadic_action (4):					/* ravel */
	call setup_monadic_operator_routine_call;
	call apl_ravel_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (5):					/* reduction last */
	call setup_monadic_operator_routine_call;

	if rs (start).bits.semantics_valid
	then operators_argument.dimension = rs_for_op (start).semantics;
	else operators_argument.dimension = rs (start - 1).semantics -> value_bead.rhorho;

	operators_argument.op1 = rs (start).bits.op2;
	call apl_reduction_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (6):					/* reduction first */
	call setup_monadic_operator_routine_call;

	if rs (start).bits.semantics_valid
	then operators_argument.dimension = rs_for_op (start).semantics;
	else operators_argument.dimension = 1;

	operators_argument.op1 = rs (start).bits.op2;
	call apl_reduction_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);


monadic_action (7):					/* scan last */
	call setup_monadic_operator_routine_call;
	if rs (start).semantics_valid
	then operators_argument.dimension = rs_for_op (start).semantics;
	else operators_argument.dimension = rs (start - 1).semantics -> value_bead.rhorho;

	operators_argument.op1 = rs (start).op2;
	call apl_scan_operator_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (8):					/* scan first */
	call setup_monadic_operator_routine_call;
	if rs (start).semantics_valid
	then operators_argument.dimension = rs_for_op (start).semantics;
	else operators_argument.dimension = 1;

	operators_argument.op1 = rs (start).op2;
	call apl_scan_operator_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (9):					/* monadic file system functions */
	call setup_monadic_operator_routine_call;
	call apl_file_system_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (10):				/* monadic not */
	call setup_monadic_operator_routine_call;
	call apl_monadic_not_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (11):				/* reverse last */
	call setup_monadic_operator_routine_call;

	if rs (start).bits.semantics_valid
	then operators_argument.dimension = rs_for_op (start).semantics;
	else operators_argument.dimension = rs (start - 1).semantics -> value_bead.rhorho;

reverse_either:
	call apl_reverse_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (12):				/* reverse first */
	call setup_monadic_operator_routine_call;

	if rs (start).bits.semantics_valid
	then operators_argument.dimension = rs_for_op (start).semantics;
	else operators_argument.dimension = 1;

	go to reverse_either;

monadic_action (13):				/* monadic transpose */
	call setup_monadic_operator_routine_call;
	call apl_transpose_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (14):				/* execute */
	execute_value_ptr = rs (start - 1).semantics;
	if execute_value_ptr = null
	then go to value_error_s1;
	data_elements = execute_value_ptr -> value_bead.total_data_elements;
	if ^execute_value_ptr -> value_bead.character_value
	then if execute_value_ptr -> value_bead.numeric_value & data_elements > 0
	     then go to domain_error_s1;
	if execute_value_ptr -> value_bead.rhorho > 1
	then go to rank_error_s1;

	call save_state;
	call push_new_frame;
	parse_frame_type = execute_frame_type;
	parse_frame.number_of_ptrs, number_of_ptrs = 3;
	rsp, reduction_stack_ptr = addrel (parse_frame_ptr, size (parse_frame));

	current_parseme = 0;			/* in case of errors */
	parse_frame.current_parseme = 0;
	call apl_execute_lex_ (execute_value_ptr -> value_bead.data_pointer -> character_string_overlay,
	     parse_frame.lexed_function_bead_ptr, was_error, 0, rsp);
	if was_error
	then go to execute_error_s0;
	parse_frame.current_line_number = 1;
	go to start_line;

monadic_action (15):				/* format */
	call setup_monadic_operator_routine_call;
	call apl_monadic_format_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (16):				/* ibeam */
	call setup_monadic_operator_routine_call;
	call apl_ibeam_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (17):				/* assign to quad */
	if rs (start - 1).semantics = null
	then go to value_error_s1;
	in_printer = "1"b;
	call apl_print_value_ (rs (start - 1).semantics, "1"b, "1"b);
	in_printer = "0"b;
	go to nop_operator;

monadic_action (18):				/* assign to quote quad */
	if rs (start - 1).semantics = null
	then go to value_error_s1;
	in_printer = "1"b;
	call apl_print_value_ (rs (start - 1).semantics, "0"b, "1"b);
	in_printer = "0"b;
	go to nop_operator;

monadic_action (19):				/* assign to system variables */
	call setup_monadic_operator_routine_call;
	call apl_system_variables_ (operators_argument);
	if operators_argument.error_code ^= 0
	then go to report_error_from_operator;

nop_operator:
	dont_interrupt_parse = "1"b;
	print_final_value = "0"b;
	rs (put_result).semantics = rs (start - 1).semantics;
	unspec (rs (put_result).bits) = unspec (rs (start - 1).bits);
	go to operator_return (return_point);

monadic_action (20):				/* assign to system variable which ignores assignment */
	go to nop_operator;

monadic_action (21):				/* monadic system functions */
	call setup_monadic_operator_routine_call;
	parse_frame.current_parseme = current_parseme;
	call apl_system_functions_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (22):				/* assign to stop/trace */
	print_final_value = "0"b;
	if rs (start - 1).semantics = null
	then go to value_error_s2;

	temp_ptr = rs (start - 1).semantics;
	if rs (start).op1 = assign_to_stop_code
	then value_bead_ptr = addr (rs (start).semantics -> function_bead.stop_control_pointer);
	else value_bead_ptr = addr (rs (start).semantics -> function_bead.trace_control_pointer);

	if temp_ptr -> value_bead.character_value
	then if temp_ptr -> value_bead.total_data_elements ^= 0
						/* not '' */
	     then go to domain_error;

	if value_bead_ptr -> based_unaligned_ptr ^= null
	then call decrement_reference_count (value_bead_ptr -> based_unaligned_ptr);

	assignment_done = "0"b;			/* we will turn this on if we are resetting stop/trace */

	if temp_ptr -> value_bead.total_data_elements = 0
	then assignment_done = "1"b;
	else if (temp_ptr -> value_bead.total_data_elements = 1
		& temp_ptr -> value_bead.data_pointer -> numeric_datum (0) = 0.0e0)
	then assignment_done = "1"b;

	if ^assignment_done
	then do;
		ws_info.dont_interrupt_parse = "0"b;	/* unmask so RQO handler can get control */
		call apl_copy_value_ (rs (start - 1).semantics, value_bead_ptr -> based_unaligned_ptr);
		ws_info.dont_interrupt_parse = "1"b;	/* remask */
		value_bead_ptr -> based_unaligned_ptr -> value_bead.label = "0"b;
		value_bead_ptr -> based_unaligned_ptr -> value_bead.reference_count =
		     value_bead_ptr -> based_unaligned_ptr -> value_bead.reference_count + 1;
	     end;

	call decrement_reference_count (rs (start).semantics);
	rs (put_result).semantics = rs (start - 1).semantics;
	unspec (rs (put_result).bits) = unspec (rs (start - 1).bits);
	go to operator_return (return_point);

monadic_action (23):				/* monadic iota */
	call setup_monadic_operator_routine_call;
	call apl_monadic_iota_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (24):				/* monadic rho */
	call setup_monadic_operator_routine_call;
	call apl_monadic_rho_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (25):				/* monadic domino */
	call setup_monadic_operator_routine_call;
	call apl_domino_operator_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (26):				/* roll */
	call setup_monadic_operator_routine_call;
	call apl_random_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (27):				/* grade up */
	call setup_monadic_operator_routine_call;
	if rs (start).semantics_valid
	then operators_argument.dimension = rs_for_op (start).semantics;
	else operators_argument.dimension = rs (start - 1).semantics -> value_bead.rhorho;

	call apl_grade_up_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (28):				/* grade down */
	call setup_monadic_operator_routine_call;
	if rs (start).semantics_valid
	then operators_argument.dimension = rs_for_op (start).semantics;
	else operators_argument.dimension = rs (start - 1).semantics -> value_bead.rhorho;

	call apl_grade_down_ (operators_argument);
	call finish_monadic_operator_routine_call;
	go to operator_return (return_point);

monadic_action (29):				/* monadic laminate (invalid) */
	go to context_error_0;

monadic_action (30):				/* monadic qCALL system function */
	call setup_monadic_operator_routine_call;
	call apl_quadcall_ (operators_argument);
	call finish_monadic_operator_routine_call;
	goto operator_return (return_point);
/* INTERNAL PROCEDURES */

setup_dyadic_operator_routine_call:
     proc;

	if rs (start).semantics = null
	then go to value_error_s0;
	if rs (start - 2).semantics = null
	then go to value_error_s2;

	operators_argument.value (1) = rs (start).semantics;
	operators_argument.value (2) = rs (start - 2).semantics;
	operators_argument.on_stack (1) = rs (start).bits.semantics_on_stack;
	operators_argument.on_stack (2) = rs (start - 2).bits.semantics_on_stack;
	operators_argument.op1 = rs (start - 1).bits.op1;
	operators_argument.error_code = 0;

	dont_interrupt_parse = "0"b;
	if dirty_interrupt_pending
	then go to dirty_stop;

	return;

     end;


finish_dyadic_operator_routine_call:
     proc;

	if operators_argument.error_code ^= 0		/* Operator discovered an error... */
	then go to report_error_from_operator;

	ws_info.dont_interrupt_parse = "1"b;

	if ^operators_argument.on_stack (1)
	then call decrement_reference_count (rs (start).semantics);

	if ^operators_argument.on_stack (2)
	then call decrement_reference_count (rs (start - 2).semantics);

	rs (put_result).semantics = operators_argument.result;
	unspec (rs (put_result).bits) = computed_value_bits;
						/* force the right bits on */

	return;

     end;

setup_monadic_operator_routine_call:
     procedure;

	if rs (start - 1).semantics = null
	then go to value_error_s1;

	operators_argument.value (1) = null;
	operators_argument.value (2) = rs (start - 1).semantics;
	operators_argument.on_stack (1) = "0"b;
	operators_argument.on_stack (2) = rs (start - 1).bits.semantics_on_stack;
	operators_argument.op1 = rs (start).bits.op1;
	operators_argument.error_code = 0;

	dont_interrupt_parse = "0"b;
	if dirty_interrupt_pending
	then go to dirty_stop;

	return;

     end;


finish_monadic_operator_routine_call:
     proc;

	if operators_argument.error_code ^= 0		/* Operator ran into a problem... */
	then go to report_error_from_operator;

	ws_info.dont_interrupt_parse = "1"b;

	if ^operators_argument.on_stack (2)
	then call decrement_reference_count (rs (start - 1).semantics);

	rs (put_result).semantics = operators_argument.result;
	unspec (rs (put_result).bits) = computed_value_bits;
						/* force the right bits on */

	return;

     end;

/* Function to restore the value of a system variable. In the current implementation,
   we get the old value out of a value_bead, and put it back into ws_info. */

restore_system_variable_value:
     procedure (P_operator_bead_ptr, P_bead_ptr);

/* parameters */

declare	(
	P_operator_bead_ptr ptr,
	P_bead_ptr	ptr unal
	)		parameter;

/* automatic */

declare	bead_ptr		ptr unal,
	value		float;

/* builtins */

declare	fixed		builtin;

/* program */

	bead_ptr = P_bead_ptr;

	if P_operator_bead_ptr -> operator_bead.op2 ^= 4	/* qLX */
	then value = bead_ptr -> value_bead.data_pointer -> numeric_datum (0);

	go to set_value (P_operator_bead_ptr -> operator_bead.op1);

set_value (2):					/* qCT */
	ws_info.fuzz = value;
	go to end_set_value;

set_value (3):					/* qIO */
	ws_info.float_index_origin = value;
	ws_info.index_origin = fixed (value, 35);
	go to end_set_value;

set_value (4):					/* qLX */
	call decrement_reference_count (ws_info.latent_expression);
	bead_ptr -> general_bead.reference_count = bead_ptr -> general_bead.reference_count + 1;
	ws_info.latent_expression = bead_ptr;
	go to end_set_value;

set_value (5):					/* qPP */
	ws_info.digits = fixed (value, 35);
	go to end_set_value;

set_value (6):					/* qPW */
	ws_info.width = fixed (value, 35);
	go to end_set_value;

set_value (7):					/* qRL */
	ws_info.random_link = fixed (value, 35);
	go to end_set_value;

set_value (16):					/* qIT */
	ws_info.integer_fuzz = value;
	go to end_set_value;

end_set_value:
	call decrement_reference_count (bead_ptr);
	return;

     end restore_system_variable_value;

/* Function to localize a system variable. In the current implementation,
   we must turn the current value of the system variable into a value_bead,
   and return a pointer to that value_bead. */

save_system_variable_value:
     procedure (P_bead_ptr) returns (ptr);

/* parameters */

declare	P_bead_ptr	ptr parameter;

/* automatic */

declare	bead_ptr		ptr unal,
	data_ptr		ptr,
	n_words		fixed bin (19),
	value		float;

/* builtins */

declare	(addrel, float, rel, size, string)
			builtin;

/* entries */

declare	apl_allocate_words_ entry (fixed bin (19), ptr unal);

/* program */

	bead_ptr = P_bead_ptr;

/* We assume that the lex has validated the function so that only system variables
   that can actually be localized every reach us. */

	go to get_value (bead_ptr -> operator_bead.op1);

get_value (2):					/* qCT */
	value = ws_info.fuzz;
	go to end_get_value;

get_value (3):					/* qIO */
	value = ws_info.float_index_origin;
	go to end_get_value;

get_value (4):					/* qLX */
	ws_info.latent_expression -> general_bead.reference_count =
	     ws_info.latent_expression -> general_bead.reference_count + 1;
	return (ws_info.latent_expression);

get_value (5):					/* qPP */
	value = float (ws_info.digits, 63);
	go to end_get_value;

get_value (6):					/* qPW */
	value = float (ws_info.width, 63);
	go to end_get_value;

get_value (7):					/* qRL */
	value = float (ws_info.random_link, 63);
	go to end_get_value;

get_value (16):					/* qIT */
	value = ws_info.integer_fuzz;
	go to end_get_value;

end_get_value:
	number_of_dimensions = 0;
	data_elements = 1;
	n_words = size (value_bead) + size (numeric_datum) + 1;
	call apl_allocate_words_ (n_words, bead_ptr);

	string (bead_ptr -> value_bead.type) = numeric_value_type;
	bead_ptr -> value_bead.total_data_elements = data_elements;
	bead_ptr -> value_bead.rhorho = 0;
	data_ptr = addrel (bead_ptr, size (value_bead));
	if substr (rel (data_ptr), 18, 1)
	then data_ptr = addrel (data_ptr, 1);

	bead_ptr -> value_bead.data_pointer = data_ptr;
	data_ptr -> numeric_datum (0) = value;
	return (bead_ptr);

     end save_system_variable_value;

print_value:
     procedure;

/* automatic */

dcl	val_ptr		ptr unal;

/* program */

	if rs (current_parseme - 1).semantics_valid
	then if rs (current_parseme - 1).semantics ^= null
	     then do;
		     val_ptr = rs (current_parseme - 1).semantics;

		     if ^print_final_value
		     then if val_ptr -> general_bead.type.list_value
			then do;			/* check for list of all assignments, suppress printing */
				do i = 1 to val_ptr -> list_bead.number_of_members;
				     if val_ptr -> list_bead.members (i).bits.op1 = 0 /* non-assignment */
					& val_ptr -> list_bead.member_ptr (i) ^= null
						/* non-null list (i.e. not ;;) */
				     then print_final_value = "1"b;
						/* non assignment appears in list */
				end;
			     end;

		     if print_final_value
		     then do;
			     in_printer = "1"b;
			     call apl_print_value_ (val_ptr, "1"b, "1"b);
			     in_printer = "0"b;
			end;
		end;

     end /* print_value */;

read_executable_input_line:
     proc;

/* automatic */

declare	in_constant	bit (1) aligned,
	n_read_more	fixed bin (21),
	prompt_length	fixed bin (21),
	prompt_ptr	ptr;

/* entries */

declare	apl_system_error_	entry (fixed bin (35));

/* program */

read_again:
	have_a_line = "0"b;				/* if interrupt, cannot display current line */
	current_parseme = 0;
	parse_frame.current_parseme = 0;
	parse_frame.initial_value_stack_ptr = ws_info.value_stack_ptr;
	parse_frame.lexed_function_bead_ptr = null;
	parse_frame.number_of_ptrs, number_of_ptrs = 1;	/* we'd say 0, except that's not good PL/I */

/* In a suspended frame (or evaluated input frame) the input buffer overlays the area normally
   used by the old meaning ptrs */

	input_buffer_ptr = addrel (parse_frame_ptr, size (parse_frame) - 1);
	input_buffer.n_read = 0;
	ok_to_stop_control = "1"b;

	call check_for_interrupt_while_input;

	if parse_frame_type = suspended_frame_type
	then do;
		prompt_ptr = addr (ws_info.immediate_input_prompt);
		prompt_length = length (ws_info.immediate_input_prompt);
	     end;
	else do;
		prompt_ptr = addr (ws_info.evaluated_input_prompt);
		prompt_length = length (ws_info.evaluated_input_prompt);
	     end;

	prompt_ptr = addrel (prompt_ptr, 1);		/* point to chars in the varying string */
	call iox_$put_chars (apl_static_$apl_output, prompt_ptr, prompt_length, (0));

	max_input_line = 4 * (65536 - binary (rel (input_buffer_ptr), 18));

	call append_to_input_buffer;
	can_be_interrupted = "0"b;

	packed_temp_ptr = null;
	call apl_scan_ (input_buffer.line, 1, input_line_position, (0), scan_token_type, packed_temp_ptr);

	if scan_token_type = 1
	then if substr (input_buffer.line, input_line_position, 1) = QRightParen
	     then do;
		     dont_interrupt_parse = "0"b;
		     if dirty_interrupt_pending
		     then go to dirty_stop;
		     call apl_command_ (input_buffer.line, input_line_position, code);
		     dont_interrupt_parse = "1"b;

		     if code = 0
		     then go to read_again;		/* nothing special this time */

		     if code = apl_error_table_$return_from_apl
		     then go to return_statement;

		     if code = apl_error_table_$ws_cleared
		     then go to start_anew;

		     parse_frame_ptr = ws_info.current_parse_frame_ptr;
		     rsp = parse_frame.reduction_stack_ptr;

		     if code = apl_error_table_$ws_loaded
		     then go to ws_just_loaded;

		     go to read_again;		/* this stmt should never be executed */
		end;
	     else if substr (input_buffer.line, input_line_position, 1) = QDel
		     | substr (input_buffer.line, input_line_position, 1) = QDelTilde
	     then do;
		     dont_interrupt_parse = "0"b;
		     if dirty_interrupt_pending
		     then go to dirty_stop;
		     call apl_editor_ (input_buffer.line, input_line_position, code);
		     dont_interrupt_parse = "1"b;
		     if code = apl_error_table_$return_from_apl
		     then go to return_statement;
		     if code = apl_error_table_$ws_cleared
		     then go to start_anew;
		     go to read_again;
		end;

/* check for use of multi-line character constant */

	in_constant = "0"b;
scan_for_constants_again:
	do input_line_position = input_line_position by 1 while (input_line_position <= input_buffer.n_read);
	     if substr (input_buffer.line, input_line_position, 1) = QApostrophe
	     then in_constant = ^in_constant;
	     else if ^in_constant
	     then if substr (input_buffer.line, input_line_position, 1) = QLamp
		then go to exitloop;
	end;

exitloop:
	if in_constant				/* constant extends to next line */
	then do;
		call check_for_interrupt_while_input;
		if max_input_line - input_buffer.n_read < 500
		then call apl_system_error_ (apl_error_table_$too_much_input);

		call append_to_input_buffer;
		can_be_interrupted = "0"b;
		input_line_position = input_buffer.n_read - n_read_more + 1;
						/* scan the line that was read */
		go to scan_for_constants_again;
	     end;

	parse_frame.current_line_number = 1;
	return;

append_to_input_buffer:
     procedure;

/* automatic */

declare	got_line		bit (1) aligned,
	input_read_ptr	ptr,
	user_input_attachment_known
			bit (1) aligned;

/* based */

declare	input_buffer_array	(max_input_line) char (1) based (addr (input_buffer.line));

/* program */

	user_input_attachment_known = "0"b;
	got_line = "0"b;

	do while (^got_line);

	     ws_info.dont_interrupt_parse = "0"b;
	     input_read_ptr = addr (input_buffer_array (input_buffer.n_read + 1));
	     call iox_$get_line (apl_static_$apl_input, input_read_ptr, max_input_line - input_buffer.n_read, n_read_more,
		code);
	     ws_info.dont_interrupt_parse = "1"b;
	     if code = 0
	     then got_line = "1"b;
	     else if code = error_table_$short_record	/* no trailing NL */
	     then do;
		     n_read_more = n_read_more + 1;
		     substr (input_buffer.line, input_buffer.n_read + n_read_more, 1) = QNewLine;
		     got_line = "1"b;
		end;
	     else if code = error_table_$end_of_info
	     then do;
		     if user_input_attachment_known
		     then call apl_system_error_ (apl_error_table_$cant_read_input);

		     call reattach_user_input;
		     user_input_attachment_known = "1"b;
		end;
	end;
	input_buffer.n_read = input_buffer.n_read + n_read_more;

     end /* append_to_input_buffer */;

check_for_interrupt_while_input:
     procedure;

	can_be_interrupted = "1"b;
	if clean_interrupt_pending
	then do;
		call apl_error_ (apl_error_table_$interrupt, ""b, 0, "", packed_temp_ptr, 0);
		go to recover_from_error;
	     end;

     end /* check_for_interrupt_while_input */;

     end /* read_executable_input_line */;

lex_input_line:
     procedure (bv_code);

/* parameters */

declare	bv_code		fixed bin (35) parameter;

/* program */

	was_error = "0"b;
	parse_frame.number_of_ptrs, number_of_ptrs = 1 + divide (input_buffer.n_read + 3, 4, 21, 0);
	parse_frame.reduction_stack_ptr, rsp = addrel (parse_frame_ptr, size (parse_frame));
	call apl_line_lex_ (input_buffer.line, parse_frame.lexed_function_bead_ptr, was_error, 0, rsp);
	if was_error
	then bv_code = 1;
	else bv_code = 0;
	return;

     end lex_input_line;

initialize_suspended_frame:
     procedure;

	parse_frame.parse_frame_type = suspended_frame_type;
						/* it is a suspended frame */
	parse_frame.number_of_ptrs, number_of_ptrs = 3;	/* put reduction stack next */
	parse_frame.reduction_stack_ptr, rsp = addrel (parse_frame_ptr, size (parse_frame));
	parse_frame.initial_value_stack_ptr = ws_info.value_stack_ptr;
	return;

     end initialize_suspended_frame;

/* Procedure to wash a pointer (decrement the reference count of the bead pointed at, free the bead
   if necessary, and wipe out the original pointer).  */

decrement_reference_count:
     procedure (bv_bead_ptr);

/* parameters */

declare	bv_bead_ptr	ptr unaligned;

/* program */

	bv_bead_ptr -> general_bead.reference_count = bv_bead_ptr -> general_bead.reference_count - 1;

	if bv_bead_ptr -> general_bead.reference_count < 1
	then call apl_free_bead_ (bv_bead_ptr);

	bv_bead_ptr = null;				/* since heap ptrs are passed by reference, this will */
	return;					/* actually null out whatever variable pointer here. */

     end decrement_reference_count;

clean_up_rs:
     proc;

	do current_parseme = current_parseme to 1 by -1;
	     if rs (current_parseme).bits.has_list
	     then call free_list_bead (rs (current_parseme).semantics);

	     if rs (current_parseme).type = val_type
	     then if rs (current_parseme).bits.semantics_valid
		then if rs (current_parseme).semantics ^= null
		     then if ^rs (current_parseme).bits.semantics_on_stack
			then call decrement_reference_count (rs (current_parseme).semantics);
	end;

	parse_frame.current_parseme = 0;
	ws_info.value_stack_ptr = parse_frame.initial_value_stack_ptr;
	return;

     end;

save_state:
     proc;

	parse_frame.current_parseme = current_parseme;
	parse_frame.current_lexeme = current_lexeme;
	parse_frame.return_point = return_point;
	parse_frame.put_result = put_result;
	parse_frame.print_final_value = print_final_value;
	return;

     end;

restore_state:
     proc;

	print_final_value = parse_frame.print_final_value;
	was_branch = "0"b;
	was_branch_value = "0"b;
	trace_branch_line = "0"b;

restore_state_after_execute:
     entry ();

	current_parseme = parse_frame.current_parseme;
	current_lexeme = parse_frame.current_lexeme;
	return_point = parse_frame.return_point;
	put_result = parse_frame.put_result;
	lexed_function_bead_ptr = parse_frame.lexed_function_bead_ptr;
	ws_info.current_parse_frame_ptr = parse_frame_ptr;
	rsp = parse_frame.reduction_stack_ptr;

	number_of_ptrs = 1;				/* I'm not sure these stmts are necessary */
	input_buffer_ptr = addrel (parse_frame_ptr, size (parse_frame) - 1);
						/* .. */

/* Due to an oversight in the original implementation, the variables
   "start" and "number_of_arguments" were not saved in the parse_frame.
   Since the format of saved workspaces would have to be changed to save them
   now (and we would still have to be able to run with old workspaces), it seems
   easier to recalculate them here. */

	if return_point = 2
	then do;
		start = current_parseme;
		number_of_arguments = 2;
	     end;
	else do;
		start = current_parseme - 1;

		if return_point >= 8
		then number_of_arguments = 0;
		else number_of_arguments = 1;
	     end;

	return;

     end;

value_error_reporter:
     proc (where);

dcl	where		fixed bin;

	operators_argument.error_code = apl_error_table_$value;
	current_lexeme = where;
	go to report_error;

     end;

push_new_frame:
     proc;

	temp_ptr = addr (rs (current_parseme + 1));
	temp_ptr -> last_parse_frame_ptr = parse_frame_ptr;
	parse_frame_ptr = temp_ptr;
	ws_info.current_parse_frame_ptr = parse_frame_ptr;
	parse_frame.lexed_function_bead_ptr = null;
	parse_frame.current_parseme = 0;
	current_parseme = 0;

	if fixed (rel (ws_info.current_parse_frame_ptr), 18) > max_parse_stack_depth
	then go to depth_error;

	return;

     end;

/* Mixed output hangs a list_bead off of the right-end (RE) parseme.
   This procedure knows how to (re)allocate it so that a new value can be added on the front. */

append_to_list_bead:
     proc (reduction);

/* parameters */

dcl	1 reduction	aligned,
	  2 type		fixed bin,
	  2 bits		unaligned like operator_bead.bits_for_parse,
	  2 semantics	ptr unaligned,
	  2 lexeme	fixed bin;

/* program */

	if reduction.semantics_valid
	then if reduction.semantics -> general_bead.list_value
	     then n_members = reduction.semantics -> list_bead.number_of_members + 1;
	     else n_members = 2;
	else n_members = 1;

	temp_ptr = apl_push_stack_ (size (list_bead));
	unspec (temp_ptr -> list_bead.type) = list_value_type;
	temp_ptr -> list_bead.reference_count = -1;
	temp_ptr -> list_bead.number_of_members = n_members;

	if ^reduction.semantics_valid
	then do;
		reduction.semantics_valid = "1"b;
		reduction.semantics_on_stack = "1"b;
		reduction.has_list = "1"b;
		reduction.semantics = temp_ptr;
		return;
	     end;

	if reduction.semantics -> general_bead.list_value
	then do i = 2 to temp_ptr -> list_bead.number_of_members;
		unspec (temp_ptr -> list_bead.members (i)) = unspec (reduction.semantics -> list_bead.members (i - 1));
	     end;
	else do;
		temp_ptr -> list_bead.member_ptr (2) = reduction.semantics;
		unspec (temp_ptr -> list_bead.bits (2)) = unspec (reduction.bits);
		unspec (reduction.bits) = ""b;
		reduction.semantics_valid = "1"b;
		reduction.semantics_on_stack = "1"b;
		reduction.has_list = "1"b;
	     end;

	reduction.semantics = temp_ptr;
	return;

     end;

free_list_bead:
     proc (which);

dcl	i		fixed bin,
	which		ptr unal;

	do i = 1 to which -> list_bead.number_of_members;
	     if which -> list_bead.member_ptr (i) ^= null
	     then if ^which -> list_bead.bits (i).semantics_on_stack
		then call decrement_reference_count (which -> list_bead.member_ptr (i));
	end;

	return;

     end;


restore_old_meanings:
     procedure;

	do i = 1 to lexed_function_bead_ptr -> lexed_function_bead.number_of_localized_symbols;
	     temp_ptr = lexed_function_bead_ptr -> lexed_function_bead.localized_symbols (i);
	     if temp_ptr ^= null
	     then if temp_ptr -> general_bead.symbol
		then do;
			if temp_ptr -> symbol_bead.meaning_pointer ^= null
			then call decrement_reference_count (temp_ptr -> symbol_bead.meaning_pointer);

			temp_ptr -> symbol_bead.meaning_pointer = parse_frame.old_meaning_ptrs (i);
		     end;
		else do;				/* must be a localized system var */
			call restore_system_variable_value (temp_ptr, parse_frame.old_meaning_ptrs (i));
		     end;
	end;

	return;

     end /* restore_old_meanings */;

check_trace_vector:
     procedure;

/* program */

	if ^was_branch
	then if this_statement_is_one (parse_frame.current_line_number,
		parse_frame.function_bead_ptr -> function_bead.trace_control_pointer)
	     then do;
		     print_final_value = "1"b;
		     if ^rs (current_parseme - 1).semantics_valid | rs (current_parseme - 1).semantics = null
		     then call print_where_I_am (parse_frame_ptr, "0"b, "1"b);
		     else call print_where_I_am (parse_frame_ptr, "0"b, "0"b);
		end;

     end /* check_trace_vector */;

this_statement_is_one:
     procedure (P_line_number, P_ptr_to_vb) returns (bit (1) aligned);

/* parameters */

declare	(
	P_line_number	fixed bin,
	P_ptr_to_vb	ptr unal
	)		parameter;

/* automatic */

declare	ptr_to_vb		pointer;

/* program */

	ptr_to_vb = P_ptr_to_vb;
	x = P_line_number;

	do i = 0 by 1 while (i < ptr_to_vb -> value_bead.total_data_elements);
	     xx = ptr_to_vb -> value_bead.data_pointer -> numeric_datum (i);
	     if x = xx
	     then return ("1"b);
	     if abs (x - xx) < fuzz * abs (x + xx)
	     then return ("1"b);
	end;
	return ("0"b);

     end /* this_statement_is_one */;

print_where_I_am:
     procedure (P_frame_ptr, P_add_arrow, P_add_nl);

/* parameters */

declare	(
	P_frame_ptr	ptr,
	(P_add_arrow, P_add_nl)
			bit (1) aligned
	)		parameter;

/* pictures */

declare	line_number	picture "zzzzzzzzzz9";	/* 11 digits */

/* automatic */

declare	(first_nonblank, line_len, linex, n_nonblank)
			fixed bin (21),
	sp		ptr;

/* based */

declare	line		char (line_len) based (addr (rs (current_parseme + 1)));

/* program */

	sp = P_frame_ptr -> parse_frame.lexed_function_bead_ptr -> lexed_function_bead.name;
	linex = length (sp -> symbol_bead.name);
	substr (line, 1, linex) = sp -> symbol_bead.name;
	linex = linex + 1;

	substr (line, linex, 1) = QLeftBracket;
	linex = linex + 1;

	line_number = P_frame_ptr -> parse_frame.current_line_number;
	first_nonblank = verify (line_number, " ");
	n_nonblank = length (line_number) - first_nonblank + 1;
	substr (line, linex, n_nonblank) = substr (line_number, first_nonblank, n_nonblank);
	linex = linex + n_nonblank;

	substr (line, linex, 1) = QRightBracket;
	linex = linex + 1;

	if P_add_arrow
	then do;
		substr (line, linex, 2) = " " || QRightArrow;
		linex = linex + 2;
	     end;

	if ^P_add_nl
	then do;
		substr (line, linex, 1) = " ";
		linex = linex + 1;
	     end;

	line_len = linex - 1;
	call apl_print_string_ (line);

	if P_add_nl
	then call apl_flush_buffer_nl_;

	return;

     end;

initial_interrupt:
     procedure;

declare	(
	four_seconds	fixed binary (71) initial (4),
	relative_seconds	bit (2) initial ("11"b)
	)		internal static options (constant);

/* Re-syn user_input to user_i/o so that &attach effect of exec_coms will be undone if
   user QUITS while in an exec_com that &attaches. */

	call reattach_user_input;
	call iox_$control (apl_static_$apl_input, "resetread", null, (0));

	if in_printer /* in apl_print_value_, stop typing and INTERRUPT now */
	     | can_be_interrupted & ^clean_interrupt_pending
	then do;

/* interrupt now. */

		operators_argument.error_code = apl_error_table_$interrupt;
		go to report_error;			/* go print "INTERRUPT" and maybe the line being executed */
	     end;
	else if clean_interrupt_pending		/* ignore multiple interrupts */
	then return;

/* we cannot take the interrupt now. defer it until later. */

	clean_interrupt_pending = "1"b;

	call timer_manager_$alarm_call (four_seconds, relative_seconds, first_timer);

	return;

     end;

/* Small procedure to attach user_input back to user_i/o. Handles case where user_input is presently
   attached via syn_, and case where user_input is attached via regular IO module. */

reattach_user_input:
     procedure;

	call iox_$detach_iocb (iox_$user_input, code);
	if code ^= 0
	then if code = error_table_$not_closed
	     then do;				/* means was vfile_ or something */
		     call iox_$close (iox_$user_input, code);
		     call iox_$detach_iocb (iox_$user_input, code);
		end;
	call iox_$attach_ptr (iox_$user_input, "syn_ user_i/o", null, code);

     end /* reattach_user_input */;

reset_interrupt_info:
     procedure;

	call timer_manager_$reset_alarm_call (first_timer);
	call timer_manager_$reset_alarm_call (second_timer);
	ws_info.dont_interrupt_parse = "1"b;
	ws_info.dont_interrupt_operator = "0"b;
	ws_info.dont_interrupt_storage_manager = "0"b;
	ws_info.dont_interrupt_command = "0"b;
	ws_info.can_be_interrupted = "0"b;
	ws_info.clean_interrupt_pending = "0"b;
	ws_info.dirty_interrupt_pending = "0"b;
	in_printer = "0"b;

	return;

     end;

first_timer:
     procedure;

declare	(
	ten_seconds	fixed binary (71) initial (10),
	relative_seconds	bit (2) initial ("11"b)
	)		internal static options (constant);

	dirty_interrupt_pending = "1"b;
	signal apl_dirty_stop_;

	call timer_manager_$alarm_call (ten_seconds, relative_seconds, second_timer);

	return;

     end;


second_timer:
     procedure;

/* entries */

declare	apl_system_error_	entry (fixed bin (35));

/* program */

	call apl_system_error_ (apl_error_table_$super_dirty_stop);
	return;

     end second_timer;

fill_in_arguments:
     procedure (bv_rsp, from_which, to_where);

/* parameters */

declare	(
	bv_rsp		ptr,
	from_which	fixed bin,
	to_where		fixed bin
	)		parameter;

/* program */

	if bv_rsp -> rs (from_which).semantics_on_stack
	then do;
		ws_info.dont_interrupt_parse = "0"b;	/* unmask so RQO handler can get control */
		call apl_copy_value_ (bv_rsp -> rs (from_which).semantics, packed_temp_ptr);
		ws_info.dont_interrupt_parse = "1"b;	/* remask */
		bv_rsp -> rs (from_which).semantics = packed_temp_ptr;
		bv_rsp -> rs (from_which).semantics_on_stack = "0"b;
	     end;

	lexed_function_bead_ptr -> lexed_function_bead.localized_symbols (to_where) -> symbol_bead.meaning_pointer =
	     bv_rsp -> rs (from_which).semantics;
	bv_rsp -> rs (from_which).semantics -> general_bead.reference_count =
	     bv_rsp -> rs (from_which).semantics -> general_bead.reference_count + 1;

	return;

     end fill_in_arguments;

%include apl_push_stack_fcn;

/* this internal proc is invoked for every condition that is signalled during the execution of APL.
   It handles quits and pi's, makes the hardware faults into the appropriate APL action
   such as domain error, and processes those conditions which are used for internal
   communication within APL.
   Added 73.9.17 by DAM
 */

apl_default_handler_:
     procedure (mc_ptr, condition_name, wc_mc_ptr, info_ptr, continue_switch);

/* parameters */

declare	(
	mc_ptr		pointer,
	condition_name	char (*),
	wc_mc_ptr		pointer,
	info_ptr		pointer,
	continue_switch	bit (1) aligned
	)		parameter;

/* automatic */

declare	oncode_number	fixed bin;

/* builtins */

declare	oncode		builtin;

/* entries */

declare	apl_save_command_	entry (char (*), char (*), fixed bin (35));

/* program */

	if ws_info.transparent_to_signals		/* )E or something - we're not supposed to be here */
	then if condition_name ^= "program_interrupt"	/* but let pi's get back into APL */
	     then do;
		     continue_switch = "1"b;
		     return;
		end;
	     else ws_info.transparent_to_signals = "0"b;	/* pi - clear flag since re-entering APL */

/* conditions used for communication with the outside world */

	if condition_name = "quit"
	then do;
		if ws_info.switches.no_quit_handler
		then do;
			continue_switch = "1"b;
			return;
		     end;

		call iox_$control (apl_static_$apl_input, "process_quit", null, code);
						/* check for editing-attention */
		if code ^= 0			/* if APL dim isn't there, we have to do it ourselves */
		then do;				/* assume quit was interrupt, since we can't edit here anyway */
			call iox_$control (apl_static_$apl_output, "resetwrite", null, (0));
						/* flush output */
			call iox_$put_chars (apl_static_$apl_output, addr (QNewLine), length (QNewLine), (0));
			signal apl_quit_;
		     end;
	     end;

	else if condition_name = "program_interrupt"
	then go to recover_from_error;		/* we probably faulted out; treat as system error */

/* conditions used for internal communication */

	else if condition_name = "apl_system_error_"	/* message already has been printed; just bomb out */
	then go to recover_from_error;

	else if condition_name = "apl_dirty_stop_"
	then do;					/* stopping in the middle of a line, between operators */

		if dont_interrupt_parse
		then go to on_return;
		if dont_interrupt_operator
		then go to on_return;
		if dont_interrupt_storage_manager
		then go to on_return;
		if dont_interrupt_command
		then go to on_return;
		go to dirty_stop;

on_return:
	     end;

	else if condition_name = "apl_quit_"		/* DIM decided this attention was an "interrupt" */
	then call initial_interrupt;			/* set up to stop later at some more convenient time */

	else do;

/* hardware conditions */
/* make sure that we are interruptible.  If we are not interruptible, then we are not
   in an operator and any faults that occur are not domain errors but system errors.
   In this case we would let them out to default_error_handler_ so we can get a nice message.
 */

		if ws_info.dont_interrupt_parse | ws_info.dont_interrupt_storage_manager
		     | ws_info.dont_interrupt_operator | ws_info.dont_interrupt_command
		then do;
			continue_switch = "1"b;
			return;
		     end;

/* Note that a zerodivide condition is treated as a real error, and not an APL 0-:0 -> 1, because
   all of the APL divides are supposed to special-case 0-:0. */

		if (condition_name = "fixedoverflow") | (condition_name = "overflow") | (condition_name = "zerodivide")
		then go to domain_error;

		else if condition_name = "underflow"
		then do;

/* The FIM has made the following changes to the machine conditions:
   1. The AQ is "0"b.
   2. The E is -128 (Thus, the EAQ is a normalized floating-point zero).
   3. The ILC has been incremented if the instruction was not FSTR or DFSTR.
   4. The RFI and IF bits in the SCU.CU data have been turned on.

   Thus, all we have to do is return, and the underflow will be changed into a zero.
   The FIM has the capability to restore the fault right in ring 0, but there
   is no way at present to turn that on. When a way is added, APL should be changed.
   PG 10/23/79 */

			n_underflows = n_underflows + 1;
						/* meter these */
		     end;

		else if condition_name = "error"
		then do;
			oncode_number = oncode ();	/* magic number which tells something about error */
			if oncode_number > 0
			then if oncode_number <= 100	/* 1-100 are math errors */
			     then go to domain_error;

			continue_switch = "1"b;	/* unknown problem. let system print message */
		     end;

		else if condition_name = "finish"	/* signalled when process is being bumped */
		then do;
			if ^ws_info.restrict_save	/* sigh */
			then call apl_save_command_ ("continue", "", code);

			continue_switch = "1"b;	/* let default system action be taken, too. */
		     end;

		else if condition_name = "record_quota_overflow"
						/* hmm. if it's on the process dir, be careful! */
		then go to ws_full_no_quota_error;

/* some condition that we don't know about.  Either a timer went off
   or the guy just lost.  In either case, let it out to default_error_handler_
   so we can see the message; user can get back into APL with the program_interrupt command. */

		else continue_switch = "1"b;
	     end;					/* hardware conditions */
	return;

     end /* apl_default_handler_ */;

     end /* apl_parse_ */;




		    apl_pendant_function_check_.pl1 11/29/83  1638.6r w 11/29/83  1346.9       15120



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

/* Program to see if a specified function is pendent on the parse stack.
   Written 731006 by DAM
   Modified 740910 by PG for installation
*/

apl_pendant_function_check_:
	procedure (fbp) returns (bit (1) aligned);

/* parameters */

dcl 1 fbp aligned structure parameter,		/* mismatch for aligned packed pointer */
    2 function_bead_to_check unaligned pointer;

/* automatic */

dcl parse_frame_ptr unaligned pointer;

/* builtin */

dcl null builtin;

/* program */

/* this procedure returns "1"b if the specified function is pendant */

	do parse_frame_ptr = current_parse_frame_ptr repeat parse_frame.last_parse_frame_ptr
	     while (parse_frame_ptr ^= null);

	     if parse_frame_type = function_frame_type
	     then if parse_frame.function_bead_ptr = function_bead_to_check
		then return("1"b);		/* pendant (or suspended), this routine wants to treat them identically
					   since only smart routines like the editor can handle suspended
					   functions and SI damage. */
	end;

	return("0"b);				/* not found in stack so is not pendant */

/* include files */

%include apl_parse_frame;
%include apl_ws_info;
%include apl_number_data;
%include apl_bead_format;
%include apl_operator_bead;
end;




		    apl_quadcall_.pl1               11/29/83  1643.6r w 11/29/83  1558.2      750051



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1983 *
   *                                                         *
   *********************************************************** */
apl_quadcall_: proc (operators_argument);

/*  Author:  H. Hoover,  Univeristy of Calgary,  81-06-05.                   */

/*  Modification history:                                                    */
/*                                                                           */
/*  81-12-11 (HH):  Added support for 'options (variable)' description of    */
/*     parameters.                                                           */
/*  82-01-06 (HH):  Added support for parameter type 'entry'.                */
/*  83-11-21 (AD):  Changed addr(substr(foo)) to based character array       */
/*     references (which should be replaced later by addcharno).             */

/*  Function:  an APL system function to provide APL users the ability to    */
/*     call a FORTRAN or PL/I routine.  If the routine is a subroutine, no   */
/*     result is returned to APL.  But if the routine is a function, the     */
/*     function's value is returned as the result.                           */

/*  Syntax:  Function call:  V -< qCALL (entry_dcl; arg1; arg2; ...; argN)    */
/*           Subroutine call:  qCALL (entry_dcl; arg1; arg2; ...; argN)      */
/*                                                                           */
/*   where 'q' is the APL quad symbol.                                       */

/*  Arguments:                                                               */
/*                                                                           */
/*  entry_dcl  (Input)                                                       */
/*     is an APL character value containing a PL/I style entry declaration   */
/*     specifying the routine to be called, the number of arguments it       */
/*     takes, whether it is a subroutine or function, and the types of the   */
/*     arguments and function value.  (See 'Entry Declaration' below for     */
/*     details.)                                                             */
/*                                                                           */
/*  arg1, arg2, ... argN  (Update)                                           */
/*     are the APL variables and values to be used as the arguments of the   */
/*     routine which is being called.  If an argument is a simple variable   */
/*     (as opposed to a constant, an expression or an indexed variable), the */
/*     value of that variable is updated to reflect any changes made by the  */
/*     called routine.                                                       */

/*  Entry Declaration:                                                       */
/*                                                                           */
/*  The entry declaration is identical to that of PL/I (except that the      */
/*  'entry' keyword is optional), with the following restrictions:           */
/*                                                                           */
/*  (1) The attributes in a parameter declaration must be in the folowing    */
/*      order:  dimensions, type, size and alignment.                        */
/*  (2) A lower bound may not be specified for a dimension.                  */
/*  (3) The mode (i.e 'real' or 'complex') may not be specified.             */
/*  (4) The only types supported are:  bit, char, entry, fixed bin, and      */
/*      float bin.                                                           */
/*  (5) Neither dimensions nor parameter descriptions (other than 'options   */
/*      (variable)') may be specified for 'entry' values.                    */
/*  (6) A scale factor may not be specified for 'fixed' values.              */
/*  (7) 'fixed' and 'float' values may not be unaligned.                     */
/*                                                                           */
/*  A typical declaration would be:                                          */
/*    'get_line_length_$stream(char(*), fixed bin(35)) returns(fixed bin)'   */

/*  Notes:                                                                   */
/*                                                                           */
/*  (1) If a simple variable is passed as an argument, that variable need    */
/*      not have been previously assigned a value.  In such a case, the      */
/*      value passed to the called routine for that argument has the shape   */
/*      and type indicated by the entry declaration and is initialized to    */
/*      binary zeroes.                                                       */
/*                                                                           */
/*  (2) The value of an argument must agree with the type specified in the   */
/*      entry declaration.  For example, if an argument is to be passed as a */
/*      'bit' value, it must be numeric and contain only zeroes and ones.    */
/*                                                                           */
/*  (3) The shape of an argument must agree with that specified in the entry */
/*      declaration.  This usually means that an argument has the shape      */
/*      indicated by the declaration.  However, an argument that is to be    */
/*      passed as a 'bit' or 'char' value is also considered to have the     */
/*      correct shape if its rank is one greater than in the declaration,    */
/*      its shape when the last dimension is excluded is the same as in the  */
/*      declaration, and the length of the last dimension is the same as the */
/*      size attribute in the declaration.  For example a 3x4 character      */
/*      matrix may be passed as '(3, 4) char (1)' or '(3) char (4)'.         */
/*                                                                           */
/*  (4) Either a positive integer or an asterisk may be used in the entry    */
/*      declaration to specify the length of a dimension or the size of a    */
/*      'bit' or 'char' value.  An asterisk in a dimension specification     */
/*      means use the current length of the corresponding dimension of the   */
/*      argument.  An asterisk in a size attribute means use the current     */
/*      length of the last dimension of the argument.  Asterisks may not be  */
/*      used when the corresponding argument is a simple variable that has   */
/*      not yet been assigned a value.  Asterisks may only be used in the    */
/*      'returns' attribute if the routine being called was written in PL/I  */
/*      and contains asterisks in the 'returns' attribute of its header.     */
/*                                                                           */
/*  (5) If 'options (variable)' is given in place of parameter declarations, */
/*      any number of arguments may be supplied.  A rank N numeric argument  */
/*      is passed as an N-dimension array of 'float bin(63)' numbers.  A     */
/*      rank N character argument is passed as an (N-1)-dimension array of   */
/*      'char(M)', where M is the size of the argument's last dimension.     */

dcl  cu_$generate_call entry (entry, ptr),
     sys_info$max_seg_size fixed bin (35) ext static;

dcl  null builtin,
     size builtin;

dcl  False bit (1) static options (constant) init ("0"b),
     Function fixed bin static options (constant) init (0),
     Left_arg fixed bin static options (constant) init (1),
     Max_rank fixed bin static options (constant) init (15),
     Right_arg fixed bin static options (constant) init (2),
     Token_chars char (63) static options (constant) init
    ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"),
     True bit (1) static options (constant) init ("1"b),
     Type_bit fixed bin static options (constant) init (19),
     Type_char fixed bin static options (constant) init (21),
     Type_entry fixed bin static options (constant) init (16),
     Type_fixed_bin_long fixed bin static options (constant) init (2),
     Type_fixed_bin_short fixed bin static options (constant) init (1),
     Type_float_bin_long fixed bin static options (constant) init (4),
     Type_float_bin_short fixed bin static options (constant) init (3);

dcl  aligned_char_vec_len fixed bin (21),
     aligned_char_vec_ptr ptr,
     aligned_char_vec_size fixed bin (21),
     arg_list_arg_count fixed bin,
     argument_desc_ptr ptr,
     argument_list_ptr ptr,
     bit_vec_len fixed bin (24),
     bit_vec_pad fixed bin,
     bit_vec_ptr ptr,
     bit_vec_size fixed bin (24),
     bits_in_result fixed bin (24),
     calling_a_function bit (1),
     declaration_len fixed bin,
     declaration_ptr ptr,
     fixed_bin_long_vec_len fixed bin (17),
     fixed_bin_long_vec_ptr ptr,
     fixed_bin_short_vec_len fixed bin (18),
     fixed_bin_short_vec_ptr ptr,
     float_bin_long_vec_len float bin (17),
     float_bin_long_vec_ptr ptr,
     float_bin_short_vec_len float bin (18),
     float_bin_short_vec_ptr ptr,
     list_ptr ptr,
     marker_ptr ptr,
     routine entry variable,
     token_idx fixed bin,
     token_len fixed bin,
     unaligned_char_vec_len fixed bin (21),
     unaligned_char_vec_ptr ptr,
     unaligned_char_vec_size fixed bin (21);

dcl 01 argument_desc based (argument_desc_ptr),
    02 header like arg_descriptor,
    02 dimension_info (argument_desc.number_dims),
      03 lower_bound fixed bin (35),
      03 upper_bound fixed bin (35),
      03 multiplier fixed bin (35);

dcl 01 argument_list based (argument_list_ptr) like arg_list;

dcl  aligned_char_vec (aligned_char_vec_len) char (aligned_char_vec_size) aligned based (aligned_char_vec_ptr),
     bit_vec (bit_vec_len) bit (bit_vec_size + bit_vec_pad) based (bit_vec_ptr),
     declaration char (declaration_len) based (declaration_ptr),
     fixed_bin_long_vec (fixed_bin_long_vec_len) fixed bin (71) based (fixed_bin_long_vec_ptr),
     fixed_bin_short_vec (fixed_bin_short_vec_len) fixed bin (35) based (fixed_bin_short_vec_ptr),
     float_bin_long_vec (float_bin_long_vec_len) float bin (63) based (float_bin_long_vec_ptr),
     float_bin_short_vec (float_bin_short_vec_len) float bin (27) based (float_bin_short_vec_ptr),
     marker (0:n_members) fixed bin based (marker_ptr),
     dummy_chars (4*sys_info$max_seg_size) char (1) unaligned based,
     token char (token_len) based (addr (declaration_ptr -> dummy_chars (token_idx))),
     unaligned_char_vec (unaligned_char_vec_len) char (unaligned_char_vec_size) unaligned based (unaligned_char_vec_ptr);
	call validate_usage;
	call allocate_table_space;
	call process_declaration;
	call convert_arguments;
	if calling_a_function
	then begin;
dcl  result_buf bit (bits_in_result) aligned init (""b);	/*  Not on APL value stack to simplify garbage collection.  */
	     if bits_in_result = 0
	     then argument_list.arg_ptrs (arg_list_arg_count) = addr (argument_list.arg_ptrs (arg_list_arg_count));
	     else argument_list.arg_ptrs (arg_list_arg_count) = addr (result_buf);
	     call cu_$generate_call (routine, argument_list_ptr);
	     call update_byname_arguments;
	     call collect_garbage;
	     call assign_result;
	end;
	else do;
	     call cu_$generate_call (routine, argument_list_ptr);
	     call update_byname_arguments;
	     call collect_garbage;
	     operators_argument.result = null;
	end;
	operators_argument.error_code = 0;
	return;
allocate_argument_storage: proc (value_ptr);

/*  Function:  to allocate a value bead, from the APL heap, of a size that   */
/*     is appropriate for the current value of an argument.                  */

/*  Arguments:                                                               */
/*                                                                           */
/*  value_ptr  (Output)                                                      */
/*     the address of the value bead that was allocated.                     */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  argument_desc  (Input)                                                   */
/*     the argument descriptor describing the value that will be placed in   */
/*     the value bead to be allocated.                                       */

/*  Notes:                                                                   */
/*                                                                           */
/*  (1)  The value bead is initialized according to the rank, shape and type */
/*       specified by the argument descriptor, but the data area is left for */
/*       for the caller to initialize.                                       */

dcl  value_ptr ptr;

dcl  apl_allocate_words_ entry (fixed bin (18), ptr unaligned);

dcl  bead_size fixed bin (18),
     data_size fixed bin (18),
     i fixed bin,
     last_dimension_implicit bit (1),
     unaligned_value_ptr ptr unaligned,
     value_size fixed bin (18);

/*  Calculate the value's size and allocate storage for it.  */

	     data_elements = 1;
	     number_of_dimensions = argument_desc.number_dims;
	     do i = 1 to number_of_dimensions;
		data_elements = argument_desc.upper_bound (i)*data_elements;
	     end;
	     if (argument_desc.type = Type_bit | argument_desc.type = Type_char) & argument_desc.size > 1
	     then do;
		last_dimension_implicit = True;
		number_of_dimensions = number_of_dimensions + 1;
		data_elements = argument_desc.size*data_elements;
	     end;
	     else last_dimension_implicit = False;
	     bead_size = round_to_even (size (value_bead));
	     if argument_desc.type = Type_char
	     then data_size = round_to_even (size (character_string_overlay));
	     else data_size = size (numeric_datum);
	     value_size = bead_size + data_size;
	     call apl_allocate_words_ (value_size, unaligned_value_ptr);
	     value_ptr = unaligned_value_ptr;

/*  Initialize the bead.  */

	     if argument_desc.type = Type_char
	     then string (value_ptr -> value_bead.type) = character_value_type;
	     else if argument_desc.type = Type_bit
	     then string (value_ptr -> value_bead.type) = zero_or_one_value_type;
	     else if argument_desc.type = Type_fixed_bin_short | argument_desc.type = Type_fixed_bin_long
	     then string (value_ptr -> value_bead.type) = integral_value_type;
	     else string (value_ptr -> value_bead.type) = numeric_value_type;
	     value_ptr -> value_bead.size = bit (value_size, 18);
	     value_ptr -> value_bead.reference_count = 1;
	     value_ptr -> value_bead.total_data_elements = data_elements;
	     value_ptr -> value_bead.rhorho = number_of_dimensions;
	     value_ptr -> value_bead.data_pointer = addrel (value_ptr, bead_size);
	     number_of_dimensions = argument_desc.number_dims;
	     do i = 1 to number_of_dimensions;
		value_ptr -> value_bead.rho (i) = argument_desc.upper_bound (number_of_dimensions - i + 1);
	     end;
	     if last_dimension_implicit
	     then value_ptr -> value_bead.rho (i) = argument_desc.size;
	end allocate_argument_storage;
allocate_table_space: proc;

/*  Function:  to allocate space on the APL value stack to hold the tables   */
/*     created from the declaration:  the argument list (which must be even  */
/*     word aligned), the argument descriptors, and the declaration marker   */
/*     array.                                                                */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  arg_list_arg_count  (Output)                                             */
/*     is set equal to 'n_members', which is either the correct argument     */
/*     count (if we are calling a function), or one more than the correct    */
/*     count (if we are calling a subroutine).                               */
/*                                                                           */
/*  argument_desc_ptr  (Output)                                              */
/*     is the address of the storage allocated for the argument descriptors. */
/*                                                                           */
/*  argument_list_ptr  (Output)                                              */
/*     is the address of the storage allocated for the argument list.  It is */
/*     even-word aligned.                                                    */
/*                                                                           */
/*  list_ptr  (Input)                                                        */
/*     is the address of the list bead for our right argument.               */
/*                                                                           */
/*  marker_ptr  (Output)                                                     */
/*     is the address of the storage allocated for the marker array.         */
/*                                                                           */
/*  n_members  (Input)                                                       */
/*     is the number of members in the list passed as our right argument.    */

dcl  descriptor_space fixed bin,
     i fixed bin,
     member_ptr ptr,
     rank fixed bin;

/*  Calculate the number of words needed to hold the argument descriptors.   */
/*  Each descriptor requires 1 word for the header and, if the argument is   */
/*  not a scalar, 3 words for each dimension.  We can determine the size of  */
/*  the descriptor needed for each input argument from the rank of its       */
/*  value.  However, we won't know the rank of any output only arguments     */
/*  until we have decoded the declaration, so we must assume the maximum     */
/*  rank for these.  Similarly, we do not yet know if we are calling a       */
/*  subroutine or function, so we must assume we are calling a function and  */
/*  that its return value is of maximum rank.                                */

	     descriptor_space = 3*Max_rank + 1;		/*  Space for result descriptor.  */
	     do i = 2 to n_members;			/*  Add space for argument descriptors.  */
		member_ptr = list_ptr -> list_bead.member_ptr (i);
		if member_ptr -> general_bead.symbol
		then if member_ptr -> symbol_bead.meaning_pointer = null
		     then rank = Max_rank;
		     else rank = member_ptr -> symbol_bead.meaning_pointer -> value_bead.rhorho;
		else rank = member_ptr -> value_bead.rhorho;
		descriptor_space = descriptor_space + 3*rank + 1;
	     end;

/*  Allocate one block of storage to contain the argument list, followed by  */
/*  the argument descriptors, followed by the marker array.                  */

	     arg_list_arg_count = n_members;
	     argument_list_ptr = apl_push_stack_ (size (argument_list) + descriptor_space + size (marker));
	     argument_desc_ptr = addrel (argument_list_ptr, size (argument_list));
	     marker_ptr = addrel (argument_desc_ptr, descriptor_space);
	end allocate_table_space;
%include apl_push_stack_fcn;
assign_result: proc;

/*  Function:  to convert the result of the function just called to an APL   */
/*     value and set that value as our result.                               */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  argument_desc  (Input)                                                   */
/*     the argument descriptor for the result.                               */
/*                                                                           */
/*  argument_list  (Input)                                                   */
/*     the argument list for the call that created the result.               */
/*                                                                           */
/*  operators_argument.result  (Output)                                      */
/*     the address of the APL value bead created for the converted result.   */

dcl  bead_ptr ptr,
     bead_size fixed bin (18),
     data_ptr ptr,
     data_size fixed bin (18),
     i fixed bin,
     j fixed bin,
     k fixed bin,
     last_dimension_implicit bit (1);

/*  Create the value bead for the result.  */

	     argument_desc_ptr = argument_list.desc_ptrs (arg_list_arg_count);
	     data_elements = 1;
	     number_of_dimensions = argument_desc.number_dims;
	     do i = 1 to number_of_dimensions;
		data_elements = data_elements*argument_desc.upper_bound (i);
	     end;
	     if (argument_desc.type = Type_bit | argument_desc.type = Type_char) & argument_desc.size > 1
	     then do;
		last_dimension_implicit = True;
		data_elements = data_elements*argument_desc.size;
		number_of_dimensions = number_of_dimensions + 1;
	     end;
	     else last_dimension_implicit = False;
	     bead_size = round_to_even (size (value_bead));
	     if argument_desc.type = Type_char
	     then data_size = round_to_even (divide (data_elements + 3, 4, 18));
	     else data_size = 2*data_elements;
	     if bead_size + data_size > MAX_VALUE_BEAD_SIZE
	     then call error (apl_error_table_$result_size, Function);
	     operators_argument.result, bead_ptr = apl_push_stack_ (bead_size + data_size);
	     bead_ptr -> value_bead.total_data_elements = data_elements;
	     bead_ptr -> value_bead.rhorho = number_of_dimensions;
	     bead_ptr -> value_bead.data_pointer, data_ptr = addrel (bead_ptr, bead_size);
	     do i = 1 to argument_desc.number_dims;
		bead_ptr -> value_bead.rho (i) = argument_desc.upper_bound (argument_desc.number_dims - i + 1);
	     end;
	     if last_dimension_implicit
	     then bead_ptr -> rho (number_of_dimensions) = argument_desc.size;

/*  Convert the result to APL format.  */

	     if argument_desc.type = Type_bit
	     then do;
		string (bead_ptr -> value_bead.type) = zero_or_one_value_type;
		float_bin_long_vec_len = data_elements;
		float_bin_long_vec_ptr = data_ptr;
		if argument_desc.packed | mod (argument_desc.size, 36) = 0
		then do;
		     bit_vec_size = float_bin_long_vec_len;
		     bit_vec_len = 1;
		end;
		else do;
		     bit_vec_size = argument_desc.size;
		     bit_vec_len = divide (float_bin_long_vec_len, bit_vec_size, 24);
		end;
		bit_vec_pad = 36*divide (bit_vec_size + 35, 36, 24) - bit_vec_size;
		bit_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count);
		i = 1;
		do j = 1 to bit_vec_len;
		     do k = 1 to bit_vec_size;
			float_bin_long_vec (i) = float (substr (bit_vec (j), k, 1));
			i = i + 1;
		     end;
		end;
	     end;
	     else if argument_desc.type = Type_char
	     then do;
		string (bead_ptr -> value_bead.type) = character_value_type;
		if ^argument_desc.packed | mod (argument_desc.size, 4) ^= 0
		then do;
		     unaligned_char_vec_size = argument_desc.size;
		     unaligned_char_vec_len = divide (data_elements,
			unaligned_char_vec_size, 21);
		     unaligned_char_vec_ptr = data_ptr;
		     aligned_char_vec_size = unaligned_char_vec_size;
		     aligned_char_vec_len = unaligned_char_vec_len;
		     aligned_char_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count);
		     do i = 1 to aligned_char_vec_len;
			unaligned_char_vec (i) = aligned_char_vec (i);
		     end;
		end;
		else do;
		     unaligned_char_vec_len = 1;
		     unaligned_char_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count);
		     unaligned_char_vec_size = data_elements;
		     data_ptr -> unaligned_char_vec = unaligned_char_vec;
		end;
	     end;
	     else if argument_desc.type = Type_fixed_bin_long
	     then do;
		float_bin_long_vec_len = data_elements;
		float_bin_long_vec_ptr = data_ptr;
		fixed_bin_long_vec_len = float_bin_long_vec_len;
		fixed_bin_long_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count);
		do i = 1 to fixed_bin_long_vec_len	/*  Copy to first non-Boolean.  */
			while (fixed_bin_long_vec (i) = 0 | fixed_bin_long_vec (i) = 1);
		     float_bin_long_vec (i) = fixed_bin_long_vec (i);
		end;
		do j = i to fixed_bin_long_vec_len;	/*  Copy remainder.  */
		     float_bin_long_vec (j) = fixed_bin_long_vec (j);
		end;
		if i > fixed_bin_long_vec_len
		then string (bead_ptr -> value_bead.type) = zero_or_one_value_type;
		else string (bead_ptr -> value_bead.type) = integral_value_type;
	     end;
	     else if argument_desc.type = Type_fixed_bin_short
	     then do;
		float_bin_long_vec_len = data_elements;
		float_bin_long_vec_ptr = data_ptr;
		fixed_bin_short_vec_len = float_bin_long_vec_len;
		fixed_bin_short_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count);
		do i = 1 to fixed_bin_short_vec_len	/*  Copy to first non-Boolean.  */
			while (fixed_bin_short_vec (i) = 0 | fixed_bin_short_vec (i) = 1);
		     float_bin_long_vec (i) = fixed_bin_short_vec (i);
		end;
		do j = i to fixed_bin_short_vec_len;	/*  Copy remainder.  */
		     float_bin_long_vec (j) = fixed_bin_short_vec (j);
		end;
		if i > fixed_bin_short_vec_len
		then string (bead_ptr -> value_bead.type) = zero_or_one_value_type;
		else string (bead_ptr -> value_bead.type) = integral_value_type;
	     end;
	     else if argument_desc.type = Type_float_bin_long
	     then do;
		float_bin_long_vec_len = data_elements;
		float_bin_long_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count);
		do i = 1 to float_bin_long_vec_len	/*  Copy to first non-Boolean.  */
			while (float_bin_long_vec (i) = 0 | float_bin_long_vec (i) = 1);
		     data_ptr -> float_bin_long_vec (i) = float_bin_long_vec (i);
		end;
		do j = i to float_bin_long_vec_len	/*  Copy to first non_integer.  */
			while (float_bin_long_vec (j) = floor (float_bin_long_vec (j)));
		     data_ptr -> float_bin_long_vec (j) = float_bin_long_vec (j);
		end;
		do k = j to float_bin_long_vec_len;	/*  Copy remainder.  */
		     data_ptr -> float_bin_long_vec (k) = float_bin_long_vec (k);
		end;
		if i > float_bin_long_vec_len
		then string (bead_ptr -> value_bead.type) = zero_or_one_value_type;
		else if j > float_bin_long_vec_len
		then string (bead_ptr -> value_bead.type) = integral_value_type;
		else string (bead_ptr -> value_bead.type) = numeric_value_type;
	     end;
	     else if argument_desc.type = Type_float_bin_short
	     then do;
		float_bin_long_vec_len = data_elements;
		float_bin_long_vec_ptr = data_ptr;
		float_bin_short_vec_len = float_bin_long_vec_len;
		float_bin_short_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count);
		do i = 1 to float_bin_short_vec_len	/*  Copy to first non-Boolean.  */
			while (float_bin_short_vec (i) = 0 | float_bin_short_vec (i) = 1);
		     float_bin_long_vec (i) = float_bin_short_vec (i);
		end;
		do j = i to float_bin_short_vec_len	/*  Copy to first non-integer.  */
			while (float_bin_short_vec (j) = floor (float_bin_short_vec (j)));
		     float_bin_long_vec (j) = float_bin_short_vec (j);
		end;
		do k = j to float_bin_short_vec_len;	/*  Copy remainder.  */
		     float_bin_long_vec (k) = float_bin_short_vec (k);
		end;
		if i > float_bin_short_vec_len
		then string (bead_ptr -> value_bead.type) = zero_or_one_value_type;
		else if j > float_bin_short_vec_len
		then string (bead_ptr -> value_bead.type) = integral_value_type;
		else string (bead_ptr -> value_bead.type) = numeric_value_type;
	     end;
	end assign_result;
collect_garbage: proc;

/*  Function:  to free the space in the APL value stack occupied by the      */
/*     arguments, since they are no longer needed.                           */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  list_ptr  (Input)                                                        */
/*     the address of the right argument list bead.                          */
/*                                                                           */
/*  ws_info.value_stack_ptr  (Output)                                        */
/*     the address of the next free location on the APL value stack.         */

dcl  apl_free_bead_ entry (ptr unaligned);

dcl  i fixed bin,
     member_ptr ptr;

/*  Pop the value stack:  The right argument list bead is lowest on the      */
/*  stack, unless some of the list members are also on the stack, in which   */
/*  case the rightmost such member is lowest.  The reference count for each  */
/*  member which is not on the value stack must also be decremented.         */

	     ws_info.value_stack_ptr = list_ptr;
	     do i = 1 to n_members;
		member_ptr = list_ptr -> list_bead.member_ptr (i);
		if list_ptr -> list_bead.semantics_on_stack (i)
		then ws_info.value_stack_ptr = member_ptr;
		else do;
		     member_ptr -> general_bead.reference_count = member_ptr -> general_bead.reference_count - 1;
		     if member_ptr -> general_bead.reference_count < 1
		     then call apl_free_bead_ ((member_ptr));
		end;
	     end;
	end collect_garbage;
convert_arguments: proc;

/*  Function:  to format the arguments to be passed to the routine which is  */
/*     to be called, according to the declaration.                           */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  argument_desc  (Input)                                                   */
/*     the argument descriptors (from which the type of conversion needed is */
/*     discovered).                                                          */
/*                                                                           */
/*  argument_list  (Update)                                                  */
/*     the argument list for the call.  The argument ptrs will be filled in. */
/*                                                                           */
/*  list_ptr  (Input)                                                        */
/*     the address of the list bead for the right argument.                  */
/*                                                                           */
/*  marker  (Input)                                                          */
/*     the indices in 'declaration' of the routine name (element 0) and the  */
/*     start of each parameter declaration (elements 1 -> 'n_members').      */

dcl  arg_num fixed bin,
     entry_ptr ptr,
     i fixed bin,
     j fixed bin,
     k fixed bin,
     member_num fixed bin,
     member_ptr ptr,
     module_name_len fixed bin (21),
     module_name_ptr ptr,
     rank fixed bin,
     routine_name_len fixed bin (21),
     routine_name_ptr ptr,
     size_limit float bin (27),
     status fixed bin (35),
     value_ptr ptr;

dcl  entry entry based (entry_ptr),
     routine_name char (routine_name_len) based (routine_name_ptr),
     module_name char (module_name_len) based (module_name_ptr);

/*  Fill in the argument list argument pointers.  If an argument is already  */
/*  in the format specified in the declaration, and it either is passed by   */
/*  by value on the value stack, or it is passed by name and does not share  */
/*  its value, then we just use it.  Otherwise, we must copy its value onto  */
/*  the value stack in the appropriate format and then use the copy.  If the */
/*  argument is already on the value stack and the desired format does not   */
/*  require any more space, do the conversion in place, rather than allocate */
/*  new storage on the value stack.                                          */

	     do member_num = 2 to n_members;
		arg_num = member_num - 1;
		member_ptr = list_ptr -> list_bead.member_ptr (member_num);
		if member_ptr -> general_bead.symbol
		then value_ptr = member_ptr -> symbol_bead.meaning_pointer;
		else value_ptr = member_ptr;
		argument_desc_ptr = argument_list.desc_ptrs (arg_num);
		if value_ptr = null
		then do;				/*  No initial value, so just allocate space.  */
		     bit_vec_len = 1;
		     rank = argument_desc.number_dims;
		     if rank < 1
		     then if argument_desc.type = Type_bit
			then bit_vec_size = argument_desc.size;
			else if argument_desc.type = Type_char
			then bit_vec_size = 9*argument_desc.size;
			else bit_vec_size = argument_desc.size + 1;
		     else if argument_desc.packed
		     then bit_vec_size = argument_desc.upper_bound (rank)*argument_desc.multiplier (rank);
		     else bit_vec_size = 36*argument_desc.upper_bound (rank)*argument_desc.multiplier (rank);
		     bit_vec_pad = 36*divide (bit_vec_size + 35, 36, 18) - bit_vec_size;
		     bit_vec_ptr = apl_push_stack_ (size (bit_vec));
		     unspec (bit_vec) = ""b;
		     argument_list.arg_ptrs (arg_num) = bit_vec_ptr;
		end;
		else if argument_desc.type = Type_bit
		then do;
		     float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
		     float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer;
		     if argument_desc.packed | mod (argument_desc.size, 36) = 0
		     then do;
			bit_vec_size = float_bin_long_vec_len;
			bit_vec_len = 1;
		     end;
		     else do;
			bit_vec_size = argument_desc.size;
			bit_vec_len = divide (float_bin_long_vec_len, bit_vec_size, 24);
		     end;
		     bit_vec_pad = 36*divide (bit_vec_size + 35, 36, 18) - bit_vec_size;
		     if list_ptr -> list_bead.semantics_on_stack (member_num)
		     then bit_vec_ptr = float_bin_long_vec_ptr;
		     else bit_vec_ptr = apl_push_stack_ (size (bit_vec));
		     i = 1;
		     do j = 1 to bit_vec_len;
			do k = 1 to bit_vec_size;
			     substr (bit_vec (j), k, 1) = (float_bin_long_vec (i) ^= 0);
			     i = i + 1;
			end;
			substr (unspec (bit_vec (j)), k) = ""b; /*  Zero the pad bits.  */
		     end;
		     argument_list.arg_ptrs (arg_num) = bit_vec_ptr;
		end;
		else if argument_desc.type = Type_char
		then do;
		     if ^argument_desc.packed & mod (argument_desc.size, 4) ^= 0
		     then do;			/*  Copy onto value stack in aligned format.  */
			unaligned_char_vec_size = argument_desc.size;
			unaligned_char_vec_len = divide (value_ptr -> value_bead.total_data_elements,
			     unaligned_char_vec_size, 21);
			unaligned_char_vec_ptr = value_ptr -> value_bead.data_pointer;
			aligned_char_vec_size = unaligned_char_vec_size;
			aligned_char_vec_len = unaligned_char_vec_len;
			aligned_char_vec_ptr = apl_push_stack_ (size (aligned_char_vec));
			unspec (aligned_char_vec) = ""b; /*  Ensure padding will be zeroes.  */
			do i = 1 to aligned_char_vec_len;
			     aligned_char_vec (i) = unaligned_char_vec (i);
			end;
			argument_list.arg_ptrs (arg_num) = aligned_char_vec_ptr;
		     end;
		     else if list_ptr -> list_bead.semantics_on_stack (member_num)
		     | (member_ptr -> general_bead.symbol & value_ptr -> value_bead.reference_count < 2)
		     then argument_list.arg_ptrs (arg_num) = value_ptr -> value_bead.data_pointer;
		     else do;			/*  Copy onto value stack without conversion.  */
			unaligned_char_vec_size = value_ptr -> value_bead.total_data_elements;
			unaligned_char_vec_len = 1;
			unaligned_char_vec_ptr = apl_push_stack_ (size (unaligned_char_vec));
			unspec (unaligned_char_vec)
			     = unspec (value_ptr -> value_bead.data_pointer -> unaligned_char_vec);
			argument_list.arg_ptrs (arg_num) = unaligned_char_vec_ptr;
		     end;
		end;
		else if argument_desc.type = Type_entry
		then do;
		     module_name_ptr = value_ptr -> value_bead.data_pointer;
		     module_name_len = value_ptr -> value_bead.total_data_elements;
		     module_name_len = length (rtrim (module_name)); /*  Exclude trailing spaces.  */
		     i = verify (module_name, " ");
		     if i > 1
		     then do;			/*  Exclude leading spaces.  */
			module_name_ptr = addr (module_name_ptr -> dummy_chars (i));
			module_name_len = module_name_len - i + 1;
		     end;
		     i = index (module_name, "$");
		     if i > 0
		     then do;			/*  Routine name is explicit.  */
			routine_name_ptr = addr (module_name_ptr -> dummy_chars (i + 1));
			routine_name_len = module_name_len - i;
			module_name_len = i - 1;
		     end;
		     else do;			/*  Segment name is also routine name.  */
			routine_name_ptr = module_name_ptr;
			routine_name_len = module_name_len;
		     end;
		     if length (module_name) < 1 | length (module_name) > 32 | verify (module_name, Token_chars) > 0
		     | length (routine_name) < 1 | length (routine_name) > 32 | verify (routine_name, Token_chars) > 0
		     then call declaration_error ("invalid entry name", marker (arg_num));
		     entry_ptr = apl_push_stack_ (size (entry));
		     call make_entry (module_name, routine_name, entry, status);
		     if status ^= 0
		     then if routine_name = module_name
			then call declaration_error (rtrim (meaning (status)) || "  " || module_name, marker (arg_num));
			else call declaration_error (rtrim (meaning (status)) || "  " || module_name
			     || "$" || routine_name, marker (arg_num));
		     argument_list.arg_ptrs (arg_num) = entry_ptr;
		end;
		else if argument_desc.type = Type_fixed_bin_long
		then do;
		     float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
		     float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer;
		     fixed_bin_long_vec_len = float_bin_long_vec_len;
		     if list_ptr -> list_bead.semantics_on_stack (member_num)
		     then fixed_bin_long_vec_ptr = float_bin_long_vec_ptr;
		     else fixed_bin_long_vec_ptr = apl_push_stack_ (size (fixed_bin_long_vec));
		     size_limit = 2e0**fixed (argument_desc.size, 7);
		     do i = 1 to fixed_bin_long_vec_len;
			if float_bin_long_vec (i) < -size_limit | float_bin_long_vec (i) >= size_limit
			then goto cannot_convert_argument;
			fixed_bin_long_vec (i) = float_bin_long_vec (i);
		     end;
		     argument_list.arg_ptrs (arg_num) = fixed_bin_long_vec_ptr;
		end;
		else if argument_desc.type = Type_fixed_bin_short
		then do;
		     float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
		     float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer;
		     fixed_bin_short_vec_len = float_bin_long_vec_len;
		     if list_ptr -> list_bead.semantics_on_stack (member_num)
		     then fixed_bin_short_vec_ptr = float_bin_long_vec_ptr;
		     else fixed_bin_short_vec_ptr = apl_push_stack_ (size (fixed_bin_short_vec));
		     size_limit = 2e0**fixed (argument_desc.size, 7);
		     do i = 1 to fixed_bin_short_vec_len;
			if float_bin_long_vec (i) < -size_limit | float_bin_long_vec (i) >= size_limit
			then goto cannot_convert_argument;
			fixed_bin_short_vec (i) = float_bin_long_vec (i);
		     end;
		     argument_list.arg_ptrs (arg_num) = fixed_bin_short_vec_ptr;
		end;
		else if argument_desc.type = Type_float_bin_long
		then if list_ptr -> list_bead.semantics_on_stack (member_num)
		     | (member_ptr -> general_bead.symbol & value_ptr -> value_bead.reference_count < 2)
		     then argument_list.arg_ptrs (arg_num) = value_ptr -> value_bead.data_pointer;
		     else do;			/*  Copy onto value stack without conversion.  */
			float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
			float_bin_long_vec_ptr = apl_push_stack_ (size (float_bin_long_vec));
			unspec (float_bin_long_vec)
			     = unspec (value_ptr -> value_bead.data_pointer -> float_bin_long_vec);
			argument_list.arg_ptrs (arg_num) = float_bin_long_vec_ptr;
		     end;
		else if argument_desc.type = Type_float_bin_short
		then do;
		     float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
		     float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer;
		     float_bin_short_vec_len = float_bin_long_vec_len;
		     if list_ptr -> list_bead.semantics_on_stack (member_num)
		     then float_bin_short_vec_ptr = float_bin_long_vec_ptr;
		     else float_bin_short_vec_ptr = apl_push_stack_ (size (float_bin_short_vec));
		     do i = 1 to float_bin_short_vec_len;
			float_bin_short_vec (i) = float_bin_long_vec (i);
		     end;
		     argument_list.arg_ptrs (arg_num) = float_bin_short_vec_ptr;
		end;
		else argument_list.arg_ptrs (arg_num) = null; /*  If we missed a conversion, this will tell us.  */
	     end;
	     return;

/*  One of the elements in the APL value is too large to convert to the      */
/*  required format.  Issue a diagnostic pointing to the size field of the   */
/*  appropriate argument declaration.                                        */

cannot_convert_argument:
	     token_idx = marker (arg_num);
	     token_len = 0;
	     call get_next_token;
	     if token = "(" | token = "dim" | token = "dimension"
	     then do;				/*  Skip dimension specification.  */
		do while (token ^= ")");
		     call get_next_token;
		end;
		call get_next_token;
	     end;
	     call get_next_token;			/*  Skip type specification.  */
	     if token = "bin"
	     then call get_next_token;
	     if token = "("
	     then call get_next_token;
	     call declaration_error ("parameter size incompatible with argument", token_idx);
	end convert_arguments;
declaration_error: proc (error_msg, declaration_idx);

/*  Function:  to display a diagnostic about the declaration, indicating     */
/*     where in the declaration the error occurred.  This is done by         */
/*     printing the declaration with a caret under the indicated character.  */

/*  Arguments:                                                               */
/*                                                                           */
/*  error_msg  (Input)                                                       */
/*     the diagnostic to be printed.                                         */
/*                                                                           */
/*  declaration_idx  (Input)                                                 */
/*     the index of the character in the declaration under which the caret   */
/*     is to appear.                                                         */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  declaration  (Input)                                                     */
/*     the declaration in which the error was detected.                      */

dcl  error_msg char (*),
     declaration_idx fixed bin;

dcl  ioa_$nnl entry options (variable);

	     call ioa_$nnl ("^/declaration error:  ^a^/^6x^a^/^vx^a", error_msg, declaration, declaration_idx+5, QAndSign);
	     call error (apl_error_table_$domain, Right_arg);
	end declaration_error;
error:	proc (status, where);

/*  Function:  to return control to APL upon detection of an error.          */

/*  Arguments:                                                               */
/*                                                                           */
/*  status  (Input)                                                          */
/*     the status code describing the error which is to be returned to APL.  */
/*                                                                           */
/*  where  (Input)                                                           */
/*     'Function' if the error is not in an argument, 'Left_arg' if it is in */
/*     the left argument, and 'Right_arg' if it is in the right argument.    */

dcl  status fixed bin (35),
     where fixed bin;

	     operators_argument.error_code = status;
	     if where = Left_arg
	     then operators_argument.where_error = operators_argument.where_error + 1;
	     else if where = Right_arg
	     then operators_argument.where_error = operators_argument.where_error - 1;
	     goto return;
	end error;
generate_argument_desc: proc (member_ptr);

/*  Function:  to generate an argument descriptor for an argument, based on  */
/*     the type, rank and shape fields of its value bead.                    */

/*  Arguments:                                                               */
/*                                                                           */
/*  member_ptr  (Input)                                                      */
/*     the address of the APL symbol or value bead for the argument for      */
/*     which an argument descriptor is to be generated.                      */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  argument_desc  (Output)                                                  */
/*     the argument descriptor generated for the argument.                   */
/*                                                                           */
/*  token_idx  (Input)                                                       */
/*     the index of the token to be associated with this argument in error   */
/*     messages.                                                             */

dcl  member_ptr ptr;

dcl  i fixed bin,
     j fixed bin,
     multiplier fixed bin (35),
     rank fixed bin,
     value_ptr ptr;

	     if member_ptr -> general_bead.symbol
	     then do;
		value_ptr = member_ptr -> symbol_bead.meaning_pointer;
		if value_ptr = null
		then call declaration_error (member_ptr -> symbol_bead.name || " not defined", token_idx);
	     end;
	     else value_ptr = member_ptr;
	     rank = value_ptr -> value_bead.rhorho;
	     if rank > Max_rank
	     then if member_ptr -> general_bead.symbol
		then call declaration_error (member_ptr -> symbol_bead.name || " rank exceeds "
		     || ltrim (char (Max_rank)), token_idx);
		else call declaration_error ("argument rank exceeds " || ltrim (char (Max_rank)), token_idx);
	     argument_desc.flag = "1"b;
	     if string (value_ptr -> value_bead.type) = character_value_type
	     then if rank = 0
		then do;				/*  Argument is character scalar.  */
		     argument_desc.type = Type_char;
		     argument_desc.packed = True;
		     argument_desc.number_dims = rank;
		     argument_desc.size = 1;
		     multiplier = 9;
		end;
		else do;				/*  Argument is character array.  */
		     argument_desc.type = Type_char;
		     argument_desc.packed = True;
		     argument_desc.number_dims = rank - 1;
		     argument_desc.size = value_ptr -> value_bead.rho (rank);
		     multiplier = 9*value_ptr -> value_bead.rho (rank);
		     rank = rank - 1;
		end;
	     else do;				/*  Argument is numeric scalar or array.  */
		argument_desc.type = Type_float_bin_long;
		argument_desc.packed = False;
		argument_desc.number_dims = rank;
		argument_desc.size = 63;
		multiplier = 2;
	     end;
	     do i = 1 to rank;
		j = rank - i + 1;
		argument_desc.lower_bound (j) = 1;
		argument_desc.upper_bound (j) = value_ptr -> value_bead.rho (i);
		argument_desc.multiplier (i) = multiplier;
		multiplier = value_ptr -> value_bead.rho (j)*multiplier;
	     end;
	end generate_argument_desc;
get_next_token: proc;

/*  Function:  to isolate the next token of the declaration.  A token is a   */
/*     string of consecutive letters, digits and underscores, or any other   */
/*     single character, except space (which has no meaning other than as a  */
/*     string delimiter).                                                    */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  declaration  (Input)                                                     */
/*     the string from which the next token is to be selected.               */
/*                                                                           */
/*  token_idx  (Update)                                                      */
/*     the index of the current token of the declaration.                    */
/*                                                                           */
/*  token_len  (Update)                                                      */
/*     the length of the current token of the declaration.                   */

dcl  spaces fixed bin;

	     token_idx = token_idx + token_len;		/*  Skip over current token.  */
	     spaces = verify (substr (declaration, token_idx), " ") - 1;
	     if spaces < 0
	     then spaces = length (substr (declaration, token_idx));
	     token_idx = token_idx + spaces;		/*  Skip over any spaces before next token.  */
	     token_len = verify (substr (declaration, token_idx), Token_chars) - 1;
	     if token_len < 0
	     then token_len = length (substr (declaration, token_idx));
	     else if token_len = 0 & token_idx <= length (declaration)
	     then token_len = 1;
	end get_next_token;
make_entry: proc (module_name, routine_name, entry, status);

/*  Function:  to form an entry value for a routine, given the names of the  */
/*     routine and the module which contains it.  If the module has not yet  */
/*     been initiated, a segment of the same name as that of the module is   */
/*     searched for using the 'apl' search paths.  If nothing is found, the  */
/*     search is continued using the search rules.                           */

/*  Arguments:                                                               */
/*                                                                           */
/*  module_name  (Input)                                                     */
/*     the name of the module containing the desired routine.                */
/*                                                                           */
/*  routine_name  (Input)                                                    */
/*     the name of the desired routine.                                      */
/*                                                                           */
/*  entry  (Output)                                                          */
/*     the entry value of the routine.                                       */
/*                                                                           */
/*  status  (Output)                                                         */
/*     a standard system status code.                                        */

dcl  module_name char (*),
     routine_name char (*),
     entry entry,
     status fixed bin (35);

dcl  hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)),
     hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin (35)),
     hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35)),
     search_paths_$find_dir entry (char (*), ptr, char (*), char (*), char (*), fixed bin (35));

dcl  codeptr builtin;

dcl  our_dir_name char (168) static init ("");

dcl  dir_name char (168),
     our_dir_name_len fixed bin,
     our_ent_name char (32),
     seg_ptr ptr;

	     call hcs_$fs_get_seg_ptr (module_name, seg_ptr, status);
	     if seg_ptr = null
	     then do;				/*  Module not initiated:  try 'apl' search paths.  */
		if our_dir_name = ""
		then call hcs_$fs_get_path_name (codeptr (make_entry), our_dir_name, our_dir_name_len, our_ent_name, status);
		call search_paths_$find_dir ("apl", null, module_name, our_dir_name, dir_name, status);
		if status = 0
		then call hcs_$initiate (dir_name, module_name, module_name, 0, 0, seg_ptr, status);
	     end;
	     call hcs_$make_entry (codeptr (make_entry), module_name, routine_name, entry, status);
	end make_entry;
meaning:	proc (status) returns (char (100));

/*  Function:  to return the meaning of a status code.                       */

/*  Arguments:                                                               */
/*                                                                           */
/*  status  (Input)                                                          */
/*     the status code whose meaning is desired.                             */

dcl  status fixed bin (35);

dcl  convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);

dcl  long_info char (100) aligned,
     short_info char (8) aligned;

	     call convert_status_code_ (status, short_info, long_info);
	     return (long_info);
	end meaning;
process_declaration: proc;

/*  Function:  to supervise the building of the argument list, argument      */
/*     descriptors and marker array from the declaration.                    */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  arg_list_arg_count  (Update)                                             */
/*     the number of arguments if we are calling a subroutine, else that     */
/*     number plus one.                                                      */
/*  argument_desc  (Output)                                                  */
/*     the argument descriptors for the parameters of the declaration.       */
/*                                                                           */
/*  argument_list  (Output)                                                  */
/*     the argument list for the routine which is to be called.  The         */
/*     argument value ptrs still need to be filled in.                       */
/*                                                                           */
/*  bits_in_result  (Output)                                                 */
/*     the number of bits of storage that we need to allocate for the return */
/*     value.  (It is zero if we are calling a subroutine or a function      */
/*     whose value has '*' extents.)                                         */
/*                                                                           */
/*  calling_a_function  (Output)                                             */
/*     a flag indicating whether we are calling a function or subroutine.    */
/*                                                                           */
/*  declaration  (Input)                                                     */
/*     a PL/I style entry declaration for the routine to be called.          */
/*                                                                           */
/*  list_ptr  (Input)                                                        */
/*     the address of the list bead for the right argument.                  */
/*                                                                           */
/*  marker  (Output)                                                         */
/*     the indices in 'declaration' of the routine name (element 0) and the  */
/*     start of each parameter declaration (elements 1 -> 'n_members').      */
/*                                                                           */
/*  n_members  (Input)                                                       */
/*     the number of members in the right argument list.                     */

dcl  Letters char (52) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz");

dcl  arg_num fixed bin,
     member_ptr ptr,
     module_name char (32),
     more bit (1),
     rank fixed bin,
     routine_name char (32),
     status fixed bin (35);

/*  Extract the module and routine names from the declaration.  */

	     token_idx = 1;
	     token_len = 0;
	     call get_next_token;
	     marker (0) = token_idx;
	     if index (Letters, substr (token, 1, min (1, token_len))) = 0 | token_len > maxlength (module_name)
	     then call declaration_error ("invalid module name", token_idx);
	     module_name = token;
	     call get_next_token;
	     if token = "$"
	     then do;				/*  Extract routine name.  */
		call get_next_token;
		if index (Letters, substr (token, 1, min (1, token_len))) = 0 | token_len > maxlength (routine_name)
		then call declaration_error ("invalid routine name", token_idx);
		routine_name = token;
		call get_next_token;
	     end;
	     else routine_name = module_name;
	     if token = "entry"
	     then call get_next_token;		/*  Ignore superfluous 'entry' attribute.  */

/*  Initialize argument list header.  */

	     calling_a_function = (index (substr (declaration, token_idx), "returns") > 0);
	     if ^calling_a_function
	     then arg_list_arg_count = arg_list_arg_count - 1;
	     argument_list.arg_count = arg_list_arg_count;
	     argument_list.pad1 = ""b;
	     argument_list.call_type = Interseg_call_type;
	     argument_list.desc_count = arg_list_arg_count;
	     argument_list.pad2 = ""b;

/*  Decode any argument declarations into the corresponding descriptors.  */

	     arg_num = 0;
	     if token = "("
	     then do;				/*  Process parameter declarations.  */
		call get_next_token;
		more = (token ^= ")");
		do while (more);
		     arg_num = arg_num + 1;
		     if arg_num >= n_members
		     then call declaration_error ("more parameters than arguments", token_idx);
		     marker (arg_num) = token_idx;
		     argument_list.desc_ptrs (arg_num) = argument_desc_ptr;
		     member_ptr = list_ptr -> list_bead.member_ptr (arg_num + 1);
		     call process_parameter_dcl (member_ptr);
		     argument_desc_ptr = addrel (argument_desc_ptr, size (argument_desc));
		     if token = ","
		     then call get_next_token;
		     else more = False;
		end;
		if token ^= ")"
		then call declaration_error ("invalid syntax", token_idx);
		call get_next_token;
	     end;
	     else if token = "options"
	     then do;				/*  Process 'options (variable)' attribute.  */
		call get_next_token;
		if token ^= "("
		then call declaration_error ("syntax error", token_idx);
		call get_next_token;
		if token ^= "variable"
		then call declaration_error ("syntax error", token_idx);
		call get_next_token;
		if token ^= ")"
		then call declaration_error ("syntax error", token_idx);
		do while (arg_num + 1 < n_members);
		     arg_num = arg_num + 1;
		     marker (arg_num) = token_idx;
		     argument_list.desc_ptrs (arg_num) = argument_desc_ptr;
		     member_ptr = list_ptr -> list_bead.member_ptr (arg_num + 1);
		     call generate_argument_desc (member_ptr);
		     argument_desc_ptr = addrel (argument_desc_ptr, size (argument_desc));
		end;
		call get_next_token;
	     end;
	     if arg_num ^= n_members - 1
	     then call declaration_error ("more arguments than parameters", token_idx);

/*  Decode 'returns' attribute, if any.  */

	     if token = "returns"
	     then do;
		call get_next_token;
		if token ^= "("
		then call declaration_error ("invalid syntax", token_idx);
		call get_next_token;
		marker (arg_num + 1) = token_idx;
		argument_list.desc_ptrs (arg_num + 1) = argument_desc_ptr;
		call process_parameter_dcl (null);
		if token ^= ")"
		then call declaration_error ("invalid syntax", token_idx);
		call get_next_token;
		rank = argument_desc.number_dims;
		if rank < 1
		then if argument_desc.type = Type_bit
		     then bits_in_result = argument_desc.size;
		     else if argument_desc.type = Type_char
		     then bits_in_result = 9*argument_desc.size;
		     else bits_in_result = argument_desc.size + 1;
		else if argument_desc.packed
		then bits_in_result = argument_desc.upper_bound (rank)*argument_desc.multiplier (rank);
		else bits_in_result = 36*argument_desc.upper_bound (rank)*argument_desc.multiplier (rank);
	     end;
	     else bits_in_result = 0;

/*  Check that we have reached the end of the declaration, then locate the   */
/*  routine to be called.                                                    */

	     if token ^= ""
	     then call declaration_error ("invalid_syntax", token_idx);
	     call make_entry (module_name, routine_name, routine, status);
	     if status ^= 0
	     then if routine_name = module_name
		then call declaration_error (rtrim (meaning (status)) || "  " || module_name, marker (0));
		else call declaration_error (rtrim (meaning (status)) || "  " || rtrim (module_name)
		     || "$" || routine_name, marker (0));
	end process_declaration;
process_parameter_dcl: proc (member_ptr);

/*  Function:  to extract the rank, shape, type, size and alignment from an  */
/*  parameter declaration and use that information to build an argument      */
/*  descriptor.                                                              */

/*  Arguments:                                                               */
/*                                                                           */
/*  member_ptr  (Input)                                                      */
/*     the address of the APL symbol or value bead for the argument which    */
/*     corresponds to the parameter declaration, or null if this declaration */
/*     is for the result value.                                              */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  argument_desc  (Output)                                                  */
/*     the argument descriptor built from the parameter declaration.         */
/*                                                                           */
/*  token  (Update)                                                          */
/*     the current token of the declaration.  On input, it will be the first */
/*     token of the parameter declaration.  On output, it will be the first  */
/*     token following the parameter declaration.                            */
/*                                                                           */
/*  token_idx  (Update)                                                      */
/*     the index in the declaration of the current token.                    */
/*                                                                           */
/*  token_len  (Update)                                                      */
/*     the length of the current token.                                      */

dcl  member_ptr ptr;

dcl  sys_info$max_seg_size fixed bin (19) ext;

dcl  bits_in_value fixed bin (71),
     bits_per_element fixed bin,
     dimensioning_idx fixed bin,
     i fixed bin,
     j fixed bin,
     last_dimension_implicit bit (1) init (False),
     more bit (1),
     multiplier fixed bin (35),
     next_token_idx fixed bin,
     next_token_len fixed bin,
     packed bit (1),
     rank fixed bin,
     shape (Max_rank) fixed bin (35),
     size fixed bin (35),
     type fixed bin,
     value_ptr ptr;

	     value_ptr = member_ptr;
	     if member_ptr ^= null
	     then if member_ptr -> general_bead.symbol
		then value_ptr = member_ptr -> symbol_bead.meaning_pointer;

/*  Verify format of dimension attribute, if any.  */

	     rank = 0;
	     if token = "dim" | token = "dimension"
	     then call get_next_token;		/*  Ignore superfluous 'dim' keyword.  */
	     dimensioning_idx = token_idx;
	     if token = "("
	     then do;
		more = True;
		do while (more);
		     call get_next_token;
		     rank = rank + 1;
		     if rank > Max_rank
		     then call declaration_error ("too many dimensions", token_idx);
		     if token = "*"
		     then if member_ptr = null
			then shape (rank) = 0;
			else if value_ptr = null
			then call declaration_error ("parameter dimension incompatible with argument", token_idx);
			else if rank > value_ptr -> value_bead.rhorho
			then call declaration_error ("parameter has more dimensions than argument", token_idx);
			else shape (rank) = value_ptr -> value_bead.rho (rank);
		     else if verify (token, "0123456789") > 0 | verify (token, "0") = 0 | length (token) > 10
		     then call declaration_error ("invalid dimension", token_idx);
		     else do;
			shape (rank) = bin (token, 35);
			if value_ptr ^= null
			then if rank > value_ptr -> value_bead.rhorho
			     then call declaration_error ("too many dimensions", token_idx);
			     else if shape (rank) ^= value_ptr -> value_bead.rho (rank)
			     then call declaration_error ("parameter dimension incompatible with argument", token_idx);
		     end;
		     call get_next_token;
		     more = (token = ",");
		end;
		if token ^= ")"
		then call declaration_error ("invalid syntax", token_idx);
		call get_next_token;
	     end;

/*  Decode type attribute.  */

	     if token = "bit"
	     then do;
		if value_ptr ^= null
		then if string (value_ptr -> value_bead.type) ^= zero_or_one_value_type
		     then call declaration_error ("parameter type incompatible with argument", token_idx);
		type = Type_bit;
		size = 1;
		packed = True;
		call get_next_token;
	     end;
	     else if token = "char" | token = "character"
	     then do;
		if value_ptr ^= null
		then if string (value_ptr -> value_bead.type) ^= character_value_type
		     then call declaration_error ("parameter type incompatible with argument", token_idx);
		type = Type_char;
		size = 1;
		packed = True;
		call get_next_token;
	     end;
	     else if token = "entry"
	     then do;
		if member_ptr = null
		then call declaration_error ("invalid type for return value", token_idx);
		if rank > 0
		then call declaration_error ("too many dimensions", token_idx);
		if value_ptr = null
		then call declaration_error ("parameter type incompatible with argument", token_idx);
		if string (value_ptr -> general_bead.type) ^= character_value_type
		then call declaration_error ("parameter type incompatible with argument", token_idx);
		type = Type_entry;
		size = 0;
		packed = False;
		last_dimension_implicit = True;
		call get_next_token;
		if token = "options"
		then do;				/*  Flush 'options (variable)' phrase.  */
		     call get_next_token;
		     if token ^= "("
		     then call declaration_error ("invalid syntax", token_idx);
		     call get_next_token;
		     if token ^= "variable"
		     then call declaration_error ("invalid syntax", token_idx);
		     call get_next_token;
		     if token ^= ")"
		     then call declaration_error ("invalid syntax", token_idx);
		     call get_next_token;
		end;
		if token = "("
		then call declaration_error ("invalid syntax", token_idx);
	     end;
	     else if token = "fixed"
	     then do;
		if value_ptr ^= null
		then if string (value_ptr -> value_bead.type) ^= integral_value_type
		     & string (value_ptr -> value_bead.type) ^= zero_or_one_value_type
		     then call declaration_error ("parameter type incompatible with argument", token_idx);
		type = Type_fixed_bin_short;
		size = 17;
		packed = False;
		call get_next_token;
		if token = "bin" | token = "binary"
		then call get_next_token;
		else if token = "dec" | token = "decimal"
		then call declaration_error ("numeric data must be binary", token_idx);
	     end;
	     else if token = "float"
	     then do;
		if value_ptr ^= null
		then if ^value_ptr -> value_bead.numeric_value
		     then call declaration_error ("parameter type incompatible with argument", token_idx);
		type = Type_float_bin_short;
		size = 27;
		packed = False;
		call get_next_token;
		if token = "bin" | token = "binary"
		then call get_next_token;
		else if token = "dec" | token = "decimal"
		then call declaration_error ("numeric data must be binary", token_idx);
	     end;
	     else call declaration_error ("invalid syntax", token_idx);

/*  Decode size attribute, if any.  */

	     if token = "("
	     then do;
		call get_next_token;
		if token = "*"
		then size = 0;
		else if verify (token, "0123456789") = 0 & verify (token, "0") > 0 & token_len <= 10
		then size = bin (token, 35);
		else call declaration_error ("invalid size", token_idx);
		if type = Type_bit
		then do;
		     if size > 36*sys_info$max_seg_size
		     then call declaration_error ("size too big", token_idx);
		     if member_ptr ^= null
		     then if value_ptr = null
			then do;
			     if size = 0
			     then call declaration_error ("parameter size incompatible with argument", token_idx);
			end;
			else if rank = value_ptr -> value_bead.rhorho
			then do;
			     if size = 0
			     then size = 1;
			     else if size ^= 1
			     then call declaration_error ("parameter size incompatible with argument", token_idx);
			end;
			else if rank = value_ptr -> value_bead.rhorho - 1
			then do;
			     if size = 0
			     then size = value_ptr -> value_bead.rho (value_ptr -> value_bead.rhorho);
			     else if size ^= value_ptr -> value_bead.rho (value_ptr -> value_bead.rhorho)
			     then call declaration_error ("parameter size incompatible with argument", token_idx);
			     last_dimension_implicit = True;
			end;
		end;
		else if type = Type_char
		then do;
		     if size > 4*sys_info$max_seg_size
		     then call declaration_error ("size too big", token_idx);
		     if member_ptr ^= null
		     then if value_ptr = null
			then do;
			     if size = 0
			     then call declaration_error ("parameter size incompatible with argument", token_idx);
			end;
			else if rank = value_ptr -> value_bead.rhorho
			then do;
			     if size = 0
			     then size = 1;
			     else if size ^= 1
			     then call declaration_error ("parameter size incompatible with argument", token_idx);
			end;
			else if rank = value_ptr -> value_bead.rhorho - 1
			then do;
			     if size = 0
			     then size = value_ptr -> value_bead.rho (value_ptr -> value_bead.rhorho);
			     else if size ^= value_ptr -> value_bead.rho (value_ptr -> value_bead.rhorho)
			     then call declaration_error ("parameter size incompatible with argument", token_idx);
			     last_dimension_implicit = True;
			end;
		end;
		else if type = Type_fixed_bin_short
		then do;
		     if size > 71
		     then call declaration_error ("size too big", token_idx);
		     else if size > 35
		     then type = Type_fixed_bin_long;
		end;
		else if type = Type_float_bin_short
		then do;
		     if size > 63
		     then call declaration_error ("size too big", token_idx);
		     else if size > 27
		     then type = Type_float_bin_long;
		end;
		call get_next_token;
		if token ^= ")"
		then call declaration_error ("syntax error", token_idx);
		call get_next_token;
	     end;

/*  Decode alignment attribute, if any.  */

	     if token = "al" | token = "aligned"
	     then do;
		packed = False;
		call get_next_token;
	     end;
	     else if token = "unal" | token = "unaligned"
	     then do;
		packed = True;
		if type ^= Type_bit & type ^= Type_char
		then call declaration_error ("numeric data must be aligned", token_idx);
		call get_next_token;
	     end;

/*  Except for possible inconsistencies in the dimensioning, the declaration */
/*  looks good, so fill in the header of the argument descriptor, followed   */
/*  by the dimension info (checking that it is consistent).                  */

	     argument_desc.flag = "1"b;
	     argument_desc.type = type;
	     argument_desc.packed = packed;
	     argument_desc.number_dims = rank;
	     argument_desc.size = size;
	     next_token_idx = token_idx;
	     next_token_len = token_len;
	     token_idx = dimensioning_idx;
	     token_len = 1;
	     if rank > 0
	     then do;
		if type = Type_bit
		then bits_per_element = size;
		else if type = Type_char
		then bits_per_element = 9*size;
		else bits_per_element = size + 1;
		if packed
		then multiplier = bits_per_element;
		else do;
		     multiplier = divide (bits_per_element + 35, 36, 35);
		     bits_per_element = 36*multiplier;
		end;
		bits_in_value = bits_per_element;
		do i = 1 to rank;
		     call get_next_token;
		     bits_in_value = max (1, shape (i))*bits_in_value;
		     if bits_in_value > 36*sys_info$max_seg_size
		     then call declaration_error ("object too large", token_idx);
		     j = rank - i + 1;
		     argument_desc.lower_bound (j) = 1;
		     argument_desc.upper_bound (j) = shape (i);
		     argument_desc.multiplier (i) = multiplier;
		     multiplier = shape (j)*multiplier;
		     call get_next_token;
		end;
	     end;
	     if value_ptr ^= null
	     then if value_ptr -> value_bead.rhorho > rank + fixed (last_dimension_implicit)
		then call declaration_error ("parameter has fewer dimensions than argument", token_idx);
	     token_idx = next_token_idx;
	     token_len = next_token_len;
	end process_parameter_dcl;
round_to_even: proc (num) returns (fixed bin (18));

/*  Function:  to return the smallest even integer not less than a given     */
/*     integer.                                                              */

/*  Arguments:                                                               */
/*                                                                           */
/*  num  (Input)                                                             */
/*     the integer to be rounded.                                            */

dcl  num fixed bin (18);

	     return (num + mod (num, 2));
	end round_to_even;
update_byname_arguments: proc;

/*  Function:  to update the value of all arguments passed by name.          */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  argument_list  (Input)                                                   */
/*     the argument list for the routine just called (so we can find the     */
/*     argument descriptors and values).                                     */
/*                                                                           */
/*  argument_desc  (Input)                                                   */
/*     the argument descriptors (so we can tell the format of the new        */
/*     values).                                                              */
/*                                                                           */
/*  list_ptr  (Input)                                                        */
/*     the address of the list bead for the right argument (so we can find   */
/*     and update the value of the by-name arguments).                       */

dcl  arg_num fixed bin,
     i fixed bin,
     j fixed bin,
     k fixed bin,
     member_num fixed bin,
     member_ptr ptr,
     value_ptr ptr;

	     do member_num = 2 to n_members;
		arg_num = member_num - 1;
		member_ptr = list_ptr -> list_bead.member_ptr (member_num);
		if member_ptr -> general_bead.symbol
		then do;
		     argument_desc_ptr = argument_list.desc_ptrs (arg_num);
		     value_ptr = member_ptr -> symbol_bead.meaning_pointer;
		     if value_ptr = null
		     then do;			/*  Allocate storage for the return value.  */
			call allocate_argument_storage (value_ptr);
			member_ptr -> symbol_bead.meaning_pointer = value_ptr;
		     end;
		     else if value_ptr -> value_bead.reference_count > 1
		     then do;			/*  Allocate unique storage for the return value.  */
			member_ptr -> symbol_bead.meaning_pointer = null;
			value_ptr -> value_bead.reference_count = value_ptr -> value_bead.reference_count - 1;
			call allocate_argument_storage (value_ptr);
			member_ptr -> symbol_bead.meaning_pointer = value_ptr;
		     end;
		     if argument_desc.type = Type_bit
		     then do;
			float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
			float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer;
			if argument_desc.packed | mod (argument_desc.size, 36) = 0
			then do;
			     bit_vec_size = float_bin_long_vec_len;
			     bit_vec_len = 1;
			end;
			else do;
			     bit_vec_size = argument_desc.size;
			     bit_vec_len = divide (float_bin_long_vec_len, bit_vec_size, 24);
			end;
			bit_vec_pad = 36*divide (bit_vec_size + 35, 36, 24) - bit_vec_size;
			bit_vec_ptr = argument_list.arg_ptrs (arg_num);
			i = 1;
			do j = 1 to bit_vec_len;
			     do k = 1 to bit_vec_size;
				float_bin_long_vec (i) = float (substr (bit_vec (j), k, 1));
				i = i + 1;
			     end;
			end;
		     end;
		     else if argument_desc.type = Type_char
		     then do;
			unaligned_char_vec_size = argument_desc.size;
			unaligned_char_vec_len = divide (value_ptr -> value_bead.total_data_elements,
			     unaligned_char_vec_size, 21);
			unaligned_char_vec_ptr = value_ptr -> value_bead.data_pointer;
			if ^argument_desc.packed & mod (argument_desc.size, 4) ^= 0
			then do;
			     aligned_char_vec_size = unaligned_char_vec_size;
			     aligned_char_vec_len = unaligned_char_vec_len;
			     aligned_char_vec_ptr = argument_list.arg_ptrs (arg_num);
			     do i = 1 to aligned_char_vec_len;
				unaligned_char_vec (i) = aligned_char_vec (i);
			     end;
			end;
			else if unaligned_char_vec_ptr ^= argument_list.arg_ptrs (arg_num)
			then unspec (unaligned_char_vec)
			     = unspec (argument_list.arg_ptrs (arg_num) -> unaligned_char_vec);
		     end;
		     else if argument_desc.type = Type_fixed_bin_long
		     then do;
			float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
			float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer;
			fixed_bin_long_vec_len = float_bin_long_vec_len;
			fixed_bin_long_vec_ptr = argument_list.arg_ptrs (arg_num);
			do i = 1 to fixed_bin_long_vec_len /*  Copy to first non-Boolean.  */
				while (fixed_bin_long_vec (i) = 0 | fixed_bin_long_vec (i) = 1);
			     float_bin_long_vec (i) = fixed_bin_long_vec (i);
			end;
			do j = i to fixed_bin_long_vec_len; /*  Copy remainder.  */
			     float_bin_long_vec (j) = fixed_bin_long_vec (j);
			end;
			if i > fixed_bin_long_vec_len
			then string (value_ptr -> value_bead.type) = zero_or_one_value_type;
			else string (value_ptr -> value_bead.type) = integral_value_type;
		     end;
		     else if argument_desc.type = Type_fixed_bin_short
		     then do;
			float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
			float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer;
			fixed_bin_short_vec_len = float_bin_long_vec_len;
			fixed_bin_short_vec_ptr = argument_list.arg_ptrs (arg_num);
			do i = 1 to fixed_bin_short_vec_len /*  Copy to first non-Boolean.  */
				while (fixed_bin_short_vec (i) = 0 | fixed_bin_short_vec (i) = 1);
			     float_bin_long_vec (i) = fixed_bin_short_vec (i);
			end;
			do j = i to fixed_bin_short_vec_len; /*  Copy remainder.  */
			     float_bin_long_vec (j) = fixed_bin_short_vec (j);
			end;
			if i > fixed_bin_short_vec_len
			then string (value_ptr -> value_bead.type) = zero_or_one_value_type;
			else string (value_ptr -> value_bead.type) = integral_value_type;
		     end;
		     else if argument_desc.type = Type_float_bin_long
		     then do;
			float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
			float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer;
			if float_bin_long_vec_ptr ^= argument_list.arg_ptrs (arg_num)
			then unspec (float_bin_long_vec)
			     = unspec (argument_list.arg_ptrs (arg_num) -> float_bin_long_vec);
			do i = 1 to float_bin_long_vec_len /*  Find first non-Boolean.  */
				while (float_bin_long_vec (i) = 0 | float_bin_long_vec (i) = 1);
			end;
			do j = i to float_bin_long_vec_len /*  Find first non-integer.  */
				while (float_bin_long_vec (j) = floor (float_bin_long_vec (j)));
			end;
			if i > float_bin_long_vec_len
			then string (value_ptr -> value_bead.type) = zero_or_one_value_type;
			else if j > float_bin_long_vec_len
			then string (value_ptr -> value_bead.type) = integral_value_type;
			else string (value_ptr -> value_bead.type) = numeric_value_type;
		     end;
		     else if argument_desc.type = Type_float_bin_short
		     then do;
			float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements;
			float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer;
			float_bin_short_vec_len = float_bin_long_vec_len;
			float_bin_short_vec_ptr = argument_list.arg_ptrs (arg_num);
			do i = 1 to float_bin_short_vec_len /*  Copy to first non-Boolean.  */
				while (float_bin_short_vec (i) = 0 | float_bin_short_vec (i) = 1);
			     float_bin_long_vec (i) = float_bin_short_vec (i);
			end;
			do j = i to float_bin_short_vec_len /*  Copy to first non-integer.  */
				while (float_bin_short_vec (j) = floor (float_bin_short_vec (j)));
			     float_bin_long_vec (j) = float_bin_short_vec (j);
			end;
			do k = j to float_bin_short_vec_len; /*  Copy remainder.  */
			     float_bin_long_vec (k) = float_bin_short_vec (k);
			end;
			if i > float_bin_short_vec_len
			then string (value_ptr -> value_bead.type) = zero_or_one_value_type;
			else if j > float_bin_short_vec_len
			then string (value_ptr -> value_bead.type) = integral_value_type;
			else string (value_ptr -> value_bead.type) = numeric_value_type;
		     end;
		end;
	     end;
	end update_byname_arguments;
validate_usage: proc;

/*  Function:  to ensure that we have been called correctly.                 */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  list_ptr  (Output)                                                       */
/*     the address of the list bead for the right argument list.             */
/*                                                                           */
/*  n_members  (Output)                                                      */
/*     the number of members in the right argument list.                     */

dcl  member_num fixed bin,
     member_ptr ptr;

/*  Insure the usage is monadic and that the right argument is a list.  */

	     if operators_argument.value (Right_arg) = null
	     then call error (apl_error_table_$domain, Function);
	     else if operators_argument.value (Left_arg) ^= null
	     then call error (apl_error_table_$domain, Left_arg);
	     list_ptr = operators_argument.value (Right_arg);
	     if string (list_ptr -> list_bead.type) ^= list_value_type
	     then do;				/*  Convert simple value into 1 member list.  */
		n_members = 1;
		list_ptr = apl_push_stack_ (size (list_bead));
		string (list_ptr -> list_bead.type) = list_value_type;
		list_ptr -> list_bead.number_of_members = 1;
		list_ptr -> list_bead.member_ptr (1) = operators_argument.value (Right_arg);
		unspec (list_ptr -> list_bead.bits) = ""b;
		list_ptr -> list_bead.semantics_on_stack = operators_argument.on_stack (Right_arg);
		operators_argument.value (Right_arg) = list_ptr;
		operators_argument.on_stack = True;
	     end;
	     else n_members = list_ptr -> list_bead.number_of_members;

/*  Find first list member and check that it is of type character.  */

	     member_ptr = list_ptr -> list_bead.member_ptr (1);
	     if string (member_ptr -> value_bead.type) ^= character_value_type
	     then call error (apl_error_table_$domain, Right_arg);
	     declaration_ptr = member_ptr -> value_bead.data_pointer;
	     declaration_len = member_ptr -> value_bead.total_data_elements;

/*  Check that the remaining list members are values, undefined symbols, or  */
/*  symbols pointing to values.                                              */

	     do member_num = 2 to n_members;
		member_ptr = list_ptr -> list_bead.member_ptr (member_num);
		if ^member_ptr -> general_bead.value
		then if ^member_ptr -> general_bead.symbol
		     then call error (apl_error_table_$domain, Right_arg);
		     else if member_ptr -> symbol_bead.meaning_pointer ^= null
		     then if ^member_ptr -> symbol_bead.meaning_pointer -> general_bead.value
			then call error (apl_error_table_$domain, Right_arg);
	     end;
	end validate_usage;
%include apl_characters;
%include apl_external_function;
%include apl_list_bead;
%include apl_operator_bead;
%include apl_symbol_bead;
%include arg_descriptor;
%include arg_list;
return:
     end apl_quadcall_;




		    apl_random_.pl1                 11/29/83  1638.6r w 11/29/83  1347.0      115281



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

apl_random_:
     procedure (operators_argument);

/*
 * this routine contains the monadic and dyadic ? operators (roll and deal)
 * written 73.9.13 by DAM
 * Modified 2 January 1974 by PG to try to speed up big dealer.
   Modified 790312 by Willaim M. York to double-word align all value_beads (bug 278).
   Modified 790329 by PG to stop signalling apl_operator_error_ (the last refuge!), and to clean up the source.
   Modified 790815 by PG to fix 414 (deal returned garbage for result of 4?204 because memory string overlaid result).

 * The same sequence of random numbers is generated as by APL/360 XM6
 * except in the case where the range is more than 2**31-1, where
 * APL/360's algorithm is highly machine-dependent.  We have not attempted
 * to duplicate it.
 */

/* automatic */

dcl	memory_ptr	ptr,
	rn		fixed bin (31),
	(right_vb, left_vb, right, result_vb, result)
			unaligned pointer,
	data_elements	fixed bin (21),
	n_words		fixed bin (19),
	(elem, other)	fixed bin (21),
	(number, choose, from, range)
			fixed bin (35),
	X		float,
	float_temp	float,
	frange		float,
	frn		float;

/* based */

dcl	memory		dimension (0:range - 1) bit (1) unaligned based (memory_ptr);

/* builtins */

dcl	(abs, addr, addrel, floor, fixed, rel, substr, string, size, float, multiply, divide, mod, null, unspec)
			builtin;

/* entries */

declare	apl_iota_appendage_ entry (float, float, fixed bin, ptr);

/* external static */

dcl	(apl_error_table_$domain, apl_error_table_$rank)
			fixed bin (35) external;

/* internal static */

dcl	P		fixed bin (31) static init (16807),
						/* 7**5 */
	Q		fixed bin (31) static init (2147483647),
						/* 2**31 - 1 */
	Biggest_Fixed_Range float static init (2147483647.0e0),
	Two_to_31		fixed bin (32) static init (1f31b),
						/* 2**31 */
	Two_to_minus_31	fixed bin (31, 31) static initial (1f-31b),
						/* 2**(-31) */
	Biggest_bit_string	fixed bin (35) static initial (9400320),
						/* 36*261120 */
	Biggest_vector_size fixed bin static initial (130557);
						/* derived from value bead with max vector */

/* program */

/* pick up arguments, make some checks, determine monadic or dyadic */

	right_vb = operands (2).value;
	if ^right_vb -> value_bead.data_type.numeric_value
	then go to domain_error_right;
	right = right_vb -> value_bead.data_pointer;

	left_vb = operands (1).value;
	if left_vb = null
	then go to roll;				/* monadic case */

	if ^left_vb -> value_bead.data_type.numeric_value
	then go to domain_error_left;

/* pick up args for deal, set 'choose' and 'from' */

	if right_vb -> value_bead.total_data_elements ^= 1
	then go to rank_error_right;			/* must be scalar */
	if left_vb -> value_bead.total_data_elements ^= 1
	then go to rank_error_left;			/* .. */

	float_temp = floor (left_vb -> value_bead.data_pointer -> numeric_datum (0) + 0.5);
	if abs (float_temp - left_vb -> value_bead.data_pointer -> numeric_datum (0)) > integer_fuzz
	then go to domain_error_left;
	if float_temp < 0
	then go to domain_error_left;
	if float_temp >= 1e21b
	then go to domain_error_left;
	choose = fixed (float_temp);

/* check for 'frandom' case, where range > Biggest_Fixed_Range; if so go to floating_dealer */

	if right -> numeric_datum (0) > Biggest_Fixed_Range
	then go to floating_dealer;

	float_temp = floor (right -> numeric_datum (0) + 0.5);
	if abs (float_temp - right -> numeric_datum (0)) > integer_fuzz
	then go to domain_error_right;
	if float_temp < 0
	then go to domain_error_right;
	from = fixed (float_temp);

/* throw away the arguments */

	if operands (2).on_stack
	then value_stack_ptr = right_vb;
	else if operands (1).on_stack
	then value_stack_ptr = left_vb;

/*	if choose < 0 then go to domain_error_left;	ALREADY CHECKED FOR */
	if choose > from
	then go to domain_error_right;

/* DEAL.

   Return vector of 'choose' elements taken from iota 'from', without replacement. */

	if choose = 0				/* return iota 0 */
	then go to small_deal;

	if from = choose				/* a permutation.  This algorithm will */
	then go to big_deal;			/* always work...or get a ws full error for
						   trying to create too big a permutation. */

	if from <= Biggest_vector_size		/* if we can create (iota from) */
	then if choose > divide (from, 16, 35, 0)	/* and it seems to be worth it */
	     then go to big_deal;			/* use permutation algorithm */
	     else ;				/* use fast dealer */
	else if from > Biggest_bit_string		/* if we can't use fast dealer */
	then go to really_big_deal;			/* use slow dealer */

	range = from;				/* initialize range of random numbers */

	data_elements = choose;			/* allocate result first */
	call deal_push;

	n_words = size (memory);			/* allocate a big bit string to remember duplicates */
	memory_ptr = apl_push_stack_ (n_words);
	string (memory) = ""b;			/* initialize it */

	do elem = 0 by 1 while (elem < choose);
try_again:
	     call random_in_range;			/* get an integer random number */
	     number = rn + index_origin;
	     if memory (number) = "1"b		/* been here already, try again */
	     then go to try_again;

	     memory (number) = "1"b;
	     result -> numeric_datum (elem) = float (number);
						/* good value, use it */
	end;

	string (memory) = ""b;			/* zero the storage now, to lessen the chance of
						   a record_quota_overflow on the process directory. */

	go to deal_fin;

really_big_deal:					/* choose ? from */
small_deal:					/* 0 ? from */
	range = from;

	data_elements = choose;
	call deal_push;

/* fill in elements of result with random numbers, checking each time
	   for duplication */

	do elem = 0 by 1 while (elem < choose);
rn_dup:
	     call random_in_range;
	     X = float (rn + index_origin);
	     do other = 0 by 1 while (other < elem);
		if result -> numeric_datum (other) = X
		then go to rn_dup;
	     end;
	     result -> numeric_datum (elem) = X;
	end;

	go to deal_fin;

big_deal:
	data_elements = from;			/* make iota, shuffle, truncate */
	call deal_push;

/* construct "iota from" - for TSO compatibility uses a backwards iota */

/* Negative quantities tell apl_iota_appendage_ to construct backwards iota. */

	call apl_iota_appendage_ (float_index_origin, -1e0, -from, (result));

/* now do exchanges on this to bring random elements to the top */

	do elem = 0 by 1 while (elem < from);
	     range = from - elem;			/* choose from remaining slots */
	     call random_in_range;
	     X = result -> numeric_datum (elem);
	     result -> numeric_datum (elem) = result -> numeric_datum (elem + rn);
	     result -> numeric_datum (elem + rn) = X;
	end;

	go to deal_fin;

/* routine to deal from floating point numbers (when range is too big for fixed point) */

floating_dealer:
	frange = floor (right -> numeric_datum (0) + 0.5);
	if abs (frange - right -> numeric_datum (0)) > integer_fuzz
	then go to domain_error_right;

	if choose < 0
	then go to domain_error_left;

	if choose > Biggest_Fixed_Range
	then go to domain_error_right;		/* (??) */

/* don't forget to throw away the arguments */

	if operands (2).on_stack
	then value_stack_ptr = right_vb;
	else if operands (1).on_stack
	then value_stack_ptr = left_vb;

	data_elements = choose;
	call deal_push;

/* fill in the result, acting similarly to small_deal */

	do elem = 0 by 1 while (elem < choose);
frn_dup:
	     call frandom;
	     X = frn + float_index_origin;
	     do other = 0 by 1 while (other < elem);
		if result -> numeric_datum (other) = X
		then go to frn_dup;
	     end;
	     result -> numeric_datum (elem) = X;
	end;

deal_fin:
	data_elements = choose;
	ws_info.value_stack_ptr = addrel (result, size (numeric_datum));
	return;

/* ROLL.

   A scalar function that returns a random number between the index origin and the argument.
   Result is overlaid on operand, and so argument is copied onto stack if necessary. */

roll:
	if ^operands (2).on_stack
	then do;					/* Copy right_vb onto the value stack */

		data_elements = right_vb -> value_bead.total_data_elements;
		number_of_dimensions = right_vb -> value_bead.rhorho;

/* Allocate the space on the value stack */

		n_words = size (value_bead) + size (numeric_datum) + 1;
		result_vb = apl_push_stack_ (n_words);

/* Copy the value_bead header info */

		result_vb -> value_bead = right_vb -> value_bead;

/* Get pointer to the new data area */

		result = addrel (result_vb, size (value_bead));
		if substr (rel (result), 18, 1)
		then result = addrel (result, 1);
		result_vb -> value_bead.data_pointer = result;

/* Copy the data */

		result -> numeric_datum (*) = right -> numeric_datum (*);

/* Make this the new right_vb */

		right_vb = result_vb;
		right = result;

	     end;

/* check that argument is composed of integers */

	if ^right_vb -> value_bead.data_type.integral_value
	then do elem = 0 by 1 while (elem < right_vb -> value_bead.total_data_elements);
		frange = floor (right -> numeric_datum (elem) + 0.5);
		if frange <= 0
		then go to domain_error_right;
		if abs (frange - right -> numeric_datum (elem)) > integer_fuzz
		then go to domain_error_right;

		right -> numeric_datum (elem) = frange; /* make exact integer for later use */
	     end;

	string (right_vb -> value_bead.type) = integral_value_type;

/* generate the random numbers, each organized to scale of corresponding
   element of the operand */

	do elem = 0 by 1 while (elem < right_vb -> value_bead.total_data_elements);
	     frange = right -> numeric_datum (elem);
	     if frange <= 0
	     then go to domain_error_right;
	     if frange <= Biggest_Fixed_Range
	     then do;				/* will fit in fixed point */
		     range = fixed (floor (frange), 35);
		     call random_in_range;
		     right -> numeric_datum (elem) = float (rn + index_origin);
		end;
	     else do;				/* need to go to floating point */
		     string (right_vb -> value_bead.type) = numeric_value_type;
						/* reset integer bit because is */
		     call frandom;			/* too big for fixing */
		     right -> numeric_datum (elem) = frn + float_index_origin;
		end;
	end;

	operators_argument.result = right_vb;
	return;

domain_error_left:
	operators_argument.where_error = operators_argument.where_error + 2;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$domain;
	return;

rank_error_left:
	operators_argument.where_error = operators_argument.where_error + 2;

rank_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
	operators_argument.error_code = apl_error_table_$rank;
	return;

/* INTERNAL PROCEDURES */

/* internal proc to generate next random number.
   It is normalized to [0:range-1], and returned in rn. */

random_in_range:
     proc;

	if random_link <= 0
	then random_link = P;
	random_link = mod (multiply (random_link, P, 63, 0), Q);

/* treat random_link as a 31 bit fraction between 0 and 1. */

	rn = multiply (random_link, range, 63, -31) * Two_to_minus_31;

     end random_in_range;

frandom:
     proc;

/* floating-point version of random_in_range.  used by roll with big argument */

dcl	orn		fixed bin (31);

	range = Two_to_31;				/* just return raw random numbers */
	call random_in_range;
	orn = rn;					/* save first random number */
	call random_in_range;			/* so can get two */

	frn = 0.95;				/* set exponent for making a fraction, 0 to 1 */
	unspec (frn) =
	     substr (unspec (frn), 1, 9) || /* construct floating-point fraction */ substr (unspec (orn), 6, 31)
	     || /* (this is a machine-dependent kludge) */ substr (unspec (rn), 6, 31) || "0"b;
	frn = floor (frn * frange);			/* multiply random fraction by range to get answer */
     end;

deal_push:
     proc;

	number_of_dimensions = 1;
	n_words = size (value_bead) + size (numeric_datum) + 1;
	result_vb = apl_push_stack_ (n_words);
	operators_argument.result = result_vb;
	string (result_vb -> value_bead.type) = integral_value_type;
	result_vb -> value_bead.rhorho = 1;
	result_vb -> value_bead.total_data_elements, result_vb -> value_bead.rho (1) = choose;
	result = addr (result_vb -> value_bead.rho (2));
	if substr (rel (result), 18, 1)
	then result = addrel (result, 1);
	result_vb -> value_bead.data_pointer = result;
     end;

%include apl_push_stack_fcn;

/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_operators_argument;
%include apl_bead_format;
%include apl_value_bead;
     end;




		    apl_read_password_.pl1          11/29/83  1638.6r w 11/29/83  1347.0       41238



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

/* Program to read a password off of a console.  The code is stolen from the
   system routine "get_password_", except that a "read_back_input" order call is used
   to the APL DIM, and upper case letters are not used (since they cause underlines
   and backspaces when printed).

   Written by some anonymous person, summer 1973.
   Modified by PG on 740211 to use correct order call.
   Modified 781208 by PG to switch to clock builtin
*/

apl_read_password_:
read_password_:
     procedure (word);

declare  word char (8) parameter,
         the_password char (nelemt-i) based (addr (buffer.char (i)));

declare  user_info_$tty_data entry (char (*), fixed bin, char (*)),
         ios_$write_ptr entry (pointer, fixed bin, fixed bin),
         ios_$read entry (char (*), pointer, fixed bin, fixed bin, fixed bin, bit (72) aligned),
         ios_$order entry (char (*), char (*), pointer, bit (72) aligned),
         nelemt fixed bin,
        (printer_on_char init ("000000110"b),
         printer_off_char init ("000010101"b),
         carriage_return_char init ("000001101"b),
         newline_char init ("000001010"b),
         red_shift_char init ("000001110"b),
         black_shift_char init ("000001111"b)) bit (9) static,

         1 buffer aligned,
         2 char char (1) unaligned dimension (150),

         time fixed bin (71),
         ubits bit (72) aligned,
         RANDOM char (32) static aligned init ("etaiosqwertyuioplkjkgfdsazxcvbnm"),
         i fixed bin,
         old_read_back_state char (32),
         additional_garbage char (12);

dcl  buffer_1_to_12 char (12) unaligned based (addr (buffer.char (1))),
     buffer_3_to_15 char (13) unaligned based (addr (buffer.char (3))),
     buffer_14_to_25 char (12) unaligned based (addr (buffer.char (14))),
     buffer_27_to_38 char (12) unaligned based (addr (buffer.char (27))),
     buffer_40_to_51 char (12) unaligned based (addr (buffer.char (40))),
     buffer_53_to_64 char (12) unaligned based (addr (buffer.char (53)));

declare  idcode char (4),
         type fixed bin,
         channel char (8);

declare	(addr, bit, clock, fixed, null, substr, unspec) builtin;

/* program */

	call user_info_$tty_data (idcode, type, channel);

	unspec (buffer.char (1)) = printer_on_char;
	unspec (buffer.char (2)) = red_shift_char;
	buffer_3_to_15 = "apl password:";
	unspec (buffer.char (16)) = newline_char;
	unspec (buffer.char (17)) = black_shift_char;
	unspec (buffer.char (18)) = printer_off_char;

	call ios_$write_ptr (addr (buffer), 0, 18);
	if type < 0 then go to mask_it;
	if type > 7 then go to mask_it;
	go to device (type);

device (2): if substr (idcode, 1, 1) < "A" then go to no_mask;
device (0): device (6): device (7): mask_it:
	time = clock ();
	substr (ubits, 1, 36) = bit (fixed (time, 36), 36);
	substr (ubits, 37, 36) = bit (fixed (fixed (time, 35) * 99991, 36), 36);
	do i = 2 to 13;
	     substr (additional_garbage, i-1, 1) = substr (RANDOM, fixed (substr (ubits, 1+5*i, 5), 17)+1, 1);
	end;

/* assemble password mask */
	buffer_1_to_12 = "TypePassword";
	buffer_14_to_25 = "xwxwxwxwxwxw";
	buffer_27_to_38 = "986986986986";
	buffer_40_to_51 = "wgxwgxwgxwgx";
	unspec (buffer.char (13)) = carriage_return_char;
	unspec (buffer.char (26)) = carriage_return_char;
	unspec (buffer.char (39)) = carriage_return_char;
	unspec (buffer.char (52)) = carriage_return_char;
	buffer_53_to_64 = additional_garbage;
	unspec (buffer.char (65)) = carriage_return_char;

	call ios_$write_ptr (addr (buffer), 0, 65);

device (1): device (3): device (4): device (5): no_mask:
	call ios_$order ("user_i/o", "read_back_input", addr (old_read_back_state), ""b);
	call ios_$read ("apl_input_", addr (buffer), 0, 150, nelemt, ""b);
	if nelemt <= 1 then go to blank;

/* remove extraneous chars */

	do i = 1 by 1 while (buffer.char (i) = " ");
	end;
	if i = nelemt then go to blank;
	word = the_password;
	go to return;
blank:	word = "*";

return:	unspec (buffer.char (1)) = printer_on_char;
	call ios_$write_ptr (addr (buffer), 0, 1);	/* click click */
	call ios_$order ("user_i/o", old_read_back_state, null, ""b);
	return;
     end;




		    apl_reduction_appendage_.alm    11/29/83  1638.6r w 11/29/83  1347.0       96633



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

" Subroutine for use by apl to do fast reductions on certain operators.
"
" Calling sequence:
"
"     call apl_reduction_appendage_ (array_ptr, column_base, highest_element,
"	     interval_between_elements, op_to_do, result [, zerodivide_label]);
"
"     declare apl_reduction_appendage_ entry (ptr, fixed bin, fixed bin, fixed bin,
"	fixed bin (8), float bin (63) [, label]);
"
" Note that the last argument is optional, and is only passed in the divide-reduction case.
"
" Modified 740829 by PG to treat index register 3 as an unsigned word offset.
" Modified 790125 by PG to change calling sequence as part of fix to bug 360
"	(or-scan and and-scan of Booleans fail because reduction and scan called
"	this subroutine differently).
" Modified 790717 by PG to use DFSTR instead of DFST when it became clear that
"	this subroutine actually uses the over-length EAQ in a reasonable
"	fashion, and that we should keep as many bits as possible.
" Modified 790727 by PG to implement 0-:0 ==> 1 special-case in divide-reduction,
"	so that this routine can be called once again for divide-reduction.

	name	apl_reduction_appendage_
	segdef	apl_reduction_appendage_
	segdef	divide
	equ	array_ptr,2		ptr to operand array
	equ	column_base,4		subscript (0 origin) of lowest element
	equ	highest_element,6		subscript (0 origin) of highest element
	equ	interval_between_elements,8	number of elements in between each element
	equ	operation,10		operator code
	equ	result,12			place to store result
	equ	zerodivide_label,14		label to goto for zerodivide (-:/ only)
"
apl_reduction_appendage_:
divide:
	eppbp	ap|array_ptr,*		get ptr to ptr to array
	eppbp	bp|0,*			get ptr to array
	lxl0	ap|operation,*		get op1 (operator code for operation to do)
	ldq	ap|column_base,*		get first element
	qls	1			form word offset
	eawpbp	bp|0,ql			form ptr to first element
	ldq	ap|highest_element,*	get last element
	sbq	ap|column_base,*		compare to first element
	tze	return_last_element		only that one element... just return it
	qls	1			conv to word offset of last element in array
	eax2	0,ql			..
	lda	ap|interval_between_elements,*	find separation between elements
	als	1			change to separation in words
	neg	0			negate so eax2 bb|0,x3 will subtract from x2
	eawpbb	0,al			put into bb for subtraction from x2
	eax1	0,al			just save in x1
	dfld	bp|0,x2			get last element
	eppbp	bp|0,x1			move back by 1 element separation
	cmpx1	-2,du			separation 1 (i.e., vector)?
	tze	offset_is_one		can special case very fast
	tra	simple_transfer,x0		go to transfer vector for operation
"
simple_transfer:
	tra	simple_plus
	tra	simple_minus
	tra	simple_multiply
	tra	simple_divide
	tra	simple_max
	tra	simple_min
	arg	0
	arg	0
	arg	0
	arg	0
	arg	0
	tra	simple_and
	tra	simple_or
	tra	simple_nand
	tra	simple_nor

"following code is reached if interval between elements is 1 (i.e., two words)

offset_is_one:
	eax3	0,x2			save
	anx2	7,du			keep only those over mod 4 boundary of elements
	anx3	=o777770,du		get rid of number > mod 4 elements
	tze	simple_transfer,x0		amount is < 4 elements, no special case
	epplb	bp|0,x2			get ptr to subarray which is mod 4 elements long
	tra	*+1,x0			go to transfer vector for special case
	tra	group_plus
	tra	group_minus
	tra	group_multiply
	tra	group_divide
	tra	group_max
	tra	group_min
	arg	0
	arg	0
	arg	0
	arg	0
	arg	0
	tra	group_and
	tra	group_or
	tra	group_nand
	tra	group_nor

"simple routines that do one element at a loop iteration

simple_plus:
	dfad	bp|0,x2			add next lower element to sum
	eax2	bb|0,x2			subtract from x2 interval_between_elements
	tnz	simple_plus		more to do?
	tra	return_result		store result and go away

simple_minus:
	dfsb	bp|0,x2			subtract next lower from amount accumulated
	fneg	0			negate, because of kludgy way -/ works
	eax2	bb|0,x2			go down to next element
	tnz	simple_minus		more left?
	tra	return_result

simple_multiply:
	dfmp	bp|0,x2			multiply next lower element to product
	eax2	bb|0,x2			subtract from x2 interval_between_elements
	tnz	simple_multiply		more to do?
	tra	return_result		store result and go away

simple_divide:
	fad	=0e0,du			is divisor zero? (set indicators)
	tnz	5,ic			no, branch
	dfcmp	bp|0,x2			is dividend zero?
	tnz	zerodivide		no, branch
	fld	=1e0,du			map 0-:0 into 1
	tra	2,ic
	dfdi	bp|0,x2			quotient is next-:last_quotient
	eax2	bb|0,x2			go down to next element
	tnz	simple_divide		more left?
	tra	return_result

simple_max:
	dfcmp	bp|0,x2			compare to next lower element
	tpnz	2,ic			greater, not interested in this element
	dfld	bp|0,x2			get it
	eax2	bb|0,x2			next lower
	tnz	simple_max		more to do
	tra	return_result

simple_min:
	dfcmp	bp|0,x2			compare to next lower element
	tmi	2,ic			less, not interested in this element
	dfld	bp|0,x2			get it
	eax2	bb|0,x2			next lower
	tnz	simple_min		more to do
	tra	return_result

simple_and:
	fcmp	=0e0,du			is last element zero?
	tze	return_result		yes... return 0 which is in eaq
simple_and_loop:
simple_or_loop:
	dfcmp	bp|0,x2			compare to next element
	tnz	invert_and_return
	eax2	bb|0,x2			reduce x2 to next element
	tnz	simple_and_loop		do next element
	tra	return_result

simple_or:
	fcmp	=1e0,du			is last element one?
	tze	return_result		yes... return 1 which is in eaq
	tra	simple_or_loop

invert_and_return:
	fsb	=1e0,du			invert by subtracting 1
	fneg	0			then reverse
	tra	return_result

simple_nand:
	eax1	1			indicate want 1 if unequal operands
	dfcmp	bp|0,x2			compare with next element
	tze	invert_ac
	fld	zero_or_one,1		load a 1 if nand, 0 if nor
	eax2	bb|0,x2			reduce to next element
	tnz	simple_nand+1		go back
	tra	return_result

invert_ac:
	fsb	=1e0,du			invert by subtracting 1
	fneg	0			and then reversing
	eax2	bb|0,x2
	tnz	simple_nand+1
	tra	return_result

simple_nor:
	eax1	0			zero to specify will load 0 on unequal operands
	tra	simple_nand+1

"follows operators done in groups of 4 to reduce loop control overhead

group_plus:
	dfad	lb|0,x3
	dfad	lb|-2,x3
	dfad	lb|-4,x3
	dfad	lb|-6,x3
	sblx3	8,du			go down 4 elements
	tnz	group_plus		go back if more to do
	tra	see_whats_left		more to do

group_minus:
	dfsb	lb|0,x3
	fneg	0
	dfsb	lb|-2,x3
	fneg	0
	dfsb	lb|-4,x3
	fneg	0
	dfsb	lb|-6,x3
	fneg	0
	sblx3	8,du			go down 4 elements
	tnz	group_minus		go back if more to do
	tra	see_whats_left		more to do

group_multiply:
	dfmp	lb|0,x3
	dfmp	lb|-2,x3
	dfmp	lb|-4,x3
	dfmp	lb|-6,x3
	sblx3	8,du			go down 4 elements
	tnz	group_multiply		go back if more to do
	tra	see_whats_left		more to do

group_divide:
	fad	=0e0,du			is divisor zero? (set indicators)
	tnz	5,ic			no, branch to dfdi
	dfcmp	lb|0,x3			is dividend zero?
	tnz	zerodivide		no, branch
	fld	=1e0,du			map 0-:0 into 1
	tra	7,ic			branch to next dfdi
	dfdi	lb|0,x3			compute this quotient--next divisor
	tnz	5,ic			divisor 0? -- no, branch to dfdi
	dfcmp	lb|-2,x3			is dividend zero?
	tnz	zerodivide		no, branch
	fld	=1e0,du			map 0-:0 into 1
	tra	7,ic
	dfdi	lb|-2,x3			compute this quotient--next divisor
	tnz	5,ic			divisor 0? -- no, branch to dfdi
	dfcmp	lb|-4,x3			is dividend zero?
	tnz	zerodivide		no, branch
	fld	=1e0,du			map 0-:0 into 1
	tra	7,ic
	dfdi	lb|-4,x3			compute this quotient--next divisor
	tnz	5,ic			divisor 0? -- no, branch to dfdi
	dfcmp	lb|-6,x3			is dividend zero?
	tnz	zerodivide		no, branch
	fld	=1e0,du			map 0-:0 into 1
	tra	2,ic
	dfdi	lb|-6,x3			compute this quotient--next divisor
	sblx3	8,du			go down 4 elements
	tnz	group_divide		go back if more to do
	tra	see_whats_left		more to do

group_max:
	dfcmp	lb|0,x3
	tpl	2,ic
	dfld	lb|0,x3
	dfcmp	lb|-2,x3
	tpl	2,ic
	dfld	lb|-2,x3
	dfcmp	lb|-4,x3
	tpl	2,ic
	dfld	lb|-4,x3
	dfcmp	lb|-6,x3
	tpl	2,ic
	dfld	lb|-6,x3
	sblx3	8,du			go down 4 elements
	tnz	group_max			go back if more to do
	tra	see_whats_left		more to do

group_min:
	dfcmp	lb|0,x3
	tmi	2,ic
	dfld	lb|0,x3
	dfcmp	lb|-2,x3
	tmi	2,ic
	dfld	lb|-2,x3
	dfcmp	lb|-4,x3
	tmi	2,ic
	dfld	lb|-4,x3
	dfcmp	lb|-6,x3
	tmi	2,ic
	dfld	lb|-6,x3
	sblx3	8,du			go down 4 elements
	tnz	group_min			go back if more to do
	tra	see_whats_left		more to do

group_and:
	fcmp	=0e0,du			already 0, return zero
	tze	return_result

group_and_loop:
	dfcmp	lb|0,x3
	tnz	invert_and_return
	dfcmp	lb|-2,x3			compare to next element
	tnz	invert_and_return
	dfcmp	lb|-4,x3			compare to next element
	tnz	invert_and_return
	dfcmp	lb|-6,x3			compare to next element
	tnz	invert_and_return
	sblx3	8,du			go down 4 elements
	tnz	group_and_loop		go back if more to do
	tra	see_whats_left		more to do

group_or:
	fcmp	=1e0,du			if already 1, return it
	tze	return_result
	tra	group_and_loop

group_nand:
	eax1	1			indicate want to load 1 when unequal

group_nand1:
	dfcmp	lb|0,x3			compare previous result with next element
	tze	invert_ac_group1		if equal, invert previous result
	fld	zero_or_one,1		load 0 if nor, 1 if nand
group_nand2:
	dfcmp	lb|-2,x3			compare previous result with next element
	tze	invert_ac_group2		if equal, invert previous result
	fld	zero_or_one,1		load 0 if nor, 1 if nand
group_nand3:
	dfcmp	lb|-4,x3			compare previous result with next element
	tze	invert_ac_group3		if equal, invert previous result
	fld	zero_or_one,1		load 0 if nor, 1 if nand
group_nand4:
	dfcmp	lb|-6,x3			compare previous result with next element
	tze	invert_ac_group4		if equal, invert previous result
	fld	zero_or_one,1		load 0 if nor, 1 if nand
	sblx3	8,du			go down 4 elements
	tnz	group_and			go back if more to do
	tra	see_whats_left		more to do

invert_ac_group1:
	fsb	=1e0,du			invert
	fneg	0
	tra	group_nand1

invert_ac_group2:
	fsb	=1e0,du			invert
	fneg	0
	tra	group_nand2

invert_ac_group3:
	fsb	=1e0,du			invert
	fneg	0
	tra	group_nand3

invert_ac_group4:
	fsb	=1e0,du			invert
	fneg	0
	tra	group_nand4

group_nor:
	eax0	0			indicate will load zero if unequal operands
	tra	group_nand1

zero_or_one:
	oct	400000000000
	oct	002400000000
return_last_element:
	dfld	bp|0
	tra	return_result

see_whats_left:				"any left after doing those mod 4?
	cmpx2	0,du			see if zero
	tnz	simple_transfer,x0		no, do operation

return_result:				"place to return result
	dfstr	ap|result,*		store into arg, rounding for accuracy
	short_return

zerodivide:
	eppbp	ap|zerodivide_label,*	get ptr to label
	eppbp	bp|0,*			load label.codeptr
	spribp	sp|stack_frame.return_ptr	change return location (alternate return!)
	short_return
"
	include	stack_frame
	end




		    apl_reverse_.pl1                11/29/83  1638.6r w 11/29/83  1347.1       56250



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

apl_reverse_:
	procedure (operators_argument);

/*
 * apl_reverse_ performs the monadic o| operator
 *
 * written 7/28/73 by DAM
 * modified 2/2/74 by G. Gordon Benedict to handle a scalar, and to optimize inner loop
   Modified 780211 by PG to fix bug 278 by calling apl_push_stack_.
 */

/* automatic */

dcl right_vb pointer,				/* -> value_bead of operand */
    right pointer,					/* -> value array of operand */
    characters bit(1),				/* "1"b if operand is character, "0"b if numeric */
    rhorho fixed bin,				/* rhorho of operand and result */
    data_elements fixed bin(21),			/* size in elements of operand and result */
    coord fixed bin,				/* dimension along which to reverse */
    rev_rho fixed bin(21),				/* extent along that dimension */
    result_vb pointer,				/* -> value_bead of result */
    result pointer,					/* -> value array of result */
    n_words fixed bin(19),				/* size of result in words */
    i fixed bin,					/* random do-loop index */
    middle_adj_minus_middle fixed bin (21),		/* factored from inner loop */
    inner_upper_bound fixed bin (21),				/* upper bound of inner loop */
    innersize fixed bin(21),				/* times reduction of rho to right of coord, exclusive */
    middlesize fixed bin(21),				/* ditto, inclusive */
    middle_adj fixed bin(21),				/* correct adjustment to find reflected position of (middle)
						   is (middle_adj-middle) */
    midpoint fixed bin(21),				/* halfway along coord */
    (outer, middle, inner) fixed bin(21),		/* three do-loop indices for going through operand and
						   result and doing the reverse */
    apl_number float,				/* numeric temp */
    apl_character char(1);				/* character temp */

/* builtins */

declare	(addr, addrel, divide, fixed, rel, size, string, substr, unspec) builtin;

/* external static */

dcl (apl_error_table_$rank,
     apl_error_table_$domain,
     apl_error_table_$operator_subscript_range,
     apl_error_table_$length) fixed bin(35) external;

/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_operators_argument;
%include apl_bead_format;
%include apl_value_bead;
%include apl_operator_bead;

/* program */

	right_vb = operands(2).value;
	right = right_vb -> value_bead.data_pointer;
	characters = right_vb -> value_bead.data_type.character_value;

	rhorho = right_vb -> value_bead.rhorho;
	data_elements = right_vb -> value_bead.total_data_elements;
	coord = operators_argument.dimension;
	if rhorho = 0 then do;		/* scalar -- coord can be 0 or 1 */
	     if coord > 1 then goto rank_error;	/* rank in subscript brackets too large */
	end;
	else do;
	     if coord > rhorho then go to rank_error;
	     rev_rho = right_vb -> value_bead.rho(coord);
	end;

/* if on stack, do in place.  Otherwise allocate result on stack */

	if operators_argument.operands (2).on_stack
	then do;
		result_vb = right_vb;
		result = right;
	     end;
	else do;
		number_of_dimensions = rhorho;
		n_words = size(value_bead);
		if characters then n_words = n_words + size(character_string_overlay);
		else n_words = n_words + (size(numeric_datum) + 1);
		result_vb = apl_push_stack_ (n_words);

		string(result_vb -> value_bead.type) = string(right_vb -> value_bead.type);
		result_vb -> value_bead.total_data_elements = data_elements;
		result_vb -> value_bead.rhorho = rhorho;
		if rhorho > 0 then		/* avoid silly IPR for zero length move */
		     unspec(result_vb -> value_bead.rho(*)) = unspec(right_vb -> value_bead.rho(*));

		result = addr(result_vb -> value_bead.rho(rhorho+1));
		if ^ characters then if substr(rel(result), 18, 1) then result = addrel(result, 1);
		result_vb -> value_bead.data_pointer = result;
	     end;


	operators_argument.result = result_vb;

/* if we have a scalar or one-element matrix (of any dimension) just return it */

	if data_elements = 1 then do;	/* effective scalar */
	     if operators_argument.operands (2).on_stack then return;	/* already there */
	     result -> numeric_datum (0) =
		right -> numeric_datum (0);	/* copy scalar from argument to result */
	     return;
	end;

	if data_elements = 0 then return;	/* null vector, nothing to do */

/* set up do-loop parameters */

	innersize = 1;
	do i = coord by 1 while (i < rhorho);
	   innersize = innersize * (result_vb -> value_bead.rho(i+1));
	   end;
	middlesize = innersize * rev_rho;
	middle_adj = middlesize - innersize;
	midpoint = innersize * divide(rev_rho+1, 2, 21, 0);

/* now perform the actual reverse operation */
/* this code works whether the operation is being done in place or
   by copying from a bead onto the stack, but for different reasons in
   the two cases. */

	do outer = 0 by middlesize while (outer < data_elements);

	   inner_upper_bound = outer + innersize;		/* set upper bound of next loop */

	   do middle = 0 by innersize while (middle < midpoint);

	      middle_adj_minus_middle = middle_adj - middle;	/* just factor from loop below */

	      do inner = outer by 1 while (inner < inner_upper_bound);

		if ^ characters then do;		/* exchange two numbers */
		   apl_number = right -> numeric_datum(inner+middle);
		   result -> numeric_datum(inner+middle) = right -> numeric_datum(inner+middle_adj_minus_middle);
		   result -> numeric_datum(inner+middle_adj_minus_middle) = apl_number;
		   end;
		else do;				/* exchange two characters */
		   apl_character = right -> character_datum(inner+middle);
		   result -> character_datum(inner+middle) = right -> character_datum(inner+middle_adj_minus_middle);
		   result -> character_datum(inner+middle_adj_minus_middle) = apl_character;

		end;
	      end;
	   end;
	end;

	return;

rank_error:
	operators_argument.error_code = apl_error_table_$operator_subscript_range;
	return;

%include apl_push_stack_fcn;
     end /* apl_reverse_ */;




		    apl_rho_appendage_.alm          11/29/83  1638.6r w 11/29/83  1347.1       39429



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


" This module does the actual replication work of the dyadic rho operator.
" The caller passes 3 arguments.  The first is the value bead of the right argument to the
" dyadic rho (for the operand to be replicated).  The second is the value bead of the result,
" with all fields filled.  The third is an array of words (currently only 2 are used) for
" temporary scratch storage for my use.  This avoids a push. The basic algorithm is
" as follows.  If the type field of the result bead indicates a numeric operand the lengths
" of the argument and result arrays are multiplied by 8 (the number of characters
" per doubleword float).  If the arg length is 1, an MVT instruction with a one-character
" translation table is used.  Otherwise, copies of the argument are moved into
" the result field until either the result is filled or until
" 32 chars are created. If 32 chars are created first, with more left to do, an
" overlapping MLR instruction is used to fill the rest.
" See BN-86A-2 (GMAP manual), page 8-31, which says four-double words is the 
" minimum winning overlapping MLR size. (for no particular reason we use 5 double-words as the cutoff).
"
"	a	number of chars done already
"	q	number of chars in argument
"	x4	type field of result, used merely for testing
"	pr1	points to scratch storage passed from caller
"	pr2	points to right arg in copy loop, beginning of result in overlap code
"	pr3	points to result array
"	pr4	points to result value bead
"	pr5	points to argument value bead
"
"
"	Created by G. Gordon Benedict on Jan 23, 1974
"	Modified 741015 by PG to use MVT instruction to replicate a single character.
"	Modified 741101 by PG to fix bug introduced by GGB, and improve code.

	segdef	apl_rho_appendage_


	equ	dupl_vb,2			ptr to value bead for arg to duplicate
	equ	result_vb,4		ptr to value bead for result arg
	equ	automatic_storage,6		offset in args of temp storage from caller

	include	apl_value_bead

	equ	no_arg_chars,0		no. chars in arg
	equ	no_to_create,1		no. chars in result

apl_rho_appendage_:
	epp5	pr0|dupl_vb,*		get pointer to value bead to arg
	epp4	pr0|result_vb,*		get pointer to value bead to result
	epp1	pr0|automatic_storage,*	ptr to scratch space from caller

	lprp2	pr5|value_bead.data_pointer	get pointer to data array from arg v.b.
	lprp3	pr4|value_bead.data_pointer	same for result
	ldx4	pr4|value_bead.header.type	get type of result
	lda	pr4|value_bead.total_data_elements	get no. of elements in result
	tze	return		wants null string, has it.

	ldq	pr5|value_bead.total_data_elements	get number of elements in arg
	canx4	=o400,du		is it char?
	tnz	2,ic		yes
	lls	3		times 8 (# chars/double float)
	sta	pr1|no_to_create	number of chars to create
	stq	pr1|no_arg_chars	number of chars in input arg
	cmpq	1,dl		if arg length is 1, can special case
	tnz	long_case		use general code.

	mvt	(),(pr,rl),fill(000)	move fill char
	arg	0		(because no source chars)
	desc9a	pr3|0,al		into target
	arg	pr2|0		translate table is input arg of 1 char.
	short_return		all done.

long_case:
	cmpa	pr1|no_arg_chars	if asking for less than already have,
	tpl	3,ic		move only number needed.
	sta	pr1|no_arg_chars	update stored value
	ldq	pr1|no_arg_chars	and copy in register
	lda	0,dl		have done 0 chars so far.
"				Q has no_arg_chars.

duplicate:
	cmpa	pr1|no_to_create	up to limit?
	tpl	return		yes.
	mlr	(pr,rl),(pr,rl,al),fill(000)	move one chunk of no_arg_chars
	desc9a	pr2|0,ql		from source
	desc9a	pr3|0,ql		to target
	ada	pr1|no_arg_chars	update offset
	cmpa	40,dl		moved 5 double words yet?
	tmi	duplicate		nope, keep going.

	lprp2	pr4|value_bead.data_pointer	reset for overlapping mlr.
	ssa	pr1|no_to_create	compute remaining # to move.
	lcq	pr1|no_to_create	get in q.
	tmoz	return		done.
	mlr	(pr,rl),(pr,rl,al),fill(000)	move remainder..overlapped!
	desc9a	pr2|0,ql		source is now base of target itself
	desc9a	pr3|0,ql		to target.

return:
	short_return
	end




		    apl_rotate_.pl1                 11/29/83  1638.6r w 11/29/83  1347.1      103797



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

/*
 * apl_rotate_ implements the dyadic o| operator
 *
 * Written 7/28/73 by DAM
 * Modified 740909 by PG for new value bead declaration, and correct handling of value stack and error marker.
   Modified 780211 by PG to fix 278 (apl_push_stack_) and 230 (can't rotate a scalar).
   Modified 781004 by Willaim York to fix 342 (not poping left arg).
   Modified 800313 by PG to fix 460 (rotate fails if left arg is on stack, and left arg is longer than result,
	because left_numbers array gets overlayed on original left operand, and copy fails).
 */

/* format: style3 */
apl_rotate_:
     procedure (operators_argument);

/* process left operand - always numeric */

	left_vb = operands (1).value;
	if ^(left_vb -> value_bead.data_type.numeric_value)
	then go to domain_error_left;
	left = left_vb -> value_bead.data_pointer;

/* process right operand - character or numeric */

	right_vb = operands (2).value;
	right = right_vb -> value_bead.data_pointer;
	characters = right_vb -> value_bead.data_type.character_value;
	rhorho = right_vb -> value_bead.rhorho;
	data_elements = right_vb -> value_bead.total_data_elements;

	coord = operators_argument.dimension;
	if coord > rhorho
	then go to rank_error;

/* determine conformability */

	if left_vb -> value_bead.total_data_elements = 1	/* extend scalar */
	then left_scalar_fudge = 0;
	else if left_vb -> value_bead.rhorho ^= rhorho - 1
	then go to rank_error_left;
	else do;
		left_scalar_fudge = 1;		/* left opnd must have same dimensions as right, except coord */
		do i = 1 by 1 while (i < coord);
		     if left_vb -> value_bead.rho (i) ^= right_vb -> value_bead.rho (i)
		     then go to length_error_left;
		end;

		do i = coord + 1 by 1 while (i <= rhorho);
		     if left_vb -> value_bead.rho (i - 1) ^= right_vb -> value_bead.rho (i)
		     then go to length_error_left;
		end;
	     end;

	left_is_integer = left_vb -> value_bead.data_type.integral_value;
	integer_fuzz = ws_info.integer_fuzz;

	if rhorho > 0
	then temp_row_length = right_vb -> value_bead.rho (coord);
	else temp_row_length = 1;			/* scalar case */

	if operands (2).on_stack
	then do;

/* doing it in place.  allocate a temporary to hold one row while it is being rotated */

		if characters
		then n_words = size (temp_chars_row);
		else n_words = size (temp_nums_row);
		save_vsp = ws_info.value_stack_ptr;
		temp_row_ptr = apl_push_stack_ (n_words);
		ws_info.value_stack_ptr = save_vsp;

		in_place = "1"b;
		result_vb = right_vb;
		result = right;

		if operands (1).on_stack
		then ws_info.value_stack_ptr = left_vb;
	     end;
	else do;

/* doing it by copy from heap to stack.  allocate space on stack for result and temp_row needed
   if not rotating last dimension.  in order to allocate space, first move left operand out of the way */

/* Compute size of result. */

		number_of_dimensions = rhorho;
		n_words = size (value_bead);

		if characters
		then n_words = n_words + size (character_string_overlay);
		else n_words = n_words + size (numeric_datum) + 1;

/* If the left argument is on the stack, reallocate it so that it is higher
   than both the result bead and the old copy of itself. (Can't overlap either) */

		if operators_argument.operands (1).on_stack
		then do;
			ws_info.value_stack_ptr = left_vb;
						/* pop left operand */

			left_data_elements = left_vb -> value_bead.total_data_elements;
			n_words_left_vb = currentsize (left_vb -> value_bead) + size (left_numeric_datum) + 1;
		     end;
		else n_words_left_vb = 0;

		result_vb = apl_push_stack_ (max (n_words, n_words_left_vb));

		save_vsp = ws_info.value_stack_ptr;	/* This is the only thing to protect */

		result = addr (result_vb -> value_bead.rho (rhorho + 1));

		if ^characters
		then if substr (rel (result), 18, 1)
		     then result = addrel (result, 1);

		if coord ^= rhorho
		then do;
			if characters
			then n_words = size (temp_chars_row);
			else n_words = size (temp_nums_row);

			temp_row_ptr = apl_push_stack_ (n_words);
		     end;

		if operands (1).on_stack
		then do;
			n_words = size (left_numbers);

			next_p = apl_push_stack_ (n_words);
			next_p -> left_numbers (*) = left -> left_numbers (*);
			left = next_p;
		     end;

		ws_info.value_stack_ptr = save_vsp;	/* forget previous stuff */

		string (result_vb -> value_bead.type) = string (right_vb -> value_bead.type);
		result_vb -> value_bead.data_pointer = result;
		result_vb -> value_bead.total_data_elements = data_elements;
		result_vb -> value_bead.rhorho = rhorho;

		if rhorho ^= 0
		then unspec (result_vb -> value_bead.rho (*)) = unspec (right_vb -> value_bead.rho (*));

		in_place = "0"b;

	     end;

	operators_argument.result = result_vb;		/* since we have carefully arranged for this to be at bottom
						   of stack, never have to move it down */

/* compute do-loop parameters */

	innersize = 1;
	do i = coord by 1 while (i < rhorho);
	     innersize = innersize * right_vb -> value_bead.rho (i + 1);
	end;

	if rhorho > 0
	then if right_vb -> value_bead.rho (coord) ^= 0
	     then left_outersize = divide (data_elements, right_vb -> value_bead.rho (coord), 21, 0);
	     else left_outersize = 0;
	else left_outersize = 1;			/* scalar case */

/* do the actual operation */

	do left_outer = 0 by innersize while (left_outer < left_outersize);
	     right_outer = left_outer * temp_row_length;
	     do inner = 0 by 1 while (inner < innersize);

		if left_is_integer
		then rotation = fixed (left -> numeric_datum ((left_outer + inner) * left_scalar_fudge));
		else do;
			float_rot = floor (left -> numeric_datum ((left_outer + inner) * left_scalar_fudge) + 0.5);
			if abs (float_rot - left -> numeric_datum ((left_outer + inner) * left_scalar_fudge))
			     > integer_fuzz
			then go to domain_error_left;
			if abs (float_rot) >= 1e21b
			then go to domain_error_left;
			rotation = float_rot;
		     end;
		rotation = mod (rotation, temp_row_length);

		if rotation = 0
		then if in_place
		     then go to nugatory;

		if ^in_place
		then if coord = rhorho
		     then do;			/* temp_xxx_row overlayed on operand */
			     if characters
			     then temp_row_ptr = addr (right -> character_datum (right_outer + inner));
			     else temp_row_ptr = addr (right -> numeric_datum (right_outer + inner));
			     go to so_rotate;
			end;

		if characters
		then do temp_row_idx = 0 by 1 while (temp_row_idx < temp_row_length);
			temp_chars_row (temp_row_idx) =
			     right -> character_datum (temp_row_idx * innersize + right_outer + inner);
		     end;
		else do temp_row_idx = 0 by 1 while (temp_row_idx < temp_row_length);
			temp_nums_row (temp_row_idx) =
			     right -> numeric_datum (temp_row_idx * innersize + right_outer + inner);
		     end;

/* now move the temp_xxx_row into the result, with rotation */

so_rotate:
		do i = 0 by 1 to temp_row_length - rotation - 1;
		     if characters
		     then result -> character_datum (i * innersize + right_outer + inner) = temp_chars_row (i + rotation);
		     else result -> numeric_datum (i * innersize + right_outer + inner) = temp_nums_row (i + rotation);
		end;
		do j = i by 1 while (j < temp_row_length);
		     if characters
		     then result -> character_datum (j * innersize + right_outer + inner) = temp_chars_row (j - i);
		     else result -> numeric_datum (j * innersize + right_outer + inner) = temp_nums_row (j - i);
		end;
nugatory:
	     end;
	end;

	return;




domain_error_left:
	operators_argument.error_code = apl_error_table_$domain;
	go to mark_left;

length_error_left:
	operators_argument.error_code = apl_error_table_$length;
	go to mark_left;

rank_error_left:
	operators_argument.error_code = apl_error_table_$rank;
mark_left:
	operators_argument.where_error = operators_argument.where_error + 1;
	return;

rank_error:
	operators_argument.error_code = apl_error_table_$operator_subscript_range;
	return;

%include apl_push_stack_fcn;

/* automatic */

dcl	left_vb		pointer,			/* -> value bead of left operand */
	left		pointer,			/* -> value array of left operand, may have got moved in stack */
	next_p		pointer,			/* random pointer */
	rhorho		fixed bin,		/* rhorho of right operand and result */
	right_vb		pointer,			/* -> value_bead of right opnd */
	right		pointer,			/* -> value array of right operand */
	save_vsp		ptr,			/* used to pop temps off value stack */
	characters	bit (1),			/* "1"b if right opnd and result are character, "0"b if numeric */
	data_elements	fixed bin (21),		/* size in elements of roght operand, result */
	coord		fixed bin,		/* the dimension of the rows to be rowtated */
	left_scalar_fudge	fixed bin,		/* horrible kludge: 0 if left arg is scalar, 1 if not.
						   used to hack the subscript calculation so extension
						   of scalar left arguments works correctly */
	(i, j)		fixed bin,		/* random do-loop indices */
	left_is_integer	bit (1),			/* copy of left_vb->value_bead.integral_value, for eff. */
	integer_fuzz	float,			/* copy of the fuzz, also for eff. */
	temp_row_length	fixed bin (21),		/* length of a row being rhotated, also of others dcl'ed below */
	temp_row_ptr	pointer,
	n_words		fixed bin (19),		/* size in words of amount of space needed in stack */
	result_vb		pointer,			/* -> value_bead for result */
	result		pointer,			/* -> value array for result */
	in_place		bit (1),			/* "1"b => result overlays right opnd, "0"b => it doesn't */
	innersize		fixed bin (21),		/* times reduction of rho of opnd|result after coord */
	left_outersize	fixed bin (21),		/* number of things in (expnaded if scalar) left argument */
	left_outer	fixed bin (21),		/* part of subscript into left operand for rotate amount */
	right_outer	fixed bin (21),		/* part of subscript into right operand for row to mung */
	inner		fixed bin (21),		/* portion of subscript derived from rho to right of coord */
	rotation		fixed bin (21),		/* amount by which this row is to be munged */
	float_rot		float,
	temp_row_idx	fixed bin (21),		/* do-loop index for moving disconnected arrays (rows) into
						   the temp_row */
	left_data_elements	fixed bin (21),		/* used in stack alloc calculation */
	n_words_left_vb	fixed bin (19);		/* .. */

/* based */

dcl	temp_chars_row	(0:temp_row_length - 1) char (1) unal based (temp_row_ptr),
						/* _m_u_s_t be unal for hack with coord=rhorho */
	temp_nums_row	(0:temp_row_length - 1) float aligned based (temp_row_ptr),
						/* these two arrays are used to hold
						a row being rotated, to avoid in-place overlay problems */
	left_numbers	(left_vb -> value_bead.total_data_elements) float aligned based,
	left_numeric_datum	(left_data_elements) float aligned based;

/* external static */

dcl	(
	apl_error_table_$domain,
	apl_error_table_$rank,
	apl_error_table_$length,
	apl_error_table_$operator_subscript_range
	)		fixed bin (35) external;

/* builtins */

dcl	(abs, addr, addrel, currentsize, divide, max, mod, rel, substr, size, string, unspec, fixed, floor)
			builtin;

/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_operators_argument;
%include apl_bead_format;
%include apl_value_bead;
     end apl_rotate_;




		    apl_save_command_.pl1           11/29/83  1638.6r w 11/29/83  1347.2      275454



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

/* Program to )SAVE an APL workspace.
   R. Lamson and P. Green, August 1973.

   Modified for Version 3 saved workspace by PG on 12/04/73
   Modified 740624 by PG to fix saving of boolean values and size of saved numeric value beads.
   Modified 741016 by PG to fix bugs 178 (throwing away old ws before quota calc), 176 (checking
	for write permission), and 173 (catching no_dir code from apl_translate_pathname_).
   Modified 741108 by PG for saving function frames correctly, printing a better "not enough quota" message,
	and adding error check to translate_pointer.
   Modified 761011 by PG for new parse_frame declaration, and to save version 4 workspaces.
   Modified 780104 by PG to fix bug 300 (truncating old ws too soon).
*/

apl_save_command_:
	procedure (a_wsid, a_lock, a_code);

	a_code = 0;

	if a_wsid = ""
	then wsid = ws_info.wsid;
	else wsid = a_wsid;

	if a_lock = ""
	then if wsid ^= ws_info.wsid
	     then lock = "";
	     else lock = ws_info.lock;
	else lock = a_lock;

	if wsid = "clear ws"
	then do;
bitch:
		call ioa_$ioa_stream (output_stream, "not saved, this ws is ^a", ws_info.wsid);
		a_code = apl_error_table_$cant_save_ws;
		return;
	     end;

	call apl_translate_pathname_ (wsid, dname, ename, fcbp, code);

	if code = 0		/* a zero code means that the ws already exists. */
	then if wsid ^= ws_info.wsid
	     then if wsid ^= "continue"
		then go to bitch;

	if code ^= 0
	then if code ^= error_table_$noentry		/* this one is ok - ws will be created. */
	     then do;
		     call com_err_ (code, "apl", "^a>^a", dname, ename);
		     a_code = code;
		     return;
		end;

	bead_table_pointer = apl_segment_manager_$get ();
	stack_frame_table_pointer = addrel (bead_table_pointer, 49152);

	saved_bead_count,
	max_component_number,
	current_segment_length,
	current_component_number = 0;

	current_pseudo_baseptr = baseptr (0);
	BeadBase = baseptr (0);

	on record_quota_overflow go to unwind_and_abort;
	on cleanup call cleaner_upper;

	call apl_create_save_frame_;

	n_words = size (saved_ws_info);
	call save_allocate;
	saved_ws_info_pseudo_pointer = save_pseudo_pointer;

	do bucket_number = 1 to symbol_table.table_size;

	     do symbol_bead_ptr = symbol_table.hash_bucket_ptr (bucket_number)
		repeat (symbol_bead_ptr -> symbol_bead.hash_link_pointer)
		while (symbol_bead_ptr ^= null);

		call save_bead (symbol_bead_ptr);
	     end;
	end;


	do symbol_number = 1 to saved_bead_count;
	     call save_bead (saved_bead_table (symbol_number).active_bead_pointer -> symbol_bead.meaning_pointer);
	end;

	call save_bead (ws_info.latent_expression);

	this_frame = 0;
	previous_frame_pointer = null;

	do parse_frame_ptr = ws_info.current_parse_frame_ptr
	   repeat (parse_frame_ptr -> parse_frame.last_parse_frame_ptr)
	   while (parse_frame_ptr ^= null);

		this_frame = this_frame + 1;

		if parse_frame.parse_frame_type = save_frame_type
		then do;

			total_symbols = parse_frame_ptr -> save_frame.saved_symbol_count;
			n_words = size (saved_sf);
			call save_allocate;
			saved_stack_frame_table (this_frame).active_frame_pointer = parse_frame_ptr;
			saved_stack_frame_table (this_frame).pseudo_pointer = save_pseudo_pointer;
			saved_stack_frame_table (this_frame).previous_pseudo_pointer = previous_frame_pointer;
			previous_frame_pointer = save_pseudo_pointer;

			do symbol_number = 1 to parse_frame_ptr -> save_frame.saved_symbol_count;
			     call save_bead (parse_frame_ptr -> save_frame.saved_meaning_pointer (symbol_number));
			end;

		     end;
		else do;		/* all parse frame types (save frame is not really a parse frame.) */

			if parse_frame.parse_frame_type = function_frame_type
			then do;
				call save_bead (parse_frame.function_bead_ptr);
				number_of_ptrs = parse_frame.lexed_function_bead_ptr ->
							lexed_function_bead.number_of_localized_symbols;
				n_words = size (saved_pf);
			     end;

			else if parse_frame.parse_frame_type = execute_frame_type
			     then do;
				     number_of_ptrs = 0;
				     n_words = size (saved_pf);
				end;
			     else do;
				     number_of_ptrs = divide(addr(parse_frame.old_meaning_ptrs(1)) ->
					suspended_source_length + 3, 4, 21, 0) + 1;
				     n_words = size (saved_pf);
				     number_of_ptrs = 0;
				end;

			call save_allocate;

			saved_stack_frame_table (this_frame).pseudo_pointer = save_pseudo_pointer;
			saved_stack_frame_table (this_frame).active_frame_pointer = parse_frame_ptr;
			saved_stack_frame_table (this_frame).previous_pseudo_pointer = previous_frame_pointer;
			previous_frame_pointer = save_pseudo_pointer;

			reduction_stack_size = parse_frame.current_parseme;
			n_words = reduction_stack_size * size (single_rs_element);
			call save_allocate;

			saved_stack_frame_table (this_frame).reduction_stack_pointer = save_pseudo_pointer;

			do symbol_number = 1 to number_of_ptrs;
			     call save_bead (parse_frame.old_meaning_ptrs (symbol_number));
			end;

			reductions_pointer = parse_frame.reduction_stack_ptr;

			do parseme = 1 to reduction_stack_size;
			     save_this_one = "0"b;

			     if reduction_stack (parseme).type = op_type
			     then if reduction_stack (parseme).function
				then save_this_one = "1"b;
				else if reduction_stack (parseme).has_list
				     then save_this_one = "1"b;
				     else;			/* rs_for_op */
			     else save_this_one = "1"b;

			     if save_this_one
			     then do;
				     if reduction_stack (parseme).semantics_valid
				     then if reduction_stack (parseme).semantics_on_stack
					then call save_bead_on_stack (reduction_stack (parseme).semantics);
					else call save_bead (reduction_stack (parseme).semantics);
				     else;
				end;
			end;
		     end;
	end;

	n_words = size (bead_description_table);
	call save_allocate;
	bead_description_pseudo_pointer = save_pseudo_pointer;

	segment_length (current_component_number) = current_segment_length;

	total_length = 0;

	do component = 0 to max_component_number;
	     total_length = total_length + divide (segment_length (component) + 1023, 1024, 18, 0);
	end;

	if max_component_number > 0
	then total_length = total_length + 2;

	/* Get pointers to, and check the access on, all workspace components. */

	old_workspace_length = 0;
	do component = 0 to max_component_number;
	     call msf_manager_$get_ptr (fcbp, component, "1"b, ws_segment (component), (0), code);
	     if ws_segment (component) = null
	     then do;
		     call com_err_ (code, "apl", "^a>^a", dname, ename);
		     go to return_code;
		end;
	     else do;
		     call hcs_$fs_get_path_name (ws_segment (component), directory, (0), entryname, code);

		     if code = 0
		     then call hcs_$status_ (directory, entryname, 1b, addr (branch), null, code);

		     if code ^= 0
		     then do;
			     call com_err_ (code, "apl", "^a>^a", dname, ename);
			     go to return_code;
			end;

		     if (bit (branch.mode, 5) & "01010"b) ^= "01010"b	/* don't have RW access */
		     then do;
			     call ioa_$ioa_stream (output_stream, "not saved, need rw access on entry.");
			     go to return_code;
			end;

		     old_workspace_length = old_workspace_length + branch.records;
		end;
	end;

	directory = dname;

calculate_remaining_quota:
	call hcs_$quota_get (directory, total_quota, (0), (""b), (0), terminal_account, quota_used, code);
	if code ^= 0
	then do;
		/* Make up some numbers. It's possible we just don't have status & modify permission to
		   the directory in which we're saving. We might still have append permission.
		   Our record_quota_overflow handler will save us. */

		code = 0;
		terminal_account = 1;
		total_quota = 1000000;
		quota_used = 0;
	     end;

	if terminal_account = 0
	then do;
		previous_greater_than_position = length (directory) - index (reverse (directory), ">");
		directory = substr (directory, 1, previous_greater_than_position);
		go to calculate_remaining_quota;
	     end;

	quota_used = quota_used - old_workspace_length;	/* Pretend we have truncated old workspace */
	quota_remaining = total_quota - quota_used;	/* Figure how much quota remains. */

	if quota_remaining < total_length		/* Does the new workspace fit? */
	then do;					/* No. */
		call ioa_$ioa_stream (output_stream, "can't save ^a (^d record^[^;s^]); need ^d more record^[^;s^]",
		     wsid, total_length, (total_length = 1), total_length - quota_remaining,
		     (total_length - quota_remaining = 1));
		go to return_code;
	     end;

	/* At this point we know we are going to save the workspace. But we don't truncate
	   the old workspace first because of the NSS-76 truncating rule...truncate after
	   write, not before, or you may get a segment full of zeros if a crash occurs after the
	   truncate but before the VTOC is updated to reflect the new pages. */

	/* Begin actual )save operation, now that we know we've got room. */

	saved_ws_info_pointer = un_pseudo_pointer (saved_ws_info_pseudo_pointer);
	bead_description_pointer = un_pseudo_pointer (bead_description_pseudo_pointer);

	saved_ws_info.save_version = current_save_version;
	saved_ws_info.highest_segment = max_component_number;
	saved_ws_info.bead_table_pointer = bead_description_pseudo_pointer;
	saved_ws_info.total_beads = saved_bead_count;

	saved_ws_info.digits = ws_info.digits;
	saved_ws_info.width = ws_info.width;
	saved_ws_info.index_origin = ws_info.index_origin;
	saved_ws_info.random_link = ws_info.random_link;
	saved_ws_info.fuzz = ws_info.fuzz;
	saved_ws_info.float_index_origin = ws_info.float_index_origin;
	saved_ws_info.number_of_symbols = ws_info.number_of_symbols;
	saved_ws_info.current_parse_frame_ptr = previous_frame_pointer;
	saved_ws_info.integer_fuzz = ws_info.integer_fuzz;
	saved_ws_info.user_number = ws_info.user_number;
	saved_ws_info.latent_expression = translate_pointer (ws_info.latent_expression);
	saved_ws_info.user_name = ws_info.user_name;

	saved_ws_info.lock = lock;
	ws_info.lock = lock;

	saved_ws_info.wsid = wsid;
	ws_info.wsid = wsid;

	do bead_number = 1 to saved_bead_count;

	     bead_pointer = saved_bead_table (bead_number).active_bead_pointer;
	     saved_bead_pointer = un_pseudo_pointer (saved_bead_table (bead_number).pseudo_pointer);
	     bead_description_table (bead_number).bead_pointer = saved_bead_table (bead_number).pseudo_pointer;

	     go to copy_bead (saved_bead_table (bead_number).bead_type);

copy_bead (1):		/* group bead */

		unspec (saved_general_bead) = unspec (bead_pointer -> general_bead);

		element_count,
		saved_gb.number_of_members = bead_pointer -> group_bead.number_of_members;

		do symbol_number = 1 to element_count;
		     saved_gb.member (symbol_number) =
		     translate_pointer (bead_pointer -> group_bead.member (symbol_number));
		end;

		go to next_bead;

copy_bead (2):		/* symbol bead */

		unspec (saved_general_bead) = unspec (bead_pointer -> general_bead);

		saved_sb.name_length = bead_pointer -> symbol_bead.name_length;

		saved_sb.name = bead_pointer -> symbol_bead.name;

		saved_sb.meaning_pointer = translate_pointer (bead_pointer -> symbol_bead.meaning_pointer);

		go to next_bead;

copy_bead (3):		/* function bead */

		unspec (saved_general_bead) = unspec (bead_pointer -> general_bead);

		saved_fb.class = bead_pointer -> function_bead.class;

		saved_fb.text_length = bead_pointer -> function_bead.text_length;

		saved_fb.text = bead_pointer -> function_bead.text;

		saved_fb.stop_control_pointer =
		translate_pointer (bead_pointer -> function_bead.stop_control_pointer);

		saved_fb.trace_control_pointer =
		translate_pointer (bead_pointer -> function_bead.trace_control_pointer);

		go to next_bead;

copy_bead (4):		/* list bead */

		unspec (saved_general_bead) = unspec (bead_pointer -> general_bead);

		element_count,
		saved_lb.number_of_members = bead_pointer -> list_bead.number_of_members;

		do member_number = 1 to element_count;
		     unspec (saved_lb.bits (member_number)) =
		     unspec (bead_pointer -> list_bead.bits (member_number));

		     saved_lb.member_ptr (member_number) =
		     translate_pointer (bead_pointer -> list_bead.member_ptr (member_number));
		end;

		go to next_bead;

copy_bead (5):		/* numeric value bead */

		call copy_value_bead_header;

		if data_elements ^= 0
		then do;
			copy_to_pointer -> numeric_datum (*) =
			copy_from_pointer -> numeric_datum (*);
		     end;

		go to next_bead;

copy_bead (6):		/* character value bead */

		call copy_value_bead_header;

		if data_elements ^= 0
		then copy_to_pointer -> character_string_overlay =
		     copy_from_pointer -> character_string_overlay;

		go to next_bead;

copy_bead (7):		/* boolean value bead */

		call copy_value_bead_header;

		copy_to_pointer -> saved_boolean_datum = ""b;

		do datum_number = 0 by 1 while (datum_number < data_elements);
		     if copy_from_pointer -> numeric_datum (datum_number) = 1e0
		     then substr (copy_to_pointer -> saved_boolean_datum, datum_number + 1, 1) = "1"b;
		end;
next_bead:
	end;

	do frame_number = 1 to this_frame;

	     parse_frame_ptr = saved_stack_frame_table (frame_number).active_frame_pointer;
	     saved_frame_pointer = un_pseudo_pointer (saved_stack_frame_table (frame_number).pseudo_pointer);

	     saved_pf.parse_frame_type = parse_frame.parse_frame_type;
	     saved_pf.last_parse_frame_ptr = saved_stack_frame_table (frame_number).previous_pseudo_pointer;

	     if parse_frame.parse_frame_type = save_frame_type
	     then do;
		     saved_sf.saved_symbol_count = parse_frame_ptr -> save_frame.saved_symbol_count;

		     do symbol_number = 1 to parse_frame_ptr -> save_frame.saved_symbol_count;
			saved_sf.symbol_pointer (symbol_number) =
			translate_pointer (parse_frame_ptr -> save_frame.symbol_pointer (symbol_number));

			saved_sf.saved_meaning_pointer (symbol_number) =
			translate_pointer (parse_frame_ptr -> save_frame.saved_meaning_pointer (symbol_number));
		     end;
		end;
	     else do;
		     saved_pf.current_parseme = parse_frame.current_parseme;
		     saved_pf.current_lexeme = parse_frame.current_lexeme;
		     saved_pf.current_line_number = parse_frame.current_line_number;
		     saved_pf.return_point = parse_frame.return_point;
		     saved_pf.put_result = parse_frame.put_result;
		     saved_pf.print_final_value = parse_frame.print_final_value;
		     saved_pf.number_of_ptrs = parse_frame.number_of_ptrs;

		     /* parse_frame.initial_value_stack_ptr will be re-created by load,
		        when it re-creates the value stacks, so it is not saved. */

		     go to copy_frame_header (parse_frame.parse_frame_type);

copy_frame_header (1):		/* suspended frame */
copy_frame_header (3):		/* evaluated frame */

		     source_length,
		     addr (saved_pf.old_meaning_ptrs (1)) -> suspended_source_length =
		     addr (parse_frame.old_meaning_ptrs (1)) -> suspended_source_length;

		     addr (saved_pf.old_meaning_ptrs (2)) -> suspended_source =
		     addr (parse_frame.old_meaning_ptrs (2)) -> suspended_source;

		     /* Tell load command whether or not to re-lex the source.
		     0=don't re-lex, 1=re-lex. */

		     if parse_frame.lexed_function_bead_ptr = null
		     then saved_pf.re_lex_source = "0"b;
		     else saved_pf.re_lex_source = "1"b;

		     go to copy_rest_of_frame;

copy_frame_header (2):		/* function  frame */

		     do symbol_number = 1 to parse_frame.lexed_function_bead_ptr ->
		        lexed_function_bead.number_of_localized_symbols;
			saved_pf.old_meaning_ptrs (symbol_number) =
			translate_pointer (parse_frame.old_meaning_ptrs (symbol_number));
		     end;
		     saved_pf.function_bead_ptr = translate_pointer (parse_frame.function_bead_ptr);

copy_frame_header (4):		/* execute   frame */
			/* We will copy the source for this frame in the next frame. */
copy_rest_of_frame:

		     saved_reductions_pointer =
			un_pseudo_pointer (saved_stack_frame_table (frame_number).reduction_stack_pointer);
		     reductions_pointer = parse_frame.reduction_stack_ptr;

		     do parseme_number = 1 to parse_frame.current_parseme;
			saved_rs (parseme_number).type,
			my_type = reduction_stack (parseme_number).type;
			copy_this_one = "0"b;

			if my_type = op_type
			then if reduction_stack (parseme_number).function
			     then copy_this_one = "1"b;
			     else if reduction_stack (parseme_number).has_list
				then copy_this_one = "1"b;
				else if reduction_stack (parseme_number).semantics_valid
				     then saved_rs_for_op (parseme_number).semantics =
					reduction_stack_for_op (parseme_number).semantics;
				     else;
			else copy_this_one = "1"b;

			if copy_this_one
			then do;
				if reduction_stack(parseme_number).semantics_valid
				then saved_rs (parseme_number).semantics
					= translate_pointer (reduction_stack(parseme_number).semantics);
			     end;

			unspec (saved_rs (parseme_number).bits) = unspec (reduction_stack (parseme_number).bits);

			saved_rs (parseme_number).lexeme = reduction_stack (parseme_number).lexeme;
		     end;
		end;
	end;

	current_time,
	saved_ws_info.time_saved = clock ();

	call msf_manager_$adjust (fcbp, max_component_number, 36 * segment_length (max_component_number),
	     "111"b /* set bc, truncate, terminate */, code);

	/* (we don't care about the code, since we can re-load it even if the bc is bad... */

	call cleaner_upper;

	if a_wsid = "" | a_wsid = "continue"
	then call ioa_$ioa_stream (output_stream, "saved  ^a ^a", apl_date_time_ (current_time), ws_info.wsid);
	else call ioa_$ioa_stream (output_stream, "saved  ^a", apl_date_time_ (current_time));

	return;

	/* Record quota overflow handler comes here. Clean up the mess and tell loser. */

unwind_and_abort:
	/* must delete partial saved ws here */
	call ioa_$ioa_stream(output_stream, "not saved, not enough quota");

return_code:
	call cleaner_upper;
	a_code = apl_error_table_$cant_save_ws;
	return;

cleaner_upper:
	procedure;

	do bead_number = 1 to saved_bead_count;

		if saved_bead_table (bead_number).active_bead_pointer -> general_bead.reference_count < 0
		then saved_bead_table (bead_number).active_bead_pointer -> general_bead.reference_count =
		     saved_bead_table (bead_number).active_reference_count;

	end;

	call apl_destroy_save_frame_;
	call apl_segment_manager_$free (bead_table_pointer);
	call msf_manager_$close (fcbp);

end cleaner_upper;

/* subroutine used by copy_bead loop to do just what it says... */

copy_value_bead_header:
	procedure;

	data_elements,
	saved_value_bead.total_data_elements = bead_pointer -> value_bead.total_data_elements;

	number_of_dimensions,
	saved_value_bead.rhorho = bead_pointer -> value_bead.rhorho;

	string (saved_general_bead.type) = string (bead_pointer -> general_bead.type);

	/* recompute size to eliminate counting the padding word, if any. apl_load_command_ will
	   always re-pad value beads by adding 1 to this saved size. */

	saved_general_bead.size = bit (add (size (value_bead), size (numeric_datum), 18, 0), 18);

	if saved_value_bead.rhorho ^= 0
	then saved_value_bead.rho (*) = bead_pointer -> value_bead.rho (*);

	copy_from_pointer = bead_pointer -> value_bead.data_pointer;

	copy_to_pointer = addr (saved_bead_pointer -> saved_value_bead.rho (number_of_dimensions + 1));

	if saved_value_bead.numeric_value & ^saved_value_bead.zero_or_one_value
	then if substr (rel (copy_to_pointer), 18, 1)
	     then copy_to_pointer = addrel (copy_to_pointer, 1);

	saved_value_bead.data_pointer = copy_to_pointer;

end copy_value_bead_header;

/* subroutine used by first pass to reserve space for each item in the saved ws. */

save_allocate:
	procedure;

	if n_words + current_segment_length > sys_info$max_seg_size
	then do;

		segment_length (current_component_number) = current_segment_length;

		do component = 0 to max_component_number;
		     if segment_length (component) + n_words <= sys_info$max_seg_size
		     then go to found_component;
		end;

		max_component_number, component = max_component_number + 1;
		segment_length (component) = 0;
found_component:
		segment_length (current_component_number) = current_segment_length;
		current_segment_length = segment_length (component);
		current_component_number = component;
		current_pseudo_baseptr = baseptr (component);
	     end;

	save_pseudo_pointer = addrel (current_pseudo_baseptr, current_segment_length);
	current_segment_length = current_segment_length + n_words;

end save_allocate;

save_bead_on_stack:
save_bead:
	procedure (bv_bead_pointer);

declare	bead_type fixed bin,
	element_number fixed bin (24),
	(bead_pointer, control_pointer) pointer unaligned;

declare	bv_bead_pointer pointer unaligned parameter;

	bead_pointer = bv_bead_pointer;

	if bead_pointer = null
	then return;

	if bead_pointer -> general_bead.reference_count < 0
	then return;

	go to compute_size (index (string (bead_pointer -> general_bead.type), "1"b));

compute_size (1):		/* OPERATOR BEAD */

	return;

compute_size (2):		/* SYMBOL BEAD */

	symbol_name_length = bead_pointer -> symbol_bead.name_length;

	n_words = size (saved_sb);

	bead_type = symbol_bead_type;
	go to allocate;

compute_size (3):		/* VALUE BEAD */

	call save_value_bead (bead_pointer);
	return;

compute_size (4):		/* FUNCTION BEAD */

	control_pointer = bead_pointer -> function_bead.stop_control_pointer;

	if control_pointer ^= null
	then call save_value_bead (control_pointer);

	control_pointer = bead_pointer -> function_bead.trace_control_pointer;

	if control_pointer ^= null
	then call save_value_bead (control_pointer);

	data_elements = bead_pointer -> function_bead.text_length;

	n_words = size (saved_fb);

	bead_type = function_bead_type;

	go to allocate;

compute_size (5):		/* GROUP BEAD */

	total_members = bead_pointer -> group_bead.number_of_members;

	n_words = size (saved_gb);

	bead_type = group_bead_type;

	go to allocate;

compute_size (9):		/* LIST BEAD */

	total_members = bead_pointer -> list_bead.number_of_members;

	n_words = size (saved_lb);

	bead_type = list_value_bead_type;

	go to allocate;

allocate:
	call save_allocate;

	/* Set active_bead_pointer before updating saved_bead_count, so our clean_up procedure will always work. */

	saved_bead_table (saved_bead_count + 1).active_bead_pointer = bead_pointer;
	saved_bead_count = saved_bead_count + 1;

	saved_bead_table (saved_bead_count).active_reference_count = bead_pointer -> general_bead.reference_count;
	saved_bead_table (saved_bead_count).pseudo_pointer = save_pseudo_pointer;
	saved_bead_table (saved_bead_count).bead_type = bead_type;
	bead_pointer -> general_bead.reference_count = - saved_bead_count;

	return;

compute_size (0):
compute_size (6):		/* LABEL BEAD */
compute_size (7):		/* SHARED VARIABLE BEAD */
compute_size (8):		/* LEXED FUNCTION BEAD */
compute_size (10):
compute_size (11):
compute_size (12):
compute_size (13):
compute_size (14):
compute_size (15):
compute_size (16):
compute_size (17):
compute_size (18):

	call apl_system_error_ (apl_error_table_$cant_save_ws);
	go to unwind_and_abort;

/* This procedure is separate so that save_bead (and save_value_bead) can be quick blocks. */

save_value_bead:
	procedure (bv_bead_pointer);

declare	bv_bead_pointer pointer unaligned parameter,
	bead_pointer pointer unaligned;

	bead_pointer = bv_bead_pointer;

	if bead_pointer -> general_bead.reference_count < 0	/* already saved */
	then return;

	data_elements = bead_pointer -> value_bead.total_data_elements;
	number_of_dimensions = bead_pointer -> value_bead.rhorho;

	if bead_pointer -> value_bead.character_value
	then do;
		n_words = size (character_string_overlay);
		bead_type = character_value_bead_type;
	     end;
	else if string(bead_pointer -> value_bead.type) = zero_or_one_value_type
	     then do;
		     n_words = size (saved_boolean_datum);
		     bead_type = boolean_value_bead_type;
		end;
	     else do;
		     n_words = size (numeric_datum (*)) + 1;
		     bead_type = numeric_value_bead_type;
		end;

	n_words = n_words + size (saved_value_bead);

	call save_allocate;

	/* Set active_bead_pointer before updating saved_bead_count, so our clean_up procedure will always work. */

	saved_bead_table (saved_bead_count + 1).active_bead_pointer = bead_pointer;
	saved_bead_count = saved_bead_count + 1;

	saved_bead_table (saved_bead_count).active_reference_count = bead_pointer -> general_bead.reference_count;
	saved_bead_table (saved_bead_count).pseudo_pointer = save_pseudo_pointer;
	saved_bead_table (saved_bead_count).bead_type = bead_type;
	bead_pointer -> general_bead.reference_count = - saved_bead_count;

	return;

end save_value_bead;

end save_bead;

/* function to convert saved bead location in MSF to ITS pointer */

un_pseudo_pointer:
	procedure (bv_pseudo_pointer) returns (pointer unaligned);

declare	bv_pseudo_pointer pointer unaligned parameter,
	pseudo_pointer pointer unaligned;

	pseudo_pointer = bv_pseudo_pointer;

	return (addrel (ws_segment (fixed (baseno (pseudo_pointer), 18, 0)), rel (pseudo_pointer)));

end un_pseudo_pointer;



/* function to convert ITS pointer to bead number */

translate_pointer:
	procedure (bv_bead_pointer) returns (fixed binary (21));

declare	bv_bead_pointer pointer unaligned parameter,
	bead_pointer pointer unaligned;

	bead_pointer = bv_bead_pointer;

	if bead_pointer = null
	then return (0);
	else if bead_pointer -> general_bead.reference_count > 0	/* bead was never "saved"! */
	     then call apl_system_error_ (apl_error_table_$cant_save_ws);
	     else return (- bead_pointer -> general_bead.reference_count);

end translate_pointer;

/* parameters */

declare	((a_wsid, a_lock) char (*),
	a_code fixed bin (35)) parameter;

/* automatic */

declare  (n_words, bucket_number, this_frame, reduction_stack_size, symbol_number, parseme,
	total_length, component, current_component_number, datum_number,
	total_quota, quota_used, quota_remaining, bead_number, element_count,
	member_number, data_elements, current_segment_length, parseme_number,
	terminal_account, previous_greater_than_position,
	my_type, frame_number, source_length, total_symbols, old_workspace_length
	) fixed binary (24) automatic;

declare	max_component_number fixed bin;

declare	code fixed binary (35);

declare	current_time fixed binary (71) automatic;

declare   segment_length fixed binary (24) automatic dimension (0:63);

declare  (current_pseudo_baseptr, saved_ws_info_pseudo_pointer, symbol_bead_ptr,
	save_pseudo_pointer, previous_frame_pointer, parse_frame_ptr,
	copy_from_pointer, copy_to_pointer, bead_pointer,
	BeadBase, bead_description_pseudo_pointer
	) pointer unaligned automatic;

declare  (fcbp, ws_segment (0:63)
	) pointer aligned automatic;

declare  (bead_table_pointer, stack_frame_table_pointer
	) pointer aligned;

declare  (dname, directory
	) character (168) automatic;

declare  (ename, entryname, lock
	) character (32) automatic;

declare   wsid character (100) automatic;

declare	(copy_this_one, save_this_one) bit(1) aligned;

declare	1 branch		aligned,
	2 type		bit (2) unal,
	2 n_names		fixed bin (15) unal,
	2 nrp		bit (18) unal,
	2 dtm		bit (36) unal,
	2 dtu		bit (36) unal,
	2 mode		bit (5) unal,
	2 pad		bit (13) unal,
	2 records		fixed bin (17) unal;

/* internal static initial */

declare	output_stream character (32) internal static initial ("apl_output_");

declare (group_bead_type initial (1),
	symbol_bead_type initial (2),
	function_bead_type initial (3),
	list_value_bead_type initial (4),
	numeric_value_bead_type initial (5),
	character_value_bead_type initial (6),
	boolean_value_bead_type initial (7)
	) fixed binary internal static;

/* based */

declare	suspended_source character (source_length) based;
declare	suspended_source_length fixed binary (29) aligned based;

declare 1 saved_bead_table aligned based (bead_table_pointer) dimension (1),
	2 active_bead_pointer pointer unaligned,
	2 active_reference_count fixed binary (29),
	2 pseudo_pointer pointer unaligned,
	2 bead_type fixed binary;

declare 1 saved_stack_frame_table aligned based (stack_frame_table_pointer) dimension (1),
	2 active_frame_pointer pointer unaligned,
	2 pseudo_pointer pointer unaligned,
	2 reduction_stack_pointer unaligned pointer,
	2 previous_pseudo_pointer pointer unaligned;

declare 1 single_rs_element aligned based like reduction_stack;

/* conditions */

declare	(cleanup, record_quota_overflow) condition;

/* external static */

declare (	error_table_$noentry fixed bin (35),
	apl_error_table_$cant_save_ws fixed bin (35),
	sys_info$max_seg_size fixed bin (19)
	) external static;

/* entries */

declare	com_err_ entry options (variable);
declare	ioa_$ioa_stream entry options (variable);
declare	apl_create_save_frame_ entry;
declare	apl_date_time_ entry (fixed binary (71)) returns (character (17));
declare	apl_destroy_save_frame_ entry;
declare	apl_system_error_ entry (fixed bin(35));
declare	apl_translate_pathname_ entry (char (*), char (*), char (*), pointer, fixed binary (35));
declare	hcs_$fs_get_path_name entry (ptr, char (*), fixed bin (21), char (*), fixed bin (35));
declare	hcs_$quota_get entry (char (*), fixed bin (24), fixed bin (24), bit (36) aligned, fixed bin (24), fixed bin (24),
			  fixed bin (24), fixed bin (35));
declare	hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
declare	hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));
declare	msf_manager_$get_ptr entry (pointer, fixed bin (24), bit (1) aligned, pointer, fixed bin (24), fixed bin (35));
declare	msf_manager_$adjust entry (pointer, fixed bin, fixed bin (24), bit (3), fixed bin (35));
declare	msf_manager_$close entry (pointer);
declare	apl_segment_manager_$get entry () returns (pointer);
declare	apl_segment_manager_$free entry (pointer);

/* builtins */

declare	(add, addr, addrel, bit, baseno, baseptr, clock, divide, fixed, index, length) builtin;
declare	(null, rel, reverse, size, string, substr, unspec) builtin;

/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_bead_format;
%include apl_symbol_bead;
%include apl_value_bead;
%include apl_list_bead;
%include apl_function_bead;
%include apl_lexed_function_bead;
%include apl_group_bead;
%include apl_operator_bead;
%include apl_parse_frame;
%include apl_symbol_table;
%include apl_save_frame;
%include apl_saved_ws;
end apl_save_command_;




		    apl_segment_manager_.pl1        11/29/83  1638.6r w 11/29/83  1347.2       75591



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


/* The following module is used to manage temporary segments in APL. These segments are used for stacks,
   editor, save and load temporaries, etc.  The get entry is called with no arguments and will return a pointer which
   will be set to point to the base of a temporary segment.  The free entry takes such a pointer, but it need not point
   at the base of the segment.   This module replaces an earlier version that did not attempt to reuse
   the segments.  Here a table is kept of pointers to the segments, along with a table of bits telling if the
   segment is in use.  If no previously-created segments are in use, a new one is created with the name
   "apl_seg_NNN" where NNN is a three-digit decimal number starting and zero and increasing for each new segment
   created.

	Created 11/28/73 by G. Gordon Benedict.
	Modified 761007 by PG to have set_temp_dir do a reset when directory is changed.
*/

apl_segment_manager_$get:				/* entry to get pointer to temporary segment */
	procedure () returns (pointer);	/* pointer will be filled in with pointer to base of segment */

declare	a_seg_ptr pointer parameter;
declare	seg_ptr pointer;		/* just a random pointer */
declare	packed_seg_ptr pointer unaligned;	/* for fast compares with packed ptrs in seg table */

declare	segment_counter	/* contains NNN (last three digits of temporary segment next to be allocated) */
	     fixed decimal precision (3,0) internal static initial (0);

declare	segment_counter_picture picture "999";

declare	segment_pointers		/* contains pointers to all segments so far created (which are NEVER deleted) */
	     dimension (0 : 31) pointer unaligned internal static initial ( (32) null () );

declare	segment_used		/* contains one bit for every segment, allocated or not. 1 = in use
				   (i.e. allocated but not yet freed) 0 = not in use or not allocated */
	     dimension (0 : 31) bit (1) internal static unaligned initial ( (32) (1) "0"b);

declare	(apl_error_table_$temp_seg_already_exists,	/* happens if segment_used says not existent but does */
	 apl_error_table_$cant_create_seg,		/* happens if in dir without modify access */
	 apl_error_table_$wsfull_out_of_segs,			/* happens if more than 32 segments are needed */
	 apl_error_table_$attempt_to_free_not_temp,	/* Attempt to free segment not known to storage manager */
	 apl_error_table_$cant_truncate_seg)		/* hcs_$truncate_seg refuses to truncate */
	     fixed binary precision (35) external static;

declare	segment_index		/* used to loop thru segment_pointers table */
	     fixed binary;

declare	temp_dir	/* contains name of directory into which to place temporary segments */
	     character (168) internal static initial ("");

declare	(hbound,
	 index,
	 null,
	 pointer,
	 string) builtin;

declare	apl_system_error_		/* used to signal all of those gruesome errors above */
	     entry (fixed binary precision (35));

declare	hcs_$make_seg		/* used to create temp segs when no unused segs are in existence */
	     entry (character (*), character (*), character (*), fixed binary precision (4), pointer,
		fixed binary precision (35));

declare	unique_chars_		/* used to guarantee unique names */
	     entry (bit (*)) returns (char (15));
declare	hcs_$delentry_seg		/* used to delete temp segs when clear command (reset entry) is used */
	     entry (pointer, fixed binary precision (35));

declare	hcs_$truncate_seg		/* used to reduce freed segments to zero length */
	     entry (pointer, fixed binary, fixed binary precision (35));

declare	code			/* error code */
	     fixed binary precision (35);

/* Now comes main code for get entry.  See if there is an unused segment with a non-null pointer */

	segment_index = index (string (segment_used), "0"b) - 1;	/* find first unused bit */
	if segment_index < 0 then do;	/* unfortunately all entries in table are used up, so... */
	      call apl_system_error_ (apl_error_table_$wsfull_out_of_segs);	/* if you get this one, tell me 
							   to increase size of this table */
	      return;
	end;

	seg_ptr = segment_pointers (segment_index);	/* fetch pointer for unused segment */

	if seg_ptr = null () then do;	/* segment does not exist, no unused segments were available. get one */
	     segment_counter_picture = segment_counter;		/* convert to 001, 002, etc. */
	     call hcs_$make_seg (temp_dir,	/* use this dir */
		unique_chars_ (""b) || ".apl_seg_" || segment_counter_picture, "", 1011b, seg_ptr, code);

	     if seg_ptr = null () then do;	/* for some reason make_seg refused to make it */
		call apl_system_error_ (apl_error_table_$cant_create_seg);
		return;
	     end;

	     if code ^= 0 then do;		/* uhoh... there's another apl running in this losers process who is
					   using his own table... los,e, lose, lose */
		call apl_system_error_ (apl_error_table_$temp_seg_already_exists);
		return;
	     end;

	     segment_counter =	/* increment NNN suffix for next time */
		segment_counter + 1;
	     segment_pointers (segment_index) = seg_ptr;	/* fill in for next time */
	end;

	segment_used (segment_index) = "1"b;	/* indicate in use */
	return (seg_ptr);		/* return pointer to allocated segment */


/* Now comes the free entry.  Mostly system-error checking */

apl_segment_manager_$free:
	entry (a_seg_ptr);		/* pointer into segment to free */

	packed_seg_ptr,		/* more efficient to compare packed to packed than packed to unpacked */
	seg_ptr = pointer (a_seg_ptr, 0);	/* copy and get ptr to base of segment */

/* search thru the segment table for one which matches */

	do segment_index = 0 by 1 while (segment_index <= hbound (segment_pointers, 1));	/* thru whole table */

	     if segment_pointers (segment_index) = packed_seg_ptr then do;	/* found it! */
		segment_used (segment_index) = "0"b;	/* indicate not used for next allocate */
		call hcs_$truncate_seg (seg_ptr, 0, code);	/* reduce to zero length */
		if code ^= 0 then do;	/* truncate refuses */
		     segment_pointers (segment_index) = null ();	/* do not let APL re-use this segment */
		     call apl_system_error_ (apl_error_table_$cant_truncate_seg);
		     return;
		end;

		return;
	     end;
	end;

/* The loser gave me a segment I couldn't find in my segment table */

	call apl_system_error_ (apl_error_table_$attempt_to_free_not_temp);
	return;

/* This entry is used to initialize the temp_dir to some directory, or to change to a new directory. */

apl_segment_manager_$set_temp_dir:
	entry (directory);

declare	directory character (*) parameter;	/* the new directory */

	if temp_dir ^= ""				/* If temp_dir is initialized */
	then if temp_dir ^= directory			/* And we are changing directories */
	     then do;
		     call apl_segment_manager_$reset;	/* delete old temp segs */
		     temp_dir = directory;
		end;
	     else;				/* directory is staying the same */
	else temp_dir = directory;			/* just initialize temp_dir first time thru */
	return;

/* This entry is used to tell the segment manager to get rid of all apl temporary segments and clear the
   table of segments, and reset the segment counter to zero. */

apl_segment_manager_$reset:
	entry ();

	segment_counter = 0;	/* reset to zero */
	string (segment_used) = ""b;		/* no segments are in use */

	do segment_index =0 by 1 while (segment_index <= hbound (segment_pointers, 1));
	     if segment_pointers (segment_index) ^= null () then do;	/* delete this segment */
		seg_ptr = segment_pointers (segment_index);
		segment_pointers (segment_index) = null ();	/* will be no segment there soon */
		call hcs_$delentry_seg (seg_ptr, code);		/* delete this temp seg */
	     end;
	end;
	return;

/* This entry is used to inquire the segment manager to give the name of the current temp_dir and value
   of the segment_counter */

apl_segment_manager_$get_dir_and_count:
	entry (directory, count);

declare	count fixed decimal (3, 0) parameter;

	directory = temp_dir;
	count = segment_counter;

     end apl_segment_manager_$get;




		    apl_si_command_.pl1             11/29/83  1638.6r w 11/29/83  1347.2       47232



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

/* Program to implement the APL )SI and )SIV commands.
   Written by R.S.Lamson, Summer, 1973.
   Modified 740910 by PG for installation.
   Modified 800130 by PG for localized system variables.
*/

/* format: style3 */
apl_si_command_:
     procedure;

	variables = "0"b;
	go to list_the_state_indicator;

apl_siv_command_:
     entry;

	variables = "1"b;

list_the_state_indicator:
	call apl_create_save_frame_;			/* needed for erased-functions check */
	last_frame_was_suspended = "0"b;

	do parse_frame_ptr = ws_info.current_parse_frame_ptr
	     repeat (parse_frame_ptr -> parse_frame.last_parse_frame_ptr) while (parse_frame_ptr ^= null);

	     if parse_frame.parse_frame_type = suspended_frame_type
	     then last_frame_was_suspended = "1"b;
	     else if parse_frame.parse_frame_type ^= save_frame_type
	     then do;
		     if parse_frame.parse_frame_type = function_frame_type
		     then do;
			     lexed_function_bead_pointer = parse_frame.lexed_function_bead_ptr;
			     line_number = parse_frame.current_line_number;

			     if last_frame_was_suspended
			     then star = "*";
			     else star = " ";

			     call get_function_name;
			     call ioa_$rsnnl ("^va[^d] ^a", string, string_length, min_function_name_length,
				function_name, line_number, star);
			     call apl_print_string_ (substr (string, 1, string_length));

			     if variables
			     then do symbol = 1
				     to lexed_function_bead_pointer
				     -> lexed_function_bead.number_of_localized_symbols;

				     p = lexed_function_bead_pointer
					-> lexed_function_bead.localized_symbols (symbol);

				     if p ^= null
				     then if p -> general_bead.symbol
					then call apl_print_string_ (p -> symbol_bead.name);
					else call apl_print_string_ (system_var_names (p -> operator_bead.op1));
				end;
			end;
		     else if parse_frame.parse_frame_type = evaluated_frame_type
		     then call apl_print_string_ (QQuad);
		     else if parse_frame.parse_frame_type = execute_frame_type
		     then call apl_print_string_ (QExecuteSign);

		     last_frame_was_suspended = "0"b;
		     call apl_print_newline_;
		end;
	end;

	call apl_flush_buffer_;
	call apl_destroy_save_frame_;

get_function_name:
     procedure;

/* this internal procedure is called to determine what function name
   should be printed.  It exists only for indentation reasons */

declare	i		fixed bin;

	min_function_name_length = 1;			/* normally don't mung ioa_ */

	if lexed_function_bead_pointer -> lexed_function_bead.name -> symbol_bead.meaning_pointer
	     = parse_frame.function_bead_ptr
	then function_name =
		lexed_function_bead_pointer -> /* global function - usual case */ lexed_function_bead.name
		-> symbol_bead.name;
	else do;
		do i = 1 by 1 while (i <= current_parse_frame_ptr -> save_frame.saved_symbol_count);

/* go looking for localized function (QuadFX) */

		     if current_parse_frame_ptr -> save_frame.symbol_list (i).symbol_pointer
			= lexed_function_bead_pointer -> lexed_function_bead.name
		     then if current_parse_frame_ptr -> save_frame.symbol_list (i).saved_meaning_pointer
			     = parse_frame.function_bead_ptr
			then do;			/* found localized function */
				function_name =
				     lexed_function_bead_pointer -> lexed_function_bead.name -> symbol_bead.name;
				go to exitloop;
			     end;
		end;

/* neither global nor most locally bound:  probably erased so give blank name */

		function_name = "";
		min_function_name_length = 6;		/* mung ioa_ to give 6 spaces */
	     end;

exitloop:
	return;

     end get_function_name;

/* automatic */

declare	(p, parse_frame_ptr, lexed_function_bead_pointer)
			ptr;

declare	(last_frame_was_suspended, variables)
			bit (1) aligned automatic;

declare	(symbol, line_number, string_length)
			fixed binary;

declare	star		char (1);

declare	string		character (256);
declare	function_name	char (200) varying;
declare	min_function_name_length
			fixed bin;

/* entries */

declare	(apl_create_save_frame_, apl_destroy_save_frame_)
			entry;

declare	ioa_$rsnnl	entry options (variable);

declare	apl_print_string_	entry (character (*));

declare	(apl_print_newline_, apl_flush_buffer_)
			entry ();

/* builtins */

declare	(char, null, substr)
			builtin;

/* internal static options (constant) */

declare	system_var_names	(2:16) char (3) internal static options (constant)
			init ("Оct", "Оio", "Оlx", "Оpp", "Оpw", "Оrl", (8) (1)"", "Оit");
						/* rest assured these strings contain Quads (\216) */

/* include files */

%include apl_number_data;
%include "apl_bead_format";
%include "apl_symbol_bead";
%include "apl_lexed_function_bead";
%include "apl_parse_frame";
%include "apl_ws_info";
%include "apl_characters";
%include "apl_operator_bead";
%include "apl_save_frame";

     end apl_si_command_;




		    apl_static_.alm                 11/29/83  1638.6rew 11/29/83  1347.2       11709



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

	name apl_static_

" this data base contains the packed pointer to the ws_info
" structure described by apl_ws_info.incl.pl1

" written 73.8.3 by DAM
" Modified 740910 by PG to flush obsolete entries.
" Modified 761005 by PG to give a temporary home to immediate_input_prompt.
" Modified 781208 by PG to add pointers to IOCB's.
" Modified 800129 by PG to delete localization info.

	use	static

"	DOUBLE-WORD ALIGNED ITEMS.

	segdef	apl_input
apl_input:
	its	-1,1

	segdef	apl_output
apl_output:
	its	-1,1

	segdef	user_tty
user_tty:
	its	-1,1

"	SINGLE-WORD ALIGNED ITEMS.

	segdef	ws_info_ptr
ws_info_ptr:
	oct	007777000001	initialize to null pointer

	segdef	immediate_input_prompt
immediate_input_prompt:
	dec	0
	aci	" ",32

	join	/link/static
	use	text
	join	/text/text

	segdef	version_number
version_number:
	aci	" 5.02",5

	end




		    apl_storage_manager_.pl1        11/29/83  1638.6r w 11/29/83  1347.2      377487



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

apl_storage_manager_:
	procedure;

/*
 * this module manages the storage heap for APL
 *
 * free blocks are remembered in a binary tree structure, sorted by address
 * there is a seperate tree for each segment
 * allocation is done by first-fit.
 * big beads and little beads are kept in seperate segments in the
 * vain hope that fragmentation and map overhead can be kept down.
 * (maps are the binary trees of free beads, kept in their own seg)
 *
 *
 * written 7/15/73 by DAM
 * modified 8/4/73 by DAM for new ws format
 * modified 8/24/73, 8/26/73 by DAM for newer ws format (version 3) and interrupts
 * modified 12/06/73 by PG for apl_segment_manager_
 * modified by G. Gordon Benedict in July 1974 to fix a bug in which unless ws_info.meter_mode is on,
 * once balance was called free_apl_bead would loop forever; and to change names of entries to appropriate
 * apl names.
 * Modified 740910 by PG to flush apl_error_table_$random_system_error, properly compute storage used by
 * value stacks, and remove last reference to apl_static_$temp_dir (long obsolete).
 * Modified 750630 by PG to re-type about 120 lines which were lost due to EIS hardware problems.
 * Modified 760325 by PG to correct balancer to zero out slots that it frees up, and fix allocater to
 * 	correctly rebalance tree after deleting nodes.
   Modified 760420 by PG to correct allocater to walk free map in pre-order (not sequential),
	thus speeding things up when no match is found in (sparse) tree,
	and to correct problem in rebalancing after deletion.
   Modified 770413 by PG to add name apl_get_value_stack_ to apl_get_next_value_stack_seg_.
   Modified 780227 by PG to catch duplicate free requests.
   Modified 780502 by PG to fix 320 (can't find first free map entry, walking map in postorder instead of inorder),
	and bug 301 (launder internal procedure not nulling argument).
   Modified 780517 by William York to make apl_allocate_words_ and the tree
	balancer in apl_free_words_ walk the free tree correctly, fixing bug 325.
   Modified 780523 by WMY to round up sizes of allocations to even words to eliminate lost words between
	storage blocks.
   Modified 790321 by WMY to fix bug 382 (values that take up exactly 261120 words
	cause phony WS FULL errors by using up all of the valuse stack segs
	while looking for one big enough.
   Modified 790328 by WMY to be able to free lexed_function_beads with no
	statement map (i.e. no statements).
 */

/* The allocation/free type codes used by the trace facility are as follows:
	1 - off end of segment
	2 - with map
	3 - left merge
	4 - left merge simple
	5 - right merge
	6 - right merge simple
	7 - discard
	8 - error, duplicate free request
*/

/* automatic */

dcl p pointer unaligned,		/* to bead being allocated or freed */
    s fixed bin(18);		/* size of it in words */
dcl depth fixed bin;
dcl map_stack (11) fixed bin;		/* stack for walking free tree.  dim must be >= log2 (LittleMapSize) */
dcl found bit (1) aligned;
dcl  neighbor fixed bin;
dcl  global_storage_system_data_pointer ptr;
dcl hash_index fixed bin,
    which_free fixed bin,				/* for tracing; which way bead was freed */
    sli fixed bin,				/* index into seg_list of seg currently being munged */
    new_sli fixed bin,
    enter_balance_time fixed bin(71),
    enter_time fixed bin(71),
    p_rel_loc bit(18),			/* rel(p) */
    already_balanced bit(1),			/* flag to avoid balance loop when tree is just too big */
    (q, old_q) pointer unaligned,
    i fixed bin,

	/* next 3 vars are used for metering only */
    rangex fixed bin,			/* index of proper element in metric.range, determined from s */
    endp fixed bin(1),			/* 0 or 1, depending on whether alloced off end of seg */
    newp fixed bin(1),			/* 0 or 1, depending on whether alloced in new seg */

    mapx fixed bin,				/* index in map of current free bead being looked at */
    other fixed bin,			/* index in map of some other bead */
    base fixed bin,				/*  ..  */
    scan_pos fixed bin,			/* index in map of next bead to look at when allocating */

    esw fixed bin,				/* entry switch */
    n_left fixed bin(18),			/* number of words left in bead or seg after allocation */
    required_usage fixed bin,			/* used in searching seg_list for match usage field */
    temp_ptr ptr,
    segp pointer aligned,			/* -> some segment involved with file system */
    small_piece fixed bin(18),		/* value to store into seg_map.smallest_piece */
    map_size fixed bin,			/* number of map entries to allocate, must be power of 2 - 1 */
    new_slot fixed bin,
    data_elements fixed bin(21);

/* conditions */

declare	apl_dirty_stop_ condition;

/* internal static */

dcl (trace_flags bit (36) aligned initial ((36)"0"b),
     trace_allocate_words bit (36) aligned initial ("1"b),
     trace_balancer bit (36) aligned initial ("01"b),
     trace_copy_value bit (36) aligned initial ("001"b),
/*   trace_unused bit (36) aligned initial ("0001"b), */
     trace_free bit (36) aligned initial ("00001"b),
     trace_get_stack_seg bit (36) aligned initial ("000001"b),
     trace_reference_count_errors bit (36) aligned initial ("0000001"b),
     trace_clear_storage bit (36) aligned initial ("00000001"b),
     check_storage_manager bit (36) aligned initial ("000000000000000000000000000000000001"b)
    ) internal static;

/* external static */

dcl sys_info$max_seg_size fixed bin(18) external;

/* entries called */

dcl apl_segment_manager_$get entry () returns (pointer),
    apl_segment_manager_$free entry (pointer),
    apl_get_symbol_ entry(char(*), pointer unaligned, fixed bin),
    apl_system_error_ entry (fixed bin (35)),
    (check_storage_manager_$allocate, check_storage_manager_$free) entry (ptr unal, fixed bin (18)),
     check_storage_manager_$clear entry (),
    debug entry (),
    ioa_$ioa_stream entry options (variable),
    hcs_$truncate_seg entry(pointer, fixed bin(18), fixed bin(35));

/* status codes */

dcl (apl_error_table_$bead_already_free,
     apl_error_table_$invalid_free_bead,
     apl_error_table_$uninterned_symbol,
     apl_error_table_$bead_not_known_to_apl,
     apl_error_table_$wsfull_alloc_too_big,
     apl_error_table_$wsfull_out_of_maps,
     apl_error_table_$wsfull_out_of_segs,
     apl_error_table_$hash_table_full,
     apl_error_table_$no_type_bits,
     apl_error_table_$wsfull_on_stack,
     apl_error_table_$non_existent_stack,
     apl_error_table_$wsfull_no_stack_segs,
     apl_error_table_$tables_inconsistent
    ) fixed bin(35) external;

/* constants which can be used for tuning */

dcl BreakSize fixed bin(18) static init(64),		/* boundary between "big" beads and "little" beads */
    BigMapSize fixed bin static init(511),		/* number of entries per map for big beads */
    LittleMapSize fixed bin static init(2047),		/* number of entries per map for little beads */
    BigSmallPiece fixed bin(18) static init(40),		/* minimum number of words in a free bead in "big" space */
    LittleSmallPiece fixed bin(18) static init(4);	/* minimum number of words in a free bead in "little" space */

/* builtin */

dcl (addr, addrel, baseno, binary, bit, dim, divide, fixed, hbound, lbound,	/* that lbound train */
     max, mod, null, ptr, rel, size, string, substr, unspec, vclock) builtin;

/* include files */

%include apl_storage_system_data;
%include apl_number_data;
%include apl_ws_info;
%include apl_symbol_table;
%include apl_bead_format;
%include apl_value_bead;
%include apl_operator_bead;
%include apl_symbol_bead;
%include apl_function_bead;
%include apl_lexed_function_bead;
%include apl_group_bead;

trace_storage_manager:
	entry (bv_trace_flags);

/* parameters */

dcl  bv_trace_flags bit (36) aligned;

/* entry */

	trace_flags = bv_trace_flags;			/* someday we should copy these into the ws */
	return;					/* during initialization to avoid the extra pagefault */

apl_free_bead_:
	entry (free_ptr_structure);

dcl 1 free_ptr_structure aligned parameter,
      2 free_ptr unaligned pointer;

	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;
	p = free_ptr;				/* -> block to be freed */
	s = fixed (p -> general_bead.size, 18);		/* number of words to free */


	if p -> general_bead.reference_count ^= 0
	then do;
		if trace_flags & trace_reference_count_errors
		then do;
			call ioa_$ioa_stream ("apl_trace_", "ref ct error: ^d ^d ^p; calling debug",
			     p -> general_bead.reference_count, s, p);
			call debug;
		     end;

		call apl_system_error_ (apl_error_table_$invalid_free_bead);
	     end;

	/* if necessary, recursively free the components of the bead.  we use actual PL/I recursion since
	   in the most common case (value beads) it won't be used. */

	if p -> general_bead.type.symbol
	then if p -> symbol_bead.meaning_pointer = null	/* only throw away symbol if it is truly meaningless */
	     then do;
		     call apl_get_symbol_ (p -> symbol_bead.name, q, i);	/* get hash-bucket number */
		     if q ^= p
		     then call apl_system_error_ (apl_error_table_$uninterned_symbol);

		     old_q = null;			/* trace hash chain and remove this symbol from table */
		     do q = hash_bucket_ptr (i) repeat (old_q -> symbol_bead.hash_link_pointer) while (q ^= null);
			if q = p
			then do;
				if old_q = null	/* first on chain */
				then hash_bucket_ptr (i) = q -> symbol_bead.hash_link_pointer;
				else old_q -> symbol_bead.hash_link_pointer = q -> symbol_bead.hash_link_pointer;

				go to escape;
			     end;
			old_q = q;
		     end;
						/* should never take normal exit from loop */
		     call apl_system_error_ (apl_error_table_$uninterned_symbol);

escape:
		     ws_info.number_of_symbols = ws_info.number_of_symbols - 1;	/* maintain this count for rsl */
		end;
	     else return;				/* meaning ptr non null */

	else if p -> general_bead.type.function
	     then do;
		     if p -> function_bead.class <= 1
		     then call launder (p -> function_bead.lexed_function_bead_pointer);
					/* check for external function, where is not really bead ptr */
		     call launder (p -> function_bead.stop_control_pointer);
		     call launder (p -> function_bead.trace_control_pointer);
		end;

	else if p -> general_bead.type.group
	     then do i = 1 to p -> group_bead.number_of_members;
		     call launder (p -> group_bead.member (i));
		end;

	else if p -> general_bead.type.lexed_function
	     then do;
		     call launder (p -> lexed_function_bead.name);
		     do i = 1 to p -> lexed_function_bead.number_of_localized_symbols;
			if p -> lexed_function_bead.localized_symbols (i) ^= null
			then if p -> lexed_function_bead.localized_symbols (i) -> general_bead.type.symbol
					/* only does next line if real symbol, not localized system variable */
			     then call launder (p -> lexed_function_bead.localized_symbols (i));
		     end;
		     do i = 1 to p -> lexed_function_bead.number_of_labels;
			call launder (p -> lexed_function_bead.label_values_ptr -> lexed_function_label_values (i));
		     end;

		     /* Make sure that there are any statements at all before
			trying to free their lexemes. */

		     if p -> lexed_function_bead.number_of_statements > 0
			then do i = 1 to p -> lexed_function_bead.statement_map_ptr -> lexed_function_statement_map (
			     p -> lexed_function_bead.number_of_statements);

			     call launder (p -> lexed_function_bead.lexeme_array_ptr -> lexed_function_lexeme_array (i));
			end;
		end;

	go to free_something;		/* go free up the storage that was occupied by this bead */

apl_free_words_:
	entry (alloc_amount, alloc_ptr_structure);

dcl alloc_amount fixed bin(18) parameter,
    1 alloc_ptr_structure aligned parameter,
      2 alloc_ptr unaligned pointer;

	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;

	p = alloc_ptr;
	s = alloc_amount;

free_something:				/* p -> bead to free, s is number of words */
	ws_info.dont_interrupt_storage_manager = "1"b;		/* inhibit interruptions while munging the map seg */

	if ws_info.meter_mode
	then enter_time = vclock ();

	/* find map for segment in which bead is being freed */

	hash_index = mod(fixed(baseno(p), 18), dim(seg_map_hash_table, 1));
	do i = hash_index by 1 while (i <= hbound(seg_map_hash_table, 1)),
	       lbound(seg_map_hash_table, 1) by 1 while (i < hash_index);	/* circular scan of hash table */
	   if seg_map_hash_table(i).seg_baseno = baseno(p) then go to g0001;
	   end;
	call apl_system_error_(apl_error_table_$bead_not_known_to_apl);	/* not in hash table??!?!?!?!!!??? */

g0001:	sli = seg_map_hash_table(i).seg_list_idx;
	if seg_list(sli).usage ^> 2 then call apl_system_error_(apl_error_table_$bead_not_known_to_apl);
	seg_map_p = seg_list(sli).pointer;

	p_rel_loc = rel(p);			/* avoid repeated recomputation of this */

	/* check if this free bead falls at end of segmant, in which case don't bother with map */

	if fixed(p_rel_loc, 18) + s = seg_map.amount_of_seg_used then do;
		seg_map.amount_of_seg_used = fixed(p_rel_loc, 18);
		mapx = 0;				/* METER */
		which_free = 1;			/* TRACE; 1 = OFF END */
		go to tree_search_exit;
		end;


	already_balanced = "0"b;		/* set flag saying have not yet called balance */
retry_after_balance:			/* re-enter here after balance is called, already_balanced will be "1"b */
	mapx = 1;				/* start searching from root of tree, looking for place to drop bead */

tree_search_loop:
	if string (map (mapx)) = ""b			/* found a leaf, drop this bead in */
	then do;
		map(mapx).rel_loc = p_rel_loc;
		map(mapx).size = bit(fixed(s, 18), 18);
		seg_map.last_entry_used = max(seg_map.last_entry_used, mapx);
		which_free = 2;				/* TRACE; 2 = WITH MAP */
		go to tree_search_exit;
	     end;
	else if p_rel_loc < map (mapx).rel_loc		/* new bead is to the left of current one */
	     then if binary (map (mapx).rel_loc, 18) = binary (p_rel_loc, 18) + s
		then do;				/* combine on the left */
			map (mapx).rel_loc = p_rel_loc;
			map (mapx).size = bit (binary (binary (map (mapx).size) + s, 18), 18);
			other = left_neighbor (mapx);	/* try to combine further on the left */

			if other ^= mapx
			then if binary (p_rel_loc) = binary (map (other).rel_loc) + binary (map (other).size)
			     then do;		/* join beads, discard neighbor */
				     map (mapx).rel_loc = map (other).rel_loc;
				     map (mapx).size = bit (binary (binary (map (mapx).size)
					+ binary (map (other).size), 18), 18);
				     which_free = 3;	/* TRACE; 3 = LEFT MERGE */
				     go to fill_hole;
				end;
			which_free = 4;				/* TRACE; 4 = LEFT MERGE SIMPLE */
			go to tree_search_exit;
		     end;
		else do;				/* not adjacent, move left */
			mapx = 2*mapx;
			if mapx > seg_map.number_of_entries
			then go to balance;
			else go to tree_search_loop;
		     end;
	     else if p_rel_loc = map (mapx).rel_loc
		then do;				/* new bead is same as current one!!! */
			call apl_system_error_ (apl_error_table_$bead_already_free);
			which_free = 8;
			go to tree_search_exit;
		     end;
		else				/* new bead is to the right of current one */
		     if binary (p_rel_loc) = binary (map (mapx).rel_loc) + binary (map (mapx).size)
		     then do;			/* combine on the left */
			     map (mapx).size = bit (binary (binary (map (mapx).size) + s, 18), 18);

			     /* see if can combine further on the right */

			     other = right_neighbor (mapx);	/* other := leftmost bead to right of mapx */
			     if other ^= mapx
			     then if binary (map (other).rel_loc) = binary (p_rel_loc) + s
				then do;
					map (mapx).size = bit (binary (binary (map (mapx).size)
					     + binary (map (other).size), 18), 18);
					which_free = 5; /* TRACE; 5 = RIGHT MERGE */

					go to fill_hole;
				     end;
			     which_free = 6;	/* TRACE; 6 = RIGHT MERGE SIMPLE */
			     go to tree_search_exit;
			end;
		     else do;			/* not adjacent, move right */
			     mapx = 2 * mapx + 1;
			     if mapx > seg_map.number_of_entries
			     then go to balance;
			     else go to tree_search_loop;
			end;

fill_hole:
	neighbor = left_neighbor (other);

	if neighbor = other
	then neighbor = right_neighbor (other);

	if neighbor ^= other
	then do;
		string (map (other)) = string (map (neighbor));
		other = neighbor;
		go to fill_hole;
	     end;
	else string (map (other)) = ""b;

/* come here when the new bead has been successfully dropped into the tree */

tree_search_exit:
	if trace_flags & trace_free
	then call ioa_$ioa_stream ("apl_trace_", "free(^d) ^d (^o) ^p", which_free, s, s, p);

	if trace_flags & check_storage_manager
	then call check_storage_manager_$free (p, s);

	seg_list(sli).words_free = seg_list(sli).words_free + s;

	/* METER */

	if ws_info.meter_mode
	then do;
		call compute_range;
		metric.range(rangex).free_time = metric.range(rangex).free_time + (vclock() - enter_time);
		metric.range(rangex).free_count = metric.range(rangex).free_count + 1;
		if mapx ^= 0 then metric.range(rangex).map_free_count = metric.range(rangex).map_free_count + 1;
		metric.range(rangex).words_freed = metric.range(rangex).words_freed + s;
	     end;

	ws_info.dont_interrupt_storage_manager = "0"b;
	if ws_info.dirty_interrupt_pending then signal apl_dirty_stop_;
	return;

/*** routine to balance the tree -- returns to retry_after_balance ***/

balance:
	if already_balanced				/* damn! no space left in tree. throw this bead away. */
	then do;
		if ws_info.meter_mode
		then if s < BreakSize		/* meter this */
		     then do;
			     metric.little_seg_balance.thrown_away = metric.little_seg_balance.thrown_away + 1;
			     metric.little_seg_balance.amt_thrown_away = metric.little_seg_balance.amt_thrown_away + s;
			end;
		     else do;
			     metric.big_seg_balance.thrown_away = metric.big_seg_balance.thrown_away + 1;
			     metric.big_seg_balance.amt_thrown_away = metric.big_seg_balance.amt_thrown_away + s;
			end;
		which_free = 7;			/* TRACE; 7 = DISCARD */
		go to tree_search_exit;
	     end;

	already_balanced = "1"b;

	if trace_flags & trace_balancer
	then call ioa_$ioa_stream ("apl_trace_", "balancing");

	if ws_info.meter_mode
	then enter_balance_time = vclock ();

	begin;			/* need a begin block to get copy-space to make balancing tree easy */

      dcl	1 map_copy (0:seg_map.last_entry_used+1) aligned automatic like seg_map.map,
				/* 2 extra entries at begin and end are used in linked-list hack below */
	link_map(0:seg_map.last_entry_used+1) fixed bin aligned based(addr(map_copy)),

	left_link fixed bin,
	right_link fixed bin,
	new_link fixed bin,
   	mapx fixed bin,
	copyx fixed bin;

	/* move entries from map to map_copy, so that map_copy is sorted array of all of them.
	   tree is walked without the assistance of a stack.  With this peculiar storage order for
	   the tree a stack is not necessary */

	copyx = 0;
	mapx = 1;
	depth = 0;				/* stack is empty. */

copy_map_recurse_left:
	if mapx > seg_map.last_entry_used
	then go to copy_map_pop;

	if string (map (mapx)) = ""b
	then go to copy_map_pop;

	depth = depth + 1;				/* push current position onto stack */
	map_stack(depth) = mapx;
	mapx = 2 * mapx;				/* recurse to left son */

	go to copy_map_recurse_left;

copy_map_pop:
	if depth = 0
	then go to copy_map_done;

	mapx = map_stack(depth);
	depth = depth - 1;				/* pop top element on stack */

	copyx = copyx + 1;
	string (map_copy (copyx)) = string (map (mapx));
	string (map (mapx)) = ""b;			/* remove from original map */

	mapx = 2 * mapx + 1;			/* now visit right son */
	go to copy_map_recurse_left;

	/* At this point map_copy is sorted into order by increasing offsets.
	   Now we move it back into the real map such that the root of the
	   tree is the median, the left son of the root is the (1/4) quartile,
	   the right son of the root is the (3/4) quartile, etc.

	   The way this works is by successive halving, quartering, etc. of copy_map
	   after each stage a linked, ordered list of all things taken so far is constructed
	   so that the next stage may be done without any recursion or anything */

	/* first step is to link up a cell at left margin and a cell at right margin */

copy_map_done:
	link_map(0) = copyx+1;
	link_map(copyx+1) = 0;

	/* loop down the list and get the map entries in between the ones on the list */

	mapx = 0;				/* outputting to orig map in linear order */

	do while (mapx < 2*copyx);		/* put out enough rows of tree to consume all the entries */
					/* mapx doubles each time, last time through copyx <= mapx < 2*copyx */

	 do left_link = 0 repeat right_link while("1"b);

	   right_link = link_map(left_link);
	   if right_link = 0 then go to g0021;	/* come to end, exit out of this loop */

	   new_link = divide(right_link-left_link, 2, 17, 0);	/* half way between left_link & right_link */
	     if new_link = 0			/* nothing here so put out a zero.  I can prove this works... */
	     then mapx = mapx + 1;
	     else do;				/* something here, put it out and change it to a link */
		     new_link = new_link + left_link;
		     mapx = mapx + 1;
		     string(map(mapx)) = string(map_copy(new_link));
		     link_map(left_link) = new_link;
		     link_map(new_link) = right_link;
		end;
	   end;

g0021:
	end;

	seg_map.last_entry_used = mapx;

	/* METER THE BALANCER */

	if ws_info.meter_mode
	then if s < BreakSize
	     then do;
		     metric.little_seg_balance.count = metric.little_seg_balance.count + 1;
		     metric.little_seg_balance.time_spent_balancing = metric.little_seg_balance.time_spent_balancing +
			(vclock() - enter_balance_time);
		     metric.little_seg_balance.space_left = metric.little_seg_balance.space_left + copyx;
		end;
	     else do;
		     metric.big_seg_balance.count = metric.big_seg_balance.count + 1;
		     metric.big_seg_balance.time_spent_balancing = metric.big_seg_balance.time_spent_balancing +
			(vclock() - enter_balance_time);
		     metric.big_seg_balance.space_left = metric.big_seg_balance.space_left + copyx;
		end;

	end;			/* end of balancing the begin block */

	go to retry_after_balance;

/*** here is the allocation part ***/

apl_allocate_words_:
	entry (alloc_amount, alloc_ptr_structure);

	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;

	s = alloc_amount;
	/* alloc_ptr is return arg, will be set from p */


	esw = 1;
	if ws_info.meter_mode
	then enter_time = vclock ();

copy_value_alloc_join:

	s = s + (s - 2 *  divide (s, 2, 19, 0));
	if s > sys_info$max_seg_size then call apl_system_error_(apl_error_table_$wsfull_alloc_too_big);

	ws_info.dont_interrupt_storage_manager = "1"b;		/* inhibit interruptions while munging the map seg */
	endp, newp = 0;
	if s < BreakSize
	then do;
		sli = current_little_bead_seg;
		scan_pos = current_little_scan_pos;
	     end;
	else do;
		sli = current_big_bead_seg;
		scan_pos = current_big_scan_pos;
	     end;

	if sli = 0
	then go to get_new_seg;

	if seg_list (sli).usage ^> 2
	then call apl_system_error_ (apl_error_table_$tables_inconsistent);

	/* try scanning through this seg's map for a free bead of suitable size */

scan_for_bead_to_alloc:
	seg_map_p = seg_list (sli).pointer;
	if seg_list(sli).words_free < s then go to get_new_seg;	/* if hopeless */

	/* Look in free map for a free bead of enough words to meet
	   allocation request.  We walk the tree in in-order to avoid
	   zero nodes (the tree is usually pretty sparse), and to favor
	   the beginning of the segment.  Someday we might want to remember
	   where we left off the last time. */

	mapx = 1;					/* start at root node */
	depth = 0;				/* stack is empty. */

search_recurse_left:
	if mapx > seg_map.last_entry_used		/* mapx increases until too big by one level */
	then go to search_pop;

	if string (map (mapx)) = ""b			/* have gone too far...null leaf */
	then go to search_pop;

	depth = depth + 1;				/* push current node onto stack */
	map_stack(depth) = mapx;
	mapx = 2 * mapx;				/* try left son */
	go to search_recurse_left;

search_pop:
	if depth = 0				/* is stack empty? */
	then go to search_done;			/* then we have searched whole tree */

	mapx = map_stack(depth);
	depth = depth - 1;				/* pop top element on stack */

	n_left = binary (map (mapx).size, 18) - s;
	if n_left >= 0				/* if not hopeless, look more carefully */
	then do;
		p = addrel (seg_map.seg_ptr, map (mapx).rel_loc);

		if n_left >= seg_map.smallest_piece	/* if amount left is big enough to go on its own */
		then do;
			map (mapx).rel_loc = rel (addrel (p, s));
			map (mapx).size = bit (fixed (n_left, 18), 18);
			go to end_alloc;
		     end;
		else do;				/* otherwise, use whole bead & move up its subtree */
			s = s + n_left;

			if s < BreakSize		/* save scan pos for next time */
			then current_little_scan_pos = mapx;
			else current_big_scan_pos = mapx;

alloc_fill_hole:
			other = left_neighbor (mapx);	/* try left first */

			if other = mapx		/* nothing, try right */
			then other = right_neighbor (mapx);

			if other ^= mapx		/* if neighbor exists */
			then do;
				string (map (mapx)) = string (map (other));
				mapx = other;
				go to alloc_fill_hole;
			     end;
			else string (map (mapx)) = ""b;
			go to end_alloc;
		     end;
	     end;

	mapx = 2 * mapx + 1;			/* nothing here, try right son */
	go to search_recurse_left;

search_done:					/* no place free, try taking end of seg */
	if seg_map.amount_of_seg_used + s <= sys_info$max_seg_size
	then do;
		p = addrel (seg_map.seg_ptr, seg_map.amount_of_seg_used);
		n_left = 0;			/* may be uninitialized */
		seg_map.amount_of_seg_used = seg_map.amount_of_seg_used + s;
		endp = 1;
		go to end_alloc;
	     end;

/** can't alloc in this seg, try another one **/

get_new_seg:
	newp = 1;
	/* find big (or small)_seg from list of such which has most words left */

	n_left = 0;
	if s < BreakSize then required_usage = 3; else required_usage = 4;
	do i = lbound(seg_list, 1) to hbound(seg_list, 1);
	   if seg_list(i).usage = required_usage
	      then if seg_list(i).words_free > n_left
	         then do;	/* foud new max-free seg */
		  n_left = seg_list(i).words_free;
		  new_sli = i;
		  end;
	   end;
	if new_sli ^= sli
	   then if n_left >= s
	      then do;

		/* found new seg with more room, try it */

		sli = new_sli;
remember_new_seg:
		scan_pos = 1;
		if s < BreakSize then do;
		     current_little_bead_seg = sli;
		     current_little_scan_pos = 0;
		     end;
		else do;
		     current_big_bead_seg = sli;
		     current_big_scan_pos = 0;
		     end;
		go to scan_for_bead_to_alloc;
		end;


	/* no present segments, get a new one */


	call get_seg_for_apl;
	if s < BreakSize then do;
	   seg_list(sli).usage = 3;
	   map_size = LittleMapSize;
	   small_piece = LittleSmallPiece;
	   end;
	else do;
	   seg_list(sli).usage = 4;
	   map_size = BigMapSize;
	   small_piece = BigSmallPiece;
	   end;
	seg_list(sli).pointer, seg_map_p = last_map;
	seg_list(sli).words_free = sys_info$max_seg_size;
	temp_ptr = addrel(seg_map_p, size(seg_map));
	if fixed(rel(temp_ptr), 18) > sys_info$max_seg_size
	   then call apl_system_error_(apl_error_table_$wsfull_out_of_maps);	/* check for oob on map seg */
	else last_map = temp_ptr;		/* update ptr to next free loc in map seg */

	seg_map.seg_ptr = segp;
	seg_map.smallest_piece = small_piece;
	seg_map.number_of_entries = map_size;
	seg_map.last_entry_used = 0;
	seg_map.amount_of_seg_used = 0;
	go to remember_new_seg;			/* go rejoin other case of get_new_seg */

apl_copy_value_:
	entry (from_ptr_structure, to_ptr_structure);

/* parameters */

dcl 1 from_ptr_structure aligned parameter,
      2 from_ptr pointer unaligned,
    1 to_ptr_structure aligned parameter,
      2 to_ptr pointer unaligned;

	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;

	if ws_info.meter_mode
	then enter_time = vclock ();

	data_elements = from_ptr -> value_bead.total_data_elements;

	if from_ptr -> value_bead.data_type.character_value
	then do;
		s = size(character_string_overlay);
		esw = -1;
	     end;
	else if from_ptr -> value_bead.data_type.numeric_value
	     then do;
		     s = size (numeric_datum) + 1;
		     esw = 0;
		end;
	     else call apl_system_error_(apl_error_table_$no_type_bits);

	number_of_dimensions = from_ptr -> value_bead.rhorho;
	s = s + size (value_bead);			/* total number of words needed */

	go to copy_value_alloc_join;

/* come here with p -> bead that has been allocated, s = actual size */

end_alloc:
	seg_list(sli).words_free = seg_list(sli).words_free - s;
	ws_info.dont_interrupt_storage_manager = "0"b;
	if ws_info.dirty_interrupt_pending then signal apl_dirty_stop_;

	/* set up bead header */

	p -> general_bead.reference_count = 1;			/* since our return argument (only) will point at it */
	p -> general_bead.size = bit(fixed(s, 18), 18);		/* actual number of words allocated */
		/* caller must set type field */

	/* METER */

	if ws_info.meter_mode
	then do;
		call compute_range;
		metric.range(rangex).alloc_time = metric.range(rangex).alloc_time + (vclock() - enter_time);
		metric.range(rangex).alloc_count = metric.range(rangex).alloc_count + 1;
		metric.range(rangex).words_alloced = metric.range(rangex).words_alloced + s;
		metric.range(rangex).alloc_end_count = metric.range(rangex).alloc_end_count + endp;
		metric.range(rangex).alloc_new_count = metric.range(rangex).alloc_new_count + newp;
	     end;

	/* dispatch according to type of alloc */

	go to end_alloc_tv (esw);

end_alloc_tv (1):		/* apl_allocate_words_ */

	if trace_flags & trace_allocate_words
	then call ioa_$ioa_stream ("apl_trace_", "alloc words ^d ^p", s, p);

	if trace_flags & check_storage_manager
	then call check_storage_manager_$allocate (p, s);

	alloc_ptr = p;		/* just returns the bead */
	return;

end_alloc_tv (-1):		/* copy_apl_value_  (character) */

	p -> value_bead.data_pointer = addr (p -> value_bead.rho (from_ptr -> value_bead.rhorho + 1));
	if data_elements ^= 0			/* avoid illegal procedure fault (kludge hardware) */
	then p -> value_bead.data_pointer -> character_string_overlay = 
	     from_ptr -> value_bead.data_pointer -> character_string_overlay;
	go to copy_apl_value_alloc_return;

end_alloc_tv (0):		/* copy_apl_value_ (numeric) */

	p -> value_bead.data_pointer = addr (p -> value_bead.rho (from_ptr -> value_bead.rhorho + 1));
	if substr (rel (p -> value_bead.data_pointer), 18, 1)
	then p -> value_bead.data_pointer = addrel (p -> value_bead.data_pointer, 1);

	if data_elements ^= 0		/* avoid IPR fault */
	then p -> value_bead.data_pointer -> numeric_datum (*) =
	     from_ptr -> value_bead.data_pointer -> numeric_datum (*);
/*	go to copy_apl_value_alloc_return; */

copy_apl_value_alloc_return:

	if trace_flags & trace_copy_value
	then call ioa_$ioa_stream ("apl_trace_", "copy value ^p ^d ^p", from_ptr, s, p);

	if trace_flags & check_storage_manager
	then call check_storage_manager_$allocate (p, s);

	string (p -> value_bead.type) = string (from_ptr -> value_bead.type);	/* new bead has same type as old */
	p -> value_bead.rhorho = from_ptr -> value_bead.rhorho;
	if p -> value_bead.rhorho ^= 0	/* avoid IPR fault */
	then unspec (p -> value_bead.rho (*)) = unspec (from_ptr -> value_bead.rho (*));

	p -> value_bead.total_data_elements = from_ptr -> value_bead.total_data_elements;
	to_ptr = p;			/* set return arg */

	/* METER */

	if ws_info.meter_mode
	then do;
		metric.copy_apl_value_calls = metric.copy_apl_value_calls + 1;
		metric.copy_apl_value_time = metric.copy_apl_value_time + (vclock () - enter_time);
	     end;

	return;

/* This entry is called by the apl command to initialize apl's working storage. */

apl_initialize_storage_:
	entry ();

						/* set up map & global-data segment */
	segp = apl_segment_manager_$get ();
	global_storage_system_data_pointer, ws_info.alloc_free_info_ptr = segp;

						/* hash table is initially zero */
	last_map = addr (first_seg_map);		/* there are no maps, yet. */

	/* Initialize some metering data (no matter what ws_info.meter_mode says,
	   because it probably hasn't been set yet). Only range.size needs to be inited. */

	s = 2;
	do i = lbound (metric.range, 1) to hbound (metric.range, 1);
	     s = s * 2;
	     metric.range (i).size = s;
	end;

	return;

/* entry to destroy all of apl's free storage. called as dying gasp of an
   apl session. */

apl_dispose_of_storage_:
	entry ();

	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;
	do i = lbound (seg_list, 1) to hbound (seg_list, 1);
	     /* free up available segs & value stacks */

	     if seg_list (i).usage = 1 | seg_list (i).usage = 2
	     then call apl_segment_manager_$free ((seg_list (i).pointer));

	     /* free heaps of both kinds */

	     else if seg_list (i).usage = 3 | seg_list (i).usage = 4
		then call apl_segment_manager_$free ((seg_list (i).pointer -> seg_map.seg_ptr));
	end;

	/* flush the map & global-data segment */

	call apl_segment_manager_$free ((ws_info.alloc_free_info_ptr));

	/* flush ws_info */

	call apl_segment_manager_$free ((ws_info_ptr));
	apl_static_$ws_info_ptr = null;

	return;

/* this entry is called by the )CLEAR command */

apl_clear_storage_:
	entry ();

	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;

	if trace_flags & trace_clear_storage
	then call ioa_$ioa_stream ("apl_trace_", "storage cleared");

	if trace_flags & check_storage_manager
	then call check_storage_manager_$clear ();

	ws_info.dont_interrupt_storage_manager = "1"b;		/* inhibit interruptions while munging the map seg */

	do i = lbound (seg_list, 1) to hbound (seg_list, 1);
	     if seg_list (i).usage > 2		/* a heap of either type? */
	     then seg_list (i).pointer = seg_list (i).pointer -> seg_map.seg_ptr;

	     if seg_list (i).usage ^= 0		/* in use? */
	     then do;
		     call apl_segment_manager_$free ((seg_list (i).pointer));
		     seg_list (i).usage = 0;
		end;
	end;

	/* get rid of the maps in the global-data segment. make sure they really go,
	   because re-used map space is assumed to be zero. */

	last_map = addr (first_seg_map);
	call hcs_$truncate_seg (addr (last_map), binary (rel (last_map), 18), (0));

	current_little_bead_seg, current_big_bead_seg = 0;

	/* assign initial segment for the value stack */

	i = lbound (seg_list, 1);			/* always use first seg for value stack root. */
	go to g0017;				/* since we just gave 'em all back, re-fetch one. */

	/* entry to return number of words of storage in use */

apl_get_storage_usage_:
	entry (storage_usage);

dcl storage_usage fixed bin(30) aligned parameter;
dcl  seen_current_value_stack bit (1) aligned;

	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;

	storage_usage = 0;
	seen_current_value_stack = "0"b;
	p = ptr (value_stack_ptr, 0);			/* get ptr to base of current value stack */
	do sli = lbound(seg_list,1) to hbound(seg_list,1);
	     if seg_list (sli).usage > 2		/* big or little heaps */
	     then storage_usage = storage_usage + (sys_info$max_seg_size - seg_list (sli).words_free);
	     else if seg_list (sli).usage = 2		/* a stack segment */
		then if seen_current_value_stack	/* stacks are ordered: used used current free free */
		     then;			/* so ignore free value stacks */
		     else if p = seg_list (sli).pointer	/* if this is current */
			then do;
				storage_usage = storage_usage + fixed (rel (value_stack_ptr), 18);
				seen_current_value_stack = "1"b;
			     end;
			else storage_usage = storage_usage + (sys_info$max_seg_size - seg_list (sli).words_free);
	end;

	return;

	/* this entry is called when a segment of value stack is filled */

apl_get_value_stack_:
apl_get_next_value_stack_seg_:
	entry (amt_needed);

dcl amt_needed fixed bin(18) parameter;

	global_storage_system_data_pointer = ws_info.alloc_free_info_ptr;

	if trace_flags & trace_get_stack_seg
	then call ioa_$ioa_stream ("apl_trace_", "get stack seg ^d", amt_needed);

	/* METER - (not worth checking ws_info.meter_mode for) */

	metric.get_next_value_stack_seg_calls = metric.get_next_value_stack_seg_calls + 1;

	if amt_needed > sys_info$max_seg_size
	then call apl_system_error_ (apl_error_table_$wsfull_on_stack);

	ws_info.dont_interrupt_storage_manager = "1"b;	/* don't allow interrupts while munging seg_list */

	/* find current position in list of value_stack segs */

	p = ptr(value_stack_ptr, 0);
	do i = lbound(seg_list, 1) to hbound(seg_list, 1);
	     if seg_list (i).usage = 2		/* a value stack */
	     then if seg_list (i).pointer = p		/* this value stack */
		then go to g0015;
	end;

	call apl_system_error_(apl_error_table_$non_existent_stack);	/* ???!? */

g0015:						/* update for storage usage entry */
	seg_list (i).words_free = (sys_info$max_seg_size - fixed (rel (value_stack_ptr), 18));
	base = i+1;				/* remember first seg in list after current one */

	do i = base to hbound(seg_list, 1);
	     if seg_list (i).usage = 2		/* found old stack seg which can be re-used */
	     then do;
g0016:		     segp, value_stack_ptr = seg_list(i).pointer;
		     seg_list(i).usage = 2;
		     call hcs_$truncate_seg(segp, 0, (0));	/* may as well avoid extra paging */
		     go to unmask_and_return;
		end;
	end;

	do i = base to hbound(seg_list, 1);		/* need new seg */
	     if seg_list (i).usage = 1		/* aha! existing segment that can be reused */
	     then go to g0016;
	     else if seg_list (i).usage = 0		/* empty slot, fill it in */
		then do;
g0017:
			segp = apl_segment_manager_$get ();
			value_stack_ptr, seg_list(i).pointer = segp;
			seg_list(i).usage = 2;
			sli = i;
			call set_up_hash_table;
			go to unmask_and_return;
		     end;
	end;

	/* after a great struggle, still couldn't find any segments to use for a stack.  die die die */

	call apl_system_error_(apl_error_table_$wsfull_no_stack_segs);
	return;					/* will never be executed */

unmask_and_return:
	ws_info.dont_interrupt_storage_manager = "0"b;
	if ws_info.dirty_interrupt_pending then signal apl_dirty_stop_;
	return;

/* Internal procedure to find the node that is just less
   than (to the left of) the input node.  Knuth calls
   this the symmetric predecessor.  See Knuth Vol 3, 6.2.2. */

left_neighbor:
	procedure (bv_mapx) returns (fixed bin);

/* parameters */

dcl  bv_mapx fixed bin parameter;

/* automatic */

dcl  nodex fixed bin;

/* program */

	found = "0"b;
	nodex = 2 * bv_mapx;
	do while (^found);				/* go left once, then right */
	     if nodex > seg_map.last_entry_used
	     then found = "1"b;
	     else if string (map (nodex)) = ""b
		then found = "1"b;
		else nodex = 2 * nodex + 1;
	end;
	return (divide (nodex, 2, 18, 0));

     end left_neighbor;

/* Internal procedure to find the node that is just greater
   than (to the right of) the input node.  Knuth calls
   this the symmetric successor.  See Knuth Vol 3, 6.2.2. */

right_neighbor:
	procedure (bv_mapx) returns (fixed bin);

/* parameters */

dcl  bv_mapx fixed bin parameter;

/* automatic */

dcl  nodex fixed bin;

/* program */

	found = "0"b;
	nodex = 2 * bv_mapx + 1;
	do while (^found);				/* go right once, then left */
	     if nodex > seg_map.last_entry_used
	     then found = "1"b;
	     else if string (map (nodex)) = ""b
		then found = "1"b;
		else nodex = 2 * nodex;
	end;
	return (divide (nodex, 2, 18, 0));

     end right_neighbor;

/* Internal procedure to help apl_free_bead_ "wash" pointers to beads */

launder:
     procedure (afp);

/* parameters */

dcl  afp ptr unaligned parameter;

/* automatic */

dcl  fp ptr unaligned;

/* entries */

dcl  apl_free_bead_ entry (pointer unaligned);

/* program */

	fp = afp;					/* do losing unaligned copy only once */

	if fp = null 				/* can get null localized_symbols in a lexed_function_bead */
	then return;

	if fp -> general_bead.type.operator		/* these read-only beads are not subject to freeing */
	then return;

	fp -> general_bead.reference_count = fp -> general_bead.reference_count - 1;	/* wash this reference */
	afp = null;				/* .. */

	if fp -> general_bead.reference_count < 1
	then call apl_free_bead_ (fp);

     end launder;

compute_range:
	procedure;

/* given size s, this routine computes proper metric.range entry, returns iss index in rangex */

	do rangex = lbound (metric.range, 1) to hbound (metric.range, 1) - 1;
	     if s < metric.range (rangex + 1).size	/* found proper range */
	     then return;
	end;

	return;			/* rangex == hbound (metric.range, 1) */

end compute_range;

	/* finds a segment, returns segp and sli, and sets up hash_table if necessary. */

get_seg_for_apl:
	procedure;

	new_slot = 0;
	do sli = lbound(seg_list, 1) to hbound(seg_list, 1);
	   if seg_list(sli).usage = 1 	/* available seg */
	      then do;
		segp = seg_list(sli).pointer;
		return;
		end;
	   else if seg_list(sli).usage = 0 then new_slot = sli;	/* save loc of last free slot in seg_list */
	   end;

	/* evidently no usage = 1 segs, need to get a completely new one */

	if new_slot = 0 then call apl_system_error_(apl_error_table_$wsfull_out_of_segs);

	sli = new_slot;
	segp = apl_segment_manager_$get ();
	seg_list(sli).pointer = segp;
	call set_up_hash_table;

end get_seg_for_apl;

set_up_hash_table:		/* put segment indicated by segp and sli into hash table */
	procedure;

dcl hash_index fixed bin,
    i fixed bin;

	hash_index = mod(fixed(baseno(segp), 18), dim(seg_map_hash_table, 1));
	do i = hash_index by 1 while (i <= hbound(seg_map_hash_table, 1)),
	       lbound(seg_map_hash_table, 1) by 1 while (i < hash_index);
	   if seg_map_hash_table(i).seg_list_idx = 0
	      then do;
		seg_map_hash_table(i).seg_list_idx = sli;
		seg_map_hash_table(i).seg_baseno = baseno(segp);
		return;
		end;
	   end;
	call apl_system_error_(apl_error_table_$hash_table_full);	/* cannot happen! */
end set_up_hash_table;

     end /* apl_storage_manager_ */;




		    apl_subscript_a_value_.pl1      11/29/83  1638.6r w 11/29/83  1347.2      117801



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

/* Program to implement APL subscripting and subscripted assignment.
   Written by Dan Bricklin, Summer, 1973.
   Modified 740909 by PG for new value bead declaration.
   Modified 741125 by PG to allow an effective scalar on the right-hand-size of a subscripted assignment
	to be extended to cover the shape of the left-hand-side.
   Modified 770301 by PG to fix bug 270 (giving RANK ERROR instead of LENGTH ERROR).
   Modified 780210 by PG to fix bug 278 by calling apl_push_stack_.
*/

apl_subscript_a_value_:
	procedure (operators_argument);

/* builtins */

declare	(abs, addr, addrel, bool, fixed, floor, null, rel, size, substr, string) builtin;

/* declarations */

dcl
	increment fixed bin,
	from_subscript fixed bin (21),
	parse_frame_ptr ptr,
	value_ptr ptr,
	list_ptr ptr,
	old_rhorho fixed bin,
	n_words fixed bin (19),
	subscript_scratch_ptr ptr,

	1 subscript_scratch (old_rhorho) aligned based (subscript_scratch_ptr),
	   2 entry fixed bin,
	   2 multiplier fixed bin,
	   2 subscripted_value_rho fixed bin,
	   2 value_bead_data_ptr ptr unaligned,
	   2 max_value fixed bin,
	   2 null_entry bit (1) aligned,
	   2 is_integer bit (1) aligned,

	value_is_numeric bit (1) aligned,
	new_rhorho fixed bin,
	data_elements fixed bin (21),
	i fixed bin (21),
	multiplier_temp fixed bin,
	temp_member_ptr ptr,
	temp_ptr ptr,
	float_index_origin float,
	integer_fuzz float,
	from_data_ptr ptr,
	which_element fixed bin (21),
	carry bit (1) aligned,
	j fixed bin,
	float_subscript float,
	float_temp float,
	fixed_subscript fixed bin (21),
	result_data_ptr ptr,
	result_ptr ptr,
	counter fixed bin,
	final_ptr ptr,
	apl_free_bead_ entry (ptr unaligned),
	apl_copy_value_ entry (ptr unaligned, ptr unaligned),
	final_data_ptr ptr,

	assigner fixed bin int static init (-1),
	assignee fixed bin int static init (1),
	list fixed bin int static init (0),
	assigner_ptr ptr,
	assignee_ptr ptr;

/* external static */

dcl	(apl_error_table_$index,
	apl_error_table_$length,
	apl_error_table_$value,
	apl_error_table_$assign_to_value,
	apl_error_table_$domain,
	apl_error_table_$rank) fixed bin (35) external static;

/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_parse_frame;
%include apl_bead_format;
%include apl_operator_bead;
%include apl_symbol_bead;
%include apl_lexed_function_bead;
%include apl_operators_argument;
%include apl_value_bead;
%include apl_list_bead;

/* program */

	value_ptr = operators_argument.value (1);
	list_ptr = operators_argument.value (2);

	old_rhorho = list_ptr -> list_bead.number_of_members;

	if old_rhorho^=value_ptr -> value_bead.rhorho then go to rank_error;

	n_words = size (subscript_scratch);
	subscript_scratch_ptr = apl_push_stack_ (n_words);

	value_is_numeric = value_ptr -> value_bead.numeric_value;
	call fill_in_scratch;

	call stack_allocate;

	float_index_origin = ws_info.index_origin;
	integer_fuzz = ws_info.integer_fuzz;
	from_data_ptr = value_ptr -> value_bead.data_pointer;

	entry (old_rhorho) = 0;

	do i = 0 by 1 while (i < data_elements);
	   call do_subscripting;

	   if value_is_numeric then result_data_ptr -> numeric_datum (i) = from_data_ptr -> numeric_datum (which_element);
	   else result_data_ptr -> character_datum (i) = from_data_ptr -> character_datum (which_element);

	end;

	call clean_up_list_bead;

	call copy_up;

	return;

fill_in_scratch:
	proc;

	new_rhorho = 0;
	data_elements = 1;
	multiplier_temp = 1;

	do i = old_rhorho to 1 by -1;
	   multiplier (i) = multiplier_temp;
	   entry (i) = 1;

	   temp_member_ptr = list_ptr -> list_bead.member_ptr (i);

	   if temp_member_ptr=null then do;
	      subscripted_value_rho (i), max_value (i) = value_ptr -> value_bead.rho (i);
	      data_elements = data_elements * max_value (i);
	      new_rhorho = new_rhorho + 1;
	      null_entry (i) = "1"b;
	      end;
	   else do;
	      max_value (i) = temp_member_ptr -> value_bead.total_data_elements;
	      data_elements = data_elements * max_value (i);
	      value_bead_data_ptr (i) = temp_member_ptr -> value_bead.data_pointer;
	      subscripted_value_rho (i) = value_ptr -> value_bead.rho (i);
	      if temp_member_ptr -> value_bead.integral_value then is_integer (i) = "1"b;
	      else if temp_member_ptr -> value_bead.character_value then go to domain_error;
	      else is_integer (i) = "0"b;
	      new_rhorho = new_rhorho + temp_member_ptr -> value_bead.rhorho;
	      null_entry (i) = "0"b;
	      end;

	   multiplier_temp = multiplier_temp * subscripted_value_rho (i);

	   end;

	return;

	end;

stack_allocate:
	proc;

	if value_is_numeric then n_words = size (numeric_datum) + 1;
	else n_words = size (character_string_overlay);

	number_of_dimensions = new_rhorho;
	n_words = n_words + size (value_bead);
	result_ptr = apl_push_stack_ (n_words);

	result_data_ptr = addr (result_ptr -> value_bead.rho (new_rhorho + 1));
	if value_is_numeric then if substr (rel (result_data_ptr),18,1) then
	   result_data_ptr = addrel (result_data_ptr, 1);

	result_ptr -> value_bead.data_pointer = result_data_ptr;
	string (result_ptr -> value_bead.type) = string (value_ptr -> value_bead.type);
	result_ptr -> value_bead.total_data_elements = data_elements;
	result_ptr -> value_bead.rhorho = new_rhorho;

	counter = 0;
	do i = 1 to old_rhorho;
	   if null_entry (i) then do;
	      counter = counter + 1;
	      result_ptr -> value_bead.rho (counter) = subscripted_value_rho (i);
	      end;
	   else do;
	      temp_member_ptr = list_ptr -> list_bead.member_ptr (i);
	      do j = 1 to temp_member_ptr -> value_bead.rhorho;
	         counter = counter + 1;
	         result_ptr -> value_bead.rho (counter) = temp_member_ptr -> value_bead.rho (j);
	         end;
	      end;
	   end;

	return;

	end;

do_subscripting:
	proc;

	which_element = 0;
	carry = "1"b;

	do j = old_rhorho to 1 by -1;

	   if carry then do;
	      entry (j) = entry (j) + 1;
	      if entry (j)>max_value (j) then entry (j) = 1;
	      else carry = "0"b;
	      end;

	   if null_entry (j) then which_element = which_element + (entry (j) - 1) * multiplier (j);
	   else do;
	      float_subscript = value_bead_data_ptr (j) -> numeric_datum (entry (j) - 1) - float_index_origin;
	      if is_integer (j) then fixed_subscript = fixed (float_subscript);
	      else do;
		  float_temp = floor (float_subscript + 0.5);
		  if abs (float_temp - float_subscript) > integer_fuzz then go to index_error;
		  if abs (float_temp) > 1e21b then go to index_error;
		  fixed_subscript = fixed (float_temp);
		  end;
	      if fixed_subscript<0 then go to index_error;
	      if fixed_subscript>=subscripted_value_rho (j) then go to index_error;
	      which_element = which_element + fixed_subscript * multiplier (j);
	      end;

	   end;


	end;

clean_up_list_bead:
	proc;


	final_ptr = list_ptr;

	do i = 1 to list_ptr -> list_bead.number_of_members;
	     temp_member_ptr = list_ptr -> list_bead.member_ptr (i);
	     if temp_member_ptr ^= null
	     then if list_ptr -> list_bead.bits (i).semantics_on_stack
		then final_ptr = temp_member_ptr;
		else do;
			temp_member_ptr -> general_bead.reference_count = temp_member_ptr -> general_bead.reference_count - 1;
			if temp_member_ptr -> general_bead.reference_count < 1
			then call apl_free_bead_ ((temp_member_ptr));
		     end;
	end;

	ws_info.value_stack_ptr = final_ptr;		/* pop list bead & friends */
	return;

	end;

copy_up:
	proc;

	final_ptr = apl_push_stack_ (n_words);

	string (final_ptr -> value_bead.type) = string (result_ptr -> value_bead.type);
	final_ptr -> value_bead.total_data_elements = result_ptr -> value_bead.total_data_elements;
	final_ptr -> value_bead.total_data_elements = data_elements;
	final_ptr -> value_bead.rhorho = new_rhorho;
	do i = 1 to new_rhorho;
	   final_ptr -> value_bead.rho (i) = result_ptr -> value_bead.rho (i);
	   end;

	final_data_ptr = addr (final_ptr -> value_bead.rho (new_rhorho + 1));
	if value_is_numeric then do;
	   if substr (rel (final_data_ptr),18,1) then final_data_ptr = addrel (final_data_ptr, 1);
	   final_data_ptr -> numeric_datum (*) = result_data_ptr -> numeric_datum (*);
	   end;
	else final_data_ptr -> character_string_overlay = result_data_ptr -> character_string_overlay;

	final_ptr -> value_bead.data_pointer = final_data_ptr;

	operators_argument.result = final_ptr;

	return;

	end;

rank_error:
	operators_argument.error_code = apl_error_table_$rank;
	return;

index_error:
	operators_argument.error_code = apl_error_table_$index;
	return;

domain_error:
	operators_argument.error_code = apl_error_table_$domain;
	return;

cant_assign_to_value:
	operators_argument.error_code = apl_error_table_$assign_to_value;
	return;

length_error:
	operators_argument.error_code = apl_error_table_$length;
	return;

value_error_right:
	operators_argument.where_error = operators_argument.where_error - 2;

value_error_left:
	operators_argument.where_error = operators_argument.where_error + 1;
	operators_argument.error_code = apl_error_table_$value;
	return;

apl_subscripted_assignment_:
	entry (operators_argument, rs_ptr);


dcl
	rs_ptr ptr,
	1 rs (1000) aligned based (rs_ptr),
	   2 type fixed bin,
	   2 bits unaligned like operator_bead.bits_for_parse,
	   2 semantics ptr unaligned,
	   2 lexeme fixed bin;

	if rs (assigner).semantics = null
	then go to value_error_right;

	if rs (assignee).semantics = null
	then go to value_error_left;

	if rs (assignee).semantics_on_stack then go to cant_assign_to_value;
	temp_ptr = current_parse_frame_ptr -> parse_frame.lexed_function_bead_ptr -> lexed_function_bead.lexeme_array_ptr ->
	   lexed_function_lexeme_array (rs (assignee).lexeme);
	if ^temp_ptr -> general_bead.symbol then go to cant_assign_to_value;
	if temp_ptr -> meaning_pointer -> general_bead.reference_count>2 then do;
	   temp_ptr -> meaning_pointer -> general_bead.reference_count =
	      temp_ptr -> meaning_pointer -> general_bead.reference_count - 1;
	   call apl_copy_value_ ( (temp_ptr -> meaning_pointer), temp_ptr -> meaning_pointer);
	   temp_ptr -> meaning_pointer -> general_bead.reference_count =
	      temp_ptr -> meaning_pointer -> general_bead.reference_count + 1;
	   rs (assignee).semantics = temp_ptr -> meaning_pointer;
	   end;

	assigner_ptr = rs (assigner).semantics;
	assignee_ptr = rs (assignee).semantics;
	list_ptr = rs (list).semantics;

	old_rhorho = list_ptr -> list_bead.number_of_members;
	if old_rhorho^=assignee_ptr -> value_bead.rhorho then go to rank_error;

	/* Allocate scratch vector. It will get popped when list bead is popped */

	n_words = size (subscript_scratch);
	subscript_scratch_ptr = apl_push_stack_ (n_words);

	value_is_numeric = assignee_ptr -> value_bead.numeric_value;
	if bool (value_is_numeric, assigner_ptr -> value_bead.numeric_value, "0110"b) then go to domain_error;

	string (assignee_ptr -> value_bead.data_type) = string (assignee_ptr -> value_bead.data_type) &
	     string (assigner_ptr -> value_bead.data_type);

	value_ptr = assignee_ptr;

	call fill_in_scratch;

	if assigner_ptr -> value_bead.total_data_elements = 1	/* an effective scalar */
	then increment = 0;
	else do;
		counter = 0;
		do i = 1 to old_rhorho;
		     if null_entry (i)
		     then do;
			     counter = counter + 1;
			     if subscripted_value_rho (i)^=assigner_ptr -> value_bead.rho (counter)
			     then go to length_error;
			end;
		     else do;
			     temp_member_ptr = list_ptr -> list_bead.member_ptr (i);
			     do j = 1 to temp_member_ptr -> value_bead.rhorho;
grace_to_one_rhos:
				counter = counter + 1;
				if assigner_ptr -> value_bead.rho (counter)^=temp_member_ptr -> value_bead.rho (j)
				then do;
					if assigner_ptr -> value_bead.rho (counter)=1
					then go to grace_to_one_rhos;
					go to length_error;
				     end;
			     end;
			end;
		end;
		increment = 1;
	     end;

	float_index_origin = ws_info.index_origin;
	integer_fuzz = ws_info.integer_fuzz;
	from_data_ptr = assigner_ptr -> value_bead.data_pointer;
	result_data_ptr = assignee_ptr -> value_bead.data_pointer;

	entry (old_rhorho) = 0;
	from_subscript = 0;

	do i = 0 by 1 while (i < data_elements);
	     call do_subscripting;

	     if value_is_numeric
	     then result_data_ptr -> numeric_datum (which_element) = from_data_ptr -> numeric_datum (from_subscript);
	     else result_data_ptr -> character_datum (which_element) = from_data_ptr -> character_datum (from_subscript);

	     from_subscript = from_subscript + increment;
	end;

	call clean_up_list_bead;

	assignee_ptr -> general_bead.reference_count = assignee_ptr -> general_bead.reference_count - 1;

	return;

%include apl_push_stack_fcn;
     end /* apl_subscript_a_value_ */;




		    apl_system_functions_.pl1       11/29/83  1638.6rew 11/29/83  1347.3      239661



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



apl_system_functions_:
     procedure (operators_argument);

/*
 * this routine implements those functions of APL whose names begin with a Quad:
 *  QuadCR, QuadDL, QuadEX, QuadFX, QuadNC, QuadNL, QuadEC, QuadAF.
 *
 * Written 73.8.22 by DAM
 * Modified 740909 by PG for new value bead declaration, and to finish QuadEC and some of QuadAF.
   Modified 781208 by PG to switch to new clock builtin
   Modified 790308 by William M. York to double-word align all value beads
	and implement qAF. 
   Modified 791219 by PG to fix 430 (qEC and qAF return invalid value_beads when no error occurs).
   Modified 800130 by PG to fix 441 (qAF returns with ws_info.vsp one word too low).
   Modified 800814 by WMY to fix 469 (qAF does not trap active_function_error).
   Modified: 8 July 1982 by GMP to use cu_$evaluate_active_string rather than cu_$af
 */


/* pick up right operand and dispatch to routine for the particular function */

	right_vb = operands (2).value;
	right = right_vb -> value_bead.data_pointer;

	go to fcn (operators_argument.op1);

fcn (63):						/* QuadDL - delay n seconds, return number of seconds of actual delay */
	number_type = numeric_value_type;
	if ^right_vb -> value_bead.data_type.numeric_value
	then go to domain_error_right;
	if right_vb -> value_bead.total_data_elements ^= 1
	then go to domain_error_right;

	if right -> numeric_datum (0) <= 0
	then do;					/* don't delay */
		apl_number = 0;
		go to return_apl_number_monadic;
	     end;

	start_of_sleep_time = clock ();
	on apl_quit_ go to quat_out_of_delay;		/* set up handler so loser can terminate the delay */
	call timer_manager_$sleep (fixed (right -> numeric_datum (0) * 1e6, 71), "10"b);
quat_out_of_delay:
	revert apl_quit_;

	apl_number = float (clock () - start_of_sleep_time) / 1e6;
						/* actual length of delay */

return_apl_number_monadic:
	if operands (2).on_stack
	then value_stack_ptr = right_vb;

	number_of_dimensions = 0;
	n_words = size (value_bead) + size (apl_number) + 1;
	result_vb = apl_push_stack_ (n_words);
	operators_argument.result = result_vb;

	string (result_vb -> value_bead.type) = number_type;
	result_vb -> value_bead.total_data_elements = 1;
	result_vb -> value_bead.rhorho = 0;
	result = addr (result_vb -> value_bead.rho (1));
	if substr (rel (result), 18, 1)
	then result = addrel (result, 1);
	result_vb -> value_bead.data_pointer = result;
	result -> numeric_datum (0) = apl_number;
	return;

fcn (58):						/* QuadCR - return character representation of function */
	if ^right_vb -> value_bead.data_type.character_value
	then go to domain_error_right;
	if right_vb -> value_bead.rhorho > 1
	then go to quad_cr_lose;
	data_elements = right_vb -> value_bead.total_data_elements;
	name_len = data_elements;
	name_pos = 0;
	call check_name;
	if name_no_good
	then go to quad_cr_lose;

	if sbp -> symbol_bead.meaning_pointer = null
	then go to quad_cr_lose_and_wash_sbp;
	if ^sbp -> symbol_bead.meaning_pointer -> general_bead.type.function
	then go to quad_cr_lose_and_wash_sbp;
	if sbp -> symbol_bead.meaning_pointer -> function_bead.class ^= 0
	then go to quad_cr_lose_and_wash_sbp;

/* got text of function.  In order to convert to matrix form, must first find number
	   of lines and maximum line length */

	max_line_length = 0;
	number_of_lines = 0;
	do line_pos = 0 repeat (line_pos + this_line_length)
	     while (line_pos < sbp -> symbol_bead.meaning_pointer -> function_bead.text_length);
	     this_line_length =
		index (substr (sbp -> symbol_bead.meaning_pointer -> function_bead.text, line_pos + 1), QNewLine);
	     if this_line_length > max_line_length
	     then max_line_length = this_line_length;
	     number_of_lines = number_of_lines + 1;
	end;

	max_line_length = max_line_length - 1;		/* because we will throw away the newlines */

	data_elements = number_of_lines * max_line_length;
	if operands (2).on_stack
	then value_stack_ptr = right_vb;		/* no longer need operand */

	call alloc_chars_on_stack (2);

	result_vb -> value_bead.rho (1) = number_of_lines;
	result_vb -> value_bead.rho (2) = max_line_length;

/* now copy in the lines of the function, stripping newlines and padding with spaces on the right */

	line_pos = 0;
	do line_number = 0 by 1 while (line_number < number_of_lines);

	     this_line_length =
		index (substr (sbp -> symbol_bead.meaning_pointer -> function_bead.text, line_pos + 1), QNewLine);
	     substr (result -> character_string_overlay, line_number * max_line_length + 1, max_line_length) =
		substr (sbp -> symbol_bead.meaning_pointer -> function_bead.text, line_pos + 1, this_line_length - 1);
	     line_pos = line_pos + this_line_length;
	end;

	call wash_sbp;
	return;


quad_cr_lose_and_wash_sbp:
	call wash_sbp;

quad_cr_lose:					/* name is not unlocked function, return a 0 by 0 character matrix */
	data_elements = 0;
	if operands (2).on_stack
	then value_stack_ptr = right_vb;
	call alloc_chars_on_stack (2);
	result_vb -> value_bead.rho (1), result_vb -> value_bead.rho (2) = 0;
	return;



wash_sbp:
     proc;

	sbp -> symbol_bead.reference_count = sbp -> symbol_bead.reference_count - 1;
	if sbp -> symbol_bead.reference_count <= 0
	then call apl_free_bead_ (sbp);
     end wash_sbp;

/* here we insert some stack allocation routines */

alloc_chars_on_stack:				/* scalar/vector/matrix of chars */
     procedure (n_dims);

/* parameters */

declare	n_dims		fixed bin;

/* program */

	number_of_dimensions = n_dims;
	n_words = size (value_bead) + size (character_string_overlay);

	result_vb = apl_push_stack_ (n_words);
	operators_argument.result = result_vb;

	value_stack_ptr = addrel (result_vb, n_words);
	string (result_vb -> value_bead.type) = character_value_type;
	result_vb -> value_bead.rhorho = number_of_dimensions;
	result_vb -> value_bead.total_data_elements = data_elements;
	result_vb -> value_bead.data_pointer, result = addrel (result_vb, size (value_bead));

     end alloc_chars_on_stack;


alloc_numbers_on_stack:
     proc;					/* vector of numbers */

	number_of_dimensions = 1;
	n_words = size (value_bead) + size (numeric_datum) + 1;

	result_vb = apl_push_stack_ (n_words);
	operators_argument.result = result_vb;

	string (result_vb -> value_bead.type) = numeric_value_type;
	result_vb -> value_bead.total_data_elements, result_vb -> value_bead.rho (1) = data_elements;
	result_vb -> value_bead.rhorho = 1;
	result = addrel (result_vb, size (value_bead));

	if substr (rel (result), 18, 1)
	then result = addrel (result, 1);

	result_vb -> value_bead.data_pointer = result;

     end alloc_numbers_on_stack;

%include apl_push_stack_fcn;

fcn (62):						/* QuadNC - returns type of use of names */
	number_type = integral_value_type;
	if ^right_vb -> value_bead.data_type.character_value
	then go to domain_error_right;
	if right_vb -> value_bead.rhorho = 2
	then do;

/* arg is matrix, process multiple names and return vector */

		data_elements = right_vb -> value_bead.rho (1);
		call alloc_numbers_on_stack;

		name_len = right_vb -> value_bead.rho (2);
		do which_name = 0 by 1 while (which_name < right_vb -> value_bead.rho (1));
		     name_pos = name_len * which_name;
		     call compute_name_usage;
		     result -> numeric_datum (which_name) = apl_number;
		end;

/* now do copy-up if necessary */

copy_up_numbers:
		if ^operands (2).on_stack
		then return;			/* if no need to copy up */

		value_stack_ptr = right_vb;
		final_result_vb = apl_push_stack_ (n_words);
						/* n_words is already set */

		string (final_result_vb -> value_bead.type) = string (result_vb -> value_bead.type);
		final_result_vb -> value_bead.total_data_elements = result_vb -> value_bead.total_data_elements;
		final_result_vb -> value_bead.rhorho = result_vb -> value_bead.rhorho;
		if final_result_vb -> value_bead.rhorho ^= 0
		then final_result_vb -> value_bead.rho (*) = result_vb -> value_bead.rho (*);

		final_result = addr (final_result_vb -> value_bead.rho (final_result_vb -> value_bead.rhorho + 1));
		if substr (rel (final_result), 18, 1)
		then final_result = addrel (final_result, 1);
		final_result_vb -> value_bead.data_pointer = final_result;

		if data_elements ^= 0
		then /* EIS bug */
		     final_result -> numeric_datum (*) = result -> numeric_datum (*);

		operators_argument.result = final_result_vb;
		return;
	     end;

/* continuation of QuadNC */

	else if right_vb -> value_bead.rhorho > 2
	then go to domain_error_right;

	else do;

/* arg is vector (or scalar, which is length-1 vector) */

		name_len = right_vb -> value_bead.total_data_elements;
		name_pos = 0;
		call compute_name_usage;
		go to return_apl_number_monadic;
	     end;



compute_name_usage:
     proc;

	call check_name;
	if name_no_good
	then apl_number = 4;
	else do;


		if sbp -> symbol_bead.meaning_pointer = null
		then apl_number = 0;
		else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.label
		then apl_number = 1;
		else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.value
		then apl_number = 2;
		else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.function
		then apl_number = 3;
		else apl_number = 4;

		call wash_sbp;
	     end;
     end compute_name_usage;


check_name:
     proc;

dcl	name_string	char (name_pos + name_len) aligned based (right);
						/* portion of right -> character_string_overlay
							   which does not go too far past name */

	call apl_scan_ (name_string, name_pos + 1, token_pos, token_len, token_type, null);
	if token_type ^= 2
	then do;
		name_no_good = "1"b;
		return;
	     end;
	call apl_scan_ (name_string, token_pos + token_len, (0), (1), token_type, null);
	if token_type ^= 0
	then do;
		name_no_good = "1"b;
		return;
	     end;					/* the "name" actually consists of a name and nothing else (except maybe white space) */

	call apl_get_symbol_ (substr (right -> character_string_overlay, token_pos, token_len), sbp, (0));
	name_no_good = "0"b;
	return;
     end check_name;

fcn (61):						/* QuadNL - list names of specified type */
	left_vb = operands (1).value;
	if left_vb ^= null
	then do;

/* dyadic QuadNL */

		if ^left_vb -> value_bead.data_type.character_value
		then go to domain_error_left;
		if left_vb -> value_bead.rhorho > 1
		then go to domain_error_left;

		left = left_vb -> value_bead.data_pointer;
		left_size = left_vb -> value_bead.total_data_elements;
	     end;

/* process right arg */

	do_labels, do_variables, do_functions = "0"b;
	if ^right_vb -> value_bead.data_type.numeric_value
	then go to domain_error_right;
	if right_vb -> value_bead.rhorho > 1
	then go to domain_error_right;

	do i = 0 by 1 while (i < right_vb -> value_bead.total_data_elements);
	     float_temp = floor (right -> numeric_datum (i) + 0.5);
	     if abs (float_temp - right -> numeric_datum (i)) > integer_fuzz
	     then go to domain_error_right;
	     if abs (float_temp) >= 1e17b
	     then go to domain_error_right;
	     fixnum = fixed (float_temp, 17);
	     if fixnum = 1
	     then do_labels = "1"b;
	     else if fixnum = 2
	     then do_variables = "1"b;
	     else if fixnum = 3
	     then do_functions = "1"b;
	     else go to domain_error_right;
	end;

/* right arg no longer needed, pop it off stack */

	if operands (2).on_stack
	then if left_vb = null
	     then value_stack_ptr = right_vb;
	     else if ^operands (1).on_stack
	     then value_stack_ptr = right_vb;

/* set up to compute size of result */

	n_rows, n_cols = 0;
	do pass = 1, 2;				/* first pass computes dimensions of result, second fills it in */

/* scan through all the symbol beads in the world */

	     do htpos = lbound (symbol_table.hash_bucket_ptr, 1) to hbound (symbol_table.hash_bucket_ptr, 1);

		do sbp = symbol_table.hash_bucket_ptr (htpos) repeat (sbp -> symbol_bead.hash_link_pointer)
		     while (sbp ^= null);

/* check alphabetic category */

		     if left_vb ^= null
		     then if index (substr (left -> character_string_overlay, 1, left_size),
			     substr (sbp -> symbol_bead.name, 1, 1)) = 0
			then go to skip_this_symbol;

/* check meaning category */

		     if sbp -> symbol_bead.meaning_pointer ^= null
		     then if sbp -> symbol_bead.meaning_pointer -> general_bead.type.label
			then if do_labels
			     then call do_this_symbol;
			     else ;
			else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.value
			then if do_variables
			     then call do_this_symbol;
			     else ;
			else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.function
			then if do_functions
			     then call do_this_symbol;
			     else ;

skip_this_symbol:
		end;

	     end;

do_this_symbol:
     proc;

	if pass = 1
	then do;
		n_rows = n_rows + 1;
		if sbp -> symbol_bead.name_length > n_cols
		then n_cols = sbp -> symbol_bead.name_length;
	     end;
	else do;
		substr (result -> character_string_overlay, line_pos + 1, n_cols) = sbp -> symbol_bead.name;
		line_pos = line_pos + n_cols;
	     end;
     end do_this_symbol;

	     if pass = 1
	     then do;

/* end of pass 1, allocate result */

		     data_elements = n_rows * n_cols;

/* reuse left arg space if on stack */

		     if left_vb ^= null
		     then if operands (1).on_stack
			then if operands (2).on_stack
			     then value_stack_ptr = right_vb;
			     else value_stack_ptr = left_vb;

		     call alloc_chars_on_stack (2);

		     result_vb -> value_bead.rho (1) = n_rows;
		     result_vb -> value_bead.rho (2) = n_cols;

		     line_pos = 0;			/* initialize for next pass */

/* special kludge to allow doing in place - move left arg up if necc */

		     if left_vb ^= null
		     then if operands (1).on_stack
			then do;

				data_elements = left_size;
				n_words = size (character_string_overlay);

				final_result = apl_push_stack_ (n_words);

				if data_elements ^= 0
				then /* EIS bug */
				     final_result -> character_string_overlay = left -> character_string_overlay;
				left = final_result;
			     end;

		end;

	end;
	return;

fcn (60):						/* QuadEX - expunge a name */
	number_type = zero_or_one_value_type;
	if ^right_vb -> value_bead.data_type.character_value
	then go to domain_error_right;
	if right_vb -> value_bead.rhorho = 2
	then do;

/* matrix of names is arg */

		data_elements = right_vb -> value_bead.rho (1);
						/* number of names */
		call alloc_numbers_on_stack;
		name_len = right_vb -> value_bead.rho (2);
		do which_name = 0 by 1 while (which_name < right_vb -> value_bead.rho (1));
		     name_pos = name_len * which_name;
		     call expunge_name;
		     result -> numeric_datum (which_name) = apl_number;
		end;
		go to copy_up_numbers;
	     end;

	else if right_vb -> value_bead.rhorho > 2
	then go to domain_error_right;
	else do;

/* arg is 1 name (vector) */

		name_len = right_vb -> value_bead.total_data_elements;
		name_pos = 0;
		call expunge_name;
		go to return_apl_number_monadic;
	     end;
expunge_name:
     proc;

	call check_name;
	if name_no_good
	then apl_number = 0;

	else if sbp -> symbol_bead.meaning_pointer = null
	then apl_number = 1;
	else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.label
	then apl_number = 0;
	else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.value
	then do;

/* expunge a non-label value */

expunge_meaning:
		sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count =
		     sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count - 1;
		if sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count <= 0
		then call apl_free_bead_ (sbp -> symbol_bead.meaning_pointer);
		sbp -> symbol_bead.meaning_pointer = null;
		apl_number = 1;
	     end;
	else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.function
	then /* expunging a function, first check if allowed to */
	     if apl_pendant_function_check_ (sbp -> symbol_bead.meaning_pointer) = "0"b
	     then go to expunge_meaning;
	     else apl_number = 0;			/* not allowed, return 0 */

	else apl_number = 0;			/* other cruft cannot be expunged */

     end expunge_name;

fcn (59):						/* QuadFX - fix definition of function */
	if ^right_vb -> value_bead.data_type.character_value
	then go to domain_error_right;
	if right_vb -> value_bead.rhorho ^= 2
	then go to domain_error_right;

	n_rows = right_vb -> value_bead.rho (1);
	n_cols = right_vb -> value_bead.rho (2);

/* first step is to put in NewLines and strip off trailing spaces */

	value_stack_popper = value_stack_ptr;
	fcn_text_ptr = value_stack_ptr;
	space_left_in_stack = 4 * (maximum_value_stack_size - fixed (rel (fcn_text_ptr), 18));

	out_pos = 0;
	do in_row = 0 by 1 while (in_row < n_rows);
	     row_pos = in_row * n_cols;
	     do row_length = n_cols by -1 while (row_length > 0);
						/* strip trailing Spaces */
		if substr (right -> character_string_overlay, row_pos + row_length - 1 + 1, 1) ^= QSpace
		then go to exitloop;
	     end;
exitloop:
	     space_left_in_stack = space_left_in_stack - (row_length + 1);
	     if space_left_in_stack < 0
	     then do;				/* stack full, switch segs */
		     call apl_get_next_value_stack_seg_ (divide (out_pos + row_length + 1 + 3, 4, 18, 0));
		     value_stack_ptr -> fcn_text = fcn_text_ptr -> fcn_text;
		     fcn_text_ptr = value_stack_ptr;
		     space_left_in_stack = 4 * (maximum_value_stack_size - fixed (rel (fcn_text_ptr), 18));
		end;
	     substr (fcn_text_ptr -> fcn_text, out_pos + 1, row_length) =
		substr (right -> character_string_overlay, row_pos + 1, row_length);
	     substr (fcn_text_ptr -> fcn_text, out_pos + row_length + 1, 1) = QNewLine;
	     out_pos = out_pos + (row_length + 1);
	end;

/* second step is to construct function bead, set fbp */

	data_elements = out_pos;
	call apl_allocate_words_ (size (function_bead), fbp);
	string (fbp -> function_bead.type) = function_type;
	fbp -> function_bead.lexed_function_bead_pointer = null;
	fbp -> function_bead.class = 0;
	fbp -> function_bead.stop_control_pointer, fbp -> function_bead.trace_control_pointer = null;
	fbp -> function_bead.text_length = data_elements;
	fbp -> function_bead.text = fcn_text_ptr -> fcn_text;
	value_stack_ptr = value_stack_popper;

	call apl_function_lex_no_messages_ (fbp -> function_bead.text, lfbp, errors_occurred, 0,
	     addr (current_parse_frame_ptr -> parse_frame.reduction_stack_ptr
	     -> reduction_stack (current_parse_frame_ptr -> parse_frame.current_parseme + 1)), error_line);

	if errors_occurred
	then do;					/* syntax error */
		apl_number = error_line + index_origin;
		call wash_fbp;
		number_type = integral_value_type;
		go to return_apl_number_monadic;
	     end;

	fbp -> function_bead.lexed_function_bead_pointer = lfbp;
	sbp = lfbp -> lexed_function_bead.name;		/* name of function being fixed */
	if sbp -> symbol_bead.meaning_pointer = null
	then sbp -> symbol_bead.meaning_pointer = fbp;
	else if sbp -> symbol_bead.meaning_pointer -> general_bead.type.function
	then if apl_pendant_function_check_ (sbp -> symbol_bead.meaning_pointer)
	     then go to cant_fix;
	     else do;
		     sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count =
			sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count - 1;
		     if sbp -> symbol_bead.meaning_pointer -> general_bead.reference_count <= 0
		     then call apl_free_bead_ (sbp -> symbol_bead.meaning_pointer);
		     sbp -> symbol_bead.meaning_pointer = fbp;
		end;
	else go to cant_fix;

/* return name of function, as character vector */

	data_elements = sbp -> symbol_bead.name_length;
	if operands (2).on_stack
	then value_stack_ptr = right_vb;
	if data_elements = 1
	then call alloc_chars_on_stack (0);
	else do;
		call alloc_chars_on_stack (1);
		result_vb -> value_bead.rho (1) = data_elements;
	     end;

	result -> character_string_overlay = sbp -> symbol_bead.name;

	return;


wash_fbp:
     proc;

	fbp -> function_bead.reference_count = fbp -> function_bead.reference_count - 1;
	if fbp -> function_bead.reference_count <= 0
	then call apl_free_bead_ (fbp);
     end wash_fbp;



cant_fix:
	apl_number = float_index_origin;		/* name error is attributed to header line */
	call wash_fbp;
	number_type = integral_value_type;
	go to return_apl_number_monadic;

fcn (64):
fcn (65):
fcn (66):						/* unimplmented shared-variable functions */
	call apl_system_error_ (apl_error_table_$no_sv);
	return;					/* just in case */

fcn (70):						/* QuadEC - Execute Multics command line */
fcn (71):						/* QuadAF - Evaluate Multics active function expression */
	if ^right_vb -> value_bead.character_value
	then go to domain_error_right;

	if right_vb -> value_bead.rhorho > 1
	then go to domain_error_right;

/* at this point we have a character vector or scalar */
/* copy operand because command processor clobbers it! */

	data_elements = right_vb -> value_bead.total_data_elements;
	n_words = size (character_string_overlay);

	result = apl_push_stack_ (n_words);

	result -> character_string_overlay = right -> character_string_overlay;

	if ws_info.switches.restrict_exec_command	/* oops */
	then do;
		operators_argument.error_code = apl_error_table_$exec_restricted;
		return;
	     end;
	else if operators_argument.op1 = 70		/* QuadEC */
	then do;
		call cu_$cp ((result), data_elements, code);

		data_elements = 0;
	     end;
	else do;					/* QuadAF */
		call apl_segment_manager_$get (final_result);

		on active_function_error
		     begin;

			if code = 0
			     then code = error_table_$badcall;

			goto return_error_message;
		     end;

		call cu_$evaluate_active_string (null (), (result -> character_string_overlay), NORMAL_ACTIVE_STRING,
		     final_result -> return_string, code);

		revert active_function_error;

		data_elements = length (final_result -> return_string);
	     end;

/* allocate result (on top of copy of operand) */

	ws_info.value_stack_ptr = result;

	if code ^= 0
	then do;
return_error_message:
		call convert_status_code_ (code, "xxxxxxxx", long_message);
		data_elements = length (rtrim (long_message));
	     end;

	call alloc_chars_on_stack (1);		/* result is always a vector */

	if code = 0
	then if data_elements ^= 0
	     then do;
		     result -> character_string_overlay = final_result -> return_string;
		     call apl_segment_manager_$free (final_result);
		end;
	     else ;
	else result -> character_string_overlay = long_message;

	result_vb -> value_bead.rho (1) = data_elements;
	result_vb -> value_bead.total_data_elements = data_elements;

	return;

domain_error_right:
	operators_argument.where_error = operators_argument.where_error - 1;
domain_error:
	operators_argument.error_code = apl_error_table_$domain;
	return;

domain_error_left:
	operators_argument.where_error = operators_argument.where_error + 1;
	go to domain_error;

/* Declarations */

declare	code		fixed bin (35),
	long_message	char (100) aligned,
	return_string	char (4 * 65535) varying based;

dcl	right_vb		unaligned pointer,
	right		unaligned pointer,
	number_type	bit (18),
	apl_number	float,
	start_of_sleep_time fixed bin (71),
	n_words		fixed bin (19),
	result_vb		unaligned pointer,
	result		pointer,
	final_result	pointer,
	final_result_vb	unaligned pointer,
	data_elements	fixed bin (21),
	name_len		fixed bin (21),
	name_pos		fixed bin (21),
	name_no_good	bit (1),
	sbp		unaligned pointer,
	fbp		unaligned pointer,
	lfbp		unaligned pointer,
	max_line_length	fixed bin (21),
	number_of_lines	fixed bin (21),
	line_pos		fixed bin (21),
	this_line_length	fixed bin (21),
	line_number	fixed bin (21),
	which_name	fixed bin (21),
	i		fixed bin (21),
	token_pos		fixed bin (21),
	token_len		fixed bin (21),
	token_type	fixed bin,
	left_vb		unaligned pointer,
	left		unaligned pointer,
	left_size		fixed bin (21),
	(do_labels, do_variables, do_functions)
			bit (1),
	fixnum		fixed bin (17),
	float_temp	float,
	n_rows		fixed bin (21),
	n_cols		fixed bin (21),
	pass		fixed bin (2),
	htpos		fixed bin,
	value_stack_popper	unaligned pointer,
	fcn_text_ptr	unaligned pointer,
	fcn_text		char (out_pos) aligned based (fcn_text_ptr),
	out_pos		fixed bin (21),
	space_left_in_stack fixed bin (21),
	in_row		fixed bin (21),
	row_pos		fixed bin (21),
	row_length	fixed bin (21),
	errors_occurred	bit (1) aligned,
	error_line	fixed bin;


/* Multics entries */

declare	convert_status_code_
			entry (fixed bin (35), char (8) aligned, char (100) aligned),
	cu_$cp		entry (ptr, fixed bin (21), fixed bin (35)),
						/*	cu_$evaluate_active_function entry (ptr, fixed bin (21), ptr, fixed bin (35)), */
	timer_manager_$sleep
			entry (fixed bin (71), bit (2));

/* APL entries */

declare	apl_free_bead_	entry (unaligned pointer),
	apl_get_next_value_stack_seg_
			entry (fixed bin (18)),
	(
	apl_segment_manager_$get,
	apl_segment_manager_$free
	)		entry (ptr),
	apl_scan_		entry (char (*) aligned, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin,
			unaligned pointer),
	apl_get_symbol_	entry (char (*), unaligned pointer, fixed bin),
	apl_pendant_function_check_
			entry (unaligned pointer) returns (bit (1) aligned),
	apl_allocate_words_ entry (fixed bin (18), unaligned pointer),
	apl_function_lex_no_messages_
			entry (char (*) aligned, unaligned pointer, bit (1) aligned, fixed bin, aligned pointer,
			fixed bin),
	apl_system_error_	entry (fixed bin (35)),
	cu_$evaluate_active_string
			entry (ptr, char (*), fixed bin, char (*) var, fixed bin (35));

/* external static */

declare	(
	error_table_$badcall,
	apl_error_table_$domain,
	apl_error_table_$not_implemented,
	apl_error_table_$exec_restricted,
	apl_error_table_$no_sv
	)		fixed bin (35) external;

/* builtin */

dcl	(abs, addr, addrel, clock, divide, fixed, float, floor, hbound, index, lbound, null, rel, reverse, size, string,
	substr, verify)	builtin;

/* conditions */

declare	apl_quit_			condition;
declare	active_function_error	condition;
/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_bead_format;
%include apl_operators_argument;
%include apl_operator_bead;
%include apl_value_bead;
%include apl_function_bead;
%include apl_lexed_function_bead;
%include apl_parse_frame;

dcl	parse_frame_ptr	ptr;			/* crock */

%include apl_characters;
%include apl_symbol_table;
%include apl_symbol_bead;
%include cp_active_string_types;



     end apl_system_functions_;




		    apl_system_variables_.pl1       11/29/83  1638.6r w 11/29/83  1347.3      157356



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

apl_system_variables_:
     procedure (operators_argument);

/*
 * this module handles referencing and setting of "system variables,"
 * i.e. variables whose names begin with a Quad.
 * it also contains code for the monadic ibeams
 *
 * written 20 July 1973 and 1 August 1973 by DAM
 * modified 8/9/73 by DAM to fix bugs.
 * modified 12/17/73 by PG to fix bugs & add QuadIT.
 * Modified 740910 by PG for installation.
   Modified 770415 by PG to cleanup qTT, and add cent-sign to qCS.
   Modified 771107 by PG to fix 291 (some ibeams weren't returning integers).
   Modified 771121 by PG to validate op1 before jumping into transfer vector.
   Modified 781128 by PG to have quote-quad generate a proper value_bead for scalar results.
   Modified 781129 by PG to use clock and vclock builtins.
   Modified 790911 by PG to update list of terminal names.
   Modified 820827 by AD to add comma-hyphen to qCS.
 */

/* automatic */

dcl	apl_number	float,
	code		fixed bin (35),
	fixnum		fixed bin (35),
	float_temp	float,
	n_words		fixed bin (19),
	result_vb		pointer,
	result		pointer,
	right_vb		pointer,
	data_elements	fixed bin (21),
	iostatus		bit (72) aligned,
	month		fixed bin,
	day		fixed bin,
	year		fixed bin,
	time_of_day	fixed bin (71),
	double_fix	fixed bin (71),
	hour		fixed bin,
	minute		fixed bin,
	second		fixed bin,
	millisecond	fixed bin,
	result_pos	fixed bin (21),
	pass		fixed bin,
	p		pointer,
	tty_name		char (32) aligned,
	type_field	bit (18),
	parse_frame_ptr	pointer,			/* just to satisfy danb's include file */
	rhorho		fixed bin,
	nelemt		fixed bin (21),
	quad_quote_input_buffer
			char (300) aligned;		/* seems about right for maximum length of input line */

/* based */

declare	word_copy_overlay	(n_words) fixed bin (35) based;

/* entries */

dcl	apl_copy_value_	entry (unaligned pointer, unaligned pointer),
	apl_free_bead_	entry (unaligned pointer),
	decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin,
			char (3) aligned),
	iox_$control	entry (ptr, char (*), ptr, fixed bin (35)),
	iox_$get_line	entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
	system_info_$users	entry (fixed bin, fixed bin (35)),
	apl_get_storage_usage_
			entry (fixed bin (35));

/* external static */

declare	(apl_error_table_$bad_assign_to_system_var, apl_error_table_$domain, apl_error_table_$unknown_system_var)
			fixed bin (35) external static;

declare	apl_static_$apl_input
			ptr external static;

/* internal static */

dcl	microseconds_per_60th
			float bin (63) internal static initial (16666.66666666666667e0);
dcl	microseconds_per_millisecond
			float bin (63) internal static initial (1e3);
dcl	microseconds_per_second
			float bin (63) internal static initial (1e6);

dcl	terminal_names	(-11:5) char (10) unal internal static
			init ("LA36", "BITPAIRED", "TYPEPAIRED", "ARDS", "TN300", "Absentee", "1030", "TELERAY11",
			"ASCII", "TELETYPE", "TEK4013", "", "CORR2741", "2741", "1050", "3270-DAF", "3270");

/* builtins */

declare	(abs, addr, addrel, clock, collate9, currentsize, divide, fixed, float, floor, hbound, lbound, length, null, rel,
	size, string, substr, vclock)
			builtin;

/* include files */

%include apl_number_data;
%include apl_ws_info;
%include apl_bead_format;
%include apl_value_bead;
%include apl_operators_argument;
%include apl_operator_bead;
%include apl_parse_frame;

	if operators_argument.op1 >= lbound (set, 1) & operators_argument.op1 <= hbound (set, 1)
	then go to set (operators_argument.op1);
	else if operators_argument.op1 >= lbound (get, 1) & operators_argument.op1 <= hbound (get, 1)
	then go to get (operators_argument.op1);
	else go to system_error;

get (2):						/* QuadCT - get the fuzz */
	apl_number = ws_info.fuzz;
	go to return_apl_number;


set (106):					/* QuadCT - set the fuzz */
	call get_scalar_float;
	if apl_number < 0
	then go to domain_error;
	else if apl_number > 1
	then go to domain_error;
	ws_info.fuzz = apl_number;
	return;					/* parse knows that assign operators return their operand */

get (3):						/* QuadIO - get the index origin */
	fixnum = ws_info.index_origin;
	go to return_fixnum;

set (107):					/* QuadIO - set the index origin */
	call get_scalar_fix;
	if fixnum ^= 0
	then if fixnum ^= 1
	     then go to domain_error;
	ws_info.index_origin = fixnum;
	ws_info.float_index_origin = float (fixnum);
	return;

get (4):						/* QuadLX - get the latent expression */
	n_words = fixed (ws_info.latent_expression -> value_bead.size);
	result_vb = apl_push_stack_ (n_words);
	result_vb -> word_copy_overlay (*) = ws_info.latent_expression -> word_copy_overlay (*);
	result = addrel (result_vb, currentsize (result_vb -> value_bead));
	result_vb -> value_bead.data_pointer = result;
	operators_argument.result = result_vb;
	return;

set (108):					/* set the latent expression */
	if operands (2).value -> value_bead.character_value
	then ;
	else go to domain_error;
	if operands (2).value -> value_bead.rhorho <= 1
	then ;
	else go to domain_error;

	ws_info.latent_expression -> value_bead.reference_count =
	     ws_info.latent_expression -> value_bead.reference_count - 1;
	if ws_info.latent_expression -> value_bead.reference_count = 0
	then call apl_free_bead_ (ws_info.latent_expression);
	call apl_copy_value_ (operands (2).value, ws_info.latent_expression);
	return;



get (5):						/* QuadPP - get printing-precision */
	fixnum = ws_info.digits;
	go to return_fixnum;


set (109):					/* QuadPP - set printing-precision */
	call get_scalar_fix;
	if fixnum < 1
	then go to domain_error;
	else if fixnum > 19
	then go to domain_error;
	ws_info.digits = fixnum;
	return;

get (6):						/* QuadPW - get print width */
	fixnum = ws_info.width;
	go to return_fixnum;

set (110):					/* QuadPW - set print width */
	call get_scalar_fix;
	if fixnum < 30
	then go to domain_error;
	else if fixnum > 390
	then go to domain_error;
	ws_info.width = fixnum;
	return;

get (7):						/* QuadRL - get random link */
	fixnum = ws_info.random_link;
	go to return_fixnum;


set (111):					/* QuadRL - set random link */
	call get_scalar_fix;
	if fixnum < 0
	then go to domain_error;
	ws_info.random_link = fixnum;
	return;

get (8):						/* QuadAI - get accounting info */
	data_elements = 4;
	call set_vector;

	result -> numeric_datum (0) = float (ws_info.user_number);
	result -> numeric_datum (1) = float (vclock ()) / microseconds_per_millisecond;
	result -> numeric_datum (2) = float (clock () - time_invoked) / microseconds_per_millisecond;
	call iox_$control (apl_static_$apl_input, "get_keying_time", addr (double_fix), code);
	if code ^= 0
	then double_fix = 0;
	result -> numeric_datum (3) = float (double_fix) / microseconds_per_millisecond;
	return;

get (16):						/* QuadIT - get the integer tolerance (integer fuzz) */
	apl_number = ws_info.integer_fuzz;
	go to return_apl_number;


set (120):					/* QuadIT - set the integer tolerance (integer fuzz) */
	call get_scalar_float;
	if apl_number < 0 | apl_number > 1
	then go to domain_error;

	ws_info.integer_fuzz = apl_number;
	return;


/* ibeams that do similar things */

ibeam (29):					/* user number */
	fixnum = ws_info.user_number;
	go to return_fixnum;

ibeam (21):					/* cpu time */
	fixnum = float (vclock ()) / microseconds_per_60th;
	go to return_fixnum;

ibeam (24):					/* sign-on time */
	call decode_clock_value_ (time_invoked, month, day, year, time_of_day, (0), (""));
	fixnum = float (time_of_day) / microseconds_per_60th;
	go to return_fixnum;

ibeam (20):					/* time of day */
	call compute_time;
	fixnum = float (time_of_day) / microseconds_per_60th;
	go to return_fixnum;

ibeam (19):					/* keying time */
	call iox_$control (apl_static_$apl_input, "get_keying_time", addr (double_fix), code);
	if code ^= 0
	then double_fix = 0;
	fixnum = float (double_fix) / microseconds_per_60th;
	go to return_fixnum;

ibeam (27):
get (9):						/* QuadLC - get the state indicator as a vector */
	data_elements = 0;
	result_pos = 0;
	do pass = 1 to 2;				/* first pass computes size of result, second makes it */

	     do p = current_parse_frame_ptr repeat p -> parse_frame.last_parse_frame_ptr while (p ^= null);

		if p -> parse_frame.parse_frame_type = function_frame_type
		then if pass = 1
		     then data_elements = data_elements + 1;
		     else do;

			     result -> numeric_datum (result_pos) = float (p -> parse_frame.current_line_number);
			     result_pos = result_pos + 1;
			end;
		else if p -> parse_frame.parse_frame_type = execute_frame_type
			| p -> parse_frame.parse_frame_type = evaluated_frame_type
		then if pass = 1
		     then data_elements = data_elements + 1;
		     else do;			/* put in a zero for evaluated input and execute */
			     result -> numeric_datum (result_pos) = 0;
			     result_pos = result_pos + 1;
			end;
		else ;				/* other types of frames are simply ignored */
	     end;

	     if pass = 1
	     then do;
		     call set_vector;		/* at end of first pass, set up vector to be filled on second */
		     string (result_vb -> value_bead.type) = integral_value_type;
		end;
	end;
	return;

ibeam (26):
	do p = current_parse_frame_ptr repeat p -> parse_frame.last_parse_frame_ptr while (p ^= null);
	     if p -> parse_frame.parse_frame_type = function_frame_type
	     then do;
		     fixnum = p -> parse_frame.current_line_number;
		     go to return_fixnum;
		end;

	     else if p -> parse_frame.parse_frame_type = execute_frame_type
		     | p -> parse_frame.parse_frame_type = evaluated_frame_type
	     then do;
		     fixnum = 0;
		     go to return_fixnum;
		end;

	     else ;				/* other types of frames are skipped over */
	end;
	fixnum = 0;
	go to return_fixnum;

ibeam (25):
	call compute_time;
	fixnum = month * 10000 + day * 100 + year;
	go to return_fixnum;

get (10):						/* QuadTS - get the "time stamp:"  y m d h m s ms */
	data_elements = 7;
	call set_vector;
	string (result_vb -> value_bead.type) = integral_value_type;
	call compute_time;

	result -> numeric_datum (0) = float (year);
	result -> numeric_datum (1) = float (month);
	result -> numeric_datum (2) = float (day);
	result -> numeric_datum (3) = float (hour);
	result -> numeric_datum (4) = float (minute);
	result -> numeric_datum (5) = float (second);
	result -> numeric_datum (6) = float (millisecond);
	return;

ibeam (28):
get (11):						/* QuadTT - get terminal type */
	call iox_$control (apl_static_$apl_input, "get_device_type", addr (tty_name), code);
	if code ^= 0				/* not apl dim... */
	then tty_name = "Absentee";			/* we should probably check... */

/* Return index of name in the array. Note that we just return
   hbound+1 if the names is not found. */

	do fixnum = lbound (terminal_names, 1) to hbound (terminal_names, 1) while (terminal_names (fixnum) ^= tty_name);
	end;
	go to return_fixnum;



get (12):						/* QuadUL - get the User Load */
ibeam (23):
	call system_info_$users ((0), fixnum);
	go to return_fixnum;

get (13):						/* QuadWA - the amount of workspace available */
						/* for now, this is infinity */
	apl_number = TheBiggestNumberWeveGot;
	go to return_apl_number;

ibeam (22):					/* workspace available */
	fixnum = 11111111111111111111111111111111111b;	/* largest single precision fixed point number */
	go to return_fixnum;


get (15):						/* QuadCS -  the character set.  Presently we return the 196 characters */
	data_elements = 196;
	number_of_dimensions = 1;
	n_words = size (value_bead) + size (character_string_overlay);
	result_vb = apl_push_stack_ (n_words);
	result = addr (result_vb -> value_bead.rho (2));
	string (result_vb -> value_bead.type) = character_value_type;
	result_vb -> value_bead.total_data_elements, result_vb -> value_bead.rho (1) = 196;
	result_vb -> value_bead.rhorho = 1;
	result_vb -> value_bead.data_pointer = result;
	operators_argument.result = result_vb;
	result -> character_string_overlay = substr (collate9, 1, 196);
	return;

get (14):						/* QuadWU - return number of characters of workspace used */
	call apl_get_storage_usage_ (fixnum);
	fixnum = 4 * fixnum;			/* convert from words to characters */
	go to return_fixnum;

get (1):						/* QuadQuote input */
						/* at present there is no prompt string for quad - quote input */
	ws_info.can_be_interrupted = "1"b;
	call iox_$get_line (apl_static_$apl_input, addr (quad_quote_input_buffer), length (quad_quote_input_buffer), nelemt,
	     0);
	ws_info.can_be_interrupted = "0"b;
						/* if there is any OTU (O bs U bs T) feature, it is in the dim so don't worry about it */

/* construct value bead to return */

	data_elements = nelemt - 1;

	if data_elements = 1
	then number_of_dimensions = 0;
	else number_of_dimensions = 1;

	n_words = size (value_bead) + size (character_string_overlay);
	result_vb = apl_push_stack_ (n_words);
	string (result_vb -> value_bead.type) = character_value_type;
	result_vb -> value_bead.total_data_elements = data_elements;
	result_vb -> value_bead.rhorho = number_of_dimensions;

	if data_elements ^= 1
	then result_vb -> value_bead.rho (1) = data_elements;

	result = addrel (result_vb, size (value_bead));
	result_vb -> value_bead.data_pointer = result;
	result -> character_string_overlay = addr (quad_quote_input_buffer) -> character_string_overlay;
	operators_argument.result = result_vb;
	return;

return_fixnum:
	type_field = integral_value_type;
	apl_number = float (fixnum);
	go to scalar_return;

return_apl_number:
	type_field = numeric_value_type;

scalar_return:
	rhorho = 0;
	data_elements = 1;
	call prepare_result;
	result -> numeric_datum (0) = apl_number;
	return;

domain_error_ibeam:
	operators_argument.where_error = operators_argument.where_error - 1;
						/* mark right arg */
	operators_argument.error_code = apl_error_table_$domain;
	return;

domain_error:
	operators_argument.where_error = operators_argument.where_error - 1;
						/* put marker on value being assigned
								   to this system variable */
	operators_argument.error_code = apl_error_table_$bad_assign_to_system_var;
	return;

system_error:
	operators_argument.error_code = apl_error_table_$unknown_system_var;
	return;

/*** enter here for monadic ibeams ***/

apl_ibeam_:
     entry (operators_argument);

	right_vb = operands (2).value;
	if ^right_vb -> value_bead.data_type.numeric_value
	then go to domain_error_ibeam;
	if ^(right_vb -> value_bead.total_data_elements = 1)
	then go to domain_error_ibeam;

	if right_vb -> value_bead.data_type.integral_value
	then float_temp = right_vb -> value_bead.data_pointer -> numeric_datum (0);
	else do;
		float_temp = floor (right_vb -> value_bead.data_pointer -> numeric_datum (0) + 0.5);
		if abs (float_temp - right_vb -> value_bead.data_pointer -> numeric_datum (0)) > integer_fuzz
		then go to domain_error_ibeam;
	     end;
	if abs (float_temp) >= 1e21b
	then go to domain_error_ibeam;
	fixnum = fixed (float_temp, 21);

	if fixnum < 19
	then go to domain_error_ibeam;
	else if fixnum > 29
	then go to domain_error_ibeam;

	go to ibeam (fixnum);			/* dispatch into code above */

/* internal procedures */

compute_time:
     procedure ();

	call decode_clock_value_ (clock (), month, day, year, time_of_day, (0), (""));
	year = year - 1900;
	second = float (time_of_day, 52) / microseconds_per_second;
						/* no precision will be lost in flt divide */
	millisecond = float (time_of_day - second * 1000000, 52) / microseconds_per_millisecond;
	hour = divide (second, 3600, 5, 0);
	second = second - 3600 * hour;
	minute = divide (second, 60, 6, 0);
	second = second - 60 * minute;
	return;

     end compute_time;

get_scalar_fix:
     procedure ();

	call get_scalar_float;
	if operands (2).value -> value_bead.data_type.integral_value
	then float_temp = apl_number;
	else do;
		float_temp = floor (apl_number + 0.5);
		if abs (float_temp - apl_number) > integer_fuzz
		then go to domain_error;
	     end;

	if abs (float_temp) >= 1e35b
	then go to domain_error;
	fixnum = fixed (float_temp, 35);
	return;

     end get_scalar_fix;

get_scalar_float:
     procedure ();

	if ^(operands (2).value -> value_bead.total_data_elements = 1)
	then go to domain_error;

	apl_number = operands (2).value -> value_bead.data_pointer -> numeric_datum (0);
	return;

     end get_scalar_float;

prepare_result:
     procedure ();

	number_of_dimensions = rhorho;
	n_words = size (value_bead) + size (numeric_datum) + 1;
	result_vb = apl_push_stack_ (n_words);
	operators_argument.result = result_vb;
	string (result_vb -> value_bead.type) = type_field;
	result_vb -> value_bead.total_data_elements = data_elements;
	result_vb -> value_bead.rhorho = rhorho;
	result = addrel (result_vb, size (value_bead));
	if substr (rel (result), 18, 1)
	then result = addrel (result, 1);

	result_vb -> value_bead.data_pointer = result;
	return;

     end prepare_result;

set_vector:
     procedure ();

	type_field = numeric_value_type;
	rhorho = 1;
	call prepare_result;
	result_vb -> value_bead.rho (1) = data_elements;
	return;

     end set_vector;

%include apl_push_stack_fcn;
     end /* apl_system_variables_ */;




		    apl_translate_pathname_.pl1     11/29/83  1638.6r w 11/29/83  1347.3       72810



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

/* format: style3 */
apl_translate_pathname_:
     procedure (a_wsid, a_dname, a_ename, a_fcbp, a_code);

/* procedure to translate an APL wsid into a Multics pathname and find the entry.
   Written August 1973 by RSL.
   Modified 15 Sep 1973 by DAM for user numbers as directory names, special-case "continue"
   Modified 740201 by PG to change continue to Username.sv.apl, and allow V1 ws names.
   Modified 740423 by PG to make V1 & V2 names mutually exclusive.
   Modified 790110 by William York to add file system expansion capability.
   Modified 800307 by PG to fix 459 (did not strip existing suffixes).
   Modified 811210 by TO to add 'use_search_paths' entrypoint.
 */

declare	a_wsid		char (*) parameter,		/* (Input) the APL workspace name */
	a_dname		char (*) parameter,		/* (Output) The Multics directory pathname */
	a_ename		char (*) parameter,		/* (Output) The Multics entry name */
	a_fcbp		pointer parameter,		/* (Output) if non-null, points at the msf_manager_ file control block */
	a_code		fixed bin (35) parameter;	/* (Output) 0 means ws exists, /=0 means non-exist or error */

/* Code starts here for normal call. */

	component_file = "0"b;			/* ws id, not file system file */
	may_use_search_paths = "0"b;			/*  Ignore APL search paths. */
	version_one = "0"b;				/* version 2, not 1 */
	goto common_code;

file_system_pathname:				/* called by apl_file_system_ */
     entry (a_wsid, a_dname, a_ename, a_fcbp, a_code);

	component_file = "1"b;			/* file system file, not WS */
	may_use_search_paths = "0"b;			/*  Ignore APL search paths. */
	version_one = "0"b;				/* version 2 names, not version 1 */
	goto common_code;

allow_version_one:					/* called by )V1COPY and )V1PCOPY */
     entry (a_wsid, a_dname, a_ename, a_fcbp, a_code);

	component_file = "0"b;
	may_use_search_paths = "0"b;			/*  Ignore APL search paths. */
	version_one = "1"b;
	goto common_code;


use_search_paths:					/*  Called by ')LOAD'.  */
	entry (a_wsid, a_dname, a_ename, a_fcbp, a_code);

	component_file = "0"b;			/*  ws id, not file system file  */
	may_use_search_paths = "1"b;			/*  Allow use of APL search paths.  */
	version_one = "0"b;				/*  version 2 names, not version 1  */
	goto common_code;

common_code:
	a_fcbp = null;

/* check for an APL/360 style wsid; i.e. a number and an optional name (optional for )LIB.) */

/* If there is a leading digit, it is a library number. V1 wsid's
	   have no library numbers, so ignore it. */

	idx = verify (a_wsid, whitespace);		/* flush leading blanks and tabs */

	if ^version_one & index ("0123456789", substr (a_wsid, idx, 1)) ^= 0
	then do;

		number_from_wsid = cv_dec_check_ (substr (a_wsid, idx), end_of_number);
		end_of_number = end_of_number + idx - 1;
		idx = end_of_number;

		start_of_name = idx + verify (substr (a_wsid, idx), whitespace) - 1;

		if start_of_name > end_of_number
		then do;
			if component_file
			then call ioa_$rsnnl (">^a.cf.apl", entry_name_part, (0), substr (a_wsid, start_of_name));
			else call ioa_$rsnnl (">^a.sv.apl", entry_name_part, (0), substr (a_wsid, start_of_name));
			absolute_path = "0"b;
		     end;
		else do;				/* just a number, return directory pathname for ")LIB" */
			entry_name_part = " ";
			absolute_path = "1"b;
			a_ename = " ";		/* will be changed to ".sv.apl", an illegal name which will be 
				if this is )LIB, which is what we expect */

		     end;

		call user_info_$whoami (user_name, user_project);

/* the user number may refer either to a public library
	        (in >apl) or a private library belonging to a member
	        of the user's project */

		if number_from_wsid >= 1000
		then call ioa_$rsnnl (">udd>^a>apl_directories>^d^a", Multics_wsid, length_Multics_wsid, user_project,
			number_from_wsid, entry_name_part);
		else call ioa_$rsnnl (">apl>library_^d^a", Multics_wsid, length_Multics_wsid, number_from_wsid,
			entry_name_part);

		if absolute_path
		then call absolute_pathname_ (Multics_wsid, dname, a_code);
		else call expand_pathname_ (Multics_wsid, dname, ename, a_code);
		if a_code ^= 0
		then return;

		if length (a_ename) = 0
		then do;				/* )LIB - return now without going through msf_manager_ cruft */
			a_dname = dname;
			return;
		     end;
	     end;

	else if length (a_ename) = 0			/* ")LIB" - just get directory pathname from argument */
	then do;
		call absolute_pathname_ (a_wsid, dname, a_code);
		a_dname = dname;
		return;
	     end;

/* check for the continue workspace, punting for file system */

	else do;
		if version_one
		then suffix = "apl";
		else if component_file
		then suffix = "cf.apl";
		else suffix = "sv.apl";

		call expand_pathname_$add_suffix (a_wsid, suffix, dname, ename, a_code);
		if a_code ^= 0
		then return;

/* Handle the continue ws */

		if ename = "continue.sv.apl"
		then do;
			call user_info_$whoami (user_name, user_project);
			call user_info_$homedir (dname);

			ename = rtrim (user_name) || ".sv.apl";
		     end;
		else if (version_one & ename = "continue.apl")
		then do;
			dname = get_wdir_ ();
		     end;
		else if may_use_search_paths & search (a_wsid, "<>") = 0
		then do;
	
/* Use search paths if path is relative and we were supposed to try search paths. */
		     if apl_dir = "" then
			call hcs_$fs_get_path_name (codeptr (apl_translate_pathname_), apl_dir, (0), (dname), a_code);
		     call search_paths_$find_dir ("apl", null (), ename, apl_dir, dname, a_code);
		     if a_code ^= 0
		     then dname = get_wdir_ ();
		end;
	     end;

/* dname and ename have been set up.  Now find the entry and
   see what kind it is */

	call msf_manager_$open (dname, ename, a_fcbp, a_code);

	if a_code ^= 0
	then if a_code ^= error_table_$noentry		/* this code is OK; msf_manager_$get_ptr will */
	     then if a_fcbp ^= null			/* create the SSF/MSF later. Any other code we */
		then do;				/* treat as fatal. */
			call msf_manager_$close (a_fcbp);
			a_fcbp = null;
		     end;

	a_dname = dname;
	a_ename = ename;
	return;

/* Entries */

dcl	ioa_$rsnnl	entry options (variable);
dcl	get_wdir_		entry returns (char (168));
dcl	user_info_$whoami	entry (char (*), char (*));
dcl	user_info_$homedir	entry (char (*));
dcl	expand_pathname_	entry (char (*), char (*), char (*), fixed bin (35));
dcl	hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl	expand_pathname_$add_suffix
			entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl	absolute_pathname_	entry (char (*), char (*), fixed bin (35));
dcl	msf_manager_$open	entry (char (*), char (*), pointer, fixed binary (35));
dcl	msf_manager_$close	entry (pointer);
dcl search_paths_$find_dir entry (char (*), ptr, char (*), char (*), char (*), fixed bin (35));
dcl	cv_dec_check_	entry (char (*), fixed bin (35)) returns (fixed bin (35));

/* Automatic */

dcl	suffix		char (6);
dcl	user_project	char (9);
dcl	user_name		char (24);
dcl	(component_file, may_use_search_paths, version_one)
			bit (1) aligned;
dcl	absolute_path	bit (1) aligned;
dcl	apl_dir		char (168) static init ("");
dcl	number_from_wsid	fixed bin (35);
dcl	idx		fixed bin;
dcl	end_of_number	fixed bin (35);
dcl	start_of_name	fixed bin;
dcl	entry_name_part	char (33);		/* blank or ">" and the ename (for number-format wsid) */
dcl	Multics_wsid	char (168);
dcl	length_Multics_wsid fixed bin;
dcl	dname		char (168);
dcl	ename		char (32);

/* Builtins */

dcl	(index, length, null, rtrim, substr, verify)
			builtin;

/* External static */

dcl	error_table_$noentry
			fixed bin (35) external static;

/* Internal Static */

dcl	whitespace	char (2) init (" 	") internal static;
						/* space, tab */

     end apl_translate_pathname_;




		    apl_transpose_.pl1              11/29/83  1638.6r w 11/29/83  1347.3      105678



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

apl_transpose_: proc(operators_argument);

/*
 * apl_transpose_ does the monadic and dyadic \o operators.
 * the way it tells monadic from dyadic is by operands(1).value being null
 *
 * written 7/29/73 by DAM (during titanic thunderstorm)
 * Modified 740201 by PG for compatibility check error
   Modified 770610 by PG to fix bug 282 (dyadic transpose failed in origin 0), and bug 194 (can't transpose empty arrays).
 *
 * I don't even attempt to do it in place, or to have a special fast EIS case,
 * because it's just too hard.  I hope no one wants a super-fast transpose
 */

dcl right_vb pointer,			/* -> value_bead of right operand */
    right pointer,				/* -> value array of right operand */
    characters bit(1),			/* "1"b if right & result are character, "0"b if numeric */
    rhorho_right fixed bin,			/* number of dimensions of right operand */

    integer_fuzz float,			/* copy of ws_info.integer_fuzz */
    index_origin fixed bin,			/* copy of ws_info.index_origin */

    left_vb pointer,			/* -> value_bead of left operand */
    left pointer,				/* -> value array for left operand */
    left_is_integral bit(1),			/* "1"b if left operand is known to contain only integers */

    rhorho_result fixed bin,			/* number of dimensions in the result */
    data_elements fixed bin(21),		/* number of elements in the result */
    result_vb pointer,			/* -> value bead of result */
    result pointer,				/* value array for result */
    final_result_vb pointer,			/* -> value_bead of result after moved down in stack */
    final_result pointer,			/* -> value array for result after moved down in stack */

    (left_index, right_index, result_index) fixed bin(21),	/* indices into respective value arrays */
    rhorho_result_float float,		/* temporary for computing rhorho_result */
    n_words fixed bin (19),			/* number of words to be pushed onto value stack */
    permute_ptr pointer,			/* address of permute table declared below */

    right_mult fixed bin(21),			/* multplier for subscripts in current right dimension
					   (used in computing the permute table) */
    fixnum fixed bin,			/* fixed-point binary version of element of left operand */
    float_temp float,
    (i, j) fixed bin,			/* random do-loop indices */
    cur_rho fixed bin;			/* index into array of do-loops (see code below at bump_rho) */

/* based */

declare	word_copy_overlay fixed bin (35) dim (n_words) based aligned;


/* permute table derived from left operand */

dcl 1 permute (rhorho_result) aligned based(permute_ptr),
    2 multiplier fixed bin(21),		/* subscript-multiplier for extracting elements from operand */
    2 result_rho fixed bin(21);		/* at first, corresponding element of rho of result is stored here,
					   later is current index into result along this dimension, i.e. control
					   variable for array of do-loops (see code near bump_rho) */


dcl (apl_error_table_$domain,
     apl_error_table_$rank,
     apl_error_table_$compatibility_error,
     apl_error_table_$length
    ) fixed bin(35) external;


dcl (abs, addr, addrel, divide, fixed, floor, min, max, null, rel, size, string, substr, unspec) builtin;

%include apl_number_data;
%include apl_ws_info;
%include apl_bead_format;
%include apl_operator_bead;
%include apl_value_bead;
%include apl_operators_argument;

/* do the usual picking up of addresses and attributes of arguments and error checking */

	right_vb = operands(2).value;
	characters = right_vb -> value_bead.data_type.character_value;
	right = right_vb -> value_bead.data_pointer;
	rhorho_right = right_vb -> value_bead.rhorho;

	integer_fuzz = ws_info.integer_fuzz;
	index_origin = ws_info.index_origin;			/* copy for spurious efficiency */

	left_vb = operands(1).value;
	if left_vb = null then go to monadic_transpose;		/* fake up the left operand if monadic */
	if ^ left_vb -> value_bead.data_type.numeric_value then go to domain_error_left;
	else left_is_integral = left_vb -> value_bead.data_type.integral_value;
	left = left_vb -> value_bead.data_pointer;
	if left_vb -> value_bead.rhorho >= 2 then go to rank_error_left;
	if left_vb -> value_bead.total_data_elements ^= rhorho_right then go to length_error_left;


/* first allocate a space in the stack for the permute table, which gives the permutation
   from operand to result in the convenient form of a set of subscript multipliers.
   The permute table also holds the rho vector of the result until we get a chance
   to allocate a result value bead in which to put it */

	rhorho_result_float = 0.0e0;			/* rhorho_result = max reduction of left operand */
	do left_index = 0 by 1 while (left_index < rhorho_right);
	   rhorho_result_float = max(rhorho_result_float, left -> numeric_datum(left_index));
	   end;
	rhorho_result = fixed (rhorho_result_float) + (1 - index_origin);

	n_words = size(permute);
	permute_ptr = apl_push_stack_ (n_words);

	permute.multiplier (*) = -1;
	permute.result_rho(*) = 1048577;		/* identity for min of rho-vector entries contributing */

/* process left operand into permute table */

	right_mult = 1;
	do left_index = rhorho_right-1 by -1 while(left_index >= 0);	/* process left operand backwards */
	   if left_is_integral then fixnum = fixed(left -> numeric_datum(left_index));
	   else do;
		float_temp = floor(left -> numeric_datum(left_index) + 0.5);
		if abs(float_temp - left -> numeric_datum(left_index)) > integer_fuzz
		then go to domain_error_left;

		if abs(float_temp) >= 1e21b then go to domain_error_left;
		fixnum = fixed(float_temp, 21);
		end;
	   fixnum = fixnum + (1 - index_origin);
	   if fixnum <= 0 then go to domain_error_left;
		/* needn't check upper bound since rhorho_result was derived from max of these */

	   /* compute fixnum'th permute.multiplier from left_index'th multiplier of operand */

	     if permute.multiplier (fixnum) = -1	/* not yet set */
	     then permute.multiplier (fixnum) = right_mult;
	     else permute.multiplier (fixnum) = permute.multiplier (fixnum) + right_mult;

	     permute.result_rho (fixnum) = min (permute.result_rho (fixnum),
		right_vb -> value_bead.rho (left_index + 1));	/* compute length of diagonal */
	     right_mult = right_mult * right_vb -> value_bead.rho (left_index + 1);	/* compute multiplier for next
									   dimension (to left) of opnd */
	end;

/* check for gap errors */

	do i = 0 by 1 while (i < rhorho_result);
	     if permute.multiplier (i + 1) = -1
	     then go to domain_error_left;
	end;

/* compute size of result and allocate it */

monadic_dyadic_join:
	data_elements = 1;
	do i = 0 by 1 while (i < rhorho_result);
	   data_elements = data_elements * permute.result_rho(i+1);
	   end;

	if characters then n_words = size(character_string_overlay);
	else n_words = size(numeric_datum)+1;
	number_of_dimensions = rhorho_result;
	n_words = n_words + size (value_bead);
	result_vb = apl_push_stack_ (n_words);
		/* no need to update value_stack_ptr, will be set before returning and not referenced before then */

	result = addr(result_vb -> value_bead.rho(rhorho_result+1));
	if ^characters then if substr(rel(result), 18, 1) then result = addrel(result, 1);

/* fill result value_bead header */

	result_vb -> value_bead.data_pointer = result;
	string(result_vb -> value_bead.type) = string(right_vb -> value_bead.type);
	result_vb -> value_bead.total_data_elements = data_elements;
	result_vb -> value_bead.rhorho = rhorho_result;
	do i = 0 by 1 while (i < rhorho_result);
	   result_vb -> value_bead.rho(i+1) = permute.result_rho(i+1);
	   end;

	if data_elements = 0			/* transposing empty array */
	then go to finish;

/* now generate the result according to the permute table */

	permute.result_rho(*) = 0;			/* use these as an array of do-loops, a control structure
						   not permitted in standard PL/I for implementation reasons */
	do result_index = 0 by 1;	/* index in result steps linrrly through */
				/* the loop is terminated by the go to finish below */
	   right_index = 0;				/* compute index in operand */
	   do i = 0 by 1 while (i < rhorho_result);
	      right_index = right_index + permute.result_rho(i+1)*permute.multiplier(i+1);
	      end;
	   if characters
	    then result -> character_datum(result_index) = right -> character_datum(right_index);
	    else result -> numeric_datum(result_index) = right -> numeric_datum(right_index);

	   /* now bump the array of do loops */

	   cur_rho = rhorho_result;
bump_rho:	   cur_rho = cur_rho-1;			/* zero-origin index into permute.result_rho */
	   if cur_rho < 0 then go to finish;
	   permute.result_rho(cur_rho+1) = permute.result_rho(cur_rho+1) + 1;
	   if permute.result_rho(cur_rho+1) >= result_vb -> value_bead.rho(cur_rho+1) then do;	/* carry into
										   enclosing
										   do-loop */
			permute.result_rho(cur_rho+1) = 0;
			go to bump_rho;
			end;
	   end;	/* end do result_index = ... */
finish:

/* move result down and set value_stack_ptr to point past it */

	if operands(2).on_stack then value_stack_ptr = right_vb;	/* find lowest place on stack, = where to move to */
	else if operands(1).on_stack then value_stack_ptr = left_vb;
	else value_stack_ptr = permute_ptr;

		/* n_words is still set from before */
	final_result_vb = apl_push_stack_ (n_words);
	number_of_dimensions = rhorho_result;
	n_words = size (value_bead);		/* number of words to copy */
	final_result_vb -> word_copy_overlay = result_vb -> word_copy_overlay;
	final_result = addr(final_result_vb -> value_bead.rho(rhorho_result+1));
	if ^characters then if substr(rel(final_result), 18, 1) then final_result = addrel(final_result, 1);
	final_result_vb -> value_bead.data_pointer = final_result;
	if characters then final_result -> character_string_overlay = result -> character_string_overlay;
	else final_result -> numeric_datum(*) = result -> numeric_datum(*);

	operators_argument.result = final_result_vb;
	return;

/* monadic case comes here to fake up left argument */

monadic_transpose:
	if ws_info.compatibility_check_mode
	then if rhorho_right > 2
	     then go to compatibility_error;		/* \oA used to mean interchange last 2 dims, now
						   means reverse all dims */
	rhorho_result = rhorho_right;
	n_words = size(permute);
	permute_ptr = apl_push_stack_ (n_words);

	right_mult = 1;
	do left_index = 0 by 1 while(left_index < rhorho_result);
	   right_index = rhorho_right - left_index;		/* right dimension is complement of left dim */
	   permute.multiplier(left_index+1) = right_mult;
	   permute.result_rho(left_index+1) = right_vb -> value_bead.rho(right_index);
	   right_mult = right_mult * right_vb -> value_bead.rho(right_index);
	   end;

	operands (1).on_stack = "0"b;			/* no left opnd... */
	go to monadic_dyadic_join;

/* error labels */

domain_error_left:
	operators_argument.error_code = apl_error_table_$domain;
	go to mark_left_operand;

rank_error_left:
	operators_argument.error_code = apl_error_table_$rank;
	go to mark_left_operand;

length_error_left:
	operators_argument.error_code = apl_error_table_$length;
	return;

compatibility_error:
	operators_argument.error_code = apl_error_table_$compatibility_error;
	go to mark_left_operand;

mark_left_operand:
	operators_argument.where_error = operators_argument.where_error + 1;
	return;

%include apl_push_stack_fcn;
     end /* apl_transpose_ */;




		    apl_v1_copy_command_.pl1        11/29/83  1638.6r w 11/29/83  1347.3      153774



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

apl_v1_copy_command_:
	procedure (bv_wsid, password, protected, names, number_of_names, bv_code);

declare	(protected bit(1),
	bv_wsid char (*),
	password char (*),
	names dimension (*) char (*),
	number_of_names fixed bin,
	bv_code fixed bin (35)) parameter;

/* procedure to copy a Version 1 APL workspace, converting it to Version 2 format.
   Written 740201 by PG, after "copy_command" by MGS.
   Modified 740430 by PG to fix bugs.
   Modified 770301 by PG to copy external functions properly (bug 238), and to copy names less than 4 chars (bug 177).
*/

/* builtin */

declare	(addr, addrel, baseno, baseptr, bin, binary, char, divide, float, hbound, index, length, mod, null, ptr,
	 rel, size, string, substr, translate, unspec) builtin;

/* external static */

declare	apl_error_table_$cant_load_ws external static fixed bin (35);

/* entries into Version 2 */

declare	apl_allocate_words_ entry (fixed bin (18), unaligned pointer),
	apl_date_time_ entry (fixed bin (71), char (*)),
	apl_free_bead_ entry (ptr unaligned),
	apl_function_lex_ entry (char (*) aligned, unaligned pointer, bit (1) aligned, fixed bin, ptr),
	apl_system_error_ entry (fixed bin (35)),
	apl_translate_pathname_$allow_version_one entry (char (*), char (*), char (*), ptr, fixed bin (35)),
	apl_create_save_frame_ entry (),
	apl_destroy_save_frame_update_ entry (),
	apl_get_symbol_ entry (char (*), unaligned pointer, fixed bin);

/* entries into Multics */

declare	ioa_$ioa_stream entry options (variable),
	msf_manager_$close entry (ptr),
	msf_manager_$get_ptr entry(ptr, fixed, bit(1), ptr, fixed bin(24), fixed (35));

/* automatic */

declare	bead_pointer pointer unaligned,
	code fixed bin (35),
	(data_elements, hook, name_length, name_number) fixed bin,
	dname char (168),
	ename char (32),
	n_words fixed bin (18),
	dtm char (17),
	bitcount fixed bin (24),
	(fcbp, free_space_ptr, p, pp, q, segptr) ptr;

/* declarations for Version 1 environment */

dcl
	wsid char(168) var,
	i fixed,
	csize(4) fixed int static init(1, 9, 36, 72),
	got(16) fixed init((16)0),

	1 seg based(segptr) aligned,
	   2 type fixed,
	   2 version,
	      3 len fixed,
	      3 name char(seg.version.len) aligned,
	   2 password char(8) aligned,
	   2 time_saved fixed bin(71),
	   2 tablen fixed,
	   2 table(seg.tablen) unaligned,
	      3 old unaligned,
	         4 seg bit(9) unaligned,
	         4 rel bit(18) unaligned,
	      3 new unaligned,
	         4 seg bit(9) unaligned,
	         4 rel bit(18) unaligned,
	      3 size bit(18) unaligned,
	   2 saved_static,
	      3 (digits, width, iorg, niorg, seed) fixed,
	      3 fuzz float bin(63),
	      3 (metersw, lexsw, parsesw) fixed,
	      3 goaheads(3),
	         4 len fixed,
	         4 chars char(16),
	   2 reserved_space(32) fixed,
	   2 data(261120) fixed,

	type_of_ws fixed int static init(0),
	line char(131) var,
	symp ptr,

	1 symtab based(symp),
	   2 prime fixed,
	   2 buckets(0:999),
	      3 (p, q) fixed,

	1 sb based(p),				/* Spelling bead */
	   2 (o, np, nq, up, uq, length) fixed,
	   2 string char(sb.length),

	1 ub based(q),				/* Usage bead */
	   2 o fixed,				/* owner list for hooks */
	   2 t fixed,				/* type (var, fcn, group) */
	   2 (vp, vq) fixed,			/* hook to value */
	   2 (np, nq) fixed,			/* hook to next usage for this spelling */
	   2 (sp, sq) fixed,			/* hook to next spelling bead */
	   2 globg bit(1);				/* "1"b if global */

	/* Procedure bead.  19 August 1971 (19 lines) */

	dcl
	1 pb based(pp),
	2 p_owner fixed,
	2 p_sname(0:0) fixed,	/* S of fcn name. */
	2 p_sanswer fixed,		/* Sname(1)=answer name, 0 if none. */
	2 p_sright fixed,		/* (2)=right argument name. */
	2 p_sleft fixed,		/* (3)=left argument name. */
	2 p_sxlocvs fixed,		/* (4)=s of first explicit local. */
	2 p_nxlocvs fixed,		/* Number of explicit local names. */
	2 p_nlabs fixed,		/* Number of labels. */
	2 p_nlocvs fixed,		/* Total number of local names. */
	2 (p_sourcep, p_sourceq) fixed,	/* Hook to fcn source. */
	2 p_nschars fixed,		/* Number of source characters. */
	2 p_nslines fixed,		/* Number of source lines. */
	2 p_nllines fixed,		/* Number of lexed lines.  0 for external fcns. */
	2 p_lexs(pp->p_nllines),		/* Hooks to individual line lexs. */
	  3 (p_lexp, p_lexq) fixed;

/* program */

	if bv_wsid = ""
	then do;
not_found:
		call ioa_$ioa_stream ("apl_output_", "ws not found");
		bv_code = apl_error_table_$cant_load_ws;
		return;
	     end;

	call apl_translate_pathname_$allow_version_one (bv_wsid, dname, ename, fcbp, bv_code);
	if bv_code ^= 0
	then go to not_found;

	call msf_manager_$get_ptr(fcbp, 0, "0"b, segptr, bitcount, code);
	if segptr=null then go to not_found;
	got(1) = bin(baseno(segptr), 18);

	if seg.type ^= type_of_ws
	then call apl_system_error_ (apl_error_table_$cant_load_ws);

	if seg.password ^= password
	then do;
		call ioa_$ioa_stream ("apl_output_", "ws locked");
		return;
	     end;

	line = "";

	symp = addr(data(2));

	if binary(rel(symp), 18)+2*prime+1>65535
	then call apl_system_error_ (apl_error_table_$cant_load_ws);

	call apl_create_save_frame_;			/* use global meanings */

	/* get ptr to end of parse stack for kludgy apl_lex_ interface */

	save_frame_pointer = ws_info.current_parse_frame_ptr;
	free_space_ptr = addr (save_frame.symbol_list (hbound (save_frame.symbol_list, 1) + 1));

	if number_of_names = 0			/* copy all names */
	then do i = 0 to prime - 1;
		do hook = buckets (i).q repeat p -> sb.nq while (hook ^= 0);
		     p = copy_expand (hook);
		     if sb.uq ^= 0
		     then do;
			     q = copy_expand(sb.uq);
			     do while(ub.nq^=0);
				q = copy_expand(ub.nq);
			     end;

			     if ub.globg
			     then call copy (sb.string, q, "0"b);
			end;
		end;
	     end;
	else do name_number = 1 to number_of_names;
		name_length = index (names (name_number), " ") - 1;
		if name_length = -1
		then name_length = length (names (name_number));

		q = copy_symget (substr (names (name_number), 1, name_length));
		if q = null
		then call not_copied (substr (names (name_number), 1, name_length));
		else call copy (substr (names (name_number), 1, name_length), q, "1"b);
	     end;

	if length (line) > 0 then call ioa_$ioa_stream ("apl_output_", "^a", line);

	call apl_date_time_ (time_saved, dtm);
	call ioa_$ioa_stream ("apl_output_", "saved  ^a", dtm);
	call msf_manager_$close(fcbp);
	call apl_destroy_save_frame_update_;
	return;

copy:	proc(name, q, chase_names);

/* parameters */

declare	(name char (*),
	q ptr,
	chase_names bit (1) aligned) parameter;

/* automatic */

declare	data_pointer pointer,
	errors_occurred bit (1) aligned,
	(in_start, in_length, line_length, number_of_groupies, out_start) fixed bin,
	symbol_pointer pointer unaligned,
	type bit (18) aligned;

/* builtin */

declare	string builtin;

/* internal static initial */

declare	(nl char (1) aligned initial ("
"),
	v1_codes char (10) aligned initial ("""#$%&@^`{}"),	/* " # $ % & @ ^ ` { } */
	v2_codes char (10) aligned initial ("ежзийклмно")	/* \245 - \256 */
	) internal static options (constant);

/* Version 1 data declarations */

declare	1 bit_value based (vp),
	2 (o, type, number, rhorho, rho (0 refer (bit_value.rhorho))) fixed,
	2 element (0 refer (bit_value.number)) bit (1),

	1 character_value based (vp),
	2 (o, type, number, rhorho, rho (0 refer (character_value.rhorho))) fixed,
	2 string char (character_value.number),

	1 integer_value based (vp),
	2 (o, type, number, rhorho, rho (0 refer (integer_value.rhorho))) fixed,
	2 element (0 refer (integer_value.number)) fixed bin (35),

	1 float_value based (vp),
	2 (o, type, number, rhorho, rho (0 refer (float_value.rhorho))) fixed,
	2 element (0 refer (float_value.number)) bit (72);

/* declarations for Version 1 environment */

dcl
	i fixed,
	vp ptr,
	vp1 ptr,
	gp ptr,

	1 vb based(vp),
	   2 (o, t, n, rr, r(vb.rr)) fixed,
	   2 v(vb.n) bit(csize(vb.t)),

	1 vb1 based(vp1),
	   2 (o, t, n, rr, r(vb.rr)) fixed,
	   2 v(vb1.n) bit(csize(vb.t)),

	1 sb based(sp),				/* Source bead */
	   2 o fixed,
	   2 source char(pp->p_nschars),

	1 gb based(gp),
	   2 (o, np, nq, l) fixed,
	   2 n char(gb.l),

	tm_var fixed int static init(46),
	tm_group fixed int static init(73),
	tm_zfn fixed int static init(48),
	tm_mfn fixed int static init (49),
	tm_dfn fixed int static init(50);


	call apl_get_symbol_ (name, symbol_pointer, (0));

	if symbol_pointer -> symbol_bead.meaning_pointer ^= null
	then do;
		if protected
		then do;
			call not_copied (name);
			return;
		     end;
		call wash (symbol_pointer -> symbol_bead.meaning_pointer);
	     end;

	if q -> ub.t = tm_var			/* COPY VARIABLE */
	then do;
		if q->ub.vq=0 then return;
		vp = copy_expand(q->ub.vq);

		data_elements = vb.n;
		number_of_dimensions = vb.rr;

		go to get_type (vb.t);

get_type (1):		/* BIT */

		type = zero_or_one_value_type;
		n_words = size (numeric_datum) + 1;
		go to end_get_type;

get_type (2):		/* CHARACTER */

		type = character_value_type;
		n_words = size (character_string_overlay);
		go to end_get_type;

get_type (3):		/* INTEGER */

		type = integral_value_type;
		n_words = size (numeric_datum) + 1;
		go to end_get_type;

get_type (4):		/* FLOAT */

		type = numeric_value_type;
		n_words = size (numeric_datum) + 1;

end_get_type:
		n_words = n_words + size (value_bead);
		call apl_allocate_words_ (n_words, bead_pointer);

		symbol_pointer -> symbol_bead.meaning_pointer = bead_pointer;

		string (bead_pointer -> general_bead.type) = type;
		bead_pointer -> value_bead.total_data_elements = data_elements;
		bead_pointer -> value_bead.rhorho = number_of_dimensions;

		data_pointer = addr (bead_pointer -> value_bead.rho (number_of_dimensions + 1));

		if type & numeric_value_type
		then if substr (rel (data_pointer), 18, 1)
		     then data_pointer = addrel (data_pointer, 1);

		bead_pointer -> value_bead.data_pointer = data_pointer;

		do i = 1 to number_of_dimensions;
		     bead_pointer -> value_bead.rho (i) = vb.r (i);
		end;

		go to copy_data (vb.t);

copy_data (1):		/* BIT */

		do i = 0 by 1 while (i < data_elements);
		     if bit_value.element (i + 1)
		     then data_pointer -> numeric_datum (i) = 1e0;
		     else data_pointer -> numeric_datum (i) = 0e0;
		end;
		go to end_copy_data;

copy_data (2):		/* CHARACTER */

		data_pointer -> character_string_overlay = translate (character_value.string, v2_codes, v1_codes);
		go to end_copy_data;

copy_data (3):		/* INTEGER */

		do i = 0 by 1 while (i < data_elements);
		     data_pointer -> numeric_datum (i) = float (integer_value.element (i + 1), 63);
		end;
		go to end_copy_data;

copy_data (4):		/* FLOAT */

		do i = 0 by 1 while (i < data_elements);

		     /* unspec must be used because Version 1 APL does not double-word align floating
		        point numbers */

		     unspec (data_pointer -> numeric_datum (i)) = float_value.element (i + 1);
		end;

end_copy_data:
	     end;

	else if q -> ub.t >= tm_zfn & q -> ub.t <= tm_dfn	/* COPY FUNCTION */
	then do;
		if q->ub.vq=0 then return;

		pp = copy_expand(q->ub.vq);

		data_elements = pp -> pb.p_nschars;
		n_words = size (function_bead);

		call apl_allocate_words_ (n_words, bead_pointer);

		symbol_pointer -> symbol_bead.meaning_pointer = bead_pointer;

		string (bead_pointer -> general_bead.type) = function_type;
		bead_pointer -> function_bead.lexed_function_bead_pointer = null;
		bead_pointer -> function_bead.stop_control_pointer = null;
		bead_pointer -> function_bead.trace_control_pointer = null;
		vp = copy_expand (pp -> p_sourceq);

		if pp -> pb.p_nllines = 0		/* We have an external function */
		then do;
			if q -> ub.t = tm_zfn
			then bead_pointer -> function_bead.class = 2;	/* niladic fcn */
			else if q -> ub.t = tm_mfn
			     then bead_pointer -> function_bead.class = 3;	/* monadic fcn */
			     else bead_pointer -> function_bead.class = 4;	/* dyadic fcn */

			bead_pointer -> function_bead.text_length = data_elements;
			bead_pointer -> function_bead.text = vp -> sb.source;
		     end;
		else do;
			bead_pointer -> function_bead.class = 0;	/* NORMAL UNLOCKED FUNCTION */
			in_start = 1;
			in_length = length (vp -> sb.source);
			out_start = 1;
			do while (in_length > 2);
			     line_length = index (substr (vp -> sb.source, in_start, in_length), nl);
			     substr (bead_pointer -> function_bead.text, out_start, line_length) = translate (substr (
				vp -> sb.source, in_start, line_length), v2_codes, v1_codes);
			     out_start = out_start + line_length;
			     in_start = in_start + line_length + 2;
			     in_length = in_length - line_length - 2;
			end;

			bead_pointer -> function_bead.text_length = out_start - 1;

			call apl_function_lex_ (bead_pointer -> function_bead.text,
			     bead_pointer -> function_bead.lexed_function_bead_pointer, errors_occurred, 0, free_space_ptr);
		     end;
	     end;

	else if q -> ub.t = tm_group			/* COPY GROUP */
	then do;
		if q -> ub.vq = 0
		then return;

		/* Visit all members of this group to count how many there are */

		number_of_groupies = 1;
		do gp = copy_expand (q -> ub.vq) repeat copy_expand (gp -> gb.nq) while (gp -> gb.nq ^= 0);
		     number_of_groupies = number_of_groupies + 1;
		end;

		n_words = size (group_bead) + number_of_groupies;
		call apl_allocate_words_ (n_words, bead_pointer);

		symbol_pointer -> symbol_bead.meaning_pointer = bead_pointer;

		string (bead_pointer -> general_bead.type) = group_type;

		bead_pointer -> group_bead.number_of_members = number_of_groupies;

		gp = copy_expand (q -> ub.vq);
		do i = 1 to number_of_groupies;
		     call apl_get_symbol_ (gp -> gb.n, symbol_pointer, (0));

		     bead_pointer -> group_bead.member (number_of_groupies - i + 1) = symbol_pointer;

		     if chase_names
		     then do;
			     vp1 = copy_symget(gp->gb.n);
			     if vp1=null then call not_copied(gp->gb.n);
			     else call copy(gp->gb.n, vp1, "0"b);
			end;
		     gp = copy_expand (gp -> gb.nq);
		end;
	     end;

	else call not_copied(name||"*");

	/* Don't flush if we created this guy, otherwise be transparent. */

	if symbol_pointer -> general_bead.reference_count > 1
	then call wash (symbol_pointer);

	return;

end;

wash:
	procedure (bv_bead_pointer);

/* parameters */

declare	bv_bead_pointer pointer unaligned parameter;

/* automatic */

declare	bead_pointer pointer unaligned;

/* program */

	bead_pointer = bv_bead_pointer;

	bead_pointer -> general_bead.reference_count = bead_pointer -> general_bead.reference_count - 1;

	if bead_pointer -> general_bead.reference_count < 1
	then call apl_free_bead_ (bead_pointer);

	return;

end wash;

copy_expand:	proc(val) returns(ptr);

dcl
	val fixed,
	i fixed,
	sptr ptr,
	high fixed,
	low fixed,
	try fixed;

	if val=0 then return(null);

	high = tablen;
	low = 1;

loop:	if high=low then do;
	   try = high;
	   go to found;
	   end;

	try = divide(high + low, 2, 17, 0);

	i = binary(table(try).old.seg || table(try).old.rel, 27);

	if i=val then go to found;

	if i<val then low = try + 1;
	else high = try - 1;

	go to loop;

found:
	i = bin(table(try).new.seg, 9);
	if got(i)=0 then do;
	   call msf_manager_$get_ptr(fcbp, i-1, "0"b, sptr, bitcount, code);
	   if sptr=null then go to not_found;
	   got(i) = bin(baseno(sptr), 18);
	   end;

	return(ptr(baseptr(got(i)), bin(table(try).new.rel,18) + bin(substr(unspec(val),19,18),18)
	   - bin(table(try).old.rel,18)));

	end;

copy_symget:
	procedure (name) returns (ptr);

/* parameters */

declare	name char (*);

/* automatic */

declare	(i, hook) fixed bin;

/* based */

declare	char4 char (4) based;

/* program */

	addr (i) -> char4 = name;
	i = mod (i, prime);

	do hook = buckets (i).q repeat p-> sb.nq while (hook ^= 0);
	     p = copy_expand (hook);
	     if p->sb.length = length(name)
	     then go to found;
	end;
	return (null);

found:	if p->sb.uq=0 then return(null);

	do p = copy_expand (p -> sb.uq) repeat copy_expand (p -> ub.nq) while (p -> ub.nq ^= 0);
	end;

	if p -> ub.globg
	then return (p);
	else return(null);

     end copy_symget;

not_copied:	proc(name);

dcl
	name char(*);

	if length(line)=0 then line = "not copied:    ";

	if length (line) + length (name) > ws_info.width
	then do;
prt_line:
		call ioa_$ioa_stream ("apl_output_", "^a", line);
		line = (15)" ";
		go to ok;
	     end;

	line = line || substr((8)" ", 1, 8-mod(length(line), 8));
	if length (line) + length (name) > ws_info.width
	then go to prt_line;

ok:	line = line || name;

	return;

	end;




%include apl_number_data;
%include apl_ws_info;
%include apl_save_frame;
%include apl_bead_format;
%include apl_symbol_bead;
%include apl_value_bead;
%include apl_group_bead;
%include apl_function_bead;

end;




		    apl_wsid_command_.pl1           11/29/83  1638.6rew 11/29/83  1347.3       10098



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

/* This program implements the )WSID command
   Modified 740910 by PG for installation.
*/

apl_wsid_command_:
	procedure (a_wsid);

	if a_wsid = ""
	then call ioa_$ioa_stream (output_stream, "is ^a", ws_info.wsid);
	else do;
		call ioa_$ioa_stream (output_stream, "was ^a", ws_info.wsid);
		ws_info.wsid = a_wsid;
	     end;

	return;

/* parameters */

declare a_wsid char (*) parameter;

/* entries */

declare ioa_$ioa_stream entry options (variable);

/* internal static initial */

declare output_stream char (32) initial ("apl_output_") internal static;

/* include files */

%include apl_number_data;
%include apl_ws_info;
end apl_wsid_command_;



*/
                                          -----------------------------------------------------------


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

*/
