COMPILATION LISTING OF SEGMENT apl_encode_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1604.5 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 apl_encode_: proc(operators_argument); 11 12 /* 13* * this procedure implements the APL T operator 14* * 15* * written 1 August 1973 by DAM 16* * Fixed 740827 by PG to set value_stack_ptr to protect result! 17* Modified 770413 by PG to fix bug 208 (infinite loop when given null vectors). 18* Modified 770414 by PG to fix bug 280 (was walking thru rows on left instead of columns). 19* */ 20 21 /* automatic */ 22 23 dcl left_vb pointer, /* the usual pointer variables */ 24 left pointer, 25 right_vb pointer, 26 right pointer, 27 result_vb pointer, 28 result pointer, 29 final_result_vb pointer, 30 final_result pointer, 31 32 left_data_elements fixed bin (21), /* elements in left opnd */ 33 right_data_elements fixed bin (21), /* elements in right opnd */ 34 data_elements fixed bin (21), /* number of elements in the result */ 35 rhorho fixed bin, /* number of dimensions of the result */ 36 n_words fixed bin (19), /* number of words in the result value bead */ 37 i fixed bin, /* do-loop var. */ 38 j fixed bin, /* .. */ 39 40 plane_base fixed bin (21), /* offset of current plane in left opnd */ 41 last_column_on_this_plane fixed bin (21), 42 column_base fixed bin (21), /* offset of first element in current column */ 43 col_pos fixed bin (21), /* position in current column */ 44 right_pos fixed bin(21), /* position of current number to be encoded, in right operand */ 45 interval_between_columns fixed bin (21), 46 interval_between_columns_minus_1 fixed bin (21), 47 highest_column_element fixed bin (21), 48 rho_subscript fixed bin (21), 49 interval_between_elements fixed bin (21), 50 column_length fixed bin (21), 51 52 accum float, /* portion of number not yet encoded (quotient after each step) */ 53 divisor float, /* copy of number from left operand */ 54 quotient float, /* quotient result of APL div-mod operation */ 55 residue float; /* remainder result of .. .. .. */ 56 57 /* builtins */ 58 59 dcl (abs, addr, addrel, rel, max, substr, string, size) builtin; 60 61 /* external static */ 62 63 dcl (apl_error_table_$domain, 64 apl_error_table_$compatibility_error) fixed bin(35) external; 65 66 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 ---------------------------------- */ 67 2 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 2 2 2 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 2 4 2 5 /* automatic */ 2 6 2 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 2 8 2 9 /* external static */ 2 10 2 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 2 12 2 static_ws_info_ptr unaligned pointer; 2 13 2 14 /* based */ 2 15 2 16 declare 1 ws_info aligned based (ws_info_ptr), 2 17 2 version_number fixed bin, /* version of this structure (3) */ 2 18 2 switches unaligned, /* mainly ws parameters */ 2 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 2 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 2 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 2 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 2 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 2 24 3 restrict_external_functions 2 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 2 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 2 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 2 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 2 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 2 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 2 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 2 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 2 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 2 34 3 compatibility_check_mode 2 35 bit, /* if 1, check for incompatible operators */ 2 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 2 37 /* remaining 20 bits not presently used */ 2 38 2 39 2 values, /* attributes of the workspace */ 2 40 3 digits fixed bin, /* number of digits of precision printed on output */ 2 41 3 width fixed bin, /* line length for formatted output */ 2 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 2 43 3 random_link fixed bin(35), /* seed for random number generator */ 2 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 2 45 3 float_index_origin float, /* the index origin in floating point */ 2 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 2 47 3 maximum_value_stack_size 2 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 2 49 2 50 2 pointers, /* pointers to various internal tables */ 2 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 2 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 2 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 2 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 2 55 2 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 2 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 2 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 2 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 2 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 2 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 2 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 2 63 2 signoff_lock character (32), 2 64 2 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 2 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 2 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 2 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 2 69 bit, /* munging his tables */ 2 70 3 unused_interrupt_bit bit, /* not presently used */ 2 71 3 dont_interrupt_command bit, 2 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 2 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 2 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 2 75 2 76 2 user_name char (32), /* process group id of user */ 2 77 2 immediate_input_prompt char (32) varying, /* normal input */ 2 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 2 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 2 80 2 vcpu_time aligned, 2 81 3 total fixed bin (71), 2 82 3 setup fixed bin (71), 2 83 3 parse fixed bin (71), 2 84 3 lex fixed bin (71), 2 85 3 operator fixed bin (71), 2 86 3 storage_manager fixed bin (71), 2 87 2 output_info aligned, /* data pertaining to output buffer */ 2 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 2 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 2 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 2 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 2 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 2 93 2 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 2 95 2 96 /* internal static */ 2 97 2 98 declare max_parse_stack_depth fixed bin int static init(64536); 2 99 2 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 68 3 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 3 2 3 3 declare 1 operators_argument aligned, 3 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 3 5* if operand (1).value is null, operator is monadic */ 3 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 3 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 3 8 2 operator aligned, /* information about the operator to be executed */ 3 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 3 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 3 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 3 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 3 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 3 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 3 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 3 16 3 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 69 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_operator_bead.incl.pl1 ================================ */ 4 2 4 3 declare 4 4 1 operator_bead aligned based, 4 5 4 6 2 type unaligned like general_bead.type, 4 7 4 8 2 bits_for_lex unaligned, 4 9 3 allow_brackets bit(1), /* operator may have dimension info in brackets */ 4 10 3 allow_product bit(1), /* operator may be used in inner and outer product */ 4 11 3 allow_reduction bit(1), /* operator may be used in reduction and scan */ 4 12 3 special_assignment bit(1), /* doesn't use standard assignment operator */ 4 13 3 ignores_assignment bit(1), /* assignment has no effect */ 4 14 3 allow_subscripted_assignment 4 15 bit(1), /* system variable that can be subscripted assigned */ 4 16 3 pad bit(12), 4 17 4 18 2 bits_for_parse unaligned, 4 19 3 stop_trace_control bit(1), /* next lexeme is function being stopped/traced 4 20* (op1 tells which) */ 4 21 3 quad bit(1), /* this is a quad type */ 4 22 3 system_variable bit(1), /* this is a system variable, not an op */ 4 23 3 dyadic bit(1), /* operator may be dyadic */ 4 24 3 monadic bit(1), /* operator may be monadic */ 4 25 3 function bit(1), /* operator is a user defined function */ 4 26 3 semantics_valid bit(1), /* if semantics has been set */ 4 27 3 has_list bit(1), /* semantics is a list */ 4 28 3 inner_product bit(1), /* op2 is valid */ 4 29 3 semantics_on_stack bit(1), /* semantics points to value stack */ 4 30 3 is_external_function bit(1), /* semantics points to function bead for ext function */ 4 31 3 pad bit(7), 4 32 3 op2 fixed bin(8) unaligned, /* secondary operator code */ 4 33 3 op1 fixed bin(8) unaligned, /* primary operator code */ 4 34 2 type_code fixed bin; /* for parse */ 4 35 4 36 /* ------ END INCLUDE SEGMENT apl_operator_bead.incl.pl1 -------------------------------- */ 70 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 5 2 5 3 declare 5 4 number_of_dimensions fixed bin, 5 5 5 6 1 value_bead aligned based, 5 7 2 header aligned like general_bead, 5 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 5 9 2 rhorho fixed binary, /* number of dimensions of value */ 5 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 5 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 5 12 /* dimensions of value (zero-origin) */ 5 13 5 14 5 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 5 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 5 17 /* actual elements of character array */ 5 18 5 19 declare character_string_overlay character (data_elements) aligned based; 5 20 /* to overlay on above structure */ 5 21 5 22 5 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 5 24 /* actual elements of numeric array */ 5 25 5 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 5 27 5 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 5 29 5 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 71 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 6 2 6 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 6 4 2 type unaligned, 6 5 3 bead_type unaligned, 6 6 4 operator bit (1), /* ON if operator bead */ 6 7 4 symbol bit (1), /* ON if symbol bead */ 6 8 4 value bit (1), /* ON if value bead */ 6 9 4 function bit (1), /* ON if function bead */ 6 10 4 group bit (1), /* ON if group bead */ 6 11 4 label bit (1), /* ON if label bead */ 6 12 4 shared_variable bit (1), /* ON if shared variable bead */ 6 13 4 lexed_function bit (1), /* ON if lexed function bead */ 6 14 3 data_type unaligned, 6 15 4 list_value bit (1), /* ON if a list value bead */ 6 16 4 character_value bit (1), /* ON if a character value bead */ 6 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 6 18 4 integral_value bit (1), /* ON if an integral value bead */ 6 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 6 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 6 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 6 22 2 size bit (18) unaligned, /* Number of words this bead occupies 6 23* (used by bead storage manager) */ 6 24 2 reference_count fixed binary (29); /* Number of pointers which point 6 25* to this bead (used by bead manager) */ 6 26 6 27 6 28 /* constant strings for initing type field in various beads */ 6 29 6 30 declare ( 6 31 operator_type init("100000000000000000"b), 6 32 symbol_type init("010000000000000000"b), 6 33 value_type init("001000000000000000"b), 6 34 function_type init("000100000000000000"b), 6 35 group_type init("000010000000000000"b), 6 36 label_type init("001001000011000000"b), 6 37 shared_variable_type init("001000100000000000"b), 6 38 lexed_function_type init("000000010000000000"b), 6 39 6 40 list_value_type init("000000001000000000"b), 6 41 character_value_type init("001000000100000000"b), 6 42 numeric_value_type init("001000000010000000"b), 6 43 integral_value_type init("001000000011000000"b), 6 44 zero_or_one_value_type init("001000000011100000"b), 6 45 complex_value_type init("001000000000010000"b), 6 46 6 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 6 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 6 49 ) bit(18) internal static; 6 50 6 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 72 73 74 /* pick up arguments, make sure they are numbers */ 75 76 left_vb = operands(1).value; 77 left_data_elements = left_vb -> value_bead.total_data_elements; 78 left = left_vb -> value_bead.data_pointer; 79 80 if (left_data_elements ^= 0) & ^left_vb -> value_bead.numeric_value 81 then go to domain_error_left; 82 83 right_vb = operands(2).value; 84 right_data_elements = right_vb -> value_bead.total_data_elements; 85 right = right_vb -> value_bead.data_pointer; 86 87 if (right_data_elements ^= 0) & ^right_vb -> value_bead.numeric_value 88 then go to domain_error_right; 89 90 /* determine length of columns of radices (and of result digits) */ 91 92 if left_vb -> value_bead.rhorho = 0 /* a scalar */ 93 then column_length = 1; 94 else column_length = max (1, left_vb -> value_bead.rho (1)); 95 96 /* compute size of result (product of sizes of operands) and allocate it */ 97 98 data_elements = left_vb -> value_bead.total_data_elements * right_vb -> value_bead.total_data_elements; 99 number_of_dimensions, rhorho = left_vb -> value_bead.rhorho + right_vb -> value_bead.rhorho; 100 n_words = size (value_bead) + size (numeric_datum) + 1; 101 result_vb = apl_push_stack_ (n_words); 102 103 string(result_vb -> value_bead.type) = integral_value_type; /* will be changed to numeric if necessary */ 104 result_vb -> value_bead.total_data_elements = data_elements; 105 result_vb -> value_bead.rhorho = rhorho; 106 result = addrel (result_vb, size (value_bead)); 107 if substr (rel (result), 18, 1) 108 then result = addrel (result, 1); 109 110 result_vb -> value_bead.data_pointer = result; 111 112 /* rho of result is concatenation of rhos of operands */ 113 114 do i = 1 by 1 while (i <= left_vb -> value_bead.rhorho); 115 result_vb -> value_bead.rho(i) = left_vb -> value_bead.rho(i); 116 end; 117 do j = i by 1 while (j <= rhorho); 118 result_vb -> value_bead.rho(j) = right_vb -> value_bead.rho(j-i+1); 119 end; 120 121 interval_between_elements = 1; 122 do rho_subscript = 2 to left_vb -> value_bead.rhorho; 123 interval_between_elements = interval_between_elements * left_vb -> value_bead.rho (rho_subscript); 124 end; 125 126 interval_between_columns = interval_between_elements * column_length; 127 interval_between_columns_minus_1 = interval_between_columns - interval_between_elements; 128 129 /* walk through columns of left arg, elements of right arg, and elements of left column */ 130 131 do plane_base = 0 repeat (plane_base + interval_between_columns) while (plane_base < left_data_elements); 132 last_column_on_this_plane = plane_base + interval_between_elements; 133 do column_base = plane_base by 1 while (column_base < last_column_on_this_plane); 134 highest_column_element = column_base + interval_between_columns_minus_1; 135 do right_pos = 0 by 1 while (right_pos < right_data_elements); 136 accum = right -> numeric_datum (right_pos); 137 do col_pos = highest_column_element repeat (col_pos - interval_between_elements) 138 while (col_pos >= column_base); 139 140 divisor = left -> numeric_datum (col_pos); 141 if divisor <= ws_info.fuzz /* if divisor is fuzz-less-or-equal to zero */ 142 then if ws_info.compatibility_check_mode 143 then go to compatibility_error_left; /* old APL acted differently with neg or zero left */ 144 145 if abs (divisor) > ws_info.fuzz /* if divisor is not fuzz-equal to zero */ 146 then do; 147 quotient = apl_floor_ (accum / divisor); 148 residue = accum - divisor*quotient; 149 end; 150 else do; /* renege on integer type */ 151 string (result_vb -> value_bead.type) = string (right_vb -> value_bead.type); 152 residue = accum; 153 quotient = 0; 154 end; 155 156 result -> numeric_datum (col_pos * right_data_elements + right_pos) = residue; 157 accum = quotient; 158 end; 159 end; 160 end; 161 end; 162 163 /* now put result in proper place */ 164 165 if operators_argument.operands (2).on_stack 166 then ws_info.value_stack_ptr = right_vb; 167 else if operators_argument.operands (1).on_stack 168 then ws_info.value_stack_ptr = left_vb; 169 else do; 170 operators_argument.result = result_vb; 171 return; 172 end; 173 174 final_result_vb = apl_push_stack_ (n_words); 175 string(final_result_vb -> value_bead.type) = string(result_vb -> value_bead.type); 176 final_result_vb -> value_bead.rhorho = result_vb -> value_bead.rhorho; 177 final_result_vb -> value_bead.total_data_elements = data_elements; 178 do i = 1 to rhorho; /* use do loop because for bad code for assigning value_bead.rho(*) */ 179 final_result_vb -> value_bead.rho(i) = result_vb -> value_bead.rho(i); 180 end; 181 182 final_result = addr(final_result_vb -> value_bead.rho(rhorho+1)); 183 if substr(rel(final_result), 18, 1) then final_result = addrel(final_result, 1); 184 final_result_vb -> data_pointer = final_result; 185 186 final_result -> numeric_datum (*) = result -> numeric_datum (*); 187 operators_argument.result = final_result_vb; 188 return; 189 190 compatibility_error_left: /* if ws_info .compatibility_check_mode was on and a element 191* of left arg was neg or zero */ 192 operators_argument.where_error = operators_argument.where_error + 1; 193 operators_argument.error_code = apl_error_table_$compatibility_error; 194 return; 195 196 domain_error_left: 197 operators_argument.where_error = operators_argument.where_error + 1; 198 go to domain_error; 199 200 domain_error_right: 201 operators_argument.where_error = operators_argument.where_error - 1; 202 203 domain_error: 204 operators_argument.error_code = apl_error_table_$domain; 205 return; 206 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 ------------------------------- */ 207 208 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 ---------------------------------- */ 209 210 end /* apl_encode_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1346.3 apl_encode_.pl1 >special_ldd>on>apl.1129>apl_encode_.pl1 67 1 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 68 2 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 69 3 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 70 4 03/27/82 0439.0 apl_operator_bead.incl.pl1 >ldd>include>apl_operator_bead.incl.pl1 71 5 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 72 6 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 207 7 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_fcn.incl.pl1 209 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. P_n_words parameter fixed bin(19,0) dcl 7-16 ref 7-4 7-35 abs builtin function dcl 59 in procedure "apl_encode_" ref 145 abs builtin function dcl 8-27 in procedure "apl_floor_" ref 8-39 accum 000142 automatic float bin(63) dcl 23 set ref 136* 147 148 152 157* addr builtin function dcl 59 ref 182 addrel builtin function dcl 59 in procedure "apl_encode_" ref 106 107 183 addrel builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-44 apl_error_table_$compatibility_error 000012 external static fixed bin(35,0) dcl 63 ref 193 apl_error_table_$domain 000010 external static fixed bin(35,0) dcl 63 ref 203 apl_get_value_stack_ 000016 constant entry external dcl 7-30 ref 7-40 apl_static_$ws_info_ptr 000014 external static structure level 1 dcl 2-11 binary builtin function dcl 7-25 ref 7-40 block_ptr 000166 automatic pointer dcl 7-20 set ref 7-43* 7-45 bv_value parameter float bin(63) dcl 8-19 ref 8-3 8-36 col_pos 000132 automatic fixed bin(21,0) dcl 23 set ref 137* 137* 140 156* 158 column_base 000131 automatic fixed bin(21,0) dcl 23 set ref 133* 133* 134 137* column_length 000141 automatic fixed bin(21,0) dcl 23 set ref 92* 94* 126 compatibility_check_mode 1(14) based bit(1) level 3 packed unaligned dcl 2-16 ref 141 data_elements 000122 automatic fixed bin(21,0) dcl 23 set ref 98* 100 104 177 186 data_pointer 4 based pointer level 2 packed unaligned dcl 5-3 set ref 78 85 110* 184* data_type 0(08) based structure level 4 packed unaligned dcl 5-3 divisor 000144 automatic float bin(63) dcl 23 set ref 140* 141 145 147 148 error_code 7 parameter fixed bin(35,0) level 2 dcl 3-3 set ref 193* 203* final_result 000116 automatic pointer dcl 23 set ref 182* 183 183* 183 184 186 final_result_vb 000114 automatic pointer dcl 23 set ref 174* 175 176 177 179 182 184 187 floor builtin function dcl 8-27 ref 8-37 8-39 fuzz 6 based float bin(63) level 3 dcl 2-16 ref 141 145 general_bead based structure level 1 dcl 6-3 header based structure level 2 dcl 5-3 highest_column_element 000136 automatic fixed bin(21,0) dcl 23 set ref 134* 137 i 000125 automatic fixed bin(17,0) dcl 23 set ref 114* 114* 115 115* 117 118 178* 179 179* integer_fuzz 22 based float bin(63) level 2 dcl 2-16 ref 8-39 integral_value_type constant bit(18) initial unaligned dcl 6-30 ref 103 interval_between_columns 000134 automatic fixed bin(21,0) dcl 23 set ref 126* 127 161 interval_between_columns_minus_1 000135 automatic fixed bin(21,0) dcl 23 set ref 127* 134 interval_between_elements 000140 automatic fixed bin(21,0) dcl 23 set ref 121* 123* 123 126 127 132 158 j 000126 automatic fixed bin(17,0) dcl 23 set ref 117* 117* 118 118* last_column_on_this_plane 000130 automatic fixed bin(21,0) dcl 23 set ref 132* 133 left 000102 automatic pointer dcl 23 set ref 78* 140 left_data_elements 000120 automatic fixed bin(21,0) dcl 23 set ref 77* 80 131 left_vb 000100 automatic pointer dcl 23 set ref 76* 77 78 80 92 94 98 99 114 115 122 123 167 max builtin function dcl 59 ref 94 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 2-16 ref 7-40 n_words 000124 automatic fixed bin(19,0) dcl 23 set ref 100* 101* 174* num_words 000170 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 000154 automatic fixed bin(17,0) dcl 5-3 set ref 99* 100 106 numeric_datum based float bin(63) array dcl 5-23 set ref 100 136 140 156* 186* 186 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 5-3 set ref 80 87 on_stack 1 parameter bit(1) array level 3 dcl 3-3 ref 165 167 operands parameter structure array level 2 dcl 3-3 operators_argument parameter structure level 1 dcl 3-3 set ref 10 plane_base 000127 automatic fixed bin(21,0) dcl 23 set ref 131* 131* 132 133* 161 pointers 14 based structure level 2 dcl 2-16 quotient 000146 automatic float bin(63) dcl 23 set ref 147* 148 153* 157 rel builtin function dcl 59 in procedure "apl_encode_" ref 107 183 rel builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-40 residue 000150 automatic float bin(63) dcl 23 set ref 148* 152* 156 result 000202 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 3-3 in procedure "apl_encode_" set ref 170* 187* result 000112 automatic pointer dcl 23 in procedure "apl_encode_" set ref 106* 107 107* 107 110 156 186 result_vb 000110 automatic pointer dcl 23 set ref 101* 103 104 105 106 110 115 118 151 170 175 176 179 rho 5 based fixed bin(21,0) array level 2 dcl 5-3 set ref 94 115* 115 118* 118 123 179* 179 182 rho_subscript 000137 automatic fixed bin(21,0) dcl 23 set ref 122* 123* rhorho 000123 automatic fixed bin(17,0) dcl 23 in procedure "apl_encode_" set ref 99* 105 117 178 182 rhorho 3 based fixed bin(17,0) level 2 in structure "value_bead" dcl 5-3 in procedure "apl_encode_" set ref 92 99 99 105* 114 122 176* 176 right 000106 automatic pointer dcl 23 set ref 85* 136 right_data_elements 000121 automatic fixed bin(21,0) dcl 23 set ref 84* 87 135 156 right_pos 000133 automatic fixed bin(21,0) dcl 23 set ref 135* 135* 136 156* right_vb 000104 automatic pointer dcl 23 set ref 83* 84 85 87 98 99 118 151 165 size builtin function dcl 59 ref 100 100 106 static_ws_info_ptr 000014 external static pointer level 2 packed unaligned dcl 2-11 ref 2-7 string builtin function dcl 59 set ref 103* 151* 151 175* 175 substr builtin function dcl 59 in procedure "apl_encode_" ref 107 183 substr builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-37 switches 1 based structure level 2 packed unaligned dcl 2-16 total_data_elements 2 based fixed bin(21,0) level 2 dcl 5-3 set ref 77 84 98 98 104* 177* type based structure level 3 in structure "value_bead" packed unaligned dcl 5-3 in procedure "apl_encode_" set ref 103* 151* 151 175* 175 type based structure level 2 in structure "general_bead" packed unaligned dcl 6-3 in procedure "apl_encode_" unspec builtin function dcl 7-25 ref 7-37 value 000200 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 3-3 in procedure "apl_encode_" ref 76 83 value_bead based structure level 1 dcl 5-3 set ref 100 106 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 2-16 set ref 165* 167* 7-40 7-43 7-44* 7-44 values 2 based structure level 2 dcl 2-16 where_error 10 parameter fixed bin(17,0) level 2 dcl 3-3 set ref 190* 190 196* 196 200* 200 ws_info based structure level 1 dcl 2-16 ws_info_ptr 000152 automatic pointer initial dcl 2-7 set ref 141 141 145 165 167 2-7* 7-40 7-40 7-43 7-44 7-44 8-39 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 5-28 NumberSize internal static fixed bin(4,0) initial dcl 1-25 TheBiggestNumberWeveGot internal static float bin(63) initial dcl 1-16 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 1-16 character_data_structure based structure level 1 dcl 5-15 character_string_overlay based char dcl 5-19 character_value_type internal static bit(18) initial unaligned dcl 6-30 complex_datum based complex float bin(63) array dcl 5-26 complex_value_type internal static bit(18) initial unaligned dcl 6-30 function_type internal static bit(18) initial unaligned dcl 6-30 group_type internal static bit(18) initial unaligned dcl 6-30 label_type internal static bit(18) initial unaligned dcl 6-30 lexed_function_type internal static bit(18) initial unaligned dcl 6-30 list_value_type internal static bit(18) initial unaligned dcl 6-30 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 2-98 not_integer_mask internal static bit(18) initial unaligned dcl 6-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 6-30 numeric_value_type internal static bit(18) initial unaligned dcl 6-30 operator_bead based structure level 1 dcl 4-3 operator_type internal static bit(18) initial unaligned dcl 6-30 output_buffer based char unaligned dcl 2-94 shared_variable_type internal static bit(18) initial unaligned dcl 6-30 symbol_type internal static bit(18) initial unaligned dcl 6-30 value_type internal static bit(18) initial unaligned dcl 6-30 zero_or_one_value_type internal static bit(18) initial unaligned dcl 6-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_encode_ 000036 constant entry external dcl 10 apl_floor_ 000534 constant entry internal dcl 8-3 ref 147 apl_push_stack_ 000471 constant entry internal dcl 7-4 ref 101 174 compatibility_error_left 000452 constant label dcl 190 ref 141 domain_error 000466 constant label dcl 203 set ref 198 domain_error_left 000461 constant label dcl 196 ref 80 domain_error_right 000464 constant label dcl 200 set ref 87 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 672 712 602 702 Length 1240 602 20 311 70 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_encode_ 142 external procedure is an external procedure. apl_push_stack_ internal procedure shares stack frame of external procedure apl_encode_. apl_floor_ internal procedure shares stack frame of external procedure apl_encode_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_encode_ 000100 left_vb apl_encode_ 000102 left apl_encode_ 000104 right_vb apl_encode_ 000106 right apl_encode_ 000110 result_vb apl_encode_ 000112 result apl_encode_ 000114 final_result_vb apl_encode_ 000116 final_result apl_encode_ 000120 left_data_elements apl_encode_ 000121 right_data_elements apl_encode_ 000122 data_elements apl_encode_ 000123 rhorho apl_encode_ 000124 n_words apl_encode_ 000125 i apl_encode_ 000126 j apl_encode_ 000127 plane_base apl_encode_ 000130 last_column_on_this_plane apl_encode_ 000131 column_base apl_encode_ 000132 col_pos apl_encode_ 000133 right_pos apl_encode_ 000134 interval_between_columns apl_encode_ 000135 interval_between_columns_minus_1 apl_encode_ 000136 highest_column_element apl_encode_ 000137 rho_subscript apl_encode_ 000140 interval_between_elements apl_encode_ 000141 column_length apl_encode_ 000142 accum apl_encode_ 000144 divisor apl_encode_ 000146 quotient apl_encode_ 000150 residue apl_encode_ 000152 ws_info_ptr apl_encode_ 000154 number_of_dimensions apl_encode_ 000166 block_ptr apl_push_stack_ 000170 num_words apl_push_stack_ 000200 value apl_floor_ 000202 result apl_floor_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out return ext_entry floor_fl THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_get_value_stack_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. apl_error_table_$compatibility_error apl_error_table_$domain apl_static_$ws_info_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 10 000033 2 7 000043 76 000045 77 000050 78 000052 80 000054 83 000060 84 000063 85 000065 87 000067 92 000073 94 000101 98 000106 99 000111 100 000115 101 000125 103 000127 104 000132 105 000135 106 000137 107 000144 110 000152 114 000153 115 000162 116 000166 117 000170 118 000175 119 000203 121 000205 122 000207 123 000217 124 000224 126 000226 127 000231 131 000233 132 000237 133 000241 134 000247 135 000251 136 000255 137 000260 140 000265 141 000270 145 000276 147 000303 148 000310 149 000315 151 000316 152 000321 153 000323 156 000325 157 000334 158 000336 159 000341 160 000343 161 000345 165 000350 167 000361 170 000370 171 000372 174 000373 175 000375 176 000400 177 000404 178 000406 179 000415 180 000422 182 000424 183 000430 184 000436 186 000440 187 000446 188 000451 190 000452 193 000455 194 000460 196 000461 198 000463 200 000464 203 000466 205 000470 7 4 000471 7 35 000473 7 37 000475 7 40 000502 7 43 000517 7 44 000522 7 45 000531 8 3 000534 8 36 000536 8 37 000540 8 39 000543 8 42 000554 ----------------------------------------------------------- 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