COMPILATION LISTING OF SEGMENT apl_quadcall_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1613.6 mst Tue Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1983 * 4* * * 5* *********************************************************** */ 6 apl_quadcall_: proc (operators_argument); 7 8 /* Author: H. Hoover, Univeristy of Calgary, 81-06-05. */ 9 10 /* Modification history: */ 11 /* */ 12 /* 81-12-11 (HH): Added support for 'options (variable)' description of */ 13 /* parameters. */ 14 /* 82-01-06 (HH): Added support for parameter type 'entry'. */ 15 /* 83-11-21 (AD): Changed addr(substr(foo)) to based character array */ 16 /* references (which should be replaced later by addcharno). */ 17 18 /* Function: an APL system function to provide APL users the ability to */ 19 /* call a FORTRAN or PL/I routine. If the routine is a subroutine, no */ 20 /* result is returned to APL. But if the routine is a function, the */ 21 /* function's value is returned as the result. */ 22 23 /* Syntax: Function call: V -< qCALL (entry_dcl; arg1; arg2; ...; argN) */ 24 /* Subroutine call: qCALL (entry_dcl; arg1; arg2; ...; argN) */ 25 /* */ 26 /* where 'q' is the APL quad symbol. */ 27 28 /* Arguments: */ 29 /* */ 30 /* entry_dcl (Input) */ 31 /* is an APL character value containing a PL/I style entry declaration */ 32 /* specifying the routine to be called, the number of arguments it */ 33 /* takes, whether it is a subroutine or function, and the types of the */ 34 /* arguments and function value. (See 'Entry Declaration' below for */ 35 /* details.) */ 36 /* */ 37 /* arg1, arg2, ... argN (Update) */ 38 /* are the APL variables and values to be used as the arguments of the */ 39 /* routine which is being called. If an argument is a simple variable */ 40 /* (as opposed to a constant, an expression or an indexed variable), the */ 41 /* value of that variable is updated to reflect any changes made by the */ 42 /* called routine. */ 43 44 /* Entry Declaration: */ 45 /* */ 46 /* The entry declaration is identical to that of PL/I (except that the */ 47 /* 'entry' keyword is optional), with the following restrictions: */ 48 /* */ 49 /* (1) The attributes in a parameter declaration must be in the folowing */ 50 /* order: dimensions, type, size and alignment. */ 51 /* (2) A lower bound may not be specified for a dimension. */ 52 /* (3) The mode (i.e 'real' or 'complex') may not be specified. */ 53 /* (4) The only types supported are: bit, char, entry, fixed bin, and */ 54 /* float bin. */ 55 /* (5) Neither dimensions nor parameter descriptions (other than 'options */ 56 /* (variable)') may be specified for 'entry' values. */ 57 /* (6) A scale factor may not be specified for 'fixed' values. */ 58 /* (7) 'fixed' and 'float' values may not be unaligned. */ 59 /* */ 60 /* A typical declaration would be: */ 61 /* 'get_line_length_$stream(char(*), fixed bin(35)) returns(fixed bin)' */ 62 63 /* Notes: */ 64 /* */ 65 /* (1) If a simple variable is passed as an argument, that variable need */ 66 /* not have been previously assigned a value. In such a case, the */ 67 /* value passed to the called routine for that argument has the shape */ 68 /* and type indicated by the entry declaration and is initialized to */ 69 /* binary zeroes. */ 70 /* */ 71 /* (2) The value of an argument must agree with the type specified in the */ 72 /* entry declaration. For example, if an argument is to be passed as a */ 73 /* 'bit' value, it must be numeric and contain only zeroes and ones. */ 74 /* */ 75 /* (3) The shape of an argument must agree with that specified in the entry */ 76 /* declaration. This usually means that an argument has the shape */ 77 /* indicated by the declaration. However, an argument that is to be */ 78 /* passed as a 'bit' or 'char' value is also considered to have the */ 79 /* correct shape if its rank is one greater than in the declaration, */ 80 /* its shape when the last dimension is excluded is the same as in the */ 81 /* declaration, and the length of the last dimension is the same as the */ 82 /* size attribute in the declaration. For example a 3x4 character */ 83 /* matrix may be passed as '(3, 4) char (1)' or '(3) char (4)'. */ 84 /* */ 85 /* (4) Either a positive integer or an asterisk may be used in the entry */ 86 /* declaration to specify the length of a dimension or the size of a */ 87 /* 'bit' or 'char' value. An asterisk in a dimension specification */ 88 /* means use the current length of the corresponding dimension of the */ 89 /* argument. An asterisk in a size attribute means use the current */ 90 /* length of the last dimension of the argument. Asterisks may not be */ 91 /* used when the corresponding argument is a simple variable that has */ 92 /* not yet been assigned a value. Asterisks may only be used in the */ 93 /* 'returns' attribute if the routine being called was written in PL/I */ 94 /* and contains asterisks in the 'returns' attribute of its header. */ 95 /* */ 96 /* (5) If 'options (variable)' is given in place of parameter declarations, */ 97 /* any number of arguments may be supplied. A rank N numeric argument */ 98 /* is passed as an N-dimension array of 'float bin(63)' numbers. A */ 99 /* rank N character argument is passed as an (N-1)-dimension array of */ 100 /* 'char(M)', where M is the size of the argument's last dimension. */ 101 102 dcl cu_$generate_call entry (entry, ptr), 103 sys_info$max_seg_size fixed bin (35) ext static; 104 105 dcl null builtin, 106 size builtin; 107 108 dcl False bit (1) static options (constant) init ("0"b), 109 Function fixed bin static options (constant) init (0), 110 Left_arg fixed bin static options (constant) init (1), 111 Max_rank fixed bin static options (constant) init (15), 112 Right_arg fixed bin static options (constant) init (2), 113 Token_chars char (63) static options (constant) init 114 ("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"), 115 True bit (1) static options (constant) init ("1"b), 116 Type_bit fixed bin static options (constant) init (19), 117 Type_char fixed bin static options (constant) init (21), 118 Type_entry fixed bin static options (constant) init (16), 119 Type_fixed_bin_long fixed bin static options (constant) init (2), 120 Type_fixed_bin_short fixed bin static options (constant) init (1), 121 Type_float_bin_long fixed bin static options (constant) init (4), 122 Type_float_bin_short fixed bin static options (constant) init (3); 123 124 dcl aligned_char_vec_len fixed bin (21), 125 aligned_char_vec_ptr ptr, 126 aligned_char_vec_size fixed bin (21), 127 arg_list_arg_count fixed bin, 128 argument_desc_ptr ptr, 129 argument_list_ptr ptr, 130 bit_vec_len fixed bin (24), 131 bit_vec_pad fixed bin, 132 bit_vec_ptr ptr, 133 bit_vec_size fixed bin (24), 134 bits_in_result fixed bin (24), 135 calling_a_function bit (1), 136 declaration_len fixed bin, 137 declaration_ptr ptr, 138 fixed_bin_long_vec_len fixed bin (17), 139 fixed_bin_long_vec_ptr ptr, 140 fixed_bin_short_vec_len fixed bin (18), 141 fixed_bin_short_vec_ptr ptr, 142 float_bin_long_vec_len float bin (17), 143 float_bin_long_vec_ptr ptr, 144 float_bin_short_vec_len float bin (18), 145 float_bin_short_vec_ptr ptr, 146 list_ptr ptr, 147 marker_ptr ptr, 148 routine entry variable, 149 token_idx fixed bin, 150 token_len fixed bin, 151 unaligned_char_vec_len fixed bin (21), 152 unaligned_char_vec_ptr ptr, 153 unaligned_char_vec_size fixed bin (21); 154 155 dcl 01 argument_desc based (argument_desc_ptr), 156 02 header like arg_descriptor, 157 02 dimension_info (argument_desc.number_dims), 158 03 lower_bound fixed bin (35), 159 03 upper_bound fixed bin (35), 160 03 multiplier fixed bin (35); 161 162 dcl 01 argument_list based (argument_list_ptr) like arg_list; 163 164 dcl aligned_char_vec (aligned_char_vec_len) char (aligned_char_vec_size) aligned based (aligned_char_vec_ptr), 165 bit_vec (bit_vec_len) bit (bit_vec_size + bit_vec_pad) based (bit_vec_ptr), 166 declaration char (declaration_len) based (declaration_ptr), 167 fixed_bin_long_vec (fixed_bin_long_vec_len) fixed bin (71) based (fixed_bin_long_vec_ptr), 168 fixed_bin_short_vec (fixed_bin_short_vec_len) fixed bin (35) based (fixed_bin_short_vec_ptr), 169 float_bin_long_vec (float_bin_long_vec_len) float bin (63) based (float_bin_long_vec_ptr), 170 float_bin_short_vec (float_bin_short_vec_len) float bin (27) based (float_bin_short_vec_ptr), 171 marker (0:n_members) fixed bin based (marker_ptr), 172 dummy_chars (4*sys_info$max_seg_size) char (1) unaligned based, 173 token char (token_len) based (addr (declaration_ptr -> dummy_chars (token_idx))), 174 unaligned_char_vec (unaligned_char_vec_len) char (unaligned_char_vec_size) unaligned based (unaligned_char_vec_ptr); 175 call validate_usage; 176 call allocate_table_space; 177 call process_declaration; 178 call convert_arguments; 179 if calling_a_function 180 then begin; 181 dcl result_buf bit (bits_in_result) aligned init (""b); /* Not on APL value stack to simplify garbage collection. */ 182 if bits_in_result = 0 183 then argument_list.arg_ptrs (arg_list_arg_count) = addr (argument_list.arg_ptrs (arg_list_arg_count)); 184 else argument_list.arg_ptrs (arg_list_arg_count) = addr (result_buf); 185 call cu_$generate_call (routine, argument_list_ptr); 186 call update_byname_arguments; 187 call collect_garbage; 188 call assign_result; 189 end; 190 else do; 191 call cu_$generate_call (routine, argument_list_ptr); 192 call update_byname_arguments; 193 call collect_garbage; 194 operators_argument.result = null; 195 end; 196 operators_argument.error_code = 0; 197 return; 198 allocate_argument_storage: proc (value_ptr); 199 200 /* Function: to allocate a value bead, from the APL heap, of a size that */ 201 /* is appropriate for the current value of an argument. */ 202 203 /* Arguments: */ 204 /* */ 205 /* value_ptr (Output) */ 206 /* the address of the value bead that was allocated. */ 207 208 /* Global Arguments: */ 209 /* */ 210 /* argument_desc (Input) */ 211 /* the argument descriptor describing the value that will be placed in */ 212 /* the value bead to be allocated. */ 213 214 /* Notes: */ 215 /* */ 216 /* (1) The value bead is initialized according to the rank, shape and type */ 217 /* specified by the argument descriptor, but the data area is left for */ 218 /* for the caller to initialize. */ 219 220 dcl value_ptr ptr; 221 222 dcl apl_allocate_words_ entry (fixed bin (18), ptr unaligned); 223 224 dcl bead_size fixed bin (18), 225 data_size fixed bin (18), 226 i fixed bin, 227 last_dimension_implicit bit (1), 228 unaligned_value_ptr ptr unaligned, 229 value_size fixed bin (18); 230 231 /* Calculate the value's size and allocate storage for it. */ 232 233 data_elements = 1; 234 number_of_dimensions = argument_desc.number_dims; 235 do i = 1 to number_of_dimensions; 236 data_elements = argument_desc.upper_bound (i)*data_elements; 237 end; 238 if (argument_desc.type = Type_bit | argument_desc.type = Type_char) & argument_desc.size > 1 239 then do; 240 last_dimension_implicit = True; 241 number_of_dimensions = number_of_dimensions + 1; 242 data_elements = argument_desc.size*data_elements; 243 end; 244 else last_dimension_implicit = False; 245 bead_size = round_to_even (size (value_bead)); 246 if argument_desc.type = Type_char 247 then data_size = round_to_even (size (character_string_overlay)); 248 else data_size = size (numeric_datum); 249 value_size = bead_size + data_size; 250 call apl_allocate_words_ (value_size, unaligned_value_ptr); 251 value_ptr = unaligned_value_ptr; 252 253 /* Initialize the bead. */ 254 255 if argument_desc.type = Type_char 256 then string (value_ptr -> value_bead.type) = character_value_type; 257 else if argument_desc.type = Type_bit 258 then string (value_ptr -> value_bead.type) = zero_or_one_value_type; 259 else if argument_desc.type = Type_fixed_bin_short | argument_desc.type = Type_fixed_bin_long 260 then string (value_ptr -> value_bead.type) = integral_value_type; 261 else string (value_ptr -> value_bead.type) = numeric_value_type; 262 value_ptr -> value_bead.size = bit (value_size, 18); 263 value_ptr -> value_bead.reference_count = 1; 264 value_ptr -> value_bead.total_data_elements = data_elements; 265 value_ptr -> value_bead.rhorho = number_of_dimensions; 266 value_ptr -> value_bead.data_pointer = addrel (value_ptr, bead_size); 267 number_of_dimensions = argument_desc.number_dims; 268 do i = 1 to number_of_dimensions; 269 value_ptr -> value_bead.rho (i) = argument_desc.upper_bound (number_of_dimensions - i + 1); 270 end; 271 if last_dimension_implicit 272 then value_ptr -> value_bead.rho (i) = argument_desc.size; 273 end allocate_argument_storage; 274 allocate_table_space: proc; 275 276 /* Function: to allocate space on the APL value stack to hold the tables */ 277 /* created from the declaration: the argument list (which must be even */ 278 /* word aligned), the argument descriptors, and the declaration marker */ 279 /* array. */ 280 281 /* Global Arguments: */ 282 /* */ 283 /* arg_list_arg_count (Output) */ 284 /* is set equal to 'n_members', which is either the correct argument */ 285 /* count (if we are calling a function), or one more than the correct */ 286 /* count (if we are calling a subroutine). */ 287 /* */ 288 /* argument_desc_ptr (Output) */ 289 /* is the address of the storage allocated for the argument descriptors. */ 290 /* */ 291 /* argument_list_ptr (Output) */ 292 /* is the address of the storage allocated for the argument list. It is */ 293 /* even-word aligned. */ 294 /* */ 295 /* list_ptr (Input) */ 296 /* is the address of the list bead for our right argument. */ 297 /* */ 298 /* marker_ptr (Output) */ 299 /* is the address of the storage allocated for the marker array. */ 300 /* */ 301 /* n_members (Input) */ 302 /* is the number of members in the list passed as our right argument. */ 303 304 dcl descriptor_space fixed bin, 305 i fixed bin, 306 member_ptr ptr, 307 rank fixed bin; 308 309 /* Calculate the number of words needed to hold the argument descriptors. */ 310 /* Each descriptor requires 1 word for the header and, if the argument is */ 311 /* not a scalar, 3 words for each dimension. We can determine the size of */ 312 /* the descriptor needed for each input argument from the rank of its */ 313 /* value. However, we won't know the rank of any output only arguments */ 314 /* until we have decoded the declaration, so we must assume the maximum */ 315 /* rank for these. Similarly, we do not yet know if we are calling a */ 316 /* subroutine or function, so we must assume we are calling a function and */ 317 /* that its return value is of maximum rank. */ 318 319 descriptor_space = 3*Max_rank + 1; /* Space for result descriptor. */ 320 do i = 2 to n_members; /* Add space for argument descriptors. */ 321 member_ptr = list_ptr -> list_bead.member_ptr (i); 322 if member_ptr -> general_bead.symbol 323 then if member_ptr -> symbol_bead.meaning_pointer = null 324 then rank = Max_rank; 325 else rank = member_ptr -> symbol_bead.meaning_pointer -> value_bead.rhorho; 326 else rank = member_ptr -> value_bead.rhorho; 327 descriptor_space = descriptor_space + 3*rank + 1; 328 end; 329 330 /* Allocate one block of storage to contain the argument list, followed by */ 331 /* the argument descriptors, followed by the marker array. */ 332 333 arg_list_arg_count = n_members; 334 argument_list_ptr = apl_push_stack_ (size (argument_list) + descriptor_space + size (marker)); 335 argument_desc_ptr = addrel (argument_list_ptr, size (argument_list)); 336 marker_ptr = addrel (argument_desc_ptr, descriptor_space); 337 end allocate_table_space; 1 1 /* ====== BEGIN INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 =============================== */ 1 2 1 3 /* format: style3 */ 1 4 apl_push_stack_: 1 5 procedure (P_n_words) returns (ptr); 1 6 1 7 /* Function to (1) double-word align ws_info.value_stack_ptr, and 1 8* (2) make sure allocation request will fit on current value stack. 1 9* 1 10* Written 770413 by PG 1 11* Modified 780210 by PG to round allocations up to an even number of words. 1 12**/ 1 13 1 14 /* parameters */ 1 15 1 16 declare P_n_words fixed bin (19) parameter; 1 17 1 18 /* automatic */ 1 19 1 20 declare block_ptr ptr, 1 21 num_words fixed bin (19); 1 22 1 23 /* builtins */ 1 24 1 25 declare (addrel, binary, rel, substr, unspec) 1 26 builtin; 1 27 1 28 /* entries */ 1 29 1 30 declare apl_get_value_stack_ 1 31 entry (fixed bin (19)); 1 32 1 33 /* program */ 1 34 1 35 num_words = P_n_words; 1 36 1 37 if substr (unspec (num_words), 36, 1) = "1"b /* num_words odd */ 1 38 then num_words = num_words + 1; 1 39 1 40 if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size 1 41 then call apl_get_value_stack_ (num_words); 1 42 1 43 block_ptr = ws_info.value_stack_ptr; 1 44 ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words); 1 45 return (block_ptr); 1 46 1 47 end apl_push_stack_; 1 48 1 49 /* ------ END INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 ------------------------------- */ 338 339 assign_result: proc; 340 341 /* Function: to convert the result of the function just called to an APL */ 342 /* value and set that value as our result. */ 343 344 /* Global Arguments: */ 345 /* */ 346 /* argument_desc (Input) */ 347 /* the argument descriptor for the result. */ 348 /* */ 349 /* argument_list (Input) */ 350 /* the argument list for the call that created the result. */ 351 /* */ 352 /* operators_argument.result (Output) */ 353 /* the address of the APL value bead created for the converted result. */ 354 355 dcl bead_ptr ptr, 356 bead_size fixed bin (18), 357 data_ptr ptr, 358 data_size fixed bin (18), 359 i fixed bin, 360 j fixed bin, 361 k fixed bin, 362 last_dimension_implicit bit (1); 363 364 /* Create the value bead for the result. */ 365 366 argument_desc_ptr = argument_list.desc_ptrs (arg_list_arg_count); 367 data_elements = 1; 368 number_of_dimensions = argument_desc.number_dims; 369 do i = 1 to number_of_dimensions; 370 data_elements = data_elements*argument_desc.upper_bound (i); 371 end; 372 if (argument_desc.type = Type_bit | argument_desc.type = Type_char) & argument_desc.size > 1 373 then do; 374 last_dimension_implicit = True; 375 data_elements = data_elements*argument_desc.size; 376 number_of_dimensions = number_of_dimensions + 1; 377 end; 378 else last_dimension_implicit = False; 379 bead_size = round_to_even (size (value_bead)); 380 if argument_desc.type = Type_char 381 then data_size = round_to_even (divide (data_elements + 3, 4, 18)); 382 else data_size = 2*data_elements; 383 if bead_size + data_size > MAX_VALUE_BEAD_SIZE 384 then call error (apl_error_table_$result_size, Function); 385 operators_argument.result, bead_ptr = apl_push_stack_ (bead_size + data_size); 386 bead_ptr -> value_bead.total_data_elements = data_elements; 387 bead_ptr -> value_bead.rhorho = number_of_dimensions; 388 bead_ptr -> value_bead.data_pointer, data_ptr = addrel (bead_ptr, bead_size); 389 do i = 1 to argument_desc.number_dims; 390 bead_ptr -> value_bead.rho (i) = argument_desc.upper_bound (argument_desc.number_dims - i + 1); 391 end; 392 if last_dimension_implicit 393 then bead_ptr -> rho (number_of_dimensions) = argument_desc.size; 394 395 /* Convert the result to APL format. */ 396 397 if argument_desc.type = Type_bit 398 then do; 399 string (bead_ptr -> value_bead.type) = zero_or_one_value_type; 400 float_bin_long_vec_len = data_elements; 401 float_bin_long_vec_ptr = data_ptr; 402 if argument_desc.packed | mod (argument_desc.size, 36) = 0 403 then do; 404 bit_vec_size = float_bin_long_vec_len; 405 bit_vec_len = 1; 406 end; 407 else do; 408 bit_vec_size = argument_desc.size; 409 bit_vec_len = divide (float_bin_long_vec_len, bit_vec_size, 24); 410 end; 411 bit_vec_pad = 36*divide (bit_vec_size + 35, 36, 24) - bit_vec_size; 412 bit_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count); 413 i = 1; 414 do j = 1 to bit_vec_len; 415 do k = 1 to bit_vec_size; 416 float_bin_long_vec (i) = float (substr (bit_vec (j), k, 1)); 417 i = i + 1; 418 end; 419 end; 420 end; 421 else if argument_desc.type = Type_char 422 then do; 423 string (bead_ptr -> value_bead.type) = character_value_type; 424 if ^argument_desc.packed | mod (argument_desc.size, 4) ^= 0 425 then do; 426 unaligned_char_vec_size = argument_desc.size; 427 unaligned_char_vec_len = divide (data_elements, 428 unaligned_char_vec_size, 21); 429 unaligned_char_vec_ptr = data_ptr; 430 aligned_char_vec_size = unaligned_char_vec_size; 431 aligned_char_vec_len = unaligned_char_vec_len; 432 aligned_char_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count); 433 do i = 1 to aligned_char_vec_len; 434 unaligned_char_vec (i) = aligned_char_vec (i); 435 end; 436 end; 437 else do; 438 unaligned_char_vec_len = 1; 439 unaligned_char_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count); 440 unaligned_char_vec_size = data_elements; 441 data_ptr -> unaligned_char_vec = unaligned_char_vec; 442 end; 443 end; 444 else if argument_desc.type = Type_fixed_bin_long 445 then do; 446 float_bin_long_vec_len = data_elements; 447 float_bin_long_vec_ptr = data_ptr; 448 fixed_bin_long_vec_len = float_bin_long_vec_len; 449 fixed_bin_long_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count); 450 do i = 1 to fixed_bin_long_vec_len /* Copy to first non-Boolean. */ 451 while (fixed_bin_long_vec (i) = 0 | fixed_bin_long_vec (i) = 1); 452 float_bin_long_vec (i) = fixed_bin_long_vec (i); 453 end; 454 do j = i to fixed_bin_long_vec_len; /* Copy remainder. */ 455 float_bin_long_vec (j) = fixed_bin_long_vec (j); 456 end; 457 if i > fixed_bin_long_vec_len 458 then string (bead_ptr -> value_bead.type) = zero_or_one_value_type; 459 else string (bead_ptr -> value_bead.type) = integral_value_type; 460 end; 461 else if argument_desc.type = Type_fixed_bin_short 462 then do; 463 float_bin_long_vec_len = data_elements; 464 float_bin_long_vec_ptr = data_ptr; 465 fixed_bin_short_vec_len = float_bin_long_vec_len; 466 fixed_bin_short_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count); 467 do i = 1 to fixed_bin_short_vec_len /* Copy to first non-Boolean. */ 468 while (fixed_bin_short_vec (i) = 0 | fixed_bin_short_vec (i) = 1); 469 float_bin_long_vec (i) = fixed_bin_short_vec (i); 470 end; 471 do j = i to fixed_bin_short_vec_len; /* Copy remainder. */ 472 float_bin_long_vec (j) = fixed_bin_short_vec (j); 473 end; 474 if i > fixed_bin_short_vec_len 475 then string (bead_ptr -> value_bead.type) = zero_or_one_value_type; 476 else string (bead_ptr -> value_bead.type) = integral_value_type; 477 end; 478 else if argument_desc.type = Type_float_bin_long 479 then do; 480 float_bin_long_vec_len = data_elements; 481 float_bin_long_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count); 482 do i = 1 to float_bin_long_vec_len /* Copy to first non-Boolean. */ 483 while (float_bin_long_vec (i) = 0 | float_bin_long_vec (i) = 1); 484 data_ptr -> float_bin_long_vec (i) = float_bin_long_vec (i); 485 end; 486 do j = i to float_bin_long_vec_len /* Copy to first non_integer. */ 487 while (float_bin_long_vec (j) = floor (float_bin_long_vec (j))); 488 data_ptr -> float_bin_long_vec (j) = float_bin_long_vec (j); 489 end; 490 do k = j to float_bin_long_vec_len; /* Copy remainder. */ 491 data_ptr -> float_bin_long_vec (k) = float_bin_long_vec (k); 492 end; 493 if i > float_bin_long_vec_len 494 then string (bead_ptr -> value_bead.type) = zero_or_one_value_type; 495 else if j > float_bin_long_vec_len 496 then string (bead_ptr -> value_bead.type) = integral_value_type; 497 else string (bead_ptr -> value_bead.type) = numeric_value_type; 498 end; 499 else if argument_desc.type = Type_float_bin_short 500 then do; 501 float_bin_long_vec_len = data_elements; 502 float_bin_long_vec_ptr = data_ptr; 503 float_bin_short_vec_len = float_bin_long_vec_len; 504 float_bin_short_vec_ptr = argument_list.arg_ptrs (arg_list_arg_count); 505 do i = 1 to float_bin_short_vec_len /* Copy to first non-Boolean. */ 506 while (float_bin_short_vec (i) = 0 | float_bin_short_vec (i) = 1); 507 float_bin_long_vec (i) = float_bin_short_vec (i); 508 end; 509 do j = i to float_bin_short_vec_len /* Copy to first non-integer. */ 510 while (float_bin_short_vec (j) = floor (float_bin_short_vec (j))); 511 float_bin_long_vec (j) = float_bin_short_vec (j); 512 end; 513 do k = j to float_bin_short_vec_len; /* Copy remainder. */ 514 float_bin_long_vec (k) = float_bin_short_vec (k); 515 end; 516 if i > float_bin_short_vec_len 517 then string (bead_ptr -> value_bead.type) = zero_or_one_value_type; 518 else if j > float_bin_short_vec_len 519 then string (bead_ptr -> value_bead.type) = integral_value_type; 520 else string (bead_ptr -> value_bead.type) = numeric_value_type; 521 end; 522 end assign_result; 523 collect_garbage: proc; 524 525 /* Function: to free the space in the APL value stack occupied by the */ 526 /* arguments, since they are no longer needed. */ 527 528 /* Global Arguments: */ 529 /* */ 530 /* list_ptr (Input) */ 531 /* the address of the right argument list bead. */ 532 /* */ 533 /* ws_info.value_stack_ptr (Output) */ 534 /* the address of the next free location on the APL value stack. */ 535 536 dcl apl_free_bead_ entry (ptr unaligned); 537 538 dcl i fixed bin, 539 member_ptr ptr; 540 541 /* Pop the value stack: The right argument list bead is lowest on the */ 542 /* stack, unless some of the list members are also on the stack, in which */ 543 /* case the rightmost such member is lowest. The reference count for each */ 544 /* member which is not on the value stack must also be decremented. */ 545 546 ws_info.value_stack_ptr = list_ptr; 547 do i = 1 to n_members; 548 member_ptr = list_ptr -> list_bead.member_ptr (i); 549 if list_ptr -> list_bead.semantics_on_stack (i) 550 then ws_info.value_stack_ptr = member_ptr; 551 else do; 552 member_ptr -> general_bead.reference_count = member_ptr -> general_bead.reference_count - 1; 553 if member_ptr -> general_bead.reference_count < 1 554 then call apl_free_bead_ ((member_ptr)); 555 end; 556 end; 557 end collect_garbage; 558 convert_arguments: proc; 559 560 /* Function: to format the arguments to be passed to the routine which is */ 561 /* to be called, according to the declaration. */ 562 563 /* Global Arguments: */ 564 /* */ 565 /* argument_desc (Input) */ 566 /* the argument descriptors (from which the type of conversion needed is */ 567 /* discovered). */ 568 /* */ 569 /* argument_list (Update) */ 570 /* the argument list for the call. The argument ptrs will be filled in. */ 571 /* */ 572 /* list_ptr (Input) */ 573 /* the address of the list bead for the right argument. */ 574 /* */ 575 /* marker (Input) */ 576 /* the indices in 'declaration' of the routine name (element 0) and the */ 577 /* start of each parameter declaration (elements 1 -> 'n_members'). */ 578 579 dcl arg_num fixed bin, 580 entry_ptr ptr, 581 i fixed bin, 582 j fixed bin, 583 k fixed bin, 584 member_num fixed bin, 585 member_ptr ptr, 586 module_name_len fixed bin (21), 587 module_name_ptr ptr, 588 rank fixed bin, 589 routine_name_len fixed bin (21), 590 routine_name_ptr ptr, 591 size_limit float bin (27), 592 status fixed bin (35), 593 value_ptr ptr; 594 595 dcl entry entry based (entry_ptr), 596 routine_name char (routine_name_len) based (routine_name_ptr), 597 module_name char (module_name_len) based (module_name_ptr); 598 599 /* Fill in the argument list argument pointers. If an argument is already */ 600 /* in the format specified in the declaration, and it either is passed by */ 601 /* by value on the value stack, or it is passed by name and does not share */ 602 /* its value, then we just use it. Otherwise, we must copy its value onto */ 603 /* the value stack in the appropriate format and then use the copy. If the */ 604 /* argument is already on the value stack and the desired format does not */ 605 /* require any more space, do the conversion in place, rather than allocate */ 606 /* new storage on the value stack. */ 607 608 do member_num = 2 to n_members; 609 arg_num = member_num - 1; 610 member_ptr = list_ptr -> list_bead.member_ptr (member_num); 611 if member_ptr -> general_bead.symbol 612 then value_ptr = member_ptr -> symbol_bead.meaning_pointer; 613 else value_ptr = member_ptr; 614 argument_desc_ptr = argument_list.desc_ptrs (arg_num); 615 if value_ptr = null 616 then do; /* No initial value, so just allocate space. */ 617 bit_vec_len = 1; 618 rank = argument_desc.number_dims; 619 if rank < 1 620 then if argument_desc.type = Type_bit 621 then bit_vec_size = argument_desc.size; 622 else if argument_desc.type = Type_char 623 then bit_vec_size = 9*argument_desc.size; 624 else bit_vec_size = argument_desc.size + 1; 625 else if argument_desc.packed 626 then bit_vec_size = argument_desc.upper_bound (rank)*argument_desc.multiplier (rank); 627 else bit_vec_size = 36*argument_desc.upper_bound (rank)*argument_desc.multiplier (rank); 628 bit_vec_pad = 36*divide (bit_vec_size + 35, 36, 18) - bit_vec_size; 629 bit_vec_ptr = apl_push_stack_ (size (bit_vec)); 630 unspec (bit_vec) = ""b; 631 argument_list.arg_ptrs (arg_num) = bit_vec_ptr; 632 end; 633 else if argument_desc.type = Type_bit 634 then do; 635 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 636 float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer; 637 if argument_desc.packed | mod (argument_desc.size, 36) = 0 638 then do; 639 bit_vec_size = float_bin_long_vec_len; 640 bit_vec_len = 1; 641 end; 642 else do; 643 bit_vec_size = argument_desc.size; 644 bit_vec_len = divide (float_bin_long_vec_len, bit_vec_size, 24); 645 end; 646 bit_vec_pad = 36*divide (bit_vec_size + 35, 36, 18) - bit_vec_size; 647 if list_ptr -> list_bead.semantics_on_stack (member_num) 648 then bit_vec_ptr = float_bin_long_vec_ptr; 649 else bit_vec_ptr = apl_push_stack_ (size (bit_vec)); 650 i = 1; 651 do j = 1 to bit_vec_len; 652 do k = 1 to bit_vec_size; 653 substr (bit_vec (j), k, 1) = (float_bin_long_vec (i) ^= 0); 654 i = i + 1; 655 end; 656 substr (unspec (bit_vec (j)), k) = ""b; /* Zero the pad bits. */ 657 end; 658 argument_list.arg_ptrs (arg_num) = bit_vec_ptr; 659 end; 660 else if argument_desc.type = Type_char 661 then do; 662 if ^argument_desc.packed & mod (argument_desc.size, 4) ^= 0 663 then do; /* Copy onto value stack in aligned format. */ 664 unaligned_char_vec_size = argument_desc.size; 665 unaligned_char_vec_len = divide (value_ptr -> value_bead.total_data_elements, 666 unaligned_char_vec_size, 21); 667 unaligned_char_vec_ptr = value_ptr -> value_bead.data_pointer; 668 aligned_char_vec_size = unaligned_char_vec_size; 669 aligned_char_vec_len = unaligned_char_vec_len; 670 aligned_char_vec_ptr = apl_push_stack_ (size (aligned_char_vec)); 671 unspec (aligned_char_vec) = ""b; /* Ensure padding will be zeroes. */ 672 do i = 1 to aligned_char_vec_len; 673 aligned_char_vec (i) = unaligned_char_vec (i); 674 end; 675 argument_list.arg_ptrs (arg_num) = aligned_char_vec_ptr; 676 end; 677 else if list_ptr -> list_bead.semantics_on_stack (member_num) 678 | (member_ptr -> general_bead.symbol & value_ptr -> value_bead.reference_count < 2) 679 then argument_list.arg_ptrs (arg_num) = value_ptr -> value_bead.data_pointer; 680 else do; /* Copy onto value stack without conversion. */ 681 unaligned_char_vec_size = value_ptr -> value_bead.total_data_elements; 682 unaligned_char_vec_len = 1; 683 unaligned_char_vec_ptr = apl_push_stack_ (size (unaligned_char_vec)); 684 unspec (unaligned_char_vec) 685 = unspec (value_ptr -> value_bead.data_pointer -> unaligned_char_vec); 686 argument_list.arg_ptrs (arg_num) = unaligned_char_vec_ptr; 687 end; 688 end; 689 else if argument_desc.type = Type_entry 690 then do; 691 module_name_ptr = value_ptr -> value_bead.data_pointer; 692 module_name_len = value_ptr -> value_bead.total_data_elements; 693 module_name_len = length (rtrim (module_name)); /* Exclude trailing spaces. */ 694 i = verify (module_name, " "); 695 if i > 1 696 then do; /* Exclude leading spaces. */ 697 module_name_ptr = addr (module_name_ptr -> dummy_chars (i)); 698 module_name_len = module_name_len - i + 1; 699 end; 700 i = index (module_name, "$"); 701 if i > 0 702 then do; /* Routine name is explicit. */ 703 routine_name_ptr = addr (module_name_ptr -> dummy_chars (i + 1)); 704 routine_name_len = module_name_len - i; 705 module_name_len = i - 1; 706 end; 707 else do; /* Segment name is also routine name. */ 708 routine_name_ptr = module_name_ptr; 709 routine_name_len = module_name_len; 710 end; 711 if length (module_name) < 1 | length (module_name) > 32 | verify (module_name, Token_chars) > 0 712 | length (routine_name) < 1 | length (routine_name) > 32 | verify (routine_name, Token_chars) > 0 713 then call declaration_error ("invalid entry name", marker (arg_num)); 714 entry_ptr = apl_push_stack_ (size (entry)); 715 call make_entry (module_name, routine_name, entry, status); 716 if status ^= 0 717 then if routine_name = module_name 718 then call declaration_error (rtrim (meaning (status)) || " " || module_name, marker (arg_num)); 719 else call declaration_error (rtrim (meaning (status)) || " " || module_name 720 || "$" || routine_name, marker (arg_num)); 721 argument_list.arg_ptrs (arg_num) = entry_ptr; 722 end; 723 else if argument_desc.type = Type_fixed_bin_long 724 then do; 725 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 726 float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer; 727 fixed_bin_long_vec_len = float_bin_long_vec_len; 728 if list_ptr -> list_bead.semantics_on_stack (member_num) 729 then fixed_bin_long_vec_ptr = float_bin_long_vec_ptr; 730 else fixed_bin_long_vec_ptr = apl_push_stack_ (size (fixed_bin_long_vec)); 731 size_limit = 2e0**fixed (argument_desc.size, 7); 732 do i = 1 to fixed_bin_long_vec_len; 733 if float_bin_long_vec (i) < -size_limit | float_bin_long_vec (i) >= size_limit 734 then goto cannot_convert_argument; 735 fixed_bin_long_vec (i) = float_bin_long_vec (i); 736 end; 737 argument_list.arg_ptrs (arg_num) = fixed_bin_long_vec_ptr; 738 end; 739 else if argument_desc.type = Type_fixed_bin_short 740 then do; 741 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 742 float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer; 743 fixed_bin_short_vec_len = float_bin_long_vec_len; 744 if list_ptr -> list_bead.semantics_on_stack (member_num) 745 then fixed_bin_short_vec_ptr = float_bin_long_vec_ptr; 746 else fixed_bin_short_vec_ptr = apl_push_stack_ (size (fixed_bin_short_vec)); 747 size_limit = 2e0**fixed (argument_desc.size, 7); 748 do i = 1 to fixed_bin_short_vec_len; 749 if float_bin_long_vec (i) < -size_limit | float_bin_long_vec (i) >= size_limit 750 then goto cannot_convert_argument; 751 fixed_bin_short_vec (i) = float_bin_long_vec (i); 752 end; 753 argument_list.arg_ptrs (arg_num) = fixed_bin_short_vec_ptr; 754 end; 755 else if argument_desc.type = Type_float_bin_long 756 then if list_ptr -> list_bead.semantics_on_stack (member_num) 757 | (member_ptr -> general_bead.symbol & value_ptr -> value_bead.reference_count < 2) 758 then argument_list.arg_ptrs (arg_num) = value_ptr -> value_bead.data_pointer; 759 else do; /* Copy onto value stack without conversion. */ 760 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 761 float_bin_long_vec_ptr = apl_push_stack_ (size (float_bin_long_vec)); 762 unspec (float_bin_long_vec) 763 = unspec (value_ptr -> value_bead.data_pointer -> float_bin_long_vec); 764 argument_list.arg_ptrs (arg_num) = float_bin_long_vec_ptr; 765 end; 766 else if argument_desc.type = Type_float_bin_short 767 then do; 768 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 769 float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer; 770 float_bin_short_vec_len = float_bin_long_vec_len; 771 if list_ptr -> list_bead.semantics_on_stack (member_num) 772 then float_bin_short_vec_ptr = float_bin_long_vec_ptr; 773 else float_bin_short_vec_ptr = apl_push_stack_ (size (float_bin_short_vec)); 774 do i = 1 to float_bin_short_vec_len; 775 float_bin_short_vec (i) = float_bin_long_vec (i); 776 end; 777 argument_list.arg_ptrs (arg_num) = float_bin_short_vec_ptr; 778 end; 779 else argument_list.arg_ptrs (arg_num) = null; /* If we missed a conversion, this will tell us. */ 780 end; 781 return; 782 783 /* One of the elements in the APL value is too large to convert to the */ 784 /* required format. Issue a diagnostic pointing to the size field of the */ 785 /* appropriate argument declaration. */ 786 787 cannot_convert_argument: 788 token_idx = marker (arg_num); 789 token_len = 0; 790 call get_next_token; 791 if token = "(" | token = "dim" | token = "dimension" 792 then do; /* Skip dimension specification. */ 793 do while (token ^= ")"); 794 call get_next_token; 795 end; 796 call get_next_token; 797 end; 798 call get_next_token; /* Skip type specification. */ 799 if token = "bin" 800 then call get_next_token; 801 if token = "(" 802 then call get_next_token; 803 call declaration_error ("parameter size incompatible with argument", token_idx); 804 end convert_arguments; 805 declaration_error: proc (error_msg, declaration_idx); 806 807 /* Function: to display a diagnostic about the declaration, indicating */ 808 /* where in the declaration the error occurred. This is done by */ 809 /* printing the declaration with a caret under the indicated character. */ 810 811 /* Arguments: */ 812 /* */ 813 /* error_msg (Input) */ 814 /* the diagnostic to be printed. */ 815 /* */ 816 /* declaration_idx (Input) */ 817 /* the index of the character in the declaration under which the caret */ 818 /* is to appear. */ 819 820 /* Global Arguments: */ 821 /* */ 822 /* declaration (Input) */ 823 /* the declaration in which the error was detected. */ 824 825 dcl error_msg char (*), 826 declaration_idx fixed bin; 827 828 dcl ioa_$nnl entry options (variable); 829 830 call ioa_$nnl ("^/declaration error: ^a^/^6x^a^/^vx^a", error_msg, declaration, declaration_idx+5, QAndSign); 831 call error (apl_error_table_$domain, Right_arg); 832 end declaration_error; 833 error: proc (status, where); 834 835 /* Function: to return control to APL upon detection of an error. */ 836 837 /* Arguments: */ 838 /* */ 839 /* status (Input) */ 840 /* the status code describing the error which is to be returned to APL. */ 841 /* */ 842 /* where (Input) */ 843 /* 'Function' if the error is not in an argument, 'Left_arg' if it is in */ 844 /* the left argument, and 'Right_arg' if it is in the right argument. */ 845 846 dcl status fixed bin (35), 847 where fixed bin; 848 849 operators_argument.error_code = status; 850 if where = Left_arg 851 then operators_argument.where_error = operators_argument.where_error + 1; 852 else if where = Right_arg 853 then operators_argument.where_error = operators_argument.where_error - 1; 854 goto return; 855 end error; 856 generate_argument_desc: proc (member_ptr); 857 858 /* Function: to generate an argument descriptor for an argument, based on */ 859 /* the type, rank and shape fields of its value bead. */ 860 861 /* Arguments: */ 862 /* */ 863 /* member_ptr (Input) */ 864 /* the address of the APL symbol or value bead for the argument for */ 865 /* which an argument descriptor is to be generated. */ 866 867 /* Global Arguments: */ 868 /* */ 869 /* argument_desc (Output) */ 870 /* the argument descriptor generated for the argument. */ 871 /* */ 872 /* token_idx (Input) */ 873 /* the index of the token to be associated with this argument in error */ 874 /* messages. */ 875 876 dcl member_ptr ptr; 877 878 dcl i fixed bin, 879 j fixed bin, 880 multiplier fixed bin (35), 881 rank fixed bin, 882 value_ptr ptr; 883 884 if member_ptr -> general_bead.symbol 885 then do; 886 value_ptr = member_ptr -> symbol_bead.meaning_pointer; 887 if value_ptr = null 888 then call declaration_error (member_ptr -> symbol_bead.name || " not defined", token_idx); 889 end; 890 else value_ptr = member_ptr; 891 rank = value_ptr -> value_bead.rhorho; 892 if rank > Max_rank 893 then if member_ptr -> general_bead.symbol 894 then call declaration_error (member_ptr -> symbol_bead.name || " rank exceeds " 895 || ltrim (char (Max_rank)), token_idx); 896 else call declaration_error ("argument rank exceeds " || ltrim (char (Max_rank)), token_idx); 897 argument_desc.flag = "1"b; 898 if string (value_ptr -> value_bead.type) = character_value_type 899 then if rank = 0 900 then do; /* Argument is character scalar. */ 901 argument_desc.type = Type_char; 902 argument_desc.packed = True; 903 argument_desc.number_dims = rank; 904 argument_desc.size = 1; 905 multiplier = 9; 906 end; 907 else do; /* Argument is character array. */ 908 argument_desc.type = Type_char; 909 argument_desc.packed = True; 910 argument_desc.number_dims = rank - 1; 911 argument_desc.size = value_ptr -> value_bead.rho (rank); 912 multiplier = 9*value_ptr -> value_bead.rho (rank); 913 rank = rank - 1; 914 end; 915 else do; /* Argument is numeric scalar or array. */ 916 argument_desc.type = Type_float_bin_long; 917 argument_desc.packed = False; 918 argument_desc.number_dims = rank; 919 argument_desc.size = 63; 920 multiplier = 2; 921 end; 922 do i = 1 to rank; 923 j = rank - i + 1; 924 argument_desc.lower_bound (j) = 1; 925 argument_desc.upper_bound (j) = value_ptr -> value_bead.rho (i); 926 argument_desc.multiplier (i) = multiplier; 927 multiplier = value_ptr -> value_bead.rho (j)*multiplier; 928 end; 929 end generate_argument_desc; 930 get_next_token: proc; 931 932 /* Function: to isolate the next token of the declaration. A token is a */ 933 /* string of consecutive letters, digits and underscores, or any other */ 934 /* single character, except space (which has no meaning other than as a */ 935 /* string delimiter). */ 936 937 /* Global Arguments: */ 938 /* */ 939 /* declaration (Input) */ 940 /* the string from which the next token is to be selected. */ 941 /* */ 942 /* token_idx (Update) */ 943 /* the index of the current token of the declaration. */ 944 /* */ 945 /* token_len (Update) */ 946 /* the length of the current token of the declaration. */ 947 948 dcl spaces fixed bin; 949 950 token_idx = token_idx + token_len; /* Skip over current token. */ 951 spaces = verify (substr (declaration, token_idx), " ") - 1; 952 if spaces < 0 953 then spaces = length (substr (declaration, token_idx)); 954 token_idx = token_idx + spaces; /* Skip over any spaces before next token. */ 955 token_len = verify (substr (declaration, token_idx), Token_chars) - 1; 956 if token_len < 0 957 then token_len = length (substr (declaration, token_idx)); 958 else if token_len = 0 & token_idx <= length (declaration) 959 then token_len = 1; 960 end get_next_token; 961 make_entry: proc (module_name, routine_name, entry, status); 962 963 /* Function: to form an entry value for a routine, given the names of the */ 964 /* routine and the module which contains it. If the module has not yet */ 965 /* been initiated, a segment of the same name as that of the module is */ 966 /* searched for using the 'apl' search paths. If nothing is found, the */ 967 /* search is continued using the search rules. */ 968 969 /* Arguments: */ 970 /* */ 971 /* module_name (Input) */ 972 /* the name of the module containing the desired routine. */ 973 /* */ 974 /* routine_name (Input) */ 975 /* the name of the desired routine. */ 976 /* */ 977 /* entry (Output) */ 978 /* the entry value of the routine. */ 979 /* */ 980 /* status (Output) */ 981 /* a standard system status code. */ 982 983 dcl module_name char (*), 984 routine_name char (*), 985 entry entry, 986 status fixed bin (35); 987 988 dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)), 989 hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin (35)), 990 hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), 991 hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35)), 992 search_paths_$find_dir entry (char (*), ptr, char (*), char (*), char (*), fixed bin (35)); 993 994 dcl codeptr builtin; 995 996 dcl our_dir_name char (168) static init (""); 997 998 dcl dir_name char (168), 999 our_dir_name_len fixed bin, 1000 our_ent_name char (32), 1001 seg_ptr ptr; 1002 1003 call hcs_$fs_get_seg_ptr (module_name, seg_ptr, status); 1004 if seg_ptr = null 1005 then do; /* Module not initiated: try 'apl' search paths. */ 1006 if our_dir_name = "" 1007 then call hcs_$fs_get_path_name (codeptr (make_entry), our_dir_name, our_dir_name_len, our_ent_name, status); 1008 call search_paths_$find_dir ("apl", null, module_name, our_dir_name, dir_name, status); 1009 if status = 0 1010 then call hcs_$initiate (dir_name, module_name, module_name, 0, 0, seg_ptr, status); 1011 end; 1012 call hcs_$make_entry (codeptr (make_entry), module_name, routine_name, entry, status); 1013 end make_entry; 1014 meaning: proc (status) returns (char (100)); 1015 1016 /* Function: to return the meaning of a status code. */ 1017 1018 /* Arguments: */ 1019 /* */ 1020 /* status (Input) */ 1021 /* the status code whose meaning is desired. */ 1022 1023 dcl status fixed bin (35); 1024 1025 dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); 1026 1027 dcl long_info char (100) aligned, 1028 short_info char (8) aligned; 1029 1030 call convert_status_code_ (status, short_info, long_info); 1031 return (long_info); 1032 end meaning; 1033 process_declaration: proc; 1034 1035 /* Function: to supervise the building of the argument list, argument */ 1036 /* descriptors and marker array from the declaration. */ 1037 1038 /* Global Arguments: */ 1039 /* */ 1040 /* arg_list_arg_count (Update) */ 1041 /* the number of arguments if we are calling a subroutine, else that */ 1042 /* number plus one. */ 1043 /* argument_desc (Output) */ 1044 /* the argument descriptors for the parameters of the declaration. */ 1045 /* */ 1046 /* argument_list (Output) */ 1047 /* the argument list for the routine which is to be called. The */ 1048 /* argument value ptrs still need to be filled in. */ 1049 /* */ 1050 /* bits_in_result (Output) */ 1051 /* the number of bits of storage that we need to allocate for the return */ 1052 /* value. (It is zero if we are calling a subroutine or a function */ 1053 /* whose value has '*' extents.) */ 1054 /* */ 1055 /* calling_a_function (Output) */ 1056 /* a flag indicating whether we are calling a function or subroutine. */ 1057 /* */ 1058 /* declaration (Input) */ 1059 /* a PL/I style entry declaration for the routine to be called. */ 1060 /* */ 1061 /* list_ptr (Input) */ 1062 /* the address of the list bead for the right argument. */ 1063 /* */ 1064 /* marker (Output) */ 1065 /* the indices in 'declaration' of the routine name (element 0) and the */ 1066 /* start of each parameter declaration (elements 1 -> 'n_members'). */ 1067 /* */ 1068 /* n_members (Input) */ 1069 /* the number of members in the right argument list. */ 1070 1071 dcl Letters char (52) static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"); 1072 1073 dcl arg_num fixed bin, 1074 member_ptr ptr, 1075 module_name char (32), 1076 more bit (1), 1077 rank fixed bin, 1078 routine_name char (32), 1079 status fixed bin (35); 1080 1081 /* Extract the module and routine names from the declaration. */ 1082 1083 token_idx = 1; 1084 token_len = 0; 1085 call get_next_token; 1086 marker (0) = token_idx; 1087 if index (Letters, substr (token, 1, min (1, token_len))) = 0 | token_len > maxlength (module_name) 1088 then call declaration_error ("invalid module name", token_idx); 1089 module_name = token; 1090 call get_next_token; 1091 if token = "$" 1092 then do; /* Extract routine name. */ 1093 call get_next_token; 1094 if index (Letters, substr (token, 1, min (1, token_len))) = 0 | token_len > maxlength (routine_name) 1095 then call declaration_error ("invalid routine name", token_idx); 1096 routine_name = token; 1097 call get_next_token; 1098 end; 1099 else routine_name = module_name; 1100 if token = "entry" 1101 then call get_next_token; /* Ignore superfluous 'entry' attribute. */ 1102 1103 /* Initialize argument list header. */ 1104 1105 calling_a_function = (index (substr (declaration, token_idx), "returns") > 0); 1106 if ^calling_a_function 1107 then arg_list_arg_count = arg_list_arg_count - 1; 1108 argument_list.arg_count = arg_list_arg_count; 1109 argument_list.pad1 = ""b; 1110 argument_list.call_type = Interseg_call_type; 1111 argument_list.desc_count = arg_list_arg_count; 1112 argument_list.pad2 = ""b; 1113 1114 /* Decode any argument declarations into the corresponding descriptors. */ 1115 1116 arg_num = 0; 1117 if token = "(" 1118 then do; /* Process parameter declarations. */ 1119 call get_next_token; 1120 more = (token ^= ")"); 1121 do while (more); 1122 arg_num = arg_num + 1; 1123 if arg_num >= n_members 1124 then call declaration_error ("more parameters than arguments", token_idx); 1125 marker (arg_num) = token_idx; 1126 argument_list.desc_ptrs (arg_num) = argument_desc_ptr; 1127 member_ptr = list_ptr -> list_bead.member_ptr (arg_num + 1); 1128 call process_parameter_dcl (member_ptr); 1129 argument_desc_ptr = addrel (argument_desc_ptr, size (argument_desc)); 1130 if token = "," 1131 then call get_next_token; 1132 else more = False; 1133 end; 1134 if token ^= ")" 1135 then call declaration_error ("invalid syntax", token_idx); 1136 call get_next_token; 1137 end; 1138 else if token = "options" 1139 then do; /* Process 'options (variable)' attribute. */ 1140 call get_next_token; 1141 if token ^= "(" 1142 then call declaration_error ("syntax error", token_idx); 1143 call get_next_token; 1144 if token ^= "variable" 1145 then call declaration_error ("syntax error", token_idx); 1146 call get_next_token; 1147 if token ^= ")" 1148 then call declaration_error ("syntax error", token_idx); 1149 do while (arg_num + 1 < n_members); 1150 arg_num = arg_num + 1; 1151 marker (arg_num) = token_idx; 1152 argument_list.desc_ptrs (arg_num) = argument_desc_ptr; 1153 member_ptr = list_ptr -> list_bead.member_ptr (arg_num + 1); 1154 call generate_argument_desc (member_ptr); 1155 argument_desc_ptr = addrel (argument_desc_ptr, size (argument_desc)); 1156 end; 1157 call get_next_token; 1158 end; 1159 if arg_num ^= n_members - 1 1160 then call declaration_error ("more arguments than parameters", token_idx); 1161 1162 /* Decode 'returns' attribute, if any. */ 1163 1164 if token = "returns" 1165 then do; 1166 call get_next_token; 1167 if token ^= "(" 1168 then call declaration_error ("invalid syntax", token_idx); 1169 call get_next_token; 1170 marker (arg_num + 1) = token_idx; 1171 argument_list.desc_ptrs (arg_num + 1) = argument_desc_ptr; 1172 call process_parameter_dcl (null); 1173 if token ^= ")" 1174 then call declaration_error ("invalid syntax", token_idx); 1175 call get_next_token; 1176 rank = argument_desc.number_dims; 1177 if rank < 1 1178 then if argument_desc.type = Type_bit 1179 then bits_in_result = argument_desc.size; 1180 else if argument_desc.type = Type_char 1181 then bits_in_result = 9*argument_desc.size; 1182 else bits_in_result = argument_desc.size + 1; 1183 else if argument_desc.packed 1184 then bits_in_result = argument_desc.upper_bound (rank)*argument_desc.multiplier (rank); 1185 else bits_in_result = 36*argument_desc.upper_bound (rank)*argument_desc.multiplier (rank); 1186 end; 1187 else bits_in_result = 0; 1188 1189 /* Check that we have reached the end of the declaration, then locate the */ 1190 /* routine to be called. */ 1191 1192 if token ^= "" 1193 then call declaration_error ("invalid_syntax", token_idx); 1194 call make_entry (module_name, routine_name, routine, status); 1195 if status ^= 0 1196 then if routine_name = module_name 1197 then call declaration_error (rtrim (meaning (status)) || " " || module_name, marker (0)); 1198 else call declaration_error (rtrim (meaning (status)) || " " || rtrim (module_name) 1199 || "$" || routine_name, marker (0)); 1200 end process_declaration; 1201 process_parameter_dcl: proc (member_ptr); 1202 1203 /* Function: to extract the rank, shape, type, size and alignment from an */ 1204 /* parameter declaration and use that information to build an argument */ 1205 /* descriptor. */ 1206 1207 /* Arguments: */ 1208 /* */ 1209 /* member_ptr (Input) */ 1210 /* the address of the APL symbol or value bead for the argument which */ 1211 /* corresponds to the parameter declaration, or null if this declaration */ 1212 /* is for the result value. */ 1213 1214 /* Global Arguments: */ 1215 /* */ 1216 /* argument_desc (Output) */ 1217 /* the argument descriptor built from the parameter declaration. */ 1218 /* */ 1219 /* token (Update) */ 1220 /* the current token of the declaration. On input, it will be the first */ 1221 /* token of the parameter declaration. On output, it will be the first */ 1222 /* token following the parameter declaration. */ 1223 /* */ 1224 /* token_idx (Update) */ 1225 /* the index in the declaration of the current token. */ 1226 /* */ 1227 /* token_len (Update) */ 1228 /* the length of the current token. */ 1229 1230 dcl member_ptr ptr; 1231 1232 dcl sys_info$max_seg_size fixed bin (19) ext; 1233 1234 dcl bits_in_value fixed bin (71), 1235 bits_per_element fixed bin, 1236 dimensioning_idx fixed bin, 1237 i fixed bin, 1238 j fixed bin, 1239 last_dimension_implicit bit (1) init (False), 1240 more bit (1), 1241 multiplier fixed bin (35), 1242 next_token_idx fixed bin, 1243 next_token_len fixed bin, 1244 packed bit (1), 1245 rank fixed bin, 1246 shape (Max_rank) fixed bin (35), 1247 size fixed bin (35), 1248 type fixed bin, 1249 value_ptr ptr; 1250 1251 value_ptr = member_ptr; 1252 if member_ptr ^= null 1253 then if member_ptr -> general_bead.symbol 1254 then value_ptr = member_ptr -> symbol_bead.meaning_pointer; 1255 1256 /* Verify format of dimension attribute, if any. */ 1257 1258 rank = 0; 1259 if token = "dim" | token = "dimension" 1260 then call get_next_token; /* Ignore superfluous 'dim' keyword. */ 1261 dimensioning_idx = token_idx; 1262 if token = "(" 1263 then do; 1264 more = True; 1265 do while (more); 1266 call get_next_token; 1267 rank = rank + 1; 1268 if rank > Max_rank 1269 then call declaration_error ("too many dimensions", token_idx); 1270 if token = "*" 1271 then if member_ptr = null 1272 then shape (rank) = 0; 1273 else if value_ptr = null 1274 then call declaration_error ("parameter dimension incompatible with argument", token_idx); 1275 else if rank > value_ptr -> value_bead.rhorho 1276 then call declaration_error ("parameter has more dimensions than argument", token_idx); 1277 else shape (rank) = value_ptr -> value_bead.rho (rank); 1278 else if verify (token, "0123456789") > 0 | verify (token, "0") = 0 | length (token) > 10 1279 then call declaration_error ("invalid dimension", token_idx); 1280 else do; 1281 shape (rank) = bin (token, 35); 1282 if value_ptr ^= null 1283 then if rank > value_ptr -> value_bead.rhorho 1284 then call declaration_error ("too many dimensions", token_idx); 1285 else if shape (rank) ^= value_ptr -> value_bead.rho (rank) 1286 then call declaration_error ("parameter dimension incompatible with argument", token_idx); 1287 end; 1288 call get_next_token; 1289 more = (token = ","); 1290 end; 1291 if token ^= ")" 1292 then call declaration_error ("invalid syntax", token_idx); 1293 call get_next_token; 1294 end; 1295 1296 /* Decode type attribute. */ 1297 1298 if token = "bit" 1299 then do; 1300 if value_ptr ^= null 1301 then if string (value_ptr -> value_bead.type) ^= zero_or_one_value_type 1302 then call declaration_error ("parameter type incompatible with argument", token_idx); 1303 type = Type_bit; 1304 size = 1; 1305 packed = True; 1306 call get_next_token; 1307 end; 1308 else if token = "char" | token = "character" 1309 then do; 1310 if value_ptr ^= null 1311 then if string (value_ptr -> value_bead.type) ^= character_value_type 1312 then call declaration_error ("parameter type incompatible with argument", token_idx); 1313 type = Type_char; 1314 size = 1; 1315 packed = True; 1316 call get_next_token; 1317 end; 1318 else if token = "entry" 1319 then do; 1320 if member_ptr = null 1321 then call declaration_error ("invalid type for return value", token_idx); 1322 if rank > 0 1323 then call declaration_error ("too many dimensions", token_idx); 1324 if value_ptr = null 1325 then call declaration_error ("parameter type incompatible with argument", token_idx); 1326 if string (value_ptr -> general_bead.type) ^= character_value_type 1327 then call declaration_error ("parameter type incompatible with argument", token_idx); 1328 type = Type_entry; 1329 size = 0; 1330 packed = False; 1331 last_dimension_implicit = True; 1332 call get_next_token; 1333 if token = "options" 1334 then do; /* Flush 'options (variable)' phrase. */ 1335 call get_next_token; 1336 if token ^= "(" 1337 then call declaration_error ("invalid syntax", token_idx); 1338 call get_next_token; 1339 if token ^= "variable" 1340 then call declaration_error ("invalid syntax", token_idx); 1341 call get_next_token; 1342 if token ^= ")" 1343 then call declaration_error ("invalid syntax", token_idx); 1344 call get_next_token; 1345 end; 1346 if token = "(" 1347 then call declaration_error ("invalid syntax", token_idx); 1348 end; 1349 else if token = "fixed" 1350 then do; 1351 if value_ptr ^= null 1352 then if string (value_ptr -> value_bead.type) ^= integral_value_type 1353 & string (value_ptr -> value_bead.type) ^= zero_or_one_value_type 1354 then call declaration_error ("parameter type incompatible with argument", token_idx); 1355 type = Type_fixed_bin_short; 1356 size = 17; 1357 packed = False; 1358 call get_next_token; 1359 if token = "bin" | token = "binary" 1360 then call get_next_token; 1361 else if token = "dec" | token = "decimal" 1362 then call declaration_error ("numeric data must be binary", token_idx); 1363 end; 1364 else if token = "float" 1365 then do; 1366 if value_ptr ^= null 1367 then if ^value_ptr -> value_bead.numeric_value 1368 then call declaration_error ("parameter type incompatible with argument", token_idx); 1369 type = Type_float_bin_short; 1370 size = 27; 1371 packed = False; 1372 call get_next_token; 1373 if token = "bin" | token = "binary" 1374 then call get_next_token; 1375 else if token = "dec" | token = "decimal" 1376 then call declaration_error ("numeric data must be binary", token_idx); 1377 end; 1378 else call declaration_error ("invalid syntax", token_idx); 1379 1380 /* Decode size attribute, if any. */ 1381 1382 if token = "(" 1383 then do; 1384 call get_next_token; 1385 if token = "*" 1386 then size = 0; 1387 else if verify (token, "0123456789") = 0 & verify (token, "0") > 0 & token_len <= 10 1388 then size = bin (token, 35); 1389 else call declaration_error ("invalid size", token_idx); 1390 if type = Type_bit 1391 then do; 1392 if size > 36*sys_info$max_seg_size 1393 then call declaration_error ("size too big", token_idx); 1394 if member_ptr ^= null 1395 then if value_ptr = null 1396 then do; 1397 if size = 0 1398 then call declaration_error ("parameter size incompatible with argument", token_idx); 1399 end; 1400 else if rank = value_ptr -> value_bead.rhorho 1401 then do; 1402 if size = 0 1403 then size = 1; 1404 else if size ^= 1 1405 then call declaration_error ("parameter size incompatible with argument", token_idx); 1406 end; 1407 else if rank = value_ptr -> value_bead.rhorho - 1 1408 then do; 1409 if size = 0 1410 then size = value_ptr -> value_bead.rho (value_ptr -> value_bead.rhorho); 1411 else if size ^= value_ptr -> value_bead.rho (value_ptr -> value_bead.rhorho) 1412 then call declaration_error ("parameter size incompatible with argument", token_idx); 1413 last_dimension_implicit = True; 1414 end; 1415 end; 1416 else if type = Type_char 1417 then do; 1418 if size > 4*sys_info$max_seg_size 1419 then call declaration_error ("size too big", token_idx); 1420 if member_ptr ^= null 1421 then if value_ptr = null 1422 then do; 1423 if size = 0 1424 then call declaration_error ("parameter size incompatible with argument", token_idx); 1425 end; 1426 else if rank = value_ptr -> value_bead.rhorho 1427 then do; 1428 if size = 0 1429 then size = 1; 1430 else if size ^= 1 1431 then call declaration_error ("parameter size incompatible with argument", token_idx); 1432 end; 1433 else if rank = value_ptr -> value_bead.rhorho - 1 1434 then do; 1435 if size = 0 1436 then size = value_ptr -> value_bead.rho (value_ptr -> value_bead.rhorho); 1437 else if size ^= value_ptr -> value_bead.rho (value_ptr -> value_bead.rhorho) 1438 then call declaration_error ("parameter size incompatible with argument", token_idx); 1439 last_dimension_implicit = True; 1440 end; 1441 end; 1442 else if type = Type_fixed_bin_short 1443 then do; 1444 if size > 71 1445 then call declaration_error ("size too big", token_idx); 1446 else if size > 35 1447 then type = Type_fixed_bin_long; 1448 end; 1449 else if type = Type_float_bin_short 1450 then do; 1451 if size > 63 1452 then call declaration_error ("size too big", token_idx); 1453 else if size > 27 1454 then type = Type_float_bin_long; 1455 end; 1456 call get_next_token; 1457 if token ^= ")" 1458 then call declaration_error ("syntax error", token_idx); 1459 call get_next_token; 1460 end; 1461 1462 /* Decode alignment attribute, if any. */ 1463 1464 if token = "al" | token = "aligned" 1465 then do; 1466 packed = False; 1467 call get_next_token; 1468 end; 1469 else if token = "unal" | token = "unaligned" 1470 then do; 1471 packed = True; 1472 if type ^= Type_bit & type ^= Type_char 1473 then call declaration_error ("numeric data must be aligned", token_idx); 1474 call get_next_token; 1475 end; 1476 1477 /* Except for possible inconsistencies in the dimensioning, the declaration */ 1478 /* looks good, so fill in the header of the argument descriptor, followed */ 1479 /* by the dimension info (checking that it is consistent). */ 1480 1481 argument_desc.flag = "1"b; 1482 argument_desc.type = type; 1483 argument_desc.packed = packed; 1484 argument_desc.number_dims = rank; 1485 argument_desc.size = size; 1486 next_token_idx = token_idx; 1487 next_token_len = token_len; 1488 token_idx = dimensioning_idx; 1489 token_len = 1; 1490 if rank > 0 1491 then do; 1492 if type = Type_bit 1493 then bits_per_element = size; 1494 else if type = Type_char 1495 then bits_per_element = 9*size; 1496 else bits_per_element = size + 1; 1497 if packed 1498 then multiplier = bits_per_element; 1499 else do; 1500 multiplier = divide (bits_per_element + 35, 36, 35); 1501 bits_per_element = 36*multiplier; 1502 end; 1503 bits_in_value = bits_per_element; 1504 do i = 1 to rank; 1505 call get_next_token; 1506 bits_in_value = max (1, shape (i))*bits_in_value; 1507 if bits_in_value > 36*sys_info$max_seg_size 1508 then call declaration_error ("object too large", token_idx); 1509 j = rank - i + 1; 1510 argument_desc.lower_bound (j) = 1; 1511 argument_desc.upper_bound (j) = shape (i); 1512 argument_desc.multiplier (i) = multiplier; 1513 multiplier = shape (j)*multiplier; 1514 call get_next_token; 1515 end; 1516 end; 1517 if value_ptr ^= null 1518 then if value_ptr -> value_bead.rhorho > rank + fixed (last_dimension_implicit) 1519 then call declaration_error ("parameter has fewer dimensions than argument", token_idx); 1520 token_idx = next_token_idx; 1521 token_len = next_token_len; 1522 end process_parameter_dcl; 1523 round_to_even: proc (num) returns (fixed bin (18)); 1524 1525 /* Function: to return the smallest even integer not less than a given */ 1526 /* integer. */ 1527 1528 /* Arguments: */ 1529 /* */ 1530 /* num (Input) */ 1531 /* the integer to be rounded. */ 1532 1533 dcl num fixed bin (18); 1534 1535 return (num + mod (num, 2)); 1536 end round_to_even; 1537 update_byname_arguments: proc; 1538 1539 /* Function: to update the value of all arguments passed by name. */ 1540 1541 /* Global Arguments: */ 1542 /* */ 1543 /* argument_list (Input) */ 1544 /* the argument list for the routine just called (so we can find the */ 1545 /* argument descriptors and values). */ 1546 /* */ 1547 /* argument_desc (Input) */ 1548 /* the argument descriptors (so we can tell the format of the new */ 1549 /* values). */ 1550 /* */ 1551 /* list_ptr (Input) */ 1552 /* the address of the list bead for the right argument (so we can find */ 1553 /* and update the value of the by-name arguments). */ 1554 1555 dcl arg_num fixed bin, 1556 i fixed bin, 1557 j fixed bin, 1558 k fixed bin, 1559 member_num fixed bin, 1560 member_ptr ptr, 1561 value_ptr ptr; 1562 1563 do member_num = 2 to n_members; 1564 arg_num = member_num - 1; 1565 member_ptr = list_ptr -> list_bead.member_ptr (member_num); 1566 if member_ptr -> general_bead.symbol 1567 then do; 1568 argument_desc_ptr = argument_list.desc_ptrs (arg_num); 1569 value_ptr = member_ptr -> symbol_bead.meaning_pointer; 1570 if value_ptr = null 1571 then do; /* Allocate storage for the return value. */ 1572 call allocate_argument_storage (value_ptr); 1573 member_ptr -> symbol_bead.meaning_pointer = value_ptr; 1574 end; 1575 else if value_ptr -> value_bead.reference_count > 1 1576 then do; /* Allocate unique storage for the return value. */ 1577 member_ptr -> symbol_bead.meaning_pointer = null; 1578 value_ptr -> value_bead.reference_count = value_ptr -> value_bead.reference_count - 1; 1579 call allocate_argument_storage (value_ptr); 1580 member_ptr -> symbol_bead.meaning_pointer = value_ptr; 1581 end; 1582 if argument_desc.type = Type_bit 1583 then do; 1584 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 1585 float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer; 1586 if argument_desc.packed | mod (argument_desc.size, 36) = 0 1587 then do; 1588 bit_vec_size = float_bin_long_vec_len; 1589 bit_vec_len = 1; 1590 end; 1591 else do; 1592 bit_vec_size = argument_desc.size; 1593 bit_vec_len = divide (float_bin_long_vec_len, bit_vec_size, 24); 1594 end; 1595 bit_vec_pad = 36*divide (bit_vec_size + 35, 36, 24) - bit_vec_size; 1596 bit_vec_ptr = argument_list.arg_ptrs (arg_num); 1597 i = 1; 1598 do j = 1 to bit_vec_len; 1599 do k = 1 to bit_vec_size; 1600 float_bin_long_vec (i) = float (substr (bit_vec (j), k, 1)); 1601 i = i + 1; 1602 end; 1603 end; 1604 end; 1605 else if argument_desc.type = Type_char 1606 then do; 1607 unaligned_char_vec_size = argument_desc.size; 1608 unaligned_char_vec_len = divide (value_ptr -> value_bead.total_data_elements, 1609 unaligned_char_vec_size, 21); 1610 unaligned_char_vec_ptr = value_ptr -> value_bead.data_pointer; 1611 if ^argument_desc.packed & mod (argument_desc.size, 4) ^= 0 1612 then do; 1613 aligned_char_vec_size = unaligned_char_vec_size; 1614 aligned_char_vec_len = unaligned_char_vec_len; 1615 aligned_char_vec_ptr = argument_list.arg_ptrs (arg_num); 1616 do i = 1 to aligned_char_vec_len; 1617 unaligned_char_vec (i) = aligned_char_vec (i); 1618 end; 1619 end; 1620 else if unaligned_char_vec_ptr ^= argument_list.arg_ptrs (arg_num) 1621 then unspec (unaligned_char_vec) 1622 = unspec (argument_list.arg_ptrs (arg_num) -> unaligned_char_vec); 1623 end; 1624 else if argument_desc.type = Type_fixed_bin_long 1625 then do; 1626 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 1627 float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer; 1628 fixed_bin_long_vec_len = float_bin_long_vec_len; 1629 fixed_bin_long_vec_ptr = argument_list.arg_ptrs (arg_num); 1630 do i = 1 to fixed_bin_long_vec_len /* Copy to first non-Boolean. */ 1631 while (fixed_bin_long_vec (i) = 0 | fixed_bin_long_vec (i) = 1); 1632 float_bin_long_vec (i) = fixed_bin_long_vec (i); 1633 end; 1634 do j = i to fixed_bin_long_vec_len; /* Copy remainder. */ 1635 float_bin_long_vec (j) = fixed_bin_long_vec (j); 1636 end; 1637 if i > fixed_bin_long_vec_len 1638 then string (value_ptr -> value_bead.type) = zero_or_one_value_type; 1639 else string (value_ptr -> value_bead.type) = integral_value_type; 1640 end; 1641 else if argument_desc.type = Type_fixed_bin_short 1642 then do; 1643 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 1644 float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer; 1645 fixed_bin_short_vec_len = float_bin_long_vec_len; 1646 fixed_bin_short_vec_ptr = argument_list.arg_ptrs (arg_num); 1647 do i = 1 to fixed_bin_short_vec_len /* Copy to first non-Boolean. */ 1648 while (fixed_bin_short_vec (i) = 0 | fixed_bin_short_vec (i) = 1); 1649 float_bin_long_vec (i) = fixed_bin_short_vec (i); 1650 end; 1651 do j = i to fixed_bin_short_vec_len; /* Copy remainder. */ 1652 float_bin_long_vec (j) = fixed_bin_short_vec (j); 1653 end; 1654 if i > fixed_bin_short_vec_len 1655 then string (value_ptr -> value_bead.type) = zero_or_one_value_type; 1656 else string (value_ptr -> value_bead.type) = integral_value_type; 1657 end; 1658 else if argument_desc.type = Type_float_bin_long 1659 then do; 1660 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 1661 float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer; 1662 if float_bin_long_vec_ptr ^= argument_list.arg_ptrs (arg_num) 1663 then unspec (float_bin_long_vec) 1664 = unspec (argument_list.arg_ptrs (arg_num) -> float_bin_long_vec); 1665 do i = 1 to float_bin_long_vec_len /* Find first non-Boolean. */ 1666 while (float_bin_long_vec (i) = 0 | float_bin_long_vec (i) = 1); 1667 end; 1668 do j = i to float_bin_long_vec_len /* Find first non-integer. */ 1669 while (float_bin_long_vec (j) = floor (float_bin_long_vec (j))); 1670 end; 1671 if i > float_bin_long_vec_len 1672 then string (value_ptr -> value_bead.type) = zero_or_one_value_type; 1673 else if j > float_bin_long_vec_len 1674 then string (value_ptr -> value_bead.type) = integral_value_type; 1675 else string (value_ptr -> value_bead.type) = numeric_value_type; 1676 end; 1677 else if argument_desc.type = Type_float_bin_short 1678 then do; 1679 float_bin_long_vec_len = value_ptr -> value_bead.total_data_elements; 1680 float_bin_long_vec_ptr = value_ptr -> value_bead.data_pointer; 1681 float_bin_short_vec_len = float_bin_long_vec_len; 1682 float_bin_short_vec_ptr = argument_list.arg_ptrs (arg_num); 1683 do i = 1 to float_bin_short_vec_len /* Copy to first non-Boolean. */ 1684 while (float_bin_short_vec (i) = 0 | float_bin_short_vec (i) = 1); 1685 float_bin_long_vec (i) = float_bin_short_vec (i); 1686 end; 1687 do j = i to float_bin_short_vec_len /* Copy to first non-integer. */ 1688 while (float_bin_short_vec (j) = floor (float_bin_short_vec (j))); 1689 float_bin_long_vec (j) = float_bin_short_vec (j); 1690 end; 1691 do k = j to float_bin_short_vec_len; /* Copy remainder. */ 1692 float_bin_long_vec (k) = float_bin_short_vec (k); 1693 end; 1694 if i > float_bin_short_vec_len 1695 then string (value_ptr -> value_bead.type) = zero_or_one_value_type; 1696 else if j > float_bin_short_vec_len 1697 then string (value_ptr -> value_bead.type) = integral_value_type; 1698 else string (value_ptr -> value_bead.type) = numeric_value_type; 1699 end; 1700 end; 1701 end; 1702 end update_byname_arguments; 1703 validate_usage: proc; 1704 1705 /* Function: to ensure that we have been called correctly. */ 1706 1707 /* Global Arguments: */ 1708 /* */ 1709 /* list_ptr (Output) */ 1710 /* the address of the list bead for the right argument list. */ 1711 /* */ 1712 /* n_members (Output) */ 1713 /* the number of members in the right argument list. */ 1714 1715 dcl member_num fixed bin, 1716 member_ptr ptr; 1717 1718 /* Insure the usage is monadic and that the right argument is a list. */ 1719 1720 if operators_argument.value (Right_arg) = null 1721 then call error (apl_error_table_$domain, Function); 1722 else if operators_argument.value (Left_arg) ^= null 1723 then call error (apl_error_table_$domain, Left_arg); 1724 list_ptr = operators_argument.value (Right_arg); 1725 if string (list_ptr -> list_bead.type) ^= list_value_type 1726 then do; /* Convert simple value into 1 member list. */ 1727 n_members = 1; 1728 list_ptr = apl_push_stack_ (size (list_bead)); 1729 string (list_ptr -> list_bead.type) = list_value_type; 1730 list_ptr -> list_bead.number_of_members = 1; 1731 list_ptr -> list_bead.member_ptr (1) = operators_argument.value (Right_arg); 1732 unspec (list_ptr -> list_bead.bits) = ""b; 1733 list_ptr -> list_bead.semantics_on_stack = operators_argument.on_stack (Right_arg); 1734 operators_argument.value (Right_arg) = list_ptr; 1735 operators_argument.on_stack = True; 1736 end; 1737 else n_members = list_ptr -> list_bead.number_of_members; 1738 1739 /* Find first list member and check that it is of type character. */ 1740 1741 member_ptr = list_ptr -> list_bead.member_ptr (1); 1742 if string (member_ptr -> value_bead.type) ^= character_value_type 1743 then call error (apl_error_table_$domain, Right_arg); 1744 declaration_ptr = member_ptr -> value_bead.data_pointer; 1745 declaration_len = member_ptr -> value_bead.total_data_elements; 1746 1747 /* Check that the remaining list members are values, undefined symbols, or */ 1748 /* symbols pointing to values. */ 1749 1750 do member_num = 2 to n_members; 1751 member_ptr = list_ptr -> list_bead.member_ptr (member_num); 1752 if ^member_ptr -> general_bead.value 1753 then if ^member_ptr -> general_bead.symbol 1754 then call error (apl_error_table_$domain, Right_arg); 1755 else if member_ptr -> symbol_bead.meaning_pointer ^= null 1756 then if ^member_ptr -> symbol_bead.meaning_pointer -> general_bead.value 1757 then call error (apl_error_table_$domain, Right_arg); 1758 end; 1759 end validate_usage; 2 1 /* ====== BEGIN INCLUDE SEGMENT apl_characters.incl.pl1 =================================== */ 2 2 2 3 /* 2 4* * This include file contains all the characters in the APL character set, 2 5* * declared char(1) [Instead of fixed bin as in the apl_character_codes.incl.pl1 file] 2 6* * 2 7* Modified 780913 by PG to add CentSign 2 8* Modified 790319 by PG to add CommaHyphen 2 9* */ 2 10 2 11 declare ( 2 12 QBell init(""), 2 13 QBackSpace init(""), 2 14 QTab init(" "), 2 15 QNewLine init(" 2 16 "), 2 17 QSpace init(" "), 2 18 QExclamation init("!"), 2 19 QDollar init("$"), 2 20 QApostrophe init("'"), 2 21 QLeftParen init("("), 2 22 QRightParen init(")"), 2 23 QStar init("*"), 2 24 QPlus init("+"), 2 25 QComma init(","), 2 26 QMinus init("-"), 2 27 QPeriod init("."), 2 28 QSlash init("/"), 2 29 QZero init("0"), 2 30 QOne init("1"), 2 31 QTwo init("2"), 2 32 QThree init("3"), 2 33 QFour init("4"), 2 34 QFive init("5"), 2 35 QSix init("6"), 2 36 QSeven init("7"), 2 37 QEight init("8"), 2 38 QNine init("9"), 2 39 QColon init(":"), 2 40 QSemiColon init(";"), 2 41 QLessThan init("<"), 2 42 QEqual init("="), 2 43 QGreaterThan init(">"), 2 44 QQuestion init("?"), 2 45 QLetterA_ init("A"), 2 46 QLetterB_ init("B"), 2 47 QLetterC_ init("C"), 2 48 QLetterD_ init("D"), 2 49 QLetterE_ init("E"), 2 50 QLetterF_ init("F"), 2 51 QLetterG_ init("G"), 2 52 QLetterH_ init("H"), 2 53 QLetterI_ init("I"), 2 54 QLetterJ_ init("J"), 2 55 QLetterK_ init("K"), 2 56 QLetterL_ init("L"), 2 57 QLetterM_ init("M"), 2 58 QLetterN_ init("N"), 2 59 QLetterO_ init("O"), 2 60 QLetterP_ init("P"), 2 61 QLetterQ_ init("Q"), 2 62 QLetterR_ init("R"), 2 63 QLetterS_ init("S"), 2 64 QLetterT_ init("T"), 2 65 QLetterU_ init("U"), 2 66 QLetterV_ init("V"), 2 67 QLetterW_ init("W"), 2 68 QLetterX_ init("X"), 2 69 QLetterY_ init("Y"), 2 70 QLetterZ_ init("Z"), 2 71 QLeftBracket init("["), 2 72 QBackSlash init("\"), 2 73 QRightBracket init("]"), 2 74 QUnderLine init("_"), 2 75 QLetterA init("a"), 2 76 QLetterB init("b"), 2 77 QLetterC init("c"), 2 78 QLetterD init("d"), 2 79 QLetterE init("e"), 2 80 QLetterF init("f"), 2 81 QLetterG init("g"), 2 82 QLetterH init("h"), 2 83 QLetterI init("i"), 2 84 QLetterJ init("j"), 2 85 QLetterK init("k"), 2 86 QLetterL init("l"), 2 87 QLetterM init("m"), 2 88 QLetterN init("n"), 2 89 QLetterO init("o"), 2 90 QLetterP init("p"), 2 91 QLetterQ init("q"), 2 92 QLetterR init("r"), 2 93 QLetterS init("s"), 2 94 QLetterT init("t"), 2 95 QLetterU init("u"), 2 96 QLetterV init("v"), 2 97 QLetterW init("w"), 2 98 QLetterX init("x"), 2 99 QLetterY init("y"), 2 100 QLetterZ init("z"), 2 101 QLeftBrace init("{"), 2 102 QVerticalBar init("|"), 2 103 QRightBrace init("}"), 2 104 QTilde init("~"), 2 105 QLessOrEqual init("€"), 2 106 QGreaterOrEqual init(""), 2 107 QNotEqual init("‚"), 2 108 QOrSign init("ƒ"), 2 109 QAndSign init("„"), 2 110 QDivision init("…"), 2 111 QEpsilon init("†"), 2 112 QUpArrow init("‡"), 2 113 QDownArrow init("ˆ"), 2 114 QCircle init("‰"), 2 115 QCeiling init("Š"), 2 116 QFloor init("‹"), 2 117 QDelta init("Œ"), 2 118 QSmallCircle init(""), 2 119 QQuad init("Ž"), 2 120 QCap init(""), 2 121 QDeCode init(""), 2 122 QEnCode init("‘"), 2 123 QLeftLump init("’"), 2 124 QRightLump init("“"), 2 125 QCup init("”"), 2 126 QNorSign init("•"), 2 127 QNandSign init("–"), 2 128 QCircleHyphen init("—"), 2 129 QSlashHyphen init("˜"), 2 130 QDelTilde init("™"), 2 131 QCircleStar init("š"), 2 132 QCircleBar init("›"), 2 133 QCircleBackSlash init("œ"), 2 134 QCircleSlash init(""), 2 135 QGradeDown init("ž"), 2 136 QGradeUp init("Ÿ"), 2 137 QLamp init(" "), 2 138 QQuadQuote init("¡"), 2 139 QIBeam init("¢"), 2 140 QBackSlashHyphen init("£"), 2 141 QDomino init("¤"), 2 142 QDiaresis init("¥"), 2 143 QOmega init("¦"), 2 144 QIota init("§"), 2 145 QRho init("¨"), 2 146 QTimes init("©"), 2 147 QAlpha init("ª"), 2 148 QUpperMinus init("«"), 2 149 QDel init("¬"), 2 150 QLeftArrow init("­"), 2 151 QRightArrow init("®"), 2 152 QDiamond init("¯"), 2 153 QZero_ init("°"), 2 154 QOne_ init("±"), 2 155 QTwo_ init("²"), 2 156 QThree_ init("³"), 2 157 QFour_ init("´"), 2 158 QFive_ init("µ"), 2 159 QSix_ init("¶"), 2 160 QSeven_ init("·"), 2 161 QEight_ init("¸"), 2 162 QNine_ init("¹"), 2 163 QDelta_ init("º"), 2 164 QMarkError init("»"), 2 165 QExecuteSign init("¼"), 2 166 QFormatSign init("½"), 2 167 QLeftTack init("¾"), 2 168 QRightTack init("¿"), 2 169 QLineFeed init("À"), 2 170 QConditionalNewLine init("Á"), 2 171 QCentSign init("Â"), 2 172 QCommaHyphen init("Ã") 2 173 ) char(1) internal static options (constant); 2 174 2 175 /* ------ END INCLUDE SEGMENT apl_characters.incl.pl1 ----------------------------------- */ 1760 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_external_function.incl.pl1 ============================ */ 3 2 3 3 /* This include segment contains all of the Version 2 apl declarations necessary for an external apl 3 4* function to interface to apl. */ 3 5 3 6 /* automatic */ 3 7 3 8 declare data_elements fixed binary (21); /* number of elements for arrays */ 3 9 3 10 /* entries */ 3 11 3 12 declare apl_allocate_words_ entry (fixed binary (19), unaligned pointer); 3 13 /* param 1 (input) number of words to allocate */ 3 14 /* param 2 (output) word-aligned packed pointer to allocated bead, 3 15* with general_bead.size and general_bead.reference_count set. */ 3 16 3 17 declare apl_free_words_ entry (fixed binary (19), unaligned pointer); 3 18 /* param 1 (input) number of words to free */ 3 19 /* param 2 (input) word-aligned packed pointer to bead to be freed. */ 3 20 3 21 declare apl_free_bead_ entry (unaligned pointer); 3 22 /* param 1 (input) word-aligned packed pointer to bead to be freed. */ 3 23 /* if reference count is non-zero, a system error will result. */ 3 24 3 25 declare apl_get_value_stack_ entry (fixed binary (19)); 3 26 /* param 1 (input) number of words needed in a value stack. */ 3 27 /* (implicit) (output) sets ws_info.value_stack_ptr to point to new value stack. */ 3 28 3 29 declare apl_subsystem_ entry (fixed bin (35), bit (*) aligned, char (*), char (*), char (*), char (*), 3 30 fixed bin (35)); 3 31 /* param 1 (input) user number */ 3 32 /* param 2 (input) control switches (1 like ws_info.switches) */ 3 33 /* param 3 (input) initial ws pathname */ 3 34 /* param 4 (input) terminal conversion table to use */ 3 35 /* param 5 (output) user-specified signoff lock ("*" = no lock) */ 3 36 /* param 6 (output) 0 = normal termination, 3 37* apl_error_table_$off_hold = )OFF HOLD, 3 38* apl_error_table_$cant_load_ws = could not load initial ws */ 3 39 3 40 declare apl_system_error_ entry (fixed bin (35)); 3 41 /* param 1 (input) status code of error to be printed. */ 3 42 /* system errors will not return to caller. */ 3 43 3 44 /* external static */ 3 45 3 46 declare (apl_error_table_$cant_load_ws, /* status code returned by apl_subsystem_ if ws not found */ 3 47 apl_error_table_$domain, /* status code for DOMAIN ERROR */ 3 48 apl_error_table_$function, /* status code for FUNCTION ERROR - IN EXTERNAL FUNCTION */ 3 49 apl_error_table_$index, /* status code for INDEX ERROR */ 3 50 apl_error_table_$length, /* status code for LENGTH ERROR */ 3 51 apl_error_table_$no_type_bits, /* status code for SYSTEM ERROR - VALUE HAS NO TYPE BITS */ 3 52 apl_error_table_$rank, /* status code for RANK ERROR */ 3 53 apl_error_table_$result_size, /* status code for RESULT SIZE ERROR - OBJECT WOULD BE LARGER THAN A SEGMENT */ 3 54 apl_error_table_$system_error, /* status code for SYSTEM ERROR */ 3 55 apl_error_table_$off_hold) /* status code returned by apl_subsystem_ after )OFF HOLD */ 3 56 fixed binary (35) external static; 3 57 3 58 /* include files */ 3 59 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_number_data.incl.pl1 ================================== */ 4 2 4 3 /* 4 4* This include file contains information about the machine representation of numbers. 4 5* In all programs numbers should simply be declared 'float'. 4 6* All default statements should be in this include file. 4 7* 4 8* This is the binary version. The manifest constant Binary should be used by programs 4 9* that need to know whether we are using binary or decimal. 4 10* */ 4 11 4 12 /* format: style3,initlm0,idind30 */ 4 13 4 14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63); 4 15 4 16 declare ( 4 17 TheBiggestNumberWeveGot float initial (0.1701411834604692317e+39), 4 18 TheSmallestNumberWeveGot float initial (.1469367938527859385e-38), 4 19 Binary bit (1) aligned initial ("1"b) 4 20 ) internal static options (constant); 4 21 4 22 /* Number of characters in a number datum entry; used for copying float number arrays as strings. 4 23* (Obsolete! use array copies!) */ 4 24 4 25 declare NumberSize fixed binary precision (4) internal static initial (8); 4 26 4 27 /* ------ END INCLUDE SEGMENT apl_number_data.incl.pl1 ---------------------------------- */ 3 60 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 -------------------------------------- */ 3 61 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 ---------------------------------- */ 3 62 7 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 7 2 7 3 declare 7 4 number_of_dimensions fixed bin, 7 5 7 6 1 value_bead aligned based, 7 7 2 header aligned like general_bead, 7 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 7 9 2 rhorho fixed binary, /* number of dimensions of value */ 7 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 7 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 7 12 /* dimensions of value (zero-origin) */ 7 13 7 14 7 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 7 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 7 17 /* actual elements of character array */ 7 18 7 19 declare character_string_overlay character (data_elements) aligned based; 7 20 /* to overlay on above structure */ 7 21 7 22 7 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 7 24 /* actual elements of numeric array */ 7 25 7 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 7 27 7 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 7 29 7 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 3 63 8 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 8 2 8 3 declare 1 operators_argument aligned, 8 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 8 5* if operand (1).value is null, operator is monadic */ 8 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 8 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 8 8 2 operator aligned, /* information about the operator to be executed */ 8 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 8 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 8 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 8 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 8 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 8 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 8 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 8 16 8 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 3 64 3 65 3 66 /* ------ END INCLUDE SEGMENT apl_external_function.incl.pl1 ---------------------------- */ 1761 9 1 /* ====== BEGIN INCLUDE SEGMENT apl_list_bead.incl.pl1 ==================================== */ 9 2 9 3 declare n_members fixed bin, 9 4 9 5 1 list_bead aligned based, 9 6 2 header aligned like general_bead, 9 7 2 number_of_members fixed bin, 9 8 2 members dimension (n_members refer (list_bead.number_of_members)) aligned, 9 9 3 member_ptr unaligned pointer, 9 10 3 bits unaligned like operator_bead.bits_for_parse; 9 11 9 12 /* ------ END INCLUDE SEGMENT apl_list_bead.incl.pl1 ------------------------------------ */ 1762 10 1 /* ====== BEGIN INCLUDE SEGMENT apl_operator_bead.incl.pl1 ================================ */ 10 2 10 3 declare 10 4 1 operator_bead aligned based, 10 5 10 6 2 type unaligned like general_bead.type, 10 7 10 8 2 bits_for_lex unaligned, 10 9 3 allow_brackets bit(1), /* operator may have dimension info in brackets */ 10 10 3 allow_product bit(1), /* operator may be used in inner and outer product */ 10 11 3 allow_reduction bit(1), /* operator may be used in reduction and scan */ 10 12 3 special_assignment bit(1), /* doesn't use standard assignment operator */ 10 13 3 ignores_assignment bit(1), /* assignment has no effect */ 10 14 3 allow_subscripted_assignment 10 15 bit(1), /* system variable that can be subscripted assigned */ 10 16 3 pad bit(12), 10 17 10 18 2 bits_for_parse unaligned, 10 19 3 stop_trace_control bit(1), /* next lexeme is function being stopped/traced 10 20* (op1 tells which) */ 10 21 3 quad bit(1), /* this is a quad type */ 10 22 3 system_variable bit(1), /* this is a system variable, not an op */ 10 23 3 dyadic bit(1), /* operator may be dyadic */ 10 24 3 monadic bit(1), /* operator may be monadic */ 10 25 3 function bit(1), /* operator is a user defined function */ 10 26 3 semantics_valid bit(1), /* if semantics has been set */ 10 27 3 has_list bit(1), /* semantics is a list */ 10 28 3 inner_product bit(1), /* op2 is valid */ 10 29 3 semantics_on_stack bit(1), /* semantics points to value stack */ 10 30 3 is_external_function bit(1), /* semantics points to function bead for ext function */ 10 31 3 pad bit(7), 10 32 3 op2 fixed bin(8) unaligned, /* secondary operator code */ 10 33 3 op1 fixed bin(8) unaligned, /* primary operator code */ 10 34 2 type_code fixed bin; /* for parse */ 10 35 10 36 /* ------ END INCLUDE SEGMENT apl_operator_bead.incl.pl1 -------------------------------- */ 1763 11 1 /* ====== BEGIN INCLUDE SEGMENT apl_symbol_bead.incl.pl1 ================================== */ 11 2 11 3 /* Explanation of fields: 11 4* symbol_bead.hash_link_pointer points to next symbol in same hash bucket in the symbol table. 11 5* symbol_bead.meaning_pointer points to current "value" of this name: 11 6* = null => unused (e.g. undefined variable) 11 7* -> group bead => group name 11 8* -> value bead => variable with a value 11 9* -> function bead => function name 11 10* -> label bead => localized label value 11 11* -> shared var bead => shared variable */ 11 12 11 13 declare 1 symbol_bead aligned based, 11 14 2 header aligned like general_bead, 11 15 2 hash_link_pointer pointer unaligned, 11 16 2 meaning_pointer pointer unaligned, 11 17 2 name_length fixed binary, 11 18 2 name character (0 refer (symbol_bead.name_length)) unaligned; 11 19 11 20 /* ------ END INCLUDE SEGMENT apl_symbol_bead.incl.pl1 ---------------------------------- */ 1764 12 1 /* BEGIN INCLUDE FILE ... arg_descriptor.incl.pl1 12 2* 12 3* James R. Davis 1 Mar 79 */ 12 4 /* Modified June 83 JMAthane for extended arg descriptor format */ 12 5 12 6 dcl 1 arg_descriptor based (arg_descriptor_ptr) aligned, 12 7 2 flag bit (1) unal, 12 8 2 type fixed bin (6) unsigned unal, 12 9 2 packed bit (1) unal, 12 10 2 number_dims fixed bin (4) unsigned unal, 12 11 2 size fixed bin (24) unsigned unal; 12 12 12 13 dcl 1 fixed_arg_descriptor based (arg_descriptor_ptr) aligned, 12 14 2 flag bit (1) unal, 12 15 2 type fixed bin (6) unsigned unal, 12 16 2 packed bit (1) unal, 12 17 2 number_dims fixed bin (4) unsigned unal, 12 18 2 scale fixed bin (11) unal, 12 19 2 precision fixed bin (12) unsigned unal; 12 20 12 21 dcl 1 extended_arg_descriptor based (arg_descriptor_ptr) aligned, 12 22 2 flag bit (1) unal, /* = "1"b */ 12 23 2 type fixed bin (6) unsigned unal, /* = 58 */ 12 24 2 packed bit (1) unal, /* significant if number_dims ^= 0 */ 12 25 2 number_dims fixed (4) unsigned unal,/* number of variable dimensions */ 12 26 2 size bit (24) unal, 12 27 2 dims (0 refer (extended_arg_descriptor.number_dims)), /* part referenced by called generated code */ 12 28 3 low fixed bin (35), 12 29 3 high fixed bin (35), 12 30 3 multiplier fixed bin (35), /* in bits if packed, in words if not */ 12 31 2 real_type fixed bin (18) unsigned unal, 12 32 2 type_offset fixed bin (18) unsigned unal; /* offset rel to symbol tree to symbol node for type, if any */ 12 33 12 34 dcl arg_descriptor_ptr ptr; 12 35 12 36 dcl extended_arg_type fixed bin init (58); 12 37 12 38 /* END INCLUDE file .... arg_descriptor.incl.pl1 */ 1765 13 1 /* BEGIN INCLUDE FILE ... arg_list.incl.pl1 13 2* 13 3* James R. Davis 10 May 79 */ 13 4 13 5 dcl 1 arg_list aligned based, 13 6 2 header, 13 7 3 arg_count fixed bin (17) unsigned unal, 13 8 3 pad1 bit (1) unal, 13 9 3 call_type fixed bin (18) unsigned unal, 13 10 3 desc_count fixed bin (17) unsigned unal, 13 11 3 pad2 bit (19) unal, 13 12 2 arg_ptrs (arg_list_arg_count refer (arg_list.arg_count)) ptr, 13 13 2 desc_ptrs (arg_list_arg_count refer (arg_list.arg_count)) ptr; 13 14 13 15 13 16 13 17 dcl 1 arg_list_with_envptr aligned based, /* used with non-quick int and entry-var calls */ 13 18 2 header, 13 19 3 arg_count fixed bin (17) unsigned unal, 13 20 3 pad1 bit (1) unal, 13 21 3 call_type fixed bin (18) unsigned unal, 13 22 3 desc_count fixed bin (17) unsigned unal, 13 23 3 pad2 bit (19) unal, 13 24 2 arg_ptrs (arg_list_arg_count refer (arg_list_with_envptr.arg_count)) ptr, 13 25 2 envptr ptr, 13 26 2 desc_ptrs (arg_list_arg_count refer (arg_list_with_envptr.arg_count)) ptr; 13 27 13 28 13 29 dcl ( 13 30 Quick_call_type init (0), 13 31 Interseg_call_type init (4), 13 32 Envptr_supplied_call_type 13 33 init (8) 13 34 ) fixed bin (18) unsigned unal int static options (constant); 13 35 13 36 /* The user must declare arg_list_arg_count - if an adjustable automatic structure 13 37* is being "liked" then arg_list_arg_count may be a parameter, in order to allocate 13 38* an argument list of the proper size in the user's stack 13 39* 13 40**/ 13 41 /* END INCLUDE FILE ... arg_list.incl.pl1 */ 1766 1767 return: 1768 end apl_quadcall_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1558.2 apl_quadcall_.pl1 >special_ldd>on>apl.1129>apl_quadcall_.pl1 338 1 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_fcn.incl.pl1 1760 2 03/27/82 0438.6 apl_characters.incl.pl1 >ldd>include>apl_characters.incl.pl1 1761 3 03/27/82 0438.7 apl_external_function.incl.pl1 >ldd>include>apl_external_function.incl.pl1 3-60 4 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 3-61 5 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 3-62 6 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 3-63 7 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 3-64 8 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 1762 9 03/27/82 0438.7 apl_list_bead.incl.pl1 >ldd>include>apl_list_bead.incl.pl1 1763 10 03/27/82 0439.0 apl_operator_bead.incl.pl1 >ldd>include>apl_operator_bead.incl.pl1 1764 11 03/27/82 0439.2 apl_symbol_bead.incl.pl1 >ldd>include>apl_symbol_bead.incl.pl1 1765 12 11/02/83 1845.0 arg_descriptor.incl.pl1 >ldd>include>arg_descriptor.incl.pl1 1766 13 10/23/81 1948.6 arg_list.incl.pl1 >ldd>include>arg_list.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. False constant bit(1) initial unaligned dcl 108 ref 244 378 917 1132 1234 1330 1357 1371 1466 Function 000102 constant fixed bin(17,0) initial dcl 108 set ref 383* 1720* Interseg_call_type constant fixed bin(18,0) initial unsigned unaligned dcl 13-29 ref 1110 Left_arg 000106 constant fixed bin(17,0) initial dcl 108 set ref 850 1722 1722* Letters 000000 constant char(52) initial unaligned dcl 1071 ref 1087 1094 MAX_VALUE_BEAD_SIZE constant fixed bin(19,0) initial dcl 7-28 ref 383 Max_rank 014041 constant fixed bin(17,0) initial dcl 108 ref 319 322 892 892 896 1234 1268 P_n_words parameter fixed bin(19,0) dcl 1-16 ref 1-4 1-35 QAndSign 000015 constant char(1) initial unaligned dcl 2-11 set ref 830* Right_arg 000107 constant fixed bin(17,0) initial dcl 108 set ref 831* 852 1720 1724 1731 1733 1734 1742* 1752* 1755* Token_chars 000016 constant char(63) initial unaligned dcl 108 ref 711 711 955 True constant bit(1) initial unaligned dcl 108 ref 240 374 902 909 1264 1305 1315 1331 1413 1439 1471 1735 Type_bit constant fixed bin(17,0) initial dcl 108 ref 238 257 372 397 619 633 1177 1303 1390 1472 1492 1582 Type_char constant fixed bin(17,0) initial dcl 108 ref 238 246 255 372 380 421 622 660 901 908 1180 1313 1416 1472 1494 1605 Type_entry constant fixed bin(17,0) initial dcl 108 ref 689 1328 Type_fixed_bin_long constant fixed bin(17,0) initial dcl 108 ref 259 444 723 1446 1624 Type_fixed_bin_short constant fixed bin(17,0) initial dcl 108 ref 259 461 739 1355 1442 1641 Type_float_bin_long constant fixed bin(17,0) initial dcl 108 ref 478 755 916 1453 1658 Type_float_bin_short constant fixed bin(17,0) initial dcl 108 ref 499 766 1369 1449 1677 addrel builtin function dcl 1-25 ref 1-44 aligned_char_vec based char array dcl 164 set ref 434 670 670 671* 673* 1617 aligned_char_vec_len 000100 automatic fixed bin(21,0) dcl 124 set ref 431* 433 669* 670 670 671 672 1614* 1616 aligned_char_vec_ptr 000102 automatic pointer dcl 124 set ref 432* 434 670* 670 670 671 673 675 1615* 1617 aligned_char_vec_size 000104 automatic fixed bin(21,0) dcl 124 set ref 430* 434 434 434 668* 670 670 670 670 671 671 673 673 673 1613* 1617 1617 1617 apl_allocate_words_ 000074 constant entry external dcl 222 ref 250 apl_error_table_$domain 000066 external static fixed bin(35,0) dcl 3-46 set ref 831* 1720* 1722* 1742* 1752* 1755* apl_error_table_$result_size 000070 external static fixed bin(35,0) dcl 3-46 set ref 383* apl_free_bead_ 000100 constant entry external dcl 536 ref 553 apl_get_value_stack_ 000076 constant entry external dcl 1-30 ref 1-40 apl_static_$ws_info_ptr 000072 external static structure level 1 dcl 5-11 arg_count based fixed bin(17,0) level 3 in structure "argument_list" packed unsigned unaligned dcl 162 in procedure "apl_quadcall_" set ref 1108* arg_count based fixed bin(17,0) level 3 in structure "arg_list" packed unsigned unaligned dcl 13-5 in procedure "apl_quadcall_" ref 366 614 1126 1152 1171 1568 arg_descriptor based structure level 1 dcl 12-6 arg_list based structure level 1 dcl 13-5 arg_list_arg_count 000105 automatic fixed bin(17,0) dcl 124 set ref 182 182 184 333* 334 334 335 335 366 412 432 439 449 466 481 504 1106* 1106 1108 1111 arg_num 000116 automatic fixed bin(17,0) dcl 1555 in procedure "update_byname_arguments" set ref 1564* 1568 1596 1615 1620 1620 1629 1646 1662 1662 1682 arg_num 000214 automatic fixed bin(17,0) dcl 579 in procedure "convert_arguments" set ref 609* 614 631 658 675 677 686 711 716 719 721 737 753 755 764 777 779 787 arg_num 000434 automatic fixed bin(17,0) dcl 1073 in procedure "process_declaration" set ref 1116* 1122* 1122 1123 1125 1126 1127 1149 1150* 1150 1151 1152 1153 1159 1170 1171 arg_ptrs 2 based pointer array level 2 dcl 162 set ref 182* 182 184* 412 432 439 449 466 481 504 631* 658* 675* 677* 686* 721* 737* 753* 755* 764* 777* 779* 1596 1615 1620 1620 1629 1646 1662 1662 1682 argument_desc based structure level 1 unaligned dcl 155 set ref 1129 1155 argument_desc_ptr 000106 automatic pointer dcl 124 set ref 234 236 238 238 238 242 246 255 257 259 259 267 269 271 335* 336 366* 368 370 372 372 372 375 380 389 390 390 392 397 402 402 408 421 424 424 426 444 461 478 499 614* 618 619 619 622 622 624 625 625 625 627 627 633 637 637 643 660 662 662 664 689 723 731 739 747 755 766 897 901 902 903 904 908 909 910 911 916 917 918 919 924 925 926 1126 1129* 1129 1129 1129 1152 1155* 1155 1155 1155 1171 1176 1177 1177 1180 1180 1182 1183 1183 1183 1185 1185 1481 1482 1483 1484 1485 1510 1511 1512 1568* 1582 1586 1586 1592 1605 1607 1611 1611 1624 1641 1658 1677 argument_list based structure level 1 unaligned dcl 162 set ref 334 335 argument_list_ptr 000110 automatic pointer dcl 124 set ref 182 182 184 185* 191* 334* 334 335 335 366 412 432 439 449 466 481 504 614 631 658 675 677 686 721 737 753 755 764 777 779 1108 1109 1110 1111 1112 1126 1152 1171 1568 1596 1615 1620 1620 1629 1646 1662 1662 1682 bead_ptr 000112 automatic pointer dcl 355 set ref 385* 386 387 388 388 390 392 399 423 457 459 474 476 493 495 497 516 518 520 bead_size 000114 automatic fixed bin(18,0) dcl 355 in procedure "assign_result" set ref 379* 383 385 388 bead_size 000106 automatic fixed bin(18,0) dcl 224 in procedure "allocate_argument_storage" set ref 245* 249 266 bead_type based structure level 3 packed unaligned dcl 6-3 binary builtin function dcl 1-25 ref 1-40 bit_vec based bit array unaligned dcl 164 set ref 416 629 629 630* 649 649 653* 656 1600 bit_vec_len 000112 automatic fixed bin(24,0) dcl 124 set ref 405* 409* 414 617* 629 629 630 640* 644* 649 649 651 1589* 1593* 1598 bit_vec_pad 000113 automatic fixed bin(17,0) dcl 124 set ref 411* 416 416 416 628* 629 629 629 629 630 630 646* 649 649 649 649 653 653 653 656 656 656 1595* 1600 1600 1600 bit_vec_ptr 000114 automatic pointer dcl 124 set ref 412* 416 629* 629 629 630 631 647* 649* 649 649 653 656 658 1596* 1600 bit_vec_size 000116 automatic fixed bin(24,0) dcl 124 set ref 404* 408* 409 411 411 415 416 416 416 619* 622* 624* 625* 627* 628 628 629 629 629 629 630 630 639* 643* 644 646 646 649 649 649 649 652 653 653 653 656 656 656 1588* 1592* 1593 1595 1595 1599 1600 1600 1600 bits 4 based structure array level 3 packed unaligned dcl 9-3 set ref 1732* bits_for_parse 1 based structure level 2 packed unaligned dcl 10-3 bits_in_result 000117 automatic fixed bin(24,0) dcl 124 set ref 181 182 1177* 1180* 1182* 1183* 1185* 1187* bits_in_value 000100 automatic fixed bin(71,0) dcl 1234 set ref 1503* 1506* 1506 1507 bits_per_element 000102 automatic fixed bin(17,0) dcl 1234 set ref 1492* 1494* 1496* 1497 1500 1501* 1503 block_ptr 000100 automatic pointer dcl 1-20 set ref 1-43* 1-45 call_type 0(18) based fixed bin(18,0) level 3 packed unsigned unaligned dcl 162 set ref 1110* calling_a_function 000120 automatic bit(1) unaligned dcl 124 set ref 179 1105* 1106 character_string_overlay based char dcl 7-19 ref 246 246 character_value_type constant bit(18) initial unaligned dcl 6-30 ref 255 423 898 1310 1326 1742 codeptr builtin function dcl 994 ref 1006 1006 1012 1012 convert_status_code_ 000116 constant entry external dcl 1025 ref 1030 cu_$generate_call 000064 constant entry external dcl 102 ref 185 191 data_elements 000163 automatic fixed bin(21,0) dcl 3-8 set ref 233* 236* 236 242* 242 246 246 246 246 248 264 367* 370* 370 375* 375 380 380 382 386 400 427 440 446 463 480 501 data_pointer 4 based pointer level 2 packed unaligned dcl 7-3 set ref 266* 388* 636 667 677 684 691 726 742 755 762 769 1585 1610 1627 1644 1661 1680 1744 data_ptr 000116 automatic pointer dcl 355 set ref 388* 401 429 441 447 464 484 488 491 502 data_size 000107 automatic fixed bin(18,0) dcl 224 in procedure "allocate_argument_storage" set ref 246* 248* 249 data_size 000120 automatic fixed bin(18,0) dcl 355 in procedure "assign_result" set ref 380* 382* 383 385 data_type 0(08) based structure level 4 packed unaligned dcl 7-3 declaration based char unaligned dcl 164 set ref 830* 951 952 955 956 958 1105 declaration_idx parameter fixed bin(17,0) dcl 825 ref 805 830 declaration_len 000121 automatic fixed bin(17,0) dcl 124 set ref 830 830 951 952 955 956 958 1105 1745* declaration_ptr 000122 automatic pointer dcl 124 set ref 791 791 791 793 799 801 830 951 952 955 956 958 1087 1089 1091 1094 1096 1100 1105 1117 1120 1130 1134 1138 1141 1144 1147 1164 1167 1173 1192 1259 1259 1262 1270 1278 1278 1278 1281 1289 1291 1298 1308 1308 1318 1333 1336 1339 1342 1346 1349 1359 1359 1361 1361 1364 1373 1373 1375 1375 1382 1385 1387 1387 1387 1457 1464 1464 1469 1469 1744* desc_count 1 based fixed bin(17,0) level 3 packed unsigned unaligned dcl 162 set ref 1111* desc_ptrs based pointer array level 2 dcl 162 set ref 366 614 1126* 1152* 1171* 1568 descriptor_space 000200 automatic fixed bin(17,0) dcl 304 set ref 319* 327* 327 334 336 dimension_info 1 based structure array level 2 unaligned dcl 155 dimensioning_idx 000103 automatic fixed bin(17,0) dcl 1234 set ref 1261* 1488 dir_name 000276 automatic char(168) unaligned dcl 998 set ref 1008* 1009* dummy_chars based char(1) array unaligned dcl 164 set ref 697 703 791 791 791 793 799 801 1087 1089 1091 1094 1096 1100 1117 1120 1130 1134 1138 1141 1144 1147 1164 1167 1173 1192 1259 1259 1262 1270 1278 1278 1278 1281 1289 1291 1298 1308 1308 1318 1333 1336 1339 1342 1346 1349 1359 1359 1361 1361 1364 1373 1373 1375 1375 1382 1385 1387 1387 1387 1457 1464 1464 1469 1469 entry parameter entry variable dcl 983 in procedure "make_entry" set ref 961 1012* entry based entry variable dcl 595 in procedure "convert_arguments" set ref 714 714 715* entry_ptr 000216 automatic pointer dcl 579 set ref 714* 714 714 715 721 error_code 7 parameter fixed bin(35,0) level 2 dcl 8-3 set ref 196* 849* error_msg parameter char unaligned dcl 825 set ref 805 830* extended_arg_type 000170 automatic fixed bin(17,0) initial dcl 12-36 set ref 12-36* fixed_bin_long_vec based fixed bin(71,0) array dcl 164 set ref 450 450 452 455 730 730 735* 1630 1630 1632 1635 fixed_bin_long_vec_len 000124 automatic fixed bin(17,0) dcl 124 set ref 448* 450 454 457 727* 730 730 732 1628* 1630 1634 1637 fixed_bin_long_vec_ptr 000126 automatic pointer dcl 124 set ref 449* 450 450 452 455 728* 730* 730 730 735 737 1629* 1630 1630 1632 1635 fixed_bin_short_vec based fixed bin(35,0) array dcl 164 set ref 467 467 469 472 746 746 751* 1647 1647 1649 1652 fixed_bin_short_vec_len 000130 automatic fixed bin(18,0) dcl 124 set ref 465* 467 471 474 743* 746 746 748 1645* 1647 1651 1654 fixed_bin_short_vec_ptr 000132 automatic pointer dcl 124 set ref 466* 467 467 469 472 744* 746* 746 746 751 753 1646* 1647 1647 1649 1652 flag based bit(1) level 3 packed unaligned dcl 155 set ref 897* 1481* float_bin_long_vec based float bin(63) array dcl 164 set ref 416* 452* 455* 469* 472* 482 482 484* 484 486 486 488* 488 491* 491 507* 511* 514* 653 733 733 735 749 749 751 761 761 762* 762 775 1600* 1632* 1635* 1649* 1652* 1662* 1662 1665 1665 1668 1668 1685* 1689* 1692* float_bin_long_vec_len 000134 automatic float bin(17) dcl 124 set ref 400* 404 409 446* 448 463* 465 480* 482 486 490 493 495 501* 503 635* 639 644 725* 727 741* 743 760* 761 761 762 762 768* 770 1584* 1588 1593 1626* 1628 1643* 1645 1660* 1662 1662 1665 1668 1671 1673 1679* 1681 float_bin_long_vec_ptr 000136 automatic pointer dcl 124 set ref 401* 416 447* 452 455 464* 469 472 481* 482 482 484 486 486 488 491 502* 507 511 514 636* 647 653 726* 728 733 733 735 742* 744 749 749 751 761* 761 761 762 764 769* 771 775 1585* 1600 1627* 1632 1635 1644* 1649 1652 1661* 1662 1662 1665 1665 1668 1668 1680* 1685 1689 1692 float_bin_short_vec based float bin(27) array dcl 164 set ref 505 505 507 509 509 511 514 773 773 775* 1683 1683 1685 1687 1687 1689 1692 float_bin_short_vec_len 000140 automatic float bin(18) dcl 124 set ref 503* 505 509 513 516 518 770* 773 773 774 1681* 1683 1687 1691 1694 1696 float_bin_short_vec_ptr 000142 automatic pointer dcl 124 set ref 504* 505 505 507 509 509 511 514 771* 773* 773 773 775 777 1682* 1683 1683 1685 1687 1687 1689 1692 general_bead based structure level 1 dcl 6-3 hcs_$fs_get_path_name 000104 constant entry external dcl 988 ref 1006 hcs_$fs_get_seg_ptr 000106 constant entry external dcl 988 ref 1003 hcs_$initiate 000110 constant entry external dcl 988 ref 1009 hcs_$make_entry 000112 constant entry external dcl 988 ref 1012 header based structure level 2 in structure "list_bead" dcl 9-3 in procedure "apl_quadcall_" header based structure level 2 in structure "arg_list" dcl 13-5 in procedure "apl_quadcall_" header based structure level 2 in structure "argument_list" packed unaligned dcl 162 in procedure "apl_quadcall_" header based structure level 2 in structure "value_bead" dcl 7-3 in procedure "apl_quadcall_" header based structure level 2 in structure "argument_desc" packed unaligned dcl 155 in procedure "apl_quadcall_" i 000117 automatic fixed bin(17,0) dcl 1555 in procedure "update_byname_arguments" set ref 1597* 1600 1601* 1601 1616* 1617 1617* 1630* 1630 1630* 1632 1632* 1634 1637 1647* 1647 1647* 1649 1649* 1651 1654 1665* 1665 1665* 1668 1671 1683* 1683 1683* 1685 1685* 1687 1694 i 000100 automatic fixed bin(17,0) dcl 538 in procedure "collect_garbage" set ref 547* 548 549* i 000104 automatic fixed bin(17,0) dcl 1234 in procedure "process_parameter_dcl" set ref 1504* 1506 1509 1511 1512* i 000260 automatic fixed bin(17,0) dcl 878 in procedure "generate_argument_desc" set ref 922* 923 925 926* i 000121 automatic fixed bin(17,0) dcl 355 in procedure "assign_result" set ref 369* 370* 389* 390 390* 413* 416 417* 417 433* 434 434* 450* 450 450* 452 452* 454 457 467* 467 467* 469 469* 471 474 482* 482 482* 484 484* 486 493 505* 505 505* 507 507* 509 516 i 000201 automatic fixed bin(17,0) dcl 304 in procedure "allocate_table_space" set ref 320* 321* i 000110 automatic fixed bin(17,0) dcl 224 in procedure "allocate_argument_storage" set ref 235* 236* 268* 269 269* 271 i 000220 automatic fixed bin(17,0) dcl 579 in procedure "convert_arguments" set ref 650* 653 654* 654 672* 673 673* 694* 695 697 698 700* 701 703 704 705 732* 733 733 735 735* 748* 749 749 751 751* 774* 775 775* integral_value_type constant bit(18) initial unaligned dcl 6-30 ref 259 459 476 495 518 1351 1639 1656 1673 1696 ioa_$nnl 000102 constant entry external dcl 828 ref 830 j 000105 automatic fixed bin(17,0) dcl 1234 in procedure "process_parameter_dcl" set ref 1509* 1510 1511 1513 j 000261 automatic fixed bin(17,0) dcl 878 in procedure "generate_argument_desc" set ref 923* 924 925 927 j 000122 automatic fixed bin(17,0) dcl 355 in procedure "assign_result" set ref 414* 416* 454* 455 455* 471* 472 472* 486* 486 486* 488 488* 490 495 509* 509 509* 511 511* 513 518 j 000221 automatic fixed bin(17,0) dcl 579 in procedure "convert_arguments" set ref 651* 653 656* j 000120 automatic fixed bin(17,0) dcl 1555 in procedure "update_byname_arguments" set ref 1598* 1600* 1634* 1635 1635* 1651* 1652 1652* 1668* 1668 1668* 1673 1687* 1687 1687* 1689 1689* 1691 1696 k 000121 automatic fixed bin(17,0) dcl 1555 in procedure "update_byname_arguments" set ref 1599* 1600* 1691* 1692 1692* k 000123 automatic fixed bin(17,0) dcl 355 in procedure "assign_result" set ref 415* 416* 490* 491 491* 513* 514 514* k 000222 automatic fixed bin(17,0) dcl 579 in procedure "convert_arguments" set ref 652* 653* 656 last_dimension_implicit 000124 automatic bit(1) unaligned dcl 355 in procedure "assign_result" set ref 374* 378* 392 last_dimension_implicit 000106 automatic bit(1) initial unaligned dcl 1234 in procedure "process_parameter_dcl" set ref 1234* 1331* 1413* 1439* 1517 last_dimension_implicit 000111 automatic bit(1) unaligned dcl 224 in procedure "allocate_argument_storage" set ref 240* 244* 271 list_bead based structure level 1 dcl 9-3 set ref 1728 1728 list_ptr 000144 automatic pointer dcl 124 set ref 321 546 548 549 610 647 677 728 744 755 771 1127 1153 1565 1724* 1725 1728* 1729 1730 1731 1732 1733 1734 1737 1741 1751 list_value_type constant bit(18) initial unaligned dcl 6-30 ref 1725 1729 long_info 000372 automatic char(100) dcl 1027 set ref 1030* 1031 lower_bound 1 based fixed bin(35,0) array level 3 dcl 155 set ref 924* 1510* marker based fixed bin(17,0) array dcl 164 set ref 334 711* 716* 719* 787 1086* 1125* 1151* 1170* 1195* 1198* marker_ptr 000146 automatic pointer dcl 124 set ref 334 336* 711 716 719 787 1086 1125 1151 1170 1195 1198 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 5-16 ref 1-40 meaning_pointer 3 based pointer level 2 packed unaligned dcl 11-13 set ref 322 325 611 886 1252 1569 1573* 1577* 1580* 1755 1755 member_num 000122 automatic fixed bin(17,0) dcl 1555 in procedure "update_byname_arguments" set ref 1563* 1564 1565* member_num 000472 automatic fixed bin(17,0) dcl 1715 in procedure "validate_usage" set ref 1750* 1751* member_num 000223 automatic fixed bin(17,0) dcl 579 in procedure "convert_arguments" set ref 608* 609 610 647 677 728 744 755 771* member_ptr parameter pointer dcl 1230 in procedure "process_parameter_dcl" ref 1201 1251 1252 1252 1252 1270 1320 1394 1420 member_ptr 000202 automatic pointer dcl 304 in procedure "allocate_table_space" set ref 321* 322 322 325 326 member_ptr 000474 automatic pointer dcl 1715 in procedure "validate_usage" set ref 1741* 1742 1744 1745 1751* 1752 1752 1755 1755 member_ptr 000102 automatic pointer dcl 538 in procedure "collect_garbage" set ref 548* 549 552 552 553 553 member_ptr 000436 automatic pointer dcl 1073 in procedure "process_declaration" set ref 1127* 1128* 1153* 1154* member_ptr 000224 automatic pointer dcl 579 in procedure "convert_arguments" set ref 610* 611 611 613 677 755 member_ptr 000124 automatic pointer dcl 1555 in procedure "update_byname_arguments" set ref 1565* 1566 1569 1573 1577 1580 member_ptr 3 based pointer array level 3 in structure "list_bead" packed unaligned dcl 9-3 in procedure "apl_quadcall_" set ref 321 548 610 1127 1153 1565 1731* 1741 1751 member_ptr parameter pointer dcl 876 in procedure "generate_argument_desc" ref 856 884 886 887 890 892 892 members 3 based structure array level 2 dcl 9-3 module_name parameter char unaligned dcl 983 in procedure "make_entry" set ref 961 1003* 1008* 1009* 1009* 1012* module_name based char unaligned dcl 595 in procedure "convert_arguments" set ref 693 694 700 711 711 711 715* 716 716 719 module_name 000440 automatic char(32) unaligned dcl 1073 in procedure "process_declaration" set ref 1087 1089* 1099 1194* 1195 1195 1198 module_name_len 000226 automatic fixed bin(21,0) dcl 579 set ref 692* 693* 693 694 698* 698 700 704 705* 709 711 711 711 715 715 716 716 719 module_name_ptr 000230 automatic pointer dcl 579 set ref 691* 693 694 697* 697 700 703 708 711 711 711 715 716 716 719 more 000450 automatic bit(1) unaligned dcl 1073 in procedure "process_declaration" set ref 1120* 1121 1132* more 000107 automatic bit(1) unaligned dcl 1234 in procedure "process_parameter_dcl" set ref 1264* 1265 1289* multiplier 3 based fixed bin(35,0) array level 3 in structure "argument_desc" dcl 155 in procedure "apl_quadcall_" set ref 625 627 926* 1183 1185 1512* multiplier 000110 automatic fixed bin(35,0) dcl 1234 in procedure "process_parameter_dcl" set ref 1497* 1500* 1501 1512 1513* 1513 multiplier 000262 automatic fixed bin(35,0) dcl 878 in procedure "generate_argument_desc" set ref 905* 912* 920* 926 927* 927 n_members 000167 automatic fixed bin(17,0) dcl 9-3 set ref 320 333 334 547 608 1123 1149 1159 1563 1727* 1728 1728 1737* 1750 name 5 based char level 2 packed unaligned dcl 11-13 ref 887 892 name_length 4 based fixed bin(17,0) level 2 dcl 11-13 ref 887 892 next_token_idx 000111 automatic fixed bin(17,0) dcl 1234 set ref 1486* 1520 next_token_len 000112 automatic fixed bin(17,0) dcl 1234 set ref 1487* 1521 null builtin function dcl 105 ref 194 322 615 779 887 1004 1008 1008 1172 1172 1252 1270 1273 1282 1300 1310 1320 1324 1351 1366 1394 1394 1420 1420 1517 1570 1577 1720 1722 1755 num parameter fixed bin(18,0) dcl 1533 ref 1523 1535 1535 num_words 000102 automatic fixed bin(19,0) dcl 1-20 set ref 1-35* 1-37 1-37* 1-37 1-40 1-40* 1-44 number_dims 0(08) based fixed bin(4,0) level 3 packed unsigned unaligned dcl 155 set ref 234 267 368 389 390 618 903* 910* 918* 1129 1155 1176 1484* number_of_dimensions 000166 automatic fixed bin(17,0) dcl 7-3 set ref 234* 235 241* 241 245 245 265 267* 268 269 368* 369 376* 376 379 379 387 392 number_of_members 2 based fixed bin(17,0) level 2 dcl 9-3 set ref 1730* 1733 1737 numeric_datum based float bin(63) array dcl 7-23 ref 248 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 7-3 set ref 1366 numeric_value_type constant bit(18) initial unaligned dcl 6-30 ref 261 497 520 1675 1698 on_stack 1 parameter bit(1) array level 3 dcl 8-3 set ref 1733 1735* operands parameter structure array level 2 dcl 8-3 operator_bead based structure level 1 dcl 10-3 operators_argument parameter structure level 1 dcl 8-3 set ref 6 our_dir_name 000010 internal static char(168) initial unaligned dcl 996 set ref 1006 1006* 1008* our_dir_name_len 000350 automatic fixed bin(17,0) dcl 998 set ref 1006* our_ent_name 000351 automatic char(32) unaligned dcl 998 set ref 1006* packed 000113 automatic bit(1) unaligned dcl 1234 in procedure "process_parameter_dcl" set ref 1305* 1315* 1330* 1357* 1371* 1466* 1471* 1483 1497 packed 0(07) based bit(1) level 3 in structure "argument_desc" packed unaligned dcl 155 in procedure "apl_quadcall_" set ref 402 424 625 637 662 902* 909* 917* 1183 1483* 1586 1611 pad1 0(17) based bit(1) level 3 packed unaligned dcl 162 set ref 1109* pad2 1(17) based bit(19) level 3 packed unaligned dcl 162 set ref 1112* pointers 14 based structure level 2 dcl 5-16 rank 000263 automatic fixed bin(17,0) dcl 878 in procedure "generate_argument_desc" set ref 891* 892 898 903 910 911 912 913* 913 918 922 923 rank 000451 automatic fixed bin(17,0) dcl 1073 in procedure "process_declaration" set ref 1176* 1177 1183 1183 1185 1185 rank 000204 automatic fixed bin(17,0) dcl 304 in procedure "allocate_table_space" set ref 322* 325* 326* 327 rank 000232 automatic fixed bin(17,0) dcl 579 in procedure "convert_arguments" set ref 618* 619 625 625 627 627 rank 000114 automatic fixed bin(17,0) dcl 1234 in procedure "process_parameter_dcl" set ref 1258* 1267* 1267 1268 1270 1275 1277 1277 1281 1282 1285 1285 1322 1400 1407 1426 1433 1484 1490 1504 1509 1517 reference_count 1 based fixed bin(29,0) level 3 in structure "value_bead" dcl 7-3 in procedure "apl_quadcall_" set ref 263* 677 755 1575 1578* 1578 reference_count 1 based fixed bin(29,0) level 2 in structure "general_bead" dcl 6-3 in procedure "apl_quadcall_" set ref 552* 552 553 rel builtin function dcl 1-25 ref 1-40 result 6 parameter pointer level 2 packed unaligned dcl 8-3 set ref 194* 385* result_buf 000100 automatic bit initial dcl 181 set ref 181* 184 rho 5 based fixed bin(21,0) array level 2 dcl 7-3 set ref 269* 271* 390* 392* 911 912 925 927 1277 1285 1409 1411 1435 1437 rhorho 3 based fixed bin(17,0) level 2 dcl 7-3 set ref 265* 325 326 387* 891 1275 1282 1400 1407 1409 1411 1426 1433 1435 1437 1517 routine 000150 automatic entry variable dcl 124 set ref 185* 191* 1194* routine_name based char unaligned dcl 595 in procedure "convert_arguments" set ref 711 711 711 715* 716 719 routine_name parameter char unaligned dcl 983 in procedure "make_entry" set ref 961 1012* routine_name 000452 automatic char(32) unaligned dcl 1073 in procedure "process_declaration" set ref 1094 1096* 1099* 1194* 1195 1198 routine_name_len 000233 automatic fixed bin(21,0) dcl 579 set ref 704* 709* 711 711 711 715 715 716 719 routine_name_ptr 000234 automatic pointer dcl 579 set ref 703* 708* 711 711 711 715 716 719 search_paths_$find_dir 000114 constant entry external dcl 988 ref 1008 seg_ptr 000362 automatic pointer dcl 998 set ref 1003* 1004 1009* semantics_on_stack 4(09) based bit(1) array level 4 packed unaligned dcl 9-3 set ref 549 647 677 728 744 755 771 1733* shape 000115 automatic fixed bin(35,0) array dcl 1234 set ref 1270* 1277* 1281* 1285 1506 1511 1513 short_info 000424 automatic char(8) dcl 1027 set ref 1030* size builtin function dcl 105 in procedure "apl_quadcall_" ref 245 245 246 246 248 334 334 335 379 379 629 629 649 649 670 670 683 683 714 714 730 730 746 746 761 761 773 773 1129 1155 1728 1728 size 0(18) based bit(18) level 3 in structure "value_bead" packed unaligned dcl 7-3 in procedure "apl_quadcall_" set ref 262* size 0(12) based fixed bin(24,0) level 3 in structure "argument_desc" packed unsigned unaligned dcl 155 in procedure "apl_quadcall_" set ref 238 242 271 372 375 392 402 408 424 426 619 622 624 637 643 662 664 731 747 904* 911* 919* 1177 1180 1182 1485* 1586 1592 1607 1611 size 000115 automatic fixed bin(35,0) dcl 1234 in procedure "process_parameter_dcl" set ref 1304* 1314* 1329* 1356* 1370* 1385* 1387* 1392 1397 1402 1402* 1404 1409 1409* 1411 1418 1423 1428 1428* 1430 1435 1435* 1437 1444 1446 1451 1453 1485 1492 1494 1496 size_limit 000236 automatic float bin(27) dcl 579 set ref 731* 733 733 747* 749 749 spaces 000100 automatic fixed bin(17,0) dcl 948 set ref 951* 952 952* 954 static_ws_info_ptr 000072 external static pointer level 2 packed unaligned dcl 5-11 ref 5-7 status parameter fixed bin(35,0) dcl 983 in procedure "make_entry" set ref 961 1003* 1006* 1008* 1009 1009* 1012* status parameter fixed bin(35,0) dcl 1023 in procedure "meaning" set ref 1014 1030* status parameter fixed bin(35,0) dcl 846 in procedure "error" ref 833 849 status 000237 automatic fixed bin(35,0) dcl 579 in procedure "convert_arguments" set ref 715* 716 716* 719* status 000462 automatic fixed bin(35,0) dcl 1073 in procedure "process_declaration" set ref 1194* 1195 1195* 1198* substr builtin function dcl 1-25 ref 1-37 symbol 0(01) based bit(1) level 4 packed unaligned dcl 6-3 ref 322 611 677 755 884 892 1252 1566 1752 symbol_bead based structure level 1 dcl 11-13 sys_info$max_seg_size 000120 external static fixed bin(19,0) dcl 1232 ref 1392 1418 1507 token based char unaligned dcl 164 ref 791 791 791 793 799 801 1087 1089 1091 1094 1096 1100 1117 1120 1130 1134 1138 1141 1144 1147 1164 1167 1173 1192 1259 1259 1262 1270 1278 1278 1278 1281 1289 1291 1298 1308 1308 1318 1333 1336 1339 1342 1346 1349 1359 1359 1361 1361 1364 1373 1373 1375 1375 1382 1385 1387 1387 1387 1457 1464 1464 1469 1469 token_idx 000154 automatic fixed bin(17,0) dcl 124 set ref 787* 791 791 791 793 799 801 803* 887* 892* 896* 950* 950 951 952 954* 954 955 956 958 1083* 1086 1087 1087* 1089 1091 1094 1094* 1096 1100 1105 1117 1120 1123* 1125 1130 1134 1134* 1138 1141 1141* 1144 1144* 1147 1147* 1151 1159* 1164 1167 1167* 1170 1173 1173* 1192 1192* 1259 1259 1261 1262 1268* 1270 1273* 1275* 1278 1278 1278 1278* 1281 1282* 1285* 1289 1291 1291* 1298 1300* 1308 1308 1310* 1318 1320* 1322* 1324* 1326* 1333 1336 1336* 1339 1339* 1342 1342* 1346 1346* 1349 1351* 1359 1359 1361 1361 1361* 1364 1366* 1373 1373 1375 1375 1375* 1378* 1382 1385 1387 1387 1387 1389* 1392* 1397* 1404* 1411* 1418* 1423* 1430* 1437* 1444* 1451* 1457 1457* 1464 1464 1469 1469 1472* 1486 1488* 1507* 1517* 1520* token_len 000155 automatic fixed bin(17,0) dcl 124 set ref 789* 791 791 791 793 799 801 950 955* 956 956* 958 958* 1084* 1087 1087 1087 1089 1091 1094 1094 1094 1096 1100 1117 1120 1130 1134 1138 1141 1144 1147 1164 1167 1173 1192 1259 1259 1262 1270 1278 1278 1278 1281 1289 1291 1298 1308 1308 1318 1333 1336 1339 1342 1346 1349 1359 1359 1361 1361 1364 1373 1373 1375 1375 1382 1385 1387 1387 1387 1387 1457 1464 1464 1469 1469 1487 1489* 1521* total_data_elements 2 based fixed bin(21,0) level 2 dcl 7-3 set ref 264* 386* 635 665 681 692 725 741 760 768 1584 1608 1626 1643 1660 1679 1745 type based structure level 2 in structure "general_bead" packed unaligned dcl 6-3 in procedure "apl_quadcall_" ref 1326 type based structure level 3 in structure "symbol_bead" packed unaligned dcl 11-13 in procedure "apl_quadcall_" type 000116 automatic fixed bin(17,0) dcl 1234 in procedure "process_parameter_dcl" set ref 1303* 1313* 1328* 1355* 1369* 1390 1416 1442 1446* 1449 1453* 1472 1472 1482 1492 1494 type based structure level 3 in structure "list_bead" packed unaligned dcl 9-3 in procedure "apl_quadcall_" set ref 1725 1729* type 0(01) based fixed bin(6,0) level 3 in structure "argument_desc" packed unsigned unaligned dcl 155 in procedure "apl_quadcall_" set ref 238 238 246 255 257 259 259 372 372 380 397 421 444 461 478 499 619 622 633 660 689 723 739 755 766 901* 908* 916* 1177 1180 1482* 1582 1605 1624 1641 1658 1677 type based structure level 3 in structure "value_bead" packed unaligned dcl 7-3 in procedure "apl_quadcall_" set ref 255* 257* 259* 261* 399* 423* 457* 459* 474* 476* 493* 495* 497* 516* 518* 520* 898 1300 1310 1351 1351 1637* 1639* 1654* 1656* 1671* 1673* 1675* 1694* 1696* 1698* 1742 unaligned_char_vec based char array unaligned dcl 164 set ref 434* 441* 441 673 683 683 684* 684 1617* 1620* 1620 unaligned_char_vec_len 000156 automatic fixed bin(21,0) dcl 124 set ref 427* 431 438* 441 441 441 665* 669 682* 683 683 684 684 1608* 1614 1620 1620 unaligned_char_vec_ptr 000160 automatic pointer dcl 124 set ref 429* 434 439* 441 667* 673 683* 683 683 684 686 1610* 1617 1620 1620 unaligned_char_vec_size 000162 automatic fixed bin(21,0) dcl 124 set ref 426* 427 430 434 434 434 440* 441 441 441 441 441 664* 665 668 673 673 673 681* 683 683 683 683 684 684 684 684 1607* 1608 1613 1617 1617 1617 1620 1620 1620 1620 unaligned_value_ptr 000112 automatic pointer unaligned dcl 224 set ref 250* 251 unspec builtin function dcl 1-25 ref 1-37 upper_bound 2 based fixed bin(35,0) array level 3 dcl 155 set ref 236 269 370 390 625 627 925* 1183 1185 1511* value parameter pointer array level 3 in structure "operators_argument" packed unaligned dcl 8-3 in procedure "apl_quadcall_" set ref 1720 1722 1724 1731 1734* value 0(02) based bit(1) level 4 in structure "general_bead" packed unaligned dcl 6-3 in procedure "apl_quadcall_" ref 1752 1755 value_bead based structure level 1 dcl 7-3 set ref 245 245 379 379 value_ptr 000240 automatic pointer dcl 579 in procedure "convert_arguments" set ref 611* 613* 615 635 636 665 667 677 677 681 684 691 692 725 726 741 742 755 755 760 762 768 769 value_ptr 000126 automatic pointer dcl 1555 in procedure "update_byname_arguments" set ref 1569* 1570 1572* 1573 1575 1578 1578 1579* 1580 1584 1585 1608 1610 1626 1627 1637 1639 1643 1644 1654 1656 1660 1661 1671 1673 1675 1679 1680 1694 1696 1698 value_ptr parameter pointer dcl 220 in procedure "allocate_argument_storage" set ref 198 251* 255 257 259 261 262 263 264 265 266 266 269 271 value_ptr 000120 automatic pointer dcl 1234 in procedure "process_parameter_dcl" set ref 1251* 1252* 1273 1275 1277 1282 1282 1285 1300 1300 1310 1310 1324 1326 1351 1351 1351 1366 1366 1394 1400 1407 1409 1409 1411 1411 1420 1426 1433 1435 1435 1437 1437 1517 1517 value_ptr 000264 automatic pointer dcl 878 in procedure "generate_argument_desc" set ref 886* 887 890* 891 898 911 912 925 927 value_size 000113 automatic fixed bin(18,0) dcl 224 set ref 249* 250* 262 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 5-16 set ref 1-40 1-43 1-44* 1-44 546* 549* values 2 based structure level 2 dcl 5-16 where parameter fixed bin(17,0) dcl 846 ref 833 850 852 where_error 10 parameter fixed bin(17,0) level 2 dcl 8-3 set ref 850* 850 852* 852 ws_info based structure level 1 dcl 5-16 ws_info_ptr 000164 automatic pointer initial dcl 5-7 set ref 5-7* 1-40 1-40 1-43 1-44 1-44 546 549 zero_or_one_value_type constant bit(18) initial unaligned dcl 6-30 ref 257 399 457 474 493 516 1300 1351 1637 1654 1671 1694 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Binary internal static bit(1) initial dcl 4-16 Envptr_supplied_call_type internal static fixed bin(18,0) initial unsigned unaligned dcl 13-29 NumberSize internal static fixed bin(4,0) initial dcl 4-25 QAlpha internal static char(1) initial unaligned dcl 2-11 QApostrophe internal static char(1) initial unaligned dcl 2-11 QBackSlash internal static char(1) initial unaligned dcl 2-11 QBackSlashHyphen internal static char(1) initial unaligned dcl 2-11 QBackSpace internal static char(1) initial unaligned dcl 2-11 QBell internal static char(1) initial unaligned dcl 2-11 QCap internal static char(1) initial unaligned dcl 2-11 QCeiling internal static char(1) initial unaligned dcl 2-11 QCentSign internal static char(1) initial unaligned dcl 2-11 QCircle internal static char(1) initial unaligned dcl 2-11 QCircleBackSlash internal static char(1) initial unaligned dcl 2-11 QCircleBar internal static char(1) initial unaligned dcl 2-11 QCircleHyphen internal static char(1) initial unaligned dcl 2-11 QCircleSlash internal static char(1) initial unaligned dcl 2-11 QCircleStar internal static char(1) initial unaligned dcl 2-11 QColon internal static char(1) initial unaligned dcl 2-11 QComma internal static char(1) initial unaligned dcl 2-11 QCommaHyphen internal static char(1) initial unaligned dcl 2-11 QConditionalNewLine internal static char(1) initial unaligned dcl 2-11 QCup internal static char(1) initial unaligned dcl 2-11 QDeCode internal static char(1) initial unaligned dcl 2-11 QDel internal static char(1) initial unaligned dcl 2-11 QDelTilde internal static char(1) initial unaligned dcl 2-11 QDelta internal static char(1) initial unaligned dcl 2-11 QDelta_ internal static char(1) initial unaligned dcl 2-11 QDiamond internal static char(1) initial unaligned dcl 2-11 QDiaresis internal static char(1) initial unaligned dcl 2-11 QDivision internal static char(1) initial unaligned dcl 2-11 QDollar internal static char(1) initial unaligned dcl 2-11 QDomino internal static char(1) initial unaligned dcl 2-11 QDownArrow internal static char(1) initial unaligned dcl 2-11 QEight internal static char(1) initial unaligned dcl 2-11 QEight_ internal static char(1) initial unaligned dcl 2-11 QEnCode internal static char(1) initial unaligned dcl 2-11 QEpsilon internal static char(1) initial unaligned dcl 2-11 QEqual internal static char(1) initial unaligned dcl 2-11 QExclamation internal static char(1) initial unaligned dcl 2-11 QExecuteSign internal static char(1) initial unaligned dcl 2-11 QFive internal static char(1) initial unaligned dcl 2-11 QFive_ internal static char(1) initial unaligned dcl 2-11 QFloor internal static char(1) initial unaligned dcl 2-11 QFormatSign internal static char(1) initial unaligned dcl 2-11 QFour internal static char(1) initial unaligned dcl 2-11 QFour_ internal static char(1) initial unaligned dcl 2-11 QGradeDown internal static char(1) initial unaligned dcl 2-11 QGradeUp internal static char(1) initial unaligned dcl 2-11 QGreaterOrEqual internal static char(1) initial unaligned dcl 2-11 QGreaterThan internal static char(1) initial unaligned dcl 2-11 QIBeam internal static char(1) initial unaligned dcl 2-11 QIota internal static char(1) initial unaligned dcl 2-11 QLamp internal static char(1) initial unaligned dcl 2-11 QLeftArrow internal static char(1) initial unaligned dcl 2-11 QLeftBrace internal static char(1) initial unaligned dcl 2-11 QLeftBracket internal static char(1) initial unaligned dcl 2-11 QLeftLump internal static char(1) initial unaligned dcl 2-11 QLeftParen internal static char(1) initial unaligned dcl 2-11 QLeftTack internal static char(1) initial unaligned dcl 2-11 QLessOrEqual internal static char(1) initial unaligned dcl 2-11 QLessThan internal static char(1) initial unaligned dcl 2-11 QLetterA internal static char(1) initial unaligned dcl 2-11 QLetterA_ internal static char(1) initial unaligned dcl 2-11 QLetterB internal static char(1) initial unaligned dcl 2-11 QLetterB_ internal static char(1) initial unaligned dcl 2-11 QLetterC internal static char(1) initial unaligned dcl 2-11 QLetterC_ internal static char(1) initial unaligned dcl 2-11 QLetterD internal static char(1) initial unaligned dcl 2-11 QLetterD_ internal static char(1) initial unaligned dcl 2-11 QLetterE internal static char(1) initial unaligned dcl 2-11 QLetterE_ internal static char(1) initial unaligned dcl 2-11 QLetterF internal static char(1) initial unaligned dcl 2-11 QLetterF_ internal static char(1) initial unaligned dcl 2-11 QLetterG internal static char(1) initial unaligned dcl 2-11 QLetterG_ internal static char(1) initial unaligned dcl 2-11 QLetterH internal static char(1) initial unaligned dcl 2-11 QLetterH_ internal static char(1) initial unaligned dcl 2-11 QLetterI internal static char(1) initial unaligned dcl 2-11 QLetterI_ internal static char(1) initial unaligned dcl 2-11 QLetterJ internal static char(1) initial unaligned dcl 2-11 QLetterJ_ internal static char(1) initial unaligned dcl 2-11 QLetterK internal static char(1) initial unaligned dcl 2-11 QLetterK_ internal static char(1) initial unaligned dcl 2-11 QLetterL internal static char(1) initial unaligned dcl 2-11 QLetterL_ internal static char(1) initial unaligned dcl 2-11 QLetterM internal static char(1) initial unaligned dcl 2-11 QLetterM_ internal static char(1) initial unaligned dcl 2-11 QLetterN internal static char(1) initial unaligned dcl 2-11 QLetterN_ internal static char(1) initial unaligned dcl 2-11 QLetterO internal static char(1) initial unaligned dcl 2-11 QLetterO_ internal static char(1) initial unaligned dcl 2-11 QLetterP internal static char(1) initial unaligned dcl 2-11 QLetterP_ internal static char(1) initial unaligned dcl 2-11 QLetterQ internal static char(1) initial unaligned dcl 2-11 QLetterQ_ internal static char(1) initial unaligned dcl 2-11 QLetterR internal static char(1) initial unaligned dcl 2-11 QLetterR_ internal static char(1) initial unaligned dcl 2-11 QLetterS internal static char(1) initial unaligned dcl 2-11 QLetterS_ internal static char(1) initial unaligned dcl 2-11 QLetterT internal static char(1) initial unaligned dcl 2-11 QLetterT_ internal static char(1) initial unaligned dcl 2-11 QLetterU internal static char(1) initial unaligned dcl 2-11 QLetterU_ internal static char(1) initial unaligned dcl 2-11 QLetterV internal static char(1) initial unaligned dcl 2-11 QLetterV_ internal static char(1) initial unaligned dcl 2-11 QLetterW internal static char(1) initial unaligned dcl 2-11 QLetterW_ internal static char(1) initial unaligned dcl 2-11 QLetterX internal static char(1) initial unaligned dcl 2-11 QLetterX_ internal static char(1) initial unaligned dcl 2-11 QLetterY internal static char(1) initial unaligned dcl 2-11 QLetterY_ internal static char(1) initial unaligned dcl 2-11 QLetterZ internal static char(1) initial unaligned dcl 2-11 QLetterZ_ internal static char(1) initial unaligned dcl 2-11 QLineFeed internal static char(1) initial unaligned dcl 2-11 QMarkError internal static char(1) initial unaligned dcl 2-11 QMinus internal static char(1) initial unaligned dcl 2-11 QNandSign internal static char(1) initial unaligned dcl 2-11 QNewLine internal static char(1) initial unaligned dcl 2-11 QNine internal static char(1) initial unaligned dcl 2-11 QNine_ internal static char(1) initial unaligned dcl 2-11 QNorSign internal static char(1) initial unaligned dcl 2-11 QNotEqual internal static char(1) initial unaligned dcl 2-11 QOmega internal static char(1) initial unaligned dcl 2-11 QOne internal static char(1) initial unaligned dcl 2-11 QOne_ internal static char(1) initial unaligned dcl 2-11 QOrSign internal static char(1) initial unaligned dcl 2-11 QPeriod internal static char(1) initial unaligned dcl 2-11 QPlus internal static char(1) initial unaligned dcl 2-11 QQuad internal static char(1) initial unaligned dcl 2-11 QQuadQuote internal static char(1) initial unaligned dcl 2-11 QQuestion internal static char(1) initial unaligned dcl 2-11 QRho internal static char(1) initial unaligned dcl 2-11 QRightArrow internal static char(1) initial unaligned dcl 2-11 QRightBrace internal static char(1) initial unaligned dcl 2-11 QRightBracket internal static char(1) initial unaligned dcl 2-11 QRightLump internal static char(1) initial unaligned dcl 2-11 QRightParen internal static char(1) initial unaligned dcl 2-11 QRightTack internal static char(1) initial unaligned dcl 2-11 QSemiColon internal static char(1) initial unaligned dcl 2-11 QSeven internal static char(1) initial unaligned dcl 2-11 QSeven_ internal static char(1) initial unaligned dcl 2-11 QSix internal static char(1) initial unaligned dcl 2-11 QSix_ internal static char(1) initial unaligned dcl 2-11 QSlash internal static char(1) initial unaligned dcl 2-11 QSlashHyphen internal static char(1) initial unaligned dcl 2-11 QSmallCircle internal static char(1) initial unaligned dcl 2-11 QSpace internal static char(1) initial unaligned dcl 2-11 QStar internal static char(1) initial unaligned dcl 2-11 QTab internal static char(1) initial unaligned dcl 2-11 QThree internal static char(1) initial unaligned dcl 2-11 QThree_ internal static char(1) initial unaligned dcl 2-11 QTilde internal static char(1) initial unaligned dcl 2-11 QTimes internal static char(1) initial unaligned dcl 2-11 QTwo internal static char(1) initial unaligned dcl 2-11 QTwo_ internal static char(1) initial unaligned dcl 2-11 QUnderLine internal static char(1) initial unaligned dcl 2-11 QUpArrow internal static char(1) initial unaligned dcl 2-11 QUpperMinus internal static char(1) initial unaligned dcl 2-11 QVerticalBar internal static char(1) initial unaligned dcl 2-11 QZero internal static char(1) initial unaligned dcl 2-11 QZero_ internal static char(1) initial unaligned dcl 2-11 Quick_call_type internal static fixed bin(18,0) initial unsigned unaligned dcl 13-29 TheBiggestNumberWeveGot internal static float bin(63) initial dcl 4-16 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 4-16 apl_allocate_words_ 000000 constant entry external dcl 3-12 apl_error_table_$cant_load_ws external static fixed bin(35,0) dcl 3-46 apl_error_table_$function external static fixed bin(35,0) dcl 3-46 apl_error_table_$index external static fixed bin(35,0) dcl 3-46 apl_error_table_$length external static fixed bin(35,0) dcl 3-46 apl_error_table_$no_type_bits external static fixed bin(35,0) dcl 3-46 apl_error_table_$off_hold external static fixed bin(35,0) dcl 3-46 apl_error_table_$rank external static fixed bin(35,0) dcl 3-46 apl_error_table_$system_error external static fixed bin(35,0) dcl 3-46 apl_free_bead_ 000000 constant entry external dcl 3-21 apl_free_words_ 000000 constant entry external dcl 3-17 apl_get_value_stack_ 000000 constant entry external dcl 3-25 apl_subsystem_ 000000 constant entry external dcl 3-29 apl_system_error_ 000000 constant entry external dcl 3-40 arg_descriptor_ptr automatic pointer dcl 12-34 arg_list_with_envptr based structure level 1 dcl 13-17 character_data_structure based structure level 1 dcl 7-15 complex_datum based complex float bin(63) array dcl 7-26 complex_value_type internal static bit(18) initial unaligned dcl 6-30 extended_arg_descriptor based structure level 1 dcl 12-21 fixed_arg_descriptor based structure level 1 dcl 12-13 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 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 5-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 operator_type internal static bit(18) initial unaligned dcl 6-30 output_buffer based char unaligned dcl 5-94 shared_variable_type internal static bit(18) initial unaligned dcl 6-30 symbol_type internal static bit(18) initial unaligned dcl 6-30 sys_info$max_seg_size external static fixed bin(35,0) dcl 102 value_type internal static bit(18) initial unaligned dcl 6-30 NAMES DECLARED BY EXPLICIT CONTEXT. allocate_argument_storage 000576 constant entry internal dcl 198 ref 1572 1579 allocate_table_space 001050 constant entry internal dcl 274 ref 176 apl_push_stack_ 001156 constant entry internal dcl 1-4 ref 334 385 629 649 670 683 714 730 746 761 773 1728 apl_quadcall_ 000443 constant entry external dcl 6 assign_result 001224 constant entry internal dcl 339 ref 188 cannot_convert_argument 004434 constant label dcl 787 ref 733 749 collect_garbage 002517 constant entry internal dcl 523 ref 187 193 convert_arguments 002575 constant entry internal dcl 558 ref 178 declaration_error 004557 constant entry internal dcl 805 ref 711 716 719 803 887 892 896 1087 1094 1123 1134 1141 1144 1147 1159 1167 1173 1192 1195 1198 1268 1273 1275 1278 1282 1285 1291 1300 1310 1320 1322 1324 1326 1336 1339 1342 1346 1351 1361 1366 1375 1378 1389 1392 1397 1404 1411 1418 1423 1430 1437 1444 1451 1457 1472 1507 1517 error 004651 constant entry internal dcl 833 ref 383 831 1720 1722 1742 1752 1755 generate_argument_desc 004700 constant entry internal dcl 856 ref 1154 get_next_token 005266 constant entry internal dcl 930 ref 790 794 796 798 799 801 1085 1090 1093 1097 1100 1119 1130 1136 1140 1143 1146 1157 1166 1169 1175 1259 1266 1288 1293 1306 1316 1332 1335 1338 1341 1344 1358 1359 1372 1373 1384 1456 1459 1467 1474 1505 1514 make_entry 005356 constant entry internal dcl 961 ref 715 1006 1006 1012 1012 1194 meaning 005632 constant entry internal dcl 1014 ref 716 719 1195 1198 process_declaration 005655 constant entry internal dcl 1033 ref 177 process_parameter_dcl 007174 constant entry internal dcl 1201 ref 1128 1172 return 000575 constant label dcl 1767 ref 854 round_to_even 012002 constant entry internal dcl 1523 ref 245 246 379 380 update_byname_arguments 012017 constant entry internal dcl 1537 ref 186 192 validate_usage 013110 constant entry internal dcl 1703 ref 175 NAMES DECLARED BY CONTEXT OR IMPLICATION. addr builtin function ref 182 184 697 703 791 791 791 793 799 801 1087 1089 1091 1094 1096 1100 1117 1120 1130 1134 1138 1141 1144 1147 1164 1167 1173 1192 1259 1259 1262 1270 1278 1278 1278 1281 1289 1291 1298 1308 1308 1318 1333 1336 1339 1342 1346 1349 1359 1359 1361 1361 1364 1373 1373 1375 1375 1382 1385 1387 1387 1387 1457 1464 1464 1469 1469 addrel builtin function ref 266 335 336 388 1129 1155 bin builtin function ref 1281 1387 bit builtin function ref 262 char builtin function ref 892 896 divide builtin function ref 380 380 409 411 427 628 644 646 665 1500 1593 1595 1608 fixed builtin function ref 731 747 1517 float builtin function ref 416 1600 floor builtin function ref 486 509 1668 1687 index builtin function ref 700 1087 1094 1105 length builtin function ref 693 711 711 711 711 952 956 958 1278 ltrim builtin function ref 892 896 max builtin function ref 1506 maxlength builtin function ref 1087 1094 min builtin function ref 1087 1094 mod builtin function ref 402 424 637 662 1535 1586 1611 rtrim builtin function ref 693 716 719 1195 1198 1198 string builtin function set ref 255 257* 259* 261* 399* 423* 457* 459* 474* 476* 493* 495* 497* 516* 518* 520* 898 1300 1310 1326 1351 1351 1637* 1639* 1654* 1656* 1671* 1673* 1675* 1694* 1696* 1698* 1725 1729* 1742 substr builtin function set ref 416 653* 656* 951 952 955 956 1087 1094 1105 1600 unspec builtin function set ref 630 656 671* 684* 684 762* 762 1620* 1620 1662* 1662 1732* verify builtin function ref 694 711 711 951 955 1278 1278 1387 1387 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 14374 14516 14054 14404 Length 15222 14054 122 467 320 52 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_quadcall_ 642 external procedure is an external procedure. begin block on line 179 128 begin block uses auto adjustable storage. allocate_argument_storage internal procedure shares stack frame of internal procedure update_byname_arguments. allocate_table_space internal procedure shares stack frame of external procedure apl_quadcall_. apl_push_stack_ 74 internal procedure is called by several nonquick procedures. assign_result internal procedure shares stack frame of begin block on line 179. collect_garbage 74 internal procedure is called by several nonquick procedures. convert_arguments internal procedure shares stack frame of external procedure apl_quadcall_. declaration_error 100 internal procedure is called during a stack extension. error 64 internal procedure is called by several nonquick procedures. generate_argument_desc internal procedure shares stack frame of external procedure apl_quadcall_. get_next_token 66 internal procedure is called by several nonquick procedures. make_entry internal procedure shares stack frame of external procedure apl_quadcall_. meaning internal procedure shares stack frame of external procedure apl_quadcall_. process_declaration internal procedure shares stack frame of external procedure apl_quadcall_. process_parameter_dcl 278 internal procedure uses auto adjustable storage. round_to_even 64 internal procedure is called by several nonquick procedures. update_byname_arguments 118 internal procedure is called by several nonquick procedures. validate_usage internal procedure shares stack frame of external procedure apl_quadcall_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 our_dir_name make_entry STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_push_stack_ 000100 block_ptr apl_push_stack_ 000102 num_words apl_push_stack_ apl_quadcall_ 000100 aligned_char_vec_len apl_quadcall_ 000102 aligned_char_vec_ptr apl_quadcall_ 000104 aligned_char_vec_size apl_quadcall_ 000105 arg_list_arg_count apl_quadcall_ 000106 argument_desc_ptr apl_quadcall_ 000110 argument_list_ptr apl_quadcall_ 000112 bit_vec_len apl_quadcall_ 000113 bit_vec_pad apl_quadcall_ 000114 bit_vec_ptr apl_quadcall_ 000116 bit_vec_size apl_quadcall_ 000117 bits_in_result apl_quadcall_ 000120 calling_a_function apl_quadcall_ 000121 declaration_len apl_quadcall_ 000122 declaration_ptr apl_quadcall_ 000124 fixed_bin_long_vec_len apl_quadcall_ 000126 fixed_bin_long_vec_ptr apl_quadcall_ 000130 fixed_bin_short_vec_len apl_quadcall_ 000132 fixed_bin_short_vec_ptr apl_quadcall_ 000134 float_bin_long_vec_len apl_quadcall_ 000136 float_bin_long_vec_ptr apl_quadcall_ 000140 float_bin_short_vec_len apl_quadcall_ 000142 float_bin_short_vec_ptr apl_quadcall_ 000144 list_ptr apl_quadcall_ 000146 marker_ptr apl_quadcall_ 000150 routine apl_quadcall_ 000154 token_idx apl_quadcall_ 000155 token_len apl_quadcall_ 000156 unaligned_char_vec_len apl_quadcall_ 000160 unaligned_char_vec_ptr apl_quadcall_ 000162 unaligned_char_vec_size apl_quadcall_ 000163 data_elements apl_quadcall_ 000164 ws_info_ptr apl_quadcall_ 000166 number_of_dimensions apl_quadcall_ 000167 n_members apl_quadcall_ 000170 extended_arg_type apl_quadcall_ 000200 descriptor_space allocate_table_space 000201 i allocate_table_space 000202 member_ptr allocate_table_space 000204 rank allocate_table_space 000214 arg_num convert_arguments 000216 entry_ptr convert_arguments 000220 i convert_arguments 000221 j convert_arguments 000222 k convert_arguments 000223 member_num convert_arguments 000224 member_ptr convert_arguments 000226 module_name_len convert_arguments 000230 module_name_ptr convert_arguments 000232 rank convert_arguments 000233 routine_name_len convert_arguments 000234 routine_name_ptr convert_arguments 000236 size_limit convert_arguments 000237 status convert_arguments 000240 value_ptr convert_arguments 000260 i generate_argument_desc 000261 j generate_argument_desc 000262 multiplier generate_argument_desc 000263 rank generate_argument_desc 000264 value_ptr generate_argument_desc 000276 dir_name make_entry 000350 our_dir_name_len make_entry 000351 our_ent_name make_entry 000362 seg_ptr make_entry 000372 long_info meaning 000424 short_info meaning 000434 arg_num process_declaration 000436 member_ptr process_declaration 000440 module_name process_declaration 000450 more process_declaration 000451 rank process_declaration 000452 routine_name process_declaration 000462 status process_declaration 000472 member_num validate_usage 000474 member_ptr validate_usage begin block on line 179 000100 result_buf begin block on line 179 000112 bead_ptr assign_result 000114 bead_size assign_result 000116 data_ptr assign_result 000120 data_size assign_result 000121 i assign_result 000122 j assign_result 000123 k assign_result 000124 last_dimension_implicit assign_result collect_garbage 000100 i collect_garbage 000102 member_ptr collect_garbage get_next_token 000100 spaces get_next_token process_parameter_dcl 000100 bits_in_value process_parameter_dcl 000102 bits_per_element process_parameter_dcl 000103 dimensioning_idx process_parameter_dcl 000104 i process_parameter_dcl 000105 j process_parameter_dcl 000106 last_dimension_implicit process_parameter_dcl 000107 more process_parameter_dcl 000110 multiplier process_parameter_dcl 000111 next_token_idx process_parameter_dcl 000112 next_token_len process_parameter_dcl 000113 packed process_parameter_dcl 000114 rank process_parameter_dcl 000115 shape process_parameter_dcl 000115 size process_parameter_dcl 000116 type process_parameter_dcl 000120 value_ptr process_parameter_dcl update_byname_arguments 000106 bead_size allocate_argument_storage 000107 data_size allocate_argument_storage 000110 i allocate_argument_storage 000111 last_dimension_implicit allocate_argument_storage 000112 unaligned_value_ptr allocate_argument_storage 000113 value_size allocate_argument_storage 000116 arg_num update_byname_arguments 000117 i update_byname_arguments 000120 j update_byname_arguments 000121 k update_byname_arguments 000122 member_num update_byname_arguments 000124 member_ptr update_byname_arguments 000126 value_ptr update_byname_arguments THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 r_g_a r_e_as r_ne_as alloc_cs alloc_temp cat_realloc_cs enter_begin leave_begin call_ext_out_desc call_ext_out call_int_this_desc call_int_this call_int_other_desc call_int_other return fl2_to_fx1 fl2_to_fx2 tra_ext alloc_auto_adj mpfx2 mod_fx1 shorten_stack ext_entry int_entry int_entry_desc floor_fl set_cs_eis index_cs_eis real_to_real_rd any_to_any_tr THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_allocate_words_ apl_free_bead_ apl_get_value_stack_ convert_status_code_ cu_$generate_call decimal_exp_ hcs_$fs_get_path_name hcs_$fs_get_seg_ptr hcs_$initiate hcs_$make_entry ioa_$nnl search_paths_$find_dir THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. apl_error_table_$domain apl_error_table_$result_size apl_static_$ws_info_ptr sys_info$max_seg_size LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 6 000440 5 7 000450 12 36 000452 175 000454 176 000455 177 000456 178 000457 179 000460 181 000465 182 000503 184 000512 185 000516 186 000527 187 000534 188 000541 189 000542 179 000543 191 000544 192 000555 193 000561 194 000565 196 000571 197 000574 1767 000575 198 000576 233 000600 234 000603 235 000607 236 000615 237 000623 238 000625 240 000645 241 000647 242 000650 243 000652 244 000653 245 000654 246 000670 248 000714 249 000717 250 000722 251 000733 255 000736 257 000750 259 000755 261 000764 262 000766 263 000773 264 000775 265 000777 266 001001 267 001005 268 001011 269 001020 270 001033 271 001035 273 001047 274 001050 319 001051 320 001053 321 001063 322 001067 325 001100 326 001104 327 001106 328 001112 333 001114 334 001116 335 001140 336 001150 337 001154 1 4 001155 1 35 001163 1 37 001166 1 40 001173 1 43 001210 1 44 001214 1 45 001221 339 001224 366 001225 367 001241 368 001243 369 001247 370 001255 371 001264 372 001266 374 001306 375 001310 376 001312 377 001313 378 001314 379 001315 380 001331 382 001355 383 001360 385 001376 386 001420 387 001423 388 001425 389 001433 390 001445 391 001460 392 001462 397 001472 399 001501 400 001504 401 001507 402 001511 404 001522 405 001525 406 001527 408 001530 409 001532 411 001536 412 001544 413 001551 414 001553 415 001563 416 001573 417 001623 418 001624 419 001626 420 001630 421 001631 423 001633 424 001636 426 001647 427 001651 429 001654 430 001656 431 001660 432 001662 433 001667 434 001677 435 001724 436 001726 438 001727 439 001731 440 001736 441 001740 442 001767 443 001770 444 001771 446 001773 447 001776 448 002000 449 002002 450 002007 452 002032 453 002040 454 002042 455 002053 456 002064 457 002066 459 002076 460 002101 461 002102 463 002104 464 002107 465 002111 466 002113 467 002120 469 002135 470 002145 471 002147 472 002157 473 002170 474 002172 476 002202 477 002205 478 002206 480 002210 481 002213 482 002220 484 002243 485 002247 486 002251 488 002273 489 002276 490 002300 491 002312 492 002322 493 002324 495 002335 497 002345 498 002350 499 002351 501 002353 502 002356 503 002360 504 002361 505 002366 507 002405 508 002413 509 002415 511 002435 512 002443 513 002445 514 002456 515 002467 516 002471 518 002502 520 002512 522 002515 523 002516 546 002524 547 002531 548 002541 549 002546 552 002555 553 002557 556 002572 557 002574 558 002575 608 002576 609 002605 610 002607 611 002614 613 002625 614 002626 615 002641 617 002645 618 002647 619 002653 622 002667 624 002676 625 002703 627 002714 628 002725 629 002732 630 002747 631 002756 632 002761 633 002762 635 002770 636 002774 637 002776 639 003007 640 003012 641 003014 643 003015 644 003017 646 003023 647 003031 649 003040 650 003055 651 003057 652 003067 653 003077 654 003126 655 003127 656 003131 657 003153 658 003155 659 003161 660 003162 662 003164 664 003175 665 003177 667 003203 668 003205 669 003207 670 003211 671 003226 672 003241 673 003251 674 003275 675 003277 676 003303 677 003304 681 003324 682 003327 683 003331 684 003345 686 003356 688 003361 689 003362 691 003364 692 003367 693 003372 694 003403 695 003416 697 003420 698 003424 700 003430 701 003443 703 003444 704 003447 705 003452 706 003455 708 003456 709 003457 711 003461 714 003544 715 003556 716 003610 719 003704 721 004010 722 004015 723 004016 725 004020 726 004024 727 004026 728 004030 730 004037 731 004051 732 004102 733 004111 735 004123 736 004127 737 004131 738 004135 739 004136 741 004140 742 004144 743 004146 744 004150 746 004157 747 004170 748 004221 749 004231 751 004243 752 004250 753 004252 754 004256 755 004257 760 004301 761 004305 762 004323 764 004340 765 004343 766 004344 768 004346 769 004352 770 004354 771 004355 773 004364 774 004377 775 004410 776 004417 777 004421 778 004425 779 004426 780 004431 781 004433 787 004434 789 004437 790 004440 791 004444 793 004463 794 004473 795 004477 796 004500 798 004504 799 004510 801 004523 803 004536 804 004555 805 004556 830 004572 831 004635 832 004647 833 004650 849 004656 850 004664 852 004671 854 004675 856 004700 884 004702 886 004706 887 004711 889 004746 890 004750 891 004752 892 004755 896 005054 897 005127 898 005132 901 005140 902 005144 903 005146 904 005152 905 005155 906 005157 908 005160 909 005164 910 005166 911 005173 912 005200 913 005202 914 005204 916 005205 917 005211 918 005213 919 005220 920 005223 922 005225 923 005235 924 005241 925 005246 926 005252 927 005257 928 005262 929 005264 930 005265 950 005273 951 005276 952 005316 954 005322 955 005323 956 005342 958 005347 960 005355 961 005356 1003 005374 1004 005417 1006 005423 1008 005463 1009 005525 1012 005574 1013 005631 1014 005632 1030 005634 1031 005647 1033 005655 1083 005656 1084 005660 1085 005661 1086 005665 1087 005667 1089 005731 1090 005737 1091 005743 1093 005752 1094 005756 1096 006023 1097 006031 1098 006035 1099 006036 1100 006041 1105 006054 1106 006074 1108 006077 1109 006104 1110 006106 1111 006111 1112 006117 1116 006121 1117 006122 1119 006130 1120 006134 1121 006144 1122 006146 1123 006147 1125 006171 1126 006174 1127 006207 1128 006213 1129 006221 1130 006231 1132 006245 1133 006246 1134 006247 1136 006276 1137 006302 1138 006303 1140 006307 1141 006313 1143 006343 1144 006347 1146 006377 1147 006403 1149 006433 1150 006440 1151 006441 1152 006444 1153 006457 1154 006463 1155 006465 1156 006475 1157 006476 1159 006502 1164 006525 1166 006534 1167 006540 1169 006567 1170 006573 1171 006577 1172 006613 1173 006623 1175 006652 1176 006656 1177 006662 1180 006676 1182 006705 1183 006712 1185 006724 1186 006736 1187 006737 1192 006740 1194 006767 1195 006772 1198 007057 1200 007171 1201 007173 1234 007201 1251 007206 1252 007212 1258 007223 1259 007224 1261 007245 1262 007250 1264 007256 1265 007260 1266 007262 1267 007267 1268 007270 1270 007314 1273 007335 1275 007362 1277 007407 1278 007414 1281 007467 1282 007502 1285 007534 1288 007562 1289 007567 1290 007600 1291 007601 1293 007632 1298 007637 1300 007647 1303 007677 1304 007701 1305 007703 1306 007705 1307 007712 1308 007713 1310 007723 1313 007753 1314 007755 1315 007757 1316 007761 1317 007766 1318 007767 1320 007773 1322 010020 1324 010043 1326 010070 1328 010115 1329 010117 1330 010120 1331 010121 1332 010123 1333 010130 1335 010140 1336 010145 1338 010176 1339 010203 1341 010234 1342 010241 1344 010272 1346 010277 1348 010330 1349 010331 1351 010335 1355 010367 1356 010371 1357 010373 1358 010374 1359 010401 1361 010423 1363 010453 1364 010454 1366 010460 1369 010507 1370 010511 1371 010513 1372 010514 1373 010521 1375 010543 1377 010573 1378 010574 1382 010615 1384 010625 1385 010632 1387 010644 1389 010705 1390 010726 1392 010731 1394 010761 1397 010772 1399 011015 1400 011016 1402 011022 1404 011027 1406 011052 1407 011053 1409 011057 1411 011065 1413 011111 1415 011113 1416 011114 1418 011116 1420 011146 1423 011157 1425 011202 1426 011203 1428 011207 1430 011214 1432 011237 1433 011240 1435 011244 1437 011252 1439 011276 1441 011300 1442 011301 1444 011303 1446 011332 1448 011336 1449 011337 1451 011341 1453 011370 1456 011374 1457 011401 1459 011433 1464 011440 1466 011454 1467 011455 1468 011462 1469 011463 1471 011473 1472 011475 1474 011522 1481 011527 1482 011532 1483 011537 1484 011544 1485 011551 1486 011554 1487 011556 1488 011560 1489 011562 1490 011564 1492 011566 1494 011574 1496 011602 1497 011606 1500 011612 1501 011615 1503 011617 1504 011622 1505 011631 1506 011636 1507 011647 1509 011700 1510 011704 1511 011712 1512 011716 1513 011723 1514 011726 1515 011733 1517 011735 1520 011773 1521 011776 1522 012000 1523 012001 1535 012007 1537 012016 1563 012024 1564 012035 1565 012037 1566 012045 1568 012050 1569 012064 1570 012066 1572 012072 1573 012074 1574 012077 1575 012100 1577 012103 1578 012105 1579 012107 1580 012111 1582 012114 1584 012123 1585 012127 1586 012131 1588 012142 1589 012145 1590 012147 1592 012150 1593 012152 1595 012156 1596 012164 1597 012171 1598 012173 1599 012203 1600 012213 1601 012243 1602 012244 1603 012246 1604 012250 1605 012251 1607 012253 1608 012256 1610 012263 1611 012265 1613 012274 1614 012276 1615 012300 1616 012305 1617 012315 1618 012342 1619 012344 1620 012345 1623 012364 1624 012365 1626 012367 1627 012373 1628 012375 1629 012377 1630 012404 1632 012426 1633 012434 1634 012436 1635 012447 1636 012460 1637 012462 1639 012472 1640 012475 1641 012476 1643 012500 1644 012504 1645 012506 1646 012510 1647 012515 1649 012533 1650 012543 1651 012545 1652 012555 1653 012566 1654 012570 1656 012600 1657 012603 1658 012604 1660 012606 1661 012612 1662 012614 1665 012641 1667 012665 1668 012667 1670 012712 1671 012714 1673 012725 1675 012734 1676 012737 1677 012740 1679 012742 1680 012746 1681 012750 1682 012751 1683 012756 1685 012775 1686 013003 1687 013005 1689 013025 1690 013033 1691 013035 1692 013046 1693 013057 1694 013061 1696 013072 1698 013102 1701 013105 1702 013107 1703 013110 1720 013111 1722 013131 1724 013146 1725 013153 1727 013157 1728 013161 1729 013174 1730 013177 1731 013202 1732 013210 1733 013211 1734 013234 1735 013240 1736 013256 1737 013257 1741 013261 1742 013264 1744 013301 1745 013304 1750 013307 1751 013317 1752 013323 1755 013343 1758 013363 1759 013365 ----------------------------------------------------------- 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