COMPILATION LISTING OF SEGMENT apl_monadic_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1609.9 mst Tue Options: optimize map 1 /* ****************************************************** 2* * * 3* * * 4* * Copyright (c) 1972 by Massachusetts Institute of * 5* * Technology and Honeywell Information Systems, Inc. * 6* * * 7* * * 8* ****************************************************** */ 9 10 /* All scalar monadic and dyadic operators are implemented in this module, 11* including reduction, outer and inner product, and scan. 12* 13* Created by G. Gordon Benedict on 06/23/73 14* Modified on 740508 by PG to fix bug in 0!0 15* Modified on 740614 by PG and GGB to fix bug in 10*^3 (was wrong data type) 16* Modified on 741115 by PG to fix logarithm to check for errors properly, 17* and fix (and, or, nand, nor) to work with vectors. 18* Modified 750331 by PG to fix inner product to call do_many subroutine properly 19* for each operator. 20* Modified 750714 by PG to fix residue to use special apl_floor_ operator. 21* Modified 760901 by PG to get 0*0 to work, to make trig operator validate left arg in 22* all cases, and to fix = and /= of chars not to overlay the operands. 23* Modified 760902 by PG to redo handling of data types so that all results are numeric except 24* when reduction or scan just drops a dimension. Bug fixed that caused result of operating 25* on null vectors when one arg is numeric and the other character to have no type bits. 26* Modified 780210 by PG to use apl_push_stack_ (bug 278), and to fix 310 27* (scanning with a non-commutative operator overlayed result on input operand and clobbered it). 28* Modified 780303 by PG to fix bug 189 by making 0-:0 be 1, and to signal a zerodivide domain error 29* if the divisor is equal to zero. 30* Modified 780510 by William York to fix bug 322 by un-special-casing scalar operands to the scan 31* operator that are on the value stack. 32* Modified 781011 by WMY to fix bugs 311, 338, and 341. 33* Modified 781101 by PG to fix bug 348 (reducing dimensions of unity extent fails), 34* which was introduced 781011 when bug 338 was fixed. 35* Modified 790122 by PG to use apl_error_table_$invalid_circular_fcn. 36* Modified 790124 by PG to fix bug 360 (or-scan and and-scan of Booleans fail) and 359 (+/'' is not 37* double-word aligned). 38* Modified 790326 by PG to add monadic not equal, and to call apl_display_bead_. 39* Modified 790618 by PG to fix 327 (binomial coefficients fails for negative args). 40* Modified 790713 by PG to fix 407 (1-,'A' worked because type of operand 41* was tested after overlayed result type was set!) 42* Modified 790717 by PG for sugg 405 to change computation of the gamma 43* function to use a more accurate algorithm. 44* Modified 790727 by PG to put divide-reduction back into assembly language subroutine. 45* Modified 800131 by BIM and PG to use new apl_monadic_not_appendage_ alm procedure. 46* Modified 800302 by BIM to use new apl_dyadic_bool_appendage_ alm procedure. 47* Modified 820429 by JRG to allow 50 choose 0 (0 ! 50). Used to give domain errors. 48**/ 49 50 apl_monadic_: 51 procedure (operators_argument); /* procedure to handle monadic type operators */ 52 53 /* automatic */ 54 55 declare 56 copy_up_needed bit (1) aligned, /* ON if a stack operand could not be overlayed */ 57 left_chars bit (1) aligned, /* ON if left opnd is character */ 58 right_chars bit (1) aligned, /* ON if right opnd is character */ 59 swapped_flag bit (1) aligned; /* ON if order of operands was exchanged */ 60 61 dcl ( 62 copy_rho_vb, /* ptr to value bead to take rho from for result */ 63 right_vb, /* pointer to value bead for operand to right of operator */ 64 right_array, /* ptr to right operand itself (data ptr from right v.b.) */ 65 left_vb, /* ptr to v.b. to left of operator */ 66 left_array, /* ptr to left operand */ 67 result_vb, /* ptr to result v.b. */ 68 result_array /* where result array will be stored */ 69 ) pointer aligned; 70 71 dcl ( 72 subscript, 73 right_data_elements, /* number of elements in right array */ 74 left_data_elements, /* number of elements in left array */ 75 plane_base, /* used in reduction; base of plane in operand array */ 76 column_base, /* base of column in reduction currently being reduced */ 77 interval_between_elements, /* interval between elements in same column being reduced */ 78 column_skip_interval, /* how many times column_base is to be incremented by 1 before plane_base is */ 79 highest_column_element, /* subscript into right operand array of highest subscript element in 80* column referenced during reduction -- first referenced */ 81 column_skip_interval_minus_1, /* just to save subtracting 1 in a loop */ 82 rho_sub_dimension, /* the extent of that dimension (copied for efficiency) */ 83 last_column_on_this_plane, /* in reduction, last column base address + 1 */ 84 data_elements /* used to tell stack_allocate_known how many elements are needed */ 85 ) fixed binary precision (21); 86 87 declare (data_words_needed, /* to tell stack_allocate_known how many words needed */ 88 number_to_copy, /* number of words in word_copy_overlay for copying */ 89 words_needed, /* words needed to get from value stack. set by stack_allocate_known */ 90 words_needed_in_bead /* words needed in value bead to be allocated. */ 91 ) fixed binary precision (19); /* for word counts */ 92 93 dcl (left_rhorho, /* no of dimensions of left operand */ 94 dimension, /* the dimension to reduce along (for reduction) */ 95 right_rhorho, /* same for right */ 96 rhorho, /* used to tell stack_allocate_known how much space needed in value bead */ 97 rho_subscript, /* steps thru rho arrays, and as a temp in monadic */ 98 trig_integer, /* integer which is left arg to circle functions */ 99 dyadic_action_place, /* for dyadic routines */ 100 many_action_place, /* which complicated operation to do (log, exp, binomial coefficients, etc.) */ 101 special_case, /* added to many_action_place to get label - either 0 or 1 */ 102 action_place, /* label array subscript identifying action routine in subroutines */ 103 op1 /* copy of operator code */ 104 ) fixed binary; 105 106 dcl (single_element_fl_1, /* used to hold one arg if it is a scalar and the other an array */ 107 single_element_fl_2, /* used if both operands are scalars (holds right element) */ 108 fuzz, /* copy of fuzz in ws_info for efficiency */ 109 integer_fuzz, /* copy of integer_fuzz */ 110 float_temp, /* temporary for float -> integer conversions */ 111 boolean_both, /* set to 1 for and/nand 0 for or/nor */ 112 set_on_equal, /* used in char compare; what result is set to on equal compare */ 113 dyadic_set_on_equal, /* value of set_on_equal for dyadic operations */ 114 dyadic_set_on_not_equal, /* value of set_on_not_equal for dyadic operations */ 115 dyadic_boolean_both, /* value of boolean_both for dyadic operations */ 116 dyadic_boolean_neither, /* value of boolean_neither for dyadic operations */ 117 reduction_set_on_equal, /* value of set_on_equal for reduction operations */ 118 reduction_set_on_not_equal, /* value of set_on_not_equal for reduction operations */ 119 reduction_boolean_both, /* value of boolean_both for reduction operations */ 120 reduction_boolean_neither, /* value of boolean_neither for reduction operations */ 121 result_accumulator) float; /* steps 1 by 1 to fill in iota array */ 122 123 declare 1 reduction_type aligned like general_bead.type; /* so reduction knows what type of operand it's getting */ 124 declare 1 free_type aligned like general_bead.type; 125 declare 1 save_free_type aligned like general_bead.type; 126 127 /* entries */ 128 129 declare apl_display_bead_ entry (ptr, bit (1) aligned), 130 apl_monadic_not_appendage_ entry (ptr, fixed bin (21), ptr, fixed bin), 131 apl_monadic_not_appendage_$in_place entry (ptr, fixed bin (21)), 132 (apl_dyadic_bool_appendage_$and, 133 apl_dyadic_bool_appendage_$nand, 134 apl_dyadic_bool_appendage_$or, 135 apl_dyadic_bool_appendage_$nor, 136 apl_dyadic_bool_appendage_$eq, 137 apl_dyadic_bool_appendage_$neq) 138 entry (ptr, ptr, ptr, fixed bin (21)), 139 apl_reduction_appendage_ entry (pointer, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, float bin (63)), 140 apl_reduction_appendage_$divide entry (pointer, fixed bin (21), fixed bin (21), fixed bin (21), fixed bin, float bin (63), 141 label); 142 143 /* external static */ 144 145 declare (apl_error_table_$compatibility_error, 146 apl_error_table_$display_disabled, 147 apl_error_table_$domain, 148 apl_error_table_$invalid_circular_fcn, 149 apl_error_table_$length, 150 apl_error_table_$no_identity, 151 apl_error_table_$rank, 152 apl_error_table_$zerodivide) fixed bin (35) external static; 153 154 /* builtins */ 155 156 declare (abs, addr, addrel, binary, ceil, complex, divide, exp, fixed, floor, imag, log, 157 max, min, mod, real, rel, sign, substr, size, string, unspec) builtin; 158 159 /* based */ 160 161 dcl unal_fl_bit_ovly bit (72) aligned based; /* for copying either a char on a word boundary 162* or a floating pt number, without knowing which */ 163 dcl word_copy_overlay based dimension (number_to_copy) fixed bin (35); /* for aggregate array copies */ 164 165 /* internal static */ 166 167 dcl pi static internal float init /* a bit string rendering of pi */ 168 ( .110010010000111111011010101000100010000101101000110000100011010e+2b); 169 170 declare booleans (11 : 14) static internal float initial 171 (1, 0, 1, 0); 172 173 dcl identity (0 : 20) float static internal init /* identity for this operator */ 174 ((2) 0, (2) 1, 175 - .1701411834604692317e+39, 176 .1701411834604692317e+39, 177 1, (2) 0, 1, 0, 1, 178 (2) 0, 1, 0, (3) 1, (2) 0); 179 180 dcl 1 operator_info (0:20) static internal aligned, /* gives info about operators */ 181 2 identity_type bit (18) unal init /* the type of the identity -- an error if ""b (no ident for this op) */ 182 ((4)("001000000011100000"b),(2)("001000000010000000"b), (1) ("001000000011100000"b), (1) (""b), 183 (2)("001000000011100000"b), (1) (""b),(2)("001000000011100000"b),(2)(""b),(6)("001000000011100000"b)), 184 2 eq_or_not_eq bit (1) unal init ((17) ("0"b), "1"b, (2) ("0"b), "1"b), 185 2 padding bit (17) unal; 186 187 dcl (scalar init (0), /* when added to 4 * op1 gives label subscript for routine to handle it */ 188 vector init (1), /* similarly when added this is for vector routines */ 189 scalar_vector init (2), /* for scalar on left, vector on right */ 190 vector_scalar init (3), /* for vector on left, scalar on right */ 191 char_compare init (-4)) /* when subtracted from 1 of the above values gives subscript into 192* label array in dyadic_operate subr. of char comparison routines */ 193 static internal fixed bin; 194 195 /* include files */ 196 1 1 /* ====== BEGIN INCLUDE SEGMENT apl_number_data.incl.pl1 ================================== */ 1 2 1 3 /* 1 4* This include file contains information about the machine representation of numbers. 1 5* In all programs numbers should simply be declared 'float'. 1 6* All default statements should be in this include file. 1 7* 1 8* This is the binary version. The manifest constant Binary should be used by programs 1 9* that need to know whether we are using binary or decimal. 1 10* */ 1 11 1 12 /* format: style3,initlm0,idind30 */ 1 13 1 14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63); 1 15 1 16 declare ( 1 17 TheBiggestNumberWeveGot float initial (0.1701411834604692317e+39), 1 18 TheSmallestNumberWeveGot float initial (.1469367938527859385e-38), 1 19 Binary bit (1) aligned initial ("1"b) 1 20 ) internal static options (constant); 1 21 1 22 /* Number of characters in a number datum entry; used for copying float number arrays as strings. 1 23* (Obsolete! use array copies!) */ 1 24 1 25 declare NumberSize fixed binary precision (4) internal static initial (8); 1 26 1 27 /* ------ END INCLUDE SEGMENT apl_number_data.incl.pl1 ---------------------------------- */ 197 2 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 2 2 2 3 declare 1 operators_argument aligned, 2 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 2 5* if operand (1).value is null, operator is monadic */ 2 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 2 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 2 8 2 operator aligned, /* information about the operator to be executed */ 2 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 2 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 2 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 2 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 2 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 2 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 2 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 2 16 2 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 198 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 3 2 3 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 3 4 2 type unaligned, 3 5 3 bead_type unaligned, 3 6 4 operator bit (1), /* ON if operator bead */ 3 7 4 symbol bit (1), /* ON if symbol bead */ 3 8 4 value bit (1), /* ON if value bead */ 3 9 4 function bit (1), /* ON if function bead */ 3 10 4 group bit (1), /* ON if group bead */ 3 11 4 label bit (1), /* ON if label bead */ 3 12 4 shared_variable bit (1), /* ON if shared variable bead */ 3 13 4 lexed_function bit (1), /* ON if lexed function bead */ 3 14 3 data_type unaligned, 3 15 4 list_value bit (1), /* ON if a list value bead */ 3 16 4 character_value bit (1), /* ON if a character value bead */ 3 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 3 18 4 integral_value bit (1), /* ON if an integral value bead */ 3 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 3 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 3 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 3 22 2 size bit (18) unaligned, /* Number of words this bead occupies 3 23* (used by bead storage manager) */ 3 24 2 reference_count fixed binary (29); /* Number of pointers which point 3 25* to this bead (used by bead manager) */ 3 26 3 27 3 28 /* constant strings for initing type field in various beads */ 3 29 3 30 declare ( 3 31 operator_type init("100000000000000000"b), 3 32 symbol_type init("010000000000000000"b), 3 33 value_type init("001000000000000000"b), 3 34 function_type init("000100000000000000"b), 3 35 group_type init("000010000000000000"b), 3 36 label_type init("001001000011000000"b), 3 37 shared_variable_type init("001000100000000000"b), 3 38 lexed_function_type init("000000010000000000"b), 3 39 3 40 list_value_type init("000000001000000000"b), 3 41 character_value_type init("001000000100000000"b), 3 42 numeric_value_type init("001000000010000000"b), 3 43 integral_value_type init("001000000011000000"b), 3 44 zero_or_one_value_type init("001000000011100000"b), 3 45 complex_value_type init("001000000000010000"b), 3 46 3 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 3 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 3 49 ) bit(18) internal static; 3 50 3 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 199 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 4 2 4 3 declare 4 4 number_of_dimensions fixed bin, 4 5 4 6 1 value_bead aligned based, 4 7 2 header aligned like general_bead, 4 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 4 9 2 rhorho fixed binary, /* number of dimensions of value */ 4 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 4 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 4 12 /* dimensions of value (zero-origin) */ 4 13 4 14 4 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 4 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 4 17 /* actual elements of character array */ 4 18 4 19 declare character_string_overlay character (data_elements) aligned based; 4 20 /* to overlay on above structure */ 4 21 4 22 4 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 4 24 /* actual elements of numeric array */ 4 25 4 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 4 27 4 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 4 29 4 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 200 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 5 2 5 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 5 4 5 5 /* automatic */ 5 6 5 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 5 8 5 9 /* external static */ 5 10 5 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 5 12 2 static_ws_info_ptr unaligned pointer; 5 13 5 14 /* based */ 5 15 5 16 declare 1 ws_info aligned based (ws_info_ptr), 5 17 2 version_number fixed bin, /* version of this structure (3) */ 5 18 2 switches unaligned, /* mainly ws parameters */ 5 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 5 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 5 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 5 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 5 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 5 24 3 restrict_external_functions 5 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 5 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 5 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 5 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 5 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 5 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 5 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 5 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 5 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 5 34 3 compatibility_check_mode 5 35 bit, /* if 1, check for incompatible operators */ 5 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 5 37 /* remaining 20 bits not presently used */ 5 38 5 39 2 values, /* attributes of the workspace */ 5 40 3 digits fixed bin, /* number of digits of precision printed on output */ 5 41 3 width fixed bin, /* line length for formatted output */ 5 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 5 43 3 random_link fixed bin(35), /* seed for random number generator */ 5 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 5 45 3 float_index_origin float, /* the index origin in floating point */ 5 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 5 47 3 maximum_value_stack_size 5 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 5 49 5 50 2 pointers, /* pointers to various internal tables */ 5 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 5 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 5 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 5 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 5 55 5 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 5 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 5 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 5 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 5 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 5 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 5 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 5 63 2 signoff_lock character (32), 5 64 5 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 5 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 5 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 5 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 5 69 bit, /* munging his tables */ 5 70 3 unused_interrupt_bit bit, /* not presently used */ 5 71 3 dont_interrupt_command bit, 5 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 5 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 5 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 5 75 5 76 2 user_name char (32), /* process group id of user */ 5 77 2 immediate_input_prompt char (32) varying, /* normal input */ 5 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 5 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 5 80 2 vcpu_time aligned, 5 81 3 total fixed bin (71), 5 82 3 setup fixed bin (71), 5 83 3 parse fixed bin (71), 5 84 3 lex fixed bin (71), 5 85 3 operator fixed bin (71), 5 86 3 storage_manager fixed bin (71), 5 87 2 output_info aligned, /* data pertaining to output buffer */ 5 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 5 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 5 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 5 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 5 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 5 93 5 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 5 95 5 96 /* internal static */ 5 97 5 98 declare max_parse_stack_depth fixed bin int static init(64536); 5 99 5 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 201 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_operator_codes.incl.pl1 =============================== */ 6 2 6 3 /* This include file contains declarations of the 9-bit codes used for each operator. */ 6 4 6 5 /* Modified 811211 by H. Hoover (UofC) to add quadcall_semicolon_code. */ 6 6 /* Modified 811211 by H. Hoover (UofC) to add semicolon_cons_code. */ 6 7 6 8 declare (plus_code init (0), 6 9 minus_code init (1), 6 10 times_code init (2), 6 11 divide_code init (3), 6 12 max_code init (4), 6 13 min_code init (5), 6 14 power_code init (6), 6 15 log_code init (7), 6 16 residue_code init (8), 6 17 factorial_code init (9), 6 18 trig_code init (10), 6 19 and_code init (11), 6 20 or_code init (12), 6 21 nand_code init (13), 6 22 nor_code init (14), 6 23 less_code init (15), 6 24 less_equal_code init (16), 6 25 equal_code init (17), 6 26 greater_equal_code init (18), 6 27 greater_code init (19), 6 28 not_equal_code init (20), 6 29 6 30 /* space will be left here in case more simple operators are added one day */ 6 31 6 32 rho_code init (36), 6 33 ravel_code init (37), 6 34 iota_code init (38), 6 35 take_code init (39), 6 36 leave_code init (40), 6 37 grade_up_code init (41), 6 38 grade_down_code init (42), 6 39 branch_code init (67), 6 40 semicolon_cons_code init (72), 6 41 fnames_code init (83), 6 42 fnums_code init (84), 6 43 laminate_code init (93), 6 44 stop_code init (100), 6 45 trace_code init (101), 6 46 assignment_code init (102), 6 47 subscripted_assignment_code 6 48 init (103), 6 49 assign_to_stop_code init (112), 6 50 assign_to_trace_code 6 51 init (113), 6 52 quadcall_semicolon_code 6 53 init (124) 6 54 ) fixed binary (8) internal static; 6 55 6 56 /* ------ END INCLUDE SEGMENT apl_operator_codes.incl.pl1 ------------------------------- */ 202 203 204 /* procedure to handle monadic operators. first copy info from argument structure for efficiency */ 205 206 call monadic_extract (); 207 go to monadic_common; 208 209 /* this entry is called only for monadic not. it is not with the other monadic operators because it cannot be 210* use dyadically (thus cannot participate in reduction, inner product, etc). Therefore its operator code 211* is not contiguous with the others, making the monadic_do label array hard to use. In order to use common code, 212* since monadic not otherwise acts like all the other monadic operators, it is given an operator code contiguous 213* to the others (16) solely for use within this program */ 214 215 apl_monadic_not_: 216 entry (operators_argument); 217 218 call monadic_extract (); 219 op1 = 16; /* assign dummy operation code */ 220 221 monadic_common: 222 rhorho = right_rhorho; /* will want result to conform with arg operand */ 223 data_elements = right_data_elements; 224 225 if operators_argument.operands (2).on_stack then do; /* can overlay result on operand completely */ 226 operators_argument.result, /* parse wants address of result too */ 227 result_vb = right_vb; /* overlay result v.b. on operand v.b. */ 228 result_array = right_array; /* and result array on operand array */ 229 end; 230 else do; /* not such good luck, operand not on stack */ 231 if right_chars 232 then call stack_allocate_char (); 233 else call stack_allocate_numeric (); 234 235 if right_vb -> value_bead.rhorho > 0 236 then result_vb -> value_bead.rho (*) = right_vb -> value_bead.rho (*); 237 238 string (result_vb -> value_bead.header.type) = string (free_type); 239 end; 240 241 if right_data_elements = 0 /* nothing to do */ 242 then if (op1 ^= equal_code) & (op1 ^= not_equal_code) /* unless debugging operators */ 243 then return; 244 245 /* note all monadic operators must not have a character operand -- check this */ 246 247 if right_chars 248 then if (op1 ^= equal_code) & (op1 ^= not_equal_code) /* let debugging operators thru */ 249 then go to domain_error_right; 250 251 goto monadic_do (op1); /* go to action code for this operator */ 252 253 /* Here begins the actual monadic operator action routines */ 254 255 monadic_do (0): /* PLUS. just return */ 256 if operators_argument.operands (2).on_stack then return; /* with same thing as called with */ 257 result_array -> numeric_datum = 258 right_array -> numeric_datum; /* copy data because operand was not on the stack */ 259 return; 260 261 monadic_do (1): /* MINUS. negate each element of argument */ 262 result_vb -> value_bead.header.type.zero_or_one_value = "0"b; /* probably will not make just 0s or 1s */ 263 264 result_array -> numeric_datum = - right_array -> numeric_datum; 265 return; 266 267 monadic_do (2): /* SIGNUM. 0 if 0, -1 if <0, 1 if >0 */ 268 result_vb -> value_bead.header.type.integral_value = "1"b; 269 270 do subscript = 0 by 1 while (subscript < data_elements); 271 if abs (right_array -> numeric_datum (subscript)) < integer_fuzz then 272 result_array -> numeric_datum (subscript) = 0; /* equal to zero within integer_fuzz */ 273 else if right_array -> numeric_datum (subscript) < 0 then /* negative, set result element to -1 */ 274 result_array -> numeric_datum (subscript) = -1; 275 else result_array -> numeric_datum (subscript) = 1; 276 end; 277 return; 278 279 monadic_do (3): /* INVERT. invert each element of arg operand */ 280 string (result_vb -> value_bead.header.type) = numeric_value_type; 281 do subscript = 0 by 1 while (subscript < data_elements); 282 if right_array -> numeric_datum (subscript) = 0e0 283 then go to zerodivide_error_right; 284 else result_array -> numeric_datum (subscript) = 1e0 / right_array -> numeric_datum (subscript); 285 end; 286 return; 287 288 /* N.B. For both ceiling and floor, if the input argument is 289* within "integer fuzz" of its integer value, the result 290* is this integer value. Otherwise, the result is the value 291* of the respective function. */ 292 293 monadic_do (4): /* CEILING. smallest integer greater than arg. */ 294 string (result_vb -> value_bead.header.type) = integral_value_type; 295 do subscript = 0 by 1 while (subscript < data_elements); 296 single_element_fl_1 = right_array -> numeric_datum (subscript); 297 result_accumulator = floor (single_element_fl_1 + .5e0); 298 299 if abs (result_accumulator - single_element_fl_1) >= integer_fuzz 300 then result_accumulator = ceil (single_element_fl_1); 301 302 result_array -> numeric_datum (subscript) = result_accumulator; 303 end; 304 return; 305 306 monadic_do (5): /* FLOOR. greatest integer smaller than arg. */ 307 string (result_vb -> value_bead.header.type) = integral_value_type; 308 do subscript = 0 by 1 while (subscript < data_elements); 309 single_element_fl_1 = right_array -> numeric_datum (subscript); 310 result_accumulator = apl_floor_ (single_element_fl_1); 311 result_array -> numeric_datum (subscript) = result_accumulator; 312 end; 313 return; 314 315 316 monadic_do (6): /* EXPONENTIATION. raise to e'th power */ 317 string (result_vb -> value_bead.header.type) = numeric_value_type; 318 do subscript = 0 by 1 while (subscript < data_elements); 319 320 result_array -> numeric_datum (subscript) = /* exponentiate it */ 321 exp (right_array -> numeric_datum (subscript)); 322 end; 323 return; 324 325 monadic_do (7): /* BASE E LOGARITHM. */ 326 string (result_vb -> value_bead.header.type) = numeric_value_type; 327 do subscript = 0 by 1 while (subscript < data_elements); 328 if right_array -> numeric_datum (subscript) < integer_fuzz then 329 goto domain_error; 330 result_array -> numeric_datum (subscript) = 331 log (right_array -> numeric_datum (subscript)); 332 end; 333 return; 334 335 monadic_do (8): /* ABSOLUTE VALUE. */ 336 if right_vb -> value_bead.zero_or_one_value 337 then go to monadic_do (0); /* treat like monadic plus */ 338 339 result_array -> numeric_datum = 340 abs (right_array -> numeric_datum); 341 return; 342 343 monadic_do (9): /* FACTORIAL. */ 344 do subscript = 0 by 1 while (subscript < data_elements); 345 result_array -> numeric_datum (subscript) = 346 gamma (right_array -> numeric_datum (subscript) + 1e0); 347 end; 348 return; 349 350 monadic_do (10): /* PI TIMES. */ 351 string (result_vb -> value_bead.header.type) = numeric_value_type; 352 result_array -> numeric_datum = 353 pi * right_array -> numeric_datum; 354 return; 355 356 monadic_do (16): /* MONADIC NOT. */ 357 if right_vb -> value_bead.header.type.zero_or_one_value then do; /* known is 0 or 1, optimize */ 358 if operators_argument.operands (2).on_stack 359 then call apl_monadic_not_appendage_$in_place (right_array, right_data_elements); 360 else call apl_monadic_not_appendage_ (right_array, right_data_elements, result_array, rho_subscript); 361 362 /* The following statement is the old PL/I code that the above subroutine calls replaced. 363* It is retained here to make it easy to revert the ALM version. 364* 365* result_array -> numeric_datum (*) = 1 - right_array -> numeric_datum (*); */ 366 367 return; 368 end; 369 370 string (result_vb -> value_bead.header.type) = zero_or_one_value_type; 371 372 do subscript = 0 by 1 while (subscript < data_elements); 373 if abs (right_array -> numeric_datum (subscript)) < integer_fuzz then /* = 0, return 1 */ 374 result_array -> numeric_datum (subscript) = 1; /* set to 1 */ 375 else 376 if abs (right_array -> numeric_datum (subscript) - 1) < integer_fuzz then /* = 1, return 0 */ 377 result_array -> numeric_datum (subscript) = 0; /* set to 0 */ 378 else goto domain_error; /* monadic not must have either 0 or 1 */ 379 end; 380 return; 381 382 monadic_do (17): /* MONADIC EQUAL. (display long) */ 383 monadic_do (20): /* MONADIC NOT EQUAL. (display brief) */ 384 if ^ws_info.debug_mode /* Don't let random users trip over this...got to know the secret */ 385 then go to display_disabled; 386 387 call apl_display_bead_ (right_vb, (op1 = not_equal_code)); /* brief if op is not equal */ 388 389 if ^operators_argument.operands (2).on_stack 390 then result_array -> numeric_datum (*) = right_array -> numeric_datum (*); 391 392 return; 393 394 /* The following entry point handles all dyadic operators */ 395 396 apl_dyadic_: 397 entry (operators_argument); 398 399 call dyadic_extract (); 400 call dyadic_result_lowest (); /* point result_vb at operand lowest in stack */ 401 402 /* check conformity of operands. either one (or both) must be effective scalars, i.e., have only 403* one element, or they must have the same number of dimensions (rank error if not true) and each dimension 404* must have the same length (length error if not) */ 405 406 if left_data_elements ^= 1 then do; /* left is not scalar; check right */ 407 data_elements = left_data_elements; /* since left is not scalar, result must be equal to it in size */ 408 409 if right_data_elements ^= 1 then do; 410 if left_rhorho ^= right_rhorho then goto rank_error; /* loses */ 411 do subscript = 0 by 1 while (subscript < left_rhorho); /* make sure each element of rho vectors are equal */ 412 if left_vb -> value_bead.rho (subscript + 1) ^= right_vb -> value_bead.rho (subscript + 1) then 413 goto length_error; /* same no of dims but bounds don't match */ 414 end; 415 dyadic_action_place = vector; /* routine for vectors (or scalars) as both operands */ 416 end; 417 else do; 418 unspec (single_element_fl_1) = right_array -> unal_fl_bit_ovly; 419 right_array = left_array; /* reverse order of arrays; action routines use right_array as 420* operand pointers when one arg is scalar */ 421 swapped_flag = "1"b; /* indicate swap for error handlers */ 422 dyadic_action_place = vector_scalar; /* action routine for left vector, right scalar */ 423 end; 424 copy_left: 425 rhorho = left_rhorho; /* use dimensionality of left operand */ 426 copy_rho_vb = left_vb; /* .. */ 427 end; 428 else do; /* left scalar, right vector */ 429 data_elements = right_data_elements; /* since left is scalar, result has length of right */ 430 if right_data_elements = 1 then do; /* both scalar */ 431 dyadic_action_place = scalar; /* action routine if both are scalars */ 432 unspec (single_element_fl_2) = right_array -> unal_fl_bit_ovly; /* copy right scalar */ 433 unspec (single_element_fl_1) = left_array -> unal_fl_bit_ovly; /* copy left scalar */ 434 if left_rhorho > right_rhorho then 435 goto copy_left; /* both have 1 element, but use left rhorho */ 436 end; 437 else do; /* right is not scalar */ 438 dyadic_action_place = scalar_vector; /* scalar on left, vector on right */ 439 unspec (single_element_fl_1) = left_array -> unal_fl_bit_ovly; /* copy left scalar */ 440 end; 441 rhorho = right_rhorho; 442 copy_rho_vb = right_vb; 443 end; 444 445 call stack_allocate_numeric (); 446 447 if copy_rho_vb -> value_bead.rhorho > 0 448 then result_vb -> value_bead.rho (*) = copy_rho_vb -> value_bead.rho (*); 449 450 call fill_type (); /* fill type field of result operand */ 451 452 if data_elements = 0 then return; /* both operands null, return null vector */ 453 454 dyadic_set_on_equal = set_on_equal; 455 dyadic_set_on_not_equal = 1 - set_on_equal; 456 457 dyadic_boolean_both = boolean_both; 458 dyadic_boolean_neither = 1 - boolean_both; 459 460 if left_chars | right_chars 461 then do; 462 if ^ operator_info (op1).eq_or_not_eq then do; /* only = and /= can take chars */ 463 if left_chars then 464 goto domain_error_left; 465 goto domain_error_right; 466 end; 467 if left_chars ^= right_chars 468 then do; /* chars on one side, numbers on other */ 469 result_array -> numeric_datum = dyadic_set_on_not_equal; /* 1s if /=, 0s if = */ 470 return; 471 end; 472 dyadic_action_place = dyadic_action_place + 473 char_compare; /* transform to label subscript of char compares in dyadic subr. */ 474 end; 475 else dyadic_action_place = dyadic_action_place + (4 * op1); /* transform to correct label subscript */ 476 477 call dyadic_operate (); 478 479 if copy_up_needed 480 then go to copy_up_stack; 481 482 return; 483 484 apl_reduction_: 485 entry (operators_argument); 486 487 call monadic_extract (); 488 489 /* Scalars need special treatment. */ 490 491 if right_rhorho = 0 492 then do; 493 if dimension > 1 494 then go to rank_error; 495 496 if operators_argument.operands (2).on_stack /* try to special-case scalars on the stack */ 497 then do; 498 operators_argument.result = right_vb; /* still protected; just return it */ 499 return; 500 end; 501 502 rhorho = 0; 503 rho_sub_dimension = 1; 504 end; 505 else do; 506 rhorho = right_rhorho - 1; 507 if dimension > right_rhorho then goto rank_error; /* dimension is out of bounds */ 508 rho_sub_dimension = right_vb -> value_bead.rho (dimension); /* the dimension which is to be deleted */ 509 end; 510 511 call monadic_result_lowest (); /* try to overlay result on right operand */ 512 string (reduction_type) = string (free_type); /* copy type field so reduction subroutine knows type */ 513 514 /* Check for null operands here. */ 515 516 if right_data_elements = 0 then do; /* operand was null, return either identities or null array */ 517 if rho_sub_dimension = 0 then do; /* dropping null dimension; find out how many elements in result */ 518 data_elements = 1; /* multiply all other dimensions except one to be dropped */ 519 do rho_subscript = 0 to dimension - 2, dimension by 1 while (rho_subscript < right_rhorho); 520 data_elements = data_elements * right_vb -> value_bead.rho (rho_subscript + 1); 521 end; 522 end; 523 else /* not dropping null dimension */ 524 data_elements = divide (right_data_elements, rho_sub_dimension, 21, 0); /* drop a dimension */ 525 526 call stack_allocate_numeric (); /* get a value bead plus data_elements number of identities */ 527 call fill_rho (); /* fill rho vector from operand, leaving out rho (dimension) */ 528 identity_fill: /* inner product comes to here if inner dim is 0 */ 529 string (result_vb -> value_bead.header.type) = 530 operator_info (op1).identity_type; /* assign result value bead correct type */ 531 if data_elements = 0 then return; /* return a null vector */ 532 if operator_info (op1).identity_type = "0"b then 533 goto no_identity_error; /* this operator cannot operate on a null vector */ 534 result_array -> numeric_datum = identity (op1); /* assign identity */ 535 return; 536 537 end; 538 539 /* Check for scalars and dimensions of unity extent here. */ 540 541 if rho_sub_dimension = 1 then do; /* just return operand with this rho dropped out */ 542 data_elements = right_data_elements; /* as many elements as in operand */ 543 if right_chars then 544 call stack_allocate_char (); 545 else /* numeric type */ 546 call stack_allocate_numeric (); 547 548 call fill_rho (); /* fill rho vector from operand, leaving out rho (dimension) */ 549 550 /* Recover proper data type...free_type is never character, but right operand might have been. */ 551 552 string (result_vb -> value_bead.type) = string (right_vb -> value_bead.type); 553 number_to_copy = data_words_needed; /* copy data */ 554 if number_to_copy > 0 then /* avoid zero length array (illegal PL/I) */ 555 result_array -> word_copy_overlay = /* copy arrays word by word */ 556 right_array -> word_copy_overlay; 557 return; 558 end; 559 560 /* Not a strange case. Calculate how many elements there will be in result by dividing number in operand 561* by length of dimension to be reduced */ 562 563 data_elements = divide (right_data_elements, rho_sub_dimension, 21, 0); 564 565 /* calculate various intervals in operand array */ 566 567 interval_between_elements = 1; /* the interval between elements within a column 568* being reduced is the product of all dimensions after the 569* one being reduced */ 570 do rho_subscript = dimension by 1 while (rho_subscript < right_rhorho); /* multiply them */ 571 interval_between_elements = interval_between_elements * 572 right_vb -> value_bead.rho (rho_subscript + 1); 573 end; 574 575 column_skip_interval = interval_between_elements * rho_sub_dimension; 576 column_skip_interval_minus_1 = column_skip_interval - interval_between_elements - 577 interval_between_elements; /* to save subtracting in loop */ 578 579 call stack_allocate_numeric (); 580 call fill_rho (); 581 call fill_type (); /* subroutine to copy type field with exceptions */ 582 583 /* if operator is = or /=, can take chars */ 584 585 /* if operand is character type, must special case it */ 586 587 if right_chars 588 then do; 589 if ^ operator_info (op1).eq_or_not_eq then 590 goto domain_error_right; /* only = and /= can take chars */ 591 if rho_sub_dimension > 2 then do; /* can optimize heavily */ 592 result_array -> numeric_datum = 1 - set_on_equal; /* = always returns 0 for more than 2 593* chars, /= always returns 1 */ 594 return; 595 end; 596 597 /* must be just 2 chars in dimension to reduce; 1 or 0 were special-cased before */ 598 599 element_size = 1; /* one char per element */ 600 action_place = -1; /* label subscript in reduction_operate routine for chars */ 601 end; 602 else /* not character, numeric */ 603 element_size = NumberSize; /* that many chars per number (for assignments with variable length) */ 604 605 reduction_set_on_equal = set_on_equal; 606 reduction_set_on_not_equal = 1 - set_on_equal; 607 608 reduction_boolean_both = boolean_both; 609 reduction_boolean_neither = 1 - boolean_both; 610 611 /* Perform the reduction */ 612 613 subscript = 0; /* initialize to first result element */ 614 do plane_base = 0 repeat (plane_base + column_skip_interval) while (plane_base < right_data_elements); 615 last_column_on_this_plane = plane_base + interval_between_elements; 616 do column_base = plane_base by 1 while (column_base < last_column_on_this_plane); 617 618 highest_column_element = column_base + column_skip_interval_minus_1; 619 addr (result_accumulator) -> char_string_overlay = 620 substr (right_array -> character_string_overlay, (highest_column_element + 621 interval_between_elements) * element_size + 1, element_size); 622 call reduction_operate (); /* reduce one column of this vector or array */ 623 624 result_array -> numeric_datum (subscript) = result_accumulator; 625 subscript = subscript + 1; 626 end; 627 end; 628 if copy_up_needed 629 then go to copy_up_stack; 630 631 return; 632 633 /* the following module implements the outer product construct in APL. This consists of applying the 634* basic operator (in op1) to each pair of elements in the left and right arguments. Thus the total number 635* of elements in the result equals the product of the numbers in the operands, the rho vector is the 636* concatenation of the operand rho vectors, and the dimensionality (rank) is the sum of the operand ranks. 637* The operation is performed by stepping thru each element of the left vector and storing it in the variable 638* single_element_fl_1. The dyadic scalar_vector routine is then called */ 639 640 apl_outer_product_: 641 entry (operators_argument); 642 643 call dyadic_extract (); /* copy info from operands */ 644 data_elements = right_data_elements * left_data_elements; /* result size = prod of operand sizes */ 645 rhorho = right_rhorho + left_rhorho; /* result rhorho is sum of operand rhorho's */ 646 /* cannot overlay result on operands */ 647 call stack_allocate_numeric (); /* get a result operand bead and value space */ 648 call fill_type (); /* fill in result type, set other goodies */ 649 dyadic_set_on_equal = set_on_equal; 650 dyadic_set_on_not_equal = 1 - set_on_equal; 651 652 dyadic_boolean_both = boolean_both; 653 dyadic_boolean_neither = 1 - boolean_both; 654 655 dyadic_action_place = 4 * op1 + scalar_vector; /* to which label to transfer in dyadic_operate */ 656 657 /* now fill the rho vector of result. this will be the left rho vector concatenated 658* with the right rho vector */ 659 660 number_to_copy = left_rhorho; /* copy left rhorho */ 661 if number_to_copy > 0 then /* avoid zero length array (illegal PL/I) */ 662 addr (result_vb -> value_bead.rho (1)) -> word_copy_overlay = 663 addr (left_vb -> value_bead.rho (1)) -> word_copy_overlay; 664 665 number_to_copy = right_rhorho; /* copy right rho after left rho */ 666 if number_to_copy > 0 then /* avoid zero length array (illegal PL/I) */ 667 addr (result_vb -> value_bead.rho (left_rhorho + 1)) -> word_copy_overlay = 668 addr (right_vb -> value_bead.rho (1)) -> word_copy_overlay; 669 670 if data_words_needed = 0 then /* null operands */ 671 goto copy_up_stack; /* copy up stack */ 672 673 if left_chars | right_chars 674 then do; 675 if ^ operator_info (op1).eq_or_not_eq then do; /* only = and /= can take chars */ 676 if left_chars then 677 goto domain_error_left; 678 goto domain_error_right; 679 end; 680 if left_chars ^= right_chars 681 then do; /* chars on one side, numbers on other */ 682 result_array -> numeric_datum = dyadic_set_on_not_equal; /* 1s if /=, 0s if = */ 683 goto copy_up_stack; /* copy result up stack */ 684 end; 685 dyadic_action_place = 686 scalar_vector + char_compare; /* subscript of char scalar-vector compare in dyadic_operate */ 687 element_size = 1; /* one char per element */ 688 end; 689 else do; /* not character, numeric */ 690 element_size = NumberSize; /* that many chars per number, for variable length assignments */ 691 left_data_elements = left_data_elements * NumberSize; 692 end; 693 694 data_elements = right_data_elements; /* use right for inner loop */ 695 do column_base = 0 repeat (column_base + element_size) 696 while (column_base < left_data_elements); /* step thru left array */ 697 addr (single_element_fl_1) -> char_string_overlay = /* extract a left element */ 698 substr (left_array -> character_string_overlay, column_base + 1, element_size); 699 call dyadic_operate (); /* perform a scalar/ vector operation */ 700 result_array = addr (result_array -> numeric_datum (data_elements)); /* move to next result vector */ 701 end; 702 goto copy_up_stack; /* copy words up stack into operands */ 703 /* This module implements the APL inner product construct. The general algorithm is to copy into a 704* temporary a row of the right array, then apply each row of the left array using a dyadic op1 operation. 705* The result vector of this is then reduced, using op2 */ 706 707 apl_inner_product_: 708 entry (operators_argument); 709 710 dcl (ip_subscript, /* just another subscript, for inner product's use */ 711 left_total_chars, /* total number of chars in left operand...for my kludgy overlays */ 712 right_move_count, /* number of elements in each row of right operand */ 713 right_count, /* number of rows on right */ 714 left_count, /* number of rows on left */ 715 op2) fixed bin (21); /* 2nd operator (user typed op2.op1) */ 716 717 dcl element_size fixed bin (4); /* used in char string overlay hack */ 718 719 dcl (actual_left_array, /* saves left array for recopying in loops */ 720 actual_right_array, /* same for right array */ 721 actual_result_array, /* same for result */ 722 temp_right_array, /* points to temp right array, used for dyadic routines */ 723 recover_right_array, /* this points at which pointer right_array should be loaded with */ 724 recover_single_element) ptr; /* this points at which pointer points at the element single_element_fl_1 gets */ 725 726 dcl based_pointer ptr based; /* used as dummy for recover_ pointers to point at */ 727 728 dcl char_string_overlay char (element_size) based unal; /* can process either double-words or chars */ 729 730 call dyadic_extract (); /* copy info from operands. */ 731 /* cannot overlay result on operands */ 732 column_base, /* lower subscript bound used by reduction */ 733 rhorho = 0; /* start off with 0 result rhorho */ 734 interval_between_elements, /* reduction will always get contiguous arrays */ 735 right_count = 1; 736 737 do rho_subscript = 2 by 1 while (rho_subscript <= right_rhorho); /* same for right but drop 1st dim */ 738 right_count = right_count * 739 right_vb -> value_bead.rho (rho_subscript); 740 rhorho = rhorho + 1; /* rhorho of result is sum of rhorho's of operands, minus dropped dimension */ 741 end; 742 743 data_elements = right_count; /* now multiply by same for left operand, giving result size */ 744 745 do rho_subscript = 1 by 1 while (rho_subscript < left_rhorho); 746 data_elements = data_elements * 747 left_vb -> value_bead.rho (rho_subscript); /* mpy all dimensions but last */ 748 rhorho = rhorho + 1; /* for each dim, add 1 to result dims */ 749 end; 750 data_words_needed = size (numeric_datum); /* words for stack_allocate_known and copy_up_stack */ 751 752 /* check conformity of operands. The conformity rules for inner product are as follows: A scalar 753* operand conforms to any other operand. A left operand with an inner (i.e., last) dimension of 1 conforms with 754* any right operand. A right operand with an inner (i.e., first) dimension of 1 conforms with any left operand. 755* Otherwise, the two inner dimensions must be the same. There is no constraint on the rank of the operans */ 756 757 if left_data_elements ^= 1 then /* not effective scalar */ 758 left_count = left_vb -> value_bead.rho (left_rhorho); /* number of elements in a left row */ 759 else 760 left_count = left_data_elements; /* set to 1 because it is a scalar */ 761 762 if right_data_elements = 1 then /* scalar */ 763 right_move_count = right_data_elements; /* set to 1, a scalar */ 764 else 765 right_move_count = right_vb -> value_bead.rho (1); /* inner dimension of right operand */ 766 767 /* now test conformity */ 768 769 if right_move_count ^= 1 then do; /* neither an effective scalar, nor is inner dim 1 */ 770 rho_sub_dimension = right_move_count; /* take number of elements dyadic will process from right */ 771 recover_right_array = addr (temp_right_array); /* we will want right array to point here */ 772 recover_single_element = addr (left_array); /* single element will come from left */ 773 774 if left_count ^= 1 then do; /* also not scalar nor inner dim 1 */ 775 776 if left_count ^= right_move_count then /* inner dims must agree if not 1 or scalar */ 777 goto length_error; 778 779 dyadic_action_place = vector; /* since both inner dims are not 1 */ 780 end; 781 else /* left inner = 1 (or is a scalar), right vector */ 782 dyadic_action_place = scalar_vector; /* left scalar, right vector */ 783 end; 784 785 else do; /* right is scalar or inner dim = 1 */ 786 rho_sub_dimension = left_count; /* left operand dominates, as right is scalar or inner dim 1 */ 787 dyadic_action_place = vector_scalar; 788 recover_right_array = addr (left_array); /* point right array at left in loop */ 789 recover_single_element = addr (temp_right_array); /* take scalar from right */ 790 swapped_flag = "1"b; 791 end; 792 793 if rho_sub_dimension = 0 then do; /* a null vector, return identities */ 794 op1 = op2; /* return identity of left operator */ 795 call dyadic_result_lowest (); /* put result_vb lowest on stack */ 796 end; 797 else do; /* test if a character operand */ 798 if left_chars | right_chars 799 then do; 800 if ^ operator_info (op1).eq_or_not_eq then do; /* only = and /= can take chars */ 801 if left_chars then 802 goto domain_error_left; 803 goto domain_error_right; 804 end; 805 if left_chars & right_chars 806 then do; 807 element_size = 1; /* for certain overlay hacks */ 808 dyadic_action_place = dyadic_action_place + char_compare; 809 if right_rhorho = 1 then /* right is also vector, result will be scalar */ 810 if op1 = equal_code then /* for special case op2 must be and */ 811 if op2 = and_code then goto inner_product_compare_strings; 812 else; 813 else /* is not_equal_code, op2 must be or */ 814 if op2 = or_code then do; /* is or.not_equals */ 815 816 inner_product_compare_strings: 817 call stack_allocate_numeric (); /* get storage */ 818 string (result_vb -> value_bead.header.type) = zero_or_one_value_type; 819 dyadic_set_on_equal = identity (op1); 820 821 dyadic_set_on_not_equal = 1 - dyadic_set_on_equal; 822 subscript = 0; 823 do ip_subscript = 0 repeat (ip_subscript + right_data_elements) 824 while (ip_subscript < left_data_elements); 825 826 if substr (left_array -> character_string_overlay, ip_subscript + 1, right_data_elements) = 827 substr (right_array -> character_string_overlay, 1, right_data_elements) then 828 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 829 else 830 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 831 832 subscript = subscript + 1; /* next result element */ 833 end; 834 /* now copy rho vector into result array value bead */ 835 836 subscript, 837 number_to_copy = max (left_rhorho - 1, 0); /* if negative or 0, no rho elements to copy */ 838 if number_to_copy > 0 then /* copy, > 0 */ 839 addr (result_vb -> value_bead.rho) -> word_copy_overlay = 840 addr (left_vb -> value_bead.rho) -> word_copy_overlay; 841 number_to_copy = right_rhorho - 1; /* if negative or 0, no rho elements to copy */ 842 if number_to_copy > 0 then /* copy, > 0 */ 843 addr (result_vb -> value_bead.rho (subscript + 1)) -> word_copy_overlay = 844 addr (right_vb -> value_bead.rho (2)) -> word_copy_overlay; 845 goto copy_up_stack; 846 847 848 end; 849 end; 850 851 data_words_needed = 852 data_words_needed + divide (right_move_count + 3, 4, 21, 0); 853 end; 854 else do; /* not chars, set counts and flags appropriately */ 855 data_words_needed = /* for temporary result array */ 856 (size (result_accumulator) * right_move_count) + data_words_needed; 857 dyadic_action_place = dyadic_action_place + (4 * op1); /* add in operator to label subscript */ 858 element_size = NumberSize; 859 end; 860 data_words_needed = data_words_needed + /* add more for temporaries needed */ 861 (size (result_accumulator) * rho_sub_dimension); /* temporary result array */ 862 end; 863 864 call stack_allocate_known (); /* get storage for result and temps */ 865 866 /* insert correct type into result */ 867 868 call fill_type (); /* insert type after dyadic operator */ 869 dyadic_set_on_equal = set_on_equal; 870 dyadic_set_on_not_equal = 1 - set_on_equal; 871 872 dyadic_boolean_both = boolean_both; 873 dyadic_boolean_neither = 1 - boolean_both; 874 875 string (save_free_type) = string (free_type); 876 string (reduction_type), /* set for reduction to be type going into reduction */ 877 string (free_type) = 878 string (result_vb -> value_bead.type); /* copy out for next operator */ 879 action_place = op2; 880 call fill_type (); 881 string (free_type) = string (save_free_type); 882 reduction_set_on_equal = set_on_equal; 883 reduction_set_on_not_equal = 1 - set_on_equal; 884 885 reduction_boolean_both = boolean_both; 886 reduction_boolean_neither = 1 - boolean_both; 887 888 /* now copy rho vector into result array value bead */ 889 890 subscript, 891 number_to_copy = max (left_rhorho - 1, 0); /* if negative or 0, no rho elements to copy */ 892 if number_to_copy > 0 then /* copy, > 0 */ 893 addr (result_vb -> value_bead.rho) -> word_copy_overlay = 894 addr (left_vb -> value_bead.rho) -> word_copy_overlay; 895 896 number_to_copy = right_rhorho - 1; /* if negative or 0, no rho elements to copy */ 897 if number_to_copy > 0 then /* copy, > 0 */ 898 addr (result_vb -> value_bead.rho (subscript + 1)) -> word_copy_overlay = 899 addr (right_vb -> value_bead.rho (2)) -> word_copy_overlay; 900 901 if rho_sub_dimension = 0 then /* null array, return identities */ 902 goto identity_fill; /* same place reduction returns identities */ 903 904 /* save ptrs to the operands and to the temporaries I have allocated on the stack because the dyadic and reduction 905* routines expect these ptrs to be loaded with various things that will force them to be smashed */ 906 907 actual_result_array = result_array; /* ptr to block allocated */ 908 result_array = addr (actual_result_array -> 909 numeric_datum (data_elements)); /* ptr to first temp block after; where dyadic will store result */ 910 911 data_elements = rho_sub_dimension; /* so dyadic knows how much to do */ 912 temp_right_array = addr (result_array -> numeric_datum (data_elements)); /* ptr to 2nd temp block; where right row is built */ 913 actual_left_array = left_array; 914 actual_right_array = right_array; 915 916 highest_column_element = rho_sub_dimension - 2; /* subtract 2 because reduction starts at next to last element */ 917 column_skip_interval = right_count * element_size; /* offsets between right rows in characters */ 918 left_count = left_count * element_size; /* length of a left row in characters */ 919 left_total_chars = left_data_elements * element_size; /* total size of left array in characters */ 920 right_move_count = right_move_count * element_size; 921 922 /* Now comes the main loop */ 923 924 do plane_base = 0 by 1 while (plane_base < right_count); 925 subscript = plane_base * element_size; /* copy an entire (not-contiguous, generally) right row */ 926 do ip_subscript = 0 repeat (ip_subscript + element_size) 927 while (ip_subscript < right_move_count); /* into temp right array */ 928 929 addr (temp_right_array -> character_data_structure.character_datum (ip_subscript)) 930 -> char_string_overlay = /* copy an element */ 931 addr (actual_right_array -> character_data_structure.character_datum (subscript)) 932 -> char_string_overlay; 933 934 subscript = subscript + column_skip_interval; /* offset to next element in right operand */ 935 end; 936 937 ip_subscript = plane_base; /* go thru each row of left, dyadicing it with temp right */ 938 939 do subscript = 0 repeat (subscript + left_count) while (subscript < left_total_chars); 940 941 left_array = 942 addr (actual_left_array -> character_data_structure.character_datum (subscript)); /* a left row */ 943 right_array = /* point right_array at vector argument (if both vector, right one) */ 944 recover_right_array -> based_pointer; 945 addr (single_element_fl_1) -> char_string_overlay = /* copy a scalar */ 946 recover_single_element -> based_pointer -> char_string_overlay; 947 948 call dyadic_operate (); /* do dyadic operator */ 949 950 right_array = result_array; /* now reduce result by op2 returned by dyadic */ 951 result_accumulator = result_array -> 952 numeric_datum (highest_column_element + 1); /* initialize first reduction result */ 953 954 call reduction_operate (); 955 956 actual_result_array -> numeric_datum (ip_subscript) = 957 result_accumulator; /* put away result */ 958 ip_subscript = ip_subscript + right_count; /* an element further on */ 959 end; 960 end; 961 962 963 data_words_needed = size (result_accumulator) * 964 result_vb -> value_bead.total_data_elements; 965 goto copy_up_stack; 966 967 /* The following module implements the scan construct in apl. This is 968* essentially a repeated application of reduction to its operand. Thus result (1) 969* = operand (1), result (2) = operand (1) operand (2), etc. Note that as 970* usual in this losing language the reductions are applied right to left and thus except 971* for commutative operators (such as plus, times, or, and, max, min) the result of scan 972* is not the intermediate results from a reduction. Scan returns a result conforming with 973* operand */ 974 975 apl_scan_operator_: 976 entry (operators_argument); 977 978 declare actual_highest_column_element fixed binary precision (21, 0); /* last element in column to reduce */ 979 declare flip_flag bit (1) aligned; /* indicates whether processing even or odd element */ 980 981 call monadic_extract (); /* pull information from right (and only) operand */ 982 983 if op1 <= min_code /* plus thru min are commutative, and so it is */ 984 then call monadic_result_lowest (); /* OK to overlay result completely on operand */ 985 else copy_up_needed = operators_argument.operands (2).on_stack; 986 987 string (reduction_type) = string (free_type); /* extract type to here for reduction_operate's sake */ 988 989 /* result will conform with operand -- make result that large and of those dimensions */ 990 991 rhorho = right_rhorho; /* result has same number of dimensions as operand */ 992 data_elements = right_data_elements; /* and same array elements */ 993 994 if data_elements = 0 then /* null operand, return it */ 995 goto return_right_scan; 996 997 if rhorho = 0 then /* scalar, return it */ 998 goto return_right_scan; 999 1000 rho_sub_dimension = right_vb -> value_bead.rho (dimension); 1001 if rho_sub_dimension = 1 then do; /* dimension to scan is 1, return operand */ 1002 return_right_scan: 1003 if right_chars 1004 then call stack_allocate_char (); 1005 else call stack_allocate_numeric (); 1006 1007 if right_vb -> value_bead.rhorho > 0 1008 then result_vb -> value_bead.rho (*) = right_vb -> value_bead.rho (*); 1009 1010 number_to_copy = data_words_needed; /* copy data */ 1011 if number_to_copy > 0 then 1012 result_array -> word_copy_overlay = 1013 right_array -> word_copy_overlay; 1014 1015 /* Recover proper data type...free_type is never character, but right operand might have been. */ 1016 1017 string (result_vb -> value_bead.type) = string (right_vb -> value_bead.type); 1018 return; /* have made copy of operand, return it */ 1019 end; 1020 1021 if right_chars 1022 then go to domain_error_right; /* can't scan character data */ 1023 1024 /* get an array and bead of numeric type but conforming with operand */ 1025 1026 call stack_allocate_numeric (); /* numeric type */ 1027 call fill_type (); 1028 1029 reduction_boolean_both = boolean_both; 1030 reduction_boolean_neither = 1 - boolean_both; 1031 1032 reduction_set_on_equal = set_on_equal; 1033 reduction_set_on_not_equal = 1 - set_on_equal; 1034 1035 if right_vb -> value_bead.rhorho > 0 1036 then result_vb -> value_bead.rho (*) = right_vb -> value_bead.rho (*); 1037 1038 /* calculate various intervals in operand array */ 1039 1040 interval_between_elements = 1; /* the interval between elements within a column 1041* being reduced is the product of all dimensions after the 1042* one being reduced */ 1043 do rho_subscript = dimension by 1 while (rho_subscript < right_rhorho); /* multiply them */ 1044 interval_between_elements = interval_between_elements * 1045 right_vb -> value_bead.rho (rho_subscript + 1); 1046 end; 1047 1048 column_skip_interval = interval_between_elements * rho_sub_dimension; 1049 column_skip_interval_minus_1 = column_skip_interval - interval_between_elements; 1050 1051 /* go thru actual scan loop now. note similarity to reduction */ 1052 1053 do plane_base = 0 repeat (plane_base + column_skip_interval) 1054 while (plane_base < right_data_elements); 1055 1056 last_column_on_this_plane = plane_base + interval_between_elements; 1057 1058 do column_base = plane_base by 1 while (column_base < last_column_on_this_plane); 1059 1060 actual_highest_column_element = column_base + column_skip_interval_minus_1; 1061 1062 result_accumulator, /* set this so can be referenced as previous element */ 1063 result_array -> numeric_datum (column_base) = /* set first element of result to be first of operand */ 1064 right_array -> numeric_datum (column_base); 1065 1066 goto scan_do (action_place); /* perform actual operation */ 1067 1068 scan_do (0): /* scan plus */ 1069 do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements) 1070 while (subscript <= actual_highest_column_element); 1071 1072 result_accumulator, 1073 result_array -> numeric_datum (subscript) = 1074 right_array -> numeric_datum (subscript) + /* add operand element */ 1075 result_accumulator; /* to previous result */ 1076 end; 1077 goto next_scan; 1078 1079 scan_do (1): /* scan minus */ 1080 flip_flag = "0"b; /* indicate on even one */ 1081 do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements) 1082 while (subscript <= actual_highest_column_element); 1083 1084 if flip_flag then 1085 result_accumulator, 1086 result_array -> numeric_datum (subscript) = 1087 right_array -> numeric_datum (subscript) + 1088 result_accumulator; 1089 1090 else /* even, subtract */ 1091 result_accumulator, 1092 result_array -> numeric_datum (subscript) = 1093 result_accumulator - 1094 right_array -> numeric_datum (subscript); 1095 flip_flag = ^ flip_flag; /* so reverse operation for next time */ 1096 end; 1097 goto next_scan; 1098 1099 scan_do (2): /* scan multiply */ 1100 do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements) 1101 while (subscript <= actual_highest_column_element); 1102 1103 result_accumulator, 1104 result_array -> numeric_datum (subscript) = 1105 right_array -> numeric_datum (subscript) * /* multiply operand element */ 1106 result_accumulator; /* to previous result */ 1107 end; 1108 goto next_scan; 1109 1110 scan_do (3): /* scan divide */ 1111 flip_flag = "0"b; /* indicate on even one */ 1112 do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements) 1113 while (subscript <= actual_highest_column_element); 1114 1115 if flip_flag 1116 then result_accumulator = right_array -> numeric_datum (subscript) * result_accumulator; 1117 else /* even, divide */ 1118 if right_array -> numeric_datum (subscript) = 0e0 /* divisor = 0? */ 1119 then if result_accumulator = 0e0 /* dividend = 0? */ 1120 then result_accumulator = 1e0; 1121 else go to zerodivide_error_right; 1122 else result_accumulator = result_accumulator / right_array -> numeric_datum (subscript); 1123 result_array -> numeric_datum (subscript) = result_accumulator; 1124 flip_flag = ^ flip_flag; /* so reverse operation for next time */ 1125 end; 1126 goto next_scan; 1127 1128 scan_do (4): /* scan max */ 1129 do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements) 1130 while (subscript <= actual_highest_column_element); 1131 1132 result_accumulator, 1133 result_array -> numeric_datum (subscript) = 1134 max (right_array -> numeric_datum (subscript), /* max operand element */ 1135 result_accumulator); /* to previous result */ 1136 end; 1137 goto next_scan; 1138 1139 scan_do (5): /* scan min */ 1140 do subscript = column_base + interval_between_elements repeat (subscript + interval_between_elements) 1141 while (subscript <= actual_highest_column_element); 1142 1143 result_accumulator, 1144 result_array -> numeric_datum (subscript) = 1145 min (right_array -> numeric_datum (subscript), /* min operand element */ 1146 result_accumulator); /* to previous result */ 1147 end; 1148 goto next_scan; 1149 1150 /* ones for all other operators follow. Will just call reduction repeatedly */ 1151 1152 scan_do (6): /* power */ 1153 scan_do (7): /* log */ 1154 scan_do (8): /* residue */ 1155 scan_do (9): /* factorial */ 1156 scan_do (10): /* circle */ 1157 scan_do (11): /* and */ 1158 scan_do (12): /* or */ 1159 scan_do (13): /* nand */ 1160 scan_do (14): /* nor */ 1161 scan_do (15): /* < */ 1162 scan_do (16): /* <_ */ 1163 scan_do (17): /* /= */ 1164 scan_do (18): /* >_ */ 1165 scan_do (19): /* > */ 1166 scan_do (20): /* = */ 1167 do highest_column_element = column_base repeat (highest_column_element + interval_between_elements) 1168 while (highest_column_element < actual_highest_column_element); 1169 1170 result_accumulator = right_array -> numeric_datum 1171 (highest_column_element + interval_between_elements); 1172 1173 call reduction_operate (); 1174 1175 result_array -> numeric_datum 1176 (highest_column_element + interval_between_elements) = 1177 result_accumulator; 1178 end; 1179 1180 next_scan: 1181 end; 1182 end; 1183 if copy_up_needed 1184 then go to copy_up_stack; 1185 1186 return; 1187 1188 /* procedure to copy garbage up stack. assumes variable words_needed_in_bead contains number of words 1189* in bead, data_words_needed contains words in data */ 1190 1191 copy_up_stack: /* not really a subroutine, just gone to */ 1192 if ^ operators_argument.operands (2).on_stack then do; /* right is not on stack */ 1193 if ^ operators_argument.operands (1).on_stack then do; /* left is not on stack */ 1194 operators_argument.result = result_vb; /* leave answer where it is */ 1195 return; 1196 end; 1197 right_vb = left_vb; /* left is on stack and right is not -- overlay on left operand */ 1198 end; 1199 if binary (rel (right_vb), 18, 0) + words_needed > ws_info.maximum_value_stack_size then do; 1200 operators_argument.result = result_vb; /* result will be where it is */ 1201 return; 1202 end; 1203 1204 /* the following kludges are used to copy the result operand lowest in the stack. Kludgy code using overlays 1205* and unspecs will be used until such time as the PL/I compiler can generate structure assignments 1206* without moving one bit at a time. Note that previous code has set the right_vb ptr to point to the operand 1207* lowest in the stack; thus it may not still be pointing at the right value bead. */ 1208 1209 /* now find the next doubleword boundary on which to put the result data. Note that if decimal data is 1210* someday used, alignment will not be necessary; in that case both the bead and data can be copied in one move */ 1211 1212 number_to_copy = words_needed_in_bead; /* the words in the bead for the result, from stack_allocate */ 1213 right_vb -> word_copy_overlay = /* copy words from bead to end bead */ 1214 result_vb -> word_copy_overlay; 1215 right_array = addrel (right_vb, words_needed_in_bead); /* try next word after bead */ 1216 if substr (rel (right_array), 18, 1) then /* if a 1 in low order bit, odd aligned */ 1217 right_array = addrel (right_array, 1); 1218 right_vb -> value_bead.data_pointer = right_array; /* pointer to data */ 1219 number_to_copy = data_words_needed; /* number of data words to move */ 1220 if number_to_copy > 0 then /* zero length arrays are illegal PL/I */ 1221 right_array -> word_copy_overlay = /* move in data */ 1222 result_vb -> value_bead.data_pointer -> word_copy_overlay; 1223 result_array = addr (result_vb -> value_bead.rho (rhorho + 1)); /* word after value bead */ 1224 ws_info.value_stack_ptr = addrel (right_array, data_words_needed); 1225 operators_argument.result = right_vb; 1226 return; 1227 1228 /* places to go to when an error is found */ 1229 1230 compatibility_error_left: 1231 operators_argument.error_code = apl_error_table_$compatibility_error; 1232 operators_argument.where_error = operators_argument.where_error + 1; 1233 return; 1234 1235 display_disabled: /* CONTEXT ERROR in brief mode */ 1236 operators_argument.error_code = apl_error_table_$display_disabled; 1237 return; 1238 1239 domain_error_left_maybe: 1240 if swapped_flag then 1241 goto domain_error_right; 1242 goto domain_error_left; 1243 1244 domain_error_right_maybe: 1245 if swapped_flag then 1246 goto domain_error_left; 1247 1248 domain_error_right: 1249 operators_argument.where_error = operators_argument.where_error - 2; 1250 1251 domain_error_left: 1252 operators_argument.where_error = operators_argument.where_error + 1; 1253 1254 domain_error: 1255 operators_argument.error_code = apl_error_table_$domain; 1256 return; 1257 1258 invalid_circular_fcn_left: /* DOMAIN ERROR in brief mode */ 1259 operators_argument.where_error = operators_argument.where_error + 1; 1260 operators_argument.error_code = apl_error_table_$invalid_circular_fcn; 1261 return; 1262 1263 length_error: 1264 operators_argument.error_code = apl_error_table_$length; 1265 return; 1266 1267 no_identity_error: /* DOMAIN ERROR in brief mode */ 1268 operators_argument.error_code = apl_error_table_$no_identity; 1269 return; 1270 1271 rank_error: 1272 operators_argument.error_code = apl_error_table_$rank; 1273 return; 1274 1275 zerodivide_error_right: /* DOMAIN ERROR in brief mode */ 1276 operators_argument.where_error = operators_argument.where_error - 1; 1277 operators_argument.error_code = apl_error_table_$zerodivide; 1278 return; 1279 1280 /* The following subroutine is used to allocate a result value bead and a result array on the value stack. 1281* The rhorho of the result v.b. is given in variable rhorho, and the number of data elements in the result array 1282* is given in data_elements. It sets result_vb to point to allocated value_bead and result_array to point to the 1283* array. All fields in the value bead are filled in except value_bead.header.type and value_bead.rho. 1284* The bead is allocated on such a boundary that the next word after it (the first word of the result array) is 1285* doubleword aligned. */ 1286 1287 stack_allocate_numeric: 1288 procedure (); 1289 1290 /* automatic */ 1291 1292 declare numeric bit (1) aligned; 1293 1294 /* program */ 1295 1296 data_words_needed = size (numeric_datum); /* get result length from data_elements */ 1297 numeric = "1"b; 1298 goto stack_allocate_known_common; /* common code */ 1299 1300 stack_allocate_char: /* entry to assume thing to alloc is char */ 1301 entry (); 1302 1303 data_words_needed = size (character_string_overlay); /* no. of chars */ 1304 numeric = "0"b; 1305 go to stack_allocate_known_common; 1306 1307 stack_allocate_known: 1308 entry (); /* caller has set data_words_needed */ 1309 1310 numeric = "1"b; 1311 1312 stack_allocate_known_common: /* to transfer from above */ 1313 number_of_dimensions = rhorho; 1314 words_needed_in_bead = size (value_bead); 1315 words_needed = words_needed_in_bead + data_words_needed + 1; /* addition of 1 to doubleword align */ 1316 result_vb = apl_push_stack_ (words_needed); 1317 result_array = addr (result_vb -> value_bead.rho (rhorho + 1)); /* word after value bead */ 1318 if numeric 1319 then if substr (rel (result_array), 18, 1) 1320 then result_array = addrel (result_array, 1); /* if next word is odd-aligned, bump by 1 word */ 1321 1322 result_vb -> value_bead.total_data_elements = data_elements; 1323 result_vb -> value_bead.rhorho = rhorho; /* make result conform with original operand */ 1324 result_vb -> value_bead.data_pointer = result_array; /* pointer to actual array */ 1325 operators_argument.result = result_vb; /* let parse know where I put result when I return */ 1326 1327 end stack_allocate_numeric; 1328 7 1 /* ====== BEGIN INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 =============================== */ 7 2 7 3 /* format: style3 */ 7 4 apl_push_stack_: 7 5 procedure (P_n_words) returns (ptr); 7 6 7 7 /* Function to (1) double-word align ws_info.value_stack_ptr, and 7 8* (2) make sure allocation request will fit on current value stack. 7 9* 7 10* Written 770413 by PG 7 11* Modified 780210 by PG to round allocations up to an even number of words. 7 12**/ 7 13 7 14 /* parameters */ 7 15 7 16 declare P_n_words fixed bin (19) parameter; 7 17 7 18 /* automatic */ 7 19 7 20 declare block_ptr ptr, 7 21 num_words fixed bin (19); 7 22 7 23 /* builtins */ 7 24 7 25 declare (addrel, binary, rel, substr, unspec) 7 26 builtin; 7 27 7 28 /* entries */ 7 29 7 30 declare apl_get_value_stack_ 7 31 entry (fixed bin (19)); 7 32 7 33 /* program */ 7 34 7 35 num_words = P_n_words; 7 36 7 37 if substr (unspec (num_words), 36, 1) = "1"b /* num_words odd */ 7 38 then num_words = num_words + 1; 7 39 7 40 if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size 7 41 then call apl_get_value_stack_ (num_words); 7 42 7 43 block_ptr = ws_info.value_stack_ptr; 7 44 ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words); 7 45 return (block_ptr); 7 46 7 47 end apl_push_stack_; 7 48 7 49 /* ------ END INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 ------------------------------- */ 1329 1330 1331 /* The folowing subroutine is used to return a type field for a given scalar dyadic function. The variable op1 1332* must contain the operator code. The variable free_type must contain the AND of the types the operands */ 1333 1334 fill_type: 1335 procedure (); 1336 1337 goto get_type (action_place); /* goto label array */ 1338 1339 /* the following ones return the same type as the AND of the operands */ 1340 1341 get_type (8): /* residue */ 1342 if ws_info.compatibility_check_mode then /* check for negative left arg */ 1343 special_case = 1; /* will cause do_many subroutine to check */ 1344 1345 get_type (2): /* multiply */ 1346 get_type (4): /* max */ 1347 get_type (5): /* min */ 1348 get_type (9): /* binomial coefficients */ 1349 string (result_vb -> value_bead.header.type) = string (free_type); /* fill in result type */ 1350 return; 1351 1352 /* the following ones can return non-Booleans and non-integers, no matter what the input type is. */ 1353 1354 get_type (7): /* log */ 1355 get_type (10): /* trig functions */ 1356 string (result_vb -> value_bead.header.type) = numeric_value_type; 1357 return; 1358 1359 /* the following one preserves integralness but not zero-or-one-ness */ 1360 1361 get_type (0): /* plus */ 1362 get_type (1): /* subtract */ 1363 string (result_vb -> value_bead.header.type) 1364 = string (free_type) & not_zero_or_one_mask; /* fill in result type */ 1365 return; 1366 1367 /* the following one preserves booleanness but not integrallness (that is, result is guaranteed to be an 1368* integer and boolean only if operand(s) is (are), but not guaranteed to produce even an integer is 1369* the operand is integral but not boolean */ 1370 1371 get_type (3): /* divide */ 1372 get_type (6): /* power */ 1373 if free_type.data_type.zero_or_one_value then /* preserves booleanness */ 1374 string (result_vb -> value_bead.header.type) = string (free_type); /* fill in result type */ 1375 else 1376 string (result_vb -> value_bead.header.type) = numeric_value_type; /* otherwise preserves nothing */ 1377 return; 1378 1379 /* boolean operations. set boolean_both to be the value (either 0 or 1) to which the operands will be compared. 1380* If both operands are equal to this value, answer will be set to set_on_equal, otherwise set to set_on_not_equal. 1381* set_on_equal will have the identity of operator (if and or or) or 1 - identity (for nand, inverse of and; for 1382* nor, inverse of or). */ 1383 1384 get_type (11): /* and */ 1385 get_type (12): /* or */ 1386 get_type (13): /* nand */ 1387 get_type (14): /* nor */ 1388 boolean_both = booleans (action_place); 1389 1390 /* the following comparisons can only return boolean values */ 1391 1392 get_type (15): /* < */ 1393 get_type (16): /* <_ */ 1394 get_type (17): /* = */ 1395 get_type (18): /* >_ */ 1396 get_type (19): /* > */ 1397 get_type (20): /*  /= */ 1398 set_on_equal = identity (action_place); /* identity for this operator */ 1399 string (result_vb -> value_bead.header.type) = zero_or_one_value_type; 1400 return; 1401 1402 end fill_type; 1403 1404 /* subroutine to fill rho vector of newly created value bead from reduction. The rho vector is merely copied from 1405* the right operand except that the dimension indicated by the variable dimension is not copied. Note that if 1406* 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. 1407* Therefore if dimension = 1 then rho (2) is to copied, if dimension = 2 then rho (1) is to be copied */ 1408 1409 fill_rho: 1410 procedure (); 1411 1412 if rhorho = 0 then return; /* result is scalar, no rho anyway */ 1413 if rhorho = 1 then do; 1414 result_vb -> value_bead.rho (1) = /* copy 1 if dimension = 2, 2 if dimension = 1 */ 1415 right_vb -> value_bead.rho (3 - dimension); 1416 return; 1417 end; 1418 1419 number_to_copy = dimension - 1; /* copy all dimensions before one to reduce */ 1420 if number_to_copy > 0 then /* check if zero length array (illegal PL/I) */ 1421 addr (result_vb -> value_bead.rho) -> word_copy_overlay = 1422 addr (right_vb -> value_bead.rho) -> word_copy_overlay; 1423 1424 number_to_copy = rhorho - number_to_copy; /* copy all after dimension to reduce */ 1425 if number_to_copy > 0 then 1426 addr (result_vb -> value_bead.rho (dimension)) -> word_copy_overlay = 1427 addr (right_vb -> value_bead.rho (dimension + 1)) -> word_copy_overlay; 1428 return; 1429 1430 end fill_rho; 1431 1432 /* procedure to extract information from operators_argument */ 1433 1434 dyadic_extract: 1435 procedure (); 1436 1437 declare dyadic bit (1) aligned init ("0"b); 1438 1439 /* copy information from argument structure */ 1440 1441 dyadic = "1"b; 1442 left_vb = operators_argument.operands (1).value; 1443 left_array = left_vb -> value_bead.data_pointer; 1444 left_data_elements = left_vb -> value_bead.total_data_elements; 1445 left_rhorho = left_vb -> value_bead.rhorho; 1446 left_chars = left_vb -> value_bead.character_value; 1447 1448 monadic_extract: /* repeat for right operand */ 1449 entry (); 1450 1451 right_vb = operators_argument.operands (2).value; 1452 right_array = right_vb -> value_bead.data_pointer; 1453 right_data_elements = right_vb -> value_bead.total_data_elements; 1454 right_rhorho = right_vb -> value_bead.rhorho; 1455 right_chars = right_vb -> value_bead.character_value; 1456 1457 if dyadic 1458 then do; 1459 string (free_type) = string (left_vb -> value_bead.type) & string (right_vb -> value_bead.type); 1460 if string (free_type.data_type) = ""b /* aarghh! mixed char and numeric operands */ 1461 | string (free_type) = character_value_type /* both args are character */ 1462 then string (free_type) = numeric_value_type; /* just happens that all scalar ops return numbers */ 1463 end; 1464 else string (free_type) = string (right_vb -> value_bead.type); 1465 1466 action_place, 1467 op1 = operators_argument.operator.op1; /* copy out primary operator code */ 1468 many_action_place = 2 * action_place; /* for do_many subroutine */ 1469 op2 = operators_argument.operator.op2; /* 2nd operator for inner product (user typed op2.op1) */ 1470 dimension = operators_argument.operator.dimension; /* dimension over which to apply reduction */ 1471 1472 fuzz = ws_info.fuzz; /* extract for efficiency */ 1473 integer_fuzz = ws_info.integer_fuzz; 1474 special_case = 0; /* not known to be a special case for do_many yet */ 1475 swapped_flag = "0"b; 1476 1477 end dyadic_extract; 1478 1479 /* Subroutine to compute whether result can overlay one or more of the operands */ 1480 1481 dyadic_result_lowest: 1482 procedure (); 1483 1484 if left_chars & right_chars 1485 then copy_up_needed = "1"b; /* can't overlay because result is numeric */ 1486 else do; 1487 copy_up_needed = "0"b; 1488 if operators_argument.operands (2).on_stack /* can overlay totally */ 1489 then ws_info.value_stack_ptr = right_vb; /* overlay on right value bead */ 1490 else if operators_argument.operands (1).on_stack 1491 then ws_info.value_stack_ptr = left_vb; /* overlay on left value bead */ 1492 end; 1493 1494 end dyadic_result_lowest; 1495 1496 /* the same, for monadic routines */ 1497 1498 monadic_result_lowest: 1499 procedure (); 1500 1501 if ^right_chars & operators_argument.operands (2).on_stack 1502 then do; 1503 ws_info.value_stack_ptr = right_vb; /* Overlay numeric right operand if it is on stack */ 1504 copy_up_needed = "0"b; 1505 end; 1506 else copy_up_needed = operators_argument.operands (2).on_stack; /* copy if arg is on stack */ 1507 1508 end monadic_result_lowest; 1509 1510 /* the following subroutine does dyadic operations. it expects result_array to point to 1511* the result array, action_place to contain the appropriate label for which operation to do, and data_elements 1512* to contain the number of result elements. if scalars are involved they must be in single_element_fl_1 and 1513* single_element_fl_2 */ 1514 1515 /* The following is a short lecture on relative and integer fuzz. Despite what you might think, a fair amount 1516* of time and effort has gone into making sure that this program correctly handles the two types of fuzz. 1517* Relative fuzz is "how close" two numbers must be before they can be considered equal. If we were 1518* in assembly language, we might do this test with a "test under mask" instruction. But we aren't, 1519* and so we've devised a simple arithmetic scheme which works despite the magnitude of the numbers. 1520* When you look at the code, you may wonder why we actually test to see that two numbers are really equal before 1521* we actually test to see if they are "fuzz equal." Well, besides perhaps being faster, 1522* it seems that zero does not compare fuzz equal to itself! So, assuming A and B are both not zero, 1523* they are equal within relative fuzz iff: 1524* |A-B| 1525* ----- < fuzz 1526* |A+B| 1527* As for integer fuzz (which is how close a floating-point number must be to an integer before it can be 1528* considered an integer; and note that there is no requirement that integer fuzz = relative fuzz), 1529* a number F is considered to be the integer floor(F+0.5) iff: 1530* abs(floor(F+0.5) - F) < integer_fuzz 1531* For testing F to be within integer fuzz of zero, this simplifies to: 1532* abs(F) < integer_fuzz 1533* 1534* For testing F to be equal to a specific integer I, 1535* abs (F - I) < integer_fuzz 1536* 1537* Class dismissed. */ 1538 1539 dyadic_operate: 1540 procedure (); 1541 1542 dcl subscript fixed bin (21); /* provides a random subscript... don't use one in outer block, 1543* in order to avoid naming conflicts */ 1544 1545 goto dyadic_do (dyadic_action_place); /* select correct action routine depending upon variable action_place */ 1546 1547 1548 /* actual action routines for various operators. note that those that are commutative have the same routine for 1549* and . Note that this includes the comparison operators 1550* which are not commutative (< <_ > >_); merely the results have been changed.(ie., set_on_equal is opposite, etc.). */ 1551 1552 dyadic_do (0): /* both scalar, + */ 1553 result_array -> numeric_datum (0) = 1554 single_element_fl_1 + 1555 single_element_fl_2; 1556 return; 1557 1558 dyadic_do (1): /* vector handler for PLUS */ 1559 do subscript = 0 by 1 while (subscript < data_elements); 1560 result_array -> numeric_datum (subscript) = 1561 left_array -> numeric_datum (subscript) + 1562 right_array -> numeric_datum (subscript); 1563 end; 1564 return; 1565 1566 dyadic_do (2): /* left sc, right vc */ 1567 dyadic_do (3): /* left vc, right sc */ 1568 do subscript = 0 by 1 while (subscript < data_elements); 1569 result_array -> numeric_datum (subscript) = 1570 single_element_fl_1 /* the scalar */ + 1571 right_array -> numeric_datum (subscript); /* the vector */ 1572 end; 1573 return; 1574 1575 dyadic_do (4): /* both scalar, - */ 1576 result_array -> numeric_datum (0) = 1577 single_element_fl_1 - 1578 single_element_fl_2; 1579 return; 1580 1581 dyadic_do (5): /* vector handler for MINUS */ 1582 do subscript = 0 by 1 while (subscript < data_elements); 1583 result_array -> numeric_datum (subscript) = 1584 left_array -> numeric_datum (subscript) - 1585 right_array -> numeric_datum (subscript); 1586 end; 1587 return; 1588 1589 dyadic_do (6): /* left sc, right vc */ 1590 do subscript = 0 by 1 while (subscript < data_elements); 1591 result_array -> numeric_datum (subscript) = 1592 single_element_fl_1 /* the scalar */ - 1593 right_array -> numeric_datum (subscript); /* the vector */ 1594 end; 1595 return; 1596 1597 dyadic_do (7): /* left vc, right sc */ 1598 do subscript = 0 by 1 while (subscript < data_elements); 1599 result_array -> numeric_datum (subscript) = 1600 right_array -> numeric_datum (subscript) - 1601 single_element_fl_1; 1602 end; 1603 return; 1604 1605 dyadic_do (8): /* both scalar, * */ 1606 result_array -> numeric_datum (0) = 1607 single_element_fl_1 * 1608 single_element_fl_2; 1609 return; 1610 1611 dyadic_do (9): /* both vector, times */ 1612 do subscript = 0 by 1 while (subscript < data_elements); 1613 result_array -> numeric_datum (subscript) = 1614 left_array -> numeric_datum (subscript) * 1615 right_array -> numeric_datum (subscript); 1616 end; 1617 return; 1618 1619 dyadic_do (10): /* left sc, right vc */ 1620 dyadic_do (11): /* but multiplication is commutative */ 1621 do subscript = 0 by 1 while (subscript < data_elements); 1622 result_array -> numeric_datum (subscript) = 1623 single_element_fl_1 /* the scalar */ * 1624 right_array -> numeric_datum (subscript); /* the vector */ 1625 end; 1626 return; 1627 1628 dyadic_do (12): /* both scalar, divide */ 1629 if single_element_fl_2 = 0e0 1630 then if single_element_fl_1 = 0e0 /* dividend =0? */ 1631 then result_array -> numeric_datum (0) = 1e0; 1632 else go to zerodivide_error_right; 1633 else result_array -> numeric_datum (0) = single_element_fl_1 / single_element_fl_2; 1634 return; 1635 1636 dyadic_do (13): /* both vectors, divide */ 1637 do subscript = 0 by 1 while (subscript < data_elements); 1638 if right_array -> numeric_datum (subscript) = 0e0 /* divisor =0? */ 1639 then if left_array -> numeric_datum (subscript) = 0e0 /* dividend =0? */ 1640 then result_array -> numeric_datum (subscript) = 1e0; 1641 else go to zerodivide_error_right; 1642 else result_array -> numeric_datum (subscript) = 1643 left_array -> numeric_datum (subscript) / 1644 right_array -> numeric_datum (subscript); 1645 end; 1646 return; 1647 1648 dyadic_do (14): /* left sc, right vc, divide */ 1649 do subscript = 0 by 1 while (subscript < data_elements); 1650 if right_array -> numeric_datum (subscript) = 0e0 /* divisor =0? */ 1651 then if single_element_fl_1 = 0e0 /* dividend =0? */ 1652 then result_array -> numeric_datum (subscript) = 1e0; 1653 else go to zerodivide_error_right; 1654 else result_array -> numeric_datum (subscript) = 1655 single_element_fl_1 / right_array -> numeric_datum (subscript); 1656 end; 1657 return; 1658 1659 dyadic_do (15): /* left vector, right scalar, divide */ 1660 do subscript = 0 by 1 while (subscript < data_elements); 1661 if single_element_fl_1 = 0e0 /* divisor 0? */ 1662 then if right_array -> numeric_datum (subscript) = 0e0 /* dividend =0? */ 1663 then result_array -> numeric_datum (subscript) = 1e0; 1664 else go to zerodivide_error_right; 1665 else result_array -> numeric_datum (subscript) = 1666 right_array -> numeric_datum (subscript) / single_element_fl_1; 1667 end; 1668 return; 1669 1670 dyadic_do (16): /* both scalar, max */ 1671 result_array -> numeric_datum (0) = max (single_element_fl_1, single_element_fl_2); 1672 return; 1673 1674 dyadic_do (17): /* both vector, max */ 1675 do subscript = 0 by 1 while (subscript < data_elements); 1676 result_array -> numeric_datum (subscript) = 1677 max (left_array -> numeric_datum (subscript), right_array -> numeric_datum (subscript)); 1678 end; 1679 return; 1680 1681 dyadic_do (18): /* left sc, right vc, max */ 1682 dyadic_do (19): /* right sc, left vc, max */ 1683 do subscript = 0 by 1 while (subscript < data_elements); 1684 result_array -> numeric_datum (subscript) = 1685 max (single_element_fl_1, right_array -> numeric_datum (subscript)); 1686 end; 1687 return; 1688 1689 dyadic_do (20): /* both scalar, min */ 1690 result_array -> numeric_datum (0) = min (single_element_fl_1, single_element_fl_2); 1691 return; 1692 1693 dyadic_do (21): /* both vector, min */ 1694 do subscript = 0 by 1 while (subscript < data_elements); 1695 result_array -> numeric_datum (subscript) = 1696 min (left_array -> numeric_datum (subscript), right_array -> numeric_datum (subscript)); 1697 end; 1698 return; 1699 1700 dyadic_do (22): /* left sc, right vc, min */ 1701 dyadic_do (23): /* right sc, left vc, min */ 1702 do subscript = 0 by 1 while (subscript < data_elements); 1703 result_array -> numeric_datum (subscript) = 1704 min (single_element_fl_1, right_array -> numeric_datum (subscript)); 1705 end; 1706 return; 1707 1708 dyadic_do (24): /* both scalar, exponentiate */ 1709 dyadic_do (28): /* both scalar, log */ 1710 dyadic_do (32): /* both scalar, residue */ 1711 dyadic_do (36): /* both scalar, binomial coefficients */ 1712 dyadic_do (40): /* both scalar, trig */ 1713 call do_many (); /* perform operation depending on many_action_place */ 1714 result_array -> numeric_datum (0) = result_accumulator; 1715 return; 1716 1717 dyadic_do (25): /* both vector, exp */ 1718 dyadic_do (29): /* both vectors, log */ 1719 dyadic_do (33): /* both vectors, residue */ 1720 dyadic_do (37): /* both vectors, binomial coefficients */ 1721 dyadic_do (41): /* both vector, trig */ 1722 do subscript = 0 by 1 while (subscript < data_elements); 1723 single_element_fl_1 = left_array -> numeric_datum (subscript); 1724 single_element_fl_2 = right_array -> numeric_datum (subscript); 1725 call do_many (); 1726 result_array -> numeric_datum (subscript) = 1727 result_accumulator; 1728 end; 1729 return; 1730 1731 dyadic_do (42): /* left scalar, right vector, trig */ 1732 float_temp = floor(single_element_fl_1 + 0.5); /* convert arg to fixed */ 1733 if abs(float_temp - single_element_fl_1) > integer_fuzz then goto domain_error_left; 1734 if abs(float_temp) > 7 then goto domain_error_left; 1735 trig_integer = fixed(float_temp, 3); /* convert to integer between -7 and +7 */ 1736 special_case = 1; /* is special case because we know left is integral */ 1737 1738 dyadic_do (26): /* left scalar, right vector, exp */ 1739 dyadic_do (30): /* left scalar, right vector, log */ 1740 dyadic_do (34): /* left scalar, right vector, residue */ 1741 dyadic_do (38): /* left scalar, right vector, binomial coefficients */ 1742 do subscript = 0 by 1 while (subscript < data_elements); 1743 single_element_fl_2 = right_array -> numeric_datum (subscript); 1744 call do_many (); 1745 result_array -> numeric_datum (subscript) = 1746 result_accumulator; 1747 end; 1748 return; 1749 1750 dyadic_do (27): /* left vector, right scalar, exp */ 1751 float_temp = floor(single_element_fl_1 + 0.5); 1752 if abs(float_temp - single_element_fl_1) <= integer_fuzz then 1753 if abs(float_temp) < 1e17b then do; /* integer */ 1754 trig_integer = fixed(float_temp, 17); /* yes, it is integer exponent */ 1755 special_case = 1; 1756 end; 1757 1758 dyadic_do (31): /* right scalar, left vector, log */ 1759 dyadic_do (35): /* right scalar, left vector, residue */ 1760 dyadic_do (39): /* right scalar, left vector, binomial coefficients */ 1761 dyadic_do (43): /* left vector, right scalar, trig */ 1762 single_element_fl_2 = single_element_fl_1; 1763 do subscript = 0 by 1 while (subscript < data_elements); 1764 single_element_fl_1 = right_array -> numeric_datum (subscript); 1765 call do_many (); 1766 result_array -> numeric_datum (subscript) = 1767 result_accumulator; 1768 end; 1769 return; 1770 1771 dyadic_do (44): /* both scalar, and */ 1772 dyadic_do (48): /* both scalar, or */ 1773 dyadic_do (52): /* both scalar, nand */ 1774 dyadic_do (56): /* both scalar, nor */ 1775 if abs (single_element_fl_1 - dyadic_boolean_both) < integer_fuzz then do; 1776 if abs (single_element_fl_2 - dyadic_boolean_both) < integer_fuzz then do; 1777 result_array -> numeric_datum (0) = dyadic_set_on_equal; 1778 return; 1779 end; 1780 if abs (single_element_fl_2 - dyadic_boolean_neither) >= integer_fuzz then goto domain_error_right; 1781 end; 1782 else 1783 if abs (single_element_fl_1 - dyadic_boolean_neither) >= integer_fuzz then goto domain_error_left; 1784 1785 if abs (single_element_fl_2 - dyadic_boolean_both) >= integer_fuzz then /* check 2nd operand */ 1786 if abs (single_element_fl_2 - dyadic_boolean_neither) >= integer_fuzz then /* doom */ 1787 goto domain_error_right; /* neither 0 nor 1 */ 1788 1789 result_array -> numeric_datum (0) = dyadic_set_on_not_equal; 1790 return; 1791 1792 dyadic_do (45): /* both vector, and */ 1793 if free_type.zero_or_one_value then do; 1794 call apl_dyadic_bool_appendage_$and (left_array, right_array, result_array, data_elements); 1795 return; 1796 end; 1797 else goto dyadic_do_bool_vector; 1798 1799 dyadic_do (49): /* both vector, or */ 1800 if free_type.zero_or_one_value then do; 1801 call apl_dyadic_bool_appendage_$or (left_array, right_array, result_array, data_elements); 1802 return; 1803 end; 1804 else goto dyadic_do_bool_vector; 1805 1806 dyadic_do (53): /* both vector, nand */ 1807 if free_type.zero_or_one_value then do; 1808 call apl_dyadic_bool_appendage_$nand (left_array, right_array, result_array, data_elements); 1809 return; 1810 end; 1811 else goto dyadic_do_bool_vector; 1812 1813 dyadic_do (57): /* both vector, nor */ 1814 if free_type.zero_or_one_value then do; 1815 call apl_dyadic_bool_appendage_$nor (left_array, right_array, result_array, data_elements); 1816 return; 1817 end; 1818 1819 /* The following block of code has now been replaced by apl_dyadic_bool_appendage_. 1820* It is retained here to make it easy to revert the ALM procedure. 1821* 1822*dyadic_do (45): !* both vector, and *! 1823*dyadic_do (49): !* both vector, or *! 1824*dyadic_do (53): !* both vector, nand *! 1825*dyadic_do (57): !* both vector, nor *! 1826* if free_type.zero_or_one_value then do; 1827* do subscript = 0 by 1 while (subscript < data_elements); 1828* if left_array -> numeric_datum (subscript) = dyadic_boolean_both then 1829* if right_array -> numeric_datum (subscript) = dyadic_boolean_both then 1830* result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 1831* else 1832* result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 1833* else 1834* result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 1835* end; 1836* return; 1837* end; 1838**/ 1839 1840 dyadic_do_bool_vector: 1841 do subscript = 0 by 1 while (subscript < data_elements); 1842 if abs (left_array -> numeric_datum (subscript) - dyadic_boolean_both) < integer_fuzz then do; 1843 if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_both) < integer_fuzz then do; 1844 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 1845 goto get_next_element_45; 1846 end; 1847 if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_neither) >= integer_fuzz then 1848 goto domain_error_right; 1849 end; 1850 else 1851 if abs (left_array -> numeric_datum (subscript) - dyadic_boolean_neither) >= integer_fuzz then 1852 goto domain_error_left; 1853 1854 if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_both) >= integer_fuzz 1855 then if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_neither) >= integer_fuzz 1856 then go to domain_error_right; /* opnd 2 is neither 0 nor 1 */ 1857 1858 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 1859 get_next_element_45: 1860 end; 1861 return; 1862 1863 dyadic_do (54): /* left sc, right vc, nand */ 1864 dyadic_do (58): /* left sc, right vc, nor */ 1865 dyadic_do (55): /* left vc, right sc, nand */ 1866 dyadic_do (59): /* left vc, right sc, nor */ 1867 if free_type.zero_or_one_value then do; /* known that both are zero or one */ 1868 if single_element_fl_1 = dyadic_boolean_both then do; 1869 result_array -> numeric_datum = 1870 1 - right_array -> numeric_datum; /* invert each one */ 1871 return; 1872 end; 1873 1874 result_array -> numeric_datum = dyadic_set_on_not_equal; 1875 return; 1876 end; 1877 1878 single_element_fl_1 = 1 - single_element_fl_1; /* invert for not types */ 1879 dyadic_do (46): /* left sc, right vc, and */ 1880 dyadic_do (50): /* left sc, right vc, or */ 1881 dyadic_do (47): /* left vc, right sc, and */ 1882 dyadic_do (51): /* left vc, right sc, or */ 1883 if free_type.zero_or_one_value then do; /* must be and | or, because of test above */ 1884 if single_element_fl_1 = dyadic_boolean_neither then do; /* 0 clears and, 1 sets or */ 1885 result_array -> numeric_datum = dyadic_set_on_not_equal; /* set whole array */ 1886 return; 1887 end; 1888 1889 if result_array ^= right_array then /* 1 and X is X; 0 or X is X */ 1890 result_array -> numeric_datum = 1891 right_array -> numeric_datum; /* move whole array, pointers not same */ 1892 return; 1893 end; 1894 1895 if abs (single_element_fl_1 - dyadic_boolean_both) > integer_fuzz then 1896 if abs (single_element_fl_1 - dyadic_boolean_neither) > integer_fuzz 1897 then goto domain_error_left_maybe; /* neither 0 nor 1 */ 1898 do subscript = 0 by 1 while (subscript < data_elements); 1899 if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_both) < integer_fuzz then 1900 result_array -> numeric_datum (subscript) = single_element_fl_1; 1901 else if abs (right_array -> numeric_datum (subscript) - dyadic_boolean_neither) < integer_fuzz then 1902 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 1903 else goto domain_error_right_maybe; 1904 end; 1905 return; 1906 1907 dyadic_do (80): /* scalar /= */ 1908 dyadic_do (68): /* scalar = */ 1909 if single_element_fl_1 = single_element_fl_2 then 1910 result_array -> numeric_datum (0) = dyadic_set_on_equal; 1911 else 1912 if abs (single_element_fl_2 - single_element_fl_1) < 1913 abs(fuzz * (single_element_fl_1 + single_element_fl_2)) then 1914 result_array -> numeric_datum (0) = dyadic_set_on_equal; 1915 else 1916 result_array -> numeric_datum (0) = dyadic_set_on_not_equal; 1917 return; 1918 1919 dyadic_do (81): /* /= for vectors */ 1920 if free_type.zero_or_one_value then do; 1921 call apl_dyadic_bool_appendage_$neq (left_array, right_array, result_array, data_elements); 1922 return; 1923 end; 1924 else goto dyadic_do_eq_neq_vector; 1925 1926 dyadic_do (69): /* = for vectors */ 1927 if free_type.zero_or_one_value then do; 1928 call apl_dyadic_bool_appendage_$eq (left_array, right_array, result_array, data_elements); 1929 return; 1930 end; 1931 1932 dyadic_do_eq_neq_vector: 1933 do subscript = 0 by 1 while (subscript < data_elements); 1934 if left_array -> numeric_datum (subscript) = 1935 right_array -> numeric_datum (subscript) then 1936 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 1937 else 1938 if abs(left_array -> numeric_datum(subscript) - right_array -> numeric_datum(subscript)) < 1939 abs(fuzz * (left_array -> numeric_datum(subscript) + right_array -> numeric_datum(subscript))) then 1940 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 1941 else 1942 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 1943 end; 1944 return; 1945 1946 dyadic_do (82): /* left sc, right vc, /= */ 1947 dyadic_do (83): /* left vc, right sc, /= */ 1948 dyadic_do (70): /* left sc, right vc, = */ 1949 dyadic_do (71): /* right sc, left vc, = */ 1950 do subscript = 0 by 1 while (subscript < data_elements); 1951 if single_element_fl_1 = right_array -> numeric_datum (subscript) then 1952 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 1953 else 1954 if abs (single_element_fl_1 - 1955 right_array -> numeric_datum (subscript) ) < 1956 abs(fuzz * (single_element_fl_1 + right_array -> numeric_datum(subscript))) then 1957 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 1958 else 1959 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 1960 end; 1961 return; 1962 1963 dyadic_do (64): /* scalar <_ */ 1964 dyadic_do (76): /* scalar > */ 1965 if single_element_fl_1 <= 1966 single_element_fl_2 then 1967 result_array -> numeric_datum (0) = dyadic_set_on_equal; 1968 else if abs(single_element_fl_1 - single_element_fl_2) < 1969 abs(fuzz * (single_element_fl_1 + single_element_fl_2)) then 1970 result_array -> numeric_datum (0) = dyadic_set_on_equal; 1971 else 1972 result_array -> numeric_datum (0) = dyadic_set_on_not_equal; 1973 return; 1974 1975 dyadic_do (65): /* <_ for vectors */ 1976 dyadic_do (77): /* > for vectors */ 1977 do subscript = 0 by 1 while (subscript < data_elements); 1978 if left_array -> numeric_datum (subscript) <= 1979 right_array -> numeric_datum (subscript) then 1980 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 1981 else if abs(left_array -> numeric_datum(subscript) - right_array -> numeric_datum(subscript)) < 1982 abs(fuzz * (left_array -> numeric_datum(subscript) + right_array -> numeric_datum(subscript))) then 1983 result_array -> numeric_datum(subscript) = dyadic_set_on_equal; 1984 else 1985 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 1986 end; 1987 return; 1988 1989 dyadic_do (63): /* left vc, right sc, < */ 1990 dyadic_do (75): /* left vc, right sc, >_ */ 1991 dyadic_do (66): /* left sc, right vc, <_ */ 1992 dyadic_do (78): /* left sc, right vc, > */ 1993 do subscript = 0 by 1 while (subscript < data_elements); 1994 if single_element_fl_1 <= 1995 right_array -> numeric_datum (subscript) then 1996 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 1997 else if abs(single_element_fl_1 - right_array -> numeric_datum(subscript)) < 1998 abs(fuzz * (single_element_fl_1 + right_array -> numeric_datum(subscript))) then 1999 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 2000 else 2001 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 2002 end; 2003 return; 2004 2005 dyadic_do (60): /* scalar < */ 2006 dyadic_do (72): /* scalar >_ */ 2007 if single_element_fl_1 >= 2008 single_element_fl_2 then 2009 result_array -> numeric_datum (0) = dyadic_set_on_equal; 2010 else if abs(single_element_fl_1 - single_element_fl_2) < 2011 abs(fuzz * (single_element_fl_1 + single_element_fl_2)) then 2012 result_array -> numeric_datum (0) = dyadic_set_on_equal; 2013 else 2014 result_array -> numeric_datum (0) = dyadic_set_on_not_equal; 2015 return; 2016 2017 dyadic_do (61): /* < for vectors */ 2018 dyadic_do (73): /* >_ for vectors */ 2019 do subscript = 0 by 1 while (subscript < data_elements); 2020 if left_array -> numeric_datum (subscript) >= 2021 right_array -> numeric_datum (subscript) then 2022 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 2023 else if abs(left_array -> numeric_datum(subscript) - right_array -> numeric_datum(subscript)) < 2024 abs(fuzz * (left_array -> numeric_datum(subscript) + right_array -> numeric_datum(subscript))) then 2025 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 2026 else 2027 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 2028 end; 2029 return; 2030 2031 dyadic_do (67): /* left vc, right sc, <_ */ 2032 dyadic_do (79): /* left vc, right sc, > */ 2033 dyadic_do (62): /* left sc, right vc, < */ 2034 dyadic_do (74): /* left sc, right vc, >_ */ 2035 do subscript = 0 by 1 while (subscript < data_elements); 2036 if single_element_fl_1 >= 2037 right_array -> numeric_datum (subscript) then 2038 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 2039 else if abs(single_element_fl_1 - right_array -> numeric_datum(subscript)) < 2040 abs(fuzz * (single_element_fl_1 + right_array -> numeric_datum(subscript))) then 2041 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 2042 else 2043 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 2044 end; 2045 return; 2046 2047 dyadic_do (-4): /* both scalar, character, = */ 2048 if addr (single_element_fl_1) -> character_data_structure.character_datum (0) = 2049 addr (single_element_fl_2) -> character_data_structure.character_datum (0) then 2050 result_array -> numeric_datum (0) = dyadic_set_on_equal; 2051 else 2052 result_array -> numeric_datum (0) = dyadic_set_on_not_equal; 2053 return; 2054 2055 dyadic_do (-3): /* both vector, character, = (and /=) */ 2056 do subscript = data_elements - 1 to 0 by -1; 2057 if left_array -> character_data_structure.character_datum (subscript) = 2058 right_array -> character_data_structure.character_datum (subscript) then 2059 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 2060 else 2061 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 2062 end; 2063 return; 2064 2065 dyadic_do (-1): /* left vector, right scalar, characters, = and /= */ 2066 dyadic_do (-2): /* left scalar, right vector, characters, = and /= */ 2067 do subscript = data_elements - 1 to 0 by -1; 2068 if addr (single_element_fl_1) -> character_data_structure.character_datum (0) = 2069 right_array -> character_data_structure.character_datum (subscript) then 2070 result_array -> numeric_datum (subscript) = dyadic_set_on_equal; 2071 else 2072 result_array -> numeric_datum (subscript) = dyadic_set_on_not_equal; 2073 end; 2074 return; 2075 2076 end dyadic_operate; 2077 /* Subroutine to perform reductions. Called by reduction and scan. All parameters are global variables. */ 2078 2079 reduction_operate: 2080 procedure; 2081 2082 /* pseudo-parameters */ 2083 2084 /* dcl right_array ptr, ptr to result array. 2085* column_base fixed bin (21), subscript (0 origin) of first element in vector. 2086* highest_column_element fixed bin (21), subscript (0 origin) of next to last element. 2087* interval_between_elements fixed bin (21), number of elements between each element of the vector. 2088* action_place fixed bin (8), which operator to perform. 2089* result_accumulator float, the result of the reduction. 2090* (reduction_boolean_both, reduction_boolean_neither, reduction_set_on_equal, reduction_set_on_not_equal) 2091* float; inputs to comparison operators. */ 2092 2093 /* The rest of the global variables this routine references are not really parameters...just ordinary global vars. */ 2094 2095 /* automatic */ 2096 2097 dcl subscript fixed bin (21); /* provides a random subscript... don't use one in outer block, 2098* in order to avoid naming conflicts */ 2099 declare save_special_case fixed binary; /* if we must call do_many, we must set special_case 2100* to zero. therefore we must save it and restore 2101* it because others may depend on it being saved */ 2102 declare save_many_action_place fixed binary; /* .. */ 2103 2104 /* program */ 2105 2106 goto reduction_do (action_place); 2107 2108 reduction_do (0): /* reduction add */ 2109 reduction_do (1): /* reduction subtract. note alternating signs */ 2110 reduction_do (2): /* reduction multiply */ 2111 reduction_do (4): /* reduction max */ 2112 reduction_do (5): /* reduction min */ 2113 call apl_reduction_appendage_ (right_array, column_base, highest_column_element + interval_between_elements, 2114 interval_between_elements, action_place, result_accumulator); 2115 return; 2116 2117 reduction_do (3): /* reduction divide */ 2118 call apl_reduction_appendage_$divide (right_array, column_base, highest_column_element + interval_between_elements, 2119 interval_between_elements, action_place, result_accumulator, zerodivide_error_right); 2120 return; 2121 2122 reduction_do (6): /* power reduction */ 2123 reduction_do (7): /* logarithm reduction */ 2124 reduction_do (8): /* residue reduction */ 2125 reduction_do (9): /* binomial coefficients reduction */ 2126 reduction_do (10): /* one of the truly worthless things in this language, circle reduction */ 2127 save_special_case = special_case; /* so we can restore this later */ 2128 save_many_action_place = many_action_place; /* .. */ 2129 many_action_place = 2 * action_place; /* done here mainly for inner product's benefit */ 2130 special_case = 0; /* reduction itself will not use this */ 2131 do subscript = highest_column_element repeat (subscript - interval_between_elements) 2132 while (subscript >= column_base); 2133 2134 single_element_fl_2 = result_accumulator; 2135 single_element_fl_1 = right_array -> numeric_datum (subscript); 2136 2137 call do_many (); 2138 end; 2139 special_case = save_special_case; /* restore cause others may need it (cf. dyadic in inner_product) */ 2140 many_action_place = save_many_action_place; /* .. */ 2141 return; 2142 2143 reduction_do (13): /* nand */ 2144 reduction_do (14): /* nor */ 2145 result_accumulator = 1 - result_accumulator; 2146 reduction_do (11): /* and */ 2147 reduction_do (12): /* or */ 2148 if reduction_type.data_type.zero_or_one_value 2149 then do; 2150 call apl_reduction_appendage_ (right_array, column_base, 2151 highest_column_element + interval_between_elements, interval_between_elements, action_place, 2152 result_accumulator); 2153 return; 2154 end; 2155 2156 if abs (result_accumulator - reduction_boolean_both) > integer_fuzz then 2157 if abs (result_accumulator - reduction_boolean_neither) > integer_fuzz 2158 then goto domain_error; /* neither 0 nor 1 */ 2159 do subscript = highest_column_element repeat (subscript - interval_between_elements) 2160 while (subscript >= column_base); 2161 2162 if abs (right_array -> numeric_datum (subscript) - reduction_boolean_both) > integer_fuzz then do; 2163 if abs (right_array -> numeric_datum (subscript) - reduction_boolean_neither) > integer_fuzz then 2164 goto domain_error; 2165 2166 result_accumulator = reduction_set_on_not_equal; 2167 end; 2168 end; 2169 return; 2170 2171 reduction_do (15): /* another winner, < reduction */ 2172 reduction_do (18): /* >_ reduction */ 2173 do subscript = highest_column_element repeat (subscript - interval_between_elements) 2174 while (subscript >= column_base); 2175 2176 if right_array -> numeric_datum (subscript) >= result_accumulator then 2177 result_accumulator = reduction_set_on_equal; 2178 else if abs(right_array -> numeric_datum(subscript) - result_accumulator) < 2179 abs(fuzz * (right_array -> numeric_datum(subscript) + result_accumulator)) then 2180 result_accumulator = reduction_set_on_equal; 2181 else 2182 result_accumulator = reduction_set_on_not_equal; 2183 end; 2184 return; 2185 2186 reduction_do (16): /* <_ reduction */ 2187 reduction_do (19): /* > reduction */ 2188 do subscript = highest_column_element repeat (subscript - interval_between_elements) 2189 while (subscript >= column_base); 2190 2191 if right_array -> numeric_datum (subscript) <= result_accumulator then 2192 result_accumulator = reduction_set_on_equal; 2193 else if abs(right_array -> numeric_datum(subscript) - result_accumulator) < 2194 abs(fuzz * (right_array -> numeric_datum(subscript) + result_accumulator)) then 2195 result_accumulator = reduction_set_on_equal; 2196 else 2197 result_accumulator = reduction_set_on_not_equal; 2198 end; 2199 return; 2200 2201 reduction_do (17): /* /= */ 2202 reduction_do (20): /* = */ 2203 do subscript = highest_column_element repeat (subscript - interval_between_elements) 2204 while (subscript >= column_base); 2205 2206 if right_array -> numeric_datum (subscript) = result_accumulator 2207 then result_accumulator = reduction_set_on_equal; 2208 else if abs (result_accumulator - right_array -> numeric_datum (subscript)) < 2209 abs(fuzz * (result_accumulator + right_array -> numeric_datum(subscript))) then 2210 result_accumulator = reduction_set_on_equal; 2211 else 2212 result_accumulator = reduction_set_on_not_equal; 2213 end; 2214 return; 2215 2216 reduction_do (-1): /* = and /= for characters */ 2217 if right_array -> character_data_structure.character_datum (column_base) = 2218 right_array -> character_data_structure.character_datum (column_base + interval_between_elements) then 2219 result_accumulator = reduction_set_on_equal; /* comparison succeeded */ 2220 else 2221 result_accumulator = reduction_set_on_not_equal; 2222 return; 2223 2224 end reduction_operate; 2225 /* many subroutine. will do operation signified by many_action_place + special_case */ 2226 2227 do_many: 2228 procedure (); 2229 2230 /* automatic */ 2231 2232 declare (b, c, d, left_arg, right_arg, sign_result) float, 2233 casex fixed bin, 2234 resultc complex float; 2235 2236 /* builtins */ 2237 2238 declare (acos, asin, atan, atanh, cos, cosh, sin, sinh, sqrt, tan, tanh) builtin; 2239 2240 /* constants */ 2241 2242 declare (POSITIVE init (+1), 2243 NEGATIVE init (-1)) fixed bin internal static options (constant); 2244 2245 /* program */ 2246 2247 goto many_actions (many_action_place + special_case); 2248 2249 /* subroutine to do trig operations. entered with single_element_fl_1 being left arg and single_element_fl_2 2250* being right arg. Left will be checked for integerness and being >= -7 and <= 7. If this is already known, 2251* trig_integer can be set equal to left arg and do_trig_integral called instead */ 2252 2253 /* No domain errors are checked for here; instead we will let each trigonometric builtin function 2254* signal the "error" condition, and the default handler in apl_parse_ will transform "error" 2255* (with oncodes between 1 and 100, indicating math errors) into a domain error. */ 2256 2257 many_actions (20): /* TRIG: left arg is floating */ 2258 result_accumulator = floor (single_element_fl_1 + 0.5); 2259 if abs (result_accumulator - single_element_fl_1) > integer_fuzz | abs (result_accumulator) >= 1e17b 2260 then go to invalid_circular_fcn_left; 2261 2262 trig_integer = fixed (result_accumulator, 35); 2263 if abs (trig_integer) > 7 2264 then go to invalid_circular_fcn_left; 2265 2266 many_actions (21): /* TRIG: left is integral and from -7 to 7 */ 2267 goto trig_array (trig_integer); 2268 2269 trig_array (-7): /* hyperbolic arctangent */ 2270 result_accumulator = atanh(single_element_fl_2); 2271 return; 2272 2273 trig_array (-6): /* hyperbolic arccosine */ 2274 result_accumulator = atanh(sqrt(single_element_fl_2*single_element_fl_2 - 1.0e0)/single_element_fl_2); 2275 return; 2276 2277 trig_array (-5): /* hyperbolic arcsine */ 2278 result_accumulator = atanh(single_element_fl_2/sqrt(1.0e0 + single_element_fl_2*single_element_fl_2)); 2279 return; 2280 2281 trig_array (-4): /* sqrt (X**2 - 1) */ 2282 result_accumulator = sqrt(-1.0e0 + single_element_fl_2*single_element_fl_2); 2283 return; 2284 2285 trig_array (-3): /* arctangent */ 2286 result_accumulator = atan(single_element_fl_2); 2287 return; 2288 2289 trig_array (-2): /* arccosine */ 2290 result_accumulator = acos (single_element_fl_2); 2291 return; 2292 2293 trig_array (-1): /* arcsine */ 2294 result_accumulator = asin (single_element_fl_2); 2295 return; 2296 2297 trig_array (0): /* sqrt (1 - X**2) */ 2298 result_accumulator = sqrt(1.0e0 - single_element_fl_2*single_element_fl_2); 2299 return; 2300 2301 trig_array (1): /* sine */ 2302 result_accumulator = sin(single_element_fl_2); 2303 return; 2304 2305 trig_array (2): /* cosine */ 2306 result_accumulator = cos(single_element_fl_2); 2307 return; 2308 2309 trig_array (3): /* tangent */ 2310 result_accumulator = tan(single_element_fl_2); 2311 return; 2312 2313 trig_array (4): /* sqrt (X**2 + 1) */ 2314 result_accumulator = sqrt(1.0e0 + single_element_fl_2*single_element_fl_2); 2315 return; 2316 2317 trig_array (5): /* hyperbolic sine */ 2318 result_accumulator = sinh(single_element_fl_2); 2319 return; 2320 2321 trig_array (6): /* hyperbolic cosine */ 2322 result_accumulator = cosh(single_element_fl_2); 2323 return; 2324 2325 trig_array (7): /* hyperbolic tangent */ 2326 result_accumulator = tanh(single_element_fl_2); 2327 return; 2328 2329 many_actions (17): /* RESIDUE: check for compatibility error */ 2330 if single_element_fl_1 <= 0 then /* neg or zero */ 2331 goto compatibility_error_left; 2332 2333 many_actions (16): /* RESIDUE */ 2334 if abs (single_element_fl_1) > fuzz then do; /* not equal to zero */ 2335 result_accumulator = single_element_fl_2 - 2336 apl_floor_ (single_element_fl_2 / single_element_fl_1) * single_element_fl_1; 2337 return; 2338 end; 2339 result_accumulator = single_element_fl_2; 2340 return; 2341 2342 many_actions (14): /* LOGARITHM: log (right arg) to base (left arg) */ 2343 many_actions (15): 2344 if single_element_fl_1 < 0e0 then do; 2345 if single_element_fl_2 = 1e0 then do; 2346 result_accumulator = 0e0; 2347 return; 2348 end; 2349 2350 if single_element_fl_2 ^= single_element_fl_1 then 2351 goto domain_error; 2352 result_accumulator = 1e0; 2353 return; 2354 end; 2355 2356 if single_element_fl_1 = 1e0 /* avoid zerodivide, below */ 2357 then go to domain_error_left; 2358 else if single_element_fl_1 = 0e0 2359 then go to domain_error_left; 2360 else if single_element_fl_2 <= 0e0 2361 then go to domain_error_right; 2362 2363 result_accumulator = log (single_element_fl_2) / log (single_element_fl_1); 2364 return; 2365 2366 many_actions (12): /* EXPONENTIATION: right arg (exponent) floating */ 2367 result_accumulator = floor (single_element_fl_2 + 0.5); 2368 if (abs (result_accumulator - single_element_fl_2) > integer_fuzz) 2369 | (abs (result_accumulator) > 1e17b) 2370 then do; 2371 2372 /* exponent is not integral. */ 2373 2374 if single_element_fl_1 > 0 2375 then result_accumulator = single_element_fl_1 ** single_element_fl_2; /* (+F)**F */ 2376 else if single_element_fl_1 = 0 2377 then do; 2378 if single_element_fl_2 < 0 2379 then go to domain_error; /* 0**(-F) */ 2380 2381 result_accumulator = 0; /* 0**(+F) */ 2382 end; 2383 else do; /* (-F)**F */ 2384 resultc = complex (single_element_fl_1, 0) ** single_element_fl_2; 2385 result_accumulator = real (resultc); 2386 if result_accumulator < 100 * imag (resultc) 2387 then go to domain_error; 2388 end; 2389 return; 2390 end; 2391 2392 trig_integer = fixed (result_accumulator, 35); 2393 2394 many_actions (13): /* EXPONENTIATION: right arg (exponent) integral */ 2395 if single_element_fl_1 = 0 2396 then do; 2397 if trig_integer < 0 2398 then goto domain_error; /* 0**(-I) */ 2399 else if trig_integer = 0 2400 then result_accumulator = 1; /* 0**0 */ 2401 else result_accumulator = 0; /* 0**(+I) */ 2402 return; 2403 end; 2404 2405 result_accumulator = single_element_fl_1 ** trig_integer; /* I**I */ 2406 return; 2407 2408 many_actions (18): /* BINOMIAL COEFFICIENTS */ 2409 many_actions (19): 2410 if integer (single_element_fl_1, NEGATIVE) 2411 then casex = 4; 2412 else casex = 0; 2413 2414 if integer (single_element_fl_2, NEGATIVE) 2415 then casex = casex + 2; 2416 2417 if integer (single_element_fl_2 - single_element_fl_1, NEGATIVE) 2418 then casex = casex + 1; 2419 2420 go to case (casex); 2421 2422 /* A B B-A (1 --> negative integer, 0 otherwise */ 2423 /* ------- */ 2424 case (1): /* 0 0 1 -> 0e0 */ 2425 case (4): /* 1 0 0 -> 0e0 */ 2426 case (7): /* 1 1 1 -> 0e0 */ 2427 result_accumulator = 0e0; 2428 return; 2429 2430 case (2): /* 0 1 0 -> DOMAIN ERROR */ 2431 case (5): /* 1 0 1 -> Impossible */ 2432 go to domain_error; 2433 2434 case (0): /* 0 0 0 -> (!B)-:(!A)x!B-A */ 2435 sign_result = 1; 2436 left_arg = single_element_fl_1; 2437 right_arg = single_element_fl_2; 2438 go to combinations_common; 2439 2440 case (3): /* 0 1 1 -> (^1*A)xA!A-B+1 */ 2441 left_arg = single_element_fl_1; 2442 right_arg = single_element_fl_1 - (single_element_fl_2 + 1e0); 2443 if mod (single_element_fl_1, 2) = 0 /* even */ 2444 then sign_result = 1; 2445 else sign_result = -1; 2446 go to combinations_common; 2447 2448 case (6): /* 1 1 0 -> (^1*B-A)x(|B+1)!|A+1 */ 2449 left_arg = abs (single_element_fl_2 + 1e0); 2450 right_arg = abs (single_element_fl_1 + 1e0); 2451 if mod (single_element_fl_2 - single_element_fl_1, 2) = 0 /* even */ 2452 then sign_result = 1; 2453 else sign_result = -1; 2454 2455 combinations_common: 2456 if (integer (left_arg, POSITIVE) | (abs(left_arg) < integer_fuzz) ) & (integer (right_arg, POSITIVE)) 2457 then do; 2458 if right_arg - left_arg > left_arg 2459 then c = right_arg - left_arg; 2460 else c = left_arg; 2461 2462 b = -(c - right_arg); 2463 c = c + 1e0; 2464 result_accumulator = 1e0; 2465 2466 do d = result_accumulator by 1e0 while (d <= b); 2467 result_accumulator = (result_accumulator * c) / d; 2468 c = c + 1e0; 2469 end; 2470 result_accumulator = sign_result * result_accumulator; 2471 return; 2472 end; 2473 2474 result_accumulator = sign_result * gamma (right_arg + 1) / (gamma (left_arg + 1) * gamma (right_arg - left_arg + 1)) 2475 ; 2476 return; 2477 2478 /* Function to determine whether its argument is an integer, positive or negative */ 2479 2480 integer: 2481 procedure (P_arg, P_sign) returns (bit (1) aligned); 2482 2483 /* parameters */ 2484 2485 declare (P_arg float, 2486 P_sign fixed bin) parameter; 2487 2488 /* automatic */ 2489 2490 declare trial_val float; 2491 2492 /* program */ 2493 2494 trial_val = floor (P_arg + .5e0); 2495 2496 if (abs (trial_val - P_arg) < ws_info.integer_fuzz) & sign (trial_val) = P_sign 2497 then return ("1"b); 2498 else return ("0"b); 2499 2500 end integer; 2501 2502 end do_many; 2503 2504 /* ALGORITHM 80 2505* [RECIPROCAL] GAMMA FUNCTION OF REAL ARGUMENT. 2506* Published March, 1962 by William Holsten, in CACM 2507* Modified 790716 by PG to return gamma(x), rather than reciprocal. 2508* 2509* This function computes the Gamma function for all real values of x, using the identities: 2510* Gamma(x-1) = Gamma(x)/(x-1) for x < -1 2511* Gamma(x+1) = x*Gamma(x) for x > 1 2512* 2513* I have tested this algorithm versus a 12-place table and have found that is 2514* accurate to 11 decimal places between 0 and 1. It is also more accurate over 2515* the entire interval than the Taylor series expansion given in the Handbook 2516* of Mathematical Functions, Abramowitz and Stegun editors, Dover Publications, 2517* New York, 1972, page 256. 2518* 2519* The reference for the 12-place table is British Association for the 2520* Advancement of Science, Mathematical Tables, Volume 1, University Press, 2521* Cambridge, England, 1951, page 40. */ 2522 2523 gamma: 2524 procedure (P_x) returns (float); 2525 2526 /* parameters */ 2527 2528 declare P_x float parameter; 2529 2530 /* automatic */ 2531 2532 declare (result, x, y) float; 2533 2534 /* program */ 2535 2536 x = P_x; 2537 2538 if x = 0 2539 then go to domain_error; 2540 2541 else if x = 1 2542 then result = 1; 2543 2544 else if x >= 1 2545 then do; 2546 y = 1; 2547 aa: x = x - 1; 2548 y = y * x; 2549 if x > 1 2550 then go to aa; 2551 2552 if x = 1 2553 then result = y; 2554 else result = y / rgamma_int (x); 2555 end; 2556 2557 else if x = -1 2558 then go to domain_error; 2559 2560 else if x > -1 2561 then result = 1 / rgamma_int (x); 2562 2563 else do; 2564 y = x; 2565 cc: x = x + 1; 2566 if x < -1 2567 then do; 2568 y = y * x; 2569 go to cc; 2570 end; 2571 2572 if x = -1 2573 then go to domain_error; 2574 2575 result = 1 / (rgamma_int (x) * y); 2576 end; 2577 return (result); 2578 2579 /* This function computes the real reciprocal Gamma function of real x for -1 < x < 1, 2580* utilizing Horner's method for polynomial evaluation of the approximation polynomial. */ 2581 2582 rgamma_int: 2583 procedure (P_x) returns (float); 2584 2585 /* parameter */ 2586 2587 declare P_x float parameter; 2588 2589 /* automatic */ 2590 2591 declare (x, y) float; 2592 2593 /* program */ 2594 2595 x = P_x; 2596 y = x + 1e0; 2597 return (y * (x * (1e0 + x * (-.422784335092 + x * (-.233093736365 + x * 2598 (+.191091101162 + x * (-.024552490887 + x * (-.017645242118 + x * (+.008023278113 + x * 2599 (-.000804341335 + x * (-.000360851496 + x * (+.000145624324 + x * (-.000017527917 + x * 2600 (-.000002625721 + x * (+.000001328554 + x * -.000000181220))))))))))))))); 2601 2602 end rgamma_int; 2603 2604 end gamma; 2605 8 1 /* ====== BEGIN INCLUDE SEGMENT apl_floor_fcn.incl.pl1 ================================== */ 8 2 8 3 apl_floor_: 8 4 procedure (bv_value) returns (float); 8 5 8 6 /* Function to compute the floor of an apl value, taking 8 7* integer fuzz into account. In apl, for both the ceiling and floor functions, 8 8* if the input argument is within "integer fuzz" of its integer value, 8 9* then the result of the floor is this integer value. Otherwise, the result 8 10* is the normal floor (or ceiling). This procedure is followed so that 8 11* binary numbers which are within a few bits of the exact decimal 8 12* representation will behave properly. 8 13* 8 14* Written 750714 by PG 8 15**/ 8 16 8 17 /* parameters */ 8 18 8 19 dcl bv_value float; 8 20 8 21 /* automatic */ 8 22 8 23 dcl (value, result) float; 8 24 8 25 /* builtins */ 8 26 8 27 dcl (abs, floor) builtin; 8 28 8 29 /* this function requires the following include files: 8 30* %include apl_number_data; 8 31* %include apl_ws_info; 8 32**/ 8 33 8 34 /* program */ 8 35 8 36 value = bv_value; /* copy argument for efficiency */ 8 37 result = floor (value + .5e0); /* form trial result */ 8 38 8 39 if abs (result - value) >= integer_fuzz /* if trial not eq input value */ 8 40 then result = floor (value); /* then use normal floor */ 8 41 8 42 return (result); 8 43 8 44 end apl_floor_; 8 45 8 46 /* ------ END INCLUDE SEGMENT apl_floor_fcn.incl.pl1 ---------------------------------- */ 2606 2607 end /* apl_monadic_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1346.8 apl_monadic_.pl1 >special_ldd>on>apl.1129>apl_monadic_.pl1 197 1 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 198 2 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 199 3 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 200 4 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 201 5 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 202 6 11/29/83 1348.0 apl_operator_codes.incl.pl1 >special_ldd>on>apl.1129>apl_operator_codes.incl.pl1 1329 7 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_fcn.incl.pl1 2606 8 03/27/82 0438.7 apl_floor_fcn.incl.pl1 >ldd>include>apl_floor_fcn.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. NEGATIVE constant fixed bin(17,0) initial dcl 2242 set ref 2408* 2414* 2417* NumberSize constant fixed bin(4,0) initial dcl 1-25 ref 602 690 691 858 POSITIVE constant fixed bin(17,0) initial dcl 2242 set ref 2455* 2455* P_arg parameter float bin(63) dcl 2485 ref 2480 2494 2496 P_n_words parameter fixed bin(19,0) dcl 7-16 ref 7-4 7-35 P_sign parameter fixed bin(17,0) dcl 2485 ref 2480 2496 P_x parameter float bin(63) dcl 2587 in procedure "rgamma_int" ref 2582 2595 P_x parameter float bin(63) dcl 2528 in procedure "gamma" ref 2523 2536 abs builtin function dcl 156 in procedure "apl_monadic_" ref 271 299 339 373 375 1733 1734 1752 1752 1771 1776 1780 1782 1785 1785 1842 1843 1847 1850 1854 1854 1895 1895 1899 1901 1911 1911 1937 1937 1953 1953 1968 1968 1981 1981 1997 1997 2010 2010 2023 2023 2039 2039 2156 2156 2162 2163 2178 2178 2193 2193 2208 2208 2259 2259 2263 2333 2368 2368 2448 2450 2455 2496 abs builtin function dcl 8-27 in procedure "apl_floor_" ref 8-39 acos builtin function dcl 2238 ref 2289 action_place 000153 automatic fixed bin(17,0) dcl 93 set ref 600* 879* 1066 1337 1384 1392 1466* 1468 2106 2108* 2117* 2129 2150* actual_highest_column_element 000250 automatic fixed bin(21,0) dcl 978 set ref 1060* 1068 1081 1099 1112 1128 1139 1152 actual_left_array 000234 automatic pointer dcl 719 set ref 913* 941 actual_result_array 000240 automatic pointer dcl 719 set ref 907* 908 956 actual_right_array 000236 automatic pointer dcl 719 set ref 914* 929 addr builtin function dcl 156 ref 619 661 661 666 666 697 700 771 772 788 789 838 838 842 842 892 892 897 897 908 912 929 929 941 945 1223 1317 1420 1420 1425 1425 2047 2047 2068 addrel builtin function dcl 156 in procedure "apl_monadic_" ref 1215 1216 1224 1318 addrel builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-44 and_code constant fixed bin(8,0) initial dcl 6-8 ref 809 apl_display_bead_ 000022 constant entry external dcl 129 ref 387 apl_dyadic_bool_appendage_$and 000030 constant entry external dcl 129 ref 1794 apl_dyadic_bool_appendage_$eq 000040 constant entry external dcl 129 ref 1928 apl_dyadic_bool_appendage_$nand 000032 constant entry external dcl 129 ref 1808 apl_dyadic_bool_appendage_$neq 000042 constant entry external dcl 129 ref 1921 apl_dyadic_bool_appendage_$nor 000036 constant entry external dcl 129 ref 1815 apl_dyadic_bool_appendage_$or 000034 constant entry external dcl 129 ref 1801 apl_error_table_$compatibility_error 000050 external static fixed bin(35,0) dcl 145 ref 1230 apl_error_table_$display_disabled 000052 external static fixed bin(35,0) dcl 145 ref 1235 apl_error_table_$domain 000054 external static fixed bin(35,0) dcl 145 ref 1254 apl_error_table_$invalid_circular_fcn 000056 external static fixed bin(35,0) dcl 145 ref 1260 apl_error_table_$length 000060 external static fixed bin(35,0) dcl 145 ref 1263 apl_error_table_$no_identity 000062 external static fixed bin(35,0) dcl 145 ref 1267 apl_error_table_$rank 000064 external static fixed bin(35,0) dcl 145 ref 1271 apl_error_table_$zerodivide 000066 external static fixed bin(35,0) dcl 145 ref 1277 apl_get_value_stack_ 000072 constant entry external dcl 7-30 ref 7-40 apl_monadic_not_appendage_ 000024 constant entry external dcl 129 ref 360 apl_monadic_not_appendage_$in_place 000026 constant entry external dcl 129 ref 358 apl_reduction_appendage_ 000044 constant entry external dcl 129 ref 2108 2150 apl_reduction_appendage_$divide 000046 constant entry external dcl 129 ref 2117 apl_static_$ws_info_ptr 000070 external static structure level 1 dcl 5-11 asin builtin function dcl 2238 ref 2293 atan builtin function dcl 2238 ref 2285 atanh builtin function dcl 2238 ref 2269 2273 2277 b 000372 automatic float bin(63) dcl 2232 set ref 2462* 2466 based_pointer based pointer dcl 726 ref 943 945 binary builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-40 binary builtin function dcl 156 in procedure "apl_monadic_" ref 1199 block_ptr 000276 automatic pointer dcl 7-20 set ref 7-43* 7-45 boolean_both 000170 automatic float bin(63) dcl 106 set ref 457 458 608 609 652 653 872 873 885 886 1029 1030 1384* booleans 000416 constant float bin(63) initial array dcl 170 ref 1384 bv_value parameter float bin(63) dcl 8-19 ref 8-3 8-36 c 000374 automatic float bin(63) dcl 2232 set ref 2458* 2460* 2462 2463* 2463 2467 2468* 2468 casex 000406 automatic fixed bin(17,0) dcl 2232 set ref 2408* 2412* 2414* 2414 2417* 2417 2420 ceil builtin function dcl 156 ref 299 char_compare constant fixed bin(17,0) initial dcl 187 ref 472 685 808 char_string_overlay based char unaligned dcl 728 set ref 619* 697* 929* 929 945* 945 character_data_structure based structure level 1 dcl 4-15 character_datum based char(1) array level 2 packed unaligned dcl 4-15 set ref 929 929 941 2047 2047 2057 2057 2068 2068 2216 2216 character_string_overlay based char dcl 4-19 ref 619 697 826 826 1303 character_value 0(09) based bit(1) level 5 packed unaligned dcl 4-3 set ref 1446 1455 character_value_type constant bit(18) initial unaligned dcl 3-30 ref 1460 column_base 000126 automatic fixed bin(21,0) dcl 71 set ref 616* 616* 618* 695* 695* 697* 701 732* 1058* 1058* 1060 1062 1062 1068 1081 1099 1112 1128 1139 1152* 2108* 2117* 2131 2150* 2159 2171 2186 2201 2216 2216 column_skip_interval 000130 automatic fixed bin(21,0) dcl 71 set ref 575* 576 627 917* 934 1048* 1049 1182 column_skip_interval_minus_1 000132 automatic fixed bin(21,0) dcl 71 set ref 576* 618 1049* 1060 compatibility_check_mode 1(14) based bit(1) level 3 packed unaligned dcl 5-16 ref 1341 complex builtin function dcl 156 ref 2384 copy_rho_vb 000104 automatic pointer dcl 61 set ref 426* 442* 447 447 copy_up_needed 000100 automatic bit(1) dcl 55 set ref 479 628 985* 1183 1484* 1487* 1504* 1506* cos builtin function dcl 2238 ref 2305 cosh builtin function dcl 2238 ref 2321 d 000376 automatic float bin(63) dcl 2232 set ref 2466* 2466* 2467* data_elements 000135 automatic fixed bin(21,0) dcl 71 set ref 223* 257 264 264 270 281 295 308 318 327 339 339 343 352 352 372 389 407* 429* 452 469 518* 520* 520 523* 531 534 542* 563* 592 619 644* 682 694* 697 700 743* 746* 746 750 826 826 908 911* 912 992* 994 1296 1303 1303 1322 1558 1566 1581 1589 1597 1611 1619 1636 1648 1659 1674 1681 1693 1700 1717 1738 1763 1794* 1801* 1808* 1815* 1840 1869 1869 1874 1885 1889 1898 1921* 1928* 1932 1946 1975 1989 2017 2031 2055 2065 data_pointer 4 based pointer level 2 packed unaligned dcl 4-3 set ref 1218* 1220 1324* 1443 1452 data_type 0(08) 000217 automatic structure level 2 in structure "free_type" packed unaligned dcl 124 in procedure "apl_monadic_" set ref 1460 data_type 0(08) 000216 automatic structure level 2 in structure "reduction_type" packed unaligned dcl 123 in procedure "apl_monadic_" data_type 0(08) based structure level 4 in structure "value_bead" packed unaligned dcl 4-3 in procedure "apl_monadic_" data_words_needed 000136 automatic fixed bin(19,0) dcl 87 set ref 553 670 750* 851* 851 855* 855 860* 860 963* 1010 1219 1224 1296* 1303* 1315 debug_mode 1(01) based bit(1) level 3 packed unaligned dcl 5-16 ref 382 dimension 000143 automatic fixed bin(17,0) dcl 93 in procedure "apl_monadic_" set ref 493 507 508 519 519 570 1000 1043 1414 1419 1425 1425 1470* dimension 4 parameter fixed bin(17,0) level 3 in structure "operators_argument" dcl 2-3 in procedure "apl_monadic_" ref 1470 divide builtin function dcl 156 ref 523 563 851 dyadic 000324 automatic bit(1) initial dcl 1437 set ref 1437* 1441* 1457 dyadic_action_place 000150 automatic fixed bin(17,0) dcl 93 set ref 415* 422* 431* 438* 472* 472 475* 475 655* 685* 779* 781* 787* 808* 808 857* 857 1545 dyadic_boolean_both 000200 automatic float bin(63) dcl 106 set ref 457* 652* 872* 1771 1776 1785 1842 1843 1854 1868 1895 1899 dyadic_boolean_neither 000202 automatic float bin(63) dcl 106 set ref 458* 653* 873* 1780 1782 1785 1847 1850 1854 1884 1895 1901 dyadic_set_on_equal 000174 automatic float bin(63) dcl 106 set ref 454* 649* 819* 821 826 869* 1777 1844 1907 1911 1934 1937 1951 1953 1963 1968 1978 1981 1994 1997 2005 2010 2020 2023 2036 2039 2047 2057 2068 dyadic_set_on_not_equal 000176 automatic float bin(63) dcl 106 set ref 455* 469 650* 682 821* 829 870* 1789 1858 1874 1885 1901 1915 1941 1958 1971 1984 2000 2013 2026 2042 2051 2060 2071 element_size 000232 automatic fixed bin(4,0) dcl 717 set ref 599* 602* 619 619 619 687* 690* 697 697 701 807* 858* 917 918 919 920 925 929 929 935 945 945 eq_or_not_eq 0(18) 000000 constant bit(1) initial array level 2 packed unaligned dcl 180 ref 462 589 675 800 equal_code constant fixed bin(8,0) initial dcl 6-8 ref 241 247 809 error_code 7 parameter fixed bin(35,0) level 2 dcl 2-3 set ref 1230* 1235* 1254* 1260* 1263* 1267* 1271* 1277* exp builtin function dcl 156 ref 320 fixed builtin function dcl 156 ref 1735 1754 2262 2392 flip_flag 000251 automatic bit(1) dcl 979 set ref 1079* 1084 1095* 1095 1110* 1115 1124* 1124 float_temp 000166 automatic float bin(63) dcl 106 set ref 1731* 1733 1734 1735 1750* 1752 1752 1754 floor builtin function dcl 156 in procedure "apl_monadic_" ref 297 1731 1750 2257 2366 2494 floor builtin function dcl 8-27 in procedure "apl_floor_" ref 8-37 8-39 free_type 000217 automatic structure level 1 dcl 124 set ref 238 512 875 876* 881* 987 1345 1361 1371 1459* 1460 1460* 1464* fuzz 000162 automatic float bin(63) dcl 106 in procedure "apl_monadic_" set ref 1472* 1911 1937 1953 1968 1981 1997 2010 2023 2039 2178 2193 2208 2333 fuzz 6 based float bin(63) level 3 in structure "ws_info" dcl 5-16 in procedure "apl_monadic_" ref 1472 general_bead based structure level 1 dcl 3-3 header based structure level 2 dcl 4-3 highest_column_element 000131 automatic fixed bin(21,0) dcl 71 set ref 618* 619 916* 951 1152* 1152* 1170 1175* 1178 2108 2117 2131 2150 2159 2171 2186 2201 identity 000344 constant float bin(63) initial array dcl 173 ref 534 819 1392 identity_type 000000 constant bit(18) initial array level 2 packed unaligned dcl 180 ref 528 532 imag builtin function dcl 156 ref 2386 integer_fuzz 000164 automatic float bin(63) dcl 106 in procedure "apl_monadic_" set ref 271 299 328 373 375 1473* 1733 1752 1771 1776 1780 1782 1785 1785 1842 1843 1847 1850 1854 1854 1895 1895 1899 1901 2156 2156 2162 2163 2259 2368 2455 8-39 integer_fuzz 22 based float bin(63) level 2 in structure "ws_info" dcl 5-16 in procedure "apl_monadic_" ref 1473 2496 integral_value 0(11) based bit(1) level 5 packed unaligned dcl 4-3 set ref 267* integral_value_type constant bit(18) initial unaligned dcl 3-30 ref 293 306 interval_between_elements 000127 automatic fixed bin(21,0) dcl 71 set ref 567* 571* 571 575 576 576 615 619 734* 1040* 1044* 1044 1048 1049 1056 1068 1076 1081 1096 1099 1107 1112 1125 1128 1136 1139 1147 1170 1175 1178 2108 2108* 2117 2117* 2138 2150 2150* 2168 2183 2198 2213 2216 ip_subscript 000224 automatic fixed bin(21,0) dcl 710 set ref 823* 823* 826* 833 926* 926* 929* 935 937* 956 958* 958 last_column_on_this_plane 000134 automatic fixed bin(21,0) dcl 71 set ref 615* 616 1056* 1058 left_arg 000400 automatic float bin(63) dcl 2232 set ref 2436* 2440* 2448* 2455* 2455 2458 2458 2458 2460 2474 2474 left_array 000114 automatic pointer dcl 61 set ref 419 433 439 697 772 788 826 913 941* 1443* 1560 1583 1613 1638 1642 1676 1695 1723 1794* 1801* 1808* 1815* 1842 1850 1921* 1928* 1934 1937 1937 1978 1981 1981 2020 2023 2023 2057 left_chars 000101 automatic bit(1) dcl 55 set ref 460 463 467 673 676 680 798 801 805 1446* 1484 left_count 000230 automatic fixed bin(21,0) dcl 710 set ref 757* 759* 774 776 786 918* 918 959 left_data_elements 000124 automatic fixed bin(21,0) dcl 71 set ref 406 407 644 691* 691 695 757 759 823 919 1444* left_rhorho 000142 automatic fixed bin(17,0) dcl 93 set ref 410 411 424 434 645 660 666 745 757 836 890 1445* left_total_chars 000225 automatic fixed bin(21,0) dcl 710 set ref 919* 939 left_vb 000112 automatic pointer dcl 61 set ref 412 426 661 746 757 838 892 1197 1442* 1443 1444 1445 1446 1459 1490 log builtin function dcl 156 ref 330 2363 2363 many_action_place 000151 automatic fixed bin(17,0) dcl 93 set ref 1468* 2128 2129* 2140* 2247 max builtin function dcl 156 ref 836 890 1132 1670 1676 1684 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 5-16 ref 1199 7-40 min builtin function dcl 156 ref 1143 1689 1695 1703 min_code constant fixed bin(8,0) initial dcl 6-8 ref 983 mod builtin function dcl 156 ref 2443 2451 not_equal_code constant fixed bin(8,0) initial dcl 6-8 ref 241 247 387 not_zero_or_one_mask constant bit(18) initial unaligned dcl 3-30 ref 1361 num_words 000300 automatic fixed bin(19,0) dcl 7-20 set ref 7-35* 7-37 7-37* 7-37 7-40 7-40* 7-44 number_of_dimensions 000221 automatic fixed bin(17,0) dcl 4-3 set ref 1312* 1314 number_to_copy 000137 automatic fixed bin(19,0) dcl 87 set ref 553* 554 554 660* 661 661 665* 666 666 836* 838 838 841* 842 842 890* 892 892 896* 897 897 1010* 1011 1011 1212* 1213 1219* 1220 1220 1419* 1420 1420 1424* 1424 1425 1425 numeric 000266 automatic bit(1) dcl 1292 set ref 1297* 1304* 1310* 1318 numeric_datum based float bin(63) array dcl 4-23 set ref 257* 257 264* 264 271 271* 273 273* 275* 282 284* 284 296 302* 309 311* 320* 320 328 330* 330 339* 339 345* 345 352* 352 373 373* 375 375* 389* 389 469* 534* 592* 624* 682* 700 750 826* 829* 908 912 951 956* 1062 1062* 1072 1072* 1084 1084* 1090 1090* 1103 1103* 1115 1117 1122 1123* 1132 1132* 1143 1143* 1170 1175* 1296 1552* 1560* 1560 1560 1569* 1569 1575* 1583* 1583 1583 1591* 1591 1599* 1599 1605* 1613* 1613 1613 1622* 1622 1628* 1633* 1638 1638 1638* 1642* 1642 1642 1650 1650* 1654* 1654 1661 1661* 1665* 1665 1670* 1676* 1676 1676 1684* 1684 1689* 1695* 1695 1695 1703* 1703 1714* 1723 1724 1726* 1743 1745* 1764 1766* 1777* 1789* 1842 1843 1844* 1847 1850 1854 1854 1858* 1869* 1869 1874* 1885* 1889* 1889 1899 1899* 1901 1901* 1907* 1911* 1915* 1934 1934 1934* 1937 1937 1937 1937 1937* 1941* 1951 1951* 1953 1953 1953* 1958* 1963* 1968* 1971* 1978 1978 1978* 1981 1981 1981 1981 1981* 1984* 1994 1994* 1997 1997 1997* 2000* 2005* 2010* 2013* 2020 2020 2020* 2023 2023 2023 2023 2023* 2026* 2036 2036* 2039 2039 2039* 2042* 2047* 2051* 2057* 2060* 2068* 2071* 2135 2162 2163 2176 2178 2178 2191 2193 2193 2206 2208 2208 numeric_value_type constant bit(18) initial unaligned dcl 3-30 ref 279 316 325 350 1354 1375 1460 on_stack 1 parameter bit(1) array level 3 dcl 2-3 ref 225 255 358 389 496 985 1191 1193 1488 1490 1501 1506 op1 000154 automatic fixed bin(17,0) dcl 93 in procedure "apl_monadic_" set ref 219* 241 241 247 247 251 387 462 475 528 532 534 589 655 675 794* 800 809 819 857 983 1466* op1 5(27) parameter fixed bin(8,0) level 3 in structure "operators_argument" packed unaligned dcl 2-3 in procedure "apl_monadic_" ref 1466 op2 5(18) parameter fixed bin(8,0) level 3 in structure "operators_argument" packed unaligned dcl 2-3 in procedure "apl_monadic_" ref 1469 op2 000231 automatic fixed bin(21,0) dcl 710 in procedure "apl_monadic_" set ref 794 809 813 879 1469* operands parameter structure array level 2 dcl 2-3 operator 4 parameter structure level 2 dcl 2-3 operator_info 000000 constant structure array level 1 dcl 180 operators_argument parameter structure level 1 dcl 2-3 set ref 50 215 396 484 640 707 975 or_code constant fixed bin(8,0) initial dcl 6-8 ref 813 pi 000426 constant float bin(63) initial dcl 167 ref 352 plane_base 000125 automatic fixed bin(21,0) dcl 71 set ref 614* 614* 615 616* 627 924* 924* 925 937* 1053* 1053* 1056 1058* 1182 pointers 14 based structure level 2 dcl 5-16 real builtin function dcl 156 ref 2385 recover_right_array 000244 automatic pointer dcl 719 set ref 771* 788* 943 recover_single_element 000246 automatic pointer dcl 719 set ref 772* 789* 945 reduction_boolean_both 000210 automatic float bin(63) dcl 106 set ref 608* 885* 1029* 2156 2162 reduction_boolean_neither 000212 automatic float bin(63) dcl 106 set ref 609* 886* 1030* 2156 2163 reduction_set_on_equal 000204 automatic float bin(63) dcl 106 set ref 605* 882* 1032* 2176 2178 2191 2193 2206 2208 2216 reduction_set_on_not_equal 000206 automatic float bin(63) dcl 106 set ref 606* 883* 1033* 2166 2181 2196 2211 2220 reduction_type 000216 automatic structure level 1 dcl 123 set ref 512* 876* 987* rel builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-40 rel builtin function dcl 156 in procedure "apl_monadic_" ref 1199 1216 1318 result 000432 automatic float bin(63) dcl 2532 in procedure "gamma" set ref 2541* 2552* 2554* 2560* 2575* 2577 result 000462 automatic float bin(63) dcl 8-23 in procedure "apl_floor_" set ref 8-37* 8-39 8-39* 8-42 result 6 parameter pointer level 2 in structure "operators_argument" packed unaligned dcl 2-3 in procedure "apl_monadic_" set ref 226* 498* 1194* 1200* 1225* 1325* result_accumulator 000214 automatic float bin(63) dcl 106 set ref 297* 299 299* 302 310* 311 619 624 855 860 951* 956 963 1062* 1072 1072* 1084 1084* 1090 1090* 1103 1103* 1115* 1115 1117 1117* 1122* 1122 1123 1132 1132* 1143 1143* 1170* 1175 1714 1726 1745 1766 2108* 2117* 2134 2143* 2143 2150* 2156 2156 2166* 2176 2176* 2178 2178 2178* 2181* 2191 2191* 2193 2193 2193* 2196* 2206 2206* 2208 2208 2208* 2211* 2216* 2220* 2257* 2259 2259 2262 2269* 2273* 2277* 2281* 2285* 2289* 2293* 2297* 2301* 2305* 2309* 2313* 2317* 2321* 2325* 2335* 2339* 2346* 2352* 2363* 2366* 2368 2368 2374* 2381* 2385* 2386 2392 2399* 2401* 2405* 2424* 2464* 2466 2467* 2467 2470* 2470 2474* result_array 000120 automatic pointer dcl 61 set ref 228* 257 264 271 273 275 284 302 311 320 330 339 345 352 360* 373 375 389 469 534 554 592 624 682 700* 700 826 829 907 908* 912 950 951 1011 1062 1072 1084 1090 1103 1123 1132 1143 1175 1223* 1317* 1318 1318* 1318 1324 1552 1560 1569 1575 1583 1591 1599 1605 1613 1622 1628 1633 1638 1642 1650 1654 1661 1665 1670 1676 1684 1689 1695 1703 1714 1726 1745 1766 1777 1789 1794* 1801* 1808* 1815* 1844 1858 1869 1874 1885 1889 1889 1899 1901 1907 1911 1915 1921* 1928* 1934 1937 1941 1951 1953 1958 1963 1968 1971 1978 1981 1984 1994 1997 2000 2005 2010 2013 2020 2023 2026 2036 2039 2042 2047 2051 2057 2060 2068 2071 result_vb 000116 automatic pointer dcl 61 set ref 226* 235 238 261 267 279 293 306 316 325 350 370 447 528 552 661 666 818 838 842 876 892 897 963 1007 1017 1035 1194 1200 1213 1220 1223 1316* 1317 1322 1323 1324 1325 1345 1354 1361 1371 1375 1399 1414 1420 1425 resultc 000410 automatic complex float bin(63) dcl 2232 set ref 2384* 2385 2386 rho 5 based fixed bin(21,0) array level 2 dcl 4-3 set ref 235* 235 412 412 447* 447 508 520 571 661 661 666 666 738 746 757 764 838 838 842 842 892 892 897 897 1000 1007* 1007 1035* 1035 1044 1223 1317 1414* 1414 1420 1420 1425 1425 rho_sub_dimension 000133 automatic fixed bin(21,0) dcl 71 set ref 503* 508* 517 523 541 563 575 591 770* 786* 793 860 901 911 916 1000* 1001 1048 rho_subscript 000146 automatic fixed bin(17,0) dcl 93 set ref 360* 519* 520* 521* 570* 570* 571* 737* 737* 738* 745* 745* 746* 1043* 1043* 1044* rhorho 000145 automatic fixed bin(17,0) dcl 93 in procedure "apl_monadic_" set ref 221* 424* 441* 502* 506* 645* 732* 740* 740 748* 748 991* 997 1223 1312 1317 1323 1412 1413 1424 rhorho 3 based fixed bin(17,0) level 2 in structure "value_bead" dcl 4-3 in procedure "apl_monadic_" set ref 235 235 447 447 1007 1007 1035 1035 1323* 1445 1454 right_arg 000402 automatic float bin(63) dcl 2232 set ref 2437* 2442* 2450* 2455* 2458 2458 2462 2474 2474 right_array 000110 automatic pointer dcl 61 set ref 228 257 264 271 273 282 284 296 309 320 328 330 339 345 352 358* 360* 373 375 389 418 419* 432 554 619 826 914 943* 950* 1011 1062 1072 1084 1090 1103 1115 1117 1122 1132 1143 1170 1215* 1216 1216* 1216 1218 1220 1224 1452* 1560 1569 1583 1591 1599 1613 1622 1638 1642 1650 1654 1661 1665 1676 1684 1695 1703 1724 1743 1764 1794* 1801* 1808* 1815* 1843 1847 1854 1854 1869 1889 1889 1899 1901 1921* 1928* 1934 1937 1937 1951 1953 1953 1978 1981 1981 1994 1997 1997 2020 2023 2023 2036 2039 2039 2057 2068 2108* 2117* 2135 2150* 2162 2163 2176 2178 2178 2191 2193 2193 2206 2208 2208 2216 2216 right_chars 000102 automatic bit(1) dcl 55 set ref 231 247 460 467 543 587 673 680 798 805 1002 1021 1455* 1484 1501 right_count 000227 automatic fixed bin(21,0) dcl 710 set ref 734* 738* 738 743 917 924 958 right_data_elements 000123 automatic fixed bin(21,0) dcl 71 set ref 223 241 358* 360* 409 429 430 516 523 542 563 614 644 694 762 762 826 826 833 992 1053 1453* right_move_count 000226 automatic fixed bin(21,0) dcl 710 set ref 762* 764* 769 770 776 851 855 920* 920 926 right_rhorho 000144 automatic fixed bin(17,0) dcl 93 set ref 221 410 434 441 491 506 507 521 570 645 665 737 809 841 896 991 1043 1454* right_vb 000106 automatic pointer dcl 61 set ref 226 235 235 335 356 387* 412 442 498 508 520 552 571 666 738 764 842 897 1000 1007 1007 1017 1035 1035 1044 1197* 1199 1213 1215 1218 1225 1414 1420 1425 1451* 1452 1453 1454 1455 1459 1464 1488 1503 save_free_type 000220 automatic structure level 1 dcl 125 set ref 875* 881 save_many_action_place 000362 automatic fixed bin(17,0) dcl 2102 set ref 2128* 2140 save_special_case 000361 automatic fixed bin(17,0) dcl 2099 set ref 2122* 2139 scalar constant fixed bin(17,0) initial dcl 187 ref 431 scalar_vector constant fixed bin(17,0) initial dcl 187 ref 438 655 685 781 set_on_equal 000172 automatic float bin(63) dcl 106 set ref 454 455 592 605 606 649 650 869 870 882 883 1032 1033 1392* sign builtin function dcl 156 ref 2496 sign_result 000404 automatic float bin(63) dcl 2232 set ref 2434* 2443* 2445* 2451* 2453* 2470 2474 sin builtin function dcl 2238 ref 2301 single_element_fl_1 000156 automatic float bin(63) dcl 106 set ref 296* 297 299 299 309* 310* 418* 433* 439* 697 945 1552 1569 1575 1591 1599 1605 1622 1628 1633 1650 1654 1661 1665 1670 1684 1689 1703 1723* 1731 1733 1750 1752 1758 1764* 1771 1782 1868 1878* 1878 1884 1895 1895 1899 1907 1911 1911 1951 1953 1953 1963 1968 1968 1994 1997 1997 2005 2010 2010 2036 2039 2039 2047 2068 2135* 2257 2259 2329 2333 2335 2335 2342 2350 2356 2358 2363 2374 2374 2376 2384 2394 2405 2408* 2417 2436 2440 2442 2443 2450 2451 single_element_fl_2 000160 automatic float bin(63) dcl 106 set ref 432* 1552 1575 1605 1628 1633 1670 1689 1724* 1743* 1758* 1776 1780 1785 1785 1907 1911 1911 1963 1968 1968 2005 2010 2010 2047 2134* 2269 2273 2273 2273 2277 2277 2277 2281 2281 2285 2289 2293 2297 2297 2301 2305 2309 2313 2313 2317 2321 2325 2335 2335 2339 2345 2350 2360 2363 2366 2368 2374 2378 2384 2414* 2417 2437 2442 2448 2451 sinh builtin function dcl 2238 ref 2317 size builtin function dcl 156 ref 750 855 860 963 1296 1303 1314 special_case 000152 automatic fixed bin(17,0) dcl 93 set ref 1341* 1474* 1736* 1755* 2122 2130* 2139* 2247 sqrt builtin function dcl 2238 ref 2273 2277 2281 2297 2313 static_ws_info_ptr 000070 external static pointer level 2 packed unaligned dcl 5-11 ref 5-7 string builtin function dcl 156 set ref 238* 238 279* 293* 306* 316* 325* 350* 370* 512* 512 528* 552* 552 818* 875* 875 876 876* 876* 881* 881 987* 987 1017* 1017 1345* 1345 1354* 1361* 1361 1371* 1371 1375* 1399* 1459* 1459 1459 1460 1460 1460* 1464* 1464 subscript 000350 automatic fixed bin(21,0) dcl 1542 in procedure "dyadic_operate" set ref 1558* 1558* 1560 1560 1560* 1566* 1566* 1569 1569* 1581* 1581* 1583 1583 1583* 1589* 1589* 1591 1591* 1597* 1597* 1599 1599* 1611* 1611* 1613 1613 1613* 1619* 1619* 1622 1622* 1636* 1636* 1638 1638 1638 1642 1642 1642* 1648* 1648* 1650 1650 1654 1654* 1659* 1659* 1661 1661 1665 1665* 1674* 1674* 1676 1676 1676* 1681* 1681* 1684 1684* 1693* 1693* 1695 1695 1695* 1700* 1700* 1703 1703* 1717* 1717* 1723 1724 1726* 1738* 1738* 1743 1745* 1763* 1763* 1764 1766* 1840* 1840* 1842 1843 1844 1847 1850 1854 1854 1858* 1898* 1898* 1899 1899 1901 1901* 1932* 1932* 1934 1934 1934 1937 1937 1937 1937 1937 1941* 1946* 1946* 1951 1951 1953 1953 1953 1958* 1975* 1975* 1978 1978 1978 1981 1981 1981 1981 1981 1984* 1989* 1989* 1994 1994 1997 1997 1997 2000* 2017* 2017* 2020 2020 2020 2023 2023 2023 2023 2023 2026* 2031* 2031* 2036 2036 2039 2039 2039 2042* 2055* 2057 2057 2057 2060* 2065* 2068 2068 2071* subscript 000360 automatic fixed bin(21,0) dcl 2097 in procedure "reduction_operate" set ref 2131* 2131* 2135* 2138 2159* 2159* 2162 2163* 2168 2171* 2171* 2176 2178 2178* 2183 2186* 2186* 2191 2193 2193* 2198 2201* 2201* 2206 2208 2208* 2213 subscript 000122 automatic fixed bin(21,0) dcl 71 in procedure "apl_monadic_" set ref 270* 270* 271 271 273 273 275* 281* 281* 282 284 284* 295* 295* 296 302* 308* 308* 309 311* 318* 318* 320 320* 327* 327* 328 330 330* 343* 343* 345 345* 372* 372* 373 373 375 375* 411* 411* 412 412* 613* 624 625* 625 822* 826 829 832* 832 836* 842 890* 897 925* 929 934* 934 939* 939* 941* 959 1068* 1068* 1072 1072* 1076 1081* 1081* 1084 1084 1090 1090* 1096 1099* 1099* 1103 1103* 1107 1112* 1112* 1115 1117 1122 1123* 1125 1128* 1128* 1132 1132* 1136 1139* 1139* 1143 1143* 1147 substr builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-37 substr builtin function dcl 156 in procedure "apl_monadic_" ref 619 697 826 826 1216 1318 swapped_flag 000103 automatic bit(1) dcl 55 set ref 421* 790* 1239 1244 1475* switches 1 based structure level 2 packed unaligned dcl 5-16 tan builtin function dcl 2238 ref 2309 tanh builtin function dcl 2238 ref 2325 temp_right_array 000242 automatic pointer dcl 719 set ref 771 789 912* 929 total_data_elements 2 based fixed bin(21,0) level 2 dcl 4-3 set ref 963 1322* 1444 1453 trial_val 000422 automatic float bin(63) dcl 2490 set ref 2494* 2496 2496 trig_integer 000147 automatic fixed bin(17,0) dcl 93 set ref 1735* 1754* 2262* 2263 2266 2392* 2397 2399 2405 type based structure level 2 in structure "general_bead" packed unaligned dcl 3-3 in procedure "apl_monadic_" type based structure level 3 in structure "value_bead" packed unaligned dcl 4-3 in procedure "apl_monadic_" set ref 238* 279* 293* 306* 316* 325* 350* 370* 528* 552* 552 818* 876 1017* 1017 1345* 1354* 1361* 1371* 1375* 1399* 1459 1459 1464 unal_fl_bit_ovly based bit(72) dcl 161 ref 418 432 433 439 unspec builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-37 unspec builtin function dcl 156 in procedure "apl_monadic_" set ref 418* 432* 433* 439* value 000460 automatic float bin(63) dcl 8-23 in procedure "apl_floor_" set ref 8-36* 8-37 8-39 8-39 value parameter pointer array level 3 in structure "operators_argument" packed unaligned dcl 2-3 in procedure "apl_monadic_" ref 1442 1451 value_bead based structure level 1 dcl 4-3 set ref 1314 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 5-16 set ref 1224* 7-40 7-43 7-44* 7-44 1488* 1490* 1503* values 2 based structure level 2 dcl 5-16 vector constant fixed bin(17,0) initial dcl 187 ref 415 779 vector_scalar constant fixed bin(17,0) initial dcl 187 ref 422 787 where_error 10 parameter fixed bin(17,0) level 2 dcl 2-3 set ref 1232* 1232 1248* 1248 1251* 1251 1258* 1258 1275* 1275 word_copy_overlay based fixed bin(35,0) array dcl 163 set ref 554* 554 661* 661 666* 666 838* 838 842* 842 892* 892 897* 897 1011* 1011 1213* 1213 1220* 1220 1420* 1420 1425* 1425 words_needed 000140 automatic fixed bin(19,0) dcl 87 set ref 1199 1315* 1316* words_needed_in_bead 000141 automatic fixed bin(19,0) dcl 87 set ref 1212 1215 1314* 1315 ws_info based structure level 1 dcl 5-16 ws_info_ptr 000222 automatic pointer initial dcl 5-7 set ref 382 1199 1224 5-7* 7-40 7-40 7-43 7-44 7-44 1341 1472 1473 1488 1490 1503 2496 x 000446 automatic float bin(63) dcl 2591 in procedure "rgamma_int" set ref 2595* 2596 2597 2597 2597 2597 2597 2597 2597 2597 2597 2597 2597 2597 2597 2597 x 000434 automatic float bin(63) dcl 2532 in procedure "gamma" set ref 2536* 2538 2541 2544 2547* 2547 2548 2549 2552 2554* 2557 2560 2560* 2564 2565* 2565 2566 2568 2572 2575* y 000436 automatic float bin(63) dcl 2532 in procedure "gamma" set ref 2546* 2548* 2548 2552 2554 2564* 2568* 2568 2575 y 000450 automatic float bin(63) dcl 2591 in procedure "rgamma_int" set ref 2596* 2597 zero_or_one_value 0(12) 000217 automatic bit(1) level 3 in structure "free_type" packed unaligned dcl 124 in procedure "apl_monadic_" set ref 1371 1792 1799 1806 1813 1863 1879 1919 1926 zero_or_one_value 0(12) 000216 automatic bit(1) level 3 in structure "reduction_type" packed unaligned dcl 123 in procedure "apl_monadic_" set ref 2146 zero_or_one_value 0(12) based bit(1) level 5 in structure "value_bead" packed unaligned dcl 4-3 in procedure "apl_monadic_" set ref 261* 335 356 zero_or_one_value_type constant bit(18) initial unaligned dcl 3-30 ref 370 818 1399 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Binary internal static bit(1) initial dcl 1-16 MAX_VALUE_BEAD_SIZE internal static fixed bin(19,0) initial dcl 4-28 TheBiggestNumberWeveGot internal static float bin(63) initial dcl 1-16 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 1-16 assign_to_stop_code internal static fixed bin(8,0) initial dcl 6-8 assign_to_trace_code internal static fixed bin(8,0) initial dcl 6-8 assignment_code internal static fixed bin(8,0) initial dcl 6-8 branch_code internal static fixed bin(8,0) initial dcl 6-8 complex_datum based complex float bin(63) array dcl 4-26 complex_value_type internal static bit(18) initial unaligned dcl 3-30 divide_code internal static fixed bin(8,0) initial dcl 6-8 factorial_code internal static fixed bin(8,0) initial dcl 6-8 fnames_code internal static fixed bin(8,0) initial dcl 6-8 fnums_code internal static fixed bin(8,0) initial dcl 6-8 function_type internal static bit(18) initial unaligned dcl 3-30 grade_down_code internal static fixed bin(8,0) initial dcl 6-8 grade_up_code internal static fixed bin(8,0) initial dcl 6-8 greater_code internal static fixed bin(8,0) initial dcl 6-8 greater_equal_code internal static fixed bin(8,0) initial dcl 6-8 group_type internal static bit(18) initial unaligned dcl 3-30 iota_code internal static fixed bin(8,0) initial dcl 6-8 label_type internal static bit(18) initial unaligned dcl 3-30 laminate_code internal static fixed bin(8,0) initial dcl 6-8 leave_code internal static fixed bin(8,0) initial dcl 6-8 less_code internal static fixed bin(8,0) initial dcl 6-8 less_equal_code internal static fixed bin(8,0) initial dcl 6-8 lexed_function_type internal static bit(18) initial unaligned dcl 3-30 list_value_type internal static bit(18) initial unaligned dcl 3-30 log_code internal static fixed bin(8,0) initial dcl 6-8 max_code internal static fixed bin(8,0) initial dcl 6-8 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 5-98 minus_code internal static fixed bin(8,0) initial dcl 6-8 nand_code internal static fixed bin(8,0) initial dcl 6-8 nor_code internal static fixed bin(8,0) initial dcl 6-8 not_integer_mask internal static bit(18) initial unaligned dcl 3-30 operator_type internal static bit(18) initial unaligned dcl 3-30 output_buffer based char unaligned dcl 5-94 plus_code internal static fixed bin(8,0) initial dcl 6-8 power_code internal static fixed bin(8,0) initial dcl 6-8 quadcall_semicolon_code internal static fixed bin(8,0) initial dcl 6-8 ravel_code internal static fixed bin(8,0) initial dcl 6-8 residue_code internal static fixed bin(8,0) initial dcl 6-8 rho_code internal static fixed bin(8,0) initial dcl 6-8 semicolon_cons_code internal static fixed bin(8,0) initial dcl 6-8 shared_variable_type internal static bit(18) initial unaligned dcl 3-30 stop_code internal static fixed bin(8,0) initial dcl 6-8 subscripted_assignment_code internal static fixed bin(8,0) initial dcl 6-8 symbol_type internal static bit(18) initial unaligned dcl 3-30 take_code internal static fixed bin(8,0) initial dcl 6-8 times_code internal static fixed bin(8,0) initial dcl 6-8 trace_code internal static fixed bin(8,0) initial dcl 6-8 trig_code internal static fixed bin(8,0) initial dcl 6-8 value_type internal static bit(18) initial unaligned dcl 3-30 NAMES DECLARED BY EXPLICIT CONTEXT. aa 007721 constant label dcl 2547 ref 2549 apl_dyadic_ 001344 constant entry external dcl 396 apl_floor_ 010052 constant entry internal dcl 8-3 ref 310 2335 apl_inner_product_ 002325 constant entry external dcl 707 apl_monadic_ 000536 constant entry external dcl 50 apl_monadic_not_ 000550 constant entry external dcl 215 apl_outer_product_ 002143 constant entry external dcl 640 apl_push_stack_ 004024 constant entry internal dcl 7-4 ref 1316 apl_reduction_ 001563 constant entry external dcl 484 apl_scan_operator_ 003112 constant entry external dcl 975 case 000333 constant label array(0:7) dcl 2424 ref 2420 cc 007757 constant label dcl 2565 ref 2569 combinations_common 007536 constant label dcl 2455 ref 2438 2446 compatibility_error_left 003644 constant label dcl 1230 ref 2329 copy_left 001420 constant label dcl 424 ref 434 copy_up_stack 003550 constant label dcl 1191 ref 479 628 670 683 702 845 965 1183 display_disabled 003653 constant label dcl 1235 ref 382 do_many 006742 constant entry internal dcl 2227 ref 1708 1725 1744 1765 2137 domain_error 003675 constant label dcl 1254 ref 328 375 2156 2163 2350 2378 2386 2397 2430 2538 2557 2572 domain_error_left 003672 constant label dcl 1251 set ref 463 676 801 1242 1244 1733 1734 1782 1850 2356 2358 domain_error_left_maybe 003661 constant label dcl 1239 ref 1895 domain_error_right 003666 constant label dcl 1248 ref 247 465 589 678 803 1021 1239 1780 1785 1847 1854 2360 domain_error_right_maybe 003664 constant label dcl 1244 ref 1901 dyadic_do 000124 constant label array(-4:83) dcl 1552 set ref 1545 dyadic_do_bool_vector 005312 constant label dcl 1840 ref 1792 1799 1806 dyadic_do_eq_neq_vector 005660 constant label dcl 1932 ref 1919 dyadic_extract 004216 constant entry internal dcl 1434 ref 399 643 730 dyadic_operate 004406 constant entry internal dcl 1539 ref 477 699 948 dyadic_result_lowest 004334 constant entry internal dcl 1481 ref 400 795 fill_rho 004145 constant entry internal dcl 1409 ref 527 548 580 fill_type 004067 constant entry internal dcl 1334 ref 450 581 648 868 880 1027 gamma 007703 constant entry internal dcl 2523 ref 345 2474 2474 2474 get_next_element_45 005375 constant label dcl 1859 ref 1845 get_type 000077 constant label array(0:20) dcl 1341 ref 1337 identity_fill 001700 constant label dcl 528 ref 901 inner_product_compare_strings 002525 constant label dcl 816 ref 809 integer 007656 constant entry internal dcl 2480 ref 2408 2414 2417 2455 2455 invalid_circular_fcn_left 003703 constant label dcl 1258 ref 2259 2263 length_error 003712 constant label dcl 1263 ref 412 776 many_actions 000302 constant label array(12:21) dcl 2257 ref 2247 monadic_common 000561 constant label dcl 221 ref 207 monadic_do 000025 constant label array(0:20) dcl 255 ref 251 335 monadic_extract 004240 constant entry internal dcl 1448 ref 206 218 487 981 monadic_result_lowest 004365 constant entry internal dcl 1498 ref 511 983 next_scan 003541 constant label dcl 1180 ref 1077 1097 1108 1126 1137 1148 no_identity_error 003720 constant label dcl 1267 ref 532 rank_error 003726 constant label dcl 1271 ref 410 493 507 reduction_do 000254 constant label array(-1:20) dcl 2108 ref 2106 reduction_operate 006336 constant entry internal dcl 2079 ref 622 954 1173 return_right_scan 003153 constant label dcl 1002 ref 994 997 rgamma_int 010005 constant entry internal dcl 2582 ref 2554 2560 2575 scan_do 000052 constant label array(0:20) dcl 1068 ref 1066 stack_allocate_char 003753 constant entry internal dcl 1300 ref 231 543 1002 stack_allocate_known 003762 constant entry internal dcl 1307 ref 864 stack_allocate_known_common 003765 constant label dcl 1312 set ref 1298 1305 stack_allocate_numeric 003744 constant entry internal dcl 1287 ref 233 445 526 545 579 647 816 1005 1026 trig_array 000314 constant label array(-7:7) dcl 2269 ref 2266 zerodivide_error_right 003734 constant label dcl 1275 ref 282 1117 1628 1638 1650 1661 2117 2117 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 10616 10714 10227 10626 Length 11340 10227 76 410 367 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_monadic_ 500 external procedure is an external procedure. stack_allocate_numeric internal procedure shares stack frame of external procedure apl_monadic_. apl_push_stack_ internal procedure shares stack frame of external procedure apl_monadic_. fill_type internal procedure shares stack frame of external procedure apl_monadic_. fill_rho internal procedure shares stack frame of external procedure apl_monadic_. dyadic_extract internal procedure shares stack frame of external procedure apl_monadic_. dyadic_result_lowest internal procedure shares stack frame of external procedure apl_monadic_. monadic_result_lowest internal procedure shares stack frame of external procedure apl_monadic_. dyadic_operate internal procedure shares stack frame of external procedure apl_monadic_. reduction_operate internal procedure shares stack frame of external procedure apl_monadic_. do_many internal procedure shares stack frame of external procedure apl_monadic_. integer internal procedure shares stack frame of external procedure apl_monadic_. gamma internal procedure shares stack frame of external procedure apl_monadic_. rgamma_int internal procedure shares stack frame of external procedure apl_monadic_. apl_floor_ internal procedure shares stack frame of external procedure apl_monadic_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_monadic_ 000100 copy_up_needed apl_monadic_ 000101 left_chars apl_monadic_ 000102 right_chars apl_monadic_ 000103 swapped_flag apl_monadic_ 000104 copy_rho_vb apl_monadic_ 000106 right_vb apl_monadic_ 000110 right_array apl_monadic_ 000112 left_vb apl_monadic_ 000114 left_array apl_monadic_ 000116 result_vb apl_monadic_ 000120 result_array apl_monadic_ 000122 subscript apl_monadic_ 000123 right_data_elements apl_monadic_ 000124 left_data_elements apl_monadic_ 000125 plane_base apl_monadic_ 000126 column_base apl_monadic_ 000127 interval_between_elements apl_monadic_ 000130 column_skip_interval apl_monadic_ 000131 highest_column_element apl_monadic_ 000132 column_skip_interval_minus_1 apl_monadic_ 000133 rho_sub_dimension apl_monadic_ 000134 last_column_on_this_plane apl_monadic_ 000135 data_elements apl_monadic_ 000136 data_words_needed apl_monadic_ 000137 number_to_copy apl_monadic_ 000140 words_needed apl_monadic_ 000141 words_needed_in_bead apl_monadic_ 000142 left_rhorho apl_monadic_ 000143 dimension apl_monadic_ 000144 right_rhorho apl_monadic_ 000145 rhorho apl_monadic_ 000146 rho_subscript apl_monadic_ 000147 trig_integer apl_monadic_ 000150 dyadic_action_place apl_monadic_ 000151 many_action_place apl_monadic_ 000152 special_case apl_monadic_ 000153 action_place apl_monadic_ 000154 op1 apl_monadic_ 000156 single_element_fl_1 apl_monadic_ 000160 single_element_fl_2 apl_monadic_ 000162 fuzz apl_monadic_ 000164 integer_fuzz apl_monadic_ 000166 float_temp apl_monadic_ 000170 boolean_both apl_monadic_ 000172 set_on_equal apl_monadic_ 000174 dyadic_set_on_equal apl_monadic_ 000176 dyadic_set_on_not_equal apl_monadic_ 000200 dyadic_boolean_both apl_monadic_ 000202 dyadic_boolean_neither apl_monadic_ 000204 reduction_set_on_equal apl_monadic_ 000206 reduction_set_on_not_equal apl_monadic_ 000210 reduction_boolean_both apl_monadic_ 000212 reduction_boolean_neither apl_monadic_ 000214 result_accumulator apl_monadic_ 000216 reduction_type apl_monadic_ 000217 free_type apl_monadic_ 000220 save_free_type apl_monadic_ 000221 number_of_dimensions apl_monadic_ 000222 ws_info_ptr apl_monadic_ 000224 ip_subscript apl_monadic_ 000225 left_total_chars apl_monadic_ 000226 right_move_count apl_monadic_ 000227 right_count apl_monadic_ 000230 left_count apl_monadic_ 000231 op2 apl_monadic_ 000232 element_size apl_monadic_ 000234 actual_left_array apl_monadic_ 000236 actual_right_array apl_monadic_ 000240 actual_result_array apl_monadic_ 000242 temp_right_array apl_monadic_ 000244 recover_right_array apl_monadic_ 000246 recover_single_element apl_monadic_ 000250 actual_highest_column_element apl_monadic_ 000251 flip_flag apl_monadic_ 000266 numeric stack_allocate_numeric 000276 block_ptr apl_push_stack_ 000300 num_words apl_push_stack_ 000324 dyadic dyadic_extract 000350 subscript dyadic_operate 000360 subscript reduction_operate 000361 save_special_case reduction_operate 000362 save_many_action_place reduction_operate 000372 b do_many 000374 c do_many 000376 d do_many 000400 left_arg do_many 000402 right_arg do_many 000404 sign_result do_many 000406 casex do_many 000410 resultc do_many 000422 trial_val integer 000432 result gamma 000434 x gamma 000436 y gamma 000446 x rgamma_int 000450 y rgamma_int 000460 value apl_floor_ 000462 result apl_floor_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_l_a r_e_as call_ext_out return fl2_to_fx1 sign mod_fl2 ext_entry ceil_fl floor_fl any_to_any_rd dsqrt dsin dcos dtan dasin dacos datan dlog dexp dbl_p_dbl dbl_p_int THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_display_bead_ apl_dyadic_bool_appendage_$and apl_dyadic_bool_appendage_$eq apl_dyadic_bool_appendage_$nand apl_dyadic_bool_appendage_$neq apl_dyadic_bool_appendage_$nor apl_dyadic_bool_appendage_$or apl_get_value_stack_ apl_monadic_not_appendage_ apl_monadic_not_appendage_$in_place apl_reduction_appendage_ apl_reduction_appendage_$divide complex_binary_op_ dcxp2_ dlog_$datanh_ dsinh_ dsinh_$dcosh_ dtanh_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. 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 apl_static_$ws_info_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 5 7 000526 50 000533 206 000544 207 000545 215 000546 218 000556 219 000557 221 000561 223 000563 225 000565 226 000572 228 000575 229 000577 231 000600 233 000604 235 000605 238 000615 241 000620 247 000627 251 000636 255 000640 257 000645 259 000654 261 000655 264 000657 265 000700 267 000701 270 000703 271 000707 273 000722 275 000730 276 000732 277 000734 279 000735 281 000740 282 000745 284 000751 285 000755 286 000757 293 000760 295 000763 296 000767 297 000773 299 000776 302 001006 303 001011 304 001013 306 001014 308 001017 309 001023 310 001026 311 001030 312 001035 313 001037 316 001040 318 001043 320 001047 322 001056 323 001060 325 001061 327 001064 328 001071 330 001076 332 001102 333 001104 335 001105 339 001110 341 001131 343 001132 345 001137 347 001154 348 001156 350 001157 352 001162 354 001204 356 001205 358 001210 360 001227 367 001244 370 001245 372 001250 373 001255 375 001270 379 001301 380 001303 382 001304 387 001310 389 001325 392 001341 396 001342 399 001352 400 001353 406 001354 407 001357 409 001360 410 001363 411 001366 412 001373 414 001401 415 001403 416 001405 418 001406 419 001412 421 001414 422 001416 424 001420 426 001422 427 001424 429 001425 430 001427 431 001431 432 001433 433 001437 434 001443 436 001446 438 001447 439 001451 441 001455 442 001457 445 001461 447 001462 450 001472 452 001473 454 001475 455 001477 457 001502 458 001504 460 001507 462 001513 463 001517 465 001521 467 001522 469 001525 470 001546 472 001547 474 001551 475 001552 477 001555 479 001556 482 001560 484 001561 487 001571 491 001572 493 001574 496 001577 498 001604 499 001606 502 001607 503 001610 504 001612 506 001613 507 001615 508 001620 511 001623 512 001624 516 001627 517 001631 518 001633 519 001635 520 001647 521 001654 522 001672 523 001673 526 001676 527 001677 528 001700 531 001705 532 001707 534 001711 535 001734 541 001735 542 001740 543 001742 545 001746 548 001747 552 001750 553 001753 554 001755 557 001764 563 001765 567 001770 570 001772 571 001777 573 002004 575 002006 576 002011 579 002014 580 002015 581 002016 587 002017 589 002021 591 002025 592 002030 594 002052 599 002053 600 002055 601 002057 602 002060 605 002062 606 002064 608 002067 609 002071 613 002074 614 002075 615 002101 616 002103 618 002111 619 002113 622 002122 624 002123 625 002130 626 002131 627 002133 628 002136 631 002140 640 002141 643 002151 644 002152 645 002155 647 002160 648 002161 649 002162 650 002164 652 002167 653 002171 655 002174 660 002200 661 002202 665 002211 666 002213 670 002224 673 002226 675 002232 676 002236 678 002240 680 002241 682 002244 683 002264 685 002265 687 002267 688 002271 690 002272 691 002274 694 002277 695 002301 697 002305 699 002312 700 002313 701 002317 702 002322 707 002323 730 002333 732 002334 734 002336 737 002341 738 002347 740 002354 741 002355 743 002357 745 002361 746 002367 748 002374 749 002375 750 002377 757 002402 759 002412 762 002413 764 002420 769 002423 770 002425 771 002426 772 002430 774 002432 776 002435 779 002437 780 002441 781 002442 783 002444 786 002445 787 002447 788 002451 789 002453 790 002455 793 002457 794 002461 795 002463 796 002464 798 002465 800 002471 801 002475 803 002477 805 002500 807 002504 808 002506 809 002510 812 002521 813 002522 816 002525 818 002526 819 002531 821 002535 822 002540 823 002541 826 002545 829 002562 832 002567 833 002570 836 002573 838 002602 841 002612 842 002615 845 002626 851 002627 853 002633 855 002634 857 002640 858 002643 860 002645 864 002651 868 002652 869 002653 870 002655 872 002660 873 002662 875 002665 876 002670 879 002674 880 002676 881 002677 882 002702 883 002704 885 002707 886 002711 890 002714 892 002723 896 002733 897 002736 901 002747 907 002751 908 002753 911 002757 912 002761 913 002764 914 002766 916 002770 917 002773 918 002776 919 003001 920 003004 924 003007 925 003013 926 003015 929 003021 934 003030 935 003032 937 003035 939 003037 941 003043 943 003046 945 003051 948 003057 950 003060 951 003062 954 003066 956 003067 958 003074 959 003076 960 003101 963 003103 965 003107 975 003110 981 003120 983 003121 985 003126 987 003133 991 003136 992 003140 994 003142 997 003143 1000 003145 1001 003151 1002 003153 1005 003157 1007 003160 1010 003170 1011 003172 1017 003201 1018 003204 1021 003205 1026 003207 1027 003210 1029 003211 1030 003213 1032 003216 1033 003220 1035 003223 1040 003233 1043 003235 1044 003243 1046 003250 1048 003252 1049 003255 1053 003257 1056 003263 1058 003265 1060 003273 1062 003275 1066 003303 1068 003305 1072 003313 1076 003321 1077 003324 1079 003325 1081 003326 1084 003335 1090 003346 1095 003354 1096 003357 1097 003362 1099 003363 1103 003371 1107 003377 1108 003402 1110 003403 1112 003404 1115 003413 1117 003422 1122 003433 1123 003435 1124 003442 1125 003445 1126 003450 1128 003451 1132 003457 1136 003467 1137 003472 1139 003473 1143 003501 1147 003511 1148 003514 1152 003515 1170 003523 1173 003527 1175 003530 1178 003536 1180 003541 1182 003543 1183 003546 1191 003550 1193 003555 1194 003560 1195 003562 1197 003563 1199 003565 1200 003573 1201 003575 1212 003576 1213 003600 1215 003606 1216 003612 1218 003620 1219 003621 1220 003623 1223 003631 1224 003634 1225 003640 1226 003643 1230 003644 1232 003651 1233 003652 1235 003653 1237 003660 1239 003661 1242 003663 1244 003664 1248 003666 1251 003672 1254 003675 1256 003702 1258 003703 1260 003706 1261 003711 1263 003712 1265 003717 1267 003720 1269 003725 1271 003726 1273 003733 1275 003734 1277 003740 1278 003743 1287 003744 1296 003745 1297 003750 1298 003752 1300 003753 1303 003754 1304 003760 1305 003761 1307 003762 1310 003763 1312 003765 1314 003767 1315 003771 1316 003774 1317 003776 1318 004002 1322 004012 1323 004015 1324 004017 1325 004020 1327 004023 7 4 004024 7 35 004026 7 37 004030 7 40 004035 7 43 004052 7 44 004055 7 45 004064 1334 004067 1337 004070 1341 004072 1345 004100 1350 004103 1354 004104 1357 004107 1361 004110 1365 004115 1371 004116 1375 004125 1377 004130 1384 004131 1392 004135 1399 004141 1400 004144 1409 004145 1412 004146 1413 004151 1414 004153 1416 004161 1419 004162 1420 004165 1424 004174 1425 004176 1428 004211 1437 004213 1434 004216 1441 004220 1442 004222 1443 004225 1444 004227 1445 004231 1446 004233 1448 004237 1451 004242 1452 004246 1453 004250 1454 004253 1455 004255 1457 004261 1459 004263 1460 004272 1463 004303 1464 004304 1466 004307 1468 004314 1469 004316 1470 004322 1472 004324 1473 004327 1474 004331 1475 004332 1477 004333 1481 004334 1484 004335 1487 004344 1488 004345 1490 004356 1494 004364 1498 004365 1501 004366 1503 004376 1504 004401 1505 004402 1506 004403 1508 004405 1539 004406 1545 004407 1552 004411 1556 004414 1558 004415 1560 004421 1563 004426 1564 004430 1566 004431 1569 004435 1572 004442 1573 004444 1575 004445 1579 004450 1581 004451 1583 004455 1586 004462 1587 004464 1589 004465 1591 004471 1594 004476 1595 004500 1597 004501 1599 004505 1602 004512 1603 004514 1605 004515 1609 004520 1611 004521 1613 004525 1616 004532 1617 004534 1619 004535 1622 004541 1625 004546 1626 004550 1628 004551 1633 004560 1634 004562 1636 004563 1638 004567 1642 004601 1645 004604 1646 004606 1648 004607 1650 004613 1654 004625 1656 004630 1657 004632 1659 004633 1661 004637 1665 004651 1667 004657 1668 004661 1670 004662 1672 004667 1674 004670 1676 004675 1678 004704 1679 004706 1681 004707 1684 004713 1686 004722 1687 004724 1689 004725 1691 004732 1693 004733 1695 004737 1697 004746 1698 004750 1700 004751 1703 004755 1705 004764 1706 004766 1708 004767 1714 004770 1715 004772 1717 004773 1723 004777 1724 005003 1725 005005 1726 005006 1728 005013 1729 005015 1731 005016 1733 005022 1734 005027 1735 005036 1736 005041 1738 005043 1743 005047 1744 005052 1745 005053 1747 005060 1748 005062 1750 005063 1752 005067 1754 005103 1755 005106 1758 005110 1763 005112 1764 005117 1765 005122 1766 005123 1768 005130 1769 005132 1771 005133 1776 005141 1777 005147 1778 005151 1780 005152 1781 005160 1782 005161 1785 005167 1789 005203 1790 005205 1792 005206 1794 005211 1795 005226 1799 005227 1801 005232 1802 005247 1806 005250 1808 005253 1809 005270 1813 005271 1815 005274 1816 005311 1840 005312 1842 005317 1843 005327 1844 005336 1845 005340 1847 005341 1849 005347 1850 005350 1854 005357 1858 005373 1859 005375 1861 005377 1863 005400 1868 005403 1869 005406 1871 005426 1874 005427 1875 005450 1878 005451 1879 005454 1884 005457 1885 005462 1886 005502 1889 005503 1892 005516 1895 005517 1898 005533 1899 005537 1901 005553 1904 005564 1905 005566 1907 005567 1911 005575 1915 005613 1917 005615 1919 005616 1921 005621 1922 005636 1926 005637 1928 005642 1929 005657 1932 005660 1934 005665 1937 005676 1941 005714 1943 005716 1944 005720 1946 005721 1951 005725 1953 005736 1958 005754 1960 005756 1961 005760 1963 005761 1968 005767 1971 006005 1973 006007 1975 006010 1978 006015 1981 006026 1984 006044 1986 006046 1987 006050 1989 006051 1994 006055 1997 006066 2000 006104 2002 006106 2003 006110 2005 006111 2010 006117 2013 006135 2015 006137 2017 006140 2020 006145 2023 006156 2026 006174 2028 006176 2029 006200 2031 006201 2036 006205 2039 006216 2042 006234 2044 006236 2045 006240 2047 006241 2051 006253 2053 006255 2055 006256 2057 006264 2060 006277 2062 006303 2063 006306 2065 006307 2068 006314 2071 006326 2073 006332 2074 006335 2079 006336 2106 006337 2108 006341 2115 006365 2117 006366 2120 006417 2122 006420 2128 006422 2129 006424 2130 006427 2131 006430 2134 006435 2135 006437 2137 006443 2138 006444 2139 006447 2140 006451 2141 006453 2143 006454 2146 006457 2150 006462 2153 006506 2156 006507 2159 006523 2162 006531 2163 006541 2166 006550 2168 006552 2169 006555 2171 006556 2176 006563 2178 006573 2181 006612 2183 006614 2184 006617 2186 006620 2191 006625 2193 006635 2196 006654 2198 006656 2199 006661 2201 006662 2206 006667 2208 006677 2211 006716 2213 006720 2214 006723 2216 006724 2220 006737 2222 006741 2227 006742 2247 006743 2257 006746 2259 006752 2262 006766 2263 006771 2266 006776 2269 007000 2271 007011 2273 007012 2275 007032 2277 007033 2279 007053 2281 007054 2283 007062 2285 007063 2287 007067 2289 007070 2291 007074 2293 007075 2295 007101 2297 007102 2299 007111 2301 007112 2303 007116 2305 007117 2307 007123 2309 007124 2311 007130 2313 007131 2315 007137 2317 007140 2319 007151 2321 007152 2323 007163 2325 007164 2327 007175 2329 007176 2333 007200 2335 007205 2337 007217 2339 007220 2340 007222 2342 007223 2345 007225 2346 007230 2347 007232 2350 007233 2352 007236 2353 007240 2356 007241 2358 007244 2360 007246 2363 007250 2364 007261 2366 007262 2368 007266 2374 007302 2376 007311 2378 007312 2381 007314 2382 007316 2384 007317 2385 007371 2386 007373 2389 007377 2392 007400 2394 007403 2397 007405 2399 007407 2401 007413 2402 007415 2405 007416 2406 007422 2408 007423 2412 007433 2414 007434 2417 007443 2420 007454 2424 007456 2428 007460 2430 007461 2434 007462 2436 007464 2437 007466 2438 007470 2440 007471 2442 007473 2443 007500 2445 007507 2446 007511 2448 007512 2450 007517 2451 007524 2453 007534 2455 007536 2458 007560 2460 007570 2462 007572 2463 007575 2464 007600 2466 007602 2467 007607 2468 007613 2469 007616 2470 007622 2471 007625 2474 007626 2476 007655 2480 007656 2494 007660 2496 007664 2498 007701 2523 007703 2536 007705 2538 007707 2541 007710 2544 007716 2546 007717 2547 007721 2548 007724 2549 007726 2552 007731 2554 007735 2555 007742 2557 007743 2560 007746 2564 007755 2565 007757 2566 007762 2568 007765 2569 007770 2572 007771 2575 007772 2577 010002 2582 010005 2595 010007 2596 010011 2597 010013 8 3 010052 8 36 010054 8 37 010056 8 39 010061 8 42 010071 ----------------------------------------------------------- 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