COMPILATION LISTING OF SEGMENT apl_monadic_rho_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1611.6 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 /* This module implements monadic iota, monadic rho, and dyadic rho 11* 12* Created by G. Gordon Benedict on 06/23/73 13* Modified 740910 by PG for error marker. 14* Modified 780210 by PG to fix bug 278 by calling apl_push_stack_. 15* Modified 780214 by PG to fix bug 312 (iEXPR, where expr is boolean, failed). Bug was introduced 780210. 16* Modified 790313 by William M. York to fix bug 311 (some programs are 17* double-word aligning character data, bug 364 (reshape does not check 18* for negative args), and bug 332 (reshape computes number of elements 19* in result before rounding left arguments). 20* Modified 790316 by WMY to fix the last fix. 21* Modified 790321 by WMY to fix bug 383 (reshape does not always re-protect very 22* large result values). 23**/ 24 25 apl_monadic_rho_: 26 procedure (operators_argument); 27 28 /* based */ 29 30 declare 1 value_bead_overlay aligned based, /* overlay so I can pass descriptor to procedure */ 31 2 header aligned like general_bead, 32 2 total_data_elements fixed binary (21), 33 2 rhorho fixed binary, 34 2 data_pointer pointer unaligned, 35 2 rho_sub_1 fixed binary (21); 36 37 dcl saved_left_arg (left_data_elements) fixed binary(21) based (saved_left_arg_ptr); 38 dcl saved_left_arg_ptr pointer aligned init (null()); 39 40 /* automatic */ 41 42 dcl ( 43 right_vb, /* pointer to value bead for operand to right of operator */ 44 right_array, /* ptr to right operand itself (data ptr from right v.b.) */ 45 left_vb, /* ptr to v.b. to left of operator */ 46 left_array, /* ptr to left operand */ 47 result_vb, /* ptr to result v.b. */ 48 result_array /* where result array will be stored */ 49 ) pointer aligned; 50 51 dcl ( 52 data_elements, /* number of elements in result */ 53 right_data_elements, /* number of elements in right array */ 54 left_data_elements /* number of elements in left array */ 55 ) fixed binary precision (21); 56 57 declare ( data_words_needed, /* to tell stack_allocate_known how many words needed */ 58 number_to_copy, /* number of words in word_copy_overlay for copying */ 59 words_needed, /* words needed to get from value stack. set by stack_allocate_known */ 60 words_needed_in_bead /* words needed in value bead to be allocated. */ 61 ) fixed bin (19); 62 63 declare (left_rhorho, /* copy of value_bead.rhorho for left arg */ 64 right_rhorho, /* same for right */ 65 rhorho, /* used to tell stack_allocate_known how much space needed in value bead */ 66 rho_subscript, /* steps thru rho arrays */ 67 count /* random counter */ 68 ) fixed binary; 69 70 dcl numeric_result bit(1); 71 72 dcl (single_element_fl_1, /* used to hold one arg if it is a scalar and the other an array */ 73 fuzz, /* copy of fuzz in ws_info for efficiency */ 74 integer_fuzz, /* copy of integer_fuzz */ 75 result_accumulator, /* another random temp */ 76 float_temp /* temporary for float -> integer conversions */ 77 ) float; 78 79 dcl 1 free_type aligned like general_bead.type; 80 81 /* entries */ 82 83 declare apl_iota_appendage_ entry (float bin (63), float bin (63), fixed bin (21), pointer); 84 declare apl_rho_appendage_ entry (1 aligned like value_bead_overlay, 1 aligned like value_bead_overlay, 85 (8) fixed binary (35)); 86 /* external static */ 87 88 dcl (apl_error_table_$rank, 89 apl_error_table_$length, 90 apl_error_table_$domain 91 ) fixed bin (35) ext static; /* error codes */ 92 93 /* builtins */ 94 95 dcl ( 96 abs, 97 addrel, 98 divide, 99 fixed, 100 float, 101 floor, 102 prod, 103 rel, 104 substr, 105 size, 106 string ) builtin; 107 108 declare automatic_storage dimension (8) fixed binary (35); /* temps for rho_appendage */ 109 110 dcl word_copy_overlay based dimension (number_to_copy) fixed bin (35); /* for aggregate array copies */ 111 112 dcl numeric_datum_or1 (data_elements) based float; /* numeric data but with an origin of 1 */ 113 114 /* include files */ 115 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 ---------------------------------- */ 116 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 --------------------------- */ 117 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 ---------------------------------- */ 118 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 ----------------------------------- */ 119 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 -------------------------------------- */ 120 121 122 /* The following subroutine is used to allocate a result value bead and a result array on the value stack. 123* The rhorho of the result v.b. is given in variable rhorho, and the number of data elements in the result array 124* is given in data_elements. It sets result_vb to point to allocated value_bead and result_array to point to the 125* array. All fields in the value bead are filled in except value_bead.header.type and value_bead.rho. 126* The bead is allocated on such a boundary that the next word after it (the first word of the result array) is 127* doubleword aligned. */ 128 129 stack_allocate_numeric: 130 procedure (); 131 132 numeric_result = "1"b; 133 data_words_needed = size (numeric_datum_or1); /* get result length from data_elements */ 134 goto stack_allocate_known_common; /* common code */ 135 136 stack_allocate_char: /* entry to assume thing to alloc is char */ 137 entry (); 138 139 numeric_result = "0"b; 140 data_words_needed = size (character_string_overlay); 141 142 143 stack_allocate_known: 144 entry (); /* if caller has already loaded data_words_needed with number needed */ 145 146 stack_allocate_known_common: /* to transfer from above */ 147 number_of_dimensions = rhorho; 148 words_needed_in_bead = size (value_bead); 149 words_needed = words_needed_in_bead + data_words_needed + 1; /* addition of 1 to doubleword align */ 150 result_vb = apl_push_stack_ (words_needed); 151 result_array = addrel (result_vb, words_needed_in_bead); 152 if numeric_result 153 then if substr (rel (result_array), 18, 1) 154 then result_array = addrel (result_array, 1); /* if next word is odd-aligned, bump by 1 word */ 155 156 result_vb -> value_bead.total_data_elements = data_elements; 157 result_vb -> value_bead.rhorho = rhorho; /* make result conform with original operand */ 158 result_vb -> value_bead.data_pointer = result_array; /* pointer to actual array */ 159 operators_argument.result = result_vb; /* let parse know where I put result when I return */ 160 161 end stack_allocate_numeric; 162 163 /* procedure to extract information from operators_argument */ 164 165 dyadic_extract: 166 procedure (); 167 168 /* copy information from argument structure */ 169 170 left_vb = operators_argument.operands (1).value; 171 left_array = left_vb -> value_bead.data_pointer; 172 left_data_elements = left_vb -> value_bead.total_data_elements; 173 left_rhorho = left_vb -> value_bead.rhorho; 174 175 monadic_extract: /* repeat for right operand */ 176 entry (); 177 178 right_vb = operators_argument.operands (2).value; 179 right_array = right_vb -> value_bead.data_pointer; 180 right_data_elements = right_vb -> value_bead.total_data_elements; 181 right_rhorho = right_vb -> value_bead.rhorho; 182 183 fuzz = ws_info.fuzz; /* extract for efficiency */ 184 integer_fuzz = ws_info.integer_fuzz; 185 end dyadic_extract; 186 187 /* procedure to implement monadic rho */ 188 189 call monadic_extract (); 190 191 if operators_argument.operands (2).on_stack /* pop right arg so it can be overlayed */ 192 then ws_info.value_stack_ptr = right_vb; 193 194 rhorho = 1; /* rho operator always returns a vector */ 195 data_elements = right_rhorho; /* as many elements as dimensions in argument */ 196 call stack_allocate_numeric (); /* get storage for result */ 197 do rho_subscript = right_rhorho - 1 to 0 by -1; /* backwards because operands may overlay each other */ 198 result_array -> numeric_datum (rho_subscript) /* change each rho vector element in operand to a data element */ 199 = float (right_vb -> value_bead.rho (rho_subscript + 1), 63); 200 end; 201 result_vb -> value_bead.rho (1) /* set vector bound */ 202 = right_rhorho; 203 string (result_vb -> value_bead.header.type) = integral_value_type; /* always numeric */ 204 return; 205 206 /* this module implements the monadic iota operator in apl */ 207 208 apl_monadic_iota_: 209 entry (operators_argument); 210 211 call monadic_extract (); 212 string (free_type) = string (right_vb -> value_bead.header.type); /* cpy type field for efficiency */ 213 214 if operators_argument.operands (2).on_stack /* pop right arg so it can be overlayed */ 215 then ws_info.value_stack_ptr = right_vb; 216 217 if right_data_elements ^= 1 then goto length_error_right; /* must be effective scalar */ 218 rhorho = right_data_elements; /* as with rho, iota produces a vector always */ 219 if free_type.zero_or_one_value then do; /* either 0 or 1, optimize */ 220 if right_array -> numeric_datum (0) = 0 then do; /* iota 0 */ 221 data_elements, 222 data_words_needed = 0; /* nothing for null vector */ 223 end; 224 else do; /* must be iota 1 */ 225 data_elements = 1; 226 data_words_needed = size (numeric_datum_or1); 227 end; 228 call stack_allocate_known (); 229 string (result_vb -> value_bead.header.type) = zero_or_one_value_type; 230 result_vb -> value_bead.rho (1) = data_elements; 231 if data_elements = 0 then return; /* none to fill in */ 232 result_array -> numeric_datum (0) = /* put in index origin */ 233 ws_info.values.float_index_origin; 234 return; 235 end; 236 if free_type.data_type.character_value then 237 goto domain_error_right; 238 result_accumulator = right_array -> numeric_datum (0); /* put in temp for efficiency */ 239 if result_accumulator < 0 then goto domain_error_right; /* cannot be negative */ 240 single_element_fl_1 = floor (result_accumulator + 0.5); /* generate fixed number */ 241 if ^ free_type.data_type.integral_value then /* check if integer */ 242 if abs(single_element_fl_1 - result_accumulator) > integer_fuzz then /* not integer */ 243 goto domain_error_right; 244 if abs(single_element_fl_1) >= 1e21b then go to domain_error_right; 245 data_elements = fixed (single_element_fl_1, 21, 0); /* fix it to index easily */ 246 call stack_allocate_numeric (); /* get storage for result */ 247 result_vb -> value_bead.rho (1) = data_elements; 248 string (result_vb -> value_bead.header.type) = integral_value_type; /* iota always returns integers */ 249 call apl_iota_appendage_ (ws_info.values.float_index_origin, 1, data_elements, result_array); 250 return; 251 /* This module implements the dyadic rho operator in apl */ 252 253 apl_dyadic_rho_: 254 entry (operators_argument); 255 256 /* extract data from args */ 257 call dyadic_extract (); 258 259 if left_rhorho > 1 then 260 goto rank_error_left; 261 262 data_elements, /* set this so prod builtin below will work (dimension of numeric_datum_or1) */ 263 rhorho = /* number of elements in left operand will be number of elements in result */ 264 left_data_elements; 265 266 saved_left_arg_ptr = null(); 267 268 if rhorho = 0 then 269 data_elements = 1; /* null left vector means return first element of right */ 270 else do; 271 if ^ left_vb -> value_bead.header.type.data_type.numeric_value then 272 goto domain_error_left; 273 274 saved_left_arg_ptr = apl_push_stack_ ((left_data_elements)); 275 276 do count = lbound (left_array -> numeric_datum_or1, 1) to hbound (left_array -> numeric_datum_or1, 1); 277 278 /* Round and fix each element of the left argument. */ 279 280 if left_array -> numeric_datum_or1(count) + integer_fuzz < 0 281 then goto domain_error_left; /* no negative args allowed */ 282 283 float_temp = floor (left_array -> numeric_datum_or1(count) + 0.5); 284 if abs (float_temp - (left_array -> numeric_datum_or1(count))) > integer_fuzz 285 then goto domain_error_left; 286 if abs (float_temp) >= 1e21b 287 then goto domain_error_left; 288 289 saved_left_arg(count) = fixed (float_temp, 21); 290 end; 291 292 data_elements = prod (saved_left_arg); 293 294 end; 295 296 /* get storage for bead and result at end of stack */ 297 298 if right_vb -> value_bead.header.type.data_type.character_value /* char operand */ 299 then call stack_allocate_char (); 300 else call stack_allocate_numeric (); 301 302 /* now copy rho vector from data in left operand */ 303 304 do rho_subscript = 1 to rhorho; 305 306 result_vb -> value_bead.rho (rho_subscript) = saved_left_arg(rho_subscript); 307 end; 308 309 string (result_vb -> value_bead.header.type) = /* copy type from right hand arg */ 310 string (right_vb -> value_bead.header.type); 311 312 if data_elements = 0 then 313 goto copy_up_stack; /* return null vector */ 314 315 if right_data_elements = 0 then 316 goto domain_error_right; /* attempt to create a vector out of nothing (null right operand) */ 317 318 /* program to actually do rho */ 319 320 call apl_rho_appendage_ (right_vb -> value_bead_overlay, result_vb -> value_bead_overlay, automatic_storage); 321 322 goto copy_up_stack; /* goto routine to copy stuff up stack */ 323 324 /* procedure to copy garbage up stack. assumes variable words_needed_in_bead contains number of words 325* in bead, data_words_needed contains words in data */ 326 327 copy_up_stack: /* not really a subroutine, just gone to */ 328 329 if ^(operators_argument.operands (2).on_stack) /* right is not on stack */ 330 then if ^(operators_argument.operands (1).on_stack) /* left is not on stack */ 331 then if saved_left_arg_ptr = null() /* no temp storage */ 332 then do; /* nothing is above result on stack */ 333 operators_argument.result = result_vb; /* leave answer where it is */ 334 return; 335 end; 336 else result_array = saved_left_arg_ptr; /* use result_array as temp ptr */ 337 else result_array = left_vb; /* left is on stack and right is not -- overlay on left operand */ 338 else result_array = right_vb; /* right and left on stack */ 339 340 /* If result will not fit in current value stack, leave it where it 341* is, as it will just end up back where it started. */ 342 343 if fixed (rel (result_array), 18, 0) + words_needed > maximum_value_stack_size 344 then do; 345 operators_argument.result = result_vb; /* result will be where it is */ 346 return; 347 end; 348 349 /* otherwise unprotect all of the stack values */ 350 351 else ws_info.value_stack_ptr = result_array; 352 353 /* the following kludges are used to copy the result operand lowest in the stack. Kludgy code using overlays 354* and unspecs will be used until such time as the PL/I compiler can generate structure assignments 355* without moving one bit at a time. */ 356 357 /* now find the next doubleword boundary on which to put the result data. Note that if decimal data is 358* someday used, alignment will not be necessary; in that case both the bead and data can be copied in one move */ 359 360 result_array = result_vb -> value_bead.data_pointer; 361 362 right_vb = apl_push_stack_ (words_needed); 363 number_to_copy = words_needed_in_bead; /* the words in the bead for the result, from stack_allocate */ 364 right_vb -> word_copy_overlay = /* copy words from bead to end bead */ 365 result_vb -> word_copy_overlay; 366 367 right_array = addrel (right_vb, words_needed_in_bead); /* try next word after bead */ 368 if right_vb -> value_bead.numeric_value 369 then if substr (rel (right_array), 18, 1) /* if a 1 in low order bit, odd aligned */ 370 then right_array = addrel (right_array, 1); 371 right_vb -> value_bead.data_pointer = right_array; /* pointer to data */ 372 373 number_to_copy = data_words_needed; /* number of data words to move */ 374 if number_to_copy > 0 then /* zero length arrays are illegal PL/I */ 375 right_array -> word_copy_overlay = /* move in data */ 376 result_array -> word_copy_overlay; 377 operators_argument.result = right_vb; 378 return; 379 380 /* places to go to when an error is found */ 381 382 rank_error_left: 383 operators_argument.error_code = apl_error_table_$rank; 384 operators_argument.where_error = operators_argument.where_error + 1; 385 return; 386 387 domain_error_left: 388 operators_argument.where_error = operators_argument.where_error + 2; 389 390 domain_error_right: 391 operators_argument.where_error = operators_argument.where_error - 1; 392 operators_argument.error_code = apl_error_table_$domain; 393 return; 394 395 length_error_right: 396 operators_argument.error_code = apl_error_table_$length; 397 operators_argument.where_error = operators_argument.where_error - 1; 398 return; 399 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 =============================== */ 6 2 6 3 /* format: style3 */ 6 4 apl_push_stack_: 6 5 procedure (P_n_words) returns (ptr); 6 6 6 7 /* Function to (1) double-word align ws_info.value_stack_ptr, and 6 8* (2) make sure allocation request will fit on current value stack. 6 9* 6 10* Written 770413 by PG 6 11* Modified 780210 by PG to round allocations up to an even number of words. 6 12**/ 6 13 6 14 /* parameters */ 6 15 6 16 declare P_n_words fixed bin (19) parameter; 6 17 6 18 /* automatic */ 6 19 6 20 declare block_ptr ptr, 6 21 num_words fixed bin (19); 6 22 6 23 /* builtins */ 6 24 6 25 declare (addrel, binary, rel, substr, unspec) 6 26 builtin; 6 27 6 28 /* entries */ 6 29 6 30 declare apl_get_value_stack_ 6 31 entry (fixed bin (19)); 6 32 6 33 /* program */ 6 34 6 35 num_words = P_n_words; 6 36 6 37 if substr (unspec (num_words), 36, 1) = "1"b /* num_words odd */ 6 38 then num_words = num_words + 1; 6 39 6 40 if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size 6 41 then call apl_get_value_stack_ (num_words); 6 42 6 43 block_ptr = ws_info.value_stack_ptr; 6 44 ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words); 6 45 return (block_ptr); 6 46 6 47 end apl_push_stack_; 6 48 6 49 /* ------ END INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 ------------------------------- */ 400 401 end apl_monadic_rho_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1346.9 apl_monadic_rho_.pl1 >special_ldd>on>apl.1129>apl_monadic_rho_.pl1 116 1 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 117 2 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 118 3 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 119 4 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 120 5 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 400 6 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 6-16 ref 6-4 6-35 abs builtin function dcl 95 ref 241 244 284 286 addrel builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-44 addrel builtin function dcl 95 in procedure "apl_monadic_rho_" ref 151 152 367 368 apl_error_table_$domain 000020 external static fixed bin(35,0) dcl 88 ref 392 apl_error_table_$length 000016 external static fixed bin(35,0) dcl 88 ref 395 apl_error_table_$rank 000014 external static fixed bin(35,0) dcl 88 ref 382 apl_get_value_stack_ 000024 constant entry external dcl 6-30 ref 6-40 apl_iota_appendage_ 000010 constant entry external dcl 83 ref 249 apl_rho_appendage_ 000012 constant entry external dcl 84 ref 320 apl_static_$ws_info_ptr 000022 external static structure level 1 dcl 5-11 automatic_storage 000147 automatic fixed bin(35,0) array dcl 108 set ref 320* binary builtin function dcl 6-25 ref 6-40 block_ptr 000212 automatic pointer dcl 6-20 set ref 6-43* 6-45 character_string_overlay based char dcl 4-19 ref 140 character_value 0(09) based bit(1) level 5 in structure "value_bead" packed unaligned dcl 4-3 in procedure "apl_monadic_rho_" set ref 298 character_value 0(09) 000146 automatic bit(1) level 3 in structure "free_type" packed unaligned dcl 79 in procedure "apl_monadic_rho_" set ref 236 count 000131 automatic fixed bin(17,0) dcl 63 set ref 276* 280 283 284 289* data_elements 000116 automatic fixed bin(21,0) dcl 51 set ref 133 140 140 156 195* 221* 225* 226 230 231 245* 247 249* 262* 268* 276 292* 312 data_pointer 4 based pointer level 2 packed unaligned dcl 4-3 set ref 158* 171 179 360 371* data_type 0(08) 000146 automatic structure level 2 in structure "free_type" packed unaligned dcl 79 in procedure "apl_monadic_rho_" data_type 0(08) based structure level 4 in structure "value_bead" packed unaligned dcl 4-3 in procedure "apl_monadic_rho_" data_words_needed 000121 automatic fixed bin(19,0) dcl 57 set ref 133* 140* 149 221* 226* 373 error_code 7 parameter fixed bin(35,0) level 2 dcl 2-3 set ref 382* 392* 395* fixed builtin function dcl 95 ref 245 289 343 float builtin function dcl 95 ref 198 float_index_origin 10 based float bin(63) level 3 dcl 5-16 set ref 232 249* float_temp 000144 automatic float bin(63) dcl 72 set ref 283* 284 286 289 floor builtin function dcl 95 ref 240 283 free_type 000146 automatic structure level 1 dcl 79 set ref 212* fuzz 6 based float bin(63) level 3 in structure "ws_info" dcl 5-16 in procedure "apl_monadic_rho_" ref 183 fuzz 000136 automatic float bin(63) dcl 72 in procedure "apl_monadic_rho_" set ref 183* general_bead based structure level 1 dcl 3-3 header based structure level 2 dcl 4-3 integer_fuzz 000140 automatic float bin(63) dcl 72 in procedure "apl_monadic_rho_" set ref 184* 241 280 284 integer_fuzz 22 based float bin(63) level 2 in structure "ws_info" dcl 5-16 in procedure "apl_monadic_rho_" ref 184 integral_value 0(11) 000146 automatic bit(1) level 3 packed unaligned dcl 79 set ref 241 integral_value_type constant bit(18) initial unaligned dcl 3-30 ref 203 248 left_array 000110 automatic pointer dcl 42 set ref 171* 276 276 280 283 284 left_data_elements 000120 automatic fixed bin(21,0) dcl 51 set ref 172* 262 274 292 left_rhorho 000125 automatic fixed bin(17,0) dcl 63 set ref 173* 259 left_vb 000106 automatic pointer dcl 42 set ref 170* 171 172 173 271 337 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 5-16 ref 343 6-40 num_words 000214 automatic fixed bin(19,0) dcl 6-20 set ref 6-35* 6-37 6-37* 6-37 6-40 6-40* 6-44 number_of_dimensions 000157 automatic fixed bin(17,0) dcl 4-3 set ref 146* 148 number_to_copy 000122 automatic fixed bin(19,0) dcl 57 set ref 363* 364 373* 374 374 numeric_datum based float bin(63) array dcl 4-23 set ref 198* 220 232* 238 numeric_datum_or1 based float bin(63) array dcl 112 ref 133 226 276 276 280 283 284 numeric_result 000132 automatic bit(1) unaligned dcl 70 set ref 132* 139* 152 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 4-3 set ref 271 368 on_stack 1 parameter bit(1) array level 3 dcl 2-3 ref 191 214 327 327 operands parameter structure array level 2 dcl 2-3 operators_argument parameter structure level 1 dcl 2-3 set ref 25 208 253 pointers 14 based structure level 2 dcl 5-16 prod builtin function dcl 95 ref 292 rel builtin function dcl 95 in procedure "apl_monadic_rho_" ref 152 343 368 rel builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-40 result 6 parameter pointer level 2 packed unaligned dcl 2-3 set ref 159* 333* 345* 377* result_accumulator 000142 automatic float bin(63) dcl 72 set ref 238* 239 240 241 result_array 000114 automatic pointer dcl 42 set ref 151* 152 152* 152 158 198 232 249* 336* 337* 338* 343 351 360* 374 result_vb 000112 automatic pointer dcl 42 set ref 150* 151 156 157 158 159 201 203 229 230 247 248 306 309 320 333 345 360 364 rho 5 based fixed bin(21,0) array level 2 dcl 4-3 set ref 198 201* 230* 247* 306* rho_subscript 000130 automatic fixed bin(17,0) dcl 63 set ref 197* 198 198* 304* 306 306* rhorho 000127 automatic fixed bin(17,0) dcl 63 in procedure "apl_monadic_rho_" set ref 146 157 194* 218* 262* 268 304 rhorho 3 based fixed bin(17,0) level 2 in structure "value_bead" dcl 4-3 in procedure "apl_monadic_rho_" set ref 157* 173 181 right_array 000104 automatic pointer dcl 42 set ref 179* 220 238 367* 368 368* 368 371 374 right_data_elements 000117 automatic fixed bin(21,0) dcl 51 set ref 180* 217 218 315 right_rhorho 000126 automatic fixed bin(17,0) dcl 63 set ref 181* 195 197 201 right_vb 000102 automatic pointer dcl 42 set ref 178* 179 180 181 191 198 212 214 298 309 320 338 362* 364 367 368 371 377 saved_left_arg based fixed bin(21,0) array dcl 37 set ref 289* 292 306 saved_left_arg_ptr 000100 automatic pointer initial dcl 38 set ref 38* 266* 274* 289 292 306 327 336 single_element_fl_1 000134 automatic float bin(63) dcl 72 set ref 240* 241 244 245 size builtin function dcl 95 ref 133 140 148 226 static_ws_info_ptr 000022 external static pointer level 2 packed unaligned dcl 5-11 ref 5-7 string builtin function dcl 95 set ref 203* 212* 212 229* 248* 309* 309 substr builtin function dcl 6-25 in procedure "apl_push_stack_" ref 6-37 substr builtin function dcl 95 in procedure "apl_monadic_rho_" ref 152 368 total_data_elements 2 based fixed bin(21,0) level 2 dcl 4-3 set ref 156* 172 180 type based structure level 3 in structure "value_bead_overlay" packed unaligned dcl 30 in procedure "apl_monadic_rho_" type based structure level 3 in structure "value_bead" packed unaligned dcl 4-3 in procedure "apl_monadic_rho_" set ref 203* 212 229* 248* 309* 309 type based structure level 2 in structure "general_bead" packed unaligned dcl 3-3 in procedure "apl_monadic_rho_" unspec builtin function dcl 6-25 ref 6-37 value parameter pointer array level 3 packed unaligned dcl 2-3 ref 170 178 value_bead based structure level 1 dcl 4-3 set ref 148 value_bead_overlay based structure level 1 dcl 30 set ref 320* 320* value_stack_ptr 16 based pointer level 3 packed unaligned dcl 5-16 set ref 191* 214* 351* 6-40 6-43 6-44* 6-44 values 2 based structure level 2 dcl 5-16 where_error 10 parameter fixed bin(17,0) level 2 dcl 2-3 set ref 384* 384 387* 387 390* 390 397* 397 word_copy_overlay based fixed bin(35,0) array dcl 110 set ref 364* 364 374* 374 words_needed 000123 automatic fixed bin(19,0) dcl 57 set ref 149* 150* 343 362* words_needed_in_bead 000124 automatic fixed bin(19,0) dcl 57 set ref 148* 149 151 363 367 ws_info based structure level 1 dcl 5-16 ws_info_ptr 000160 automatic pointer initial dcl 5-7 set ref 191 214 232 249 343 351 5-7* 183 184 6-40 6-40 6-43 6-44 6-44 zero_or_one_value 0(12) 000146 automatic bit(1) level 3 packed unaligned dcl 79 set ref 219 zero_or_one_value_type constant bit(18) initial unaligned dcl 3-30 ref 229 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 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 4-15 character_value_type internal static bit(18) initial unaligned dcl 3-30 complex_datum based complex float bin(63) array dcl 4-26 complex_value_type internal static bit(18) initial unaligned dcl 3-30 divide builtin function dcl 95 function_type internal static bit(18) initial unaligned dcl 3-30 group_type internal static bit(18) initial unaligned dcl 3-30 label_type internal static bit(18) initial unaligned dcl 3-30 lexed_function_type internal static bit(18) initial unaligned dcl 3-30 list_value_type internal static bit(18) initial unaligned dcl 3-30 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 5-98 not_integer_mask internal static bit(18) initial unaligned dcl 3-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 3-30 numeric_value_type 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 shared_variable_type internal static bit(18) initial unaligned dcl 3-30 symbol_type internal static bit(18) initial unaligned dcl 3-30 value_type internal static bit(18) initial unaligned dcl 3-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_dyadic_rho_ 000267 constant entry external dcl 253 apl_monadic_iota_ 000124 constant entry external dcl 208 apl_monadic_rho_ 000050 constant entry external dcl 25 apl_push_stack_ 000733 constant entry internal dcl 6-4 ref 150 274 362 copy_up_stack 000457 constant label dcl 327 ref 312 322 domain_error_left 000577 constant label dcl 387 ref 271 280 284 286 domain_error_right 000603 constant label dcl 390 set ref 236 239 241 244 315 dyadic_extract 000677 constant entry internal dcl 165 ref 257 length_error_right 000613 constant label dcl 395 set ref 217 monadic_extract 000712 constant entry internal dcl 175 ref 189 211 rank_error_left 000570 constant label dcl 382 ref 259 stack_allocate_char 000630 constant entry internal dcl 136 ref 298 stack_allocate_known 000637 constant entry internal dcl 143 ref 228 stack_allocate_known_common 000640 constant label dcl 146 ref 134 stack_allocate_numeric 000621 constant entry internal dcl 129 ref 196 246 300 NAMES DECLARED BY CONTEXT OR IMPLICATION. hbound builtin function ref 276 lbound builtin function ref 276 null builtin function ref 38 266 327 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1154 1202 1020 1164 Length 1506 1020 26 270 133 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_monadic_rho_ 164 external procedure is an external procedure. stack_allocate_numeric internal procedure shares stack frame of external procedure apl_monadic_rho_. dyadic_extract internal procedure shares stack frame of external procedure apl_monadic_rho_. apl_push_stack_ internal procedure shares stack frame of external procedure apl_monadic_rho_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_monadic_rho_ 000100 saved_left_arg_ptr apl_monadic_rho_ 000102 right_vb apl_monadic_rho_ 000104 right_array apl_monadic_rho_ 000106 left_vb apl_monadic_rho_ 000110 left_array apl_monadic_rho_ 000112 result_vb apl_monadic_rho_ 000114 result_array apl_monadic_rho_ 000116 data_elements apl_monadic_rho_ 000117 right_data_elements apl_monadic_rho_ 000120 left_data_elements apl_monadic_rho_ 000121 data_words_needed apl_monadic_rho_ 000122 number_to_copy apl_monadic_rho_ 000123 words_needed apl_monadic_rho_ 000124 words_needed_in_bead apl_monadic_rho_ 000125 left_rhorho apl_monadic_rho_ 000126 right_rhorho apl_monadic_rho_ 000127 rhorho apl_monadic_rho_ 000130 rho_subscript apl_monadic_rho_ 000131 count apl_monadic_rho_ 000132 numeric_result apl_monadic_rho_ 000134 single_element_fl_1 apl_monadic_rho_ 000136 fuzz apl_monadic_rho_ 000140 integer_fuzz apl_monadic_rho_ 000142 result_accumulator apl_monadic_rho_ 000144 float_temp apl_monadic_rho_ 000146 free_type apl_monadic_rho_ 000147 automatic_storage apl_monadic_rho_ 000157 number_of_dimensions apl_monadic_rho_ 000160 ws_info_ptr apl_monadic_rho_ 000212 block_ptr apl_push_stack_ 000214 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 call_ext_out return fl2_to_fx1 mpfx2 ext_entry floor_fl THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_get_value_stack_ apl_iota_appendage_ apl_rho_appendage_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. apl_error_table_$domain apl_error_table_$length apl_error_table_$rank apl_static_$ws_info_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 38 000036 5 7 000040 25 000045 189 000056 191 000057 194 000067 195 000071 196 000073 197 000074 198 000102 200 000111 201 000114 203 000117 204 000121 208 000122 211 000132 212 000133 214 000136 217 000146 218 000151 219 000152 220 000155 221 000157 223 000161 225 000162 226 000164 228 000166 229 000167 230 000172 231 000175 232 000176 234 000201 236 000202 238 000205 239 000207 240 000210 241 000213 244 000224 245 000233 246 000236 247 000237 248 000242 249 000244 250 000264 253 000265 257 000275 259 000276 262 000301 266 000304 268 000306 271 000313 274 000316 276 000322 280 000331 283 000337 284 000344 286 000351 289 000360 290 000365 292 000367 298 000410 300 000415 304 000416 306 000425 307 000432 309 000434 312 000437 315 000441 320 000443 322 000456 327 000457 333 000473 334 000475 336 000476 337 000501 338 000504 343 000506 345 000514 346 000516 351 000517 360 000521 362 000524 363 000526 364 000530 367 000536 368 000542 371 000553 373 000554 374 000556 377 000564 378 000567 382 000570 384 000575 385 000576 387 000577 390 000603 392 000607 393 000612 395 000613 397 000616 398 000620 129 000621 132 000622 133 000624 134 000627 136 000630 139 000631 140 000632 143 000636 146 000640 148 000642 149 000644 150 000647 151 000651 152 000655 156 000665 157 000670 158 000672 159 000673 161 000676 165 000677 170 000700 171 000703 172 000705 173 000707 175 000711 178 000713 179 000717 180 000721 181 000723 183 000725 184 000730 185 000732 6 4 000733 6 35 000735 6 37 000737 6 40 000744 6 43 000761 6 44 000764 6 45 000773 ----------------------------------------------------------- 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