COMPILATION LISTING OF SEGMENT basic_runtime_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell Multics Op. - System M Compiled on: 09/11/84 1244.8 mst Tue Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* *********************************************************** */ 9 10 11 /* Runtime system for Multics BASIC 12* 13* Initial Version: 12 November 1973 by BLW 14* Modified: 20 January 1974 by BLW to use iox_ 15* Modified: 12 March 1974 by BLW to fix bug013 16* Modified: 17 March 1974 by BLW to fix bug015 17* Modified: 28 March 1974 by BLW to fix bug022 18* Modified: 2 April 1974 by BLW to fix bug025 19* Modified: 22 April 1974 by BLW to fix bug026, bug027, bug028, and bug029 20* Modified: 23 July 1974 by BLW to fix bugs 038 and 042 21* Modified: 27 August 1974 by BLW to fix bug 047 22* Modified: January 1976 by MBW to use iox_ more extensively 23* Modified: May 1976 by MBW to add double precision capabilities 24* Modified: 21 January 1977 by MBW to fix bug 064 25* Modified: 18 February 1977 by MBW to fix bug 066 26* Modified: 7 March 1977 by MBW to fix bug 067 27* Modified: 6 July 1977 by MBW to fix bug 074 28* Modified: 29 July 1977 by MBW to change file opening strategy 29* Modified: 4 August 1977 by MBW to reset margins when changing file types 30* Modified: 25 May 1978 by MBW to not reset tty margin automatically 31* Modified: 29 December 1983 by MBW to fix switch(66) and to not try to close unused file 32* Modified: 24 April 1984 by AH, 103: Fix the implied minus sign 33* in the PRINT USING statement. 34* Modified: 15 May 1984 by DWL to document use of sst$ for mid$ 35* Modified: 22 May 1984 by DWL to add new switch 134 for left$ 36* Modified: 23 May 1984 by DWL to add new switch 135 for right$ 37* Modified: 28 May 1984 by DWL to fix ep error on switch 134 (201), 38* and switch 135 (202) for left$, right$ 39**/ 40 41 basic_runtime_: proc(bo_stack_pt); 42 43 dcl bo_stack_pt ptr; 44 45 dcl (bo_pt,p1,p2,p3,p4,program_header_pt) ptr, 46 ans char(28) varying, 47 ch aligned char(1), 48 c6 char(6), 49 c8 char(8), 50 c12 char(12), 51 user_name char(22), 52 c32 char(32), 53 c64 char(64), 54 dir char(168), 55 ent char(32), 56 (no_input,mat_input) bit(1), 57 seg_no bit(18), 58 (buff_size,old_buff_size) fixed bin(21), 59 code fixed(35), 60 bit_length fixed bin(5), 61 file_lng fixed bin (34), 62 (i,k,loc,m,n,tab_size) fixed bin; 63 64 dcl ascii_size_op char (5) varying static; 65 66 dcl sys_info$max_seg_size fixed bin ext; 67 68 dcl vfx fixed bin(35), 69 vbs bit(36) aligned based(addr(vfx)); 70 71 dcl double_vfx fixed bin(71), 72 double_vbs bit(72) aligned based(addr(double_vfx)); 73 74 dcl entry_variable entry variable, 75 1 ev based(addr(entry_variable)), 76 2 location ptr, 77 2 stack ptr; 78 79 dcl ( max_string_size init(4096), 80 max_buffer_size init(4096), 81 default_buffer_size init(128), 82 area_header_size init(24), 83 bits_per_char init(9)) fixed bin static; 84 85 dcl based_vs char(4096) varying based; 86 87 dcl 1 varying aligned based, 88 2 len fixed bin, 89 2 chars char(1); 90 91 dcl 1 change aligned based, 92 2 str(n) bit(bit_length) unaligned; 93 94 dcl float_bin(0:10) float bin based; 95 96 dcl double_float_bin(0:10) float bin(63) based; 97 98 dcl double_bit_word(0:10) bit(72) aligned based; 99 100 dcl fix_bin(0:10) fixed bin based; 101 102 dcl bit_word(0:10) bit(36) aligned based; 103 104 105 dcl char_string char(n) based unaligned; 106 107 dcl varying_char_string char(n) varying based; 108 109 dcl header_numbers (2) char(1) unaligned static init("1", "2"); 110 111 dcl typ_name(5) char(8) varying int static 112 init("any", "tty", "terminal", "numeric", "string"); 113 114 dcl per_name(7) char(8) varying int static 115 init("input","linput","read","print","reset","scratch","write"); 116 117 dcl per_bits(7) bit(5) aligned int static 118 init("01100"b, /* input */ 119 "01100"b, /* linput */ 120 "00011"b, /* read */ 121 "01100"b, /* print */ 122 "00111"b, /* reset */ 123 "00111"b, /* scratch */ 124 "00011"b); /* write */ 125 126 dcl NL char(1) static init(" 127 "), 128 white_space char(2) static init(" "), /* space, HT */ 129 amp_NL char(2) static init("& 130 "), 131 comma_NL char(2) static init(", 132 "); 133 134 dcl (ioa_,ioa_$nnl,com_err_) entry options(variable), 135 basic_file_name_ entry(char(168) aligned), 136 timer_manager_$cpu_call entry(fixed bin(71),bit(2),entry), 137 timer_manager_$reset_cpu_call entry(entry), 138 hcs_$make_seg entry(char(*),char(*),char(*),fixed bin(5),ptr,fixed(35)), 139 assign_round_ options(variable), 140 area_ entry(fixed bin,ptr), 141 user_info_ entry(char(*),char(*),char(*)), 142 hcs_$delentry_file entry(char(*),char(*),fixed(35)), 143 hcs_$del_dir_tree entry(char(*),char(*),fixed(35)), 144 cu_$stack_frame_ptr entry returns(ptr), 145 get_pdir_ entry(char(168)), 146 expand_path_ entry(ptr,fixed bin,ptr,ptr,fixed(35)), 147 hcs_$status_ entry(char(*),char(*),fixed bin,ptr,ptr,fixed(35)), 148 iox_$open entry(ptr, fixed bin, bit(1) aligned, fixed bin(35)), 149 iox_$control entry(ptr, char(*), ptr, fixed bin(35)), 150 iox_$close entry(ptr, fixed bin(35)), 151 iox_$detach_iocb entry( ptr, fixed bin(35)), 152 iox_$position entry (ptr, fixed bin, fixed bin(21), fixed bin(35)), 153 iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)), 154 iox_$get_chars entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)), 155 iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)), 156 iox_$write_record entry (ptr, ptr, fixed bin(21), fixed bin(35)), 157 vfile_status_ entry (char(*), char(*), ptr, fixed bin(35)), 158 convert_old_basic_file_ entry (char(*), char(*), fixed bin(35)), 159 iox_$find_iocb entry(aligned char(*),ptr,fixed(35)), 160 iox_$attach_iocb entry(ptr,char(*),fixed(35)), 161 iox_$destroy_iocb entry(ptr,fixed(35)); 162 163 dcl iox_$user_output ptr ext, 164 iox_$user_input ptr ext; 165 166 dcl ( error_table_$end_of_info, 167 error_table_$fulldir, 168 error_table_$no_operation, 169 error_table_$not_done, 170 error_table_$long_record, 171 error_table_$noentry) fixed bin(35) ext static; 172 173 dcl fast_related_data_$basic_area_p ptr ext; 174 dcl fast_related_data_$in_fast_or_dfast bit(1) aligned ext; 175 176 dcl buffer char(buffer_size) based(buffer_pt), 177 1 buffer_pair based(buffer_pt), 178 2 buff1 char(old_buff_size), 179 2 buff2 char(old_buff_size); 180 181 dcl string_seg ptr; 182 183 dcl (field_length,field_start,precision,scale,exp_length,digit_count, 184 digit_pos,field_pos) fixed bin; 185 186 dcl 1 print_using_bits unaligned, 187 2 (left_just,right_just) bit(1), 188 2 have_dollar bit(1), 189 2 (have_plus,have_minus) bit(1), 190 2 have_exp bit(1), 191 2 have_decimal bit(1); 192 193 dcl pu_string char(pu_length) aligned based(print_using_pt); 194 195 dcl fixed_dec_1 fixed dec(1), 196 fixed_dec_1_overlay char(2) aligned based(addr(fixed_dec_1)); 197 198 dcl fixed_dec_2 fixed dec(2), 199 fixed_dec_2_overlay char(3) aligned based(addr(fixed_dec_2)); 200 201 dcl (abs,addr,addrel,bit,convert,date,divide,fixed,hbound,oncode,baseno,reverse,string,ptr, 202 float,index,length,null,substr,verify,search,rel,unspec,time,max,min,mod,rtrim) builtin; 203 204 dcl 1 param_info_aligned based, 205 2 param_type(1) bit(9) unaligned; 206 207 dcl basic_error_messages_$ aligned ext, 208 1 message_overlay aligned based(addr(basic_error_messages_$)), 209 2 index_block(0:500), 210 3 loc fixed bin, 211 3 sev fixed bin, 212 3 len fixed bin, 213 2 skip unal char(k), 214 2 message unal char(index_block(error_number).len-1); 215 216 dcl 1 basic_string aligned based, 217 2 count fixed bin, 218 2 value char(n) varying; 219 220 dcl 1 string_word aligned based, 221 2 offset bit(18) unaligned, 222 2 ignored bit(18) unaligned; 223 224 dcl 1 arg_info aligned based, 225 2 string_word bit(36), /* string word used for local copy */ 226 2 type fixed bin(17) unal, /* 0 = fixed, 1 = varying */ 227 2 length fixed bin(17) unal; /* length of original string arg */ 228 229 dcl word fixed bin based aligned; 230 231 dcl 1 arglist aligned based, 232 2 arg_count fixed bin(16) unaligned, 233 2 skip bit(54) unaligned, 234 2 arg_ptr(10) ptr; 235 236 dcl string_area area(65536) based(string_segment); 237 238 dcl info(20) fixed bin(35); /* storage for vfile_status_ */ 239 240 dcl 1 position_info aligned, 241 2 next_position fixed bin(34), 242 2 last_position fixed bin(34); 243 244 dcl 1 margin_info aligned, 245 2 old_max_recl fixed bin(21), 246 2 new_max_recl fixed bin(21); 247 248 dcl string_buffer char(4096) aligned; 249 250 dcl 1 map(100) aligned based, 251 2 location bit(18) unaligned, 252 2 line bit(18) unaligned; 253 254 dcl have_conversion_label bit(36) aligned based(addr(conversion_label)); 255 256 dcl have_size_label bit(36) aligned based(addr(size_label)); 257 258 /* following block of words will be used as the fcb for tty. it is 259* declared "big enough" instead of via like attribute so we 260* can make unqualified references to basic_fcb */ 261 262 dcl tty_fcb(32) fixed bin(71) static; 263 1 1 dcl 1 basic_operators_frame aligned based(bo_pt), 1 2 2 pr(0:7) ptr, 1 3 2 prev_sp ptr, 1 4 2 next_sp ptr, 1 5 2 return_ptr ptr, 1 6 2 entry_ptr ptr, 1 7 2 operator_and_lp_ptr ptr, 1 8 2 arglist_ptr ptr, 1 9 2 reserved bit(72), 1 10 2 on_unit_relp(2) bit(18) unaligned, 1 11 2 translator_id bit(18) unaligned, 1 12 2 operator_return_offset bit(18) unaligned, 1 13 2 regs, 1 14 3 xr(0:7) bit(18) unaligned, 1 15 3 (a_reg,q_reg) fixed bin(35), 1 16 3 rest_of_regs(2) bit(36) aligned, 1 17 2 print_using_pt ptr, /* N.B. this holds return loc, pos in struc must be the same 1 18* as for ep basic as debuggers depend on this */ 1 19 2 abort_label label, 1 20 2 conversion_label label, 1 21 2 size_label label, 1 22 2 on_units(2), 1 23 3 name ptr, 1 24 3 body ptr, 1 25 3 size fixed bin, 1 26 3 next fixed bin, 1 27 2 program_header ptr, 1 28 2 text_base_ptr ptr, 1 29 2 string_segment ptr, 1 30 2 fcb_pt ptr, 1 31 2 arglist1(2) ptr, 1 32 2 runtime_arglist(2) ptr, 1 33 2 cpu_start fixed bin(71), 1 34 2 determinant float bin(63), 1 35 2 fcb(0:16) ptr unaligned, 1 36 2 precision_lng fixed bin(17) unaligned, 1 37 2 file_number fixed bin(17) unaligned, 1 38 2 (error_number,pdl) fixed bin, 1 39 2 program_header_offset bit(18) aligned, 1 40 2 numeric_data unaligned, 1 41 3 (finish,start) fixed bin(17), 1 42 2 string_data unaligned, 1 43 3 (finish,start) fixed bin(17), 1 44 2 random fixed bin, 1 45 2 first_frame bit(18), 1 46 2 last_frame bit(18), 1 47 2 next_frame bit(18), 1 48 2 number_read fixed bin, 1 49 2 (pu_pos,pu_length) fixed bin, 1 50 2 definitions ptr unal, 1 51 2 fn_temp1 fixed bin, 1 52 2 fn_temp2 fixed bin, 1 53 2 entryname ptr unal, 1 54 2 flags unaligned, 1 55 3 non_basic_caller bit(1), 1 56 3 main_program bit(1), 1 57 3 quits_disabled bit(1), 1 58 3 had_quit bit(1), 1 59 3 ignore_handler bit(1), 1 60 3 filler bit(13), 1 61 2 number_length fixed bin(17) unaligned, 1 62 2 string_value bit(36), 1 63 2 temporaries(3) aligned, 1 64 3 temp float bin, 1 65 3 tpad bit(36), 1 66 2 arg(1) ptr; 1 67 1 68 dcl 1 d_basic_operators_frame aligned based(bo_pt), 1 69 2 x_pr(0:7) ptr, 1 70 2 x_prev_sp ptr, 1 71 2 x_next_sp ptr, 1 72 2 x_return_ptr ptr, 1 73 2 x_entry_ptr ptr, 1 74 2 x_operator_and_lp_ptr ptr, 1 75 2 x_arglist_ptr ptr, 1 76 2 x_reserved bit(72), 1 77 2 x_on_unit_relp(2) bit(18) unaligned, 1 78 2 x_translator_id bit(18) unaligned, 1 79 2 x_operator_return_offset bit(18) unaligned, 1 80 2 x_regs, 1 81 3 x_xr(0:7) bit(18) unaligned, 1 82 3 (x_a_reg,x_q_reg) fixed bin, 1 83 3 x_rest_of_regs(2) bit(36) aligned, 1 84 2 x_print_using_pt ptr, 1 85 2 x_abort_label label, 1 86 2 x_conversion_label label, 1 87 2 x_size_label label, 1 88 2 x_on_units(2), 1 89 3 x_name ptr, 1 90 3 x_body ptr, 1 91 3 x_size fixed bin, 1 92 3 x_next fixed bin, 1 93 2 x_program_header ptr, 1 94 2 x_text_base_ptr ptr, 1 95 2 x_string_segment ptr, 1 96 2 x_fcb_pt ptr, 1 97 2 x_arglist1(2) ptr, 1 98 2 x_runtime_arglist(2) ptr, 1 99 2 x_cpu_start fixed bin(71), 1 100 2 x_determinant float bin(63), 1 101 2 x_fcb(0:16) ptr unaligned, 1 102 2 x_precision_lng fixed bin(17) unaligned, 1 103 2 x_file_number fixed bin(17) unaligned, 1 104 2 x_error_number fixed bin, 1 105 2 x_pdl fixed bin, 1 106 2 x_program_header_offset bit(18) aligned, 1 107 2 x_numeric_data unaligned, 1 108 3 (x_finish,x_start) fixed bin(17), 1 109 2 x_string_data unaligned, 1 110 3 (x_finish,x_start) fixed bin(17), 1 111 2 x_random fixed bin, 1 112 2 x_first_frame bit(18), 1 113 2 x_last_frame bit(18), 1 114 2 x_next_frame bit(18), 1 115 2 x_number_read fixed bin, 1 116 2 (x_pu_pos,x_pu_length) fixed bin, 1 117 2 x_definitions ptr unal, 1 118 2 x_fn_temp1 fixed bin, 1 119 2 x_fn_temp2 fixed bin, 1 120 2 x_entryname ptr unal, 1 121 2 x_flags unaligned, 1 122 3 x_non_basic_caller bit(1), 1 123 3 x_main_program bit(1), 1 124 3 x_quits_disabled bit(1), 1 125 3 x_had_quit bit(1), 1 126 3 x_filler bit(14), 1 127 2 x_number_length fixed bin(17) unaligned, 1 128 2 x_string_value bit(36), 1 129 2 d_temp(3) float bin(63), 1 130 2 x_arg(1) ptr; 264 2 1 dcl 1 basic_fcb aligned based(fcb_pt), 2 2 2 seg_pt ptr, 2 3 2 buffer_pt ptr, 2 4 2 owner ptr, 2 5 2 file_type fixed bin, 2 6 2 open_mode fixed bin, 2 7 2 line_pos fixed bin, 2 8 2 buffer_pos fixed bin(21), 2 9 2 margin fixed bin, 2 10 2 io_ops_since_margin fixed bin(35), 2 11 2 last_operation fixed bin, 2 12 2 buffer_length fixed bin(21), 2 13 2 buffer_size fixed bin(21), 2 14 2 bits unaligned, 2 15 3 attached_by_us bit(1), 2 16 3 opened_by_us bit(1), 2 17 3 temporary_file bit(1), 2 18 3 must_be_ascii bit(1), 2 19 3 write_permission bit(1), 2 20 2 file_name char(168); 2 21 2 22 dcl ( undefined_file init(1), 2 23 tty_file init(2), 2 24 ascii_file init(3), 2 25 numeric_file init(4), 2 26 string_file init(5)) fixed bin int static options (constant); 2 27 2 28 dcl ( file_op init(1), 2 29 scratch_op init(2), 2 30 reset_op init(3), 2 31 input_op init(4), 2 32 print_op init(5), 2 33 read_op init(6), 2 34 write_op init(7), 2 35 close_op init(8)) fixed bin int static options (constant); 2 36 2 37 dcl ( Not_open init(1), 2 38 Numeric_input init(2), 2 39 String_input init(3), 2 40 Ascii_input init(4), 2 41 Numeric_input_output init(5), 2 42 String_update init(6), 2 43 Ascii_input_output init(7), 2 44 Ascii_output init(8)) fixed bin static options (constant); 2 45 2 46 dcl open_types (8) init (-1, 1, 4, 1, 3, 7, 3, 2) fixed bin static options (constant); 2 47 2 48 dcl ( stream_input init(1), 2 49 stream_output init(2), 2 50 stream_input_output init(3), 2 51 sequential_input init(4), 2 52 sequential_update init(7)) fixed bin static options (constant); 265 266 3 1 dcl 1 uns_info based (addr (info)), /* info structure for unstructured files */ 3 2 2 info_version fixed, /* (Input) must =1--only one version 3 3* currently supported */ 3 4 2 type fixed, /* =1 */ 3 5 2 end_pos fixed (34), /* length (bytes) not including header */ 3 6 2 flags aligned, 3 7 3 pad1 bit (2) unal, /* used for lock_status in other files */ 3 8 3 header_present bit (1) unal, /* on if file code is set */ 3 9 3 pad2 bit (33) unal, 3 10 2 header_id fixed (35); /* meaning is user defined */ 3 11 dcl 1 seq_info based (addr (info)), /* info structure for sequential files */ 3 12 2 info_version fixed, 3 13 2 type fixed, /* =2 */ 3 14 2 end_pos fixed (34), /* record count */ 3 15 2 flags aligned, 3 16 3 lock_status bit (2) unal, /* 0,1,2, or 3 to indicate not locked, 3 17* locked by (other,this,dead) process */ 3 18 3 pad bit (34) unal, 3 19 2 version fixed, /* end_pos valid only in latest version */ 3 20 2 action fixed; /* indicates if adjustment or rollback is needed */ 3 21 dcl 1 blk_info based (addr (info)), /* info structure for blocked files */ 3 22 2 info_version fixed, 3 23 2 type fixed, /* =3 */ 3 24 2 end_pos fixed (34), /* record count */ 3 25 2 flags aligned, 3 26 3 lock_status bit (2) unal, /* same as seq_info.= */ 3 27 3 pad bit (34) unal, 3 28 2 version fixed, /* only one currently supported */ 3 29 2 action fixed, /* non-zero if truncation in progress, else =0 */ 3 30 2 max_rec_len fixed (21), /* bytes--determines characteristiWc block size */ 3 31 2 pad fixed, /* not used at this time */ 3 32 2 time_last_modified fixed (71); /* time stamp for synchronization */ 3 33 dcl 1 indx_info based (addr (info)), /* info structure for indexed files */ 3 34 2 info_version fixed, 3 35 2 type fixed, /* =4 */ 3 36 2 records fixed (34), /* record count */ 3 37 2 flags aligned, 3 38 3 lock_status bit (2) unal, /* same as seq_info.= */ 3 39 3 pad bit (34) unal, 3 40 2 version_info aligned, 3 41 3 file_version fixed (17) unal, /* headers differ */ 3 42 3 program_version fixed (17) unal, /* may indicate bugs */ 3 43 2 action fixed, /* non-zero code indicates update in progress */ 3 44 2 non_null_recs fixed (34), /* count of allocated recs */ 3 45 2 record_bytes fixed (34), /* total record length */ 3 46 2 free_blocks fixed, /* available record blocks */ 3 47 2 index_height fixed, /* height of index tree (0 if empty) */ 3 48 2 nodes fixed, /* nodes being used in the index */ 3 49 2 key_bytes fixed (34), /* total length of keys */ 3 50 2 change_count fixed (35), /* bumped on each file modification */ 3 51 2 num_keys fixed (34), /* number of index entries */ 3 52 2 dup_keys fixed (34), /* 0 if all keys are distinct, else 1 for each dup */ 3 53 2 dup_key_bytes fixed (34), /* total bytes of duplicate keys */ 3 54 2 word (1) fixed; /* reserved for future use */ 3 55 dcl 1 vbl_info based (addr (info)), /* info structure for variable files */ 3 56 2 info_version fixed, 3 57 2 type fixed, /* =5 */ 3 58 2 end_pos fixed (34), /* logical end of file--not necessarily allocation count */ 3 59 2 flags aligned, 3 60 3 lock_status bit (2) unal, /* same as seq_info.= */ 3 61 3 pad bit (34) unal, 3 62 2 version fixed, /* only one currently supported */ 3 63 2 action fixed, /* same as in indexed files */ 3 64 2 first_nz fixed (34), /* position (numeric key) for first allocated record */ 3 65 2 last_nz fixed (34), /* last allocated record position */ 3 66 2 change_count fixed (35); /* used for synchronization */ 3 67 dcl vfs_version_1 static internal fixed init (1); 3 68 /* should be used in 3 69* assignments to info_version */ 267 4 1 dcl 1 basic_program_header aligned based(program_header_pt), 4 2 2 version_number fixed binary, 4 3 2 numeric_storage like loc_number, 4 4 2 string_storage like loc_number, 4 5 2 numeric_data like loc_number, 4 6 2 string_data like loc_number, 4 7 2 incoming_args like loc_number, 4 8 2 time_limit float bin, 4 9 2 numeric_scalars like loc_number, 4 10 2 string_scalars like loc_number, 4 11 2 numeric_arrays like loc_number, 4 12 2 string_arrays like loc_number, 4 13 2 functions like loc_number, 4 14 2 statement_map like loc_number, 4 15 2 precision_ind fixed bin(17) unaligned, 4 16 2 definitions fixed bin(17) unaligned; 4 17 4 18 dcl 1 loc_number based, 4 19 2 location bit(18) unaligned, 4 20 2 number bit(18) unaligned; 268 5 1 dcl 1 array_dope aligned based, 5 2 2 data ptr, 5 3 2 original_bounds(2) fixed bin, 5 4 2 current_bounds(2) fixed bin; 5 5 5 6 dcl 1 scalar_symbol aligned based, 5 7 2 name char(2) unaligned, 5 8 2 parameter bit(1) unaligned, 5 9 2 location bit(17) unaligned; 5 10 5 11 dcl 1 array_symbol aligned based, 5 12 2 name char(1) unaligned, 5 13 2 skip bit(9) unaligned, 5 14 2 parameter bit(1) unaligned, 5 15 2 location bit(17) unaligned, 5 16 2 offset fixed bin, 5 17 2 bounds(2) fixed bin(17) unaligned; 269 6 1 dcl ( numeric_scalar_param init(2), 6 2 string_scalar_param init(3), 6 3 numeric_list_param init(4), 6 4 string_list_param init(5), 6 5 numeric_table_param init(6), 6 6 string_table_param init(7), 6 7 numeric_function_param init(8), 6 8 string_function_param init(9), 6 9 file_param init(10)) fixed bin static; 270 7 1 /* BEGIN INCLUDE FILE ..... iocb.incl.pl1 ..... 13 Feb 1975, M. Asherman */ 7 2 /* Modified 11/29/82 by S. Krupp to add new entries and to change 7 3* version number to IOX2. */ 7 4 /* format: style2 */ 7 5 7 6 dcl 1 iocb aligned based, /* I/O control block. */ 7 7 2 version character (4) aligned, /* IOX2 */ 7 8 2 name char (32), /* I/O name of this block. */ 7 9 2 actual_iocb_ptr ptr, /* IOCB ultimately SYNed to. */ 7 10 2 attach_descrip_ptr ptr, /* Ptr to printable attach description. */ 7 11 2 attach_data_ptr ptr, /* Ptr to attach data structure. */ 7 12 2 open_descrip_ptr ptr, /* Ptr to printable open description. */ 7 13 2 open_data_ptr ptr, /* Ptr to open data structure (old SDB). */ 7 14 2 reserved bit (72), /* Reserved for future use. */ 7 15 2 detach_iocb entry (ptr, fixed (35)),/* detach_iocb(p,s) */ 7 16 2 open entry (ptr, fixed, bit (1) aligned, fixed (35)), 7 17 /* open(p,mode,not_used,s) */ 7 18 2 close entry (ptr, fixed (35)),/* close(p,s) */ 7 19 2 get_line entry (ptr, ptr, fixed (21), fixed (21), fixed (35)), 7 20 /* get_line(p,bufptr,buflen,actlen,s) */ 7 21 2 get_chars entry (ptr, ptr, fixed (21), fixed (21), fixed (35)), 7 22 /* get_chars(p,bufptr,buflen,actlen,s) */ 7 23 2 put_chars entry (ptr, ptr, fixed (21), fixed (35)), 7 24 /* put_chars(p,bufptr,buflen,s) */ 7 25 2 modes entry (ptr, char (*), char (*), fixed (35)), 7 26 /* modes(p,newmode,oldmode,s) */ 7 27 2 position entry (ptr, fixed, fixed (21), fixed (35)), 7 28 /* position(p,u1,u2,s) */ 7 29 2 control entry (ptr, char (*), ptr, fixed (35)), 7 30 /* control(p,order,infptr,s) */ 7 31 2 read_record entry (ptr, ptr, fixed (21), fixed (21), fixed (35)), 7 32 /* read_record(p,bufptr,buflen,actlen,s) */ 7 33 2 write_record entry (ptr, ptr, fixed (21), fixed (35)), 7 34 /* write_record(p,bufptr,buflen,s) */ 7 35 2 rewrite_record entry (ptr, ptr, fixed (21), fixed (35)), 7 36 /* rewrite_record(p,bufptr,buflen,s) */ 7 37 2 delete_record entry (ptr, fixed (35)),/* delete_record(p,s) */ 7 38 2 seek_key entry (ptr, char (256) varying, fixed (21), fixed (35)), 7 39 /* seek_key(p,key,len,s) */ 7 40 2 read_key entry (ptr, char (256) varying, fixed (21), fixed (35)), 7 41 /* read_key(p,key,len,s) */ 7 42 2 read_length entry (ptr, fixed (21), fixed (35)), 7 43 /* read_length(p,len,s) */ 7 44 2 open_file entry (ptr, fixed bin, char (*), bit (1) aligned, fixed bin (35)), 7 45 /* open_file(p,mode,desc,not_used,s) */ 7 46 2 close_file entry (ptr, char (*), fixed bin (35)), 7 47 /* close_file(p,desc,s) */ 7 48 2 detach entry (ptr, char (*), fixed bin (35)); 7 49 /* detach(p,desc,s) */ 7 50 7 51 declare iox_$iocb_version_sentinel 7 52 character (4) aligned external static; 7 53 7 54 /* END INCLUDE FILE ..... iocb.incl.pl1 ..... */ 271 8 1 /* BEGIN INCLUDE FILE status_info_branch.incl.pl1 */ 8 2 dcl 1 status_info_branch, /* structure returned for branch */ 8 3 2 type bit(2), /* 0=link, 1=seg, 2=dir */ 8 4 2 nnames bit(16), /* number of names for this entry */ 8 5 2 nrp bit(18), /* ??????? */ 8 6 2 dtm bit(36), /* date and time last modified */ 8 7 2 dtu bit(36), /* date and time last used */ 8 8 2 mode bit(5), /* user's access mode */ 8 9 2 pad bit(13), 8 10 2 records bit(18); /* number of records used */ 8 11 /* END INCLUDE FILE status_info_branch.incl.pl1 */ 272 273 274 bo_pt = bo_stack_pt; 275 goto switch(q_reg + (precision_lng-1)*67); 276 277 /* initialize */ 278 279 switch(0): 280 switch(67): 281 if fast_related_data_$basic_area_p = null 282 then do; 283 284 /* first time in process */ 285 286 call hcs_$make_seg("","basic_string_segment_","",01011b,string_seg,code); 287 288 if string_seg = null 289 then do; 290 call com_err_(0,"basic","Could not make string segment"); 291 goto abort_label; 292 end; 293 294 call area_(sys_info$max_seg_size + area_header_size,string_seg); 295 296 fast_related_data_$basic_area_p = string_seg; 297 298 fcb_pt = addr(tty_fcb); 299 owner = null; 300 margin = 75; 301 open_mode = Ascii_input_output; 302 end; 303 304 string_segment = fast_related_data_$basic_area_p; 305 string_value = "0"b; 306 307 if fast_related_data_$in_fast_or_dfast then ascii_size_op = " -ssf"; 308 else ascii_size_op = " "; 309 310 do i = 1 to 16; 311 fcb(i) = null; 312 end; 313 314 fcb_pt = addr(tty_fcb); 315 fcb(0) = fcb_pt; 316 317 if owner = null then owner = bo_pt; 318 319 buffer_pos = 0; 320 buffer_pt = addr(file_name); 321 buffer_size = length(file_name); 322 323 file_type = tty_file; 324 325 last_operation = 0; 326 327 program_header_pt = program_header; 328 329 if time_limit ^= 0.0e0 330 then do; 331 332 /* Set up cpu timer to go off after specified time limit. Since we may 333* have several basic programs active, we fill in the stack part of the 334* entry variable to indicate which program set up the timer; this will 335* be used to turn off timer at end of execution. */ 336 337 entry_variable = cpu_limit; 338 ev.stack = bo_pt; 339 340 call timer_manager_$cpu_call(time_limit * 1.0e6,"10"b,entry_variable); 341 end; 342 343 return; 344 345 /* cleanup */ 346 347 switch(1): 348 switch(68): 349 call tidy_up("1"b); 350 return; 351 352 /* print error message */ 353 354 switch(2): switch(69): 355 call print_error(error_number); 356 return; 357 358 /* numeric print */ 359 360 switch(3): switch(70): 361 call check_print; 362 call numeric_print; 363 return; 364 365 /* string print */ 366 367 switch(4): switch(71): 368 call check_print; 369 p1 = get_string_ptr(pr(1)); 370 call string_print; 371 return; 372 373 /* tab to next multiple of 15 */ 374 375 switch(5): switch(72): 376 call check_print; 377 tab_size = max(15, number_length+8); 378 call tab(divide(line_pos + tab_size,tab_size,17,0)*tab_size); 379 return; 380 381 /* end print */ 382 383 switch(6): switch(73): 384 call check_print; 385 call force_buffer; 386 return; 387 388 /* print new line */ 389 390 switch(7): switch(74): 391 call check_print; 392 call print_new_line; 393 return; 394 395 /* tab function */ 396 397 switch(8): switch(75): 398 call check_print; 399 call tab(fixed(temp(1))); 400 return; 401 402 /* spc function */ 403 404 switch(9): switch(76): 405 call check_print; 406 call tab(fixed(temp(1)) + line_pos); 407 return; 408 409 /* string assign, pr(1) is right side, pr(3) is left side */ 410 411 switch(10): switch(77): 412 call string_assign; 413 pr(1) = addr(pr(3) -> string_word); 414 return; 415 416 /* string compare, pr(1) is left side, pr(3) is right side */ 417 418 switch(11): switch(78): 419 p1 = get_string_ptr(pr(1)); 420 p2 = get_string_ptr(pr(3)); 421 422 if p1 = p2 423 then do; 424 temp(1) = 0; 425 return; 426 end; 427 428 if p1 -> based_vs < p2 -> based_vs 429 then temp(1) = -1; 430 else if p1 -> based_vs = p2 -> based_vs 431 then temp(1) = 0; 432 else temp(1) = +1; 433 434 return; 435 436 /* concatenation, pr(1) is left side, pr(3) is right side */ 437 438 switch(12): switch(79): 439 p1 = get_string_ptr(pr(1)); 440 p2 = get_string_ptr(pr(3)); 441 442 n = length(p1 -> based_vs) + length(p2 -> based_vs); 443 444 if n > max_string_size 445 then do; 446 call print_error(104); 447 goto abort_label; 448 end; 449 450 call allocate_string; 451 452 p3 -> basic_string.value = p1 -> based_vs || p2 -> based_vs; 453 454 call return_string; 455 return; 456 457 /* linput */ 458 459 switch(13): switch(80): 460 call check_input; 461 call linput; 462 call return_string; 463 return; 464 465 /* numeric input */ 466 467 switch(14): switch(81): 468 call check_input; 469 mat_input = "0"b; 470 471 call numeric_input; 472 473 do while(no_input); 474 call get_input(-107); 475 call numeric_input; 476 end; 477 478 return; 479 480 /* string input */ 481 482 switch(15): switch(82): 483 call check_input; 484 mat_input = "0"b; 485 486 call string_input; 487 488 do while(no_input); 489 call get_input(-107); 490 call string_input; 491 end; 492 493 call return_string; 494 return; 495 496 /* end input */ 497 498 switch(16): switch(83): 499 call end_input; 500 return; 501 502 /* pos(a$,b$,n); pr(1) gives a$, pr(3) gives b$, n in temp(1) */ 503 504 switch(17): switch(84): 505 i = fixed(temp(1)); 506 507 if i <= 0 508 then do; 509 510 return_0: temp(1) = 0; 511 return; 512 end; 513 514 p1 = get_string_ptr(pr(1)); 515 516 if i > length(p1 -> based_vs) then goto return_0; 517 518 p2 = get_string_ptr(pr(3)); 519 520 n = index(substr(p1 -> based_vs,i),p2 -> based_vs); 521 522 if n = 0 then goto return_0; 523 524 temp(1) = n + i - 1; 525 return; 526 527 /* chr$(n) */ 528 529 switch(18): switch(85): 530 unspec(ch) = bit(fixed(temp(1),9),9) & "001111111"b; 531 532 n = 1; 533 call allocate_string; 534 p3 -> basic_string.value = ch; 535 536 call return_string; 537 return; 538 539 /* clk$ */ 540 541 switch(19): switch(86): 542 c12 = time(); 543 544 c8 = substr(c12,1,2) || ":" || substr(c12,3,2) || ":" || substr(c12,5,2); 545 546 call use_c8; 547 return; 548 549 /* dat$ */ 550 551 switch(20): switch(87): 552 c6 = date(); 553 554 c8 = substr(c6,3,2) || "/" || substr(c6,5,2) || "/" || substr(c6,1,2); 555 call use_c8; 556 return; 557 558 /* usr$ */ 559 560 switch(21): switch(88): 561 call user_info_(user_name,c8,c8); 562 563 n = index(user_name," ") - 1; 564 if n < 0 then n = length(user_name); 565 call allocate_string; 566 p3 -> basic_string.value = substr(user_name,1,n); 567 call return_string; 568 return; 569 570 /* str$(x) */ 571 572 switch(22): 573 call convert_number; 574 575 n = length(ans); 576 call allocate_string; 577 p3 -> basic_string.value = ans; 578 call return_string; 579 return; 580 581 /* seg$(a$,i,j) */ 582 583 switch(23): switch(90): 584 i = fixed(temp(1)); 585 n = fixed(temp(2)) - i + 1; 586 goto sst; 587 588 /* sst$(a$,i,n) and mid$(a$,i,n) */ 589 590 switch(24): switch(91): 591 i = fixed(temp(1)); 592 n = fixed(temp(2)); 593 594 sst: p1 = get_string_ptr(pr(1)); 595 596 right_entry: 597 if i < 1 then n = 0; 598 599 n = max(min(n,length(p1 -> based_vs) - i + 1),0); 600 601 call allocate_string; 602 p3 -> basic_string.value = substr(p1 -> based_vs,i,n); 603 call return_string; 604 return; 605 606 /* hps */ 607 608 switch(25): switch(92): 609 call get_file_number("01100"b); 610 611 temp(1) = fcb(n) -> line_pos; 612 return; 613 614 /* tst(a$) */ 615 616 switch(26): 617 temp(1) = float(fixed(convert_string(),1),1); 618 return; 619 620 /* val(a$) */ 621 622 switch(27): 623 if convert_string() then return; 624 625 call print_error(124); 626 goto abort_label; 627 628 /* deallocate string specified by pr(1) */ 629 630 switch(28): switch(95): 631 call deallocate_string(pr(1)); 632 return; 633 634 /* file */ 635 636 switch(29): switch(96): 637 file_number = fixed(temp(1)); 638 639 if file_number = 0 then goto invalid_file_number; 640 if file_number > 16 then goto invalid_file_number; 641 642 fcb_pt = fcb(file_number); 643 644 if fcb_pt ^= null then call close_file("0"b); /* but save iocb */ 645 else do; 646 quits_disabled = "1"b; 647 allocate basic_fcb in(string_area); 648 quits_disabled = "0"b; 649 650 if had_quit then call signal_quit; 651 652 fcb(file_number) = fcb_pt; 653 seg_pt = null; /* do not have iocb yet */ 654 owner = bo_pt; 655 end; 656 657 string(basic_fcb.bits) = "0"b; 658 file_type = undefined_file; 659 open_mode = Not_open; 660 write_permission = "0"b; 661 margin = -1; 662 io_ops_since_margin = -1; 663 buffer_pt = null; 664 665 p1 = get_string_ptr(pr(1)); 666 667 if p1 -> based_vs = "*" 668 then do; 669 670 /* Create unique name for segment in process directory */ 671 672 call get_pdir_(dir); 673 674 n = index(dir," "); 675 if n = 0 then n = length(dir) + 1; 676 677 file_name = substr(dir,1,n-1) || ">" || unique(); 678 679 temporary_file = "1"b; 680 write_permission = "1"b; 681 end; 682 else do; 683 file_name = p1 -> based_vs; 684 685 call open_file; 686 end; 687 688 last_operation = file_op; 689 690 return; 691 692 /* margin */ 693 694 switch(30): switch(97): 695 n = fixed(temp(1)); 696 if n < 0 then goto invalid_margin; 697 if n > 4095 then goto invalid_margin; 698 699 if file_type = numeric_file 700 then do; /* if empty, just set margin variable and hope that next 701* use will change file type */ 702 call iox_$control (seg_pt, "read_position", addr(position_info), code); 703 if position_info.last_position > 0 704 then if n ^= 1 then goto invalid_margin; 705 end; 706 else if file_type = string_file 707 then do; 708 call check_random_string(String_update); /* be sure it's open correctly */ 709 margin_info.new_max_recl = n; 710 call iox_$control (seg_pt, "max_rec_len", addr(margin_info), code); 711 if code = error_table_$no_operation 712 then if n ^= margin_info.old_max_recl 713 then go to invalid_margin; 714 end; 715 716 margin = n; 717 io_ops_since_margin = -1; 718 return; 719 720 /* scratch */ 721 722 switch(31): switch(98): 723 if file_number = 0 then goto invalid_file_number; 724 725 /* seg_pt = null should imply that file is nonexistent */ 726 727 if seg_pt = null then return; 728 if file_type = undefined_file then return; 729 730 if file_type = ascii_file then do; 731 call zap_file; /* can't open for input_output if attached to record_stream */ 732 call attach_ascii; 733 buffer_pos = buffer_length; 734 end; 735 else do; 736 if open_mode < Ascii_input then do; /* not open or open for input only */ 737 if file_type = numeric_file then call open_random (Numeric_input_output); 738 else call open_random (String_update); 739 end; 740 call iox_$position (seg_pt, -1, 0, code); 741 call iox_$control (seg_pt, "truncate", null, code); 742 end; 743 744 last_operation = scratch_op; 745 return; 746 747 /* reset ascii */ 748 749 switch(32): switch(99): 750 if file_number = 0 then goto invalid_file_number; 751 752 if (file_type ^= undefined_file) & (open_mode ^= Not_open) 753 then do; 754 if open_mode = Ascii_output then return; /* can't reset output only */ 755 call check_ascii (Ascii_input); 756 call reset_ascii; 757 end; 758 759 return; 760 761 /* reset random */ 762 763 switch(33): switch(100): 764 n = fixed(temp(1)); 765 766 if file_type = tty_file then goto invalid_file_number; 767 if file_type = undefined_file then do; 768 if n = 0 then return; /* file will start at 0 when it's created */ 769 else goto pointer_error; 770 end; 771 if file_type = ascii_file then goto type_and_usage_conflict; 772 773 if open_mode = Not_open then do; /* must open first */ 774 if file_type = numeric_file then i = Numeric_input; 775 else i = String_input; 776 call open_random (i); 777 end; 778 779 if n < 0 then goto pointer_error; 780 if file_type = numeric_file then buff_size = n*precision_lng*4; 781 else if file_type = string_file then buff_size = n; 782 call iox_$position (seg_pt, 2, buff_size, code); 783 if code ^= 0 then goto pointer_error; 784 785 last_operation = reset_op; 786 return; 787 788 /* numeric write */ 789 790 switch(34): 791 call check_random_numeric (Numeric_input_output); 792 call numeric_write; 793 return; 794 795 /* numeric read */ 796 797 switch(35): 798 call check_random_numeric (Numeric_input); 799 call numeric_read; 800 return; 801 802 /* string write */ 803 804 switch(36): switch(103): 805 call check_random_string (String_update); 806 p1 = get_string_ptr(pr(1)); 807 call string_write; 808 return; 809 810 /* string read */ 811 812 switch(37): switch(104): 813 call check_random_string (String_input); 814 call string_read; 815 call return_string; 816 return; 817 818 /* lof function */ 819 820 switch(38): switch(105): 821 call get_file_number("10011"b); 822 823 if n = 0 then goto invalid_file_number; 824 temp(1) = length_of_file (fcb(n) -> seg_pt); 825 return; 826 827 /* loc function */ 828 829 switch(39): switch(106): 830 call get_file_number("10011"b); 831 832 if n = 0 then goto invalid_file_number; 833 if (fcb(n) -> seg_pt = null) 834 | (file_type = undefined_file) 835 | (open_mode = Not_open) 836 then do; 837 temp(1) = 0; 838 return; 839 end; 840 841 call iox_$control (fcb(n)->seg_pt, "read_position", addr(position_info), code); 842 if code ^= 0 then goto invalid_file_number; 843 844 if fcb(n)->file_type = numeric_file 845 then temp(1) = divide(position_info.next_position, (precision_lng*4), 21, 0); 846 else temp(1) = position_info.next_position; 847 848 return; 849 850 /* mar function */ 851 852 switch(40): switch(107): 853 call get_file_number("11111"b); 854 855 temp(1) = fcb(n) -> margin; 856 return; 857 858 /* check eof for file specified by temp(1) 859* result temp(1) = 0 => more, ^= 0 -> eof */ 860 861 switch(41): switch(108): 862 call get_file_number("11111"b); 863 864 if n = 0 then temp(1) = 0; 865 else do; 866 file_number = n; 867 fcb_pt = fcb(n); 868 869 if open_mode = Not_open 870 then do; 871 file_lng = length_of_file (seg_pt); 872 if file_lng > 0 then temp(1) = 0; 873 else temp(1) = 1; 874 end; 875 876 else do; 877 call iox_$control (seg_pt, "read_position", addr(position_info), code); 878 if code ^= 0 879 then temp(1) = 1; /* assume unopen file is empty */ 880 else if position_info.next_position < position_info.last_position 881 then temp(1) = 0; 882 else do; 883 temp(1) = 1; 884 if file_type = ascii_file 885 then if buffer_pos < buffer_length 886 then temp(1) = 0; 887 end; 888 end; 889 end; 890 891 return; 892 893 /* typ(n,str) where n in temp(1) and str given by pr(1) */ 894 895 switch(42): switch(109): 896 p1 = get_string_ptr(pr(1)); 897 898 do i = 1 to hbound(typ_name,1); 899 if p1 -> based_vs = typ_name(i) then goto typ_ok; 900 end; 901 902 temp(1) = -1; 903 return; 904 905 typ_ok: n = fixed(temp(1)); 906 907 if n < 0 then goto invalid_file_number; 908 if n > 16 then goto invalid_file_number; 909 910 if fcb(n) = null then temp(1) = 0; 911 else if i = 1 | (fcb(n) -> file_type = undefined_file & i ^= 2) 912 then temp(1) = 1; 913 else temp(1) = float(fixed(fcb(n) -> file_type = i,1),1); 914 915 return; 916 917 /* change from string given by pr(1) to array given by pr(2) */ 918 919 switch(43): 920 bit_length = fixed(temp(1)); 921 if bit_length <= 0 then goto change_error; 922 if bit_length > 27 then goto change_error; 923 924 p1 = get_string_ptr(pr(1)); 925 926 n = divide(length(p1 -> based_vs) * bits_per_char,bit_length,17,0); 927 928 if n > pr(2) -> current_bounds(1) then goto change_error; 929 930 p2 = pr(2) -> array_dope.data; 931 p2 -> float_bin(0) = n; 932 933 p1 = addr(p1 -> varying.chars); 934 935 do i = 1 to n; 936 p2 -> float_bin(i) = float(fixed(p1 -> change.str(i),27),27); 937 end; 938 939 return; 940 941 /* change to string given by pr(1) from array given by pr(2) */ 942 943 switch(44): 944 bit_length = fixed(temp(1)); 945 if bit_length <= 0 then goto change_error; 946 if bit_length > 27 then goto change_error; 947 948 call deallocate_string(pr(1)); 949 950 p2 = pr(2) -> array_dope.data; 951 m = p2 -> float_bin(0); 952 if m > pr(2) -> current_bounds(1) then goto change_error; 953 954 n = divide(m*bit_length + bits_per_char-1,bits_per_char,17,0); 955 956 call allocate_string; 957 958 pr(1) -> bit_word(0) = rel(p3); 959 p1 = addr(p3 -> basic_string.value); 960 961 p1 -> varying.len = n; 962 p1 = addr(p1 -> varying.chars); 963 964 do i = 1 to m; 965 vfx = p2 -> float_bin(i); 966 967 if vfx < 0 then goto change_error; 968 if substr(vbs,1,36-bit_length) then goto change_error; 969 970 p1 -> change.str(i) = substr(vbs,37-bit_length,bit_length); 971 end; 972 973 /* zero out any remaining bits in last ASCII character */ 974 975 n = n*bits_per_char - m*bit_length; 976 if n ^= 0 then substr(p1 -> change.str(i),1,n) = "0"b; 977 978 return; 979 980 /* mat numeric input */ 981 982 switch(45): 983 call check_input; 984 mat_input = "1"b; 985 number_read = 0; 986 call mat_loop(1); 987 return; 988 989 /* mat string input */ 990 991 switch(46): 992 call check_input; 993 mat_input = "1"b; 994 number_read = 0; 995 call mat_loop(2); 996 return; 997 998 /* mat numeric print */ 999 1000 switch(47): 1001 call check_print; 1002 1003 if pr(2) -> current_bounds(2) > 1 then a_reg = max(a_reg,1); 1004 1005 call print_new_line; 1006 call mat_loop(3); 1007 return; 1008 1009 /* mat string print */ 1010 1011 switch(48): 1012 call check_print; 1013 1014 if pr(2) -> current_bounds(2) > 1 then a_reg = max(a_reg,1); 1015 1016 call print_new_line; 1017 call mat_loop(4); 1018 return; 1019 1020 /* mat numeric read */ 1021 1022 switch(49): 1023 call check_random_numeric (Numeric_input); 1024 call mat_loop(7); 1025 return; 1026 1027 /* mat string read */ 1028 1029 switch(50): 1030 call check_random_string (String_input); 1031 call mat_loop(8); 1032 return; 1033 1034 /* mat numeric write */ 1035 1036 switch(51): 1037 call check_random_numeric (Numeric_input_output); 1038 call mat_loop(9); 1039 return; 1040 1041 /* mat string write */ 1042 1043 switch(52): 1044 call check_random_string (String_update); 1045 call mat_loop(10); 1046 return; 1047 1048 /* mat numeric data read */ 1049 1050 switch(53): 1051 call mat_loop(5); 1052 return; 1053 1054 /* mat string data read */ 1055 1056 switch(54): 1057 call mat_loop(6); 1058 return; 1059 1060 /* mat linput */ 1061 1062 switch(55): 1063 call mat_loop(11); 1064 call end_input; 1065 return; 1066 1067 /* start print using */ 1068 1069 switch(56): switch(123): 1070 call check_print; 1071 1072 p1 = get_string_ptr(pr(1)); 1073 pu_length = length(p1 -> based_vs); 1074 1075 if pu_length = 0 then goto zero_print_using; 1076 1077 quits_disabled = "1"b; 1078 allocate pu_string in(string_area); 1079 quits_disabled = "0"b; 1080 1081 if had_quit then call signal_quit; 1082 1083 pu_string = p1 -> based_vs; 1084 pu_pos = 0; 1085 1086 return; 1087 1088 /* print using numeric */ 1089 1090 switch(57): 1091 call print_using_numeric; 1092 return; 1093 1094 /* print using string */ 1095 1096 switch(58): switch(125): 1097 p1 = get_string_ptr(pr(1)); 1098 call print_using_string; 1099 return; 1100 1101 /* end print using */ 1102 1103 switch(59): switch(126): 1104 call get_next_field("1"b); 1105 1106 quits_disabled = "1"b; 1107 free pu_string in(string_area); 1108 quits_disabled = "0"b; 1109 1110 if had_quit then call signal_quit; 1111 1112 return; 1113 1114 /* mat print using numeric */ 1115 1116 switch(60): 1117 call mat_loop(12); 1118 return; 1119 1120 /* mat print using string */ 1121 1122 switch(61): 1123 call mat_loop(13); 1124 return; 1125 1126 /* mat a$ = nul$ */ 1127 1128 switch(62): 1129 call mat_loop(14); 1130 return; 1131 1132 /* mat a$ = b$ */ 1133 1134 switch(63): 1135 p4 = pr(1) -> array_dope.data; 1136 call mat_loop(15); 1137 return; 1138 1139 /* per(n,str) where n in temp(1) and str given by pr(1) */ 1140 1141 switch(64): switch(131): 1142 p1 = get_string_ptr(pr(1)); 1143 1144 do i = 1 to hbound(per_name,1); 1145 if p1 -> based_vs = per_name(i) then goto per_ok; 1146 end; 1147 1148 temp(1) = -1; 1149 return; 1150 1151 per_ok: n = fixed(temp(1)); 1152 1153 if n < 0 then goto invalid_file_number; 1154 if n > 16 then goto invalid_file_number; 1155 1156 if fcb(n) = null then temp(1) = 0; 1157 else temp(1) = float(fixed(substr(per_bits(i),fcb(n) -> file_type,1),1)); 1158 1159 if i > 3 /* check for output permission */ 1160 then if file_type ^= undefined_file 1161 then if ^write_permission 1162 then temp(1) = 0; 1163 1164 return; 1165 1166 /* create string value from string pointed at by pr(2) and whose 1167* length is in a_reg */ 1168 1169 switch(65): switch(132): 1170 n = a_reg; 1171 call allocate_string; 1172 p3 -> basic_string.value = pr(2) -> char_string; 1173 call return_string; 1174 return; 1175 1176 /* make the string word pointed at by pr(2) specify a unique string value */ 1177 1178 switch(66): switch(133): 1179 p1 = get_string_ptr(pr(2)); 1180 n = length(p1 -> based_vs); 1181 1182 if (n = 0) | (addrel(p1,-1) -> basic_string.count ^= 1) 1183 then do; 1184 1185 /* The string value is shared, we have to make unique copy */ 1186 1187 call allocate_string; 1188 p3 -> basic_string.value = p1 -> based_vs; 1189 1190 call deallocate_string(pr(2)); 1191 1192 pr(2) -> string_word.offset = rel(p3); 1193 end; 1194 1195 return; 1196 1197 /* str$(x) */ 1198 1199 switch(89): 1200 call d_convert_number; 1201 1202 n = length(ans); 1203 call allocate_string; 1204 p3 -> basic_string.value = ans; 1205 call return_string; 1206 return; 1207 1208 /* tst(a$) */ 1209 1210 switch(93): 1211 1212 temp(1) = float(fixed(d_convert_string(),1),1); 1213 return; 1214 1215 /* val(a$) */ 1216 1217 switch(94): 1218 if d_convert_string() then return; 1219 1220 call print_error(124); 1221 goto abort_label; 1222 1223 /* numeric write */ 1224 1225 switch(101): 1226 call check_random_numeric (Numeric_input_output); 1227 call d_numeric_write; 1228 return; 1229 1230 /* numeric read */ 1231 1232 switch(102): 1233 call check_random_numeric (Numeric_input); 1234 call d_numeric_read; 1235 return; 1236 1237 /* change from string given by pr(1) to array given by pr(2) */ 1238 1239 switch(110): 1240 bit_length = fixed(temp(1)); 1241 if bit_length <= 0 then goto change_error; 1242 if bit_length > 63 then goto change_error; 1243 1244 p1 = get_string_ptr(pr(1)); 1245 1246 n = divide(length(p1 -> based_vs) * bits_per_char,bit_length,17,0); 1247 1248 if n > pr(2) -> current_bounds(1) then goto change_error; 1249 1250 p2 = pr(2) -> array_dope.data; 1251 p2 -> double_float_bin(0) = n; 1252 1253 p1 = addr(p1 -> varying.chars); 1254 1255 do i = 1 to n; 1256 p2 -> double_float_bin(i) = float(fixed(p1 -> change.str(i),63),63); 1257 end; 1258 1259 return; 1260 1261 /* change to string given by pr(1) from array given by pr(2) */ 1262 1263 switch(111): 1264 bit_length = fixed(temp(1)); 1265 if bit_length <= 0 then goto change_error; 1266 if bit_length > 63 then goto change_error; 1267 1268 call deallocate_string(pr(1)); 1269 1270 p2 = pr(2) -> array_dope.data; 1271 m = p2 -> double_float_bin(0); 1272 if m > pr(2) -> current_bounds(1) then goto change_error; 1273 1274 n = divide(m*bit_length + bits_per_char-1,bits_per_char,17,0); 1275 1276 call allocate_string; 1277 1278 pr(1) -> bit_word(0) = rel(p3); 1279 p1 = addr(p3 -> basic_string.value); 1280 1281 p1 -> varying.len = n; 1282 p1 = addr(p1 -> varying.chars); 1283 1284 do i = 1 to m; 1285 double_vfx = p2 -> double_float_bin(i); 1286 1287 if double_vfx < 0 then goto change_error; 1288 if substr(double_vbs,1,72-bit_length) then goto change_error; 1289 1290 p1 -> change.str(i) = substr(double_vbs,73-bit_length,bit_length); 1291 end; 1292 1293 /* zero out any remaining bits in last ASCII character */ 1294 1295 n = n*bits_per_char - m*bit_length; 1296 if n ^= 0 then substr(p1 -> change.str(i),1,n) = "0"b; 1297 1298 return; 1299 1300 /* mat numeric input */ 1301 1302 switch(112): 1303 call check_input; 1304 mat_input = "1"b; 1305 number_read = 0; 1306 call d_mat_loop(1); 1307 return; 1308 1309 /* mat string input */ 1310 1311 switch(113): 1312 call check_input; 1313 mat_input = "1"b; 1314 number_read = 0; 1315 call d_mat_loop(2); 1316 return; 1317 1318 /* mat numeric print */ 1319 1320 switch(114): 1321 call check_print; 1322 1323 if pr(2) -> current_bounds(2) > 1 then a_reg = max(a_reg,1); 1324 1325 call print_new_line; 1326 call d_mat_loop(3); 1327 return; 1328 1329 /* mat string print */ 1330 1331 switch(115): 1332 call check_print; 1333 1334 if pr(2) -> current_bounds(2) > 1 then a_reg = max(a_reg,1); 1335 1336 call print_new_line; 1337 call d_mat_loop(4); 1338 return; 1339 1340 /* mat numeric read */ 1341 1342 switch(116): 1343 call check_random_numeric (Numeric_input); 1344 call d_mat_loop(7); 1345 return; 1346 1347 /* mat string read */ 1348 1349 switch(117): 1350 call check_random_string (String_input); 1351 call d_mat_loop(8); 1352 return; 1353 1354 /* mat numeric write */ 1355 1356 switch(118): 1357 call check_random_numeric (Numeric_input_output); 1358 call d_mat_loop(9); 1359 return; 1360 1361 /* mat string write */ 1362 1363 switch(119): 1364 call check_random_string (String_update); 1365 call d_mat_loop(10); 1366 return; 1367 1368 /* mat numeric data read */ 1369 1370 switch(120): 1371 call d_mat_loop(5); 1372 return; 1373 1374 /* mat string data read */ 1375 1376 switch(121): 1377 call d_mat_loop(6); 1378 return; 1379 1380 /* mat linput */ 1381 1382 switch(122): 1383 call d_mat_loop(11); 1384 call end_input; 1385 return; 1386 1387 /* print using numeric */ 1388 1389 switch(124): 1390 call d_print_using_numeric; 1391 return; 1392 1393 /* mat print using numeric */ 1394 1395 switch(127): 1396 call d_mat_loop(12); 1397 return; 1398 1399 /* mat print using string */ 1400 1401 switch(128): 1402 call d_mat_loop(13); 1403 return; 1404 1405 /* mat a$ = nul$ */ 1406 1407 switch(129): 1408 call d_mat_loop(14); 1409 return; 1410 1411 /* mat a$ = b$ */ 1412 1413 switch(130): 1414 p4 = pr(1) -> array_dope.data; 1415 call d_mat_loop(15); 1416 return; 1417 1418 switch(134): 1419 switch(201): 1420 /* left$ */ 1421 /* used code from sst$ but initialize first */ 1422 i = 1; 1423 n = fixed (temp(1)); 1424 goto sst; 1425 switch(135): 1426 switch(202): 1427 /* right$ */ 1428 /* use sst$ but initialize first */ 1429 n = fixed(temp(1)); 1430 1431 /* Determine length and count back */ 1432 1433 p1 = get_string_ptr(pr(1)); 1434 i = length(p1 -> based_vs) - n + 1; 1435 if i <= 0 then i = 1; 1436 goto right_entry; 1437 1438 1439 /* errors */ 1440 1441 invalid_margin: 1442 n = 131; 1443 1444 err: call print_error(n); 1445 goto abort_label; 1446 1447 type_and_usage_conflict: 1448 n = 132; 1449 goto err; 1450 1451 end_of_file: 1452 n = 133; 1453 goto err; 1454 1455 file_error: 1456 n = 134; 1457 goto err; 1458 1459 invalid_file_number: 1460 n = 135; 1461 goto err; 1462 1463 pointer_error: 1464 n = 136; 1465 goto err; 1466 1467 change_error: 1468 n = 138; 1469 goto err; 1470 1471 array_error: 1472 n = 139; 1473 goto err; 1474 1475 out_of_data: 1476 n = 103; 1477 goto err; 1478 1479 zero_print_using: 1480 n = 141; 1481 goto err; 1482 1483 print_using_error: 1484 n = 142; 1485 goto err; 1486 1487 incorrect_format_for_file_input: 1488 n = 145; 1489 goto err; 1490 1491 open_error: 1492 n = 147; 1493 goto err; 1494 1495 cannot_write: 1496 n = 148; 1497 goto err; 1498 1499 input_line_too_long: 1500 n = 149; 1501 goto err; 1502 1503 iox_error: 1504 n = 158; 1505 goto err; 1506 1507 close_error: 1508 n = 157; 1509 file_type = undefined_file; 1510 goto err; 1511 1512 cannot_read: 1513 n = 156; 1514 goto err; 1515 1516 cannot_scratch: 1517 n = 159; 1518 goto err; 1519 1520 default: entry(mc_ptr,name,co_ptr,info_ptr,continue); 1521 1522 dcl (mc_ptr,co_ptr,info_ptr) ptr, 1523 name char(*) unaligned, 1524 continue bit(1) aligned; 1525 9 1 /* */ 9 2 /* BEGIN INCLUDE FILE mc.incl.pl1 Created Dec 72 for 6180 - WSS. */ 9 3 /* Modified 06/07/76 by Greenberg for mc.resignal */ 9 4 /* Modified 07/07/76 by Morris for fault register data */ 9 5 /* Modified 08/28/80 by J. A. Bush for the DPS8/70M CVPU */ 9 6 /* Modified '82 to make values constant */ 9 7 9 8 /* words 0-15 pointer registers */ 9 9 9 10 dcl mcp ptr; 9 11 9 12 dcl 1 mc based (mcp) aligned, 9 13 2 prs (0:7) ptr, /* POINTER REGISTERS */ 9 14 (2 regs, /* registers */ 9 15 3 x (0:7) bit (18), /* index registers */ 9 16 3 a bit (36), /* accumulator */ 9 17 3 q bit (36), /* q-register */ 9 18 3 e bit (8), /* exponent */ 9 19 3 pad1 bit (28), 9 20 3 t bit (27), /* timer register */ 9 21 3 pad2 bit (6), 9 22 3 ralr bit (3), /* ring alarm register */ 9 23 9 24 2 scu (0:7) bit (36), 9 25 9 26 2 mask bit (72), /* mem controller mask at time of fault */ 9 27 2 ips_temp bit (36), /* Temporary storage for IPS info */ 9 28 2 errcode fixed bin (35), /* fault handler's error code */ 9 29 2 fim_temp, 9 30 3 unique_index bit (18) unal, /* unique index for restarting faults */ 9 31 3 resignal bit (1) unal, /* recompute signal name with fcode below */ 9 32 3 fcode bit (17) unal, /* fault code used as index to FIM table and SCT */ 9 33 2 fault_reg bit (36), /* fault register */ 9 34 2 pad2 bit (1), 9 35 2 cpu_type fixed bin (2) unsigned, /* L68 = 0, DPS8/70M = 1 */ 9 36 2 ext_fault_reg bit (15), /* extended fault reg for DPS8/70M CPU */ 9 37 2 fault_time bit (54), /* time of fault */ 9 38 9 39 2 eis_info (0:7) bit (36)) unaligned; 9 40 9 41 9 42 dcl (apx fixed bin init (0), 9 43 abx fixed bin init (1), 9 44 bpx fixed bin init (2), 9 45 bbx fixed bin init (3), 9 46 lpx fixed bin init (4), 9 47 lbx fixed bin init (5), 9 48 spx fixed bin init (6), 9 49 sbx fixed bin init (7)) internal static options (constant); 9 50 9 51 9 52 9 53 9 54 dcl scup ptr; 9 55 9 56 dcl 1 scu based (scup) aligned, /* SCU DATA */ 9 57 9 58 9 59 /* WORD (0) */ 9 60 9 61 (2 ppr, /* PROCEDURE POINTER REGISTER */ 9 62 3 prr bit (3), /* procedure ring register */ 9 63 3 psr bit (15), /* procedure segment register */ 9 64 3 p bit (1), /* procedure privileged bit */ 9 65 9 66 2 apu, /* APPENDING UNIT STATUS */ 9 67 3 xsf bit (1), /* ext seg flag - IT modification */ 9 68 3 sdwm bit (1), /* match in SDW Ass. Mem. */ 9 69 3 sd_on bit (1), /* SDW Ass. Mem. ON */ 9 70 3 ptwm bit (1), /* match in PTW Ass. Mem. */ 9 71 3 pt_on bit (1), /* PTW Ass. Mem. ON */ 9 72 3 pi_ap bit (1), /* Instr Fetch or Append cycle */ 9 73 3 dsptw bit (1), /* Fetch of DSPTW */ 9 74 3 sdwnp bit (1), /* Fetch of SDW non paged */ 9 75 3 sdwp bit (1), /* Fetch of SDW paged */ 9 76 3 ptw bit (1), /* Fetch of PTW */ 9 77 3 ptw2 bit (1), /* Fetch of pre-paged PTW */ 9 78 3 fap bit (1), /* Fetch of final address paged */ 9 79 3 fanp bit (1), /* Fetch of final address non-paged */ 9 80 3 fabs bit (1), /* Fetch of final address absolute */ 9 81 9 82 2 fault_cntr bit (3), /* number of retrys of EIS instructions */ 9 83 9 84 9 85 /* WORD (1) */ 9 86 9 87 2 fd, /* FAULT DATA */ 9 88 3 iro bit (1), /* illegal ring order */ 9 89 3 oeb bit (1), /* out of execute bracket */ 9 90 3 e_off bit (1), /* no execute */ 9 91 3 orb bit (1), /* out of read bracket */ 9 92 3 r_off bit (1), /* no read */ 9 93 3 owb bit (1), /* out of write bracket */ 9 94 3 w_off bit (1), /* no write */ 9 95 3 no_ga bit (1), /* not a gate */ 9 96 3 ocb bit (1), /* out of call bracket */ 9 97 3 ocall bit (1), /* outward call */ 9 98 3 boc bit (1), /* bad outward call */ 9 99 3 inret bit (1), /* inward return */ 9 100 3 crt bit (1), /* cross ring transfer */ 9 101 3 ralr bit (1), /* ring alarm register */ 9 102 3 am_er bit (1), /* associative memory fault */ 9 103 3 oosb bit (1), /* out of segment bounds */ 9 104 3 paru bit (1), /* processor parity upper */ 9 105 3 parl bit (1), /* processor parity lower */ 9 106 3 onc_1 bit (1), /* op not complete type 1 */ 9 107 3 onc_2 bit (1), /* op not complete type 2 */ 9 108 9 109 2 port_stat, /* PORT STATUS */ 9 110 3 ial bit (4), /* illegal action lines */ 9 111 3 iac bit (3), /* illegal action channel */ 9 112 3 con_chan bit (3), /* connect channel */ 9 113 9 114 2 fi_num bit (5), /* (fault/interrupt) number */ 9 115 2 fi_flag bit (1), /* 1 => fault, 0 => interrupt */ 9 116 9 117 9 118 /* WORD (2) */ 9 119 9 120 2 tpr, /* TEMPORARY POINTER REGISTER */ 9 121 3 trr bit (3), /* temporary ring register */ 9 122 3 tsr bit (15), /* temporary segment register */ 9 123 9 124 2 pad2 bit (9), 9 125 9 126 2 cpu_no bit (3), /* CPU number */ 9 127 9 128 2 delta bit (6), /* tally modification DELTA */ 9 129 9 130 9 131 /* WORD (3) */ 9 132 9 133 2 word3 bit (18), 9 134 9 135 2 tsr_stat, /* TSR STATUS for 1,2,&3 word instructions */ 9 136 3 tsna, /* Word 1 status */ 9 137 4 prn bit (3), /* Word 1 PR number */ 9 138 4 prv bit (1), /* Word 1 PR valid bit */ 9 139 3 tsnb, /* Word 2 status */ 9 140 4 prn bit (3), /* Word 2 PR number */ 9 141 4 prv bit (1), /* Word 2 PR valid bit */ 9 142 3 tsnc, /* Word 3 status */ 9 143 4 prn bit (3), /* Word 3 PR number */ 9 144 4 prv bit (1), /* Word 3 PR valid bit */ 9 145 9 146 2 tpr_tbr bit (6), /* TPR.TBR field */ 9 147 9 148 9 149 /* WORD (4) */ 9 150 9 151 2 ilc bit (18), /* INSTRUCTION COUNTER */ 9 152 9 153 2 ir, /* INDICATOR REGISTERS */ 9 154 3 zero bit (1), /* zero indicator */ 9 155 3 neg bit (1), /* negative indicator */ 9 156 3 carry bit (1), /* carryry indicator */ 9 157 3 ovfl bit (1), /* overflow indicator */ 9 158 3 eovf bit (1), /* eponent overflow */ 9 159 3 eufl bit (1), /* exponent underflow */ 9 160 3 oflm bit (1), /* overflow mask */ 9 161 3 tro bit (1), /* tally runout */ 9 162 3 par bit (1), /* parity error */ 9 163 3 parm bit (1), /* parity mask */ 9 164 3 bm bit (1), /* ^bar mode */ 9 165 3 tru bit (1), /* truncation mode */ 9 166 3 mif bit (1), /* multi-word instruction mode */ 9 167 3 abs bit (1), /* absolute mode */ 9 168 3 hex bit (1), /* hexadecimal exponent mode */ 9 169 3 pad bit (3), 9 170 9 171 9 172 /* WORD (5) */ 9 173 9 174 2 ca bit (18), /* COMPUTED ADDRESS */ 9 175 9 176 2 cu, /* CONTROL UNIT STATUS */ 9 177 3 rf bit (1), /* on first cycle of repeat instr */ 9 178 3 rpt bit (1), /* repeat instruction */ 9 179 3 rd bit (1), /* repeat double instruction */ 9 180 3 rl bit (1), /* repeat link instruciton */ 9 181 3 pot bit (1), /* IT modification */ 9 182 3 pon bit (1), /* return type instruction */ 9 183 3 xde bit (1), /* XDE from Even location */ 9 184 3 xdo bit (1), /* XDE from Odd location */ 9 185 3 poa bit (1), /* operation preparation */ 9 186 3 rfi bit (1), /* tells CPU to refetch instruction */ 9 187 3 its bit (1), /* ITS modification */ 9 188 3 if bit (1), /* fault occured during instruction fetch */ 9 189 9 190 2 cpu_tag bit (6)) unaligned, /* computed tag field */ 9 191 9 192 9 193 /* WORDS (6,7) */ 9 194 9 195 2 even_inst bit (36), /* even instruction of faulting pair */ 9 196 9 197 2 odd_inst bit (36); /* odd instruction of faulting pair */ 9 198 9 199 9 200 9 201 9 202 9 203 9 204 /* ALTERNATE SCU DECLARATION */ 9 205 9 206 9 207 dcl 1 scux based (scup) aligned, 9 208 9 209 (2 pad0 bit (36), 9 210 9 211 2 fd, /* GROUP II FAULT DATA */ 9 212 3 isn bit (1), /* illegal segment number */ 9 213 3 ioc bit (1), /* illegal op code */ 9 214 3 ia_am bit (1), /* illegal address - modifier */ 9 215 3 isp bit (1), /* illegal slave procedure */ 9 216 3 ipr bit (1), /* illegal procedure */ 9 217 3 nea bit (1), /* non existent address */ 9 218 3 oobb bit (1), /* out of bounds */ 9 219 3 pad bit (29), 9 220 9 221 2 pad2 bit (36), 9 222 9 223 2 pad3a bit (18), 9 224 9 225 2 tsr_stat (0:2), /* TSR STATUS as an ARRAY */ 9 226 3 prn bit (3), /* PR number */ 9 227 3 prv bit (1), /* PR valid bit */ 9 228 9 229 2 pad3b bit (6)) unaligned, 9 230 9 231 2 pad45 (0:1) bit (36), 9 232 9 233 2 instr (0:1) bit (36); /* Instruction ARRAY */ 9 234 9 235 9 236 9 237 /* END INCLUDE FILE mc.incl.pl1 */ 1526 1527 1528 dcl oncode_values(20) fixed bin static init(5,8,9,10,11,12,13,16,33,46,17,18,6,19,20,21,22,23,47,63); 1529 1530 dcl math_message(20) fixed bin static init(114,115,116,117,118,119,120,121,122,123,95,96, 1531 114,115,116,117,120,119,122,123); 1532 1533 dcl convert_new_oncode_ entry (fixed bin (35)) returns (fixed bin (35)); 1534 dcl cond char(32); 1535 1536 /* get ptr to stack frame of basic program in which fault occurred 1537* by fishing it out of our argument list */ 1538 1539 p1 = cu_$stack_frame_ptr() -> arglist_ptr; 1540 bo_pt = p1 -> arglist.arg_ptr(p1 -> arglist.arg_count + 1); 1541 1542 if ignore_handler then go to refuse; 1543 cond = name; 1544 1545 if cond = "error" 1546 then do; 1547 n = convert_new_oncode_ (oncode()); 1548 1549 if n < 5 then goto refuse; 1550 if precision_lng = 1 then if n > 46 then go to refuse; 1551 else if n > 63 then go to refuse; 1552 1553 if n = 17 then return; 1554 1555 do i = 1 to hbound(oncode_values,1); 1556 if oncode_values(i) = n then goto math_error; 1557 end; 1558 1559 refuse: continue = "1"b; 1560 return; 1561 1562 math_error: call print_error(math_message(i)); 1563 1564 return; 1565 end; 1566 1567 if have_conversion_label 1568 then do; 1569 if cond = "conversion" then goto conversion_label; 1570 if cond = "underflow" then goto conversion_label; 1571 if cond = "overflow" then goto conversion_label; 1572 end; 1573 1574 if have_size_label 1575 then do; 1576 if cond = "size" then goto size_label; 1577 if cond = "fixedoverflow" then goto size_label; 1578 end; 1579 1580 if cond = "overflow" 1581 then do; 1582 call restart_with_infinity(125,precision_lng); 1583 1584 /* the eovf indicator must be turned off here because it isn't later; 1585* otherwise it can mess up interpretatio of later faults */ 1586 1587 if mc_ptr ^= null then addr(mc_ptr->mc.scu(0))->scu.ir.eovf = "0"b; 1588 1589 return; 1590 end; 1591 1592 if cond = "zerodivide" 1593 then do; 1594 call restart_with_infinity(144,precision_lng); 1595 return; 1596 end; 1597 1598 if cond = "underflow" 1599 then do; 1600 call get_mc_info; 1601 1602 call error_print(140); 1603 1604 /* turn off eufl indicator here because it's not turned off automatically */ 1605 1606 if mc_ptr ^= null then addr(mc_ptr->mc.scu(0))->scu.ir.eufl = "0"b; 1607 1608 /* the FIM has already advanced the location counter and 1609* put 0.0e0 in the eaq, so all we have to do is return */ 1610 1611 return; 1612 end; 1613 1614 if cond = "lockup" 1615 then do; 1616 mcp = mc_ptr; 1617 scup = addr(mc.scu); 1618 1619 if baseno(program_header) ^= "000"b || scu.psr then goto refuse; 1620 1621 loc = fixed(scu.ilc,18); 1622 call error_print(126); 1623 1624 goto abort_label; 1625 end; 1626 1627 if cond = "area" 1628 then do; 1629 loc = fixed(basic_operators_frame.xr(7),18) - 1; 1630 1631 call error_print(143); 1632 1633 goto abort_label; 1634 end; 1635 1636 if cond = "stringsize" then return; 1637 1638 if cond = "quit" 1639 then if quits_disabled 1640 then do; 1641 had_quit = "1"b; 1642 return; 1643 end; 1644 else goto refuse; 1645 1646 goto refuse; 1647 1648 cpu_limit: entry(mc_ptr); 1649 1650 /* cpu limit reached, get ptr to stack frame of basic program by 1651* fishing it out of our arg list */ 1652 1653 p1 = cu_$stack_frame_ptr() -> arglist_ptr; 1654 bo_pt = p1 -> arglist.arg_ptr(p1 -> arglist.arg_count + 1); 1655 1656 call get_mc_info; 1657 1658 call error_print(146); 1659 1660 goto abort_label; 1661 1662 cleanup: entry; 1663 1664 /* get ptr to stack frame of basic program by fishing it out of our arg list */ 1665 1666 p1 = cu_$stack_frame_ptr() -> arglist_ptr; 1667 bo_pt = p1 -> arglist.arg_ptr(p1 -> arglist.arg_count + 1); 1668 1669 call tidy_up("0"b); 1670 return; 1671 1672 close_basic_file: entry(fn); 1673 1674 dcl fn float bin; 1675 1676 /* This entry is called by a basic sub-program to close a specified file. 1677* We get the pointer to the stack frame of the basic program by taking 1678* one step backwards in the stack */ 1679 1680 bo_pt = cu_$stack_frame_ptr() -> prev_sp; 1681 1682 file_number = fixed(fn); 1683 1684 if file_number <= 0 then return; 1685 if file_number > 16 then return; 1686 1687 fcb_pt = fcb(file_number); 1688 1689 if fcb_pt ^= null then call close_file("1"b); 1690 1691 return; 1692 1693 /* This procedure determines the location at which a fault occurred 1694* by looking in machine conditions provided by signal. If no 1695* machine conditions are available, the condition is refused. 1696* If the fault happened in the basic program, the ilc is used; 1697* otherwise, the point of entry into basic_operators_ is used. */ 1698 1699 get_mc_info: proc; 1700 1701 mcp = mc_ptr; 1702 if mcp = null then goto refuse; 1703 1704 scup = addr(mc.scu); 1705 1706 seg_no = "000"b || scu.psr; 1707 1708 if seg_no = baseno(program_header) then loc = fixed(scu.ilc,18); 1709 else loc = fixed(basic_operators_frame.xr(7),18) - 1; 1710 1711 end; 1712 1713 /* This procedure is called when the default handler wishes to 1714* restart executing with the instruction after the one which 1715* caused a fault. */ 1716 1717 restart: proc; 1718 1719 scu.ilc = bit(fixed(fixed(scu.ilc, 18) + 1,18), 18); 1720 scu.rfi = "1"b; 1721 scu.if = "0"b; 1722 1723 end; 1724 1725 /* This procedure is called to restart instruction after one causing 1726* fault with value of + infinity in EAQ. The argument gives error 1727* message to be printed. */ 1728 1729 restart_with_infinity: proc(errno,prec_lng); 1730 1731 dcl errno fixed bin; 1732 dcl prec_lng fixed bin unaligned; 1733 1734 call get_mc_info; 1735 1736 call error_print(errno); 1737 1738 /* set result to + infinity */ 1739 1740 if prec_lng = 1 then do; /* single precision */ 1741 mc.e = "01111111"b; 1742 mc.a = "011111111111111111111111111000000000"b; 1743 mc.q = "0"b; 1744 end; 1745 1746 else do; /* extended precision*/ 1747 mc.e = "01111111"b; 1748 mc.a = "011111111111111111111111111111111111"b; 1749 mc.q = "111111111111111111111111111000000000"b; 1750 end; 1751 1752 /* restart with instruction after one causing fault */ 1753 1754 call restart; 1755 end; 1756 1757 /* This procedure is called to straighten up after program finishes. */ 1758 1759 tidy_up: proc(normal); 1760 1761 dcl normal bit(1) aligned; 1762 1763 program_header_pt = program_header; 1764 1765 if time_limit ^= 0.0e0 1766 then do; 1767 1768 /* Turn off cpu timer */ 1769 1770 entry_variable = cpu_limit; 1771 ev.stack = bo_pt; 1772 1773 call timer_manager_$reset_cpu_call(entry_variable); 1774 end; 1775 1776 call cleanup_strings; 1777 1778 if non_basic_caller 1779 then do; 1780 1781 /* If any of the arguments of this subprogram are string scalars, 1782* we have to copy current value of string argument into original 1783* argument and then free the basic string value */ 1784 1785 p1 = addrel(program_header_pt,incoming_args.location); 1786 1787 do i = 1 to fixed(substr(incoming_args.number,1,17),17); 1788 if fixed(p1 -> param_type(i),9) = string_scalar_param 1789 then do; 1790 p2 = arg(i); 1791 p3 = get_string_ptr(p2); 1792 p4 = arglist_ptr -> arg_ptr(i); 1793 1794 n = p2 -> arg_info.length; 1795 if p2 -> arg_info.type = 0 then p4 -> char_string = p3 -> based_vs; 1796 else addrel(p4,-1) -> varying_char_string = p3 -> based_vs; 1797 1798 call deallocate_string(p2); 1799 end; 1800 end; 1801 end; 1802 1803 call close_all_files(normal); 1804 end; 1805 1806 /* This procedure is called to perform a string assignment. PR3 1807* points at target and PR1 points at source. If the target string 1808* is non-null, the reference count on the string block is decremented 1809* and the block is freed if the count reached zero. If the source 1810* is a null string, the target word is zeroed. If the source string 1811* is a constant, it must be copied into the string segment. The 1812* target word gets set to the offset of the string block in the 1813* string segment. For a normal assignment of the form 1814* let a$ = b$ 1815* the string words of both variables will "point" to same block 1816* in string storage. */ 1817 1818 string_assign: proc; 1819 1820 /* don't do anything if we have a$ = a$ */ 1821 1822 if pr(1) = pr(3) then return; 1823 1824 /* drop reference count and free (if necessary) current value of left side */ 1825 1826 call deallocate_string(pr(3)); 1827 1828 if pr(1) -> word = 0 1829 then do; 1830 1831 /* right side is null string */ 1832 1833 pr(3) -> word = 0; 1834 return; 1835 end; 1836 1837 if pr(1) -> string_word.offset 1838 then do; 1839 1840 /* right side is variable, bump its reference count */ 1841 1842 p1 = ptr(string_segment,pr(1) -> string_word.offset); 1843 1844 p1 -> basic_string.count = p1 -> basic_string.count + 1; 1845 1846 pr(3) -> string_word.offset = pr(1) -> string_word.offset; 1847 end; 1848 else do; 1849 1850 /* right side is constant, copy it into string segment */ 1851 1852 n = length(pr(1) -> based_vs); 1853 call allocate_string; 1854 1855 p3 -> basic_string.value = pr(1) -> based_vs; 1856 1857 pr(3) -> string_word.offset = rel(p3); 1858 end; 1859 end; 1860 1861 /* This procedure is called to allocate a string block; the size of 1862* the string is contained in the global variable "n". The reference 1863* count of the new block (pointed at by global variable p3) is set to 1. */ 1864 1865 allocate_string: proc; 1866 1867 quits_disabled = "1"b; 1868 allocate basic_string in(string_area) set(p3); 1869 quits_disabled = "0"b; 1870 1871 if had_quit then call signal_quit; 1872 1873 p3 -> basic_string.count = 1; 1874 1875 end; 1876 1877 /* This procedure is called to deallocate the string specified by the 1878* string variable pointed at by arg sp. The reference count on the string 1879* block is decremented and the block is freed if the count reached zero. 1880* The string variable is set to zero which indicates a null value. */ 1881 1882 deallocate_string: proc(sp); 1883 1884 dcl (sp,bsp) ptr; 1885 1886 if sp -> string_word.offset 1887 then do; 1888 bsp = ptr(string_segment,sp -> string_word.offset); 1889 bsp -> basic_string.count = bsp -> basic_string.count - 1; 1890 1891 if bsp -> basic_string.count = 0 1892 then do; 1893 quits_disabled = "1"b; 1894 free bsp -> basic_string in(string_area); 1895 quits_disabled = "0"b; 1896 1897 if had_quit then call signal_quit; 1898 end; 1899 1900 string(sp -> string_word) = (36)"0"b; 1901 end; 1902 1903 end; 1904 1905 /* This procedure contains entries for printing run-time error messages 1906* whose text is stored in basic_error_messages_. A negative message 1907* number indicates that no trailing is desired. The "print_error" 1908* entry gets its line number from the value of index register 7 at last 1909* entry into basic_operators_ while the "error_print" entry uses the 1910* value of the global variable "loc" to find the line number. */ 1911 1912 print_error: proc(num); 1913 1914 dcl (num,ln,save_file_number,et) fixed bin, 1915 main bit(1), 1916 save_fcb_pt ptr, 1917 ev entry variable options(variable); 1918 1919 ln = get_line_number(); 1920 1921 com: save_file_number = file_number; 1922 save_fcb_pt = fcb_pt; 1923 1924 file_number = 0; 1925 fcb_pt = fcb(0); 1926 1927 if last_operation = print_op 1928 then if line_pos ^= 0 1929 then call print_new_line; 1930 1931 file_number = save_file_number; 1932 fcb_pt = save_fcb_pt; 1933 1934 error_number = abs(num); 1935 1936 et = index_block(error_number).sev; 1937 main = et = 4 | main_program; 1938 1939 if main 1940 then if num < 0 then ev = ioa_$nnl; else ev = ioa_; 1941 else ev = ioa_$nnl; 1942 1943 if et = 3 1944 then do; 1945 if file_number ^= 0 then call ioa_$nnl("File ""^a"": ",file_name); 1946 et = 2; 1947 end; 1948 1949 k = index_block(error_number).loc; 1950 if k = -1 then call ev("RUNTIME ERROR ^d in ^d",error_number,ln); 1951 else if et = 2 1952 then call ev(message,ln); 1953 else if et = 1 1954 then call ev(message,pr(1) -> based_vs,ln); 1955 else call ev(message,pr(1),ln); 1956 1957 if ^main 1958 then do; 1959 if num < 0 then ev = ioa_$nnl; else ev = ioa_; 1960 1961 call ev(" of subprogram ""^A""",addrel(entryname,0)); /* pass UNPACKED ptr */ 1962 end; 1963 1964 if num < 0 then call ioa_$nnl("? "); 1965 return; 1966 1967 error_print: entry(num); 1968 1969 ln = obtain_line_number(); 1970 goto com; 1971 end; 1972 1973 /* This procedure is called to convert an object program location into 1974* a line number; it does a binary search on the statement map. The 1975* "get_line_number" entry uses the value of index register 7 at last 1976* entry into basic_operators_ while the "obtain_line_number" entry 1977* uses the value in the global variable "loc". In either case, the 1978* location is adjusted to be an offset with respect to the program 1979* header and that is the value actually used in the search. */ 1980 1981 get_line_number: proc returns(fixed bin); 1982 1983 dcl (lower,upper,i,map_loc) fixed bin, 1984 mp ptr; 1985 1986 loc = fixed(xr(7),18) - 1; 1987 1988 obtain_line_number: entry returns(fixed bin); 1989 1990 loc = loc - fixed(program_header_offset,18); 1991 1992 lower = 1; 1993 upper = fixed(program_header -> basic_program_header.statement_map.number,18); 1994 1995 mp = addrel(program_header,program_header -> basic_program_header.statement_map.location); 1996 1997 do while(lower <= upper); 1998 i = divide(lower+upper,2,17,0); 1999 2000 map_loc = fixed(mp -> map(i).location,18); 2001 2002 if loc < map_loc 2003 then upper = i - 1; 2004 else if loc = map_loc then do; 2005 /* skip over any remark lines */ 2006 do while(loc = fixed(mp->map(i+1).location,18)); i = i+1; end; 2007 return(fixed(mp -> map(i).line,18)); 2008 end; 2009 else if loc < fixed(mp -> map(i+1).location,18) 2010 then return(fixed(mp -> map(i).line,18)); 2011 else lower = i + 1; 2012 2013 end; 2014 2015 return(-1); 2016 end; 2017 2018 /* This procedure is called at the end of execution, just prior to 2019* a return, to clean up all string variables. Each string variable 2020* has its string block reference count decremented; the block is freed 2021* if the count reached zero. Note that we cannot just free each block 2022* since the same block may be referenced by more than one variable and 2023* in fact, such references may be from other programs. It is for the 2024* convenience of this procedure that all string variables are stored in 2025* a contiguous block. */ 2026 2027 cleanup_strings: proc; 2028 2029 dcl i fixed bin, 2030 p ptr; 2031 2032 p = addrel(bo_pt,program_header -> basic_program_header.string_storage.location); 2033 2034 do i = 1 to fixed(program_header -> basic_program_header.string_storage.number,18); 2035 call deallocate_string(p); 2036 2037 p = addrel(p,1); 2038 end; 2039 2040 /* if the string temporary contains a value, free it */ 2041 2042 call deallocate_string(addr(string_value)); 2043 end; 2044 2045 2046 /* This procedure is called to convert the value in the global variable 2047* "temp(1)" from float binary(27) to the appropriate string representation 2048* in I, F, or E format according to the rules of the language; 2049* the converted value is placed in the global variable "ans". */ 2050 2051 convert_number: proc; 2052 2053 dcl abs_value float bin, 2054 (k,j,ndigits) fixed bin, 2055 dec_value float dec(6), 2056 fixed_dec_value fixed dec(9), 2057 exp fixed bin; 2058 2059 dcl 1 dec_value_overlay aligned based(addr(dec_value)), 2060 2 sign char(1) unaligned, 2061 2 digits char(6) unaligned, 2062 2 skip bit(1) unaligned, 2063 2 exponent fixed bin(7) unaligned; 2064 2065 dcl fixed_digits char(10) aligned based(addr(fixed_dec_value)); 2066 2067 if temp(1) = 0 2068 then do; 2069 ans = " 0"; 2070 return; 2071 end; 2072 2073 abs_value = abs(temp(1)); 2074 2075 if temp(1) < 0 then ans = "-"; else ans = " "; 2076 2077 if abs_value < 134217728 /* 2 ** 27 */ 2078 then if float(fixed(abs_value)) = abs_value 2079 then do; 2080 2081 /* integer format */ 2082 2083 fixed_dec_value = convert(fixed_dec_value,abs_value); 2084 2085 k = verify(substr(fixed_digits,2),"0"); 2086 ans = ans || substr(fixed_digits,k+1); 2087 return; 2088 end; 2089 2090 /* we assume that the following conversion is ROUNDED 2091* and normalized to the left */ 2092 2093 dec_value = convert(dec_value,abs_value); 2094 2095 k = verify(reverse(digits),"0"); 2096 ndigits = 7 - k; 2097 2098 exp = exponent + k - 1; 2099 2100 if exp >= 0 2101 then do; 2102 2103 if exp + ndigits <= 8 2104 then do; 2105 2106 /* due to rounding integer is closest approximation */ 2107 2108 ans = ans || substr(digits,1,ndigits); 2109 2110 if exp > 0 then ans = ans || substr("00000000",1,exp); 2111 2112 return; 2113 end; 2114 2115 /* exponential format */ 2116 2117 e_format: ans = ans || substr(digits,1,1); 2118 ans = ans || "."; 2119 ans = ans || substr(digits,2,ndigits-1); 2120 ans = ans || " E"; 2121 2122 exp = exp + ndigits - 1; 2123 2124 if abs(exp) < 10 2125 then do; 2126 fixed_dec_1 = convert(fixed_dec_1,exp); 2127 ans = ans || fixed_dec_1_overlay; 2128 end; 2129 else do; 2130 fixed_dec_2 = convert(fixed_dec_2,exp); 2131 ans = ans || fixed_dec_2_overlay; 2132 end; 2133 2134 return; 2135 end; 2136 2137 j = ndigits + exp; 2138 2139 if j <= 0 2140 then do; 2141 if ndigits - j > 6 then goto e_format; 2142 2143 ans = ans || "0."; 2144 if j ^= 0 then ans = ans || substr("00000000",1,abs(j)); 2145 ans = ans || substr(digits,1,ndigits); 2146 end; 2147 else do; 2148 ans = ans || substr(digits,1,j); 2149 ans = ans || "."; 2150 ans = ans || substr(digits,j+1,ndigits-j); 2151 end; 2152 2153 end; 2154 2155 /* This function converts the BASIC string specified by pr(1) 2156* to a numeric value in temp(1). "1"b is returned if no 2157* error was found and "0"b is returned if the string was 2158* erroneous. The conversion is attempted twice; if the 2159* first attempt fails, we try again with all white space removed 2160* from the string. This logic attempts to optimize the 2161* simple cases that do not have embedded white space. */ 2162 2163 convert_string: proc returns(bit(1) aligned); 2164 2165 dcl good_string bit(1) aligned; 2166 2167 p1 = get_string_ptr(pr(1)); 2168 good_string = "0"b; 2169 2170 conversion_label = first_error; 2171 temp(1) = convert(temp(1),p1 -> based_vs); 2172 2173 ok: good_string = "1"b; 2174 2175 done: have_conversion_label = (36)"0"b; 2176 return(good_string); 2177 2178 /* had error first time, try again if string contains white space */ 2179 2180 first_error: if search(p1 -> based_vs,white_space) = 0 then goto done; 2181 2182 conversion_label = done; 2183 2184 begin; 2185 2186 dcl copy char(length(p1 -> based_vs)), 2187 (i,j) fixed bin; 2188 2189 copy = ""; 2190 j = 0; 2191 2192 do i = 1 to length(p1 -> based_vs); 2193 if index(white_space,substr(p1 -> based_vs,i,1)) = 0 2194 then do; 2195 2196 /* current char not white space, copy it */ 2197 2198 j = j + 1; 2199 substr(copy,j,1) = substr(p1 -> based_vs,i,1); 2200 end; 2201 end; 2202 2203 temp(1) = convert(temp(1),copy); 2204 end; 2205 2206 goto ok; 2207 end; 2208 2209 /* This procedure is called to obtain a pointer to the string block 2210* specified by the string variable pointed at by the argument ptr "sp". 2211* If the specified string variable is zero, a pointer to the zero 2212* length varying string is returned. */ 2213 2214 get_string_ptr: proc(sp) returns(ptr); 2215 2216 dcl sp ptr, 2217 null_vs char(1) varying static init(""); 2218 2219 if sp -> word = 0 then return(addr(null_vs)); 2220 2221 if sp -> string_word.offset 2222 then return(addr(ptr(string_segment,sp -> string_word.offset) -> basic_string.value)); 2223 2224 return(sp); 2225 end; 2226 2227 /* This procedure is called to make sure that a PRINT-type operation 2228* is valid on the file specified by the global variable "fcb_pt". 2229* The file must be ASCII (or TTY); if the last operation was not 2230* a PRINT, the file is converted to PRINT and the buffers set up. */ 2231 2232 check_print: proc; 2233 2234 call check_ascii (Ascii_output); 2235 2236 if last_operation ^= print_op 2237 then do; 2238 2239 if file_number = 0 then seg_pt = iox_$user_output; 2240 2241 buffer_pos, line_pos = 0; 2242 last_operation = print_op; 2243 end; 2244 2245 end; 2246 2247 /* This procedure is called to make sure that a INPUT-type operation 2248* is valid on the file specified by the global variable "fcb_pt". 2249* The file must be ASCII (or TTY); if the last operation was not 2250* a INPUT, the file is converted to INPUT and more input is gotten. */ 2251 2252 check_input: proc; 2253 2254 call check_ascii (Ascii_input); 2255 2256 if last_operation ^= input_op 2257 then do; 2258 if file_number = 0 then seg_pt = iox_$user_input; 2259 2260 last_operation = input_op; 2261 buffer_pos = buffer_length; 2262 end; 2263 2264 if buffer_pos >= buffer_length 2265 then do; 2266 if file_number = 0 then call prompt; 2267 2268 call get_input(0); 2269 end; 2270 2271 end; 2272 2273 /* This procedure repositions an ascii file to its beginning */ 2274 2275 reset_ascii: proc; 2276 2277 call seg_pt -> iocb.position(seg_pt,-1,0,code); 2278 2279 if code ^= 0 2280 then if code ^= error_table_$no_operation 2281 then goto iox_error; 2282 2283 buffer_pos = buffer_length; 2284 2285 last_operation = reset_op; 2286 end; 2287 2288 /* This procedure prints an input prompt on terminal */ 2289 2290 prompt: proc; 2291 2292 substr(buffer,1,2) = "? "; 2293 call iox_$user_output -> iocb.put_chars(iox_$user_output,buffer_pt,2,code); 2294 2295 end; 2296 2297 /* This procedure is called to make sure that ASCII-type operations 2298* are valid on the file specified by the global variable "fcb_pt". 2299* If the file is not ASCII or TTY, it can be converted to ASCII if 2300* it empty but an error is issued if it is non-empty. */ 2301 2302 check_ascii: proc (new_mode); 2303 2304 dcl new_mode fixed bin; 2305 2306 io_ops_since_margin = io_ops_since_margin + 1; 2307 2308 if file_type = tty_file then return; 2309 2310 if open_mode = new_mode then return; 2311 if open_mode = Ascii_input_output then return; 2312 if file_type = ascii_file then do; /* open the wrong way--close and reopen */ 2313 call open_ascii (new_mode); 2314 return; 2315 end; 2316 2317 /* can convert file to ascii if it is empty */ 2318 2319 /* be sure file is empty */ 2320 if length_of_file (seg_pt) > 0 then goto type_and_usage_conflict; 2321 2322 if file_type >= numeric_file 2323 then call zap_file; 2324 2325 if io_ops_since_margin > 0 then do; 2326 margin = -1; /* reset so we don't use old margin */ 2327 io_ops_since_margin = 0; 2328 end; 2329 2330 call attach_ascii; 2331 call open_ascii (new_mode); 2332 2333 last_operation = 0; 2334 end; 2335 2336 /* This procedure is called to make sure that the file specified by 2337* the global variable "fcb_pt" is RANDOM-NUMERIC. If not, it 2338* is converted if empty or an error is issued if it is non-empty. */ 2339 2340 check_random_numeric: proc (new_mode); 2341 2342 dcl new_mode fixed bin; 2343 2344 io_ops_since_margin = io_ops_since_margin + 1; 2345 2346 if open_mode = new_mode then return; 2347 if open_mode = Numeric_input_output then return; 2348 if file_type = numeric_file then do; /* close and reopen the right way */ 2349 call open_random (new_mode); 2350 return; 2351 end; 2352 2353 if must_be_ascii then goto type_and_usage_conflict; 2354 /* be sure file is empty before converting type */ 2355 2356 if open_mode = Ascii_output then goto type_and_usage_conflict; 2357 /* can't be empty if open for stream_output */ 2358 if length_of_file (seg_pt) > 0 then goto type_and_usage_conflict; 2359 2360 /* if file used to be some other type, we must get rid of 2361* vfile header or vfile won't allow random numeric use */ 2362 2363 if file_type = string_file then call zap_file; 2364 else if file_type = ascii_file then call close_vfile; 2365 2366 call attach_numeric; 2367 call open_random(new_mode); /* this should create file if it doesn't already exist */ 2368 2369 margin = 1; 2370 io_ops_since_margin = 0; 2371 end; 2372 2373 /* This procedure is called to make sure that the file specified by 2374* the global variable "fcb_pt" is RANDOM-STRING. If not, it is 2375* converted if empty or an error is issued if it is non-empty. */ 2376 2377 check_random_string: proc (new_mode); 2378 2379 dcl new_mode fixed bin; 2380 2381 io_ops_since_margin = io_ops_since_margin + 1; 2382 2383 if open_mode = new_mode then return; 2384 if open_mode = String_update then return; 2385 if file_type = string_file then do; 2386 call open_random (new_mode); 2387 return; 2388 end; 2389 2390 if must_be_ascii then goto type_and_usage_conflict; 2391 2392 /* be sure file is empty before converting type */ 2393 2394 if open_mode = Ascii_output then goto type_and_usage_conflict; 2395 /* can't be empty if open for ascii output */ 2396 if length_of_file (seg_pt) > 0 then goto type_and_usage_conflict; 2397 2398 if file_type = numeric_file then call zap_file; /* get rid of old vfile header */ 2399 else if file_type = ascii_file then call close_vfile; 2400 2401 if (io_ops_since_margin > 0) | (margin < 0) then do; 2402 margin = 12; 2403 io_ops_since_margin = 0; 2404 end; 2405 2406 call attach_string; 2407 call open_random (new_mode); /* this should create file if it doesn't already exist */ 2408 2409 end; 2410 2411 /* This function returns the length of a file attached through vfile_. 2412* If the file is not attached, or not attached through vfile_, 2413* 0 is returned. The length is in units appropriate to the type of file. */ 2414 2415 length_of_file: proc (iocbptr) returns (fixed bin (34)); 2416 2417 dcl iocbptr ptr; 2418 2419 if iocbptr = null then return (0); 2420 2421 info (1) = vfs_version_1; 2422 call iox_$control (iocbptr, "file_status", addr (info), code); 2423 if code ^= 0 then return (0); 2424 2425 file_lng = uns_info.end_pos; /* this works for blocked files too */ 2426 if file_lng ^= 0 2427 then if uns_info.type = 1 /* unstructured */ 2428 then if uns_info.flags.header_present /* numeric */ 2429 then file_lng = divide (file_lng, (precision_lng*4), 34, 0); 2430 2431 return (file_lng); 2432 2433 end; 2434 2435 2436 /* This procedure is called to completely wipe out an empty file so that 2437* its type can be changed. We must get rid of the vfile header so vfile 2438* won't give us an error. We don't do this during scratch op because 2439* then we want header (with margin) to stay around. */ 2440 2441 zap_file: proc; 2442 2443 call close_vfile; 2444 if code ^= 0 then goto close_error; 2445 2446 /* truncate by opening for stream_output without append */ 2447 2448 call iox_$attach_iocb (seg_pt, "vfile_ " || file_name, code); 2449 2450 if code = 0 then do; 2451 attached_by_us = "1"b; 2452 call iox_$open (seg_pt, stream_output, "0"b, code); 2453 if code = 0 then opened_by_us = "1"b; 2454 end; 2455 2456 if code ^= 0 then goto open_error; 2457 2458 call close_vfile; /* close this special opening */ 2459 2460 end; 2461 2462 /* This procedure allocates a buffer for an ASCII file */ 2463 2464 get_ascii_buffer: proc; 2465 2466 file_type = ascii_file; 2467 if margin < 0 then margin = 75; 2468 2469 buff_size, buffer_size = default_buffer_size; 2470 2471 quits_disabled = "1"b; 2472 allocate buffer in(string_area); 2473 quits_disabled = "0"b; 2474 2475 if had_quit then call signal_quit; 2476 2477 end; 2478 2479 /* This procedure is called to force the contents of the print 2480* buffer of the ASCII or TTY file specified by the global variable 2481* "fcb_pt". */ 2482 2483 force_buffer: proc; 2484 2485 call seg_pt -> iocb.put_chars(seg_pt,buffer_pt,buffer_pos,code); 2486 if code ^= 0 then goto iox_error; 2487 2488 2489 buffer_pos = 0; 2490 end; 2491 2492 /* This procedure places a at the end of the print buffer of 2493* the file specified by the global variable "fcb_pt" and then 2494* forces the buffer. */ 2495 2496 print_new_line: proc; 2497 2498 if buffer_pos = buffer_size then call force_buffer; 2499 2500 buffer_pos = buffer_pos + 1; 2501 substr(buffer,buffer_pos,1) = NL; 2502 2503 call force_buffer; 2504 2505 line_pos = 0; 2506 end; 2507 2508 /* This procedure appends the varying string pointed at by the 2509* global variable "p1" to the PRINT buffer of the ASCII (or TTY) 2510* file specified by the global variable "fcb_pt". In the case of 2511* the "string_print" entry, the value of "p1" was set by the caller; 2512* in the case of the "numeric_print" entry, the value in global 2513* variable "temp(1)" is converted to string form and "p1" is set 2514* to point at the result of the conversion. This routine worries 2515* about the situations where the string to be PRINTed does not 2516* fit in the space left on the line and where the string is too 2517* big for a completely empty line. */ 2518 2519 numeric_print: proc; 2520 2521 if precision_lng = 1 then call convert_number; 2522 else call d_convert_number; 2523 ans = ans || " "; 2524 p1 = addr(ans); 2525 2526 string_print: entry; 2527 2528 if margin ^= 0 2529 then if line_pos + length(p1 -> based_vs) > margin 2530 then call print_new_line; 2531 2532 do i = 0 repeat(i + k) while("1"b); 2533 n = length(p1 -> based_vs) - i; 2534 2535 k = buffer_size - buffer_pos; 2536 if margin ^= 0 then k = min(k,margin - line_pos); 2537 2538 if k >= n 2539 then do; 2540 substr(buffer,buffer_pos + 1,n) = substr(p1 -> based_vs,i+1,n); 2541 buffer_pos = buffer_pos + n; 2542 line_pos = line_pos + n; 2543 return; 2544 end; 2545 2546 substr(buffer,buffer_pos+1,k) = substr(p1 -> based_vs,i+1,k); 2547 buffer_pos = buffer_pos + k; 2548 line_pos = line_pos + k; 2549 2550 if line_pos = margin then call print_new_line; 2551 else call force_buffer; 2552 end; 2553 2554 end; 2555 2556 /* This procedure is called to close the file specified by the 2557* global variable "fcb_pt". A is placed at the end of a 2558* PRINT file if needed. A scratch file is deleted; the bit 2559* count of a non-scratch segment is computed and the file 2560* is released. */ 2561 2562 close_file: proc(destroy); 2563 2564 dcl destroy bit(1) aligned; 2565 2566 if last_operation = close_op then return; 2567 2568 if last_operation = print_op 2569 then if line_pos ^= 0 2570 then call print_new_line; 2571 2572 code = 0; 2573 2574 call close_vfile; 2575 if destroy 2576 then if code = 0 2577 then if ^must_be_ascii 2578 then call iox_$destroy_iocb (seg_pt, code); 2579 2580 if code ^= 0 then call print_error(157); 2581 2582 if temporary_file then do; 2583 2584 /* A temporary file gets deleted after closing */ 2585 2586 call expand_path_(addr(file_name),length(file_name),addr(dir),addr(ent),code); 2587 call hcs_$delentry_file(dir,ent,code); 2588 2589 if code = error_table_$fulldir 2590 then do; 2591 2592 /* file is multi-segment-file */ 2593 2594 call hcs_$del_dir_tree(dir,ent,code); 2595 2596 if code = 0 then call hcs_$delentry_file(dir,ent,code); 2597 end; 2598 2599 /* ignore other error codes */ 2600 end; 2601 2602 last_operation = close_op; 2603 end; 2604 2605 /* This procedure is called to close all files belonging to 2606* the current object program; any files received as parameters 2607* will not be closed. If the TTY belongs to this object program 2608* and the closing is NORMAL, a will be appended to the 2609* TTY output. */ 2610 2611 close_all_files: proc(normal); 2612 2613 dcl normal bit(1) aligned; 2614 2615 do i = 1 to 16; 2616 fcb_pt = fcb(i); 2617 2618 if fcb_pt ^= null 2619 then if owner = bo_pt 2620 then do; 2621 if fcb_pt -> basic_fcb.seg_pt ^= null 2622 then call close_file("1"b); 2623 2624 quits_disabled = "1"b; 2625 free basic_fcb in(string_area); 2626 quits_disabled = "0"b; 2627 2628 if had_quit then call signal_quit; 2629 end; 2630 end; 2631 2632 if normal 2633 then do; 2634 fcb_pt = fcb(0); 2635 2636 if owner = bo_pt 2637 then do; 2638 if last_operation = print_op 2639 then if line_pos ^= 0 2640 then call print_new_line; 2641 2642 owner = null; 2643 end; 2644 2645 end; 2646 end; 2647 2648 /* This procedure is called to get a line of input for an INPUT 2649* operation on the file specified by the global variable "fcb_pt". 2650* A non-zero argument indicates an error message to be printed if 2651* the file is actually the TTY. */ 2652 2653 get_input: proc(en); 2654 2655 dcl en fixed bin; 2656 2657 if file_type = tty_file 2658 then if en ^= 0 2659 then call print_error(en); 2660 2661 call read_line; 2662 2663 if code = error_table_$end_of_info then goto end_of_file; 2664 end; 2665 2666 /* This procedure is called to read a complete line of input from 2667* an ASCII file. If the line is too long for the buffer associated 2668* with the file, a new buffer of twice the size is obtained and 2669* another read is done. */ 2670 2671 read_line: proc; 2672 2673 dcl bp ptr, 2674 bl fixed bin(21); 2675 2676 call seg_pt -> iocb.get_line(seg_pt,buffer_pt,buffer_size,buffer_length,code); 2677 2678 do while(code ^= 0); 2679 if code ^= error_table_$long_record then return; 2680 2681 if file_type = tty_file then goto input_line_too_long; 2682 if buffer_size >= max_buffer_size then goto input_line_too_long; 2683 2684 old_buff_size = buffer_size; 2685 buffer_size = 2 * old_buff_size; 2686 2687 quits_disabled = "1"b; 2688 allocate buffer in(string_area) set(bp); 2689 substr(bp -> buffer,1,old_buff_size) = substr(buffer,1,old_buff_size); 2690 free buffer in(string_area); 2691 buffer_pt = bp; 2692 quits_disabled = "0"b; 2693 2694 if had_quit then call signal_quit; 2695 2696 call seg_pt -> iocb.get_line(seg_pt,addr(buff2),old_buff_size,bl,code); 2697 2698 buffer_length = buffer_length + bl; 2699 end; 2700 2701 buffer_pos = 0; 2702 end; 2703 2704 /* This procedure is called to open the file whose name is in fcb 2705* specified by global variable fcb_pt. If the file name begins 2706* with ":", it is a Multics switch name; otherwise, the file name 2707* specifies a segment or msf in storage system. If the file exists, 2708* open_file attempts to determine type so it can open file 2709* appropriately; if file doesn't exist, we can't create it */ 2710 2711 open_file: proc; 2712 2713 /* Give special operating system a chance to change file name */ 2714 2715 call basic_file_name_(file_name); 2716 2717 if substr(file_name,1,1) = ":" 2718 then do; 2719 2720 /* file name is Multics switch name */ 2721 2722 if fast_related_data_$in_fast_or_dfast then go to open_error; /* don't allow this mode in FAST */ 2723 2724 must_be_ascii = "1"b; 2725 2726 n = index(file_name," "); 2727 if n = 0 then n = length(file_name) + 1; 2728 2729 call iox_$find_iocb(substr(file_name,2,n-1),seg_pt,code); 2730 if code ^= 0 then goto open_error; 2731 2732 /* we must attach using description given in file name 2733* if iocb is not already attached */ 2734 2735 if seg_pt -> iocb.attach_descrip_ptr = null 2736 then do; 2737 if n > length(file_name) then goto open_error; 2738 2739 do while(substr(file_name,n,1) = " "); 2740 if n >= length(file_name) then goto open_error; 2741 n = n + 1; 2742 end; 2743 2744 call iox_$attach_iocb(seg_pt,substr(file_name,n),code); 2745 if code ^= 0 then goto open_error; 2746 2747 attached_by_us = "1"b; 2748 end; 2749 file_type = ascii_file; 2750 2751 /* open file if not already open, if already open, determine mode */ 2752 2753 p4 = seg_pt -> iocb.open_descrip_ptr; 2754 2755 if p4 ^= null 2756 then do; 2757 if substr(p4 -> based_vs,1,6) ^= "stream" then goto open_error; 2758 2759 n = index(p4 -> based_vs," ") - 1; 2760 if n < 0 then n = length(p4 -> based_vs); 2761 2762 if index(substr(p4 -> based_vs,1,n),"input") ^= 0 then open_mode = Ascii_input; 2763 if index(substr(p4 -> based_vs,1,n),"output") ^= 0 then do; 2764 if open_mode = Ascii_input 2765 then open_mode = Ascii_input_output; 2766 else open_mode = Ascii_output; 2767 write_permission = "1"b; 2768 end; 2769 2770 end; 2771 2772 call get_ascii_buffer; 2773 end; 2774 else do; 2775 2776 /* file is segment or msf in storage system */ 2777 2778 must_be_ascii = "0"b; 2779 2780 call expand_path_(addr(file_name),length(file_name),addr(dir),addr(ent),code); 2781 2782 if code ^= 0 then goto file_error; 2783 2784 call hcs_$status_(dir,ent,1,addr(status_info_branch),null,code); 2785 2786 if code ^= 0 2787 then do; 2788 2789 /* if file does not exist, we cannot create it until 2790* we know what type it is to be. */ 2791 2792 if code ^= error_table_$noentry then goto open_error; 2793 write_permission = "1"b; /* can write if we create */ 2794 2795 return; 2796 end; 2797 2798 write_permission = substr (mode,4,1); 2799 if status_info_branch.type = "10"b /* directory */ 2800 then do; 2801 must_be_ascii = "1"b; /* to keep close from truncating */ 2802 call attach_ascii; 2803 end; 2804 else do; 2805 2806 /* we must have at least 'r' permission on segment */ 2807 2808 if substr(mode,2,1) = "0"b then goto open_error; 2809 2810 /* determine type and open */ 2811 2812 info(1) = vfs_version_1; /* set version number */ 2813 call vfile_status_ (dir, ent, addr(info), code); 2814 if code ^= 0 then go to open_error; /* can't do anything */ 2815 2816 2817 /* check for old format random files and convert if necessary */ 2818 2819 if uns_info.type = 1 2820 then if ^uns_info.flags.header_present 2821 then do; 2822 2823 call convert_old_basic_file_ (dir, ent, code); 2824 if code = 0 then do; 2825 2826 call ioa_ ("Converted file ^a to new format.", file_name); 2827 call vfile_status_(dir, ent, addr(info), code); 2828 end; 2829 2830 else if code = error_table_$not_done 2831 then do; 2832 call attach_ascii; 2833 return; 2834 end; 2835 else do; 2836 call ioa_ ("Unable to convert old format file ^a to new format.", file_name); 2837 go to open_error; 2838 end; 2839 2840 end; 2841 2842 if blk_info.type = 3 then do; 2843 margin = blk_info.max_rec_len; 2844 call attach_string; 2845 end; 2846 2847 else if uns_info.type ^= 1 2848 then goto type_and_usage_conflict; 2849 else do; 2850 if ^uns_info.flags.header_present then call attach_ascii; 2851 2852 else do; 2853 if uns_info.header_id ^= precision_lng then goto type_and_usage_conflict; 2854 margin = 1; 2855 call attach_numeric; 2856 end; 2857 end; 2858 end; 2859 2860 end; 2861 2862 end; 2863 2864 /* This procedure specifies the attachment options for a terminal format file. 2865* Opening is done when the file is actually referenced. */ 2866 2867 attach_ascii: proc; 2868 2869 call attach_vfile ("vfile_ " || rtrim(file_name) || " -append " || ascii_size_op); 2870 2871 call get_ascii_buffer; 2872 2873 file_type = ascii_file; 2874 2875 end; 2876 2877 /* This procedure specifies the attachment options for a random numeric file. 2878* Opening is done when the file is actually referenced. */ 2879 2880 attach_numeric: proc; 2881 2882 call attach_vfile ("vfile_ " || rtrim(file_name) || " -no_trunc -header " || header_numbers(precision_lng) || " -ssf"); 2883 2884 file_type = numeric_file; 2885 2886 end; 2887 2888 /* This procedure specifies the attachment options for a random string file. 2889* Opening is done when the file is actually referenced. */ 2890 2891 attach_string: proc; 2892 2893 dcl k fixed bin; 2894 dcl fixed_dec_value fixed dec(7); 2895 dcl fixed_digits char(8) aligned based(addr(fixed_dec_value)); 2896 2897 fixed_dec_value = convert(fixed_dec_value, margin); 2898 k = verify (substr (fixed_digits, 2), "0"); 2899 2900 call attach_vfile ("vfile_ " || rtrim(file_name) || " -blocked " || substr(fixed_digits, k+1) || " -ssf"); 2901 2902 file_type = string_file; 2903 2904 end; 2905 2906 /* This procedure is called to attach a file via the vfile_ 2907* IO module using a unique stream name of the form basic.xxxx */ 2908 2909 attach_vfile: proc(attach_descrip); 2910 2911 dcl attach_descrip char(*); 2912 2913 attached_by_us = "1"b; 2914 2915 if seg_pt = null then do; 2916 call iox_$find_iocb(unique(),seg_pt,code); 2917 if code ^= 0 then goto open_error; 2918 end; 2919 2920 call iox_$attach_iocb (seg_pt, attach_descrip, code); 2921 if code ^= 0 then goto open_error; 2922 2923 end; 2924 2925 /* This procedure returns a string of the form 2926* basic.nnnnnn 2927* where the decimal number nnnnnn is incremented 2928* by 1 each time unique is called. */ 2929 2930 unique: proc returns(char(12)); 2931 2932 dcl unique_count fixed dec(6) static init(0), 2933 1 unique_value static, 2934 2 header char(6) init("basic."), 2935 2 count picture "999999"; 2936 2937 unique_count = unique_count + 1; 2938 unique_value.count = unique_count; 2939 2940 return(string(unique_value)); 2941 end; 2942 2943 /* This procedure opens an ascii file. If the file is already open, it must 2944* be closed first. */ 2945 2946 open_ascii: proc (new_open_mode); 2947 2948 dcl new_open_mode fixed bin; 2949 2950 if open_mode > Not_open then do; 2951 if ^opened_by_us then goto open_error; 2952 call iox_$close (seg_pt, code); 2953 if code ^= 0 then goto open_error; 2954 end; 2955 2956 call iox_$open (seg_pt, open_types (new_open_mode), "0"b, code); 2957 if code ^= 0 then goto open_error; 2958 2959 opened_by_us = "1"b; 2960 open_mode = new_open_mode; 2961 end; 2962 2963 2964 /* This procedure opens a random numeric or string file. If the file is already open, 2965* the current position must be remembered, the file must be closed, and the 2966* position must be restored after reopening. */ 2967 2968 open_random: proc (new_open_mode); 2969 2970 dcl new_open_mode fixed bin; 2971 2972 if open_mode > Not_open then do; 2973 if ^opened_by_us then goto open_error; 2974 call iox_$control (seg_pt, "read_position", addr(position_info), code); 2975 if code ^= 0 then goto open_error; 2976 buff_size = position_info.next_position; 2977 call iox_$close (seg_pt, code); 2978 if code ^= 0 then goto open_error; 2979 end; 2980 2981 call iox_$open (seg_pt, open_types (new_open_mode), "0"b, code); 2982 if code ^= 0 then goto open_error; 2983 2984 opened_by_us = "1"b; /* set so we can close */ 2985 2986 if open_mode > Not_open then do; 2987 call iox_$position (seg_pt, 2, buff_size, code); 2988 if code ^= 0 then goto pointer_error; 2989 end; 2990 2991 open_mode = new_open_mode; 2992 2993 end; 2994 2995 2996 /* This procedure is called to close a file. The file is closed 2997* and detached (if we opened or attached), and for ascii files 2998* the buffer is freed. */ 2999 3000 close_vfile: proc; 3001 3002 if seg_pt ^= null then do; /* sometimes this gets called with seg_pt=null! */ 3003 if seg_pt -> iocb.open_descrip_ptr ^= null & opened_by_us 3004 then do; 3005 call seg_pt -> iocb.close(seg_pt,code); 3006 if code ^= 0 then return; 3007 opened_by_us = "0"b; 3008 open_mode = Not_open; 3009 end; 3010 3011 if seg_pt -> iocb.attach_descrip_ptr ^= null & attached_by_us 3012 then do; 3013 call seg_pt -> iocb.detach_iocb(seg_pt,code); 3014 if code ^= 0 then return; 3015 attached_by_us = "0"b; 3016 end; 3017 end; 3018 3019 if buffer_pt ^= null then do; 3020 quits_disabled = "1"b; 3021 free buffer in(string_area); 3022 buffer_pt = null; 3023 quits_disabled = "0"b; 3024 end; 3025 3026 if had_quit then call signal_quit; 3027 3028 file_type = undefined_file; 3029 end; 3030 3031 3032 /* This procedure is called to tab to the indicated position on 3033* the PRINT file specified by the global variable "fcb_pt". */ 3034 3035 tab: proc(new_pos); 3036 3037 dcl new_pos fixed bin; 3038 3039 if margin = 0 then n = new_pos; 3040 else n = mod(new_pos, margin); 3041 3042 n = n - line_pos; 3043 3044 do while(n > 0); 3045 k = min(buffer_size - buffer_pos,n); 3046 substr(buffer,buffer_pos+1,k) = ""; 3047 buffer_pos = buffer_pos + k; 3048 3049 if buffer_pos = buffer_size then call force_buffer; 3050 3051 n = n - k; 3052 end; 3053 3054 line_pos = new_pos; 3055 end; 3056 3057 /* This procedure sets the global variable "n" to the file number 3058* specified by the global variable "temp(1)". An error is issued 3059* if the file number is invalid, no file exists for the specified 3060* number, or if the file is of the wrong type as indicated by the 3061* argument "ok_type". */ 3062 3063 get_file_number: proc(ok_type); 3064 3065 dcl ok_type bit(5) aligned; 3066 3067 n = fixed(temp(1)); 3068 3069 if n < 0 then goto invalid_file_number; 3070 if n > 16 then goto invalid_file_number; 3071 3072 if fcb(n) = null then goto invalid_file_number; 3073 3074 if substr(ok_type,fcb(n) -> file_type,1) = "0"b then goto invalid_file_number; 3075 end; 3076 3077 /* This procedure writes the value in the global variable "temp(1)" 3078* into the next position in the RANDOM NUMERIC file specified 3079* by the global variable "fcb_pt". An endfile is generated if the 3080* max length of the file is exceeded. */ 3081 3082 numeric_write: proc; 3083 3084 call iox_$put_chars (seg_pt, addr(temp(1)), 4, code); 3085 3086 if code ^= 0 then goto end_of_file; /* msg should really reflect code */ 3087 3088 end; 3089 3090 /* This procedure writes the varying string pointed at by the 3091* global variable "p1" into the next position in the RANDOM 3092* STRING file specified by the global variable "fcb_pt". 3093* An endfile is generated if the max length of the file is exceeded. */ 3094 3095 string_write: proc; 3096 3097 call iox_$write_record (seg_pt, addrel(p1,1), min(length(p1->based_vs), margin), code); 3098 3099 if code ^= 0 then goto end_of_file; /* should improve to use code */ 3100 3101 end; 3102 3103 /* This procedures sets the global variable "temp(1)" to the value 3104* in the next position in the RANDOM NUMERIC file specified by 3105* the global variable "fcb_pt". */ 3106 3107 numeric_read: proc; 3108 3109 call iox_$get_chars (seg_pt, addr(temp(1)), 4, buff_size, code); 3110 3111 if code ^= 0 then go to end_of_file; 3112 3113 end; 3114 3115 /* This procedure sets the global variable "p1" to point to 3116* the next string in the RANDOM STRING file specified by 3117* the global variable "fcb_pt". A new string block is allocated. */ 3118 3119 string_read: proc; 3120 3121 call iox_$read_record (seg_pt, addr(string_buffer), 4096, buff_size, code); 3122 if code ^= 0 then goto end_of_file; 3123 3124 n = buff_size; 3125 call allocate_string; 3126 p3 -> basic_string.value = substr(string_buffer, 1, n); 3127 3128 end; 3129 3130 /* This procedure is called when a string value is to be returned 3131* to the object program. The global variable "string_value" is set to 3132* the offset of the string block in the string segment and PR1 3133* is set to point at "string_value". */ 3134 3135 return_string: proc; 3136 3137 call deallocate_string(addr(string_value)); 3138 3139 string_value = rel(p3); 3140 pr(1) = addr(string_value); 3141 3142 end; 3143 3144 /* This procedure is called to read a numeric value from the 3145* file specified by the global variable "fcb_pt". The "conversion" 3146* condition is handled by setting the global variable "conversion_label" 3147* before the conversion; after the conversion is completed the 3148* global label is set to "null" by zeroing out the first word. 3149* The value read will be stored in the global variable "temp(1)". */ 3150 3151 numeric_input: proc; 3152 3153 no_input = "1"b; 3154 3155 num: if buffer_pos >= buffer_length - 1 then return; 3156 3157 n = 0; 3158 do while(buffer_pos < buffer_length); 3159 buffer_pos = buffer_pos + 1; 3160 3161 ch = substr(buffer,buffer_pos,1); 3162 3163 if ch = "," then goto ni_done; 3164 if ch = NL then goto ni_done; 3165 3166 if mat_input 3167 then if substr(buffer,buffer_pos,2) = amp_NL 3168 then do; 3169 3170 /* make sure we see & at beginning of next request */ 3171 3172 buffer_pos = buffer_pos - 1; 3173 goto ni_done; 3174 end; 3175 3176 if search(ch,white_space) = 0 3177 then do; 3178 n = n + 1; 3179 substr(c32,n,1) = ch; 3180 end; 3181 end; 3182 3183 /* there was no NL at end of input line */ 3184 3185 if file_type ^= tty_file then goto incorrect_format_for_file_input; 3186 3187 call get_input(-110); 3188 goto num; 3189 3190 ni_done: if n = 0 3191 then do; 3192 if ch = "," then goto num; 3193 if ch ^= "&" then return; 3194 3195 if file_type = tty_file then call prompt; 3196 3197 call get_input(0); 3198 goto num; 3199 end; 3200 3201 if file_type = tty_file 3202 then if substr(c32,1,1) = "s" | substr(c32,1,1) = "S" 3203 then do; 3204 call print_error(109); 3205 goto abort_label; 3206 end; 3207 3208 conversion_label = bad_ni; 3209 3210 if precision_lng = 1 then temp(1) = convert(temp(1),substr(c32,1,n)); 3211 else d_temp(1) = convert(d_temp(1),substr(c32,1,n)); 3212 3213 have_conversion_label = "0"b; 3214 no_input = "0"b; 3215 return; 3216 3217 bad_ni: if file_type ^= tty_file then goto incorrect_format_for_file_input; 3218 3219 /* special case this message because an extra string is printed */ 3220 call ioa_$nnl ("Incorrect numeric input in ^d, retype beginning with ^a^/?", 3221 get_line_number(), substr(c32, 1, n)); 3222 call get_input(0); 3223 goto num; 3224 end; 3225 3226 /* This procedure is called to read a string value from the file 3227* specified by the global variable "fcb_pt". The global variable 3228* "p3" will point to the string block for the new value. */ 3229 3230 string_input: proc; 3231 3232 no_input = "1"b; 3233 3234 str: if buffer_pos >= buffer_length - 1 then return; 3235 3236 n = verify(substr(buffer,buffer_pos+1,buffer_length-buffer_pos),white_space); 3237 3238 if n = 0 3239 then do; 3240 if file_type ^= tty_file then goto incorrect_format_for_file_input; 3241 3242 call get_input(-110); 3243 goto str; 3244 end; 3245 3246 buffer_pos = buffer_pos + n; 3247 3248 if substr(buffer,buffer_pos,1) = """" 3249 then do; 3250 3251 /* pick up quoted string */ 3252 3253 buffer_pos = buffer_pos + 1; 3254 3255 k = index(substr(buffer,buffer_pos,buffer_length-buffer_pos+1),""""); 3256 3257 if k = 0 3258 then do; 3259 si_bad: if file_type ^= tty_file then goto incorrect_format_for_file_input; 3260 3261 call ioa_$nnl ("Incorrect string input in ^d, retype beginning with ^a^/?", 3262 get_line_number(), substr(buffer, buffer_pos-1, buffer_length-buffer_pos+1)); 3263 call get_input(0); 3264 goto str; 3265 end; 3266 3267 n = k-1; 3268 end; 3269 else do; 3270 3271 /* pick up string terminated by a comma or NL */ 3272 3273 k = search(substr(buffer,buffer_pos,buffer_length-buffer_pos+1),comma_NL); 3274 3275 if k = 0 then goto si_bad; 3276 3277 n, k = k - 1; 3278 3279 if n = 0 3280 then if substr(buffer,buffer_pos,1) = "," 3281 then goto str; 3282 else return; 3283 3284 if mat_input 3285 then if substr(buffer,buffer_pos+k-1,2) = amp_NL 3286 then if k > 1 then n = n - 1; 3287 else do; 3288 call get_input(0); 3289 goto str; 3290 end; 3291 3292 end; 3293 3294 call allocate_string; 3295 p3 -> basic_string.value = substr(buffer,buffer_pos,n); 3296 3297 buffer_pos = buffer_pos + k; 3298 3299 no_input = "0"b; 3300 end; 3301 3302 /* This procedure is called to do a LINPUT operation on the file 3303* specified by the global variable "fcb_pt". The global variable 3304* "p3" will be set to point to the string block for the line that 3305* was read. */ 3306 3307 linput: proc; 3308 3309 n = buffer_length - buffer_pos - 1; 3310 if n < 0 then n = 0; 3311 3312 call allocate_string; 3313 3314 p3 -> basic_string.value = substr(buffer,buffer_pos+1,n); 3315 3316 buffer_pos = buffer_length; 3317 end; 3318 3319 /* The procedure is called when an 8 character string is to be 3320* returned to the object program; the value to be used is in 3321* the global variable "c8". */ 3322 3323 use_c8: proc; 3324 3325 n = 8; 3326 call allocate_string; 3327 p3 -> basic_string.value = c8; 3328 call return_string; 3329 end; 3330 3331 /* This procedure is called to do the looping required to do the 3332* matrix operation indicated by the argument "action_code". 3333* Global variable PR2 points at the array dope. */ 3334 3335 mat_loop: proc(action_code); 3336 3337 dcl action_code fixed bin; 3338 3339 dcl (row,row_max,col,col_max,i) fixed bin, 3340 data_pt ptr, 3341 vector bit(1) aligned; 3342 3343 row_max = pr(2) -> current_bounds(1) - 1; 3344 if row_max <= 0 then goto array_error; 3345 3346 col_max = pr(2) -> current_bounds(2); 3347 if col_max = 0 then goto array_error; 3348 3349 if col_max < 0 3350 then do; 3351 vector = "1"b; 3352 col_max = 1; 3353 i = 1; 3354 3355 if action_code <= 2 3356 then if a_reg = 0 3357 then row_max = pr(2) -> original_bounds(1) - 1; 3358 end; 3359 else do; 3360 vector = "0"b; 3361 col_max = col_max - 1; 3362 i = col_max + 2; 3363 end; 3364 3365 data_pt = pr(2) -> array_dope.data; 3366 3367 do row = 1 to row_max; 3368 do col = 1 to col_max; 3369 3370 goto mat(action_code); 3371 3372 /* numeric input */ 3373 3374 mat(1): call numeric_input; 3375 3376 if no_input 3377 then do; 3378 if vector & a_reg = 0 3379 then do; 3380 pr(2) -> current_bounds(1) = number_read + 1; 3381 return; 3382 end; 3383 3384 do while(no_input); 3385 call get_input(-107); 3386 call numeric_input; 3387 end; 3388 end; 3389 3390 number_read = number_read + 1; 3391 3392 data_pt -> float_bin(i) = temp(1); 3393 goto next_mat; 3394 3395 /* string input */ 3396 3397 mat(2): call string_input; 3398 3399 if no_input 3400 then do; 3401 if vector & a_reg = 0 3402 then do; 3403 pr(2) -> current_bounds(1) = number_read + 1; 3404 return; 3405 end; 3406 3407 do while(no_input); 3408 call get_input(-107); 3409 call string_input; 3410 end; 3411 end; 3412 3413 call deallocate_string(addr(data_pt -> bit_word(i))); 3414 3415 number_read = number_read + 1; 3416 3417 data_pt -> bit_word(i) = rel(p3); 3418 goto next_mat; 3419 3420 /* numeric print */ 3421 3422 mat(3): temp(1) = data_pt -> float_bin(i); 3423 call numeric_print; 3424 3425 call mat_print_format_check; 3426 goto next_mat; 3427 3428 /* string print */ 3429 3430 mat(4): p1 = get_string_ptr(addr(data_pt -> bit_word(i))); 3431 call string_print; 3432 3433 call mat_print_format_check; 3434 goto next_mat; 3435 3436 /* numeric data read */ 3437 3438 mat(5): if numeric_data.start >= numeric_data.finish then goto out_of_data; 3439 3440 data_pt -> float_bin(i) = text_base_ptr -> float_bin(numeric_data.start); 3441 3442 numeric_data.start = numeric_data.start + 1; 3443 goto next_mat; 3444 3445 /* string data read */ 3446 3447 mat(6): if string_data.start >= string_data.finish then goto out_of_data; 3448 3449 call deallocate_string(addr(data_pt -> bit_word(i))); 3450 3451 p1 = addr(text_base_ptr -> bit_word(text_base_ptr -> fix_bin(string_data.start))); 3452 n = length(p1 -> based_vs); 3453 3454 call allocate_string; 3455 p3 -> basic_string.value = p1 -> based_vs; 3456 3457 data_pt -> bit_word(i) = rel(p3); 3458 3459 string_data.start = string_data.start + 1; 3460 goto next_mat; 3461 3462 /* numeric read */ 3463 3464 mat(7): call numeric_read; 3465 data_pt -> float_bin(i) = temp(1); 3466 goto next_mat; 3467 3468 /* string read */ 3469 3470 mat(8): call deallocate_string(addr(data_pt -> bit_word(i))); 3471 3472 call string_read; 3473 data_pt -> bit_word(i) = rel(p3); 3474 goto next_mat; 3475 3476 /* numeric write */ 3477 3478 mat(9): temp(1) = data_pt -> float_bin(i); 3479 call numeric_write; 3480 goto next_mat; 3481 3482 /* string write */ 3483 3484 mat(10): p1 = get_string_ptr(addr(data_pt -> bit_word(i))); 3485 call string_write; 3486 goto next_mat; 3487 3488 /* linput */ 3489 3490 mat(11): call deallocate_string(addr(data_pt -> bit_word(i))); 3491 3492 call check_input; /* get next line */ 3493 call linput; 3494 3495 data_pt -> bit_word(i) = rel(p3); 3496 goto next_mat; 3497 3498 /* numeric print using */ 3499 3500 mat(12): temp(1) = data_pt -> float_bin(i); 3501 call print_using_numeric; 3502 call mat_print_using_check; 3503 goto next_mat; 3504 3505 /* string print using */ 3506 3507 mat(13): p1 = get_string_ptr(addr(data_pt -> bit_word(i))); 3508 call print_using_string; 3509 call mat_print_using_check; 3510 goto next_mat; 3511 3512 /* set string matrix to nul */ 3513 3514 mat(14): call deallocate_string(addr(data_pt -> bit_word(i))); 3515 data_pt -> bit_word(i) = "0"b; 3516 goto next_mat; 3517 3518 /* mat a$ = b$ */ 3519 3520 mat(15): pr(3) = addr(data_pt -> bit_word(i)); 3521 pr(1) = addr(p4 -> bit_word(i)); 3522 call string_assign; 3523 goto next_mat; 3524 3525 next_mat: i = i + 1; 3526 end; 3527 3528 if ^ vector then i = i + 1; 3529 end; 3530 3531 mat_print_format_check: proc; 3532 3533 if col ^= col_max then call mat_print_format; 3534 else if vector 3535 then if row ^= row_max 3536 then call mat_print_format; 3537 else call print_new_line; 3538 else call print_new_line; 3539 3540 end; 3541 3542 mat_print_format: proc; 3543 3544 if a_reg = 0 then call print_new_line; 3545 else if a_reg = 1 3546 then call tab(divide(line_pos + 15,15,17,0)*15); 3547 3548 end; 3549 3550 mat_print_using_check: proc; 3551 3552 if col = col_max 3553 then if ^ vector 3554 then do; 3555 call print_new_line; 3556 pu_pos = 0; 3557 end; 3558 3559 end; 3560 3561 end; 3562 3563 /* This procedure is called at the end of an INPUT operation on 3564* the file specified by the global variable "fcb_pt". It 3565* verifies that no unexpected data values were provided. */ 3566 3567 end_input: proc; 3568 3569 if buffer_pos < buffer_length 3570 then if verify(substr(buffer,buffer_pos+1,buffer_length-buffer_pos-1),", ") ^= 0 3571 then call print_error(108); 3572 3573 buffer_pos = buffer_length; 3574 end; 3575 3576 /* This procedure writes its string argument, a character at a 3577* time, into the file indicated by the global variable "fcb_pt". */ 3578 3579 put_string: proc(s); 3580 3581 dcl s char(*) aligned; 3582 3583 dcl si fixed bin; 3584 3585 do si = 1 to length(s); 3586 call put_char(substr(s,si,1)); 3587 end; 3588 3589 end; 3590 3591 /* This procedure writes a single character into the print buffer 3592* of the file specified by the global variable "fcb_pt". */ 3593 3594 put_char: proc(c); 3595 3596 dcl c char(1) aligned; 3597 3598 if buffer_pos = buffer_size then call force_buffer; 3599 3600 if margin ^= 0 3601 then if line_pos = margin 3602 then call print_new_line; 3603 3604 line_pos = line_pos + 1; 3605 3606 buffer_pos = buffer_pos + 1; 3607 substr(buffer,buffer_pos,1) = c; 3608 3609 end; 3610 3611 3612 /* This procedure is called to identify the next field in a 3613* PRINT USING string; the argument indicates if this is the 3614* end of the PRINT USING operation. Data about the field that 3615* was found is left in the global variables "field_length", "field_start", 3616* "precision", "scale", "exp_length", "left_just", and "right_just". 3617* Any characters that precede the start of the field are written 3618* into the output buffer of the file specified by global variable 3619* "fcb_pt". */ 3620 3621 get_next_field: proc(end_scan); 3622 3623 dcl end_scan bit(1) aligned; 3624 3625 dcl here_before bit(1); 3626 3627 here_before = "0"b; 3628 3629 field_length, 3630 field_start, 3631 precision, 3632 scale, 3633 exp_length = 0; 3634 3635 string(print_using_bits) = "0"b; 3636 3637 next_char: pu_pos = pu_pos + 1; 3638 3639 if pu_pos > pu_length 3640 then do; 3641 if field_start ^= 0 then goto end_field; 3642 3643 if end_scan then return; 3644 3645 if here_before then goto print_using_error; 3646 3647 here_before = "1"b; 3648 call print_new_line; 3649 pu_pos = 0; 3650 goto next_char; 3651 end; 3652 3653 goto case(index("<>$+-#^.",substr(pu_string,pu_pos,1))); 3654 3655 /* not special character */ 3656 3657 case(0): if field_start = 0 then call put_char(substr(pu_string,pu_pos,1)); 3658 else field_length = field_length + 1; 3659 3660 goto next_char; 3661 3662 /* < */ 3663 3664 case(1): if field_start ^= 0 then goto end_field; 3665 3666 left_just = "1"b; 3667 3668 case1a: field_start = pu_pos; 3669 field_length = field_length + 1; 3670 goto next_char; 3671 3672 /* > */ 3673 3674 case(2): if field_start ^= 0 then goto end_field; 3675 3676 right_just = "1"b; 3677 goto case1a; 3678 3679 /* $ */ 3680 3681 case(3): if field_start ^= 0 then goto end_field; 3682 3683 have_dollar = "1"b; 3684 3685 field_start = pu_pos; 3686 field_length = field_length + 1; 3687 3688 /* make sure $ is followed by + or - */ 3689 3690 if pu_pos = pu_length then goto print_using_error; 3691 3692 if substr(pu_string,pu_pos+1,1) = "+" then have_plus = "1"b; 3693 else do; 3694 have_minus = "1"b; /* - is assumed when there is no control */ 3695 if substr(pu_string,pu_pos+1, 1) ^= "-" then go to next_char; 3696 end; 3697 3698 pu_pos = pu_pos + 1; 3699 3700 field_length = field_length + 1; 3701 goto next_char; 3702 3703 /* + */ 3704 3705 case(4): if field_start ^= 0 then goto end_field; 3706 3707 have_plus = "1"b; 3708 goto case1a; 3709 3710 /* - */ 3711 3712 case(5): if field_start ^= 0 then goto end_field; 3713 3714 have_minus = "1"b; 3715 goto case1a; 3716 3717 /* # */ 3718 3719 case(6): if exp_length ^= 0 then goto end_field; 3720 3721 if field_start = 0 then goto print_using_error; 3722 3723 field_length = field_length + 1; 3724 precision = precision + 1; 3725 3726 if have_decimal then scale = scale + 1; 3727 goto next_char; 3728 3729 /* ^ */ 3730 3731 case(7): if field_start = 0 then goto print_using_error; 3732 3733 exp_length = exp_length + 1; 3734 field_length = field_length + 1; 3735 goto next_char; 3736 3737 /* . */ 3738 3739 case(8): if field_start = 0 then call put_char(ch); 3740 else do; 3741 if have_decimal then goto print_using_error; 3742 3743 have_decimal = "1"b; 3744 field_length = field_length + 1; 3745 end; 3746 3747 goto next_char; 3748 3749 end_field: if exp_length ^= 0 3750 then do; 3751 if exp_length ^= 5 then goto print_using_error; 3752 have_exp = "1"b; 3753 end; 3754 3755 pu_pos = pu_pos - 1; 3756 end; 3757 3758 /* This procedure is called to put out the numeric value in the 3759* global variable "temp(1)" on file specified by global variable 3760* "fcb_pt" according to the next field in the PRINT USING string. 3761* The "size" condition is handled by setting the global label 3762* variable "size_label" which is recognized by the default 3763* handler; the label is reset after the conversion by setting 3764* its first word to zero. */ 3765 3766 print_using_numeric: proc; 3767 3768 dcl zero_surpression bit(1), 3769 exp fixed bin, 3770 float_sign aligned char(1); 3771 3772 dcl 1 decimal_value based(addr(c64)) aligned, 3773 2 sign char(1) unal, 3774 2 digit(precision) char(1) unal, 3775 2 skip bit(1) unal, 3776 2 exponent fixed bin(7) unal; 3777 3778 call get_next_field("0"b); 3779 3780 if left_just then goto print_using_error; 3781 if right_just then goto print_using_error; 3782 3783 if scale > 38 then goto punt; 3784 3785 if exp_length = 0 3786 then do; 3787 3788 /* f format */ 3789 3790 if have_minus 3791 then if temp(1) >= 0 3792 then precision = precision + 1; 3793 3794 if precision = 0 then goto punt; 3795 3796 size_label = punt; 3797 3798 call assign_round_(addr(c64),18,fixed(scale * 1000000000000000000b + precision,35), 3799 addr(temp(1)),6,27); 3800 3801 have_size_label = (36)"0"b; 3802 end; 3803 else do; 3804 3805 /* e format, we assume the following conversion 3806* produces a left justified result */ 3807 3808 if precision = 0 then precision = 1; 3809 3810 call assign_round_(addr(c64),20,precision,addr(temp(1)),6,27); 3811 3812 if temp(1) = 0 then exp = 0; 3813 else exp = exponent + scale; 3814 end; 3815 3816 zero_surpression = ^ have_exp; 3817 3818 digit_count = 0; 3819 digit_pos = 0; 3820 3821 do field_pos = field_start to field_start+field_length - 1; 3822 ch = substr(pu_string,field_pos,1); 3823 goto case(index("$+-#^.",ch)); 3824 3825 case(0): if zero_surpression then ch = " "; 3826 goto place; 3827 3828 /* $ */ 3829 3830 case(1): goto next; 3831 3832 /* + */ 3833 3834 case(2): float_sign = decimal_value.sign; 3835 3836 if have_exp then call put_char(float_sign); 3837 3838 goto next; 3839 3840 /* - */ 3841 3842 case(3): if temp(1) < 0 then goto case(2); 3843 3844 float_sign = " "; 3845 3846 if have_exp 3847 then do; 3848 call put_char(float_sign); 3849 goto next; 3850 end; 3851 3852 /* # */ 3853 3854 case(4): digit_pos = digit_pos + 1; 3855 ch = digit(digit_pos); 3856 3857 if zero_surpression 3858 then if ch ^= "0" | digit_pos = precision - scale | have_exp 3859 then call end_surpression; 3860 else ch = " "; 3861 else digit_count = digit_count + 1; 3862 3863 if digit_count > 8 then ch = "?"; 3864 3865 goto place; 3866 3867 /* ^ */ 3868 3869 case(5): call put_string(" E"); 3870 3871 if abs(exp) < 10 3872 then do; 3873 fixed_dec_1 = convert(fixed_dec_1,exp); 3874 call put_string(fixed_dec_1_overlay); 3875 call put_char(" "); 3876 end; 3877 else do; 3878 fixed_dec_2 = convert(fixed_dec_2,exp); 3879 call put_string(fixed_dec_2_overlay); 3880 end; 3881 3882 field_pos = field_pos + 4; 3883 goto next; 3884 3885 /* . */ 3886 3887 case(6): if zero_surpression 3888 then do; 3889 call end_surpression; 3890 if float_sign = " " then call put_char("0"); 3891 end; 3892 3893 place: call put_char(ch); 3894 3895 next: end; 3896 3897 return; 3898 3899 punt: have_size_label = (36)"0"b; 3900 3901 do field_pos = field_start to field_start+field_length - 1; 3902 ch = substr(pu_string,field_pos,1); 3903 3904 if index("$+-#^",ch) ^= 0 then ch = "*"; 3905 3906 call put_char(ch); 3907 end; 3908 3909 3910 end_surpression: proc; 3911 3912 if have_dollar then call put_char("$"); 3913 3914 if float_sign ^= " " then call put_char(float_sign); 3915 3916 zero_surpression = "0"b; 3917 end; 3918 3919 end; 3920 3921 /* This procedure is called to output the string value specified by 3922* the global pointer "p1" on the file specified by the global 3923* variable "fcb_pt" according to the next field in the PRINT USING 3924* string. */ 3925 3926 print_using_string: proc; 3927 3928 dcl (n_spaces,s_pos) fixed bin; 3929 3930 call get_next_field("0"b); 3931 3932 if right_just 3933 then do; 3934 n_spaces = precision + 1 - length(p1 -> based_vs); 3935 3936 if n_spaces >= 0 then s_pos = 0; 3937 else s_pos = - n_spaces; 3938 end; 3939 else if left_just 3940 then n_spaces, s_pos = 0; 3941 else goto print_using_error; 3942 3943 do field_pos = field_start to field_start + field_length - 1; 3944 ch = substr(pu_string,field_pos,1); 3945 3946 if index("<>#",ch) ^= 0 3947 then if n_spaces > 0 3948 then do; 3949 ch = " "; 3950 n_spaces = n_spaces - 1; 3951 end; 3952 else do; 3953 s_pos = s_pos + 1; 3954 3955 if s_pos > length(p1 -> based_vs) then ch = " "; 3956 else ch = substr(p1 -> based_vs,s_pos,1); 3957 end; 3958 3959 call put_char(ch); 3960 end; 3961 3962 end; 3963 3964 /* This procedure is called to resignal the quit condition because 3965* a quit occurred while quits were inhibited */ 3966 3967 signal_quit: proc; 3968 3969 dcl quit condition; 3970 3971 had_quit = "0"b; 3972 signal quit; 3973 3974 end; 3975 3976 3977 /* This procedure is called to convert the value in the global variable 3978* "temp(1)" from float binary(27) to the appropriate string representation 3979* in I, F, or E format according to the rules of the language; 3980* the converted value is placed in the global variable "ans". */ 3981 3982 d_convert_number: proc; 3983 3984 dcl abs_value float bin(63), 3985 (k,j,ndigits,num_size) fixed bin, 3986 fixed_dec_value fixed dec(9), 3987 exp fixed bin; 3988 3989 dcl 1 c64_overlay aligned based(addr(c64)), 3990 2 sign char(1) unaligned, 3991 2 digits char(num_size) unaligned, 3992 2 skip bit(1) unaligned, 3993 2 exponent fixed bin(7) unaligned; 3994 3995 dcl fixed_digits char(10) aligned based(addr(fixed_dec_value)); 3996 3997 if d_temp(1) = 0 3998 then do; 3999 ans = " 0"; 4000 return; 4001 end; 4002 4003 abs_value = abs(d_temp(1)); 4004 4005 if d_temp(1) < 0 then ans = "-"; else ans = " "; 4006 4007 if abs_value < 134217728 /* 2 ** 27 */ 4008 then if float(fixed(abs_value)) = abs_value 4009 then do; 4010 4011 /* integer format */ 4012 4013 fixed_dec_value = convert(fixed_dec_value,abs_value); 4014 4015 k = verify(substr(fixed_digits,2),"0"); 4016 ans = ans || substr(fixed_digits,k+1); 4017 return; 4018 end; 4019 4020 /* we assume that the following conversion is ROUNDED 4021* and normalized to the left */ 4022 4023 num_size = number_length; /* copy for faster accessing */ 4024 call assign_round_(addr(c64),20,num_size,addr(d_temp(1)),8,63); 4025 4026 k = verify(reverse(digits),"0"); 4027 ndigits = num_size - k + 1; 4028 4029 exp = exponent + k - 1; 4030 4031 if exp >= 0 4032 then do; 4033 4034 if (exp + ndigits) = num_size 4035 then do; 4036 4037 /* due to rounding integer is closest approximation */ 4038 /* type 1234560 */ 4039 4040 ans = ans || substr(digits,1,ndigits); 4041 4042 ans = ans || "."; /* indicate integer is approximation */ 4043 return; 4044 end; 4045 4046 /* exponential format */ 4047 4048 e_format: ans = ans || substr(digits,1,1); 4049 ans = ans || "."; 4050 ans = ans || substr(digits,2,ndigits-1); 4051 ans = ans || " E"; 4052 4053 exp = exp + ndigits - 1; 4054 4055 if abs(exp) < 10 4056 then do; 4057 fixed_dec_1 = convert(fixed_dec_1,exp); 4058 ans = ans || fixed_dec_1_overlay; 4059 end; 4060 else do; 4061 fixed_dec_2 = convert(fixed_dec_2,exp); 4062 ans = ans || fixed_dec_2_overlay; 4063 end; 4064 4065 return; 4066 end; 4067 4068 j = ndigits + exp; 4069 4070 if j <= 0 4071 then do; 4072 if ndigits - j > num_size then goto e_format; /* type .0123456 */ 4073 /* type .000123 */ 4074 4075 ans = ans || "0."; 4076 if j ^= 0 then ans = ans || substr("0000000000000000000",1,abs(j)); 4077 ans = ans || substr(digits,1,ndigits); 4078 end; 4079 else do; 4080 /* type 1.23456 */ 4081 ans = ans || substr(digits,1,j); 4082 ans = ans || "."; 4083 ans = ans || substr(digits,j+1,ndigits-j); 4084 end; 4085 4086 end; 4087 4088 /* This function converts the BASIC string specified by pr(1) 4089* to a numeric value in temp(1). "1"b is returned if no 4090* error was found and "0"b is returned if the string was 4091* erroneous. The conversion is attempted twice; if the 4092* first attempt fails, we try again with all white space removed 4093* from the string. This logic attempts to optimize the 4094* simple cases that do not have embedded white space. */ 4095 4096 d_convert_string: proc returns(bit(1) aligned); 4097 4098 dcl good_string bit(1) aligned; 4099 4100 p1 = get_string_ptr(pr(1)); 4101 good_string = "0"b; 4102 4103 conversion_label = first_error; 4104 d_temp(1) = convert(d_temp(1),p1 -> based_vs); 4105 4106 ok: good_string = "1"b; 4107 4108 done: have_conversion_label = (36)"0"b; 4109 return(good_string); 4110 4111 /* had error first time, try again if string contains white space */ 4112 4113 first_error: if search(p1 -> based_vs,white_space) = 0 then goto done; 4114 4115 conversion_label = done; 4116 4117 begin; 4118 4119 dcl copy char(length(p1 -> based_vs)), 4120 (i,j) fixed bin; 4121 4122 copy = ""; 4123 j = 0; 4124 4125 do i = 1 to length(p1 -> based_vs); 4126 if index(white_space,substr(p1 -> based_vs,i,1)) = 0 4127 then do; 4128 4129 /* current char not white space, copy it */ 4130 4131 j = j + 1; 4132 substr(copy,j,1) = substr(p1 -> based_vs,i,1); 4133 end; 4134 end; 4135 4136 d_temp(1) = convert(d_temp(1),copy); 4137 end; 4138 4139 goto ok; 4140 end; 4141 4142 /* This procedure writes the value in the global variable "temp(1)" 4143* into the next position in the RANDOM NUMERIC file specified 4144* by the global variable "fcb_pt". An endfile is generated if the 4145* max length of the file is exceeded. */ 4146 4147 d_numeric_write: proc; 4148 4149 call iox_$put_chars(seg_pt, addr(d_temp(1)), 8, code); 4150 4151 if code ^= 0 then goto end_of_file; 4152 4153 end; 4154 4155 /* This procedures sets the global variable "temp(1)" to the value 4156* in the next position in the RANDOM NUMERIC file specified by 4157* the global variable "fcb_pt". */ 4158 4159 d_numeric_read: proc; 4160 4161 call iox_$get_chars(seg_pt, addr(d_temp(1)), 8, buff_size, code); 4162 4163 if code ^= 0 then goto end_of_file; 4164 4165 end; 4166 4167 /* This procedure is called to do the looping required to do the 4168* matrix operation indicated by the argument "action_code". 4169* Global variable PR2 points at the array dope. */ 4170 4171 d_mat_loop: proc(action_code); 4172 4173 dcl action_code fixed bin; 4174 4175 dcl (row,row_max,col,col_max,i) fixed bin, 4176 data_pt ptr, 4177 vector bit(1) aligned; 4178 4179 row_max = pr(2) -> current_bounds(1) - 1; 4180 if row_max <= 0 then goto array_error; 4181 4182 col_max = pr(2) -> current_bounds(2); 4183 if col_max = 0 then goto array_error; 4184 4185 if col_max < 0 4186 then do; 4187 vector = "1"b; 4188 col_max = 1; 4189 i = 1; 4190 4191 if action_code <= 2 4192 then if a_reg = 0 4193 then row_max = pr(2) -> original_bounds(1) - 1; 4194 end; 4195 else do; 4196 vector = "0"b; 4197 col_max = col_max - 1; 4198 i = col_max + 2; 4199 end; 4200 4201 data_pt = pr(2) -> array_dope.data; 4202 4203 do row = 1 to row_max; 4204 do col = 1 to col_max; 4205 4206 goto mat(action_code); 4207 4208 /* numeric input */ 4209 4210 mat(1): call numeric_input; 4211 4212 if no_input 4213 then do; 4214 if vector & a_reg = 0 4215 then do; 4216 pr(2) -> current_bounds(1) = number_read + 1; 4217 return; 4218 end; 4219 4220 do while(no_input); 4221 call get_input(-107); 4222 call numeric_input; 4223 end; 4224 end; 4225 4226 number_read = number_read + 1; 4227 4228 data_pt -> double_float_bin(i) = d_temp(1); 4229 goto next_mat; 4230 4231 /* string input */ 4232 4233 mat(2): call string_input; 4234 4235 if no_input 4236 then do; 4237 if vector & a_reg = 0 4238 then do; 4239 pr(2) -> current_bounds(1) = number_read + 1; 4240 return; 4241 end; 4242 4243 do while(no_input); 4244 call get_input(-107); 4245 call string_input; 4246 end; 4247 end; 4248 4249 call deallocate_string(addr(data_pt -> double_bit_word(i))); 4250 4251 number_read = number_read + 1; 4252 4253 data_pt -> double_bit_word(i) = rel(p3); 4254 goto next_mat; 4255 4256 /* numeric print */ 4257 4258 mat(3): d_temp(1) = data_pt -> double_float_bin(i); 4259 call numeric_print; 4260 4261 call mat_print_format_check; 4262 goto next_mat; 4263 4264 /* string print */ 4265 4266 mat(4): p1 = get_string_ptr(addr(data_pt -> double_bit_word(i))); 4267 call string_print; 4268 4269 call mat_print_format_check; 4270 goto next_mat; 4271 4272 /* numeric data read */ 4273 4274 mat(5): if numeric_data.start >= numeric_data.finish then goto out_of_data; 4275 4276 data_pt -> double_float_bin(i) = addr(text_base_ptr -> float_bin(numeric_data.start)) -> double_float_bin(0); 4277 4278 numeric_data.start = numeric_data.start + 2; 4279 goto next_mat; 4280 4281 /* string data read */ 4282 4283 mat(6): if string_data.start >= string_data.finish then goto out_of_data; 4284 4285 call deallocate_string(addr(data_pt -> double_bit_word(i))); 4286 4287 p1 = addr(text_base_ptr -> bit_word(text_base_ptr -> fix_bin(string_data.start))); 4288 n = length(p1 -> based_vs); 4289 4290 call allocate_string; 4291 p3 -> basic_string.value = p1 -> based_vs; 4292 4293 data_pt -> double_bit_word(i) = rel(p3); 4294 4295 string_data.start = string_data.start + 1; 4296 goto next_mat; 4297 4298 /* numeric read */ 4299 4300 mat(7): call d_numeric_read; 4301 data_pt -> double_float_bin(i) = d_temp(1); 4302 goto next_mat; 4303 4304 /* string read */ 4305 4306 mat(8): call deallocate_string(addr(data_pt -> double_bit_word(i))); 4307 4308 call string_read; 4309 data_pt -> double_bit_word(i) = rel(p3); 4310 goto next_mat; 4311 4312 /* numeric write */ 4313 4314 mat(9): d_temp(1) = data_pt -> double_float_bin(i); 4315 call d_numeric_write; 4316 goto next_mat; 4317 4318 /* string write */ 4319 4320 mat(10): p1 = get_string_ptr(addr(data_pt -> double_bit_word(i))); 4321 call string_write; 4322 goto next_mat; 4323 4324 /* linput */ 4325 4326 mat(11): call deallocate_string(addr(data_pt -> double_bit_word(i))); 4327 4328 call check_input; /* get next line */ 4329 call linput; 4330 4331 data_pt -> double_bit_word(i) = rel(p3); 4332 goto next_mat; 4333 4334 /* numeric print using */ 4335 4336 mat(12): d_temp(1) = data_pt -> double_float_bin(i); 4337 call d_print_using_numeric; 4338 call mat_print_using_check; 4339 goto next_mat; 4340 4341 /* string print using */ 4342 4343 mat(13): p1 = get_string_ptr(addr(data_pt -> double_bit_word(i))); 4344 call print_using_string; 4345 call mat_print_using_check; 4346 goto next_mat; 4347 4348 /* set string matrix to nul */ 4349 4350 mat(14): call deallocate_string(addr(data_pt -> double_bit_word(i))); 4351 data_pt -> double_bit_word(i) = "0"b; 4352 goto next_mat; 4353 4354 /* mat a$ = b$ */ 4355 4356 mat(15): pr(3) = addr(data_pt -> double_bit_word(i)); 4357 pr(1) = addr(p4 -> double_bit_word(i)); 4358 call string_assign; 4359 goto next_mat; 4360 4361 next_mat: i = i + 1; 4362 end; 4363 4364 if ^ vector then i = i + 1; 4365 end; 4366 4367 mat_print_format_check: proc; 4368 4369 if col ^= col_max then call mat_print_format; 4370 else if vector 4371 then if row ^= row_max 4372 then call mat_print_format; 4373 else call print_new_line; 4374 else call print_new_line; 4375 4376 end; 4377 4378 mat_print_format: proc; 4379 4380 if a_reg = 0 then call print_new_line; 4381 else if a_reg = 1 4382 then do; 4383 tab_size = max(15,number_length+8); 4384 call tab(divide(line_pos + tab_size, tab_size, 17, 0)*tab_size); 4385 end; 4386 4387 end; 4388 4389 mat_print_using_check: proc; 4390 4391 if col = col_max 4392 then if ^ vector 4393 then do; 4394 call print_new_line; 4395 pu_pos = 0; 4396 end; 4397 4398 end; 4399 4400 end; 4401 4402 /* This procedure is called to put out the numeric value in the 4403* global variable "temp(1)" on file specified by global variable 4404* "fcb_pt" according to the next field in the PRINT USING string. 4405* The "size" condition is handled by setting the global label 4406* variable "size_label" which is recognized by the default 4407* handler; the label is reset after the conversion by setting 4408* its first word to zero. */ 4409 4410 d_print_using_numeric: proc; 4411 4412 dcl zero_surpression bit(1), 4413 exp fixed bin, 4414 float_sign aligned char(1); 4415 4416 dcl 1 decimal_value based(addr(c64)) aligned, 4417 2 sign char(1) unal, 4418 2 digit(precision) char(1) unal, 4419 2 skip bit(1) unal, 4420 2 exponent fixed bin(7) unal; 4421 4422 call get_next_field("0"b); 4423 4424 if left_just then goto print_using_error; 4425 if right_just then goto print_using_error; 4426 4427 if scale > 38 then goto punt; 4428 4429 if exp_length = 0 4430 then do; 4431 4432 /* f format */ 4433 4434 if have_minus 4435 then if d_temp(1) >= 0 4436 then precision = precision + 1; 4437 4438 if precision = 0 then goto punt; 4439 4440 size_label = punt; 4441 4442 call assign_round_(addr(c64),18,fixed(scale * 1000000000000000000b + precision,35), 4443 addr(temp(1)),8,27); 4444 4445 have_size_label = (36)"0"b; 4446 end; 4447 else do; 4448 4449 /* e format, we assume the following conversion 4450* produces a left justified result */ 4451 4452 if precision = 0 then precision = 1; 4453 4454 call assign_round_(addr(c64),20,precision,addr(temp(1)),8,27); 4455 4456 if d_temp(1) = 0 then exp = 0; 4457 else exp = exponent + scale; 4458 end; 4459 4460 zero_surpression = ^ have_exp; 4461 4462 digit_count = 0; 4463 digit_pos = 0; 4464 4465 do field_pos = field_start to field_start+field_length - 1; 4466 ch = substr(pu_string,field_pos,1); 4467 goto case(index("$+-#^.",ch)); 4468 4469 case(0): if zero_surpression then ch = " "; 4470 goto place; 4471 4472 /* $ */ 4473 4474 case(1): goto next; 4475 4476 /* + */ 4477 4478 case(2): float_sign = decimal_value.sign; 4479 4480 if have_exp then call put_char(float_sign); 4481 4482 goto next; 4483 4484 /* - */ 4485 4486 case(3): if d_temp(1) < 0 then goto case(2); 4487 4488 float_sign = " "; 4489 4490 if have_exp 4491 then do; 4492 call put_char(float_sign); 4493 goto next; 4494 end; 4495 4496 /* # */ 4497 4498 case(4): digit_pos = digit_pos + 1; 4499 ch = digit(digit_pos); 4500 4501 if zero_surpression 4502 then if ch ^= "0" | digit_pos = precision - scale | have_exp 4503 then call end_surpression; 4504 else ch = " "; 4505 else digit_count = digit_count + 1; 4506 4507 if digit_count > number_length+2 then ch = "?"; 4508 4509 goto place; 4510 4511 /* ^ */ 4512 4513 case(5): call put_string(" E"); 4514 4515 if abs(exp) < 10 4516 then do; 4517 fixed_dec_1 = convert(fixed_dec_1,exp); 4518 call put_string(fixed_dec_1_overlay); 4519 call put_char(" "); 4520 end; 4521 else do; 4522 fixed_dec_2 = convert(fixed_dec_2,exp); 4523 call put_string(fixed_dec_2_overlay); 4524 end; 4525 4526 field_pos = field_pos + 4; 4527 goto next; 4528 4529 /* . */ 4530 4531 case(6): if zero_surpression 4532 then do; 4533 call end_surpression; 4534 if float_sign = " " then call put_char("0"); 4535 end; 4536 4537 place: call put_char(ch); 4538 4539 next: end; 4540 4541 return; 4542 4543 punt: have_size_label = (36)"0"b; 4544 4545 do field_pos = field_start to field_start+field_length - 1; 4546 ch = substr(pu_string,field_pos,1); 4547 4548 if index("$+-#^",ch) ^= 0 then ch = "*"; 4549 4550 call put_char(ch); 4551 end; 4552 4553 4554 end_surpression: proc; 4555 4556 if have_dollar then call put_char("$"); 4557 4558 if float_sign ^= " " then call put_char(float_sign); 4559 4560 zero_surpression = "0"b; 4561 end; 4562 4563 end; 4564 4565 end; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 09/11/84 1223.9 basic_runtime_.pl1 >spec>on>basic>basic_runtime_.pl1 264 1 03/27/82 0439.4 basic_operator_frame.incl.pl1 >ldd>include>basic_operator_frame.incl.pl1 265 2 03/27/82 0439.4 basic_fcb.incl.pl1 >ldd>include>basic_fcb.incl.pl1 267 3 07/19/79 1547.0 vfs_info.incl.pl1 >ldd>include>vfs_info.incl.pl1 268 4 03/27/82 0439.4 basic_program_header.incl.pl1 >ldd>include>basic_program_header.incl.pl1 269 5 03/27/82 0439.4 basic_symbols.incl.pl1 >ldd>include>basic_symbols.incl.pl1 270 6 03/27/82 0439.4 basic_param_types.incl.pl1 >ldd>include>basic_param_types.incl.pl1 271 7 05/20/83 1846.4 iocb.incl.pl1 >ldd>include>iocb.incl.pl1 272 8 05/06/74 1751.6 status_info_branch.incl.pl1 >ldd>include>status_info_branch.incl.pl1 1526 9 12/15/83 1100.4 mc.incl.pl1 >ldd>include>mc.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. Ascii_input constant fixed bin(17,0) initial dcl 2-37 set ref 736 755* 2254* 2762 2764 Ascii_input_output constant fixed bin(17,0) initial dcl 2-37 ref 301 2311 2764 Ascii_output constant fixed bin(17,0) initial dcl 2-37 set ref 754 2234* 2356 2394 2766 NL constant char(1) initial unaligned dcl 126 ref 2501 3164 Not_open constant fixed bin(17,0) initial dcl 2-37 ref 659 752 773 833 869 2950 2972 2986 3008 Numeric_input constant fixed bin(17,0) initial dcl 2-37 set ref 774 797* 1022* 1232* 1342* Numeric_input_output constant fixed bin(17,0) initial dcl 2-37 set ref 737* 790* 1036* 1225* 1356* 2347 String_input constant fixed bin(17,0) initial dcl 2-37 set ref 775 812* 1029* 1349* String_update constant fixed bin(17,0) initial dcl 2-37 set ref 708* 738* 804* 1043* 1363* 2384 a 24 based bit(36) level 3 packed unaligned dcl 9-12 set ref 1742* 1748* a_reg 44 based fixed bin(35,0) level 3 dcl 1-1 set ref 1003* 1003 1014* 1014 1169 1323* 1323 1334* 1334 3355 3378 3401 3544 3545 4191 4214 4237 4380 4381 abort_label 52 based label variable level 2 dcl 1-1 ref 291 447 626 1221 1445 1624 1633 1660 3205 abs builtin function dcl 201 ref 1934 2073 2124 2144 3871 4003 4055 4076 4515 abs_value 003270 automatic float bin(63) dcl 3984 in procedure "d_convert_number" set ref 4003* 4007 4007 4007 4013 abs_value 002530 automatic float bin(27) dcl 2053 in procedure "convert_number" set ref 2073* 2077 2077 2077 2083 2093 action_code parameter fixed bin(17,0) dcl 3337 in procedure "mat_loop" ref 3335 3355 3370 action_code parameter fixed bin(17,0) dcl 4173 in procedure "d_mat_loop" ref 4171 4191 4206 addr builtin function dcl 201 ref 298 314 320 338 413 702 702 710 710 841 841 877 877 933 959 962 968 970 1253 1279 1282 1288 1290 1567 1574 1587 1606 1617 1704 1771 1936 1949 1951 1951 1951 1953 1953 1953 1955 1955 1955 2042 2042 2085 2086 2095 2098 2108 2117 2119 2127 2131 2145 2148 2150 2175 2219 2221 2422 2422 2425 2426 2426 2524 2586 2586 2586 2586 2586 2586 2696 2696 2780 2780 2780 2780 2780 2780 2784 2784 2813 2813 2819 2819 2827 2827 2842 2843 2847 2850 2853 2898 2900 2974 2974 3084 3084 3109 3109 3121 3121 3137 3137 3140 3213 3413 3413 3430 3430 3449 3449 3451 3470 3470 3484 3484 3490 3490 3507 3507 3514 3514 3520 3521 3798 3798 3798 3798 3801 3810 3810 3810 3810 3813 3834 3855 3874 3879 3899 4015 4016 4024 4024 4024 4024 4026 4029 4040 4048 4050 4058 4062 4077 4081 4083 4108 4149 4149 4161 4161 4249 4249 4266 4266 4276 4285 4285 4287 4306 4306 4320 4320 4326 4326 4343 4343 4350 4350 4356 4357 4442 4442 4442 4442 4445 4454 4454 4454 4454 4457 4478 4499 4518 4523 4543 addrel builtin function dcl 201 ref 1182 1785 1796 1961 1961 1995 2032 2037 3097 3097 amp_NL 022217 constant char(2) initial unaligned dcl 126 ref 3166 3284 ans 000114 automatic varying char(28) dcl 45 set ref 575 577 1202 1204 2069* 2075* 2075* 2086* 2086 2108* 2108 2110* 2110 2117* 2117 2118* 2118 2119* 2119 2120* 2120 2127* 2127 2131* 2131 2143* 2143 2144* 2144 2145* 2145 2148* 2148 2149* 2149 2150* 2150 2523* 2523 2524 3999* 4005* 4005* 4016* 4016 4040* 4040 4042* 4042 4048* 4048 4049* 4049 4050* 4050 4051* 4051 4058* 4058 4062* 4062 4075* 4075 4076* 4076 4077* 4077 4081* 4081 4082* 4082 4083* 4083 area_ 000200 constant entry external dcl 134 ref 294 area_header_size constant fixed bin(17,0) initial dcl 79 ref 294 arg 200 based pointer array level 2 dcl 1-1 ref 1790 arg_count based fixed bin(16,0) level 2 packed unaligned dcl 231 ref 1540 1654 1667 arg_info based structure level 1 dcl 224 arg_ptr 2 based pointer array level 2 dcl 231 ref 1540 1654 1667 1792 arglist based structure level 1 dcl 231 arglist_ptr 32 based pointer level 2 dcl 1-1 ref 1539 1653 1666 1792 array_dope based structure level 1 dcl 5-1 ascii_file constant fixed bin(17,0) initial dcl 2-22 ref 730 771 884 2312 2364 2399 2466 2749 2873 ascii_size_op 000010 internal static varying char(5) dcl 64 set ref 307* 308* 2869 assign_round_ 000176 constant entry external dcl 134 ref 3798 3810 4024 4442 4454 attach_descrip parameter char unaligned dcl 2911 set ref 2909 2920* attach_descrip_ptr 14 based pointer level 2 dcl 7-6 ref 2735 3011 attached_by_us 17 based bit(1) level 3 packed unaligned dcl 2-1 set ref 2451* 2747* 2913* 3011 3015* based_vs based varying char(4096) dcl 85 set ref 428 428 430 430 442 442 452 452 516 520 520 599 602 667 683 899 926 1073 1083 1145 1180 1188 1246 1434 1795 1796 1852 1855 1953* 2171 2180 2186 2192 2193 2199 2528 2533 2540 2546 2757 2759 2760 2762 2763 3097 3097 3452 3455 3934 3955 3956 4104 4113 4119 4125 4126 4132 4288 4291 baseno builtin function dcl 201 ref 1619 1708 basic_error_messages_$ 000276 external static fixed bin(17,0) dcl 207 set ref 1936 1949 1951 1951 1951 1953 1953 1953 1955 1955 1955 basic_fcb based structure level 1 dcl 2-1 set ref 647 2625 basic_file_name_ 000166 constant entry external dcl 134 ref 2715 basic_operators_frame based structure level 1 dcl 1-1 basic_program_header based structure level 1 dcl 4-1 basic_string based structure level 1 dcl 216 set ref 1868 1894 bit builtin function dcl 201 ref 529 1719 bit_length 000263 automatic fixed bin(5,0) dcl 45 set ref 919* 921 922 926 936 936 936 943* 945 946 954 968 970 970 970 970 970 975 976 976 976 1239* 1241 1242 1246 1256 1256 1256 1263* 1265 1266 1274 1288 1290 1290 1290 1290 1290 1295 1296 1296 1296 bit_word based bit(36) array dcl 102 set ref 958* 1278* 3413 3413 3417* 3430 3430 3449 3449 3451 3457* 3470 3470 3473* 3484 3484 3490 3490 3495* 3507 3507 3514 3514 3515* 3520 3521 4287 bits 17 based structure level 2 packed unaligned dcl 2-1 set ref 657* bits_per_char constant fixed bin(17,0) initial dcl 79 ref 926 954 954 975 1246 1274 1274 1295 bl 002730 automatic fixed bin(21,0) dcl 2673 set ref 2696* 2698 blk_info based structure level 1 unaligned dcl 3-21 bo_pt 000100 automatic pointer dcl 45 set ref 274* 275 275 291 298 299 300 301 304 305 311 314 315 315 317 317 317 319 320 320 321 321 323 325 327 338 354 369 377 378 399 399 406 406 413 413 418 420 424 428 430 432 438 440 447 504 510 514 518 524 529 583 585 590 592 594 611 611 616 626 630 636 636 639 640 642 642 642 644 646 647 647 648 650 652 652 652 653 654 654 657 658 659 660 661 662 663 665 677 679 680 683 688 694 699 702 706 710 716 717 722 727 728 730 733 733 736 737 740 741 744 749 752 752 754 763 766 767 771 773 774 780 780 781 782 785 806 824 824 833 833 833 837 841 844 844 844 846 855 855 864 866 867 867 869 871 872 873 877 878 880 883 884 884 884 884 895 902 905 910 910 911 911 913 913 919 924 928 930 943 948 950 952 958 985 994 1003 1003 1003 1014 1014 1014 1072 1073 1075 1077 1078 1078 1078 1078 1079 1081 1083 1083 1084 1096 1106 1107 1107 1107 1107 1108 1110 1134 1141 1148 1151 1156 1156 1157 1157 1159 1159 1159 1169 1172 1178 1190 1192 1210 1221 1239 1244 1248 1250 1263 1268 1270 1272 1278 1305 1314 1323 1323 1323 1334 1334 1334 1413 1423 1425 1433 1445 1509 1540* 1542 1550 1567 1569 1570 1571 1574 1576 1577 1582 1594 1619 1624 1629 1633 1638 1641 1654* 1660 1667* 1680* 1682 1684 1685 1687 1687 1687 1689 1708 1709 1763 1771 1778 1790 1792 1822 1822 1826 1828 1833 1837 1842 1842 1846 1846 1852 1855 1857 1867 1868 1869 1871 1888 1893 1894 1895 1897 1921 1922 1924 1925 1925 1927 1927 1931 1932 1934 1936 1937 1945 1945 1949 1950 1951 1951 1953 1953 1953 1955 1955 1955 1961 1961 1986 1990 1993 1995 1995 2032 2032 2034 2042 2042 2067 2073 2075 2167 2170 2171 2171 2175 2182 2203 2203 2221 2236 2239 2239 2241 2241 2242 2256 2258 2258 2260 2261 2261 2264 2264 2266 2277 2277 2283 2283 2285 2292 2292 2293 2306 2306 2308 2310 2311 2312 2320 2322 2325 2326 2327 2333 2344 2344 2346 2347 2348 2353 2356 2358 2363 2364 2369 2370 2381 2381 2383 2384 2385 2390 2394 2396 2398 2399 2401 2401 2402 2403 2426 2448 2448 2451 2452 2453 2466 2467 2467 2469 2471 2472 2472 2472 2472 2473 2475 2485 2485 2485 2485 2489 2498 2498 2500 2500 2501 2501 2501 2505 2521 2528 2528 2528 2535 2535 2536 2536 2536 2540 2540 2540 2541 2541 2542 2542 2546 2546 2546 2547 2547 2548 2548 2550 2550 2566 2568 2568 2575 2575 2582 2586 2586 2586 2586 2602 2616 2616 2618 2618 2618 2621 2624 2625 2625 2626 2628 2634 2634 2636 2636 2638 2638 2642 2657 2676 2676 2676 2676 2676 2681 2682 2684 2685 2687 2688 2688 2688 2689 2689 2689 2690 2690 2690 2690 2691 2692 2694 2696 2696 2696 2696 2698 2698 2701 2715 2717 2724 2726 2727 2729 2729 2729 2735 2737 2739 2740 2744 2744 2744 2747 2749 2753 2762 2764 2764 2766 2767 2778 2780 2780 2780 2780 2793 2798 2801 2826 2836 2843 2853 2854 2869 2873 2882 2882 2884 2897 2900 2902 2913 2915 2916 2920 2950 2951 2952 2956 2959 2960 2972 2973 2974 2977 2981 2984 2986 2987 2991 3002 3003 3003 3005 3005 3007 3008 3011 3011 3013 3013 3015 3019 3020 3021 3021 3021 3021 3022 3023 3026 3028 3039 3040 3042 3045 3045 3046 3046 3046 3047 3047 3049 3049 3054 3067 3072 3074 3084 3084 3084 3097 3097 3097 3109 3109 3109 3121 3137 3137 3139 3140 3140 3155 3155 3158 3158 3159 3159 3161 3161 3161 3166 3166 3166 3172 3172 3185 3195 3201 3205 3208 3210 3210 3210 3211 3211 3213 3217 3234 3234 3236 3236 3236 3236 3236 3240 3246 3246 3248 3248 3248 3253 3253 3255 3255 3255 3255 3255 3259 3261 3261 3261 3261 3261 3261 3261 3261 3261 3261 3273 3273 3273 3273 3273 3279 3279 3279 3284 3284 3284 3295 3295 3295 3297 3297 3309 3309 3314 3314 3314 3316 3316 3343 3346 3355 3355 3365 3378 3380 3380 3390 3390 3392 3401 3403 3403 3415 3415 3422 3438 3438 3440 3440 3442 3442 3447 3447 3451 3451 3451 3459 3459 3465 3478 3500 3520 3521 3544 3545 3545 3556 3569 3569 3569 3569 3569 3569 3569 3573 3573 3598 3598 3600 3600 3600 3604 3604 3606 3606 3607 3607 3607 3637 3637 3639 3639 3649 3653 3653 3653 3657 3657 3657 3657 3657 3657 3668 3685 3690 3690 3692 3692 3692 3695 3695 3695 3698 3698 3755 3755 3790 3796 3798 3798 3801 3810 3810 3812 3822 3822 3842 3899 3902 3902 3944 3944 3971 3997 4003 4005 4023 4024 4024 4100 4103 4104 4104 4108 4115 4136 4136 4149 4149 4149 4161 4161 4161 4179 4182 4191 4191 4201 4214 4216 4216 4226 4226 4228 4237 4239 4239 4251 4251 4258 4274 4274 4276 4276 4278 4278 4283 4283 4287 4287 4287 4295 4295 4301 4314 4336 4356 4357 4380 4381 4383 4384 4395 4434 4440 4442 4442 4445 4454 4454 4456 4466 4466 4486 4507 4543 4546 4546 bo_stack_pt parameter pointer dcl 43 ref 41 274 bp 002726 automatic pointer dcl 2673 set ref 2688* 2689 2691 bsp 002450 automatic pointer dcl 1884 set ref 1888* 1889 1889 1891 1894 buff2 based char level 2 packed unaligned dcl 176 set ref 2696 2696 buff_size 000260 automatic fixed bin(21,0) dcl 45 set ref 780* 781* 782* 2469* 2976* 2987* 3109* 3121* 3124 4161* buffer based char unaligned dcl 176 set ref 2292* 2472 2501* 2540* 2546* 2688 2689* 2689 2690 3021 3046* 3161 3166 3236 3248 3255 3261 3261 3273 3279 3284 3295 3314 3569 3607* buffer_length 15 based fixed bin(21,0) level 2 dcl 2-1 set ref 733 884 2261 2264 2283 2676* 2698* 2698 3155 3158 3234 3236 3255 3261 3261 3273 3309 3316 3569 3569 3573 buffer_pair based structure level 1 packed unaligned dcl 176 buffer_pos 11 based fixed bin(21,0) level 2 dcl 2-1 set ref 319* 733* 884 2241* 2261* 2264 2283* 2485* 2489* 2498 2500* 2500 2501 2535 2540 2541* 2541 2546 2547* 2547 2701* 3045 3046 3047* 3047 3049 3155 3158 3159* 3159 3161 3166 3172* 3172 3234 3236 3236 3246* 3246 3248 3253* 3253 3255 3255 3261 3261 3261 3261 3273 3273 3279 3284 3295 3297* 3297 3309 3314 3316* 3569 3569 3569 3573* 3598 3606* 3606 3607 buffer_pt 2 based pointer level 2 dcl 2-1 set ref 320* 663* 2292 2293* 2472* 2485* 2501 2540 2546 2676* 2689 2690 2691* 2696 2696 3019 3021 3022* 3046 3161 3166 3236 3248 3255 3261 3261 3273 3279 3284 3295 3314 3569 3607 buffer_size 16 based fixed bin(21,0) level 2 dcl 2-1 set ref 321* 2292 2469* 2472 2472 2498 2501 2535 2540 2546 2676* 2682 2684 2685* 2688 2688 2689 2689 2690 2690 3021 3021 3045 3046 3049 3161 3166 3236 3248 3255 3261 3261 3273 3279 3284 3295 3314 3569 3598 3607 c parameter char(1) dcl 3596 ref 3594 3607 c12 000132 automatic char(12) unaligned dcl 45 set ref 541* 544 544 544 c32 000143 automatic char(32) unaligned dcl 45 set ref 3179* 3201 3201 3210 3211 3220 3220 c6 000126 automatic char(6) unaligned dcl 45 set ref 551* 554 554 554 c64 000153 automatic char(64) unaligned dcl 45 set ref 3798 3798 3810 3810 3813 3834 3855 4024 4024 4026 4029 4040 4048 4050 4077 4081 4083 4442 4442 4454 4454 4457 4478 4499 c64_overlay based structure level 1 dcl 3989 c8 000130 automatic char(8) unaligned dcl 45 set ref 544* 554* 560* 560* 3327 ch 000124 automatic char(1) dcl 45 set ref 529* 534 3161* 3163 3164 3176 3179 3192 3193 3739* 3822* 3823 3825* 3855* 3857 3860* 3863* 3893* 3902* 3904 3904* 3906* 3944* 3946 3949* 3955* 3956* 3959* 4466* 4467 4469* 4499* 4501 4504* 4507* 4537* 4546* 4548 4548* 4550* change based structure level 1 dcl 91 char_string based char unaligned dcl 105 set ref 1172 1795* chars 1 based char(1) level 2 dcl 87 set ref 933 962 1253 1282 close 36 based entry variable level 2 dcl 7-6 ref 3005 close_op constant fixed bin(17,0) initial dcl 2-28 ref 2566 2602 co_ptr parameter pointer dcl 1522 ref 1520 code 000262 automatic fixed bin(35,0) dcl 45 set ref 286* 702* 710* 711 740* 741* 782* 783 841* 842 877* 878 2277* 2279 2279 2293* 2422* 2423 2444 2448* 2450 2452* 2453 2456 2485* 2486 2572* 2575 2575* 2580 2586* 2587* 2589 2594* 2596 2596* 2663 2676* 2678 2679 2696* 2729* 2730 2744* 2745 2780* 2782 2784* 2786 2792 2813* 2814 2823* 2824 2827* 2830 2916* 2917 2920* 2921 2952* 2953 2956* 2957 2974* 2975 2977* 2978 2981* 2982 2987* 2988 3005* 3006 3013* 3014 3084* 3086 3097* 3099 3109* 3111 3121* 3122 4149* 4151 4161* 4163 col 003122 automatic fixed bin(17,0) dcl 3339 in procedure "mat_loop" set ref 3368* 3533 3552 col 003336 automatic fixed bin(17,0) dcl 4175 in procedure "d_mat_loop" set ref 4204* 4369 4391 col_max 003337 automatic fixed bin(17,0) dcl 4175 in procedure "d_mat_loop" set ref 4182* 4183 4185 4188* 4197* 4197 4198 4204 4369 4391 col_max 003123 automatic fixed bin(17,0) dcl 3339 in procedure "mat_loop" set ref 3346* 3347 3349 3352* 3361* 3361 3362 3368 3533 3552 com_err_ 000164 constant entry external dcl 134 ref 290 comma_NL constant char(2) initial unaligned dcl 126 ref 3273 cond 002360 automatic char(32) unaligned dcl 1534 set ref 1543* 1545 1569 1570 1571 1576 1577 1580 1592 1598 1614 1627 1636 1638 continue parameter bit(1) dcl 1522 set ref 1520 1559* conversion_label 56 based label variable level 2 dcl 1-1 set ref 1567 1569 1570 1571 2170* 2175 2182* 3208* 3213 4103* 4108 4115* convert builtin function dcl 201 ref 2083 2093 2126 2130 2171 2203 2897 3210 3211 3873 3878 4013 4057 4061 4104 4136 4517 4522 convert_new_oncode_ 000300 constant entry external dcl 1533 ref 1547 convert_old_basic_file_ 000242 constant entry external dcl 134 ref 2823 copy 000100 automatic char unaligned dcl 4119 in begin block on line 4117 set ref 4122* 4132* 4136 copy 000100 automatic char unaligned dcl 2186 in begin block on line 2184 set ref 2189* 2199* 2203 count 1(18) 000144 internal static picture(6) level 2 in structure "unique_value" packed unaligned dcl 2932 in procedure "unique" set ref 2938* count based fixed bin(17,0) level 2 in structure "basic_string" dcl 216 in procedure "basic_runtime_" set ref 1182 1844* 1844 1873* 1889* 1889 1891 cu 5(18) based structure level 2 packed unaligned dcl 9-56 cu_$stack_frame_ptr 000210 constant entry external dcl 134 ref 1539 1653 1666 1680 current_bounds 4 based fixed bin(17,0) array level 2 dcl 5-1 set ref 928 952 1003 1014 1248 1272 1323 1334 3343 3346 3380* 3403* 4179 4182 4216* 4239* d_basic_operators_frame based structure level 1 dcl 1-68 d_temp 172 based float bin(63) array level 2 dcl 1-68 set ref 3211* 3211 3997 4003 4005 4024 4024 4104* 4104 4136* 4136 4149 4149 4161 4161 4228 4258* 4301 4314* 4336* 4434 4456 4486 data based pointer level 2 dcl 5-1 ref 930 950 1134 1250 1270 1413 3365 4201 data_pt 003126 automatic pointer dcl 3339 in procedure "mat_loop" set ref 3365* 3392 3413 3413 3417 3422 3430 3430 3440 3449 3449 3457 3465 3470 3470 3473 3478 3484 3484 3490 3490 3495 3500 3507 3507 3514 3514 3515 3520 data_pt 003342 automatic pointer dcl 4175 in procedure "d_mat_loop" set ref 4201* 4228 4249 4249 4253 4258 4266 4266 4276 4285 4285 4293 4301 4306 4306 4309 4314 4320 4320 4326 4326 4331 4336 4343 4343 4350 4350 4351 4356 date builtin function dcl 201 ref 551 dec_value 002534 automatic float dec(6) dcl 2053 set ref 2093* 2093 2095 2098 2108 2117 2119 2145 2148 2150 dec_value_overlay based structure level 1 dcl 2059 decimal_value based structure level 1 dcl 3772 in procedure "print_using_numeric" decimal_value based structure level 1 dcl 4416 in procedure "d_print_using_numeric" default_buffer_size constant fixed bin(17,0) initial dcl 79 ref 2469 destroy parameter bit(1) dcl 2564 ref 2562 2575 detach_iocb 26 based entry variable level 2 dcl 7-6 ref 3013 digit 0(09) based char(1) array level 2 in structure "decimal_value" packed unaligned dcl 3772 in procedure "print_using_numeric" ref 3855 digit 0(09) based char(1) array level 2 in structure "decimal_value" packed unaligned dcl 4416 in procedure "d_print_using_numeric" ref 4499 digit_count 000311 automatic fixed bin(17,0) dcl 183 set ref 3818* 3861* 3861 3863 4462* 4505* 4505 4507 digit_pos 000312 automatic fixed bin(17,0) dcl 183 set ref 3819* 3854* 3854 3855 3857 4463* 4498* 4498 4499 4501 digits 0(09) based char level 2 in structure "c64_overlay" packed unaligned dcl 3989 in procedure "d_convert_number" ref 4026 4040 4048 4050 4077 4081 4083 digits 0(09) based char(6) level 2 in structure "dec_value_overlay" packed unaligned dcl 2059 in procedure "convert_number" ref 2095 2108 2117 2119 2145 2148 2150 dir 000173 automatic char(168) unaligned dcl 45 set ref 672* 674 675 677 2586 2586 2587* 2594* 2596* 2780 2780 2784* 2813* 2823* 2827* divide builtin function dcl 201 ref 378 844 926 954 1246 1274 1998 2426 3545 4384 double_bit_word based bit(72) array dcl 98 set ref 4249 4249 4253* 4266 4266 4285 4285 4293* 4306 4306 4309* 4320 4320 4326 4326 4331* 4343 4343 4350 4350 4351* 4356 4357 double_float_bin based float bin(63) array dcl 96 set ref 1251* 1256* 1271 1285 4228* 4258 4276* 4276 4301* 4314 4336 double_vbs based bit(72) dcl 71 ref 1288 1290 double_vfx 000274 automatic fixed bin(71,0) dcl 71 set ref 1285* 1287 1288 1290 e 26 based bit(8) level 3 packed unaligned dcl 9-12 set ref 1741* 1747* en parameter fixed bin(17,0) dcl 2655 set ref 2653 2657 2657* end_pos 2 based fixed bin(34,0) level 2 dcl 3-1 ref 2425 end_scan parameter bit(1) dcl 3623 ref 3621 3643 ent 000245 automatic char(32) unaligned dcl 45 set ref 2586 2586 2587* 2594* 2596* 2780 2780 2784* 2813* 2823* 2827* entry_variable 000276 automatic entry variable dcl 74 set ref 337* 338 340* 1770* 1771 1773* entryname 167 based pointer level 2 packed unaligned dcl 1-1 ref 1961 1961 eovf 4(22) based bit(1) level 3 packed unaligned dcl 9-56 set ref 1587* errno parameter fixed bin(17,0) dcl 1731 set ref 1729 1736* error_number 150 based fixed bin(17,0) level 2 dcl 1-1 set ref 354* 1934* 1936 1949 1950* 1951 1951 1953 1953 1955 1955 error_table_$end_of_info 000256 external static fixed bin(35,0) dcl 166 ref 2663 error_table_$fulldir 000260 external static fixed bin(35,0) dcl 166 ref 2589 error_table_$long_record 000266 external static fixed bin(35,0) dcl 166 ref 2679 error_table_$no_operation 000262 external static fixed bin(35,0) dcl 166 ref 711 2279 error_table_$noentry 000270 external static fixed bin(35,0) dcl 166 ref 2792 error_table_$not_done 000264 external static fixed bin(35,0) dcl 166 ref 2830 et 002462 automatic fixed bin(17,0) dcl 1914 set ref 1936* 1937 1943 1946* 1951 1953 eufl 4(23) based bit(1) level 3 packed unaligned dcl 9-56 set ref 1606* ev based structure level 1 unaligned dcl 74 in procedure "basic_runtime_" ev 002466 automatic entry variable dcl 1914 in procedure "print_error" set ref 1939* 1940* 1941* 1950 1951 1953 1955 1959* 1959* 1961 exp 002541 automatic fixed bin(17,0) dcl 2053 in procedure "convert_number" set ref 2098* 2100 2103 2110 2110 2122* 2122 2124 2126 2130 2137 exp 003401 automatic fixed bin(17,0) dcl 4412 in procedure "d_print_using_numeric" set ref 4456* 4457* 4515 4517 4522 exp 003221 automatic fixed bin(17,0) dcl 3768 in procedure "print_using_numeric" set ref 3812* 3813* 3871 3873 3878 exp 003301 automatic fixed bin(17,0) dcl 3984 in procedure "d_convert_number" set ref 4029* 4031 4034 4053* 4053 4055 4057 4061 4068 exp_length 000310 automatic fixed bin(17,0) dcl 183 set ref 3629* 3719 3733* 3733 3749 3751 3785 4429 expand_path_ 000214 constant entry external dcl 134 ref 2586 2780 exponent based fixed bin(7,0) level 2 in structure "c64_overlay" packed unaligned dcl 3989 in procedure "d_convert_number" ref 4029 exponent 1(28) based fixed bin(7,0) level 2 in structure "dec_value_overlay" packed unaligned dcl 2059 in procedure "convert_number" ref 2098 exponent based fixed bin(7,0) level 2 in structure "decimal_value" packed unaligned dcl 4416 in procedure "d_print_using_numeric" ref 4457 exponent based fixed bin(7,0) level 2 in structure "decimal_value" packed unaligned dcl 3772 in procedure "print_using_numeric" ref 3813 fast_related_data_$basic_area_p 000272 external static pointer dcl 173 set ref 279 296* 304 fast_related_data_$in_fast_or_dfast 000274 external static bit(1) dcl 174 ref 307 2722 fcb 126 based pointer array level 2 packed unaligned dcl 1-1 set ref 311* 315* 611 642 652* 824 833 841 844 855 867 910 911 913 1156 1157 1687 1925 2616 2634 3072 3074 fcb_pt 110 based pointer level 2 dcl 1-1 set ref 298* 299 300 301 314* 315 317 317 319 320 320 321 321 323 325 378 406 642* 644 647* 652 653 654 657 658 659 660 661 662 663 677 679 680 683 688 699 702 706 710 716 717 727 728 730 733 733 736 737 740 741 744 752 752 754 766 767 771 773 774 780 781 782 785 833 833 867* 869 871 877 884 884 884 1159 1159 1509 1687* 1689 1922 1925* 1927 1927 1932* 1945 2236 2239 2241 2241 2242 2256 2258 2260 2261 2261 2264 2264 2277 2277 2283 2283 2285 2292 2292 2293 2306 2306 2308 2310 2311 2312 2320 2322 2325 2326 2327 2333 2344 2344 2346 2347 2348 2353 2356 2358 2363 2364 2369 2370 2381 2381 2383 2384 2385 2390 2394 2396 2398 2399 2401 2401 2402 2403 2448 2448 2451 2452 2453 2466 2467 2467 2469 2472 2472 2472 2485 2485 2485 2485 2489 2498 2498 2500 2500 2501 2501 2501 2505 2528 2528 2528 2535 2535 2536 2536 2536 2540 2540 2540 2541 2541 2542 2542 2546 2546 2546 2547 2547 2548 2548 2550 2550 2566 2568 2568 2575 2575 2582 2586 2586 2586 2586 2602 2616* 2618 2618 2621 2625 2634* 2636 2638 2638 2642 2657 2676 2676 2676 2676 2676 2681 2682 2684 2685 2688 2688 2689 2689 2689 2690 2690 2690 2691 2696 2696 2696 2696 2698 2698 2701 2715 2717 2724 2726 2727 2729 2729 2729 2735 2737 2739 2740 2744 2744 2744 2747 2749 2753 2762 2764 2764 2766 2767 2778 2780 2780 2780 2780 2793 2798 2801 2826 2836 2843 2854 2869 2873 2882 2884 2897 2900 2902 2913 2915 2916 2920 2950 2951 2952 2956 2959 2960 2972 2973 2974 2977 2981 2984 2986 2987 2991 3002 3003 3003 3005 3005 3007 3008 3011 3011 3013 3013 3015 3019 3021 3021 3021 3022 3028 3039 3040 3042 3045 3045 3046 3046 3046 3047 3047 3049 3049 3054 3084 3097 3097 3097 3109 3121 3155 3155 3158 3158 3159 3159 3161 3161 3161 3166 3166 3166 3172 3172 3185 3195 3201 3217 3234 3234 3236 3236 3236 3236 3236 3240 3246 3246 3248 3248 3248 3253 3253 3255 3255 3255 3255 3255 3259 3261 3261 3261 3261 3261 3261 3261 3261 3261 3261 3273 3273 3273 3273 3273 3279 3279 3279 3284 3284 3284 3295 3295 3295 3297 3297 3309 3309 3314 3314 3314 3316 3316 3545 3569 3569 3569 3569 3569 3569 3569 3573 3573 3598 3598 3600 3600 3600 3604 3604 3606 3606 3607 3607 3607 4149 4161 4384 field_length 000304 automatic fixed bin(17,0) dcl 183 set ref 3629* 3658* 3658 3669* 3669 3686* 3686 3700* 3700 3723* 3723 3734* 3734 3744* 3744 3821 3901 3943 4465 4545 field_pos 000313 automatic fixed bin(17,0) dcl 183 set ref 3821* 3822 3882* 3882* 3901* 3902* 3943* 3944* 4465* 4466 4526* 4526* 4545* 4546* field_start 000305 automatic fixed bin(17,0) dcl 183 set ref 3629* 3641 3657 3664 3668* 3674 3681 3685* 3705 3712 3721 3731 3739 3821 3821 3901 3901 3943 3943 4465 4465 4545 4545 file_lng 000264 automatic fixed bin(34,0) dcl 45 set ref 871* 872 2425* 2426 2426* 2426 2431 file_name 20 based char(168) level 2 dcl 2-1 set ref 320 321 677* 683* 1945* 2448 2586 2586 2586 2586 2715* 2717 2726 2727 2729 2729 2737 2739 2740 2744 2744 2780 2780 2780 2780 2826* 2836* 2869 2882 2900 file_number 147(18) based fixed bin(17,0) level 2 packed unaligned dcl 1-1 set ref 636* 639 640 642 652 722 749 866* 1682* 1684 1685 1687 1921 1924* 1931* 1945 2239 2258 2266 file_op constant fixed bin(17,0) initial dcl 2-28 ref 688 file_type 6 based fixed bin(17,0) level 2 dcl 2-1 set ref 323* 658* 699 706 728 730 737 752 766 767 771 774 780 781 833 844 884 911 913 1157 1159 1509* 2308 2312 2322 2348 2363 2364 2385 2398 2399 2466* 2657 2681 2749* 2873* 2884* 2902* 3028* 3074 3185 3195 3201 3217 3240 3259 finish 153 based fixed bin(17,0) level 3 in structure "basic_operators_frame" packed unaligned dcl 1-1 in procedure "basic_runtime_" ref 3438 4274 finish 154 based fixed bin(17,0) level 3 in structure "basic_operators_frame" packed unaligned dcl 1-1 in procedure "basic_runtime_" ref 3447 4283 fix_bin based fixed bin(17,0) array dcl 100 ref 3451 4287 fixed builtin function dcl 201 ref 399 399 406 504 529 583 585 590 592 616 636 694 763 905 913 919 936 943 1151 1157 1210 1239 1256 1263 1423 1425 1621 1629 1682 1708 1709 1719 1719 1787 1788 1986 1990 1993 2000 2006 2007 2009 2009 2034 2077 3067 3798 3798 4007 4442 4442 fixed_dec_1 000315 automatic fixed dec(1,0) dcl 195 set ref 2126* 2126 2127 3873* 3873 3874 4057* 4057 4058 4517* 4517 4518 fixed_dec_1_overlay based char(2) dcl 195 set ref 2127 3874* 4058 4518* fixed_dec_2 000316 automatic fixed dec(2,0) dcl 198 set ref 2130* 2130 2131 3878* 3878 3879 4061* 4061 4062 4522* 4522 4523 fixed_dec_2_overlay based char(3) dcl 198 set ref 2131 3879* 4062 4523* fixed_dec_value 003276 automatic fixed dec(9,0) dcl 3984 in procedure "d_convert_number" set ref 4013* 4013 4015 4016 fixed_dec_value 002536 automatic fixed dec(9,0) dcl 2053 in procedure "convert_number" set ref 2083* 2083 2085 2086 fixed_dec_value 002764 automatic fixed dec(7,0) dcl 2894 in procedure "attach_string" set ref 2897* 2897 2898 2900 fixed_digits based char(8) dcl 2895 in procedure "attach_string" ref 2898 2900 fixed_digits based char(10) dcl 3995 in procedure "d_convert_number" ref 4015 4016 fixed_digits based char(10) dcl 2065 in procedure "convert_number" ref 2085 2086 flags 3 based structure level 2 in structure "uns_info" dcl 3-1 in procedure "basic_runtime_" flags 170 based structure level 2 in structure "basic_operators_frame" packed unaligned dcl 1-1 in procedure "basic_runtime_" float builtin function dcl 201 ref 616 913 936 1157 1210 1256 2077 4007 float_bin based float bin(27) array dcl 94 set ref 931* 936* 951 965 3392* 3422 3440* 3440 3465* 3478 3500 4276 float_sign 003402 automatic char(1) dcl 4412 in procedure "d_print_using_numeric" set ref 4478* 4480* 4488* 4492* 4534 4558 4558* float_sign 003222 automatic char(1) dcl 3768 in procedure "print_using_numeric" set ref 3834* 3836* 3844* 3848* 3890 3914 3914* fn parameter float bin(27) dcl 1674 ref 1672 1682 get_line 42 based entry variable level 2 dcl 7-6 ref 2676 2696 get_pdir_ 000212 constant entry external dcl 134 ref 672 good_string 003310 automatic bit(1) dcl 4098 in procedure "d_convert_string" set ref 4101* 4106* 4109 good_string 002550 automatic bit(1) dcl 2165 in procedure "convert_string" set ref 2168* 2173* 2176 had_quit 170(03) based bit(1) level 3 packed unaligned dcl 1-1 set ref 650 1081 1110 1641* 1871 1897 2475 2628 2694 3026 3971* have_conversion_label based bit(36) dcl 254 set ref 1567 2175* 3213* 4108* have_decimal 0(06) 000314 automatic bit(1) level 2 packed unaligned dcl 186 set ref 3726 3741 3743* have_dollar 0(02) 000314 automatic bit(1) level 2 packed unaligned dcl 186 set ref 3683* 3912 4556 have_exp 0(05) 000314 automatic bit(1) level 2 packed unaligned dcl 186 set ref 3752* 3816 3836 3846 3857 4460 4480 4490 4501 have_minus 0(04) 000314 automatic bit(1) level 2 packed unaligned dcl 186 set ref 3694* 3714* 3790 4434 have_plus 0(03) 000314 automatic bit(1) level 2 packed unaligned dcl 186 set ref 3692* 3707* have_size_label based bit(36) dcl 256 set ref 1574 3801* 3899* 4445* 4543* hbound builtin function dcl 201 ref 898 1144 1555 hcs_$del_dir_tree 000206 constant entry external dcl 134 ref 2594 hcs_$delentry_file 000204 constant entry external dcl 134 ref 2587 2596 hcs_$make_seg 000174 constant entry external dcl 134 ref 286 hcs_$status_ 000216 constant entry external dcl 134 ref 2784 header_id 4 based fixed bin(35,0) level 2 dcl 3-1 ref 2853 header_numbers 000507 constant char(1) initial array unaligned dcl 109 ref 2882 header_present 3(02) based bit(1) level 3 packed unaligned dcl 3-1 ref 2426 2819 2850 here_before 003210 automatic bit(1) unaligned dcl 3625 set ref 3627* 3645 3647* i 000265 automatic fixed bin(17,0) dcl 45 in procedure "basic_runtime_" set ref 310* 311* 504* 507 516 520 524 583* 585 590* 596 599 602 774* 775* 776* 898* 899* 911 911 913 935* 936 936* 964* 965 970* 976 1144* 1145* 1157 1159 1255* 1256 1256* 1284* 1285 1290* 1296 1418* 1434* 1435 1435* 1555* 1556* 1562 1787* 1788 1790 1792* 2532* 2533 2540 2546* 2552* 2615* 2616* i 002514 automatic fixed bin(17,0) dcl 2029 in procedure "cleanup_strings" set ref 2034* i 003340 automatic fixed bin(17,0) dcl 4175 in procedure "d_mat_loop" set ref 4189* 4198* 4228 4249 4249 4253 4258 4266 4266 4276 4285 4285 4293 4301 4306 4306 4309 4314 4320 4320 4326 4326 4331 4336 4343 4343 4350 4350 4351 4356 4357 4361* 4361 4364* 4364 i 003124 automatic fixed bin(17,0) dcl 3339 in procedure "mat_loop" set ref 3353* 3362* 3392 3413 3413 3417 3422 3430 3430 3440 3449 3449 3457 3465 3470 3470 3473 3478 3484 3484 3490 3490 3495 3500 3507 3507 3514 3514 3515 3520 3521 3525* 3525 3528* 3528 i 002502 automatic fixed bin(17,0) dcl 1983 in procedure "get_line_number" set ref 1998* 2000 2002 2006 2006* 2006 2007 2009 2009 2011 i 000100 automatic fixed bin(17,0) dcl 2186 in begin block on line 2184 set ref 2192* 2193 2199* i 000100 automatic fixed bin(17,0) dcl 4119 in begin block on line 4117 set ref 4125* 4126 4132* if 5(29) based bit(1) level 3 packed unaligned dcl 9-56 set ref 1721* ignore_handler 170(04) based bit(1) level 3 packed unaligned dcl 1-1 ref 1542 ilc 4 based bit(18) level 2 packed unaligned dcl 9-56 set ref 1621 1708 1719* 1719 incoming_args 5 based structure level 2 dcl 4-1 index builtin function dcl 201 ref 520 563 674 2193 2726 2759 2762 2763 3255 3653 3823 3904 3946 4126 4467 4548 index_block based structure array level 2 dcl 207 info 000317 automatic fixed bin(35,0) array dcl 238 set ref 2421* 2422 2422 2425 2426 2426 2812* 2813 2813 2819 2819 2827 2827 2842 2843 2847 2850 2853 info_ptr parameter pointer dcl 1522 ref 1520 input_op constant fixed bin(17,0) initial dcl 2-28 ref 2256 2260 io_ops_since_margin 13 based fixed bin(35,0) level 2 dcl 2-1 set ref 662* 717* 2306* 2306 2325 2327* 2344* 2344 2370* 2381* 2381 2401 2403* ioa_ 000160 constant entry external dcl 134 ref 1940 1959 2826 2836 ioa_$nnl 000162 constant entry external dcl 134 ref 1939 1941 1945 1959 1964 3220 3261 iocb based structure level 1 dcl 7-6 iocbptr parameter pointer dcl 2417 set ref 2415 2419 2422* iox_$attach_iocb 000246 constant entry external dcl 134 ref 2448 2744 2920 iox_$close 000224 constant entry external dcl 134 ref 2952 2977 iox_$control 000222 constant entry external dcl 134 ref 702 710 741 841 877 2422 2974 iox_$destroy_iocb 000250 constant entry external dcl 134 ref 2575 iox_$find_iocb 000244 constant entry external dcl 134 ref 2729 2916 iox_$get_chars 000232 constant entry external dcl 134 ref 3109 4161 iox_$open 000220 constant entry external dcl 134 ref 2452 2956 2981 iox_$position 000226 constant entry external dcl 134 ref 740 782 2987 iox_$put_chars 000230 constant entry external dcl 134 ref 3084 4149 iox_$read_record 000234 constant entry external dcl 134 ref 3121 iox_$user_input 000254 external static pointer dcl 163 ref 2258 iox_$user_output 000252 external static pointer dcl 163 set ref 2239 2293 2293* iox_$write_record 000236 constant entry external dcl 134 ref 3097 ir 4(18) based structure level 2 packed unaligned dcl 9-56 j 002532 automatic fixed bin(17,0) dcl 2053 in procedure "convert_number" set ref 2137* 2139 2141 2144 2144 2148 2150 2150 j 000101 automatic fixed bin(17,0) dcl 2186 in begin block on line 2184 set ref 2190* 2198* 2198 2199 j 003273 automatic fixed bin(17,0) dcl 3984 in procedure "d_convert_number" set ref 4068* 4070 4072 4076 4076 4081 4083 4083 j 000101 automatic fixed bin(17,0) dcl 4119 in begin block on line 4117 set ref 4123* 4131* 4131 4132 k 000266 automatic fixed bin(17,0) dcl 45 in procedure "basic_runtime_" set ref 1949* 1950 1951 1953 1955 2535* 2536* 2536 2538 2546 2546 2547 2548 2552 3045* 3046 3047 3051 3255* 3257 3267 3273* 3275 3277 3277* 3284 3284 3297 k 003272 automatic fixed bin(17,0) dcl 3984 in procedure "d_convert_number" set ref 4015* 4016 4026* 4027 4029 k 002762 automatic fixed bin(17,0) dcl 2893 in procedure "attach_string" set ref 2898* 2900 k 002531 automatic fixed bin(17,0) dcl 2053 in procedure "convert_number" set ref 2085* 2086 2095* 2096 2098 last_operation 14 based fixed bin(17,0) level 2 dcl 2-1 set ref 325* 688* 744* 785* 1927 2236 2242* 2256 2260* 2285* 2333* 2566 2568 2602* 2638 last_position 1 000344 automatic fixed bin(34,0) level 2 dcl 240 set ref 703 880 left_just 000314 automatic bit(1) level 2 packed unaligned dcl 186 set ref 3666* 3780 3939 4424 len 2 based fixed bin(17,0) array level 3 in structure "message_overlay" dcl 207 in procedure "basic_runtime_" ref 1951 1951 1953 1953 1955 1955 len based fixed bin(17,0) level 2 in structure "varying" dcl 87 in procedure "basic_runtime_" set ref 961* 1281* length builtin function dcl 201 in procedure "basic_runtime_" ref 321 442 442 516 564 575 599 675 926 1073 1180 1202 1246 1434 1852 2186 2192 2528 2533 2586 2586 2727 2737 2740 2760 2780 2780 3097 3097 3452 3585 3934 3955 4119 4125 4288 length 1(18) based fixed bin(17,0) level 2 in structure "arg_info" packed unaligned dcl 224 in procedure "basic_runtime_" ref 1794 line 0(18) based bit(18) array level 2 packed unaligned dcl 250 ref 2007 2009 line_pos 10 based fixed bin(17,0) level 2 dcl 2-1 set ref 378 406 611 1927 2241* 2505* 2528 2536 2542* 2542 2548* 2548 2550 2568 2638 3042 3054* 3545 3600 3604* 3604 4384 ln 002460 automatic fixed bin(17,0) dcl 1914 set ref 1919* 1950* 1951* 1953* 1955* 1969* loc 000267 automatic fixed bin(17,0) dcl 45 in procedure "basic_runtime_" set ref 1621* 1629* 1708* 1709* 1986* 1990* 1990 2002 2004 2006 2009 loc based fixed bin(17,0) array level 3 in structure "message_overlay" dcl 207 in procedure "basic_runtime_" ref 1949 loc_number based structure level 1 packed unaligned dcl 4-18 location based bit(18) array level 2 in structure "map" packed unaligned dcl 250 in procedure "basic_runtime_" ref 2000 2006 2009 location 14 based bit(18) level 3 in structure "basic_program_header" packed unaligned dcl 4-1 in procedure "basic_runtime_" ref 1995 location 2 based bit(18) level 3 in structure "basic_program_header" packed unaligned dcl 4-1 in procedure "basic_runtime_" ref 2032 location 5 based bit(18) level 3 in structure "basic_program_header" packed unaligned dcl 4-1 in procedure "basic_runtime_" ref 1785 lower 002500 automatic fixed bin(17,0) dcl 1983 set ref 1992* 1997 1998 2011* m 000270 automatic fixed bin(17,0) dcl 45 set ref 951* 952 954 964 975 1271* 1272 1274 1284 1295 main 002463 automatic bit(1) unaligned dcl 1914 set ref 1937* 1939 1957 main_program 170(01) based bit(1) level 3 packed unaligned dcl 1-1 ref 1937 map based structure array level 1 dcl 250 map_loc 002503 automatic fixed bin(17,0) dcl 1983 set ref 2000* 2002 2004 margin 12 based fixed bin(17,0) level 2 dcl 2-1 set ref 300* 661* 716* 855 2326* 2369* 2401 2402* 2467 2467* 2528 2528 2536 2536 2550 2843* 2854* 2897 3039 3040 3097 3097 3600 3600 margin_info 000346 automatic structure level 1 dcl 244 set ref 710 710 mat_input 000256 automatic bit(1) unaligned dcl 45 set ref 469* 484* 984* 993* 1304* 1313* 3166 3284 math_message 000114 internal static fixed bin(17,0) initial array dcl 1530 set ref 1562* max builtin function dcl 201 ref 377 599 1003 1014 1323 1334 4383 max_buffer_size constant fixed bin(17,0) initial dcl 79 ref 2682 max_rec_len 6 based fixed bin(21,0) level 2 dcl 3-21 ref 2843 max_string_size constant fixed bin(17,0) initial dcl 79 ref 444 mc based structure level 1 dcl 9-12 mc_ptr parameter pointer dcl 1522 ref 1520 1587 1587 1606 1606 1616 1648 1701 mcp 002354 automatic pointer dcl 9-10 set ref 1616* 1617 1701* 1702 1704 1741 1742 1743 1747 1748 1749 message based char level 2 packed unaligned dcl 207 set ref 1951* 1953* 1955* message_overlay based structure level 1 dcl 207 min builtin function dcl 201 ref 599 2536 3045 3097 3097 mod builtin function dcl 201 ref 3040 mode 3 002350 automatic bit(5) level 2 packed unaligned dcl 8-2 set ref 2798 2808 mp 002504 automatic pointer dcl 1983 set ref 1995* 2000 2006 2007 2009 2009 must_be_ascii 17(03) based bit(1) level 3 packed unaligned dcl 2-1 set ref 2353 2390 2575 2724* 2778* 2801* n 000271 automatic fixed bin(17,0) dcl 45 set ref 442* 444 452 520* 522 524 532* 534 563* 564 564* 566 566 575* 577 585* 592* 596* 599* 599 602 602 611 674* 675 675* 677 694* 696 697 703 709 711 716 763* 768 779 780 781 823 824 832 833 841 844 855 864 866 867 905* 907 908 910 911 913 926* 928 931 935 954* 961 975* 975 976 976 1151* 1153 1154 1156 1157 1169* 1172 1172 1180* 1182 1188 1202* 1204 1246* 1248 1251 1255 1274* 1281 1295* 1295 1296 1296 1423* 1425* 1434 1441* 1444* 1447* 1451* 1455* 1459* 1463* 1467* 1471* 1475* 1479* 1483* 1487* 1491* 1495* 1499* 1503* 1507* 1512* 1516* 1547* 1549 1550 1551 1553 1556 1794* 1795 1796 1852* 1855 1868 1894 2533* 2538 2540 2540 2541 2542 2726* 2727 2727* 2729 2729 2737 2739 2740 2741* 2741 2744 2744 2759* 2760 2760* 2762 2763 3039* 3040* 3042* 3042 3044 3045 3051* 3051 3067* 3069 3070 3072 3074 3124* 3126 3126 3157* 3178* 3178 3179 3190 3210 3211 3220 3220 3236* 3238 3246 3267* 3277* 3279 3284* 3284 3295 3295 3309* 3310 3310* 3314 3314 3325* 3327 3452* 3455 4288* 4291 n_spaces 003242 automatic fixed bin(17,0) dcl 3928 set ref 3934* 3936 3937 3939* 3946 3950* 3950 name parameter char unaligned dcl 1522 ref 1520 1543 ndigits 002533 automatic fixed bin(17,0) dcl 2053 in procedure "convert_number" set ref 2096* 2103 2108 2119 2122 2137 2141 2145 2150 ndigits 003274 automatic fixed bin(17,0) dcl 3984 in procedure "d_convert_number" set ref 4027* 4034 4040 4050 4053 4068 4072 4077 4083 new_max_recl 1 000346 automatic fixed bin(21,0) level 2 dcl 244 set ref 709* new_mode parameter fixed bin(17,0) dcl 2379 in procedure "check_random_string" set ref 2377 2383 2386* 2407* new_mode parameter fixed bin(17,0) dcl 2342 in procedure "check_random_numeric" set ref 2340 2346 2349* 2367* new_mode parameter fixed bin(17,0) dcl 2304 in procedure "check_ascii" set ref 2302 2310 2313* 2331* new_open_mode parameter fixed bin(17,0) dcl 2948 in procedure "open_ascii" ref 2946 2956 2960 new_open_mode parameter fixed bin(17,0) dcl 2970 in procedure "open_random" ref 2968 2981 2991 new_pos parameter fixed bin(17,0) dcl 3037 ref 3035 3039 3040 3054 next_position 000344 automatic fixed bin(34,0) level 2 dcl 240 set ref 844 846 880 2976 no_input 000255 automatic bit(1) unaligned dcl 45 set ref 473 488 3153* 3214* 3232* 3299* 3376 3384 3399 3407 4212 4220 4235 4243 non_basic_caller 170 based bit(1) level 3 packed unaligned dcl 1-1 ref 1778 normal parameter bit(1) dcl 1761 in procedure "tidy_up" set ref 1759 1803* normal parameter bit(1) dcl 2613 in procedure "close_all_files" ref 2611 2632 null builtin function dcl 201 ref 279 288 299 311 317 644 653 663 727 741 741 833 910 1156 1587 1606 1689 1702 2419 2618 2621 2642 2735 2755 2784 2784 2915 3002 3003 3011 3019 3022 3072 null_vs 000140 internal static varying char(1) initial dcl 2216 set ref 2219 num parameter fixed bin(17,0) dcl 1914 ref 1912 1934 1939 1959 1964 1967 num_size 003275 automatic fixed bin(17,0) dcl 3984 set ref 4023* 4024* 4026 4027 4029 4034 4040 4048 4050 4072 4077 4081 4083 number 2(18) based bit(18) level 3 in structure "basic_program_header" packed unaligned dcl 4-1 in procedure "basic_runtime_" ref 2034 number 14(18) based bit(18) level 3 in structure "basic_program_header" packed unaligned dcl 4-1 in procedure "basic_runtime_" ref 1993 number 5(18) based bit(18) level 3 in structure "basic_program_header" packed unaligned dcl 4-1 in procedure "basic_runtime_" ref 1787 number_length 170(18) based fixed bin(17,0) level 2 packed unaligned dcl 1-1 ref 377 4023 4383 4507 number_read 161 based fixed bin(17,0) level 2 dcl 1-1 set ref 985* 994* 1305* 1314* 3380 3390* 3390 3403 3415* 3415 4216 4226* 4226 4239 4251* 4251 numeric_data 153 based structure level 2 packed unaligned dcl 1-1 numeric_file constant fixed bin(17,0) initial dcl 2-22 ref 699 737 774 780 844 2322 2348 2398 2884 offset based bit(18) level 2 packed unaligned dcl 220 set ref 1192* 1837 1842 1846* 1846 1857* 1886 1888 2221 2221 ok_type parameter bit(5) dcl 3065 ref 3063 3074 old_buff_size 000261 automatic fixed bin(21,0) dcl 45 set ref 2684* 2685 2689 2689 2696 2696 2696 2696 2696* old_max_recl 000346 automatic fixed bin(21,0) level 2 dcl 244 set ref 711 oncode builtin function dcl 201 ref 1547 1547 oncode_values 000400 constant fixed bin(17,0) initial array dcl 1528 ref 1555 1556 open_descrip_ptr 20 based pointer level 2 dcl 7-6 ref 2753 3003 open_mode 7 based fixed bin(17,0) level 2 dcl 2-1 set ref 301* 659* 736 752 754 773 833 869 2310 2311 2346 2347 2356 2383 2384 2394 2762* 2764 2764* 2766* 2950 2960* 2972 2986 2991* 3008* open_types 000424 constant fixed bin(17,0) initial array dcl 2-46 set ref 2956* 2981* opened_by_us 17(01) based bit(1) level 3 packed unaligned dcl 2-1 set ref 2453* 2951 2959* 2973 2984* 3003 3007* original_bounds 2 based fixed bin(17,0) array level 2 dcl 5-1 ref 3355 4191 owner 4 based pointer level 2 dcl 2-1 set ref 299* 317 317* 654* 2618 2636 2642* p 002516 automatic pointer dcl 2029 set ref 2032* 2035* 2037* 2037 p1 000102 automatic pointer dcl 45 set ref 369* 418* 422 428 430 438* 442 452 514* 516 520 594* 599 602 665* 667 683 806* 895* 899 924* 926 933* 933 936 959* 961 962* 962 970 976 1072* 1073 1083 1096* 1141* 1145 1178* 1180 1182 1188 1244* 1246 1253* 1253 1256 1279* 1281 1282* 1282 1290 1296 1433* 1434 1539* 1540 1540 1653* 1654 1654 1666* 1667 1667 1785* 1788 1842* 1844 1844 2167* 2171 2180 2186 2192 2193 2199 2524* 2528 2533 2540 2546 3097 3097 3097 3097 3430* 3451* 3452 3455 3484* 3507* 3934 3955 3956 4100* 4104 4113 4119 4125 4126 4132 4266* 4287* 4288 4291 4320* 4343* p2 000104 automatic pointer dcl 45 set ref 420* 422 428 430 440* 442 452 518* 520 930* 931 936 950* 951 965 1250* 1251 1256 1270* 1271 1285 1790* 1791* 1794 1795 1798* p3 000106 automatic pointer dcl 45 set ref 452 534 566 577 602 958 959 1172 1188 1192 1204 1278 1279 1791* 1795 1796 1855 1857 1868* 1873 3126 3139 3295 3314 3327 3417 3455 3457 3473 3495 4253 4291 4293 4309 4331 p4 000110 automatic pointer dcl 45 set ref 1134* 1413* 1792* 1795 1796 2753* 2755 2757 2759 2760 2762 2763 3521 4357 param_info_aligned based structure level 1 packed unaligned dcl 204 param_type based bit(9) array level 2 packed unaligned dcl 204 ref 1788 per_bits 000434 constant bit(5) initial array dcl 117 ref 1157 per_name 000443 constant varying char(8) initial array dcl 114 ref 1144 1145 position 62 based entry variable level 2 dcl 7-6 ref 2277 position_info 000344 automatic structure level 1 dcl 240 set ref 702 702 841 841 877 877 2974 2974 ppr based structure level 2 packed unaligned dcl 9-56 pr based pointer array level 2 dcl 1-1 set ref 369* 413* 413 418* 420* 438* 440* 514* 518* 594* 630* 665* 806* 895* 924* 928 930 948* 950 952 958 1003 1014 1072* 1096* 1134 1141* 1172 1178* 1190* 1192 1244* 1248 1250 1268* 1270 1272 1278 1323 1334 1413 1433* 1822 1822 1826* 1828 1833 1837 1842 1846 1846 1852 1855 1857 1953 1955* 2167* 3140* 3343 3346 3355 3365 3380 3403 3520* 3521* 4100* 4179 4182 4191 4201 4216 4239 4356* 4357* prec_lng parameter fixed bin(17,0) unaligned dcl 1732 ref 1729 1740 precision 000306 automatic fixed bin(17,0) dcl 183 set ref 3629* 3724* 3724 3790* 3790 3794 3798 3798 3808 3808* 3810* 3813 3857 3934 4434* 4434 4438 4442 4442 4452 4452* 4454* 4457 4501 precision_lng 147 based fixed bin(17,0) level 2 packed unaligned dcl 1-1 set ref 275 780 844 1550 1582* 1594* 2426 2521 2853 2882 3210 prev_sp 20 based pointer level 2 dcl 1-1 ref 1680 print_op constant fixed bin(17,0) initial dcl 2-28 ref 1927 2236 2242 2568 2638 print_using_bits 000314 automatic structure level 1 packed unaligned dcl 186 set ref 3635* print_using_pt 50 based pointer level 2 dcl 1-1 set ref 1078* 1083 1107 3653 3657 3657 3692 3695 3822 3902 3944 4466 4546 program_header 102 based pointer level 2 dcl 1-1 ref 327 1619 1708 1763 1993 1995 1995 2032 2034 program_header_offset 152 based bit(18) level 2 dcl 1-1 ref 1990 program_header_pt 000112 automatic pointer dcl 45 set ref 327* 329 340 1763* 1765 1785 1785 1787 psr 0(03) based bit(15) level 3 packed unaligned dcl 9-56 ref 1619 1706 ptr builtin function dcl 201 ref 1842 1888 2221 pu_length 163 based fixed bin(17,0) level 2 dcl 1-1 set ref 1073* 1075 1078 1078 1083 1107 1107 3639 3653 3657 3657 3690 3692 3695 3822 3902 3944 4466 4546 pu_pos 162 based fixed bin(17,0) level 2 dcl 1-1 set ref 1084* 3556* 3637* 3637 3639 3649* 3653 3657 3657 3668 3685 3690 3692 3695 3698* 3698 3755* 3755 4395* pu_string based char dcl 193 set ref 1078 1083* 1107 3653 3657 3657 3692 3695 3822 3902 3944 4466 4546 put_chars 52 based entry variable level 2 dcl 7-6 ref 2293 2485 q 25 based bit(36) level 3 packed unaligned dcl 9-12 set ref 1743* 1749* q_reg 45 based fixed bin(35,0) level 3 dcl 1-1 ref 275 quit 003254 stack reference condition dcl 3969 ref 3972 quits_disabled 170(02) based bit(1) level 3 packed unaligned dcl 1-1 set ref 646* 648* 1077* 1079* 1106* 1108* 1638 1867* 1869* 1893* 1895* 2471* 2473* 2624* 2626* 2687* 2692* 3020* 3023* regs 20 based structure level 2 in structure "mc" packed unaligned dcl 9-12 in procedure "basic_runtime_" regs 40 based structure level 2 in structure "basic_operators_frame" dcl 1-1 in procedure "basic_runtime_" rel builtin function dcl 201 ref 958 1192 1278 1857 3139 3417 3457 3473 3495 4253 4293 4309 4331 reset_op constant fixed bin(17,0) initial dcl 2-28 ref 785 2285 reverse builtin function dcl 201 ref 2095 4026 rfi 5(27) based bit(1) level 3 packed unaligned dcl 9-56 set ref 1720* right_just 0(01) 000314 automatic bit(1) level 2 packed unaligned dcl 186 set ref 3676* 3781 3932 4425 row 003334 automatic fixed bin(17,0) dcl 4175 in procedure "d_mat_loop" set ref 4203* 4370 row 003120 automatic fixed bin(17,0) dcl 3339 in procedure "mat_loop" set ref 3367* 3534 row_max 003121 automatic fixed bin(17,0) dcl 3339 in procedure "mat_loop" set ref 3343* 3344 3355* 3367 3534 row_max 003335 automatic fixed bin(17,0) dcl 4175 in procedure "d_mat_loop" set ref 4179* 4180 4191* 4203 4370 rtrim builtin function dcl 201 ref 2869 2882 2900 s parameter char dcl 3581 ref 3579 3585 3586 3586 s_pos 003243 automatic fixed bin(17,0) dcl 3928 set ref 3936* 3937* 3939* 3953* 3953 3955 3956 save_fcb_pt 002464 automatic pointer dcl 1914 set ref 1922* 1932 save_file_number 002461 automatic fixed bin(17,0) dcl 1914 set ref 1921* 1931 scale 000307 automatic fixed bin(17,0) dcl 183 set ref 3629* 3726* 3726 3783 3798 3798 3813 3857 4427 4442 4442 4457 4501 scratch_op constant fixed bin(17,0) initial dcl 2-28 ref 744 scu based structure level 1 dcl 9-56 in procedure "basic_runtime_" scu 30 based bit(36) array level 2 in structure "mc" packed unaligned dcl 9-12 in procedure "basic_runtime_" set ref 1587 1606 1617 1704 scup 002356 automatic pointer dcl 9-54 set ref 1617* 1619 1621 1704* 1706 1708 1719 1719 1720 1721 search builtin function dcl 201 ref 2180 3176 3273 4113 seg_no 000257 automatic bit(18) unaligned dcl 45 set ref 1706* 1708 seg_pt based pointer level 2 dcl 2-1 set ref 653* 702* 710* 727 740* 741* 782* 824* 833 841* 871* 877* 2239* 2258* 2277 2277* 2320* 2358* 2396* 2448* 2452* 2485 2485* 2575* 2621 2676 2676* 2696 2696* 2729* 2735 2744* 2753 2915 2916* 2920* 2952* 2956* 2974* 2977* 2981* 2987* 3002 3003 3005 3005* 3011 3013 3013* 3084* 3097* 3109* 3121* 4149* 4161* sev 1 based fixed bin(17,0) array level 3 dcl 207 ref 1936 si 003172 automatic fixed bin(17,0) dcl 3583 set ref 3585* 3586 3586* sign based char(1) level 2 in structure "decimal_value" packed unaligned dcl 4416 in procedure "d_print_using_numeric" ref 4478 sign based char(1) level 2 in structure "decimal_value" packed unaligned dcl 3772 in procedure "print_using_numeric" ref 3834 size_label 62 based label variable level 2 dcl 1-1 set ref 1574 1576 1577 3796* 3801 3899 4440* 4445 4543 sp parameter pointer dcl 1884 in procedure "deallocate_string" ref 1882 1886 1888 1900 sp parameter pointer dcl 2216 in procedure "get_string_ptr" ref 2214 2219 2221 2221 2224 stack 2 based pointer level 2 dcl 74 set ref 338* 1771* start 154(18) based fixed bin(17,0) level 3 in structure "basic_operators_frame" packed unaligned dcl 1-1 in procedure "basic_runtime_" set ref 3447 3451 3459* 3459 4283 4287 4295* 4295 start 153(18) based fixed bin(17,0) level 3 in structure "basic_operators_frame" packed unaligned dcl 1-1 in procedure "basic_runtime_" set ref 3438 3440 3442* 3442 4274 4276 4278* 4278 statement_map 14 based structure level 2 dcl 4-1 status_info_branch 002350 automatic structure level 1 packed unaligned dcl 8-2 set ref 2784 2784 str based bit array level 2 packed unaligned dcl 91 set ref 936 970* 976* 1256 1290* 1296* stream_output 000566 constant fixed bin(17,0) initial dcl 2-48 set ref 2452* string builtin function dcl 201 set ref 657* 1900* 2940 3635* string_area based area(65536) dcl 236 ref 647 1078 1107 1868 1894 2472 2625 2688 2690 3021 string_buffer 000350 automatic char(4096) dcl 248 set ref 3121 3121 3126 string_data 154 based structure level 2 packed unaligned dcl 1-1 string_file constant fixed bin(17,0) initial dcl 2-22 ref 706 781 2363 2385 2902 string_scalar_param constant fixed bin(17,0) initial dcl 6-1 ref 1788 string_seg 000302 automatic pointer dcl 181 set ref 286* 288 294* 296 string_segment 106 based pointer level 2 dcl 1-1 set ref 304* 647 1078 1107 1842 1868 1888 1894 2221 2472 2625 2688 2690 3021 string_storage 2 based structure level 2 dcl 4-1 string_value 171 based bit(36) level 2 dcl 1-1 set ref 305* 2042 2042 3137 3137 3139* 3140 string_word based structure level 1 dcl 220 set ref 413 1900* substr builtin function dcl 201 set ref 520 544 544 544 554 554 554 566 602 677 968 970 976* 1157 1288 1290 1296* 1787 2085 2086 2108 2110 2117 2119 2144 2145 2148 2150 2193 2199* 2199 2292* 2501* 2540* 2540 2546* 2546 2689* 2689 2717 2729 2729 2739 2744 2744 2757 2762 2763 2798 2808 2898 2900 3046* 3074 3126 3161 3166 3179* 3201 3201 3210 3211 3220 3220 3236 3248 3255 3261 3261 3273 3279 3284 3295 3314 3569 3586 3586 3607* 3653 3657 3657 3692 3695 3822 3902 3944 3956 4015 4016 4040 4048 4050 4076 4077 4081 4083 4126 4132* 4132 4466 4546 sys_info$max_seg_size 000156 external static fixed bin(17,0) dcl 66 ref 294 tab_size 000272 automatic fixed bin(17,0) dcl 45 set ref 377* 378 378 378 4383* 4384 4384 4384 temp 172 based float bin(27) array level 3 dcl 1-1 set ref 399 399 406 424* 428* 430* 432* 504 510* 524* 529 583 585 590 592 611* 616* 636 694 763 824* 837* 844* 846* 855* 864* 872* 873* 878* 880* 883* 884* 902* 905 910* 911* 913* 919 943 1148* 1151 1156* 1157* 1159* 1210* 1239 1263 1423 1425 2067 2073 2075 2171* 2171 2203* 2203 3067 3084 3084 3109 3109 3210* 3210 3392 3422* 3465 3478* 3500* 3790 3798 3798 3810 3810 3812 3842 4442 4442 4454 4454 temporaries 172 based structure array level 2 dcl 1-1 temporary_file 17(02) based bit(1) level 3 packed unaligned dcl 2-1 set ref 679* 2582 text_base_ptr 104 based pointer level 2 dcl 1-1 ref 3440 3451 3451 4276 4287 4287 time builtin function dcl 201 ref 541 time_limit 6 based float bin(27) level 2 dcl 4-1 ref 329 340 1765 timer_manager_$cpu_call 000170 constant entry external dcl 134 ref 340 timer_manager_$reset_cpu_call 000172 constant entry external dcl 134 ref 1773 tty_fcb 000014 internal static fixed bin(71,0) array dcl 262 set ref 298 314 tty_file constant fixed bin(17,0) initial dcl 2-22 ref 323 766 2308 2657 2681 3185 3195 3201 3217 3240 3259 typ_name 000470 constant varying char(8) initial array dcl 111 ref 898 899 type 1 based fixed bin(17,0) level 2 in structure "arg_info" packed unaligned dcl 224 in procedure "basic_runtime_" ref 1795 type 1 based fixed bin(17,0) level 2 in structure "uns_info" dcl 3-1 in procedure "basic_runtime_" ref 2426 2819 2847 type 1 based fixed bin(17,0) level 2 in structure "blk_info" dcl 3-21 in procedure "basic_runtime_" ref 2842 type 002350 automatic bit(2) level 2 in structure "status_info_branch" packed unaligned dcl 8-2 in procedure "basic_runtime_" set ref 2799 undefined_file constant fixed bin(17,0) initial dcl 2-22 ref 658 728 752 767 833 911 1159 1509 3028 unique_count 000142 internal static fixed dec(6,0) initial dcl 2932 set ref 2937* 2937 2938 unique_value 000144 internal static structure level 1 packed unaligned dcl 2932 set ref 2940 uns_info based structure level 1 unaligned dcl 3-1 unspec builtin function dcl 201 set ref 529* upper 002501 automatic fixed bin(17,0) dcl 1983 set ref 1993* 1997 1998 2002* user_info_ 000202 constant entry external dcl 134 ref 560 user_name 000135 automatic char(22) unaligned dcl 45 set ref 560* 563 564 566 value 1 based varying char level 2 dcl 216 set ref 452* 534* 566* 577* 602* 959 1172* 1188* 1204* 1279 1855* 2221 3126* 3295* 3314* 3327* 3455* 4291* varying based structure level 1 dcl 87 varying_char_string based varying char dcl 107 set ref 1796* vbs based bit(36) dcl 68 ref 968 970 vector 003130 automatic bit(1) dcl 3339 in procedure "mat_loop" set ref 3351* 3360* 3378 3401 3528 3534 3552 vector 003344 automatic bit(1) dcl 4175 in procedure "d_mat_loop" set ref 4187* 4196* 4214 4237 4364 4370 4391 verify builtin function dcl 201 ref 2085 2095 2898 3236 3569 4015 4026 vfile_status_ 000240 constant entry external dcl 134 ref 2813 2827 vfs_version_1 constant fixed bin(17,0) initial dcl 3-67 ref 2421 2812 vfx 000273 automatic fixed bin(35,0) dcl 68 set ref 965* 967 968 970 white_space 022220 constant char(2) initial unaligned dcl 126 ref 2180 2193 3176 3236 4113 4126 word based fixed bin(17,0) dcl 229 set ref 1828 1833* 2219 write_permission 17(04) based bit(1) level 3 packed unaligned dcl 2-1 set ref 660* 680* 1159 2767* 2793* 2798* xr 40 based bit(18) array level 3 packed unaligned dcl 1-1 ref 1629 1709 1986 zero_surpression 003220 automatic bit(1) unaligned dcl 3768 in procedure "print_using_numeric" set ref 3816* 3825 3857 3887 3916* zero_surpression 003400 automatic bit(1) unaligned dcl 4412 in procedure "d_print_using_numeric" set ref 4460* 4469 4501 4531 4560* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. abx internal static fixed bin(17,0) initial dcl 9-42 apx internal static fixed bin(17,0) initial dcl 9-42 array_symbol based structure level 1 dcl 5-11 bbx internal static fixed bin(17,0) initial dcl 9-42 bpx internal static fixed bin(17,0) initial dcl 9-42 file_param internal static fixed bin(17,0) initial dcl 6-1 indx_info based structure level 1 unaligned dcl 3-33 iox_$detach_iocb 000000 constant entry external dcl 134 iox_$iocb_version_sentinel external static char(4) dcl 7-51 lbx internal static fixed bin(17,0) initial dcl 9-42 lpx internal static fixed bin(17,0) initial dcl 9-42 numeric_function_param internal static fixed bin(17,0) initial dcl 6-1 numeric_list_param internal static fixed bin(17,0) initial dcl 6-1 numeric_scalar_param internal static fixed bin(17,0) initial dcl 6-1 numeric_table_param internal static fixed bin(17,0) initial dcl 6-1 read_op internal static fixed bin(17,0) initial dcl 2-28 sbx internal static fixed bin(17,0) initial dcl 9-42 scalar_symbol based structure level 1 dcl 5-6 scux based structure level 1 dcl 9-207 seq_info based structure level 1 unaligned dcl 3-11 sequential_input internal static fixed bin(17,0) initial dcl 2-48 sequential_update internal static fixed bin(17,0) initial dcl 2-48 spx internal static fixed bin(17,0) initial dcl 9-42 stream_input internal static fixed bin(17,0) initial dcl 2-48 stream_input_output internal static fixed bin(17,0) initial dcl 2-48 string_function_param internal static fixed bin(17,0) initial dcl 6-1 string_list_param internal static fixed bin(17,0) initial dcl 6-1 string_table_param internal static fixed bin(17,0) initial dcl 6-1 vbl_info based structure level 1 unaligned dcl 3-55 write_op internal static fixed bin(17,0) initial dcl 2-28 NAMES DECLARED BY EXPLICIT CONTEXT. allocate_string 006367 constant entry internal dcl 1865 ref 450 533 565 576 601 956 1171 1187 1203 1276 1853 3125 3294 3312 3326 3454 4290 array_error 005215 constant label dcl 1471 ref 3344 3347 4180 4183 attach_ascii 012503 constant entry internal dcl 2867 ref 732 2330 2802 2832 2850 attach_numeric 012575 constant entry internal dcl 2880 ref 2366 2855 attach_string 012675 constant entry internal dcl 2891 ref 2406 2844 attach_vfile 013017 constant entry internal dcl 2909 ref 2869 2882 2900 bad_ni 014232 constant label dcl 3217 ref 3208 basic_runtime_ 001021 constant entry external dcl 41 cannot_read 005257 constant label dcl 1512 cannot_scratch 005262 constant label dcl 1516 cannot_write 005237 constant label dcl 1495 case 000343 constant label array(0:6) dcl 3825 in procedure "print_using_numeric" ref 3823 3842 case 000371 constant label array(0:6) dcl 4469 in procedure "d_print_using_numeric" ref 4467 4486 case 000332 constant label array(0:8) dcl 3657 in procedure "get_next_field" ref 3653 case1a 015521 constant label dcl 3668 ref 3677 3708 3715 change_error 005212 constant label dcl 1467 ref 921 922 928 945 946 952 967 968 1241 1242 1248 1265 1266 1272 1287 1288 check_ascii 010225 constant entry internal dcl 2302 ref 755 2234 2254 check_input 010073 constant entry internal dcl 2252 ref 459 467 482 982 991 1302 1311 3492 4328 check_print 010045 constant entry internal dcl 2232 ref 360 367 375 383 390 397 404 1000 1011 1069 1320 1331 check_random_numeric 010325 constant entry internal dcl 2340 ref 790 797 1022 1036 1225 1232 1342 1356 check_random_string 010426 constant entry internal dcl 2377 ref 708 804 812 1029 1043 1349 1363 cleanup 005720 constant entry external dcl 1662 cleanup_strings 007173 constant entry internal dcl 2027 ref 1776 close_all_files 011363 constant entry internal dcl 2611 ref 1803 close_basic_file 005754 constant entry external dcl 1672 close_error 005250 constant label dcl 1507 ref 2444 close_file 011161 constant entry internal dcl 2562 ref 644 1689 2621 close_vfile 013417 constant entry internal dcl 3000 ref 2364 2399 2443 2458 2574 com 006463 constant label dcl 1921 ref 1970 convert_number 007230 constant entry internal dcl 2051 ref 572 2521 convert_string 007645 constant entry internal dcl 2163 ref 616 622 cpu_limit 005663 constant entry external dcl 1648 ref 337 1770 d_convert_number 016470 constant entry internal dcl 3982 ref 1199 2522 d_convert_string 017152 constant entry internal dcl 4096 ref 1210 1217 d_mat_loop 017405 constant entry internal dcl 4171 ref 1306 1315 1326 1337 1344 1351 1358 1365 1370 1376 1382 1395 1401 1407 1415 d_numeric_read 017354 constant entry internal dcl 4159 ref 1234 4300 d_numeric_write 017325 constant entry internal dcl 4147 ref 1227 4315 d_print_using_numeric 020161 constant entry internal dcl 4410 ref 1389 4337 deallocate_string 006416 constant entry internal dcl 1882 ref 630 948 1190 1268 1798 1826 2035 2042 3137 3413 3449 3470 3490 3514 4249 4285 4306 4326 4350 default 005272 constant entry external dcl 1520 done 007700 constant label dcl 2175 in procedure "convert_string" ref 2180 2182 done 017205 constant label dcl 4108 in procedure "d_convert_string" ref 4113 4115 e_format 007417 constant label dcl 2117 in procedure "convert_number" set ref 2141 e_format 016724 constant label dcl 4048 in procedure "d_convert_number" ref 4072 end_field 015633 constant label dcl 3749 ref 3641 3664 3674 3681 3705 3712 3719 end_input 015301 constant entry internal dcl 3567 ref 498 1064 1384 end_of_file 005176 constant label dcl 1451 ref 2663 3086 3099 3111 3122 4151 4163 end_surpression 016331 constant entry internal dcl 3910 in procedure "print_using_numeric" ref 3857 3889 end_surpression 020653 constant entry internal dcl 4554 in procedure "d_print_using_numeric" ref 4501 4533 err 005166 constant label dcl 1444 ref 1449 1453 1457 1461 1465 1469 1473 1477 1481 1485 1489 1493 1497 1501 1505 1510 1514 1518 error_print 007052 constant entry internal dcl 1967 ref 1602 1622 1631 1658 1736 file_error 005201 constant label dcl 1455 ref 2782 first_error 017213 constant label dcl 4113 in procedure "d_convert_string" ref 4103 first_error 007706 constant label dcl 2180 in procedure "convert_string" ref 2170 force_buffer 010767 constant entry internal dcl 2483 ref 385 2498 2503 2551 3049 3598 get_ascii_buffer 010727 constant entry internal dcl 2464 ref 2772 2871 get_file_number 013621 constant entry internal dcl 3063 ref 608 820 829 852 861 get_input 011464 constant entry internal dcl 2653 ref 474 489 2268 3187 3197 3222 3242 3263 3288 3385 3408 4221 4244 get_line_number 007057 constant entry internal dcl 1981 ref 1919 3220 3220 3261 3261 get_mc_info 006016 constant entry internal dcl 1699 ref 1600 1656 1734 get_next_field 015431 constant entry internal dcl 3621 ref 1103 3778 3930 4422 get_string_ptr 010017 constant entry internal dcl 2214 ref 369 418 420 438 440 514 518 594 665 806 895 924 1072 1096 1141 1178 1244 1433 1791 2167 3430 3484 3507 4100 4266 4320 4343 incorrect_format_for_file_input 005231 constant label dcl 1487 ref 3185 3217 3240 3259 input_line_too_long 005242 constant label dcl 1499 ref 2681 2682 invalid_file_number 005204 constant label dcl 1459 ref 639 640 722 749 766 823 832 842 907 908 1153 1154 3069 3070 3072 3074 invalid_margin 005164 constant label dcl 1441 ref 696 697 703 711 iox_error 005245 constant label dcl 1503 ref 2279 2486 length_of_file 010533 constant entry internal dcl 2415 ref 824 871 2320 2358 2396 linput 014541 constant entry internal dcl 3307 ref 461 3493 4329 mat 000352 constant label array(15) dcl 4210 in procedure "d_mat_loop" ref 4206 mat 000313 constant label array(15) dcl 3374 in procedure "mat_loop" ref 3370 mat_loop 014607 constant entry internal dcl 3335 ref 986 995 1006 1017 1024 1031 1038 1045 1050 1056 1062 1116 1122 1128 1136 mat_print_format 020117 constant entry internal dcl 4378 in procedure "d_mat_loop" ref 4369 4370 mat_print_format 015246 constant entry internal dcl 3542 in procedure "mat_loop" ref 3533 3534 mat_print_format_check 020076 constant entry internal dcl 4367 in procedure "d_mat_loop" ref 4261 4269 mat_print_format_check 015225 constant entry internal dcl 3531 in procedure "mat_loop" ref 3425 3433 mat_print_using_check 020147 constant entry internal dcl 4389 in procedure "d_mat_loop" ref 4338 4345 mat_print_using_check 015267 constant entry internal dcl 3550 in procedure "mat_loop" ref 3502 3509 math_error 005422 constant label dcl 1562 ref 1556 next 016264 constant label dcl 3895 in procedure "print_using_numeric" ref 3830 3838 3849 3883 next 020606 constant label dcl 4539 in procedure "d_print_using_numeric" ref 4474 4482 4493 4527 next_char 015443 constant label dcl 3637 ref 3650 3660 3670 3695 3701 3727 3735 3747 next_mat 020065 constant label dcl 4361 in procedure "d_mat_loop" ref 4229 4254 4262 4270 4279 4296 4302 4310 4316 4322 4332 4339 4346 4352 4359 next_mat 015214 constant label dcl 3525 in procedure "mat_loop" ref 3393 3418 3426 3434 3443 3460 3466 3474 3480 3486 3496 3503 3510 3516 3523 ni_done 014134 constant label dcl 3190 ref 3163 3164 3173 num 014041 constant label dcl 3155 ref 3188 3192 3198 3223 numeric_input 014036 constant entry internal dcl 3151 ref 471 475 3374 3386 4210 4222 numeric_print 011041 constant entry internal dcl 2519 ref 362 3423 4259 numeric_read 013730 constant entry internal dcl 3107 ref 799 3464 numeric_write 013646 constant entry internal dcl 3082 ref 792 3479 obtain_line_number 007067 constant entry internal dcl 1988 ref 1969 ok 017203 constant label dcl 4106 in procedure "d_convert_string" ref 4139 ok 007676 constant label dcl 2173 in procedure "convert_string" ref 2206 open_ascii 013166 constant entry internal dcl 2946 ref 2313 2331 open_error 005234 constant label dcl 1491 ref 2456 2722 2730 2737 2740 2745 2757 2792 2808 2814 2837 2917 2921 2951 2953 2957 2973 2975 2978 2982 open_file 011654 constant entry internal dcl 2711 ref 685 open_random 013247 constant entry internal dcl 2968 ref 737 738 776 2349 2367 2386 2407 out_of_data 005220 constant label dcl 1475 ref 3438 3447 4274 4283 per_ok 004274 constant label dcl 1151 ref 1145 place 016262 constant label dcl 3893 in procedure "print_using_numeric" ref 3826 3865 place 020604 constant label dcl 4537 in procedure "d_print_using_numeric" ref 4470 4509 pointer_error 005207 constant label dcl 1463 ref 768 779 783 2988 print_error 006457 constant entry internal dcl 1912 ref 354 446 625 1220 1444 1562 2580 2657 3204 3569 print_new_line 011015 constant entry internal dcl 2496 ref 392 1005 1016 1325 1336 1927 2528 2550 2568 2638 3537 3538 3544 3555 3600 3648 4373 4374 4380 4394 print_using_error 005226 constant label dcl 1483 ref 3645 3690 3721 3731 3741 3751 3780 3781 3939 4424 4425 print_using_numeric 015644 constant entry internal dcl 3766 ref 1090 3501 print_using_string 016351 constant entry internal dcl 3926 ref 1098 3508 4344 prompt 010174 constant entry internal dcl 2290 ref 2266 3195 punt 016267 constant label dcl 3899 in procedure "print_using_numeric" ref 3783 3794 3796 punt 020611 constant label dcl 4543 in procedure "d_print_using_numeric" ref 4427 4438 4440 put_char 015376 constant entry internal dcl 3594 ref 3586 3657 3739 3836 3848 3875 3890 3893 3906 3912 3914 3959 4480 4492 4519 4534 4537 4550 4556 4558 put_string 015337 constant entry internal dcl 3579 ref 3869 3874 3879 4513 4518 4523 read_line 011511 constant entry internal dcl 2671 ref 2661 refuse 005416 constant label dcl 1559 ref 1542 1549 1550 1551 1619 1638 1646 1702 reset_ascii 010135 constant entry internal dcl 2275 ref 756 restart 006054 constant entry internal dcl 1717 ref 1754 restart_with_infinity 006073 constant entry internal dcl 1729 ref 1582 1594 return_0 001630 constant label dcl 510 ref 516 522 return_string 014022 constant entry internal dcl 3135 ref 454 462 493 536 567 578 603 815 1173 1205 3328 right_entry 002136 constant label dcl 596 ref 1436 si_bad 014371 constant label dcl 3259 ref 3275 signal_quit 016460 constant entry internal dcl 3967 ref 650 1081 1110 1871 1897 2475 2628 2694 3026 sst 002125 constant label dcl 594 ref 586 1424 str 014304 constant label dcl 3234 ref 3243 3264 3279 3289 string_assign 006307 constant entry internal dcl 1818 ref 411 3522 4358 string_input 014301 constant entry internal dcl 3230 ref 486 490 3397 3409 4233 4245 string_print 011064 constant entry internal dcl 2526 ref 370 3431 4267 string_read 013761 constant entry internal dcl 3119 ref 814 3472 4308 string_write 013675 constant entry internal dcl 3095 ref 807 3485 4321 switch 000000 constant label array(0:202) dcl 279 ref 275 tab 013544 constant entry internal dcl 3035 ref 378 399 406 3545 4384 tidy_up 006142 constant entry internal dcl 1759 ref 347 1669 typ_ok 003452 constant label dcl 905 ref 899 type_and_usage_conflict 005173 constant label dcl 1447 ref 771 2320 2353 2356 2358 2390 2394 2396 2847 2853 unique 013144 constant entry internal dcl 2930 ref 677 2916 2916 use_c8 014570 constant entry internal dcl 3323 ref 546 555 zap_file 010633 constant entry internal dcl 2441 ref 731 2322 2363 2398 zero_print_using 005223 constant label dcl 1479 ref 1075 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 23016 23320 22240 23026 Length 24036 22240 302 501 555 140 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME basic_runtime_ 3107 external procedure is an external procedure. get_mc_info internal procedure shares stack frame of external procedure basic_runtime_. restart internal procedure shares stack frame of external procedure basic_runtime_. restart_with_infinity internal procedure shares stack frame of external procedure basic_runtime_. tidy_up internal procedure shares stack frame of external procedure basic_runtime_. string_assign internal procedure shares stack frame of external procedure basic_runtime_. allocate_string internal procedure shares stack frame of external procedure basic_runtime_. deallocate_string internal procedure shares stack frame of external procedure basic_runtime_. print_error internal procedure shares stack frame of external procedure basic_runtime_. get_line_number internal procedure shares stack frame of external procedure basic_runtime_. cleanup_strings internal procedure shares stack frame of external procedure basic_runtime_. convert_number internal procedure shares stack frame of external procedure basic_runtime_. convert_string internal procedure shares stack frame of external procedure basic_runtime_. begin block on line 2184 230 begin block uses auto adjustable storage. get_string_ptr internal procedure shares stack frame of external procedure basic_runtime_. check_print internal procedure shares stack frame of external procedure basic_runtime_. check_input internal procedure shares stack frame of external procedure basic_runtime_. reset_ascii internal procedure shares stack frame of external procedure basic_runtime_. prompt internal procedure shares stack frame of external procedure basic_runtime_. check_ascii internal procedure shares stack frame of external procedure basic_runtime_. check_random_numeric internal procedure shares stack frame of external procedure basic_runtime_. check_random_string internal procedure shares stack frame of external procedure basic_runtime_. length_of_file internal procedure shares stack frame of external procedure basic_runtime_. zap_file internal procedure shares stack frame of external procedure basic_runtime_. get_ascii_buffer internal procedure shares stack frame of external procedure basic_runtime_. force_buffer internal procedure shares stack frame of external procedure basic_runtime_. print_new_line internal procedure shares stack frame of external procedure basic_runtime_. numeric_print internal procedure shares stack frame of external procedure basic_runtime_. close_file internal procedure shares stack frame of external procedure basic_runtime_. close_all_files internal procedure shares stack frame of external procedure basic_runtime_. get_input internal procedure shares stack frame of external procedure basic_runtime_. read_line internal procedure shares stack frame of external procedure basic_runtime_. open_file internal procedure shares stack frame of external procedure basic_runtime_. attach_ascii internal procedure shares stack frame of external procedure basic_runtime_. attach_numeric internal procedure shares stack frame of external procedure basic_runtime_. attach_string internal procedure shares stack frame of external procedure basic_runtime_. attach_vfile 90 internal procedure is called during a stack extension. unique 64 internal procedure is called by several nonquick procedures. open_ascii internal procedure shares stack frame of external procedure basic_runtime_. open_random internal procedure shares stack frame of external procedure basic_runtime_. close_vfile internal procedure shares stack frame of external procedure basic_runtime_. tab internal procedure shares stack frame of external procedure basic_runtime_. get_file_number internal procedure shares stack frame of external procedure basic_runtime_. numeric_write internal procedure shares stack frame of external procedure basic_runtime_. string_write internal procedure shares stack frame of external procedure basic_runtime_. numeric_read internal procedure shares stack frame of external procedure basic_runtime_. string_read internal procedure shares stack frame of external procedure basic_runtime_. return_string internal procedure shares stack frame of external procedure basic_runtime_. numeric_input internal procedure shares stack frame of external procedure basic_runtime_. string_input internal procedure shares stack frame of external procedure basic_runtime_. linput internal procedure shares stack frame of external procedure basic_runtime_. use_c8 internal procedure shares stack frame of external procedure basic_runtime_. mat_loop internal procedure shares stack frame of external procedure basic_runtime_. mat_print_format_check internal procedure shares stack frame of external procedure basic_runtime_. mat_print_format internal procedure shares stack frame of external procedure basic_runtime_. mat_print_using_check internal procedure shares stack frame of external procedure basic_runtime_. end_input internal procedure shares stack frame of external procedure basic_runtime_. put_string internal procedure shares stack frame of external procedure basic_runtime_. put_char internal procedure shares stack frame of external procedure basic_runtime_. get_next_field internal procedure shares stack frame of external procedure basic_runtime_. print_using_numeric internal procedure shares stack frame of external procedure basic_runtime_. end_surpression internal procedure shares stack frame of external procedure basic_runtime_. print_using_string internal procedure shares stack frame of external procedure basic_runtime_. signal_quit internal procedure shares stack frame of external procedure basic_runtime_. d_convert_number internal procedure shares stack frame of external procedure basic_runtime_. d_convert_string internal procedure shares stack frame of external procedure basic_runtime_. begin block on line 4117 230 begin block uses auto adjustable storage. d_numeric_write internal procedure shares stack frame of external procedure basic_runtime_. d_numeric_read internal procedure shares stack frame of external procedure basic_runtime_. d_mat_loop internal procedure shares stack frame of external procedure basic_runtime_. mat_print_format_check internal procedure shares stack frame of external procedure basic_runtime_. mat_print_format internal procedure shares stack frame of external procedure basic_runtime_. mat_print_using_check internal procedure shares stack frame of external procedure basic_runtime_. d_print_using_numeric internal procedure shares stack frame of external procedure basic_runtime_. end_surpression internal procedure shares stack frame of external procedure basic_runtime_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 ascii_size_op basic_runtime_ 000014 tty_fcb basic_runtime_ 000114 math_message basic_runtime_ 000140 null_vs get_string_ptr 000142 unique_count unique 000144 unique_value unique STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME basic_runtime_ 000100 bo_pt basic_runtime_ 000102 p1 basic_runtime_ 000104 p2 basic_runtime_ 000106 p3 basic_runtime_ 000110 p4 basic_runtime_ 000112 program_header_pt basic_runtime_ 000114 ans basic_runtime_ 000124 ch basic_runtime_ 000126 c6 basic_runtime_ 000130 c8 basic_runtime_ 000132 c12 basic_runtime_ 000135 user_name basic_runtime_ 000143 c32 basic_runtime_ 000153 c64 basic_runtime_ 000173 dir basic_runtime_ 000245 ent basic_runtime_ 000255 no_input basic_runtime_ 000256 mat_input basic_runtime_ 000257 seg_no basic_runtime_ 000260 buff_size basic_runtime_ 000261 old_buff_size basic_runtime_ 000262 code basic_runtime_ 000263 bit_length basic_runtime_ 000264 file_lng basic_runtime_ 000265 i basic_runtime_ 000266 k basic_runtime_ 000267 loc basic_runtime_ 000270 m basic_runtime_ 000271 n basic_runtime_ 000272 tab_size basic_runtime_ 000273 vfx basic_runtime_ 000274 double_vfx basic_runtime_ 000276 entry_variable basic_runtime_ 000302 string_seg basic_runtime_ 000304 field_length basic_runtime_ 000305 field_start basic_runtime_ 000306 precision basic_runtime_ 000307 scale basic_runtime_ 000310 exp_length basic_runtime_ 000311 digit_count basic_runtime_ 000312 digit_pos basic_runtime_ 000313 field_pos basic_runtime_ 000314 print_using_bits basic_runtime_ 000315 fixed_dec_1 basic_runtime_ 000316 fixed_dec_2 basic_runtime_ 000317 info basic_runtime_ 000344 position_info basic_runtime_ 000346 margin_info basic_runtime_ 000350 string_buffer basic_runtime_ 002350 status_info_branch basic_runtime_ 002354 mcp basic_runtime_ 002356 scup basic_runtime_ 002360 cond basic_runtime_ 002450 bsp deallocate_string 002460 ln print_error 002461 save_file_number print_error 002462 et print_error 002463 main print_error 002464 save_fcb_pt print_error 002466 ev print_error 002500 lower get_line_number 002501 upper get_line_number 002502 i get_line_number 002503 map_loc get_line_number 002504 mp get_line_number 002514 i cleanup_strings 002516 p cleanup_strings 002530 abs_value convert_number 002531 k convert_number 002532 j convert_number 002533 ndigits convert_number 002534 dec_value convert_number 002536 fixed_dec_value convert_number 002541 exp convert_number 002550 good_string convert_string 002726 bp read_line 002730 bl read_line 002762 k attach_string 002764 fixed_dec_value attach_string 003120 row mat_loop 003121 row_max mat_loop 003122 col mat_loop 003123 col_max mat_loop 003124 i mat_loop 003126 data_pt mat_loop 003130 vector mat_loop 003172 si put_string 003210 here_before get_next_field 003220 zero_surpression print_using_numeric 003221 exp print_using_numeric 003222 float_sign print_using_numeric 003242 n_spaces print_using_string 003243 s_pos print_using_string 003270 abs_value d_convert_number 003272 k d_convert_number 003273 j d_convert_number 003274 ndigits d_convert_number 003275 num_size d_convert_number 003276 fixed_dec_value d_convert_number 003301 exp d_convert_number 003310 good_string d_convert_string 003334 row d_mat_loop 003335 row_max d_mat_loop 003336 col d_mat_loop 003337 col_max d_mat_loop 003340 i d_mat_loop 003342 data_pt d_mat_loop 003344 vector d_mat_loop 003400 zero_surpression d_print_using_numeric 003401 exp d_print_using_numeric 003402 float_sign d_print_using_numeric begin block on line 2184 000100 copy begin block on line 2184 000100 i begin block on line 2184 000101 j begin block on line 2184 begin block on line 4117 000100 i begin block on line 4117 000100 copy begin block on line 4117 000101 j begin block on line 4117 THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 r_e_as alloc_cs cat_realloc_cs enter_begin leave_begin call_var_desc call_var call_ext_out_desc call_ext_out call_int_this_desc call_int_this call_int_other return fl2_to_fx1 fl2_to_fx2 bs_to_fx2 tra_ext tra_label_var alloc_auto_adj mod_fx1 signal shorten_stack ext_entry ext_entry_desc int_entry int_entry_desc set_cs_eis set_bs_eis index_cs_eis real_to_real_rd real_to_real_tr any_to_any_rd divide_fx3 alloc_based free_based THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. area_ assign_round_ basic_file_name_ com_err_ convert_new_oncode_ convert_old_basic_file_ cu_$stack_frame_ptr expand_path_ get_pdir_ hcs_$del_dir_tree hcs_$delentry_file hcs_$make_seg hcs_$status_ ioa_ ioa_$nnl iox_$attach_iocb iox_$close iox_$control iox_$destroy_iocb iox_$find_iocb iox_$get_chars iox_$open iox_$position iox_$put_chars iox_$read_record iox_$write_record on_data_$get_oncode pl1_date_ pl1_time_ timer_manager_$cpu_call timer_manager_$reset_cpu_call user_info_ vfile_status_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. basic_error_messages_$ error_table_$end_of_info error_table_$fulldir error_table_$long_record error_table_$no_operation error_table_$noentry error_table_$not_done fast_related_data_$basic_area_p fast_related_data_$in_fast_or_dfast iox_$user_input iox_$user_output sys_info$max_seg_size LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 41 001016 274 001026 275 001032 279 001040 286 001044 288 001104 290 001110 291 001137 294 001142 296 001156 298 001161 299 001164 300 001166 301 001171 304 001173 305 001177 307 001200 308 001210 310 001214 311 001221 312 001225 314 001227 315 001233 317 001234 319 001241 320 001243 321 001245 323 001250 325 001252 327 001253 329 001255 337 001257 338 001263 340 001264 343 001304 347 001305 350 001311 354 001312 356 001320 360 001321 362 001322 363 001323 367 001324 369 001325 370 001336 371 001337 375 001340 377 001341 378 001352 379 001361 383 001362 385 001363 386 001364 390 001365 392 001366 393 001367 397 001370 399 001371 400 001377 404 001400 406 001401 407 001411 411 001412 413 001413 414 001417 418 001420 420 001430 422 001441 424 001445 425 001450 428 001451 430 001465 432 001472 434 001475 438 001476 440 001506 442 001517 444 001522 446 001524 447 001530 450 001533 452 001534 454 001562 455 001564 459 001565 461 001566 462 001567 463 001570 467 001571 469 001572 471 001573 473 001574 474 001576 475 001602 476 001603 478 001604 482 001605 484 001606 486 001607 488 001610 489 001612 490 001616 491 001617 493 001620 494 001621 498 001622 500 001623 504 001624 507 001627 510 001630 511 001633 514 001634 516 001644 518 001647 520 001660 522 001677 524 001700 525 001705 529 001706 532 001716 533 001720 534 001721 536 001732 537 001733 541 001734 544 001742 546 001767 547 001770 551 001771 554 001777 555 002023 556 002024 560 002025 563 002043 564 002053 565 002056 566 002057 567 002065 568 002066 572 002067 575 002070 576 002072 577 002073 578 002104 579 002105 583 002106 585 002111 586 002116 590 002117 592 002122 594 002125 596 002136 599 002142 601 002154 602 002155 603 002165 604 002166 608 002167 611 002173 612 002202 616 002203 618 002216 622 002217 625 002230 626 002234 630 002237 632 002245 636 002246 639 002251 640 002252 642 002254 644 002257 646 002270 647 002272 648 002301 650 002303 652 002307 653 002313 654 002315 657 002317 658 002323 659 002325 660 002327 661 002331 662 002333 663 002335 665 002337 667 002347 672 002355 674 002364 675 002375 677 002400 679 002437 680 002442 681 002444 683 002445 685 002453 688 002454 690 002460 694 002461 696 002464 697 002465 699 002467 702 002473 703 002526 705 002533 706 002534 708 002536 709 002540 710 002542 711 002575 716 002604 717 002610 718 002612 722 002613 727 002617 728 002623 730 002627 731 002631 732 002632 733 002633 734 002637 736 002640 737 002643 738 002651 740 002653 741 002674 744 002725 745 002731 749 002732 752 002736 754 002745 755 002747 756 002751 759 002752 763 002753 766 002756 767 002762 768 002764 771 002767 773 002771 774 002774 775 003002 776 003004 779 003006 780 003010 781 003023 782 003027 783 003046 785 003050 786 003054 790 003055 792 003057 793 003060 797 003061 799 003063 800 003064 804 003065 806 003067 807 003100 808 003101 812 003102 814 003104 815 003105 816 003106 820 003107 823 003113 824 003115 825 003133 829 003134 832 003140 833 003142 837 003161 838 003164 841 003165 842 003221 844 003223 846 003243 848 003247 852 003250 855 003254 856 003263 861 003264 864 003270 866 003276 867 003300 869 003302 871 003305 872 003315 873 003323 874 003326 877 003327 878 003363 880 003371 883 003400 884 003403 891 003414 895 003415 898 003425 899 003433 900 003444 902 003446 903 003451 905 003452 907 003456 908 003457 910 003461 911 003467 913 003506 915 003514 919 003515 921 003520 922 003521 924 003523 926 003533 928 003541 930 003545 931 003547 933 003551 935 003554 936 003563 937 003577 939 003601 943 003602 945 003605 946 003606 948 003610 950 003616 951 003622 952 003625 954 003630 956 003634 958 003635 959 003640 961 003643 962 003645 964 003647 965 003657 967 003662 968 003663 970 003671 971 003705 975 003707 976 003723 978 003734 982 003735 984 003736 985 003740 986 003742 987 003746 991 003747 993 003750 994 003752 995 003754 996 003760 1000 003761 1003 003762 1005 003774 1006 003775 1007 004001 1011 004002 1014 004003 1016 004015 1017 004016 1018 004022 1022 004023 1024 004025 1025 004031 1029 004032 1031 004034 1032 004040 1036 004041 1038 004043 1039 004047 1043 004050 1045 004052 1046 004056 1050 004057 1052 004063 1056 004064 1058 004070 1062 004071 1064 004075 1065 004076 1069 004077 1072 004100 1073 004111 1075 004114 1077 004115 1078 004117 1079 004130 1081 004132 1083 004136 1084 004146 1086 004147 1090 004150 1092 004151 1096 004152 1098 004162 1099 004163 1103 004164 1106 004170 1107 004173 1108 004200 1110 004203 1112 004207 1116 004210 1118 004214 1122 004215 1124 004221 1128 004222 1130 004226 1134 004227 1136 004232 1137 004236 1141 004237 1144 004247 1145 004255 1146 004266 1148 004270 1149 004273 1151 004274 1153 004300 1154 004301 1156 004303 1157 004311 1159 004330 1164 004344 1169 004345 1171 004347 1172 004350 1173 004360 1174 004361 1178 004362 1180 004372 1182 004374 1187 004402 1188 004403 1190 004415 1192 004424 1195 004430 1199 004431 1202 004432 1203 004434 1204 004435 1205 004446 1206 004447 1210 004450 1213 004463 1217 004464 1220 004475 1221 004501 1225 004504 1227 004506 1228 004507 1232 004510 1234 004512 1235 004513 1239 004514 1241 004517 1242 004520 1244 004522 1246 004532 1248 004540 1250 004544 1251 004546 1253 004550 1255 004553 1256 004563 1257 004602 1259 004604 1263 004605 1265 004610 1266 004611 1268 004613 1270 004621 1271 004625 1272 004630 1274 004633 1276 004637 1278 004640 1279 004643 1281 004646 1282 004650 1284 004652 1285 004661 1287 004665 1288 004666 1290 004674 1291 004710 1295 004712 1296 004726 1298 004737 1302 004740 1304 004741 1305 004743 1306 004745 1307 004751 1311 004752 1313 004753 1314 004755 1315 004757 1316 004763 1320 004764 1323 004765 1325 004777 1326 005000 1327 005004 1331 005005 1334 005006 1336 005020 1337 005021 1338 005025 1342 005026 1344 005030 1345 005034 1349 005035 1351 005037 1352 005043 1356 005044 1358 005046 1359 005052 1363 005053 1365 005055 1366 005061 1370 005062 1372 005066 1376 005067 1378 005073 1382 005074 1384 005100 1385 005101 1389 005102 1391 005103 1395 005104 1397 005110 1401 005111 1403 005115 1407 005116 1409 005122 1413 005123 1415 005126 1416 005132 1418 005133 1423 005135 1424 005140 1425 005141 1433 005144 1434 005154 1435 005160 1436 005163 1441 005164 1444 005166 1445 005170 1447 005173 1449 005175 1451 005176 1453 005200 1455 005201 1457 005203 1459 005204 1461 005206 1463 005207 1465 005211 1467 005212 1469 005214 1471 005215 1473 005217 1475 005220 1477 005222 1479 005223 1481 005225 1483 005226 1485 005230 1487 005231 1489 005233 1491 005234 1493 005236 1495 005237 1497 005241 1499 005242 1501 005244 1503 005245 1505 005247 1507 005250 1509 005252 1510 005256 1512 005257 1514 005261 1516 005262 1518 005264 1520 005265 1539 005305 1540 005317 1542 005324 1543 005327 1545 005335 1547 005341 1549 005365 1550 005367 1551 005377 1553 005401 1555 005404 1556 005411 1557 005414 1559 005416 1560 005421 1562 005422 1564 005432 1567 005433 1569 005435 1570 005443 1571 005451 1574 005457 1576 005461 1577 005467 1580 005475 1582 005501 1587 005513 1589 005524 1592 005525 1594 005531 1595 005543 1598 005544 1600 005550 1602 005551 1606 005555 1611 005566 1614 005567 1616 005573 1617 005576 1619 005600 1621 005611 1622 005614 1624 005620 1627 005623 1629 005627 1631 005633 1633 005637 1636 005642 1638 005646 1641 005655 1642 005657 1646 005660 1648 005661 1653 005670 1654 005702 1656 005707 1658 005710 1660 005714 1662 005717 1666 005725 1667 005737 1669 005744 1670 005750 1672 005751 1680 005761 1682 005773 1684 005777 1685 006000 1687 006002 1689 006005 1691 006015 1699 006016 1701 006017 1702 006023 1704 006027 1706 006031 1708 006036 1709 006047 1711 006053 1717 006054 1719 006055 1720 006066 1721 006070 1723 006072 1729 006073 1734 006075 1736 006076 1740 006105 1741 006116 1742 006123 1743 006125 1744 006126 1747 006127 1748 006134 1749 006136 1754 006140 1755 006141 1759 006142 1763 006144 1765 006147 1770 006151 1771 006155 1773 006157 1776 006166 1778 006167 1785 006173 1787 006201 1788 006213 1790 006224 1791 006231 1792 006233 1794 006241 1795 006246 1796 006260 1798 006273 1800 006275 1803 006277 1804 006306 1818 006307 1822 006310 1826 006316 1828 006324 1833 006327 1834 006330 1837 006331 1842 006335 1844 006340 1846 006341 1847 006344 1852 006345 1853 006347 1855 006350 1857 006363 1859 006366 1865 006367 1867 006370 1868 006373 1869 006404 1871 006407 1873 006413 1875 006415 1882 006416 1886 006420 1888 006424 1889 006430 1891 006432 1893 006434 1894 006436 1895 006444 1897 006447 1900 006453 1903 006456 1912 006457 1919 006461 1921 006463 1922 006470 1924 006472 1925 006474 1927 006476 1931 006504 1932 006507 1934 006511 1936 006517 1937 006524 1939 006535 1940 006545 1941 006552 1943 006556 1945 006561 1946 006607 1949 006611 1950 006620 1951 006647 1953 006677 1955 006733 1957 006763 1959 006765 1959 006776 1961 007003 1964 007033 1965 007051 1967 007052 1969 007054 1970 007056 1981 007057 1986 007061 1988 007066 1990 007071 1992 007077 1993 007101 1995 007105 1997 007111 1998 007115 2000 007120 2002 007124 2004 007132 2006 007133 2006 007141 2006 007142 2007 007143 2009 007151 2011 007163 2013 007166 2015 007167 2027 007173 2032 007174 2034 007203 2035 007213 2037 007215 2038 007220 2042 007222 2043 007227 2051 007230 2067 007231 2069 007234 2070 007240 2073 007241 2075 007244 2075 007253 2077 007257 2083 007266 2085 007276 2086 007310 2087 007326 2093 007327 2095 007337 2096 007351 2098 007354 2100 007362 2103 007365 2108 007370 2110 007402 2112 007416 2117 007417 2118 007426 2119 007435 2120 007452 2122 007464 2124 007470 2126 007475 2127 007500 2128 007512 2130 007513 2131 007516 2134 007530 2137 007531 2139 007533 2141 007534 2143 007540 2144 007552 2145 007572 2146 007604 2148 007605 2149 007617 2150 007626 2153 007644 2163 007645 2167 007647 2168 007660 2170 007661 2171 007665 2173 007676 2175 007700 2176 007702 2180 007706 2182 007722 2184 007726 2186 007731 2189 007741 2190 007745 2192 007746 2193 007755 2198 007773 2199 007774 2201 010001 2203 010003 2204 010015 2206 010016 2214 010017 2219 010021 2221 010030 2224 010042 2232 010045 2234 010046 2236 010050 2239 010055 2241 010065 2242 010070 2245 010072 2252 010073 2254 010074 2256 010076 2258 010103 2260 010113 2261 010116 2264 010120 2266 010124 2268 010131 2271 010134 2275 010135 2277 010136 2279 010160 2283 010165 2285 010171 2286 010173 2290 010174 2292 010175 2293 010203 2295 010224 2302 010225 2306 010227 2308 010235 2310 010241 2311 010245 2312 010250 2313 010253 2314 010261 2320 010262 2322 010274 2325 010302 2326 010306 2327 010310 2330 010311 2331 010312 2333 010321 2334 010324 2340 010325 2344 010327 2346 010335 2347 010341 2348 010344 2349 010347 2350 010355 2353 010356 2356 010361 2358 010364 2363 010376 2364 010405 2366 010410 2367 010411 2369 010420 2370 010424 2371 010425 2377 010426 2381 010430 2383 010436 2384 010442 2385 010445 2386 010450 2387 010456 2390 010457 2394 010462 2396 010465 2398 010477 2399 010506 2401 010511 2402 010517 2403 010521 2406 010522 2407 010523 2409 010532 2415 010533 2419 010535 2421 010543 2422 010545 2423 010577 2425 010604 2426 010606 2431 010627 2441 010633 2443 010634 2444 010635 2448 010637 2450 010670 2451 010672 2452 010676 2453 010715 2456 010723 2458 010725 2460 010726 2464 010727 2466 010730 2467 010734 2469 010740 2471 010743 2472 010745 2473 010760 2475 010762 2477 010766 2483 010767 2485 010770 2486 011007 2489 011011 2490 011014 2496 011015 2498 011016 2500 011024 2501 011027 2503 011034 2505 011035 2506 011040 2519 011041 2521 011042 2522 011051 2523 011052 2524 011061 2526 011063 2528 011065 2532 011076 2533 011100 2535 011103 2536 011110 2538 011117 2540 011122 2541 011132 2542 011134 2543 011135 2546 011136 2547 011145 2548 011146 2550 011147 2551 011154 2552 011155 2554 011160 2562 011161 2566 011163 2568 011171 2572 011176 2574 011177 2575 011200 2580 011224 2582 011232 2586 011237 2587 011266 2589 011307 2594 011313 2596 011333 2602 011356 2603 011362 2611 011363 2615 011365 2616 011373 2618 011377 2621 011407 2624 011417 2625 011422 2626 011424 2628 011427 2630 011433 2632 011435 2634 011441 2636 011445 2638 011451 2642 011457 2646 011463 2653 011464 2657 011466 2661 011503 2663 011504 2664 011510 2671 011511 2676 011512 2678 011533 2679 011536 2681 011542 2682 011547 2684 011552 2685 011553 2687 011555 2688 011557 2689 011570 2690 011577 2691 011604 2692 011610 2694 011612 2696 011616 2698 011643 2699 011647 2701 011650 2702 011653 2711 011654 2715 011655 2717 011666 2722 011674 2724 011677 2726 011701 2727 011712 2729 011715 2730 011745 2735 011750 2737 011757 2739 011762 2740 011771 2741 011774 2742 011775 2744 011776 2745 012033 2747 012036 2749 012042 2753 012045 2755 012050 2757 012054 2759 012061 2760 012072 2762 012075 2763 012105 2764 012114 2766 012122 2767 012124 2772 012126 2773 012127 2778 012130 2780 012132 2782 012161 2784 012163 2786 012225 2792 012227 2793 012232 2795 012236 2798 012237 2799 012246 2801 012252 2802 012254 2803 012255 2808 012256 2812 012261 2813 012263 2814 012312 2819 012314 2823 012322 2824 012343 2826 012345 2827 012367 2828 012416 2830 012417 2832 012422 2833 012423 2836 012424 2837 012445 2842 012446 2843 012453 2844 012457 2845 012460 2847 012461 2850 012464 2853 012471 2854 012476 2855 012501 2862 012502 2867 012503 2869 012504 2871 012566 2873 012570 2875 012574 2880 012575 2882 012576 2884 012667 2886 012674 2891 012675 2897 012676 2898 012703 2900 012715 2902 013010 2904 013015 2909 013016 2913 013032 2915 013037 2916 013043 2917 013101 2920 013107 2921 013134 2923 013142 2930 013143 2937 013151 2938 013154 2940 013160 2946 013166 2950 013170 2951 013175 2952 013200 2953 013211 2956 013213 2957 013235 2959 013237 2960 013243 2961 013246 2968 013247 2972 013251 2973 013256 2974 013261 2975 013315 2976 013317 2977 013321 2978 013333 2981 013335 2982 013357 2984 013361 2986 013365 2987 013370 2988 013407 2991 013411 2993 013416 3000 013417 3002 013420 3003 013425 3005 013437 3006 013447 3007 013452 3008 013456 3011 013460 3013 013472 3014 013502 3015 013505 3019 013511 3020 013516 3021 013520 3022 013525 3023 013531 3026 013533 3028 013537 3029 013543 3035 013544 3039 013546 3040 013555 3042 013561 3044 013563 3045 013566 3046 013576 3047 013603 3049 013604 3051 013610 3052 013612 3054 013613 3055 013620 3063 013621 3067 013623 3069 013627 3070 013630 3072 013632 3074 013635 3075 013645 3082 013646 3084 013647 3086 013672 3088 013674 3095 013675 3097 013676 3099 013725 3101 013727 3107 013730 3109 013731 3111 013756 3113 013760 3119 013761 3121 013762 3122 014006 3124 014010 3125 014012 3126 014013 3128 014021 3135 014022 3137 014023 3139 014030 3140 014033 3142 014035 3151 014036 3153 014037 3155 014041 3157 014050 3158 014051 3159 014057 3161 014060 3163 014066 3164 014072 3166 014074 3172 014103 3173 014105 3176 014106 3178 014116 3179 014117 3181 014123 3185 014124 3187 014127 3188 014133 3190 014134 3192 014136 3193 014142 3195 014145 3197 014151 3198 014154 3201 014155 3204 014167 3205 014173 3208 014176 3210 014201 3211 014216 3213 014226 3214 014230 3215 014231 3217 014232 3220 014237 3222 014274 3223 014300 3230 014301 3232 014302 3234 014304 3236 014313 3238 014331 3240 014332 3242 014335 3243 014341 3246 014342 3248 014343 3253 014352 3255 014353 3257 014370 3259 014371 3261 014376 3263 014442 3264 014446 3267 014447 3268 014451 3273 014452 3275 014470 3277 014471 3279 014474 3282 014500 3284 014501 3288 014516 3289 014521 3294 014522 3295 014523 3297 014535 3299 014537 3300 014540 3307 014541 3309 014542 3310 014550 3312 014552 3314 014553 3316 014565 3317 014567 3323 014570 3325 014571 3326 014573 3327 014574 3328 014605 3329 014606 3335 014607 3343 014611 3344 014616 3346 014617 3347 014621 3349 014622 3351 014623 3352 014625 3353 014627 3355 014630 3358 014640 3360 014641 3361 014642 3362 014644 3365 014647 3367 014651 3368 014661 3370 014671 3374 014674 3376 014675 3378 014677 3380 014704 3381 014710 3384 014711 3385 014714 3386 014720 3387 014721 3390 014722 3392 014724 3393 014727 3397 014730 3399 014731 3401 014733 3403 014740 3404 014744 3407 014745 3408 014750 3409 014754 3410 014755 3413 014756 3415 014763 3417 014765 3418 014770 3422 014771 3423 014775 3425 014776 3426 014777 3430 015000 3431 015005 3433 015006 3434 015007 3438 015010 3440 015021 3442 015026 3443 015032 3447 015033 3449 015044 3451 015051 3452 015056 3454 015060 3455 015061 3457 015073 3459 015076 3460 015104 3464 015105 3465 015106 3466 015112 3470 015113 3472 015120 3473 015121 3474 015124 3478 015125 3479 015131 3480 015132 3484 015133 3485 015140 3486 015141 3490 015142 3492 015147 3493 015150 3495 015151 3496 015154 3500 015155 3501 015161 3502 015162 3503 015163 3507 015164 3508 015171 3509 015172 3510 015173 3514 015174 3515 015201 3516 015203 3520 015204 3521 015210 3522 015212 3523 015213 3525 015214 3526 015215 3528 015217 3529 015222 3561 015224 3531 015225 3533 015226 3534 015233 3537 015242 3538 015244 3540 015245 3542 015246 3544 015247 3545 015254 3548 015266 3550 015267 3552 015270 3555 015275 3556 015276 3559 015300 3567 015301 3569 015302 3573 015332 3574 015336 3579 015337 3585 015350 3586 015363 3587 015373 3589 015375 3594 015376 3598 015400 3600 015406 3604 015415 3606 015420 3607 015421 3609 015430 3621 015431 3627 015433 3629 015434 3635 015441 3637 015443 3639 015445 3641 015450 3643 015452 3645 015457 3647 015461 3648 015463 3649 015464 3650 015466 3653 015467 3657 015501 3658 015513 3660 015514 3664 015515 3666 015517 3668 015521 3669 015524 3670 015525 3674 015526 3676 015530 3677 015532 3681 015533 3683 015535 3685 015537 3686 015541 3690 015542 3692 015544 3694 015555 3695 015557 3698 015562 3700 015563 3701 015564 3705 015565 3707 015567 3708 015571 3712 015572 3714 015574 3715 015576 3719 015577 3721 015601 3723 015603 3724 015604 3726 015605 3727 015611 3731 015612 3733 015614 3734 015615 3735 015616 3739 015617 3741 015624 3743 015627 3744 015631 3747 015632 3749 015633 3751 015635 3752 015637 3755 015641 3756 015643 3766 015644 3778 015645 3780 015651 3781 015654 3783 015657 3785 015662 3790 015664 3794 015673 3796 015675 3798 015701 3801 015752 3802 015754 3808 015755 3810 015761 3812 016027 3813 016034 3816 016047 3818 016054 3819 016055 3821 016056 3822 016067 3823 016075 3825 016106 3826 016112 3830 016113 3834 016114 3836 016117 3838 016124 3842 016125 3844 016127 3846 016131 3848 016134 3849 016136 3854 016137 3855 016140 3857 016145 3860 016164 3861 016167 3863 016170 3865 016175 3869 016176 3871 016203 3873 016211 3874 016214 3875 016224 3876 016230 3878 016231 3879 016234 3882 016244 3883 016246 3887 016247 3889 016251 3890 016252 3893 016262 3895 016264 3897 016266 3899 016267 3901 016271 3902 016303 3904 016311 3906 016324 3907 016326 3919 016330 3910 016331 3912 016332 3914 016341 3916 016347 3917 016350 3926 016351 3930 016352 3932 016356 3934 016361 3936 016365 3937 016370 3938 016372 3939 016373 3943 016400 3944 016411 3946 016417 3949 016432 3950 016434 3951 016436 3953 016437 3955 016440 3956 016446 3959 016453 3960 016455 3962 016457 3967 016460 3971 016461 3972 016464 3974 016467 3982 016470 3997 016471 3999 016474 4000 016500 4003 016501 4005 016504 4005 016513 4007 016517 4013 016527 4015 016537 4016 016551 4017 016567 4023 016570 4024 016574 4026 016641 4027 016654 4029 016660 4031 016674 4034 016677 4040 016702 4042 016714 4043 016723 4048 016724 4049 016733 4050 016742 4051 016757 4053 016771 4055 016775 4057 017002 4058 017005 4059 017017 4061 017020 4062 017023 4065 017035 4068 017036 4070 017040 4072 017041 4075 017045 4076 017057 4077 017077 4078 017111 4081 017112 4082 017124 4083 017133 4086 017151 4096 017152 4100 017154 4101 017165 4103 017166 4104 017172 4106 017203 4108 017205 4109 017207 4113 017213 4115 017227 4117 017233 4119 017236 4122 017246 4123 017252 4125 017253 4126 017263 4131 017301 4132 017302 4134 017307 4136 017311 4137 017323 4139 017324 4147 017325 4149 017326 4151 017351 4153 017353 4159 017354 4161 017355 4163 017402 4165 017404 4171 017405 4179 017407 4180 017414 4182 017415 4183 017417 4185 017420 4187 017421 4188 017423 4189 017425 4191 017426 4194 017436 4196 017437 4197 017440 4198 017442 4201 017445 4203 017447 4204 017457 4206 017467 4210 017472 4212 017473 4214 017475 4216 017502 4217 017506 4220 017507 4221 017512 4222 017516 4223 017517 4226 017520 4228 017522 4229 017527 4233 017530 4235 017531 4237 017533 4239 017540 4240 017544 4243 017545 4244 017550 4245 017554 4246 017555 4249 017556 4251 017564 4253 017566 4254 017576 4258 017577 4259 017604 4261 017605 4262 017606 4266 017607 4267 017615 4269 017616 4270 017617 4274 017620 4276 017631 4278 017640 4279 017644 4283 017645 4285 017656 4287 017664 4288 017671 4290 017673 4291 017674 4293 017706 4295 017716 4296 017724 4300 017725 4301 017726 4302 017734 4306 017735 4308 017743 4309 017744 4310 017754 4314 017755 4315 017762 4316 017763 4320 017764 4321 017772 4322 017773 4326 017774 4328 020002 4329 020003 4331 020004 4332 020014 4336 020015 4337 020022 4338 020023 4339 020024 4343 020025 4344 020033 4345 020034 4346 020035 4350 020036 4351 020044 4352 020053 4356 020054 4357 020061 4358 020063 4359 020064 4361 020065 4362 020066 4364 020070 4365 020073 4400 020075 4367 020076 4369 020077 4370 020104 4373 020113 4374 020115 4376 020116 4378 020117 4380 020120 4381 020125 4383 020127 4384 020137 4387 020146 4389 020147 4391 020150 4394 020155 4395 020156 4398 020160 4410 020161 4422 020162 4424 020166 4425 020171 4427 020174 4429 020177 4434 020201 4438 020210 4440 020212 4442 020216 4445 020267 4446 020271 4452 020272 4454 020276 4456 020344 4457 020351 4460 020364 4462 020371 4463 020372 4465 020373 4466 020405 4467 020413 4469 020424 4470 020430 4474 020431 4478 020432 4480 020435 4482 020442 4486 020443 4488 020445 4490 020447 4492 020452 4493 020454 4498 020455 4499 020456 4501 020463 4504 020502 4505 020505 4507 020506 4509 020517 4513 020520 4515 020525 4517 020533 4518 020536 4519 020546 4520 020552 4522 020553 4523 020556 4526 020566 4527 020570 4531 020571 4533 020573 4534 020574 4537 020604 4539 020606 4541 020610 4543 020611 4545 020613 4546 020625 4548 020633 4550 020646 4551 020650 4563 020652 4554 020653 4556 020654 4558 020663 4560 020671 4561 020672 ----------------------------------------------------------- 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