COMPILATION LISTING OF SEGMENT apl_decode_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1600.1 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_decode_: 11 procedure (operators_argument); 12 13 /* 14* * this module implements the APL _| operator 15* * 16* * written 73.7.31 by DAM 17* * Modified 740717 by PG for new value bead dcl & error marker. 18* * Modified 760903 by PG to protect result on value stack. 19* Modified 770927 by PG to fix bug 250 (scalar_|matrix failed because rhorho of result computed incorrectly). 20* */ 21 22 23 dcl left_vb pointer, /* -> value bead for left operand */ 24 left pointer, /* -> value array of left operand */ 25 right_vb pointer, /* -> value bead for right operand */ 26 right pointer, /* -> value array of right operand */ 27 result_vb pointer, /* -> value bead on stack in which result is constructed */ 28 result pointer, /* -> value array on stack in which result is constructed */ 29 data_elements fixed bin(21), /* number of elements in the result */ 30 31 left_walk_pos fixed bin(21), /* position in walking from row to row of left operand */ 32 left_walk_bump fixed bin(21), /* increment to left_walk_pos to get to next row */ 33 right_walk_pos fixed bin(21), /* position in walking from column to column of right operand */ 34 right_walk_size fixed bin(21), /* right_walk_pos is bumped by 1 until it reaches this value */ 35 36 add_up float, /* temporary for adding up one element of the result */ 37 left_pos fixed bin(21), /* position of current element in current row of left operand */ 38 left_inc fixed bin(21), /* amount to bump left_pos to get to next element, same row */ 39 right_pos fixed bin(21), /* position of current element in current column of right operand */ 40 right_inc fixed bin(21), /* amount to bump right_pos by to get next element, same column */ 41 add_up_length fixed bin(21), /* length of row/column which is added up */ 42 result_pos fixed bin(21), /* position in result of element currently being computed */ 43 44 factor float, /* current power of radix, used in adding_up loop */ 45 add_up_count fixed bin(21), /* counter to count number of times around adding_up loop */ 46 47 n_words fixed bin (19), /* number of words of stack space required to hold the result */ 48 final_result_vb pointer, /* -> value bead where result is finally put on stack */ 49 final_result pointer; /* -> array for ditto */ 50 51 dcl (i, j) fixed bin; /* do-loop temporaries */ 52 53 dcl (addr, addrel, size, rel, substr, string, max) builtin; 54 55 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 ---------------------------------- */ 56 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 --------------------------- */ 57 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 3 2 3 3 declare 3 4 number_of_dimensions fixed bin, 3 5 3 6 1 value_bead aligned based, 3 7 2 header aligned like general_bead, 3 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 3 9 2 rhorho fixed binary, /* number of dimensions of value */ 3 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 3 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 3 12 /* dimensions of value (zero-origin) */ 3 13 3 14 3 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 3 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 3 17 /* actual elements of character array */ 3 18 3 19 declare character_string_overlay character (data_elements) aligned based; 3 20 /* to overlay on above structure */ 3 21 3 22 3 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 3 24 /* actual elements of numeric array */ 3 25 3 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 3 27 3 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 3 29 3 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 58 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 4 2 4 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 4 4 2 type unaligned, 4 5 3 bead_type unaligned, 4 6 4 operator bit (1), /* ON if operator bead */ 4 7 4 symbol bit (1), /* ON if symbol bead */ 4 8 4 value bit (1), /* ON if value bead */ 4 9 4 function bit (1), /* ON if function bead */ 4 10 4 group bit (1), /* ON if group bead */ 4 11 4 label bit (1), /* ON if label bead */ 4 12 4 shared_variable bit (1), /* ON if shared variable bead */ 4 13 4 lexed_function bit (1), /* ON if lexed function bead */ 4 14 3 data_type unaligned, 4 15 4 list_value bit (1), /* ON if a list value bead */ 4 16 4 character_value bit (1), /* ON if a character value bead */ 4 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 4 18 4 integral_value bit (1), /* ON if an integral value bead */ 4 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 4 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 4 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 4 22 2 size bit (18) unaligned, /* Number of words this bead occupies 4 23* (used by bead storage manager) */ 4 24 2 reference_count fixed binary (29); /* Number of pointers which point 4 25* to this bead (used by bead manager) */ 4 26 4 27 4 28 /* constant strings for initing type field in various beads */ 4 29 4 30 declare ( 4 31 operator_type init("100000000000000000"b), 4 32 symbol_type init("010000000000000000"b), 4 33 value_type init("001000000000000000"b), 4 34 function_type init("000100000000000000"b), 4 35 group_type init("000010000000000000"b), 4 36 label_type init("001001000011000000"b), 4 37 shared_variable_type init("001000100000000000"b), 4 38 lexed_function_type init("000000010000000000"b), 4 39 4 40 list_value_type init("000000001000000000"b), 4 41 character_value_type init("001000000100000000"b), 4 42 numeric_value_type init("001000000010000000"b), 4 43 integral_value_type init("001000000011000000"b), 4 44 zero_or_one_value_type init("001000000011100000"b), 4 45 complex_value_type init("001000000000010000"b), 4 46 4 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 4 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 4 49 ) bit(18) internal static; 4 50 4 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 59 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_operator_bead.incl.pl1 ================================ */ 5 2 5 3 declare 5 4 1 operator_bead aligned based, 5 5 5 6 2 type unaligned like general_bead.type, 5 7 5 8 2 bits_for_lex unaligned, 5 9 3 allow_brackets bit(1), /* operator may have dimension info in brackets */ 5 10 3 allow_product bit(1), /* operator may be used in inner and outer product */ 5 11 3 allow_reduction bit(1), /* operator may be used in reduction and scan */ 5 12 3 special_assignment bit(1), /* doesn't use standard assignment operator */ 5 13 3 ignores_assignment bit(1), /* assignment has no effect */ 5 14 3 allow_subscripted_assignment 5 15 bit(1), /* system variable that can be subscripted assigned */ 5 16 3 pad bit(12), 5 17 5 18 2 bits_for_parse unaligned, 5 19 3 stop_trace_control bit(1), /* next lexeme is function being stopped/traced 5 20* (op1 tells which) */ 5 21 3 quad bit(1), /* this is a quad type */ 5 22 3 system_variable bit(1), /* this is a system variable, not an op */ 5 23 3 dyadic bit(1), /* operator may be dyadic */ 5 24 3 monadic bit(1), /* operator may be monadic */ 5 25 3 function bit(1), /* operator is a user defined function */ 5 26 3 semantics_valid bit(1), /* if semantics has been set */ 5 27 3 has_list bit(1), /* semantics is a list */ 5 28 3 inner_product bit(1), /* op2 is valid */ 5 29 3 semantics_on_stack bit(1), /* semantics points to value stack */ 5 30 3 is_external_function bit(1), /* semantics points to function bead for ext function */ 5 31 3 pad bit(7), 5 32 3 op2 fixed bin(8) unaligned, /* secondary operator code */ 5 33 3 op1 fixed bin(8) unaligned, /* primary operator code */ 5 34 2 type_code fixed bin; /* for parse */ 5 35 5 36 /* ------ END INCLUDE SEGMENT apl_operator_bead.incl.pl1 -------------------------------- */ 60 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 6 2 6 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 6 4 6 5 /* automatic */ 6 6 6 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 6 8 6 9 /* external static */ 6 10 6 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 6 12 2 static_ws_info_ptr unaligned pointer; 6 13 6 14 /* based */ 6 15 6 16 declare 1 ws_info aligned based (ws_info_ptr), 6 17 2 version_number fixed bin, /* version of this structure (3) */ 6 18 2 switches unaligned, /* mainly ws parameters */ 6 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 6 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 6 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 6 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 6 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 6 24 3 restrict_external_functions 6 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 6 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 6 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 6 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 6 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 6 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 6 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 6 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 6 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 6 34 3 compatibility_check_mode 6 35 bit, /* if 1, check for incompatible operators */ 6 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 6 37 /* remaining 20 bits not presently used */ 6 38 6 39 2 values, /* attributes of the workspace */ 6 40 3 digits fixed bin, /* number of digits of precision printed on output */ 6 41 3 width fixed bin, /* line length for formatted output */ 6 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 6 43 3 random_link fixed bin(35), /* seed for random number generator */ 6 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 6 45 3 float_index_origin float, /* the index origin in floating point */ 6 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 6 47 3 maximum_value_stack_size 6 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 6 49 6 50 2 pointers, /* pointers to various internal tables */ 6 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 6 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 6 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 6 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 6 55 6 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 6 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 6 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 6 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 6 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 6 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 6 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 6 63 2 signoff_lock character (32), 6 64 6 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 6 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 6 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 6 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 6 69 bit, /* munging his tables */ 6 70 3 unused_interrupt_bit bit, /* not presently used */ 6 71 3 dont_interrupt_command bit, 6 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 6 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 6 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 6 75 6 76 2 user_name char (32), /* process group id of user */ 6 77 2 immediate_input_prompt char (32) varying, /* normal input */ 6 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 6 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 6 80 2 vcpu_time aligned, 6 81 3 total fixed bin (71), 6 82 3 setup fixed bin (71), 6 83 3 parse fixed bin (71), 6 84 3 lex fixed bin (71), 6 85 3 operator fixed bin (71), 6 86 3 storage_manager fixed bin (71), 6 87 2 output_info aligned, /* data pertaining to output buffer */ 6 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 6 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 6 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 6 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 6 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 6 93 6 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 6 95 6 96 /* internal static */ 6 97 6 98 declare max_parse_stack_depth fixed bin int static init(64536); 6 99 6 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 61 62 63 /* pick up pointers to arguments */ 64 65 left_vb = operands(1).value; 66 left = left_vb -> value_bead.data_pointer; 67 if ^left_vb -> value_bead.numeric_value 68 then go to domain_error_left; 69 70 right_vb = operands(2).value; 71 right = right_vb -> value_bead.data_pointer; 72 if ^right_vb -> value_bead.numeric_value 73 then go to domain_error_right; 74 75 /* determine conformability and set up control variables according to which case */ 76 77 if left_vb -> value_bead.total_data_elements = 1 then do; /* effective scalar */ 78 left_walk_bump = 1; 79 left_inc = 0; 80 if right_vb -> value_bead.total_data_elements = 1 then do; /* effective scalar */ 81 add_up_length = 1; 82 right_inc = 0; 83 right_walk_size = 1; 84 end; 85 else do; 86 add_up_length = right_vb -> value_bead.rho(1); 87 right_inc = 1; 88 do i = 2 to right_vb -> value_bead.rhorho; 89 right_inc = right_inc * right_vb -> value_bead.rho(i); 90 end; 91 right_walk_size = right_inc; 92 end; 93 end; 94 95 else if right_vb -> value_bead.total_data_elements = 1 then do; 96 right_inc = 0; 97 right_walk_size = 1; 98 left_walk_bump = left_vb -> value_bead.rho(left_vb -> value_bead.rhorho); 99 add_up_length = left_walk_bump; 100 left_inc = 1; 101 end; 102 103 else if left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) = 104 right_vb -> value_bead.rho(1) then do; 105 left_walk_bump = left_vb -> value_bead.rho(left_vb -> value_bead.rhorho); 106 left_inc = 1; 107 right_inc = 1; 108 do i = 2 to right_vb -> value_bead.rhorho; 109 right_inc = right_inc * right_vb -> value_bead.rho(i); 110 end; 111 right_walk_size = right_inc; 112 add_up_length = left_walk_bump; 113 end; 114 115 else if left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) = 1 then do; 116 right_inc = 1; 117 do i = 2 to right_vb -> value_bead.rhorho; 118 right_inc = right_inc * right_vb -> value_bead.rho(i); 119 end; 120 right_walk_size = right_inc; 121 add_up_length = right_vb -> value_bead.rho(1); 122 left_inc = 0; 123 left_walk_bump = 1; 124 end; 125 126 else if right_vb -> value_bead.rho(1) = 1 then do; 127 left_walk_bump = left_vb -> value_bead.rho(left_vb -> value_bead.rhorho); 128 right_walk_size = right_vb -> value_bead.total_data_elements; 129 left_inc = 1; 130 right_inc = 0; 131 add_up_length = left_walk_bump; 132 end; 133 134 else go to length_error; /* I guess */ 135 136 /* compute size of result */ 137 138 data_elements = 1; 139 if left_vb -> value_bead.total_data_elements ^= 1 140 then do i = 1 by 1 while (i < left_vb -> value_bead.rhorho); 141 data_elements = data_elements * left_vb -> value_bead.rho(i); 142 end; 143 144 if right_vb -> value_bead.total_data_elements ^= 1 145 then do i = 2 to right_vb -> value_bead.rhorho; 146 data_elements = data_elements * right_vb -> value_bead.rho(i); 147 end; 148 149 /* push result onto stack */ 150 151 number_of_dimensions = max (left_vb -> value_bead.rhorho - 1, 0) + max (right_vb -> value_bead.rhorho - 1, 0); 152 n_words = size (value_bead) + size (numeric_datum) + 1; 153 result_vb = apl_push_stack_ (n_words); 154 string(result_vb -> value_bead.type) = string(left_vb -> value_bead.type) & 155 string(right_vb -> value_bead.type) & integral_value_type; 156 result_vb -> value_bead.total_data_elements = data_elements; 157 result_vb -> value_bead.rhorho = number_of_dimensions; 158 result = addr(result_vb -> value_bead.rho(result_vb -> value_bead.rhorho+1)); 159 if substr(rel(result), 18, 1) then result = addrel(result, 1); 160 result_vb -> value_bead.data_pointer = result; 161 162 /* construct rho of result as concatenation of rhos of operands */ 163 164 do i = 1 by 1 while (i < left_vb -> value_bead.rhorho); 165 result_vb -> value_bead.rho(i) = left_vb -> value_bead.rho(i); 166 end; 167 do j = i by 1 while (j <= result_vb -> value_bead.rhorho); 168 result_vb -> value_bead.rho(j) = right_vb -> value_bead.rho(j-i+2); 169 end; 170 171 /* do it */ 172 173 result_pos = 0; 174 do left_walk_pos = 0 by left_walk_bump while(left_walk_pos < left_vb -> value_bead.total_data_elements); 175 176 do right_walk_pos = 0 by 1 while (right_walk_pos < right_walk_size); 177 178 add_up = 0; 179 factor = 1; 180 left_pos = left_walk_pos + add_up_length*left_inc; /* work from right to left */ 181 right_pos = right_walk_pos + add_up_length*right_inc; /* .. */ 182 do add_up_count = 0 by 1 while(add_up_count < add_up_length); 183 right_pos = right_pos - right_inc; 184 add_up = add_up + factor * right -> numeric_datum(right_pos); 185 left_pos = left_pos - left_inc; 186 factor = factor * left -> numeric_datum(left_pos); 187 end; 188 189 result -> numeric_datum(result_pos) = add_up; 190 result_pos = result_pos + 1; 191 192 end; 193 end; 194 195 if result_pos = 0 then result -> numeric_datum(0) = 0; /* special kludge for (iota 0) _| iota 0 */ 196 197 /* copy result down on stack in the usual way */ 198 199 if operands(2).on_stack then value_stack_ptr = right_vb; 200 else if operands(1).on_stack then value_stack_ptr = left_vb; 201 else do; /* result is already in right place */ 202 operators_argument.result = result_vb; 203 return; 204 end; 205 206 /* n_words is already set */ 207 208 final_result_vb = apl_push_stack_ (n_words); 209 string(final_result_vb -> value_bead.type) = string(result_vb -> value_bead.type); 210 final_result_vb -> value_bead.total_data_elements = result_vb -> value_bead.total_data_elements; 211 final_result_vb -> value_bead.rhorho = result_vb -> value_bead.rhorho; 212 if result_vb -> value_bead.rhorho > 0 /* zero-length arrays are illegal in PL/I */ 213 then final_result_vb -> value_bead.rho (*) = result_vb -> value_bead.rho (*); 214 215 final_result = addr(final_result_vb -> value_bead.rho(final_result_vb -> value_bead.rhorho+1)); 216 if substr(rel(final_result), 18, 1) then final_result = addrel(final_result, 1); 217 final_result_vb -> value_bead.data_pointer = final_result; 218 219 final_result -> numeric_datum(*) = result -> numeric_datum(*); 220 221 operators_argument.result = final_result_vb; 222 return; 223 224 domain_error_right: 225 operators_argument.where_error = operators_argument.where_error - 2; 226 227 domain_error_left: 228 operators_argument.where_error = operators_argument.where_error + 1; 229 operators_argument.error_code = apl_error_table_$domain; 230 return; 231 232 length_error: 233 operators_argument.error_code = apl_error_table_$length; 234 return; 235 236 237 dcl (apl_error_table_$domain, apl_error_table_$length) fixed bin(35) external; 238 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 ------------------------------- */ 239 240 241 end /* apl_decode_ */ ; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1346.2 apl_decode_.pl1 >special_ldd>on>apl.1129>apl_decode_.pl1 56 1 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 57 2 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 58 3 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 59 4 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 60 5 03/27/82 0439.0 apl_operator_bead.incl.pl1 >ldd>include>apl_operator_bead.incl.pl1 61 6 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 239 7 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_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 add_up 000122 automatic float bin(63) dcl 23 set ref 178* 184* 184 189 add_up_count 000134 automatic fixed bin(21,0) dcl 23 set ref 182* 182* add_up_length 000130 automatic fixed bin(21,0) dcl 23 set ref 81* 86* 99* 112* 121* 131* 180 181 182 addr builtin function dcl 53 ref 158 215 addrel builtin function dcl 53 in procedure "apl_decode_" ref 159 216 addrel builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-44 apl_error_table_$domain 000012 external static fixed bin(35,0) dcl 237 ref 229 apl_error_table_$length 000014 external static fixed bin(35,0) dcl 237 ref 232 apl_get_value_stack_ 000016 constant entry external dcl 7-30 ref 7-40 apl_static_$ws_info_ptr 000010 external static structure level 1 dcl 6-11 binary builtin function dcl 7-25 ref 7-40 block_ptr 000164 automatic pointer dcl 7-20 set ref 7-43* 7-45 data_elements 000114 automatic fixed bin(21,0) dcl 23 set ref 138* 141* 141 146* 146 152 156 219 data_pointer 4 based pointer level 2 packed unaligned dcl 3-3 set ref 66 71 160* 217* data_type 0(08) based structure level 4 packed unaligned dcl 3-3 error_code 7 parameter fixed bin(35,0) level 2 dcl 2-3 set ref 229* 232* factor 000132 automatic float bin(63) dcl 23 set ref 179* 184 186* 186 final_result 000140 automatic pointer dcl 23 set ref 215* 216 216* 216 217 219 final_result_vb 000136 automatic pointer dcl 23 set ref 208* 209 210 211 212 215 215 217 221 general_bead based structure level 1 dcl 4-3 header based structure level 2 dcl 3-3 i 000142 automatic fixed bin(17,0) dcl 51 set ref 88* 89* 108* 109* 117* 118* 139* 139* 141* 144* 146* 164* 164* 165 165* 167 168 integral_value_type constant bit(18) initial unaligned dcl 4-30 ref 154 j 000143 automatic fixed bin(17,0) dcl 51 set ref 167* 167* 168 168* left 000102 automatic pointer dcl 23 set ref 66* 186 left_inc 000125 automatic fixed bin(21,0) dcl 23 set ref 79* 100* 106* 122* 129* 180 185 left_pos 000124 automatic fixed bin(21,0) dcl 23 set ref 180* 185* 185 186 left_vb 000100 automatic pointer dcl 23 set ref 65* 66 67 77 98 98 103 103 105 105 115 115 127 127 139 139 141 151 154 164 165 174 200 left_walk_bump 000116 automatic fixed bin(21,0) dcl 23 set ref 78* 98* 99 105* 112 123* 127* 131 174 left_walk_pos 000115 automatic fixed bin(21,0) dcl 23 set ref 174* 174* 180* max builtin function dcl 53 ref 151 151 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 6-16 ref 7-40 n_words 000135 automatic fixed bin(19,0) dcl 23 set ref 152* 153* 208* num_words 000166 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 000144 automatic fixed bin(17,0) dcl 3-3 set ref 151* 152 157 numeric_datum based float bin(63) array dcl 3-23 set ref 152 184 186 189* 195* 219* 219 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 3-3 set ref 67 72 on_stack 1 parameter bit(1) array level 3 dcl 2-3 ref 199 200 operands parameter structure array level 2 dcl 2-3 operators_argument parameter structure level 1 dcl 2-3 set ref 10 pointers 14 based structure level 2 dcl 6-16 rel builtin function dcl 53 in procedure "apl_decode_" ref 159 216 rel builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-40 result 6 parameter pointer level 2 in structure "operators_argument" packed unaligned dcl 2-3 in procedure "apl_decode_" set ref 202* 221* result 000112 automatic pointer dcl 23 in procedure "apl_decode_" set ref 158* 159 159* 159 160 189 195 219 result_pos 000131 automatic fixed bin(21,0) dcl 23 set ref 173* 189 190* 190 195 result_vb 000110 automatic pointer dcl 23 set ref 153* 154 156 157 158 158 160 165 167 168 202 209 210 211 212 212 rho 5 based fixed bin(21,0) array level 2 dcl 3-3 set ref 86 89 98 103 103 105 109 115 118 121 126 127 141 146 158 165* 165 168* 168 212* 212 215 rhorho 3 based fixed bin(17,0) level 2 dcl 3-3 set ref 88 98 103 105 108 115 117 127 139 144 151 151 157* 158 164 167 211* 211 212 212 215 right 000106 automatic pointer dcl 23 set ref 71* 184 right_inc 000127 automatic fixed bin(21,0) dcl 23 set ref 82* 87* 89* 89 91 96* 107* 109* 109 111 116* 118* 118 120 130* 181 183 right_pos 000126 automatic fixed bin(21,0) dcl 23 set ref 181* 183* 183 184 right_vb 000104 automatic pointer dcl 23 set ref 70* 71 72 80 86 88 89 95 103 108 109 117 118 121 126 128 144 144 146 151 154 168 199 right_walk_pos 000117 automatic fixed bin(21,0) dcl 23 set ref 176* 176* 181* right_walk_size 000120 automatic fixed bin(21,0) dcl 23 set ref 83* 91* 97* 111* 120* 128* 176 size builtin function dcl 53 ref 152 152 static_ws_info_ptr 000010 external static pointer level 2 packed unaligned dcl 6-11 ref 6-7 string builtin function dcl 53 set ref 154* 154 154 209* 209 substr builtin function dcl 53 in procedure "apl_decode_" ref 159 216 substr builtin function dcl 7-25 in procedure "apl_push_stack_" ref 7-37 total_data_elements 2 based fixed bin(21,0) level 2 dcl 3-3 set ref 77 80 95 128 139 144 156* 174 210* 210 type based structure level 2 in structure "general_bead" packed unaligned dcl 4-3 in procedure "apl_decode_" type based structure level 3 in structure "value_bead" packed unaligned dcl 3-3 in procedure "apl_decode_" set ref 154* 154 154 209* 209 unspec builtin function dcl 7-25 ref 7-37 value parameter pointer array level 3 packed unaligned dcl 2-3 ref 65 70 value_bead based structure level 1 dcl 3-3 set ref 152 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 6-16 set ref 199* 200* 7-40 7-43 7-44* 7-44 values 2 based structure level 2 dcl 6-16 where_error 10 parameter fixed bin(17,0) level 2 dcl 2-3 set ref 224* 224 227* 227 ws_info based structure level 1 dcl 6-16 ws_info_ptr 000146 automatic pointer initial dcl 6-7 set ref 199 200 6-7* 7-40 7-40 7-43 7-44 7-44 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 3-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 3-15 character_string_overlay based char dcl 3-19 character_value_type internal static bit(18) initial unaligned dcl 4-30 complex_datum based complex float bin(63) array dcl 3-26 complex_value_type internal static bit(18) initial unaligned dcl 4-30 function_type internal static bit(18) initial unaligned dcl 4-30 group_type internal static bit(18) initial unaligned dcl 4-30 label_type internal static bit(18) initial unaligned dcl 4-30 lexed_function_type internal static bit(18) initial unaligned dcl 4-30 list_value_type internal static bit(18) initial unaligned dcl 4-30 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 6-98 not_integer_mask internal static bit(18) initial unaligned dcl 4-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 4-30 numeric_value_type internal static bit(18) initial unaligned dcl 4-30 operator_bead based structure level 1 dcl 5-3 operator_type internal static bit(18) initial unaligned dcl 4-30 output_buffer based char unaligned dcl 6-94 shared_variable_type internal static bit(18) initial unaligned dcl 4-30 symbol_type internal static bit(18) initial unaligned dcl 4-30 value_type internal static bit(18) initial unaligned dcl 4-30 zero_or_one_value_type internal static bit(18) initial unaligned dcl 4-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_decode_ 000036 constant entry external dcl 10 apl_push_stack_ 000631 constant entry internal dcl 7-4 ref 153 208 domain_error_left 000620 constant label dcl 227 set ref 67 domain_error_right 000616 constant label dcl 224 set ref 72 length_error 000625 constant label dcl 232 ref 126 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 776 1016 710 1006 Length 1326 710 20 273 65 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_decode_ 126 external procedure is an external procedure. apl_push_stack_ internal procedure shares stack frame of external procedure apl_decode_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_decode_ 000100 left_vb apl_decode_ 000102 left apl_decode_ 000104 right_vb apl_decode_ 000106 right apl_decode_ 000110 result_vb apl_decode_ 000112 result apl_decode_ 000114 data_elements apl_decode_ 000115 left_walk_pos apl_decode_ 000116 left_walk_bump apl_decode_ 000117 right_walk_pos apl_decode_ 000120 right_walk_size apl_decode_ 000122 add_up apl_decode_ 000124 left_pos apl_decode_ 000125 left_inc apl_decode_ 000126 right_pos apl_decode_ 000127 right_inc apl_decode_ 000130 add_up_length apl_decode_ 000131 result_pos apl_decode_ 000132 factor apl_decode_ 000134 add_up_count apl_decode_ 000135 n_words apl_decode_ 000136 final_result_vb apl_decode_ 000140 final_result apl_decode_ 000142 i apl_decode_ 000143 j apl_decode_ 000144 number_of_dimensions apl_decode_ 000146 ws_info_ptr apl_decode_ 000164 block_ptr apl_push_stack_ 000166 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out return ext_entry 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_$domain apl_error_table_$length apl_static_$ws_info_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 10 000033 6 7 000043 65 000045 66 000050 67 000052 70 000055 71 000060 72 000062 77 000065 78 000071 79 000073 80 000074 81 000077 82 000101 83 000102 84 000103 86 000104 87 000106 88 000110 89 000117 90 000124 91 000126 93 000130 95 000131 96 000134 97 000135 98 000137 99 000142 100 000143 101 000145 103 000146 105 000152 106 000153 107 000155 108 000156 109 000165 110 000172 111 000174 112 000176 113 000200 115 000201 116 000203 117 000205 118 000215 119 000222 120 000224 121 000226 122 000231 123 000232 124 000234 126 000235 127 000240 128 000242 129 000244 130 000246 131 000247 138 000251 139 000253 141 000266 142 000272 144 000274 146 000307 147 000314 151 000316 152 000335 153 000345 154 000347 156 000360 157 000363 158 000365 159 000367 160 000375 164 000376 165 000404 166 000410 167 000412 168 000420 169 000425 173 000427 174 000430 176 000440 178 000445 179 000447 180 000451 181 000455 182 000461 183 000465 184 000467 185 000476 186 000500 187 000506 189 000510 190 000515 192 000516 193 000520 195 000523 199 000527 200 000540 202 000546 203 000550 208 000551 209 000553 210 000556 211 000562 212 000564 215 000572 216 000575 217 000603 219 000604 221 000612 222 000615 224 000616 227 000620 229 000622 230 000624 232 000625 234 000630 7 4 000631 7 35 000633 7 37 000635 7 40 000642 7 43 000657 7 44 000662 7 45 000671 ----------------------------------------------------------- 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