COMPILATION LISTING OF SEGMENT apl_subscript_a_value_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1617.6 mst Tue Options: optimize map 1 /* ****************************************************** 2* * * 3* * * 4* * Copyright (c) 1972 by Massachusetts Institute of * 5* * Technology and Honeywell Information Systems, Inc. * 6* * * 7* * * 8* ****************************************************** */ 9 10 /* Program to implement APL subscripting and subscripted assignment. 11* Written by Dan Bricklin, Summer, 1973. 12* Modified 740909 by PG for new value bead declaration. 13* Modified 741125 by PG to allow an effective scalar on the right-hand-size of a subscripted assignment 14* to be extended to cover the shape of the left-hand-side. 15* Modified 770301 by PG to fix bug 270 (giving RANK ERROR instead of LENGTH ERROR). 16* Modified 780210 by PG to fix bug 278 by calling apl_push_stack_. 17**/ 18 19 apl_subscript_a_value_: 20 procedure (operators_argument); 21 22 /* builtins */ 23 24 declare (abs, addr, addrel, bool, fixed, floor, null, rel, size, substr, string) builtin; 25 26 /* declarations */ 27 28 dcl 29 increment fixed bin, 30 from_subscript fixed bin (21), 31 parse_frame_ptr ptr, 32 value_ptr ptr, 33 list_ptr ptr, 34 old_rhorho fixed bin, 35 n_words fixed bin (19), 36 subscript_scratch_ptr ptr, 37 38 1 subscript_scratch (old_rhorho) aligned based (subscript_scratch_ptr), 39 2 entry fixed bin, 40 2 multiplier fixed bin, 41 2 subscripted_value_rho fixed bin, 42 2 value_bead_data_ptr ptr unaligned, 43 2 max_value fixed bin, 44 2 null_entry bit (1) aligned, 45 2 is_integer bit (1) aligned, 46 47 value_is_numeric bit (1) aligned, 48 new_rhorho fixed bin, 49 data_elements fixed bin (21), 50 i fixed bin (21), 51 multiplier_temp fixed bin, 52 temp_member_ptr ptr, 53 temp_ptr ptr, 54 float_index_origin float, 55 integer_fuzz float, 56 from_data_ptr ptr, 57 which_element fixed bin (21), 58 carry bit (1) aligned, 59 j fixed bin, 60 float_subscript float, 61 float_temp float, 62 fixed_subscript fixed bin (21), 63 result_data_ptr ptr, 64 result_ptr ptr, 65 counter fixed bin, 66 final_ptr ptr, 67 apl_free_bead_ entry (ptr unaligned), 68 apl_copy_value_ entry (ptr unaligned, ptr unaligned), 69 final_data_ptr ptr, 70 71 assigner fixed bin int static init (-1), 72 assignee fixed bin int static init (1), 73 list fixed bin int static init (0), 74 assigner_ptr ptr, 75 assignee_ptr ptr; 76 77 /* external static */ 78 79 dcl (apl_error_table_$index, 80 apl_error_table_$length, 81 apl_error_table_$value, 82 apl_error_table_$assign_to_value, 83 apl_error_table_$domain, 84 apl_error_table_$rank) fixed bin (35) external static; 85 86 /* include files */ 87 1 1 /* ====== BEGIN INCLUDE SEGMENT apl_number_data.incl.pl1 ================================== */ 1 2 1 3 /* 1 4* This include file contains information about the machine representation of numbers. 1 5* In all programs numbers should simply be declared 'float'. 1 6* All default statements should be in this include file. 1 7* 1 8* This is the binary version. The manifest constant Binary should be used by programs 1 9* that need to know whether we are using binary or decimal. 1 10* */ 1 11 1 12 /* format: style3,initlm0,idind30 */ 1 13 1 14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63); 1 15 1 16 declare ( 1 17 TheBiggestNumberWeveGot float initial (0.1701411834604692317e+39), 1 18 TheSmallestNumberWeveGot float initial (.1469367938527859385e-38), 1 19 Binary bit (1) aligned initial ("1"b) 1 20 ) internal static options (constant); 1 21 1 22 /* Number of characters in a number datum entry; used for copying float number arrays as strings. 1 23* (Obsolete! use array copies!) */ 1 24 1 25 declare NumberSize fixed binary precision (4) internal static initial (8); 1 26 1 27 /* ------ END INCLUDE SEGMENT apl_number_data.incl.pl1 ---------------------------------- */ 88 2 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 2 2 2 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 2 4 2 5 /* automatic */ 2 6 2 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 2 8 2 9 /* external static */ 2 10 2 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 2 12 2 static_ws_info_ptr unaligned pointer; 2 13 2 14 /* based */ 2 15 2 16 declare 1 ws_info aligned based (ws_info_ptr), 2 17 2 version_number fixed bin, /* version of this structure (3) */ 2 18 2 switches unaligned, /* mainly ws parameters */ 2 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 2 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 2 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 2 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 2 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 2 24 3 restrict_external_functions 2 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 2 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 2 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 2 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 2 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 2 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 2 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 2 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 2 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 2 34 3 compatibility_check_mode 2 35 bit, /* if 1, check for incompatible operators */ 2 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 2 37 /* remaining 20 bits not presently used */ 2 38 2 39 2 values, /* attributes of the workspace */ 2 40 3 digits fixed bin, /* number of digits of precision printed on output */ 2 41 3 width fixed bin, /* line length for formatted output */ 2 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 2 43 3 random_link fixed bin(35), /* seed for random number generator */ 2 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 2 45 3 float_index_origin float, /* the index origin in floating point */ 2 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 2 47 3 maximum_value_stack_size 2 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 2 49 2 50 2 pointers, /* pointers to various internal tables */ 2 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 2 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 2 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 2 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 2 55 2 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 2 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 2 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 2 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 2 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 2 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 2 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 2 63 2 signoff_lock character (32), 2 64 2 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 2 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 2 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 2 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 2 69 bit, /* munging his tables */ 2 70 3 unused_interrupt_bit bit, /* not presently used */ 2 71 3 dont_interrupt_command bit, 2 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 2 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 2 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 2 75 2 76 2 user_name char (32), /* process group id of user */ 2 77 2 immediate_input_prompt char (32) varying, /* normal input */ 2 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 2 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 2 80 2 vcpu_time aligned, 2 81 3 total fixed bin (71), 2 82 3 setup fixed bin (71), 2 83 3 parse fixed bin (71), 2 84 3 lex fixed bin (71), 2 85 3 operator fixed bin (71), 2 86 3 storage_manager fixed bin (71), 2 87 2 output_info aligned, /* data pertaining to output buffer */ 2 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 2 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 2 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 2 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 2 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 2 93 2 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 2 95 2 96 /* internal static */ 2 97 2 98 declare max_parse_stack_depth fixed bin int static init(64536); 2 99 2 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 89 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_parse_frame.incl.pl1 ================================== */ 3 2 3 3 declare 1 parse_frame aligned based (parse_frame_ptr), 3 4 2 last_parse_frame_ptr ptr unaligned, /* pointer to last parse frame, or null */ 3 5 2 parse_frame_type fixed bin, /* suspended, function, eval input, etc. */ 3 6 2 function_bead_ptr ptr unaligned, /* ptr to function bead */ 3 7 2 lexed_function_bead_ptr ptr unaligned, /* ptr to lexed function bead */ 3 8 2 reduction_stack_ptr ptr unaligned, /* ptr to reduction stack for this frame */ 3 9 2 current_parseme fixed bin, /* element of reduction stack that is top of stack */ 3 10 2 current_lexeme fixed bin, /* element number of current lexeme */ 3 11 2 current_line_number fixed bin, /* line number being executed */ 3 12 2 return_point fixed bin, /* where to join the reductions on return */ 3 13 2 put_result fixed bin, /* where to put the value when returning to this frame */ 3 14 2 print_final_value bit(1) aligned, /* if true, print final value on line */ 3 15 2 initial_value_stack_ptr ptr unaligned, /* for cleaning up the value stack */ 3 16 2 number_of_ptrs fixed bin, /* number of old meaning ptrs */ 3 17 2 old_meaning_ptrs dim (number_of_ptrs refer (parse_frame.number_of_ptrs)) ptr unaligned; 3 18 /* old meanings for local variables. */ 3 19 3 20 declare number_of_ptrs fixed bin; 3 21 3 22 declare (suspended_frame_type init (1), /* for comparison with parse frame type */ 3 23 function_frame_type init (2), 3 24 evaluated_frame_type init (3), 3 25 execute_frame_type init (4), 3 26 save_frame_type init (5) 3 27 ) fixed bin internal static options (constant); 3 28 3 29 declare reductions_pointer pointer; 3 30 3 31 declare 3 32 1 reduction_stack aligned dim (1000) based (reductions_pointer), 3 33 2 type fixed bin, /* type of parseme */ 3 34 2 bits unaligned like operator_bead.bits_for_parse, 3 35 2 semantics ptr unaligned, 3 36 2 lexeme fixed bin, 3 37 3 38 1 reduction_stack_for_op aligned dim (1000) based (reductions_pointer), 3 39 2 type fixed bin, 3 40 2 bits unaligned like operator_bead.bits_for_parse, 3 41 2 semantics fixed bin, 3 42 2 lexeme fixed bin, 3 43 3 44 (eol_type init(0), /* parseme types - end of line */ 3 45 bol_type init(1), /* begining of line */ 3 46 val_type init(2), /* value */ 3 47 op_type init(3), /* op */ 3 48 open_paren_type init(4), 3 49 close_paren_type init(5), 3 50 open_bracket_type init(6), 3 51 close_subscript_type init(7), 3 52 close_rank_type init(8), 3 53 semi_colon_type init(9), 3 54 diamond_type init (10), 3 55 subscript_type init (11)) fixed bin internal static options (constant); 3 56 3 57 /* ------ END INCLUDE SEGMENT apl_parse_frame.incl.pl1 ---------------------------------- */ 90 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 4 2 4 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 4 4 2 type unaligned, 4 5 3 bead_type unaligned, 4 6 4 operator bit (1), /* ON if operator bead */ 4 7 4 symbol bit (1), /* ON if symbol bead */ 4 8 4 value bit (1), /* ON if value bead */ 4 9 4 function bit (1), /* ON if function bead */ 4 10 4 group bit (1), /* ON if group bead */ 4 11 4 label bit (1), /* ON if label bead */ 4 12 4 shared_variable bit (1), /* ON if shared variable bead */ 4 13 4 lexed_function bit (1), /* ON if lexed function bead */ 4 14 3 data_type unaligned, 4 15 4 list_value bit (1), /* ON if a list value bead */ 4 16 4 character_value bit (1), /* ON if a character value bead */ 4 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 4 18 4 integral_value bit (1), /* ON if an integral value bead */ 4 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 4 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 4 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 4 22 2 size bit (18) unaligned, /* Number of words this bead occupies 4 23* (used by bead storage manager) */ 4 24 2 reference_count fixed binary (29); /* Number of pointers which point 4 25* to this bead (used by bead manager) */ 4 26 4 27 4 28 /* constant strings for initing type field in various beads */ 4 29 4 30 declare ( 4 31 operator_type init("100000000000000000"b), 4 32 symbol_type init("010000000000000000"b), 4 33 value_type init("001000000000000000"b), 4 34 function_type init("000100000000000000"b), 4 35 group_type init("000010000000000000"b), 4 36 label_type init("001001000011000000"b), 4 37 shared_variable_type init("001000100000000000"b), 4 38 lexed_function_type init("000000010000000000"b), 4 39 4 40 list_value_type init("000000001000000000"b), 4 41 character_value_type init("001000000100000000"b), 4 42 numeric_value_type init("001000000010000000"b), 4 43 integral_value_type init("001000000011000000"b), 4 44 zero_or_one_value_type init("001000000011100000"b), 4 45 complex_value_type init("001000000000010000"b), 4 46 4 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 4 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 4 49 ) bit(18) internal static; 4 50 4 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 91 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_operator_bead.incl.pl1 ================================ */ 5 2 5 3 declare 5 4 1 operator_bead aligned based, 5 5 5 6 2 type unaligned like general_bead.type, 5 7 5 8 2 bits_for_lex unaligned, 5 9 3 allow_brackets bit(1), /* operator may have dimension info in brackets */ 5 10 3 allow_product bit(1), /* operator may be used in inner and outer product */ 5 11 3 allow_reduction bit(1), /* operator may be used in reduction and scan */ 5 12 3 special_assignment bit(1), /* doesn't use standard assignment operator */ 5 13 3 ignores_assignment bit(1), /* assignment has no effect */ 5 14 3 allow_subscripted_assignment 5 15 bit(1), /* system variable that can be subscripted assigned */ 5 16 3 pad bit(12), 5 17 5 18 2 bits_for_parse unaligned, 5 19 3 stop_trace_control bit(1), /* next lexeme is function being stopped/traced 5 20* (op1 tells which) */ 5 21 3 quad bit(1), /* this is a quad type */ 5 22 3 system_variable bit(1), /* this is a system variable, not an op */ 5 23 3 dyadic bit(1), /* operator may be dyadic */ 5 24 3 monadic bit(1), /* operator may be monadic */ 5 25 3 function bit(1), /* operator is a user defined function */ 5 26 3 semantics_valid bit(1), /* if semantics has been set */ 5 27 3 has_list bit(1), /* semantics is a list */ 5 28 3 inner_product bit(1), /* op2 is valid */ 5 29 3 semantics_on_stack bit(1), /* semantics points to value stack */ 5 30 3 is_external_function bit(1), /* semantics points to function bead for ext function */ 5 31 3 pad bit(7), 5 32 3 op2 fixed bin(8) unaligned, /* secondary operator code */ 5 33 3 op1 fixed bin(8) unaligned, /* primary operator code */ 5 34 2 type_code fixed bin; /* for parse */ 5 35 5 36 /* ------ END INCLUDE SEGMENT apl_operator_bead.incl.pl1 -------------------------------- */ 92 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_symbol_bead.incl.pl1 ================================== */ 6 2 6 3 /* Explanation of fields: 6 4* symbol_bead.hash_link_pointer points to next symbol in same hash bucket in the symbol table. 6 5* symbol_bead.meaning_pointer points to current "value" of this name: 6 6* = null => unused (e.g. undefined variable) 6 7* -> group bead => group name 6 8* -> value bead => variable with a value 6 9* -> function bead => function name 6 10* -> label bead => localized label value 6 11* -> shared var bead => shared variable */ 6 12 6 13 declare 1 symbol_bead aligned based, 6 14 2 header aligned like general_bead, 6 15 2 hash_link_pointer pointer unaligned, 6 16 2 meaning_pointer pointer unaligned, 6 17 2 name_length fixed binary, 6 18 2 name character (0 refer (symbol_bead.name_length)) unaligned; 6 19 6 20 /* ------ END INCLUDE SEGMENT apl_symbol_bead.incl.pl1 ---------------------------------- */ 93 7 1 /* ====== BEGIN INCLUDE SEGMENT apl_lexed_function_bead.incl.pl1 ========================== */ 7 2 7 3 /* this is the format of a user-defined function after it has been run 7 4* through apl_lex_, the first (left to right) parsing phase. */ 7 5 7 6 dcl 1 lexed_function_bead based aligned, 7 7 2 header like general_bead, /* type bits, etc. */ 7 8 7 9 2 name pointer unaligned, /* -> symbol bead which names the function */ 7 10 2 bits_for_parse unaligned like operator_bead.bits_for_parse, /* so can treat like system function */ 7 11 2 number_of_statements fixed bin, 7 12 2 number_of_localized_symbols fixed bin, /* including labels and parameter variables, return var */ 7 13 /* even if they aren't there, thus >_ 3 */ 7 14 2 number_of_labels fixed bin, 7 15 2 label_values_ptr pointer unaligned, /* -> label_values below */ 7 16 2 statement_map_ptr pointer unaligned, /* -> statement_map below */ 7 17 2 lexeme_array_ptr pointer unaligned, /* -> lexeme_array below */ 7 18 7 19 /* the first 3 localized symbols are always reserved for ReturnSymbol, LeftArgSymbol, RighArgSymbol respectively. 7 20* If some of these symbols are not present (e.g. monadic or value-less function), null pointers are used. 7 21* So beware!, there can be null ptrs in the localized_symbols array. */ 7 22 7 23 2 localized_symbols( (0) refer (lexed_function_bead.number_of_localized_symbols)) pointer unaligned, 7 24 /* first localized vars from header line, then labels */ 7 25 2 label_values ( (0) refer (lexed_function_bead.number_of_labels)) pointer unaligned, 7 26 /* ptrs to label-value beads for labels */ 7 27 2 statement_map ( (0) refer (lexed_function_bead.number_of_statements)) fixed bin(18), 7 28 /* index in lexeme_array of rightmost lexeme of each stmt */ 7 29 2 lexeme_array ( (0) refer (lexed_function_bead.number_of_labels) /* not really, but fake out compiler */ ) pointer unaligned; 7 30 /* the actual lexemes. Length of array is 7 31* statement_map(number_of_statements) */ 7 32 7 33 7 34 /* manifest constants for first 3 localized symbols */ 7 35 7 36 dcl (ReturnSymbol init(1), 7 37 LeftArgSymbol init(2), 7 38 RightArgSymbol init(3) 7 39 ) fixed binary static; 7 40 7 41 7 42 /* the last three parts of this bead are referenced separately, though ptrs earlier in the bead. 7 43* Here are declarations for them as level-1 structures */ 7 44 7 45 dcl 1 lexed_function_label_values_structure based aligned, 7 46 2 lexed_function_label_values ( 500 /* or so */ ) pointer unaligned, 7 47 7 48 statement_count fixed bin, 7 49 lexed_function_statement_map (statement_count) fixed bin(18) aligned based, 7 50 7 51 1 lexed_function_lexemes_structure based aligned, 7 52 2 lexed_function_lexeme_array ( 500 /* or so */ ) pointer unaligned; 7 53 7 54 /* ------ END INCLUDE SEGMENT apl_lexed_function_bead.incl.pl1 -------------------------- */ 94 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 --------------------------- */ 95 9 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 9 2 9 3 declare 9 4 number_of_dimensions fixed bin, 9 5 9 6 1 value_bead aligned based, 9 7 2 header aligned like general_bead, 9 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 9 9 2 rhorho fixed binary, /* number of dimensions of value */ 9 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 9 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 9 12 /* dimensions of value (zero-origin) */ 9 13 9 14 9 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 9 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 9 17 /* actual elements of character array */ 9 18 9 19 declare character_string_overlay character (data_elements) aligned based; 9 20 /* to overlay on above structure */ 9 21 9 22 9 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 9 24 /* actual elements of numeric array */ 9 25 9 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 9 27 9 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 9 29 9 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 96 10 1 /* ====== BEGIN INCLUDE SEGMENT apl_list_bead.incl.pl1 ==================================== */ 10 2 10 3 declare n_members fixed bin, 10 4 10 5 1 list_bead aligned based, 10 6 2 header aligned like general_bead, 10 7 2 number_of_members fixed bin, 10 8 2 members dimension (n_members refer (list_bead.number_of_members)) aligned, 10 9 3 member_ptr unaligned pointer, 10 10 3 bits unaligned like operator_bead.bits_for_parse; 10 11 10 12 /* ------ END INCLUDE SEGMENT apl_list_bead.incl.pl1 ------------------------------------ */ 97 98 99 /* program */ 100 101 value_ptr = operators_argument.value (1); 102 list_ptr = operators_argument.value (2); 103 104 old_rhorho = list_ptr -> list_bead.number_of_members; 105 106 if old_rhorho^=value_ptr -> value_bead.rhorho then go to rank_error; 107 108 n_words = size (subscript_scratch); 109 subscript_scratch_ptr = apl_push_stack_ (n_words); 110 111 value_is_numeric = value_ptr -> value_bead.numeric_value; 112 call fill_in_scratch; 113 114 call stack_allocate; 115 116 float_index_origin = ws_info.index_origin; 117 integer_fuzz = ws_info.integer_fuzz; 118 from_data_ptr = value_ptr -> value_bead.data_pointer; 119 120 entry (old_rhorho) = 0; 121 122 do i = 0 by 1 while (i < data_elements); 123 call do_subscripting; 124 125 if value_is_numeric then result_data_ptr -> numeric_datum (i) = from_data_ptr -> numeric_datum (which_element); 126 else result_data_ptr -> character_datum (i) = from_data_ptr -> character_datum (which_element); 127 128 end; 129 130 call clean_up_list_bead; 131 132 call copy_up; 133 134 return; 135 136 fill_in_scratch: 137 proc; 138 139 new_rhorho = 0; 140 data_elements = 1; 141 multiplier_temp = 1; 142 143 do i = old_rhorho to 1 by -1; 144 multiplier (i) = multiplier_temp; 145 entry (i) = 1; 146 147 temp_member_ptr = list_ptr -> list_bead.member_ptr (i); 148 149 if temp_member_ptr=null then do; 150 subscripted_value_rho (i), max_value (i) = value_ptr -> value_bead.rho (i); 151 data_elements = data_elements * max_value (i); 152 new_rhorho = new_rhorho + 1; 153 null_entry (i) = "1"b; 154 end; 155 else do; 156 max_value (i) = temp_member_ptr -> value_bead.total_data_elements; 157 data_elements = data_elements * max_value (i); 158 value_bead_data_ptr (i) = temp_member_ptr -> value_bead.data_pointer; 159 subscripted_value_rho (i) = value_ptr -> value_bead.rho (i); 160 if temp_member_ptr -> value_bead.integral_value then is_integer (i) = "1"b; 161 else if temp_member_ptr -> value_bead.character_value then go to domain_error; 162 else is_integer (i) = "0"b; 163 new_rhorho = new_rhorho + temp_member_ptr -> value_bead.rhorho; 164 null_entry (i) = "0"b; 165 end; 166 167 multiplier_temp = multiplier_temp * subscripted_value_rho (i); 168 169 end; 170 171 return; 172 173 end; 174 175 stack_allocate: 176 proc; 177 178 if value_is_numeric then n_words = size (numeric_datum) + 1; 179 else n_words = size (character_string_overlay); 180 181 number_of_dimensions = new_rhorho; 182 n_words = n_words + size (value_bead); 183 result_ptr = apl_push_stack_ (n_words); 184 185 result_data_ptr = addr (result_ptr -> value_bead.rho (new_rhorho + 1)); 186 if value_is_numeric then if substr (rel (result_data_ptr),18,1) then 187 result_data_ptr = addrel (result_data_ptr, 1); 188 189 result_ptr -> value_bead.data_pointer = result_data_ptr; 190 string (result_ptr -> value_bead.type) = string (value_ptr -> value_bead.type); 191 result_ptr -> value_bead.total_data_elements = data_elements; 192 result_ptr -> value_bead.rhorho = new_rhorho; 193 194 counter = 0; 195 do i = 1 to old_rhorho; 196 if null_entry (i) then do; 197 counter = counter + 1; 198 result_ptr -> value_bead.rho (counter) = subscripted_value_rho (i); 199 end; 200 else do; 201 temp_member_ptr = list_ptr -> list_bead.member_ptr (i); 202 do j = 1 to temp_member_ptr -> value_bead.rhorho; 203 counter = counter + 1; 204 result_ptr -> value_bead.rho (counter) = temp_member_ptr -> value_bead.rho (j); 205 end; 206 end; 207 end; 208 209 return; 210 211 end; 212 213 do_subscripting: 214 proc; 215 216 which_element = 0; 217 carry = "1"b; 218 219 do j = old_rhorho to 1 by -1; 220 221 if carry then do; 222 entry (j) = entry (j) + 1; 223 if entry (j)>max_value (j) then entry (j) = 1; 224 else carry = "0"b; 225 end; 226 227 if null_entry (j) then which_element = which_element + (entry (j) - 1) * multiplier (j); 228 else do; 229 float_subscript = value_bead_data_ptr (j) -> numeric_datum (entry (j) - 1) - float_index_origin; 230 if is_integer (j) then fixed_subscript = fixed (float_subscript); 231 else do; 232 float_temp = floor (float_subscript + 0.5); 233 if abs (float_temp - float_subscript) > integer_fuzz then go to index_error; 234 if abs (float_temp) > 1e21b then go to index_error; 235 fixed_subscript = fixed (float_temp); 236 end; 237 if fixed_subscript<0 then go to index_error; 238 if fixed_subscript>=subscripted_value_rho (j) then go to index_error; 239 which_element = which_element + fixed_subscript * multiplier (j); 240 end; 241 242 end; 243 244 245 end; 246 247 clean_up_list_bead: 248 proc; 249 250 251 final_ptr = list_ptr; 252 253 do i = 1 to list_ptr -> list_bead.number_of_members; 254 temp_member_ptr = list_ptr -> list_bead.member_ptr (i); 255 if temp_member_ptr ^= null 256 then if list_ptr -> list_bead.bits (i).semantics_on_stack 257 then final_ptr = temp_member_ptr; 258 else do; 259 temp_member_ptr -> general_bead.reference_count = temp_member_ptr -> general_bead.reference_count - 1; 260 if temp_member_ptr -> general_bead.reference_count < 1 261 then call apl_free_bead_ ((temp_member_ptr)); 262 end; 263 end; 264 265 ws_info.value_stack_ptr = final_ptr; /* pop list bead & friends */ 266 return; 267 268 end; 269 270 copy_up: 271 proc; 272 273 final_ptr = apl_push_stack_ (n_words); 274 275 string (final_ptr -> value_bead.type) = string (result_ptr -> value_bead.type); 276 final_ptr -> value_bead.total_data_elements = result_ptr -> value_bead.total_data_elements; 277 final_ptr -> value_bead.total_data_elements = data_elements; 278 final_ptr -> value_bead.rhorho = new_rhorho; 279 do i = 1 to new_rhorho; 280 final_ptr -> value_bead.rho (i) = result_ptr -> value_bead.rho (i); 281 end; 282 283 final_data_ptr = addr (final_ptr -> value_bead.rho (new_rhorho + 1)); 284 if value_is_numeric then do; 285 if substr (rel (final_data_ptr),18,1) then final_data_ptr = addrel (final_data_ptr, 1); 286 final_data_ptr -> numeric_datum (*) = result_data_ptr -> numeric_datum (*); 287 end; 288 else final_data_ptr -> character_string_overlay = result_data_ptr -> character_string_overlay; 289 290 final_ptr -> value_bead.data_pointer = final_data_ptr; 291 292 operators_argument.result = final_ptr; 293 294 return; 295 296 end; 297 298 rank_error: 299 operators_argument.error_code = apl_error_table_$rank; 300 return; 301 302 index_error: 303 operators_argument.error_code = apl_error_table_$index; 304 return; 305 306 domain_error: 307 operators_argument.error_code = apl_error_table_$domain; 308 return; 309 310 cant_assign_to_value: 311 operators_argument.error_code = apl_error_table_$assign_to_value; 312 return; 313 314 length_error: 315 operators_argument.error_code = apl_error_table_$length; 316 return; 317 318 value_error_right: 319 operators_argument.where_error = operators_argument.where_error - 2; 320 321 value_error_left: 322 operators_argument.where_error = operators_argument.where_error + 1; 323 operators_argument.error_code = apl_error_table_$value; 324 return; 325 326 apl_subscripted_assignment_: 327 entry (operators_argument, rs_ptr); 328 329 330 dcl 331 rs_ptr ptr, 332 1 rs (1000) aligned based (rs_ptr), 333 2 type fixed bin, 334 2 bits unaligned like operator_bead.bits_for_parse, 335 2 semantics ptr unaligned, 336 2 lexeme fixed bin; 337 338 if rs (assigner).semantics = null 339 then go to value_error_right; 340 341 if rs (assignee).semantics = null 342 then go to value_error_left; 343 344 if rs (assignee).semantics_on_stack then go to cant_assign_to_value; 345 temp_ptr = current_parse_frame_ptr -> parse_frame.lexed_function_bead_ptr -> lexed_function_bead.lexeme_array_ptr -> 346 lexed_function_lexeme_array (rs (assignee).lexeme); 347 if ^temp_ptr -> general_bead.symbol then go to cant_assign_to_value; 348 if temp_ptr -> meaning_pointer -> general_bead.reference_count>2 then do; 349 temp_ptr -> meaning_pointer -> general_bead.reference_count = 350 temp_ptr -> meaning_pointer -> general_bead.reference_count - 1; 351 call apl_copy_value_ ( (temp_ptr -> meaning_pointer), temp_ptr -> meaning_pointer); 352 temp_ptr -> meaning_pointer -> general_bead.reference_count = 353 temp_ptr -> meaning_pointer -> general_bead.reference_count + 1; 354 rs (assignee).semantics = temp_ptr -> meaning_pointer; 355 end; 356 357 assigner_ptr = rs (assigner).semantics; 358 assignee_ptr = rs (assignee).semantics; 359 list_ptr = rs (list).semantics; 360 361 old_rhorho = list_ptr -> list_bead.number_of_members; 362 if old_rhorho^=assignee_ptr -> value_bead.rhorho then go to rank_error; 363 364 /* Allocate scratch vector. It will get popped when list bead is popped */ 365 366 n_words = size (subscript_scratch); 367 subscript_scratch_ptr = apl_push_stack_ (n_words); 368 369 value_is_numeric = assignee_ptr -> value_bead.numeric_value; 370 if bool (value_is_numeric, assigner_ptr -> value_bead.numeric_value, "0110"b) then go to domain_error; 371 372 string (assignee_ptr -> value_bead.data_type) = string (assignee_ptr -> value_bead.data_type) & 373 string (assigner_ptr -> value_bead.data_type); 374 375 value_ptr = assignee_ptr; 376 377 call fill_in_scratch; 378 379 if assigner_ptr -> value_bead.total_data_elements = 1 /* an effective scalar */ 380 then increment = 0; 381 else do; 382 counter = 0; 383 do i = 1 to old_rhorho; 384 if null_entry (i) 385 then do; 386 counter = counter + 1; 387 if subscripted_value_rho (i)^=assigner_ptr -> value_bead.rho (counter) 388 then go to length_error; 389 end; 390 else do; 391 temp_member_ptr = list_ptr -> list_bead.member_ptr (i); 392 do j = 1 to temp_member_ptr -> value_bead.rhorho; 393 grace_to_one_rhos: 394 counter = counter + 1; 395 if assigner_ptr -> value_bead.rho (counter)^=temp_member_ptr -> value_bead.rho (j) 396 then do; 397 if assigner_ptr -> value_bead.rho (counter)=1 398 then go to grace_to_one_rhos; 399 go to length_error; 400 end; 401 end; 402 end; 403 end; 404 increment = 1; 405 end; 406 407 float_index_origin = ws_info.index_origin; 408 integer_fuzz = ws_info.integer_fuzz; 409 from_data_ptr = assigner_ptr -> value_bead.data_pointer; 410 result_data_ptr = assignee_ptr -> value_bead.data_pointer; 411 412 entry (old_rhorho) = 0; 413 from_subscript = 0; 414 415 do i = 0 by 1 while (i < data_elements); 416 call do_subscripting; 417 418 if value_is_numeric 419 then result_data_ptr -> numeric_datum (which_element) = from_data_ptr -> numeric_datum (from_subscript); 420 else result_data_ptr -> character_datum (which_element) = from_data_ptr -> character_datum (from_subscript); 421 422 from_subscript = from_subscript + increment; 423 end; 424 425 call clean_up_list_bead; 426 427 assignee_ptr -> general_bead.reference_count = assignee_ptr -> general_bead.reference_count - 1; 428 429 return; 430 11 1 /* ====== BEGIN INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 =============================== */ 11 2 11 3 /* format: style3 */ 11 4 apl_push_stack_: 11 5 procedure (P_n_words) returns (ptr); 11 6 11 7 /* Function to (1) double-word align ws_info.value_stack_ptr, and 11 8* (2) make sure allocation request will fit on current value stack. 11 9* 11 10* Written 770413 by PG 11 11* Modified 780210 by PG to round allocations up to an even number of words. 11 12**/ 11 13 11 14 /* parameters */ 11 15 11 16 declare P_n_words fixed bin (19) parameter; 11 17 11 18 /* automatic */ 11 19 11 20 declare block_ptr ptr, 11 21 num_words fixed bin (19); 11 22 11 23 /* builtins */ 11 24 11 25 declare (addrel, binary, rel, substr, unspec) 11 26 builtin; 11 27 11 28 /* entries */ 11 29 11 30 declare apl_get_value_stack_ 11 31 entry (fixed bin (19)); 11 32 11 33 /* program */ 11 34 11 35 num_words = P_n_words; 11 36 11 37 if substr (unspec (num_words), 36, 1) = "1"b /* num_words odd */ 11 38 then num_words = num_words + 1; 11 39 11 40 if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size 11 41 then call apl_get_value_stack_ (num_words); 11 42 11 43 block_ptr = ws_info.value_stack_ptr; 11 44 ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words); 11 45 return (block_ptr); 11 46 11 47 end apl_push_stack_; 11 48 11 49 /* ------ END INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 ------------------------------- */ 431 432 end /* apl_subscript_a_value_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1347.2 apl_subscript_a_value_.pl1 >special_ldd>on>apl.1129>apl_subscript_a_value_.pl1 88 1 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 89 2 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 90 3 03/27/82 0439.0 apl_parse_frame.incl.pl1 >ldd>include>apl_parse_frame.incl.pl1 91 4 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 92 5 03/27/82 0439.0 apl_operator_bead.incl.pl1 >ldd>include>apl_operator_bead.incl.pl1 93 6 03/27/82 0439.2 apl_symbol_bead.incl.pl1 >ldd>include>apl_symbol_bead.incl.pl1 94 7 03/27/82 0438.7 apl_lexed_function_bead.incl.pl1 >ldd>include>apl_lexed_function_bead.incl.pl1 95 8 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 96 9 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 97 10 03/27/82 0438.7 apl_list_bead.incl.pl1 >ldd>include>apl_list_bead.incl.pl1 431 11 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_fcn.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. P_n_words parameter fixed bin(19,0) dcl 11-16 ref 11-4 11-35 abs builtin function dcl 24 ref 233 234 addr builtin function dcl 24 ref 185 283 addrel builtin function dcl 24 in procedure "apl_subscript_a_value_" ref 186 285 addrel builtin function dcl 11-25 in procedure "apl_push_stack_" ref 11-44 apl_copy_value_ 000012 constant entry external dcl 28 ref 351 apl_error_table_$assign_to_value 000022 external static fixed bin(35,0) dcl 79 ref 310 apl_error_table_$domain 000024 external static fixed bin(35,0) dcl 79 ref 306 apl_error_table_$index 000014 external static fixed bin(35,0) dcl 79 ref 302 apl_error_table_$length 000016 external static fixed bin(35,0) dcl 79 ref 314 apl_error_table_$rank 000026 external static fixed bin(35,0) dcl 79 ref 298 apl_error_table_$value 000020 external static fixed bin(35,0) dcl 79 ref 323 apl_free_bead_ 000010 constant entry external dcl 28 ref 260 apl_get_value_stack_ 000032 constant entry external dcl 11-30 ref 11-40 apl_static_$ws_info_ptr 000030 external static structure level 1 dcl 2-11 assignee constant fixed bin(17,0) initial dcl 28 ref 341 344 345 354 358 assignee_ptr 000160 automatic pointer dcl 28 set ref 358* 362 369 372 372 375 410 427 427 assigner constant fixed bin(17,0) initial dcl 28 ref 338 357 assigner_ptr 000156 automatic pointer dcl 28 set ref 357* 370 372 379 387 395 397 409 bead_type based structure level 3 packed unaligned dcl 4-3 binary builtin function dcl 11-25 ref 11-40 bits 1 based structure array level 2 in structure "rs" packed unaligned dcl 330 in procedure "apl_subscript_a_value_" bits 4 based structure array level 3 in structure "list_bead" packed unaligned dcl 10-3 in procedure "apl_subscript_a_value_" bits_for_parse 1 based structure level 2 packed unaligned dcl 5-3 block_ptr 000242 automatic pointer dcl 11-20 set ref 11-43* 11-45 bool builtin function dcl 24 ref 370 carry 000133 automatic bit(1) dcl 28 set ref 217* 221 224* character_data_structure based structure level 1 dcl 9-15 character_datum based char(1) array level 2 packed unaligned dcl 9-15 set ref 126* 126 420* 420 character_string_overlay based char dcl 9-19 set ref 179 288* 288 character_value 0(09) based bit(1) level 5 packed unaligned dcl 9-3 set ref 161 counter 000150 automatic fixed bin(17,0) dcl 28 set ref 194* 197* 197 198 203* 203 204 382* 386* 386 387 393* 393 395 397 current_parse_frame_ptr 15 based pointer level 3 packed unaligned dcl 2-16 ref 345 data_elements 000114 automatic fixed bin(21,0) dcl 28 set ref 122 140* 151* 151 157* 157 178 179 179 191 277 286 288 288 415 data_pointer 4 based pointer level 2 packed unaligned dcl 9-3 set ref 118 158 189* 290* 409 410 data_type 0(08) based structure level 4 packed unaligned dcl 9-3 set ref 372* 372 372 entry based fixed bin(17,0) array level 2 dcl 28 set ref 120* 145* 222* 222 223 223* 227 229 412* error_code 7 parameter fixed bin(35,0) level 2 dcl 8-3 set ref 298* 302* 306* 310* 314* 323* final_data_ptr 000154 automatic pointer dcl 28 set ref 283* 285 285* 285 286 288 290 final_ptr 000152 automatic pointer dcl 28 set ref 251* 255* 265 273* 275 276 277 278 280 283 290 292 fixed builtin function dcl 24 ref 230 235 fixed_subscript 000142 automatic fixed bin(21,0) dcl 28 set ref 230* 235* 237 238 239 float_index_origin 000124 automatic float bin(63) dcl 28 set ref 116* 229 407* float_subscript 000136 automatic float bin(63) dcl 28 set ref 229* 230 232 233 float_temp 000140 automatic float bin(63) dcl 28 set ref 232* 233 234 235 floor builtin function dcl 24 ref 232 from_data_ptr 000130 automatic pointer dcl 28 set ref 118* 125 126 409* 418 420 from_subscript 000101 automatic fixed bin(21,0) dcl 28 set ref 413* 418 420 422* 422 general_bead based structure level 1 dcl 4-3 header based structure level 2 dcl 9-3 i 000115 automatic fixed bin(21,0) dcl 28 set ref 122* 122* 125 126* 143* 144 145 147 150 150 150 151 153 156 157 158 159 159 160 162 164 167* 195* 196 198 201* 253* 254 255* 279* 280 280* 383* 384 387 391* 415* 415* increment 000100 automatic fixed bin(17,0) dcl 28 set ref 379* 404* 422 index_origin 4 based fixed bin(17,0) level 3 dcl 2-16 ref 116 407 integer_fuzz 000126 automatic float bin(63) dcl 28 in procedure "apl_subscript_a_value_" set ref 117* 233 408* integer_fuzz 22 based float bin(63) level 2 in structure "ws_info" dcl 2-16 in procedure "apl_subscript_a_value_" ref 117 408 integral_value 0(11) based bit(1) level 5 packed unaligned dcl 9-3 set ref 160 is_integer 6 based bit(1) array level 2 dcl 28 set ref 160* 162* 230 j 000134 automatic fixed bin(17,0) dcl 28 set ref 202* 204* 219* 222 222 223 223 223 227 227 227 229 229 230 238 239* 392* 395* lexed_function_bead based structure level 1 dcl 7-6 lexed_function_bead_ptr 3 based pointer level 2 packed unaligned dcl 3-3 ref 345 lexed_function_lexeme_array based pointer array level 2 packed unaligned dcl 7-45 ref 345 lexed_function_lexemes_structure based structure level 1 dcl 7-45 lexeme 3 based fixed bin(17,0) array level 2 dcl 330 ref 345 lexeme_array_ptr 11 based pointer level 2 packed unaligned dcl 7-6 ref 345 list constant fixed bin(17,0) initial dcl 28 ref 359 list_bead based structure level 1 dcl 10-3 list_ptr 000104 automatic pointer dcl 28 set ref 102* 104 147 201 251 253 254 255 359* 361 391 max_value 4 based fixed bin(17,0) array level 2 dcl 28 set ref 150* 151 156* 157 223 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 2-16 ref 11-40 meaning_pointer 3 based pointer level 2 packed unaligned dcl 6-13 set ref 348 349 349 351 351* 352 352 354 member_ptr 3 based pointer array level 3 packed unaligned dcl 10-3 ref 147 201 254 391 members 3 based structure array level 2 dcl 10-3 multiplier 1 based fixed bin(17,0) array level 2 dcl 28 set ref 144* 227 239 multiplier_temp 000116 automatic fixed bin(17,0) dcl 28 set ref 141* 144 167* 167 n_words 000107 automatic fixed bin(19,0) dcl 28 set ref 108* 109* 178* 179* 182* 182 183* 273* 366* 367* new_rhorho 000113 automatic fixed bin(17,0) dcl 28 set ref 139* 152* 152 163* 163 181 185 192 278 279 283 null builtin function dcl 24 ref 149 255 338 341 null_entry 5 based bit(1) array level 2 dcl 28 set ref 153* 164* 196 227 384 num_words 000244 automatic fixed bin(19,0) dcl 11-20 set ref 11-35* 11-37 11-37* 11-37 11-40 11-40* 11-44 number_of_dimensions 000164 automatic fixed bin(17,0) dcl 9-3 set ref 181* 182 number_of_members 2 based fixed bin(17,0) level 2 dcl 10-3 ref 104 253 361 numeric_datum based float bin(63) array dcl 9-23 set ref 125* 125 178 229 286* 286 418* 418 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 9-3 set ref 111 369 370 old_rhorho 000106 automatic fixed bin(17,0) dcl 28 set ref 104* 106 108 120 143 195 219 361* 362 366 383 412 operands parameter structure array level 2 dcl 8-3 operator_bead based structure level 1 dcl 5-3 operators_argument parameter structure level 1 dcl 8-3 set ref 19 326 parse_frame based structure level 1 dcl 3-3 pointers 14 based structure level 2 dcl 2-16 reference_count 1 based fixed bin(29,0) level 2 dcl 4-3 set ref 259* 259 260 348 349* 349 352* 352 427* 427 rel builtin function dcl 11-25 in procedure "apl_push_stack_" ref 11-40 rel builtin function dcl 24 in procedure "apl_subscript_a_value_" ref 186 285 result 6 parameter pointer level 2 packed unaligned dcl 8-3 set ref 292* result_data_ptr 000144 automatic pointer dcl 28 set ref 125 126 185* 186 186* 186 189 286 288 410* 418 420 result_ptr 000146 automatic pointer dcl 28 set ref 183* 185 189 190 191 192 198 204 275 276 280 rho 5 based fixed bin(21,0) array level 2 dcl 9-3 set ref 150 159 185 198* 204* 204 280* 280 283 387 395 395 397 rhorho 3 based fixed bin(17,0) level 2 dcl 9-3 set ref 106 163 192* 202 278* 362 392 rs based structure array level 1 dcl 330 rs_ptr parameter pointer dcl 330 ref 326 338 341 344 345 354 357 358 359 semantics 2 based pointer array level 2 packed unaligned dcl 330 set ref 338 341 354* 357 358 359 semantics_on_stack 4(09) based bit(1) array level 4 in structure "list_bead" packed unaligned dcl 10-3 in procedure "apl_subscript_a_value_" ref 255 semantics_on_stack 1(09) based bit(1) array level 3 in structure "rs" packed unaligned dcl 330 in procedure "apl_subscript_a_value_" ref 344 size builtin function dcl 24 ref 108 178 179 182 366 static_ws_info_ptr 000030 external static pointer level 2 packed unaligned dcl 2-11 ref 2-7 string builtin function dcl 24 set ref 190* 190 275* 275 372* 372 372 subscript_scratch based structure array level 1 dcl 28 set ref 108 366 subscript_scratch_ptr 000110 automatic pointer dcl 28 set ref 108 109* 120 144 145 150 150 151 153 156 157 158 159 160 162 164 167 196 198 222 222 223 223 223 227 227 227 229 229 230 238 239 366 367* 384 387 412 subscripted_value_rho 2 based fixed bin(17,0) array level 2 dcl 28 set ref 150* 159* 167 198 238 387 substr builtin function dcl 11-25 in procedure "apl_push_stack_" ref 11-37 substr builtin function dcl 24 in procedure "apl_subscript_a_value_" ref 186 285 symbol 0(01) based bit(1) level 4 packed unaligned dcl 4-3 ref 347 symbol_bead based structure level 1 dcl 6-13 temp_member_ptr 000120 automatic pointer dcl 28 set ref 147* 149 156 158 160 161 163 201* 202 204 254* 255 255 259 259 260 260 391* 392 395 temp_ptr 000122 automatic pointer dcl 28 set ref 345* 347 348 349 349 351 351 352 352 354 total_data_elements 2 based fixed bin(21,0) level 2 dcl 9-3 set ref 156 191* 276* 276 277* 379 type based structure level 3 in structure "value_bead" packed unaligned dcl 9-3 in procedure "apl_subscript_a_value_" set ref 190* 190 275* 275 type based structure level 3 in structure "lexed_function_bead" packed unaligned dcl 7-6 in procedure "apl_subscript_a_value_" type based structure level 2 in structure "general_bead" packed unaligned dcl 4-3 in procedure "apl_subscript_a_value_" type based structure level 3 in structure "list_bead" packed unaligned dcl 10-3 in procedure "apl_subscript_a_value_" type based structure level 3 in structure "symbol_bead" packed unaligned dcl 6-13 in procedure "apl_subscript_a_value_" unspec builtin function dcl 11-25 ref 11-37 value parameter pointer array level 3 packed unaligned dcl 8-3 ref 101 102 value_bead based structure level 1 dcl 9-3 set ref 182 value_bead_data_ptr 3 based pointer array level 2 packed unaligned dcl 28 set ref 158* 229 value_is_numeric 000112 automatic bit(1) dcl 28 set ref 111* 125 178 186 284 369* 370 418 value_ptr 000102 automatic pointer dcl 28 set ref 101* 106 111 118 150 159 190 375* value_stack_ptr 16 based pointer level 3 packed unaligned dcl 2-16 set ref 265* 11-40 11-43 11-44* 11-44 values 2 based structure level 2 dcl 2-16 where_error 10 parameter fixed bin(17,0) level 2 dcl 8-3 set ref 318* 318 321* 321 which_element 000132 automatic fixed bin(21,0) dcl 28 set ref 125 126 216* 227* 227 239* 239 418 420 ws_info based structure level 1 dcl 2-16 ws_info_ptr 000162 automatic pointer initial dcl 2-7 set ref 116 117 345 407 408 2-7* 265 11-40 11-40 11-43 11-44 11-44 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Binary internal static bit(1) initial dcl 1-16 LeftArgSymbol internal static fixed bin(17,0) initial dcl 7-36 MAX_VALUE_BEAD_SIZE internal static fixed bin(19,0) initial dcl 9-28 NumberSize internal static fixed bin(4,0) initial dcl 1-25 ReturnSymbol internal static fixed bin(17,0) initial dcl 7-36 RightArgSymbol internal static fixed bin(17,0) initial dcl 7-36 TheBiggestNumberWeveGot internal static float bin(63) initial dcl 1-16 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 1-16 bol_type internal static fixed bin(17,0) initial dcl 3-31 character_value_type internal static bit(18) initial unaligned dcl 4-30 close_paren_type internal static fixed bin(17,0) initial dcl 3-31 close_rank_type internal static fixed bin(17,0) initial dcl 3-31 close_subscript_type internal static fixed bin(17,0) initial dcl 3-31 complex_datum based complex float bin(63) array dcl 9-26 complex_value_type internal static bit(18) initial unaligned dcl 4-30 diamond_type internal static fixed bin(17,0) initial dcl 3-31 eol_type internal static fixed bin(17,0) initial dcl 3-31 evaluated_frame_type internal static fixed bin(17,0) initial dcl 3-22 execute_frame_type internal static fixed bin(17,0) initial dcl 3-22 function_frame_type internal static fixed bin(17,0) initial dcl 3-22 function_type internal static bit(18) initial unaligned dcl 4-30 group_type internal static bit(18) initial unaligned dcl 4-30 integral_value_type internal static bit(18) initial unaligned dcl 4-30 label_type internal static bit(18) initial unaligned dcl 4-30 lexed_function_label_values_structure based structure level 1 dcl 7-45 lexed_function_statement_map based fixed bin(18,0) array dcl 7-45 lexed_function_type internal static bit(18) initial unaligned dcl 4-30 list_value_type internal static bit(18) initial unaligned dcl 4-30 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 2-98 n_members automatic fixed bin(17,0) dcl 10-3 not_integer_mask internal static bit(18) initial unaligned dcl 4-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 4-30 number_of_ptrs automatic fixed bin(17,0) dcl 3-20 numeric_value_type internal static bit(18) initial unaligned dcl 4-30 op_type internal static fixed bin(17,0) initial dcl 3-31 open_bracket_type internal static fixed bin(17,0) initial dcl 3-31 open_paren_type internal static fixed bin(17,0) initial dcl 3-31 operator_type internal static bit(18) initial unaligned dcl 4-30 output_buffer based char unaligned dcl 2-94 parse_frame_ptr automatic pointer dcl 28 reduction_stack based structure array level 1 dcl 3-31 reduction_stack_for_op based structure array level 1 dcl 3-31 reductions_pointer automatic pointer dcl 3-29 save_frame_type internal static fixed bin(17,0) initial dcl 3-22 semi_colon_type internal static fixed bin(17,0) initial dcl 3-31 shared_variable_type internal static bit(18) initial unaligned dcl 4-30 statement_count automatic fixed bin(17,0) dcl 7-45 subscript_type internal static fixed bin(17,0) initial dcl 3-31 suspended_frame_type internal static fixed bin(17,0) initial dcl 3-22 symbol_type internal static bit(18) initial unaligned dcl 4-30 val_type internal static fixed bin(17,0) initial dcl 3-31 value_type internal static bit(18) initial unaligned dcl 4-30 zero_or_one_value_type internal static bit(18) initial unaligned dcl 4-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_push_stack_ 001254 constant entry internal dcl 11-4 ref 109 183 273 367 apl_subscript_a_value_ 000042 constant entry external dcl 19 apl_subscripted_assignment_ 000221 constant entry external dcl 326 cant_assign_to_value 000166 constant label dcl 310 ref 344 347 clean_up_list_bead 001104 constant entry internal dcl 247 ref 130 425 copy_up 001162 constant entry internal dcl 270 ref 132 do_subscripting 000766 constant entry internal dcl 213 ref 123 416 domain_error 000160 constant label dcl 306 ref 161 370 fill_in_scratch 000540 constant entry internal dcl 136 ref 112 377 grace_to_one_rhos 000437 constant label dcl 393 ref 397 index_error 000152 constant label dcl 302 set ref 233 234 237 238 length_error 000174 constant label dcl 314 ref 387 399 rank_error 000144 constant label dcl 298 ref 106 362 stack_allocate 000645 constant entry internal dcl 175 ref 114 value_error_left 000206 constant label dcl 321 set ref 341 value_error_right 000202 constant label dcl 318 ref 338 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1512 1546 1344 1522 Length 2170 1344 34 405 146 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_subscript_a_value_ 196 external procedure is an external procedure. fill_in_scratch internal procedure shares stack frame of external procedure apl_subscript_a_value_. stack_allocate internal procedure shares stack frame of external procedure apl_subscript_a_value_. do_subscripting internal procedure shares stack frame of external procedure apl_subscript_a_value_. clean_up_list_bead internal procedure shares stack frame of external procedure apl_subscript_a_value_. copy_up internal procedure shares stack frame of external procedure apl_subscript_a_value_. apl_push_stack_ internal procedure shares stack frame of external procedure apl_subscript_a_value_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_subscript_a_value_ 000100 increment apl_subscript_a_value_ 000101 from_subscript apl_subscript_a_value_ 000102 value_ptr apl_subscript_a_value_ 000104 list_ptr apl_subscript_a_value_ 000106 old_rhorho apl_subscript_a_value_ 000107 n_words apl_subscript_a_value_ 000110 subscript_scratch_ptr apl_subscript_a_value_ 000112 value_is_numeric apl_subscript_a_value_ 000113 new_rhorho apl_subscript_a_value_ 000114 data_elements apl_subscript_a_value_ 000115 i apl_subscript_a_value_ 000116 multiplier_temp apl_subscript_a_value_ 000120 temp_member_ptr apl_subscript_a_value_ 000122 temp_ptr apl_subscript_a_value_ 000124 float_index_origin apl_subscript_a_value_ 000126 integer_fuzz apl_subscript_a_value_ 000130 from_data_ptr apl_subscript_a_value_ 000132 which_element apl_subscript_a_value_ 000133 carry apl_subscript_a_value_ 000134 j apl_subscript_a_value_ 000136 float_subscript apl_subscript_a_value_ 000140 float_temp apl_subscript_a_value_ 000142 fixed_subscript apl_subscript_a_value_ 000144 result_data_ptr apl_subscript_a_value_ 000146 result_ptr apl_subscript_a_value_ 000150 counter apl_subscript_a_value_ 000152 final_ptr apl_subscript_a_value_ 000154 final_data_ptr apl_subscript_a_value_ 000156 assigner_ptr apl_subscript_a_value_ 000160 assignee_ptr apl_subscript_a_value_ 000162 ws_info_ptr apl_subscript_a_value_ 000164 number_of_dimensions apl_subscript_a_value_ 000242 block_ptr apl_push_stack_ 000244 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 call_ext_out return fl2_to_fx2 ext_entry floor_fl THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_copy_value_ apl_free_bead_ apl_get_value_stack_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. apl_error_table_$assign_to_value apl_error_table_$domain apl_error_table_$index apl_error_table_$length apl_error_table_$rank apl_error_table_$value apl_static_$ws_info_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 2 7 000032 19 000037 101 000050 102 000053 104 000056 106 000060 108 000062 109 000064 111 000066 112 000072 114 000073 116 000074 117 000100 118 000102 120 000105 122 000111 123 000115 125 000116 126 000130 128 000137 130 000141 132 000142 134 000143 298 000144 300 000151 302 000152 304 000157 306 000160 308 000165 310 000166 312 000173 314 000174 316 000201 318 000202 321 000206 323 000211 324 000214 326 000215 338 000227 341 000237 344 000244 345 000247 347 000256 348 000261 349 000266 351 000270 352 000303 354 000306 357 000315 358 000323 359 000325 361 000330 362 000332 366 000334 367 000336 369 000340 370 000344 372 000351 375 000365 377 000367 379 000370 382 000376 383 000377 384 000407 386 000414 387 000415 389 000422 391 000423 392 000430 393 000437 395 000440 397 000447 399 000451 401 000452 403 000454 404 000456 407 000460 408 000464 409 000466 410 000471 412 000474 413 000500 415 000501 416 000505 418 000506 420 000520 422 000527 423 000531 425 000533 427 000534 429 000537 136 000540 139 000541 140 000542 141 000544 143 000546 144 000553 145 000560 147 000562 149 000567 150 000574 151 000601 152 000603 153 000604 154 000606 156 000607 157 000611 158 000613 159 000615 160 000621 161 000627 162 000632 163 000633 164 000635 167 000636 169 000641 171 000644 175 000645 178 000646 179 000655 181 000661 182 000663 183 000665 185 000667 186 000673 189 000703 190 000705 191 000707 192 000711 194 000713 195 000714 196 000723 197 000730 198 000731 199 000735 201 000736 202 000743 203 000753 204 000754 205 000761 207 000763 209 000765 213 000766 216 000767 217 000770 219 000772 221 000777 222 001001 223 001004 224 001014 227 001015 229 001032 230 001040 232 001047 233 001053 234 001060 235 001067 237 001072 238 001073 239 001075 242 001100 245 001103 247 001104 251 001105 253 001107 254 001117 255 001123 259 001137 260 001141 263 001154 265 001156 266 001161 270 001162 273 001163 275 001165 276 001170 277 001174 278 001176 279 001200 280 001207 281 001214 283 001216 284 001222 285 001224 286 001232 287 001240 288 001241 290 001246 292 001250 294 001253 11 4 001254 11 35 001256 11 37 001260 11 40 001265 11 43 001302 11 44 001305 11 45 001314 ----------------------------------------------------------- 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