COMPILATION LISTING OF SEGMENT apl_system_variables_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1618.4 mst Tue Options: optimize map 1 /* ****************************************************** 2* * * 3* * * 4* * Copyright (c) 1972 by Massachusetts Institute of * 5* * Technology and Honeywell Information Systems, Inc. * 6* * * 7* * * 8* ****************************************************** */ 9 10 apl_system_variables_: 11 procedure (operators_argument); 12 13 /* 14* * this module handles referencing and setting of "system variables," 15* * i.e. variables whose names begin with a Quad. 16* * it also contains code for the monadic ibeams 17* * 18* * written 20 July 1973 and 1 August 1973 by DAM 19* * modified 8/9/73 by DAM to fix bugs. 20* * modified 12/17/73 by PG to fix bugs & add QuadIT. 21* * Modified 740910 by PG for installation. 22* Modified 770415 by PG to cleanup qTT, and add cent-sign to qCS. 23* Modified 771107 by PG to fix 291 (some ibeams weren't returning integers). 24* Modified 771121 by PG to validate op1 before jumping into transfer vector. 25* Modified 781128 by PG to have quote-quad generate a proper value_bead for scalar results. 26* Modified 781129 by PG to use clock and vclock builtins. 27* Modified 790911 by PG to update list of terminal names. 28* Modified 820827 by AD to add comma-hyphen to qCS. 29* */ 30 31 /* automatic */ 32 33 dcl apl_number float, 34 code fixed bin (35), 35 fixnum fixed bin (35), 36 float_temp float, 37 n_words fixed bin (19), 38 result_vb pointer, 39 result pointer, 40 right_vb pointer, 41 data_elements fixed bin (21), 42 iostatus bit (72) aligned, 43 month fixed bin, 44 day fixed bin, 45 year fixed bin, 46 time_of_day fixed bin (71), 47 double_fix fixed bin (71), 48 hour fixed bin, 49 minute fixed bin, 50 second fixed bin, 51 millisecond fixed bin, 52 result_pos fixed bin (21), 53 pass fixed bin, 54 p pointer, 55 tty_name char (32) aligned, 56 type_field bit (18), 57 parse_frame_ptr pointer, /* just to satisfy danb's include file */ 58 rhorho fixed bin, 59 nelemt fixed bin (21), 60 quad_quote_input_buffer 61 char (300) aligned; /* seems about right for maximum length of input line */ 62 63 /* based */ 64 65 declare word_copy_overlay (n_words) fixed bin (35) based; 66 67 /* entries */ 68 69 dcl apl_copy_value_ entry (unaligned pointer, unaligned pointer), 70 apl_free_bead_ entry (unaligned pointer), 71 decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, 72 char (3) aligned), 73 iox_$control entry (ptr, char (*), ptr, fixed bin (35)), 74 iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), 75 system_info_$users entry (fixed bin, fixed bin (35)), 76 apl_get_storage_usage_ 77 entry (fixed bin (35)); 78 79 /* external static */ 80 81 declare (apl_error_table_$bad_assign_to_system_var, apl_error_table_$domain, apl_error_table_$unknown_system_var) 82 fixed bin (35) external static; 83 84 declare apl_static_$apl_input 85 ptr external static; 86 87 /* internal static */ 88 89 dcl microseconds_per_60th 90 float bin (63) internal static initial (16666.66666666666667e0); 91 dcl microseconds_per_millisecond 92 float bin (63) internal static initial (1e3); 93 dcl microseconds_per_second 94 float bin (63) internal static initial (1e6); 95 96 dcl terminal_names (-11:5) char (10) unal internal static 97 init ("LA36", "BITPAIRED", "TYPEPAIRED", "ARDS", "TN300", "Absentee", "1030", "TELERAY11", 98 "ASCII", "TELETYPE", "TEK4013", "", "CORR2741", "2741", "1050", "3270-DAF", "3270"); 99 100 /* builtins */ 101 102 declare (abs, addr, addrel, clock, collate9, currentsize, divide, fixed, float, floor, hbound, lbound, length, null, rel, 103 size, string, substr, vclock) 104 builtin; 105 106 /* include files */ 107 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 ---------------------------------- */ 108 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 -------------------------------------- */ 109 3 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 3 2 3 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 3 4 2 type unaligned, 3 5 3 bead_type unaligned, 3 6 4 operator bit (1), /* ON if operator bead */ 3 7 4 symbol bit (1), /* ON if symbol bead */ 3 8 4 value bit (1), /* ON if value bead */ 3 9 4 function bit (1), /* ON if function bead */ 3 10 4 group bit (1), /* ON if group bead */ 3 11 4 label bit (1), /* ON if label bead */ 3 12 4 shared_variable bit (1), /* ON if shared variable bead */ 3 13 4 lexed_function bit (1), /* ON if lexed function bead */ 3 14 3 data_type unaligned, 3 15 4 list_value bit (1), /* ON if a list value bead */ 3 16 4 character_value bit (1), /* ON if a character value bead */ 3 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 3 18 4 integral_value bit (1), /* ON if an integral value bead */ 3 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 3 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 3 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 3 22 2 size bit (18) unaligned, /* Number of words this bead occupies 3 23* (used by bead storage manager) */ 3 24 2 reference_count fixed binary (29); /* Number of pointers which point 3 25* to this bead (used by bead manager) */ 3 26 3 27 3 28 /* constant strings for initing type field in various beads */ 3 29 3 30 declare ( 3 31 operator_type init("100000000000000000"b), 3 32 symbol_type init("010000000000000000"b), 3 33 value_type init("001000000000000000"b), 3 34 function_type init("000100000000000000"b), 3 35 group_type init("000010000000000000"b), 3 36 label_type init("001001000011000000"b), 3 37 shared_variable_type init("001000100000000000"b), 3 38 lexed_function_type init("000000010000000000"b), 3 39 3 40 list_value_type init("000000001000000000"b), 3 41 character_value_type init("001000000100000000"b), 3 42 numeric_value_type init("001000000010000000"b), 3 43 integral_value_type init("001000000011000000"b), 3 44 zero_or_one_value_type init("001000000011100000"b), 3 45 complex_value_type init("001000000000010000"b), 3 46 3 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 3 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 3 49 ) bit(18) internal static; 3 50 3 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 110 4 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 4 2 4 3 declare 4 4 number_of_dimensions fixed bin, 4 5 4 6 1 value_bead aligned based, 4 7 2 header aligned like general_bead, 4 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 4 9 2 rhorho fixed binary, /* number of dimensions of value */ 4 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 4 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 4 12 /* dimensions of value (zero-origin) */ 4 13 4 14 4 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 4 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 4 17 /* actual elements of character array */ 4 18 4 19 declare character_string_overlay character (data_elements) aligned based; 4 20 /* to overlay on above structure */ 4 21 4 22 4 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 4 24 /* actual elements of numeric array */ 4 25 4 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 4 27 4 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 4 29 4 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 111 5 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 5 2 5 3 declare 1 operators_argument aligned, 5 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 5 5* if operand (1).value is null, operator is monadic */ 5 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 5 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 5 8 2 operator aligned, /* information about the operator to be executed */ 5 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 5 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 5 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 5 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 5 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 5 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 5 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 5 16 5 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 112 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_operator_bead.incl.pl1 ================================ */ 6 2 6 3 declare 6 4 1 operator_bead aligned based, 6 5 6 6 2 type unaligned like general_bead.type, 6 7 6 8 2 bits_for_lex unaligned, 6 9 3 allow_brackets bit(1), /* operator may have dimension info in brackets */ 6 10 3 allow_product bit(1), /* operator may be used in inner and outer product */ 6 11 3 allow_reduction bit(1), /* operator may be used in reduction and scan */ 6 12 3 special_assignment bit(1), /* doesn't use standard assignment operator */ 6 13 3 ignores_assignment bit(1), /* assignment has no effect */ 6 14 3 allow_subscripted_assignment 6 15 bit(1), /* system variable that can be subscripted assigned */ 6 16 3 pad bit(12), 6 17 6 18 2 bits_for_parse unaligned, 6 19 3 stop_trace_control bit(1), /* next lexeme is function being stopped/traced 6 20* (op1 tells which) */ 6 21 3 quad bit(1), /* this is a quad type */ 6 22 3 system_variable bit(1), /* this is a system variable, not an op */ 6 23 3 dyadic bit(1), /* operator may be dyadic */ 6 24 3 monadic bit(1), /* operator may be monadic */ 6 25 3 function bit(1), /* operator is a user defined function */ 6 26 3 semantics_valid bit(1), /* if semantics has been set */ 6 27 3 has_list bit(1), /* semantics is a list */ 6 28 3 inner_product bit(1), /* op2 is valid */ 6 29 3 semantics_on_stack bit(1), /* semantics points to value stack */ 6 30 3 is_external_function bit(1), /* semantics points to function bead for ext function */ 6 31 3 pad bit(7), 6 32 3 op2 fixed bin(8) unaligned, /* secondary operator code */ 6 33 3 op1 fixed bin(8) unaligned, /* primary operator code */ 6 34 2 type_code fixed bin; /* for parse */ 6 35 6 36 /* ------ END INCLUDE SEGMENT apl_operator_bead.incl.pl1 -------------------------------- */ 113 7 1 /* ====== BEGIN INCLUDE SEGMENT apl_parse_frame.incl.pl1 ================================== */ 7 2 7 3 declare 1 parse_frame aligned based (parse_frame_ptr), 7 4 2 last_parse_frame_ptr ptr unaligned, /* pointer to last parse frame, or null */ 7 5 2 parse_frame_type fixed bin, /* suspended, function, eval input, etc. */ 7 6 2 function_bead_ptr ptr unaligned, /* ptr to function bead */ 7 7 2 lexed_function_bead_ptr ptr unaligned, /* ptr to lexed function bead */ 7 8 2 reduction_stack_ptr ptr unaligned, /* ptr to reduction stack for this frame */ 7 9 2 current_parseme fixed bin, /* element of reduction stack that is top of stack */ 7 10 2 current_lexeme fixed bin, /* element number of current lexeme */ 7 11 2 current_line_number fixed bin, /* line number being executed */ 7 12 2 return_point fixed bin, /* where to join the reductions on return */ 7 13 2 put_result fixed bin, /* where to put the value when returning to this frame */ 7 14 2 print_final_value bit(1) aligned, /* if true, print final value on line */ 7 15 2 initial_value_stack_ptr ptr unaligned, /* for cleaning up the value stack */ 7 16 2 number_of_ptrs fixed bin, /* number of old meaning ptrs */ 7 17 2 old_meaning_ptrs dim (number_of_ptrs refer (parse_frame.number_of_ptrs)) ptr unaligned; 7 18 /* old meanings for local variables. */ 7 19 7 20 declare number_of_ptrs fixed bin; 7 21 7 22 declare (suspended_frame_type init (1), /* for comparison with parse frame type */ 7 23 function_frame_type init (2), 7 24 evaluated_frame_type init (3), 7 25 execute_frame_type init (4), 7 26 save_frame_type init (5) 7 27 ) fixed bin internal static options (constant); 7 28 7 29 declare reductions_pointer pointer; 7 30 7 31 declare 7 32 1 reduction_stack aligned dim (1000) based (reductions_pointer), 7 33 2 type fixed bin, /* type of parseme */ 7 34 2 bits unaligned like operator_bead.bits_for_parse, 7 35 2 semantics ptr unaligned, 7 36 2 lexeme fixed bin, 7 37 7 38 1 reduction_stack_for_op aligned dim (1000) based (reductions_pointer), 7 39 2 type fixed bin, 7 40 2 bits unaligned like operator_bead.bits_for_parse, 7 41 2 semantics fixed bin, 7 42 2 lexeme fixed bin, 7 43 7 44 (eol_type init(0), /* parseme types - end of line */ 7 45 bol_type init(1), /* begining of line */ 7 46 val_type init(2), /* value */ 7 47 op_type init(3), /* op */ 7 48 open_paren_type init(4), 7 49 close_paren_type init(5), 7 50 open_bracket_type init(6), 7 51 close_subscript_type init(7), 7 52 close_rank_type init(8), 7 53 semi_colon_type init(9), 7 54 diamond_type init (10), 7 55 subscript_type init (11)) fixed bin internal static options (constant); 7 56 7 57 /* ------ END INCLUDE SEGMENT apl_parse_frame.incl.pl1 ---------------------------------- */ 114 115 116 if operators_argument.op1 >= lbound (set, 1) & operators_argument.op1 <= hbound (set, 1) 117 then go to set (operators_argument.op1); 118 else if operators_argument.op1 >= lbound (get, 1) & operators_argument.op1 <= hbound (get, 1) 119 then go to get (operators_argument.op1); 120 else go to system_error; 121 122 get (2): /* QuadCT - get the fuzz */ 123 apl_number = ws_info.fuzz; 124 go to return_apl_number; 125 126 127 set (106): /* QuadCT - set the fuzz */ 128 call get_scalar_float; 129 if apl_number < 0 130 then go to domain_error; 131 else if apl_number > 1 132 then go to domain_error; 133 ws_info.fuzz = apl_number; 134 return; /* parse knows that assign operators return their operand */ 135 136 get (3): /* QuadIO - get the index origin */ 137 fixnum = ws_info.index_origin; 138 go to return_fixnum; 139 140 set (107): /* QuadIO - set the index origin */ 141 call get_scalar_fix; 142 if fixnum ^= 0 143 then if fixnum ^= 1 144 then go to domain_error; 145 ws_info.index_origin = fixnum; 146 ws_info.float_index_origin = float (fixnum); 147 return; 148 149 get (4): /* QuadLX - get the latent expression */ 150 n_words = fixed (ws_info.latent_expression -> value_bead.size); 151 result_vb = apl_push_stack_ (n_words); 152 result_vb -> word_copy_overlay (*) = ws_info.latent_expression -> word_copy_overlay (*); 153 result = addrel (result_vb, currentsize (result_vb -> value_bead)); 154 result_vb -> value_bead.data_pointer = result; 155 operators_argument.result = result_vb; 156 return; 157 158 set (108): /* set the latent expression */ 159 if operands (2).value -> value_bead.character_value 160 then ; 161 else go to domain_error; 162 if operands (2).value -> value_bead.rhorho <= 1 163 then ; 164 else go to domain_error; 165 166 ws_info.latent_expression -> value_bead.reference_count = 167 ws_info.latent_expression -> value_bead.reference_count - 1; 168 if ws_info.latent_expression -> value_bead.reference_count = 0 169 then call apl_free_bead_ (ws_info.latent_expression); 170 call apl_copy_value_ (operands (2).value, ws_info.latent_expression); 171 return; 172 173 174 175 get (5): /* QuadPP - get printing-precision */ 176 fixnum = ws_info.digits; 177 go to return_fixnum; 178 179 180 set (109): /* QuadPP - set printing-precision */ 181 call get_scalar_fix; 182 if fixnum < 1 183 then go to domain_error; 184 else if fixnum > 19 185 then go to domain_error; 186 ws_info.digits = fixnum; 187 return; 188 189 get (6): /* QuadPW - get print width */ 190 fixnum = ws_info.width; 191 go to return_fixnum; 192 193 set (110): /* QuadPW - set print width */ 194 call get_scalar_fix; 195 if fixnum < 30 196 then go to domain_error; 197 else if fixnum > 390 198 then go to domain_error; 199 ws_info.width = fixnum; 200 return; 201 202 get (7): /* QuadRL - get random link */ 203 fixnum = ws_info.random_link; 204 go to return_fixnum; 205 206 207 set (111): /* QuadRL - set random link */ 208 call get_scalar_fix; 209 if fixnum < 0 210 then go to domain_error; 211 ws_info.random_link = fixnum; 212 return; 213 214 get (8): /* QuadAI - get accounting info */ 215 data_elements = 4; 216 call set_vector; 217 218 result -> numeric_datum (0) = float (ws_info.user_number); 219 result -> numeric_datum (1) = float (vclock ()) / microseconds_per_millisecond; 220 result -> numeric_datum (2) = float (clock () - time_invoked) / microseconds_per_millisecond; 221 call iox_$control (apl_static_$apl_input, "get_keying_time", addr (double_fix), code); 222 if code ^= 0 223 then double_fix = 0; 224 result -> numeric_datum (3) = float (double_fix) / microseconds_per_millisecond; 225 return; 226 227 get (16): /* QuadIT - get the integer tolerance (integer fuzz) */ 228 apl_number = ws_info.integer_fuzz; 229 go to return_apl_number; 230 231 232 set (120): /* QuadIT - set the integer tolerance (integer fuzz) */ 233 call get_scalar_float; 234 if apl_number < 0 | apl_number > 1 235 then go to domain_error; 236 237 ws_info.integer_fuzz = apl_number; 238 return; 239 240 241 /* ibeams that do similar things */ 242 243 ibeam (29): /* user number */ 244 fixnum = ws_info.user_number; 245 go to return_fixnum; 246 247 ibeam (21): /* cpu time */ 248 fixnum = float (vclock ()) / microseconds_per_60th; 249 go to return_fixnum; 250 251 ibeam (24): /* sign-on time */ 252 call decode_clock_value_ (time_invoked, month, day, year, time_of_day, (0), ("")); 253 fixnum = float (time_of_day) / microseconds_per_60th; 254 go to return_fixnum; 255 256 ibeam (20): /* time of day */ 257 call compute_time; 258 fixnum = float (time_of_day) / microseconds_per_60th; 259 go to return_fixnum; 260 261 ibeam (19): /* keying time */ 262 call iox_$control (apl_static_$apl_input, "get_keying_time", addr (double_fix), code); 263 if code ^= 0 264 then double_fix = 0; 265 fixnum = float (double_fix) / microseconds_per_60th; 266 go to return_fixnum; 267 268 ibeam (27): 269 get (9): /* QuadLC - get the state indicator as a vector */ 270 data_elements = 0; 271 result_pos = 0; 272 do pass = 1 to 2; /* first pass computes size of result, second makes it */ 273 274 do p = current_parse_frame_ptr repeat p -> parse_frame.last_parse_frame_ptr while (p ^= null); 275 276 if p -> parse_frame.parse_frame_type = function_frame_type 277 then if pass = 1 278 then data_elements = data_elements + 1; 279 else do; 280 281 result -> numeric_datum (result_pos) = float (p -> parse_frame.current_line_number); 282 result_pos = result_pos + 1; 283 end; 284 else if p -> parse_frame.parse_frame_type = execute_frame_type 285 | p -> parse_frame.parse_frame_type = evaluated_frame_type 286 then if pass = 1 287 then data_elements = data_elements + 1; 288 else do; /* put in a zero for evaluated input and execute */ 289 result -> numeric_datum (result_pos) = 0; 290 result_pos = result_pos + 1; 291 end; 292 else ; /* other types of frames are simply ignored */ 293 end; 294 295 if pass = 1 296 then do; 297 call set_vector; /* at end of first pass, set up vector to be filled on second */ 298 string (result_vb -> value_bead.type) = integral_value_type; 299 end; 300 end; 301 return; 302 303 ibeam (26): 304 do p = current_parse_frame_ptr repeat p -> parse_frame.last_parse_frame_ptr while (p ^= null); 305 if p -> parse_frame.parse_frame_type = function_frame_type 306 then do; 307 fixnum = p -> parse_frame.current_line_number; 308 go to return_fixnum; 309 end; 310 311 else if p -> parse_frame.parse_frame_type = execute_frame_type 312 | p -> parse_frame.parse_frame_type = evaluated_frame_type 313 then do; 314 fixnum = 0; 315 go to return_fixnum; 316 end; 317 318 else ; /* other types of frames are skipped over */ 319 end; 320 fixnum = 0; 321 go to return_fixnum; 322 323 ibeam (25): 324 call compute_time; 325 fixnum = month * 10000 + day * 100 + year; 326 go to return_fixnum; 327 328 get (10): /* QuadTS - get the "time stamp:" y m d h m s ms */ 329 data_elements = 7; 330 call set_vector; 331 string (result_vb -> value_bead.type) = integral_value_type; 332 call compute_time; 333 334 result -> numeric_datum (0) = float (year); 335 result -> numeric_datum (1) = float (month); 336 result -> numeric_datum (2) = float (day); 337 result -> numeric_datum (3) = float (hour); 338 result -> numeric_datum (4) = float (minute); 339 result -> numeric_datum (5) = float (second); 340 result -> numeric_datum (6) = float (millisecond); 341 return; 342 343 ibeam (28): 344 get (11): /* QuadTT - get terminal type */ 345 call iox_$control (apl_static_$apl_input, "get_device_type", addr (tty_name), code); 346 if code ^= 0 /* not apl dim... */ 347 then tty_name = "Absentee"; /* we should probably check... */ 348 349 /* Return index of name in the array. Note that we just return 350* hbound+1 if the names is not found. */ 351 352 do fixnum = lbound (terminal_names, 1) to hbound (terminal_names, 1) while (terminal_names (fixnum) ^= tty_name); 353 end; 354 go to return_fixnum; 355 356 357 358 get (12): /* QuadUL - get the User Load */ 359 ibeam (23): 360 call system_info_$users ((0), fixnum); 361 go to return_fixnum; 362 363 get (13): /* QuadWA - the amount of workspace available */ 364 /* for now, this is infinity */ 365 apl_number = TheBiggestNumberWeveGot; 366 go to return_apl_number; 367 368 ibeam (22): /* workspace available */ 369 fixnum = 11111111111111111111111111111111111b; /* largest single precision fixed point number */ 370 go to return_fixnum; 371 372 373 get (15): /* QuadCS - the character set. Presently we return the 196 characters */ 374 data_elements = 196; 375 number_of_dimensions = 1; 376 n_words = size (value_bead) + size (character_string_overlay); 377 result_vb = apl_push_stack_ (n_words); 378 result = addr (result_vb -> value_bead.rho (2)); 379 string (result_vb -> value_bead.type) = character_value_type; 380 result_vb -> value_bead.total_data_elements, result_vb -> value_bead.rho (1) = 196; 381 result_vb -> value_bead.rhorho = 1; 382 result_vb -> value_bead.data_pointer = result; 383 operators_argument.result = result_vb; 384 result -> character_string_overlay = substr (collate9, 1, 196); 385 return; 386 387 get (14): /* QuadWU - return number of characters of workspace used */ 388 call apl_get_storage_usage_ (fixnum); 389 fixnum = 4 * fixnum; /* convert from words to characters */ 390 go to return_fixnum; 391 392 get (1): /* QuadQuote input */ 393 /* at present there is no prompt string for quad - quote input */ 394 ws_info.can_be_interrupted = "1"b; 395 call iox_$get_line (apl_static_$apl_input, addr (quad_quote_input_buffer), length (quad_quote_input_buffer), nelemt, 396 0); 397 ws_info.can_be_interrupted = "0"b; 398 /* if there is any OTU (O bs U bs T) feature, it is in the dim so don't worry about it */ 399 400 /* construct value bead to return */ 401 402 data_elements = nelemt - 1; 403 404 if data_elements = 1 405 then number_of_dimensions = 0; 406 else number_of_dimensions = 1; 407 408 n_words = size (value_bead) + size (character_string_overlay); 409 result_vb = apl_push_stack_ (n_words); 410 string (result_vb -> value_bead.type) = character_value_type; 411 result_vb -> value_bead.total_data_elements = data_elements; 412 result_vb -> value_bead.rhorho = number_of_dimensions; 413 414 if data_elements ^= 1 415 then result_vb -> value_bead.rho (1) = data_elements; 416 417 result = addrel (result_vb, size (value_bead)); 418 result_vb -> value_bead.data_pointer = result; 419 result -> character_string_overlay = addr (quad_quote_input_buffer) -> character_string_overlay; 420 operators_argument.result = result_vb; 421 return; 422 423 return_fixnum: 424 type_field = integral_value_type; 425 apl_number = float (fixnum); 426 go to scalar_return; 427 428 return_apl_number: 429 type_field = numeric_value_type; 430 431 scalar_return: 432 rhorho = 0; 433 data_elements = 1; 434 call prepare_result; 435 result -> numeric_datum (0) = apl_number; 436 return; 437 438 domain_error_ibeam: 439 operators_argument.where_error = operators_argument.where_error - 1; 440 /* mark right arg */ 441 operators_argument.error_code = apl_error_table_$domain; 442 return; 443 444 domain_error: 445 operators_argument.where_error = operators_argument.where_error - 1; 446 /* put marker on value being assigned 447* to this system variable */ 448 operators_argument.error_code = apl_error_table_$bad_assign_to_system_var; 449 return; 450 451 system_error: 452 operators_argument.error_code = apl_error_table_$unknown_system_var; 453 return; 454 455 /*** enter here for monadic ibeams ***/ 456 457 apl_ibeam_: 458 entry (operators_argument); 459 460 right_vb = operands (2).value; 461 if ^right_vb -> value_bead.data_type.numeric_value 462 then go to domain_error_ibeam; 463 if ^(right_vb -> value_bead.total_data_elements = 1) 464 then go to domain_error_ibeam; 465 466 if right_vb -> value_bead.data_type.integral_value 467 then float_temp = right_vb -> value_bead.data_pointer -> numeric_datum (0); 468 else do; 469 float_temp = floor (right_vb -> value_bead.data_pointer -> numeric_datum (0) + 0.5); 470 if abs (float_temp - right_vb -> value_bead.data_pointer -> numeric_datum (0)) > integer_fuzz 471 then go to domain_error_ibeam; 472 end; 473 if abs (float_temp) >= 1e21b 474 then go to domain_error_ibeam; 475 fixnum = fixed (float_temp, 21); 476 477 if fixnum < 19 478 then go to domain_error_ibeam; 479 else if fixnum > 29 480 then go to domain_error_ibeam; 481 482 go to ibeam (fixnum); /* dispatch into code above */ 483 484 /* internal procedures */ 485 486 compute_time: 487 procedure (); 488 489 call decode_clock_value_ (clock (), month, day, year, time_of_day, (0), ("")); 490 year = year - 1900; 491 second = float (time_of_day, 52) / microseconds_per_second; 492 /* no precision will be lost in flt divide */ 493 millisecond = float (time_of_day - second * 1000000, 52) / microseconds_per_millisecond; 494 hour = divide (second, 3600, 5, 0); 495 second = second - 3600 * hour; 496 minute = divide (second, 60, 6, 0); 497 second = second - 60 * minute; 498 return; 499 500 end compute_time; 501 502 get_scalar_fix: 503 procedure (); 504 505 call get_scalar_float; 506 if operands (2).value -> value_bead.data_type.integral_value 507 then float_temp = apl_number; 508 else do; 509 float_temp = floor (apl_number + 0.5); 510 if abs (float_temp - apl_number) > integer_fuzz 511 then go to domain_error; 512 end; 513 514 if abs (float_temp) >= 1e35b 515 then go to domain_error; 516 fixnum = fixed (float_temp, 35); 517 return; 518 519 end get_scalar_fix; 520 521 get_scalar_float: 522 procedure (); 523 524 if ^(operands (2).value -> value_bead.total_data_elements = 1) 525 then go to domain_error; 526 527 apl_number = operands (2).value -> value_bead.data_pointer -> numeric_datum (0); 528 return; 529 530 end get_scalar_float; 531 532 prepare_result: 533 procedure (); 534 535 number_of_dimensions = rhorho; 536 n_words = size (value_bead) + size (numeric_datum) + 1; 537 result_vb = apl_push_stack_ (n_words); 538 operators_argument.result = result_vb; 539 string (result_vb -> value_bead.type) = type_field; 540 result_vb -> value_bead.total_data_elements = data_elements; 541 result_vb -> value_bead.rhorho = rhorho; 542 result = addrel (result_vb, size (value_bead)); 543 if substr (rel (result), 18, 1) 544 then result = addrel (result, 1); 545 546 result_vb -> value_bead.data_pointer = result; 547 return; 548 549 end prepare_result; 550 551 set_vector: 552 procedure (); 553 554 type_field = numeric_value_type; 555 rhorho = 1; 556 call prepare_result; 557 result_vb -> value_bead.rho (1) = data_elements; 558 return; 559 560 end set_vector; 561 8 1 /* ====== BEGIN INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 =============================== */ 8 2 8 3 /* format: style3 */ 8 4 apl_push_stack_: 8 5 procedure (P_n_words) returns (ptr); 8 6 8 7 /* Function to (1) double-word align ws_info.value_stack_ptr, and 8 8* (2) make sure allocation request will fit on current value stack. 8 9* 8 10* Written 770413 by PG 8 11* Modified 780210 by PG to round allocations up to an even number of words. 8 12**/ 8 13 8 14 /* parameters */ 8 15 8 16 declare P_n_words fixed bin (19) parameter; 8 17 8 18 /* automatic */ 8 19 8 20 declare block_ptr ptr, 8 21 num_words fixed bin (19); 8 22 8 23 /* builtins */ 8 24 8 25 declare (addrel, binary, rel, substr, unspec) 8 26 builtin; 8 27 8 28 /* entries */ 8 29 8 30 declare apl_get_value_stack_ 8 31 entry (fixed bin (19)); 8 32 8 33 /* program */ 8 34 8 35 num_words = P_n_words; 8 36 8 37 if substr (unspec (num_words), 36, 1) = "1"b /* num_words odd */ 8 38 then num_words = num_words + 1; 8 39 8 40 if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size 8 41 then call apl_get_value_stack_ (num_words); 8 42 8 43 block_ptr = ws_info.value_stack_ptr; 8 44 ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words); 8 45 return (block_ptr); 8 46 8 47 end apl_push_stack_; 8 48 8 49 /* ------ END INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 ------------------------------- */ 562 563 end /* apl_system_variables_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1347.3 apl_system_variables_.pl1 >special_ldd>on>apl.1129>apl_system_variables_.pl1 108 1 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 109 2 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 110 3 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 111 4 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 112 5 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 113 6 03/27/82 0439.0 apl_operator_bead.incl.pl1 >ldd>include>apl_operator_bead.incl.pl1 114 7 03/27/82 0439.0 apl_parse_frame.incl.pl1 >ldd>include>apl_parse_frame.incl.pl1 562 8 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 8-16 ref 8-4 8-35 TheBiggestNumberWeveGot 000052 constant float bin(63) initial dcl 1-16 ref 363 abs builtin function dcl 102 ref 470 473 510 514 addr builtin function dcl 102 ref 221 221 261 261 343 343 378 395 395 419 addrel builtin function dcl 102 in procedure "apl_system_variables_" ref 153 417 542 543 addrel builtin function dcl 8-25 in procedure "apl_push_stack_" ref 8-44 apl_copy_value_ 000010 constant entry external dcl 69 ref 170 apl_error_table_$bad_assign_to_system_var 000026 external static fixed bin(35,0) dcl 81 ref 448 apl_error_table_$domain 000030 external static fixed bin(35,0) dcl 81 ref 441 apl_error_table_$unknown_system_var 000032 external static fixed bin(35,0) dcl 81 ref 451 apl_free_bead_ 000012 constant entry external dcl 69 ref 168 apl_get_storage_usage_ 000024 constant entry external dcl 69 ref 387 apl_get_value_stack_ 000040 constant entry external dcl 8-30 ref 8-40 apl_number 000100 automatic float bin(63) dcl 33 set ref 122* 129 131 133 227* 234 234 237 363* 425* 435 506 509 510 527* apl_static_$apl_input 000034 external static pointer dcl 84 set ref 221* 261* 343* 395* apl_static_$ws_info_ptr 000036 external static structure level 1 dcl 2-11 binary builtin function dcl 8-25 ref 8-40 bits_for_parse 1 based structure level 2 packed unaligned dcl 6-3 block_ptr 000334 automatic pointer dcl 8-20 set ref 8-43* 8-45 can_be_interrupted 105 based bit(1) level 3 dcl 2-16 set ref 392* 397* character_string_overlay based char dcl 4-19 set ref 376 384* 408 419* 419 character_value 0(09) based bit(1) level 5 packed unaligned dcl 4-3 set ref 158 character_value_type constant bit(18) initial unaligned dcl 3-30 ref 379 410 clock builtin function dcl 102 ref 220 489 489 code 000102 automatic fixed bin(35,0) dcl 33 set ref 221* 222 261* 263 343* 346 collate9 builtin function dcl 102 ref 384 current_line_number 7 based fixed bin(17,0) level 2 dcl 7-3 ref 281 307 current_parse_frame_ptr 15 based pointer level 3 packed unaligned dcl 2-16 ref 274 303 currentsize builtin function dcl 102 ref 153 data_elements 000116 automatic fixed bin(21,0) dcl 33 set ref 214* 268* 276* 276 284* 284 328* 373* 376 376 384 402* 404 408 408 411 414 414 419 419 433* 536 540 557 data_pointer 4 based pointer level 2 packed unaligned dcl 4-3 set ref 154* 382* 418* 466 469 470 527 546* data_type 0(08) based structure level 4 packed unaligned dcl 4-3 day 000120 automatic fixed bin(17,0) dcl 33 set ref 251* 325 336 489* decode_clock_value_ 000014 constant entry external dcl 69 ref 251 489 digits 2 based fixed bin(17,0) level 3 dcl 2-16 set ref 175 186* divide builtin function dcl 102 ref 494 496 double_fix 000124 automatic fixed bin(71,0) dcl 33 set ref 221 221 222* 224 261 261 263* 265 error_code 7 parameter fixed bin(35,0) level 2 dcl 5-3 set ref 441* 448* 451* evaluated_frame_type constant fixed bin(17,0) initial dcl 7-22 ref 284 311 execute_frame_type constant fixed bin(17,0) initial dcl 7-22 ref 284 311 fixed builtin function dcl 102 ref 149 475 516 fixnum 000103 automatic fixed bin(35,0) dcl 33 set ref 136* 142 142 145 146 175* 182 184 186 189* 195 197 199 202* 209 211 243* 247* 253* 258* 265* 307* 314* 320* 325* 352* 352* 358* 368* 387* 389* 389 425 475* 477 479 482 516* float builtin function dcl 102 ref 146 218 219 220 224 247 253 258 265 281 334 335 336 337 338 339 340 425 491 493 float_index_origin 10 based float bin(63) level 3 dcl 2-16 set ref 146* float_temp 000104 automatic float bin(63) dcl 33 set ref 466* 469* 470 473 475 506* 509* 510 514 516 floor builtin function dcl 102 ref 469 509 function_frame_type constant fixed bin(17,0) initial dcl 7-22 ref 276 305 fuzz 6 based float bin(63) level 3 dcl 2-16 set ref 122 133* general_bead based structure level 1 dcl 3-3 hbound builtin function dcl 102 ref 116 118 352 header based structure level 2 dcl 4-3 hour 000126 automatic fixed bin(17,0) dcl 33 set ref 337 494* 495 index_origin 4 based fixed bin(17,0) level 3 dcl 2-16 set ref 136 145* integer_fuzz 22 based float bin(63) level 2 dcl 2-16 set ref 227 237* 470 510 integral_value 0(11) based bit(1) level 5 packed unaligned dcl 4-3 set ref 466 506 integral_value_type constant bit(18) initial unaligned dcl 3-30 ref 298 331 423 interrupt_info 100 based structure level 2 dcl 2-16 iox_$control 000016 constant entry external dcl 69 ref 221 261 343 iox_$get_line 000020 constant entry external dcl 69 ref 395 last_parse_frame_ptr based pointer level 2 packed unaligned dcl 7-3 ref 293 319 latent_expression 25 based pointer level 2 packed unaligned dcl 2-16 set ref 149 152 166 166 168 168* 170* lbound builtin function dcl 102 ref 116 118 352 length builtin function dcl 102 ref 395 395 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 2-16 ref 8-40 microseconds_per_60th 000134 constant float bin(63) initial dcl 89 ref 247 253 258 265 microseconds_per_millisecond 000132 constant float bin(63) initial dcl 91 ref 219 220 224 493 microseconds_per_second 000130 constant float bin(63) initial dcl 93 ref 491 millisecond 000131 automatic fixed bin(17,0) dcl 33 set ref 340 493* minute 000127 automatic fixed bin(17,0) dcl 33 set ref 338 496* 497 month 000117 automatic fixed bin(17,0) dcl 33 set ref 251* 325 335 489* n_words 000106 automatic fixed bin(19,0) dcl 33 set ref 149* 151* 152 376* 377* 408* 409* 536* 537* nelemt 000150 automatic fixed bin(21,0) dcl 33 set ref 395* 402 null builtin function dcl 102 ref 274 303 num_words 000336 automatic fixed bin(19,0) dcl 8-20 set ref 8-35* 8-37 8-37* 8-37 8-40 8-40* 8-44 number_of_dimensions 000266 automatic fixed bin(17,0) dcl 4-3 set ref 375* 376 404* 406* 408 412 417 535* 536 542 numeric_datum based float bin(63) array dcl 4-23 set ref 218* 219* 220* 224* 281* 289* 334* 335* 336* 337* 338* 339* 340* 435* 466 469 470 527 536 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 4-3 set ref 461 numeric_value_type constant bit(18) initial unaligned dcl 3-30 ref 428 554 op1 5(27) parameter fixed bin(8,0) level 3 packed unaligned dcl 5-3 ref 116 116 116 118 118 118 operands parameter structure array level 2 dcl 5-3 operator 4 parameter structure level 2 dcl 5-3 operator_bead based structure level 1 dcl 6-3 operators_argument parameter structure level 1 dcl 5-3 set ref 10 457 p 000134 automatic pointer dcl 33 set ref 274* 274* 276 281 284 284* 293 303* 303* 305 307 311 311* 319 parse_frame based structure level 1 dcl 7-3 parse_frame_type 1 based fixed bin(17,0) level 2 dcl 7-3 ref 276 284 284 305 311 311 pass 000133 automatic fixed bin(17,0) dcl 33 set ref 272* 276 284 295* pointers 14 based structure level 2 dcl 2-16 quad_quote_input_buffer 000151 automatic char(300) dcl 33 set ref 395 395 395 395 419 random_link 5 based fixed bin(35,0) level 3 dcl 2-16 set ref 202 211* reference_count 1 based fixed bin(29,0) level 3 dcl 4-3 set ref 166* 166 168 rel builtin function dcl 102 in procedure "apl_system_variables_" ref 543 rel builtin function dcl 8-25 in procedure "apl_push_stack_" ref 8-40 result 000112 automatic pointer dcl 33 in procedure "apl_system_variables_" set ref 153* 154 218 219 220 224 281 289 334 335 336 337 338 339 340 378* 382 384 417* 418 419 435 542* 543 543* 543 546 result 6 parameter pointer level 2 in structure "operators_argument" packed unaligned dcl 5-3 in procedure "apl_system_variables_" set ref 155* 383* 420* 538* result_pos 000132 automatic fixed bin(21,0) dcl 33 set ref 271* 281 282* 282 289 290* 290 result_vb 000110 automatic pointer dcl 33 set ref 151* 152 153 153 154 155 298 331 377* 378 379 380 380 381 382 383 409* 410 411 412 414 417 418 420 537* 538 539 540 541 542 546 557 rho 5 based fixed bin(21,0) array level 2 dcl 4-3 set ref 378 380* 414* 557* rhorho 000147 automatic fixed bin(17,0) dcl 33 in procedure "apl_system_variables_" set ref 431* 535 541 555* rhorho 3 based fixed bin(17,0) level 2 in structure "value_bead" dcl 4-3 in procedure "apl_system_variables_" set ref 153 162 381* 412* 541* right_vb 000114 automatic pointer dcl 33 set ref 460* 461 463 466 466 469 470 second 000130 automatic fixed bin(17,0) dcl 33 set ref 339 491* 493 494 495* 495 496 497* 497 size builtin function dcl 102 in procedure "apl_system_variables_" ref 376 376 408 408 417 536 536 542 size 0(18) based bit(18) level 3 in structure "value_bead" packed unaligned dcl 4-3 in procedure "apl_system_variables_" ref 149 static_ws_info_ptr 000036 external static pointer level 2 packed unaligned dcl 2-11 ref 2-7 string builtin function dcl 102 set ref 298* 331* 379* 410* 539* substr builtin function dcl 8-25 in procedure "apl_push_stack_" ref 8-37 substr builtin function dcl 102 in procedure "apl_system_variables_" ref 384 543 system_info_$users 000022 constant entry external dcl 69 ref 358 terminal_names 000054 constant char(10) initial array unaligned dcl 96 ref 352 352 352 time_invoked 20 based fixed bin(71,0) level 2 dcl 2-16 set ref 220 251* time_of_day 000122 automatic fixed bin(71,0) dcl 33 set ref 251* 253 258 489* 491 493 total_data_elements 2 based fixed bin(21,0) level 2 dcl 4-3 set ref 380* 411* 463 524 540* tty_name 000136 automatic char(32) dcl 33 set ref 343 343 346* 352 type based structure level 2 in structure "general_bead" packed unaligned dcl 3-3 in procedure "apl_system_variables_" type based structure level 3 in structure "value_bead" packed unaligned dcl 4-3 in procedure "apl_system_variables_" set ref 298* 331* 379* 410* 539* type_field 000146 automatic bit(18) unaligned dcl 33 set ref 423* 428* 539 554* unspec builtin function dcl 8-25 ref 8-37 user_number 24 based fixed bin(35,0) level 2 dcl 2-16 ref 218 243 value parameter pointer array level 3 packed unaligned dcl 5-3 set ref 158 162 170* 460 506 524 527 value_bead based structure level 1 dcl 4-3 set ref 153 376 408 417 536 542 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 2-16 set ref 8-40 8-43 8-44* 8-44 values 2 based structure level 2 dcl 2-16 vclock builtin function dcl 102 ref 219 247 where_error 10 parameter fixed bin(17,0) level 2 dcl 5-3 set ref 438* 438 444* 444 width 3 based fixed bin(17,0) level 3 dcl 2-16 set ref 189 199* word_copy_overlay based fixed bin(35,0) array dcl 65 set ref 152* 152 ws_info based structure level 1 dcl 2-16 ws_info_ptr 000264 automatic pointer initial dcl 2-7 set ref 122 133 136 145 146 149 152 166 166 168 168 170 175 186 189 199 202 211 218 220 227 237 243 251 274 303 392 397 470 2-7* 510 8-40 8-40 8-43 8-44 8-44 year 000121 automatic fixed bin(17,0) dcl 33 set ref 251* 325 334 489* 490* 490 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Binary internal static bit(1) initial dcl 1-16 MAX_VALUE_BEAD_SIZE internal static fixed bin(19,0) initial dcl 4-28 NumberSize internal static fixed bin(4,0) initial dcl 1-25 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 1-16 bol_type internal static fixed bin(17,0) initial dcl 7-31 character_data_structure based structure level 1 dcl 4-15 close_paren_type internal static fixed bin(17,0) initial dcl 7-31 close_rank_type internal static fixed bin(17,0) initial dcl 7-31 close_subscript_type internal static fixed bin(17,0) initial dcl 7-31 complex_datum based complex float bin(63) array dcl 4-26 complex_value_type internal static bit(18) initial unaligned dcl 3-30 diamond_type internal static fixed bin(17,0) initial dcl 7-31 eol_type internal static fixed bin(17,0) initial dcl 7-31 function_type internal static bit(18) initial unaligned dcl 3-30 group_type internal static bit(18) initial unaligned dcl 3-30 iostatus automatic bit(72) dcl 33 label_type internal static bit(18) initial unaligned dcl 3-30 lexed_function_type internal static bit(18) initial unaligned dcl 3-30 list_value_type internal static bit(18) initial unaligned dcl 3-30 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 2-98 not_integer_mask internal static bit(18) initial unaligned dcl 3-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 3-30 number_of_ptrs automatic fixed bin(17,0) dcl 7-20 op_type internal static fixed bin(17,0) initial dcl 7-31 open_bracket_type internal static fixed bin(17,0) initial dcl 7-31 open_paren_type internal static fixed bin(17,0) initial dcl 7-31 operator_type internal static bit(18) initial unaligned dcl 3-30 output_buffer based char unaligned dcl 2-94 parse_frame_ptr automatic pointer dcl 33 reduction_stack based structure array level 1 dcl 7-31 reduction_stack_for_op based structure array level 1 dcl 7-31 reductions_pointer automatic pointer dcl 7-29 save_frame_type internal static fixed bin(17,0) initial dcl 7-22 semi_colon_type internal static fixed bin(17,0) initial dcl 7-31 shared_variable_type internal static bit(18) initial unaligned dcl 3-30 subscript_type internal static fixed bin(17,0) initial dcl 7-31 suspended_frame_type internal static fixed bin(17,0) initial dcl 7-22 symbol_type internal static bit(18) initial unaligned dcl 3-30 val_type internal static fixed bin(17,0) initial dcl 7-31 value_type internal static bit(18) initial unaligned dcl 3-30 zero_or_one_value_type internal static bit(18) initial unaligned dcl 3-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_ibeam_ 001640 constant entry external dcl 457 apl_push_stack_ 002142 constant entry internal dcl 8-4 ref 151 377 409 537 apl_system_variables_ 000424 constant entry external dcl 10 compute_time 001721 constant entry internal dcl 486 ref 256 323 332 domain_error 001620 constant label dcl 444 ref 129 131 142 158 162 182 184 195 197 209 234 510 514 524 domain_error_ibeam 001610 constant label dcl 438 ref 461 463 470 473 477 479 get 000000 constant label array(16) dcl 122 ref 118 118 118 get_scalar_fix 002011 constant entry internal dcl 502 ref 140 180 193 207 get_scalar_float 002051 constant entry internal dcl 521 ref 127 232 505 ibeam 000037 constant label array(19:29) dcl 243 set ref 482 prepare_result 002064 constant entry internal dcl 532 ref 434 556 return_apl_number 001577 constant label dcl 428 set ref 124 229 366 return_fixnum 001571 constant label dcl 423 ref 138 177 191 204 245 249 254 259 266 308 315 321 326 354 361 370 390 scalar_return 001601 constant label dcl 431 ref 426 set 000020 constant label array(106:120) dcl 127 ref 116 116 116 set_vector 002130 constant entry internal dcl 551 ref 216 297 330 system_error 001630 constant label dcl 451 ref 120 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 2422 2464 2214 2432 Length 3046 2214 42 345 206 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_system_variables_ 288 external procedure is an external procedure. compute_time internal procedure shares stack frame of external procedure apl_system_variables_. get_scalar_fix internal procedure shares stack frame of external procedure apl_system_variables_. get_scalar_float internal procedure shares stack frame of external procedure apl_system_variables_. prepare_result internal procedure shares stack frame of external procedure apl_system_variables_. set_vector internal procedure shares stack frame of external procedure apl_system_variables_. apl_push_stack_ internal procedure shares stack frame of external procedure apl_system_variables_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_system_variables_ 000100 apl_number apl_system_variables_ 000102 code apl_system_variables_ 000103 fixnum apl_system_variables_ 000104 float_temp apl_system_variables_ 000106 n_words apl_system_variables_ 000110 result_vb apl_system_variables_ 000112 result apl_system_variables_ 000114 right_vb apl_system_variables_ 000116 data_elements apl_system_variables_ 000117 month apl_system_variables_ 000120 day apl_system_variables_ 000121 year apl_system_variables_ 000122 time_of_day apl_system_variables_ 000124 double_fix apl_system_variables_ 000126 hour apl_system_variables_ 000127 minute apl_system_variables_ 000130 second apl_system_variables_ 000131 millisecond apl_system_variables_ 000132 result_pos apl_system_variables_ 000133 pass apl_system_variables_ 000134 p apl_system_variables_ 000136 tty_name apl_system_variables_ 000146 type_field apl_system_variables_ 000147 rhorho apl_system_variables_ 000150 nelemt apl_system_variables_ 000151 quad_quote_input_buffer apl_system_variables_ 000264 ws_info_ptr apl_system_variables_ 000266 number_of_dimensions apl_system_variables_ 000334 block_ptr apl_push_stack_ 000336 num_words apl_push_stack_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 call_ext_out_desc call_ext_out return fl2_to_fx1 ext_entry floor_fl clock vclock THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_copy_value_ apl_free_bead_ apl_get_storage_usage_ apl_get_value_stack_ decode_clock_value_ iox_$control iox_$get_line system_info_$users THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. apl_error_table_$bad_assign_to_system_var apl_error_table_$domain apl_error_table_$unknown_system_var apl_static_$apl_input apl_static_$ws_info_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 2 7 000414 10 000421 116 000432 118 000446 120 000454 122 000455 124 000460 127 000461 129 000462 131 000464 133 000467 134 000472 136 000473 138 000476 140 000477 142 000500 145 000504 146 000506 147 000510 149 000511 151 000516 152 000520 153 000530 154 000535 155 000536 156 000541 158 000542 162 000550 166 000553 168 000557 170 000571 171 000605 175 000606 177 000611 180 000612 182 000613 184 000616 186 000620 187 000622 189 000623 191 000626 193 000627 195 000630 197 000633 199 000635 200 000637 202 000640 204 000643 207 000644 209 000645 211 000647 212 000651 214 000652 216 000654 218 000655 219 000661 220 000667 221 000677 222 000731 224 000735 225 000743 227 000744 229 000747 232 000750 234 000751 237 000756 238 000761 243 000762 245 000765 247 000766 249 000774 251 000775 253 001024 254 001032 256 001033 258 001034 259 001042 261 001043 263 001075 265 001101 266 001107 268 001110 271 001111 272 001112 274 001117 276 001126 281 001137 282 001145 283 001146 284 001147 289 001160 290 001165 293 001166 295 001171 297 001174 298 001175 300 001200 301 001202 303 001203 305 001212 307 001216 308 001220 311 001221 314 001225 315 001226 319 001227 320 001232 321 001233 323 001234 325 001235 326 001245 328 001246 330 001250 331 001251 332 001254 334 001255 335 001260 336 001264 337 001267 338 001272 339 001275 340 001300 341 001303 343 001304 346 001336 352 001343 353 001356 354 001363 358 001364 361 001376 363 001377 366 001401 368 001402 370 001404 373 001405 375 001407 376 001411 377 001421 378 001423 379 001426 380 001431 381 001435 382 001437 383 001440 384 001443 385 001447 387 001450 389 001457 390 001462 392 001463 395 001466 397 001512 402 001514 404 001517 406 001523 408 001525 409 001535 410 001537 411 001542 412 001545 414 001547 417 001553 418 001560 419 001561 420 001565 421 001570 423 001571 425 001573 426 001576 428 001577 431 001601 433 001602 434 001604 435 001605 436 001607 438 001610 441 001614 442 001617 444 001620 448 001624 449 001627 451 001630 453 001635 457 001636 460 001646 461 001652 463 001655 466 001660 469 001667 470 001674 473 001702 475 001711 477 001714 479 001716 482 001720 486 001721 489 001722 490 001752 491 001754 493 001762 494 001772 495 001775 496 002001 497 002004 498 002010 502 002011 505 002012 506 002013 509 002024 510 002030 514 002036 516 002045 517 002050 521 002051 524 002052 527 002060 528 002063 532 002064 535 002065 536 002067 537 002077 538 002101 539 002105 540 002107 541 002111 542 002113 543 002120 546 002126 547 002127 551 002130 554 002131 555 002133 556 002135 557 002136 558 002141 8 4 002142 8 35 002144 8 37 002146 8 40 002153 8 43 002170 8 44 002173 8 45 002202 ----------------------------------------------------------- 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