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) 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 and . 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 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 */