COMPILATION LISTING OF SEGMENT apl_file_system_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 11/29/83 1605.5 mst Tue Options: optimize map 1 /* ****************************************************** 2* * * 3* * * 4* * Copyright (c) 1972 by Massachusetts Institute of * 5* * Technology and Honeywell Information Systems, Inc. * 6* * * 7* * * 8* ****************************************************** */ 9 10 apl_file_system_: 11 procedure (operators_argument); 12 13 /* Procedure to manage APL component files. 14* Written 2/79 by William M. York. 15* Modified 790212 by WMY to add entrypoints for untying and unlocking all tied files, 16* and to check for code = 0 before calling file_error. 17* Modified 790213 by WMY to implement qFLIB. 18* Modified 790225 by WMY to make qFLIB free up allocated storage. 19* Modified 790225 by WMY to fix bug 397 (value_stack_ptr gets assigned from 20* an uninitialized variable). 21* Modified 800814 by WMY fix bug 470 (attemtping to open or create a file when 22* quota is exhausted leaves the switch attached). 23* Modified 820120 by WMY to fix a problem for Renault in which qFHOLD 24* returns a not_a_valid_iocb or no_iocb error code. 25**/ 26 27 /* Automatic storage */ 28 29 dcl share bit (1) aligned; /* open file for sharing */ 30 dcl create_if_not_found bit(1) aligned; /* create new files? */ 31 dcl untie_error bit(1) aligned; 32 dcl flim_not_fsize bit(1) aligned; /* for common code */ 33 dcl fsetacl_not_faddacl bit(1) aligned; /* for common code */ 34 dcl switched_one bit(1) aligned; /* for sorting */ 35 36 dcl (left_vb, right_vb) ptr; /* ptrs to arg beads */ 37 dcl (left, right) ptr; /* ptrs to arg values */ 38 dcl result_vb ptr unaligned; /* to APL bead */ 39 dcl bead_size fixed bin(21); /* size of APL value */ 40 dcl size_read fixed bin(21); /* size of record read */ 41 dcl data_ptr ptr; /* ptr to data elements */ 42 43 dcl tie_num fixed; /* current tie num */ 44 dcl iocb_ptr ptr; /* current file ptr */ 45 dcl tied_array_idx fixed bin; /* where to put info */ 46 dcl data_elements fixed bin; /* number of values in right arg */ 47 dcl component_number fixed bin; 48 dcl component_key picture "99999999999"; /* for conversion to string */ 49 dcl start_component fixed bin; /* first component done */ 50 dcl end_component fixed bin; /* last one done */ 51 dcl drop_number fixed bin; /* number of components to drop */ 52 53 dcl file_pathname char(168); /* file name stuff */ 54 dcl (file_dname, new_dname) char(168); 55 dcl (file_ename, new_ename) char(32); 56 57 dcl user_name char(22); /* for keeping record of */ 58 dcl user_project char(9); /* who wrote what */ 59 60 dcl (count, idx) fixed bin; /* random counters */ 61 dcl increment fixed bin; /* do loop step */ 62 dcl temp_string char(20) varying; /* scratch string */ 63 dcl info_ptr ptr; /* for vfile_status_ */ 64 65 dcl lock_info bit(2) aligned; /* for set_file_lock */ 66 dcl lock bit(2) init ("10"b); /* lock file, inhibit writes only */ 67 dcl unlock bit(2) init ("00"b); /* unlock file */ 68 dcl current_file_locked bit(1) init ("0"b); /* indicator of locking */ 69 70 dcl system_area area (261120) based (area_ptr); /* for acl structure */ 71 dcl area_ptr pointer; /* for acl hacking */ 72 73 dcl acl_ptr pointer; 74 dcl acl_count fixed bin; 75 dcl mode_string char(4); /* ACL modes; "rew", etc */ 76 dcl fcb_ptr pointer; /* for msf_manager_ */ 77 78 dcl (code, code2) fixed bin(35); /* status code */ 79 80 dcl 1 index_info based (info_ptr) like indx_info; 81 82 dcl 1 segment_acl (acl_count) aligned based (acl_ptr), 83 2 access_name char(32), 84 2 modes bit(36), 85 2 zero_pad bit(36), 86 2 status_code fixed bin(35); 87 88 dcl 1 delete_acl (acl_count) aligned based (acl_ptr), 89 2 access_name char(32), 90 2 status_code fixed bin(35); 91 92 93 dcl uid bit(36); /* segment unique id */ 94 95 /* These arrays must be the same dimension as tied_files */ 96 97 dcl file_uids (100) bit(36); /* for locking order */ 98 dcl array_idxs (100) fixed bin; /* for keeping array idxs */ 99 100 /* Header information at the beginning of each file. */ 101 102 dcl 1 file_header, /* info at head of file */ 103 2 version fixed bin, 104 2 first_component fixed bin, 105 2 last_component fixed bin; 106 107 dcl file_header_version fixed bin init (1); 108 dcl file_header_size fixed bin (21); 109 dcl file_header_key char(256) varying init ("APL_file_header"); 110 111 /* Header information for each component. */ 112 113 dcl 1 component_header, 114 2 size fixed bin, 115 2 user_id char(32), 116 2 user_number fixed bin, 117 2 time fixed bin(71); 118 119 dcl component_header_size fixed bin(21); 120 121 /* Internal static */ 122 123 dcl 1 apl_file_system_static static, 124 2 number_of_files_tied fixed bin init (0), 125 2 first_file_open bit(1) aligned init ("1"b), 126 2 group_id char(32), 127 128 2 tied_files (100), 129 3 iocb_ptr pointer init ((100) null()), 130 3 tie_number fixed bin, 131 3 file_name char(168), 132 3 shared bit(1), 133 3 locked bit(1), 134 3 read_only bit(1), 135 3 first_component fixed, 136 3 last_component fixed; 137 138 /* External static */ 139 140 dcl apl_static_$apl_output ptr static external; 141 142 /* Entries */ 143 144 dcl vfile_status_ entry (char(*), char(*), ptr, fixed bin(35)); 145 dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); 146 dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); 147 dcl hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); 148 dcl hcs_$chname_file entry (char(*), char(*), char(*), char(*), fixed bin(35)); 149 dcl msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)); 150 dcl msf_manager_$acl_list entry (ptr, ptr, ptr, ptr, fixed bin, fixed bin(35)); 151 dcl msf_manager_$acl_replace entry (ptr, ptr, fixed bin, bit(1), fixed bin(35)); 152 dcl msf_manager_$acl_add entry (ptr, ptr, fixed bin, fixed bin(35)); 153 dcl msf_manager_$acl_delete entry (ptr, ptr, fixed bin, fixed bin(35)); 154 dcl msf_manager_$close entry (ptr); 155 dcl apl_translate_pathname_$file_system_pathname entry (char(*), char(*), char(*), ptr, fixed bin(35)); 156 dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); 157 dcl delete_$path entry (char(*), char(*), bit(6), char(*), fixed bin(35)); 158 dcl unique_chars_ entry (bit(*)) returns (char(15)); 159 dcl user_info_$whoami entry (char(*), char(*), char(*)); 160 dcl cv_userid_ entry (char(*)) returns (char(32)); 161 dcl get_system_free_area_ entry returns (ptr); 162 dcl ioa_$ioa_switch entry options (variable); 163 164 /* I/O manipulation routines */ 165 166 dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)); 167 dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)); 168 dcl iox_$close entry (ptr, fixed bin(35)); 169 dcl iox_$detach_iocb entry (ptr, fixed bin(35)); 170 dcl iox_$seek_key entry (ptr, char(256) varying, fixed bin(21), fixed bin(35)); 171 dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin (35)); 172 dcl iox_$write_record entry (ptr, ptr, fixed bin(21), fixed bin(35)); 173 dcl iox_$rewrite_record entry (ptr, ptr, fixed bin(21), fixed bin(35)); 174 dcl iox_$delete_record entry (ptr, fixed bin(35)); 175 dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); 176 177 /* Builtins */ 178 179 dcl (null, addr, addrel, rtrim, substr, index, length, size, 180 hbound, lbound, dimension, clock, abs, binary, codeptr, 181 currentsize, divide, fixed, floor, ltrim, rel, string, 182 sum, verify) 183 builtin; 184 185 /* Error codes */ 186 187 dcl (error_table_$noentry, 188 error_table_$nomatch, 189 error_table_$file_busy, 190 error_table_$lock_not_locked, 191 error_table_$locked_by_this_process, 192 error_table_$moderr, 193 error_table_$no_info, 194 error_table_$no_operation, 195 error_table_$no_record) 196 fixed bin(35) external; 197 198 dcl (apl_error_table_$domain, 199 apl_error_table_$not_within_int_fuzz, 200 apl_error_table_$rank, 201 apl_error_table_$length, 202 apl_error_table_$file_already_tied, 203 apl_error_table_$file_already_exists, 204 apl_error_table_$no_write_permission, 205 apl_error_table_$no_access_to_file, 206 apl_error_table_$tie_num_in_use, 207 apl_error_table_$no_such_file, 208 apl_error_table_$bad_tie_num, 209 apl_error_table_$bad_file_name, 210 apl_error_table_$bad_fname_match, 211 apl_error_table_$bad_component_num, 212 apl_error_table_$not_enough_components, 213 apl_error_table_$bad_apl_file, 214 apl_error_table_$old_file_header, 215 apl_error_table_$bad_access_matrix, 216 apl_error_table_$bad_access_modes, 217 apl_error_table_$too_many_files) 218 fixed bin(35) external; 219 220 /* Include files */ 221 1 1 dcl 1 uns_info based (addr (info)), /* info structure for unstructured files */ 1 2 2 info_version fixed, /* (Input) must =1--only one version 1 3* currently supported */ 1 4 2 type fixed, /* =1 */ 1 5 2 end_pos fixed (34), /* length (bytes) not including header */ 1 6 2 flags aligned, 1 7 3 pad1 bit (2) unal, /* used for lock_status in other files */ 1 8 3 header_present bit (1) unal, /* on if file code is set */ 1 9 3 pad2 bit (33) unal, 1 10 2 header_id fixed (35); /* meaning is user defined */ 1 11 dcl 1 seq_info based (addr (info)), /* info structure for sequential files */ 1 12 2 info_version fixed, 1 13 2 type fixed, /* =2 */ 1 14 2 end_pos fixed (34), /* record count */ 1 15 2 flags aligned, 1 16 3 lock_status bit (2) unal, /* 0,1,2, or 3 to indicate not locked, 1 17* locked by (other,this,dead) process */ 1 18 3 pad bit (34) unal, 1 19 2 version fixed, /* end_pos valid only in latest version */ 1 20 2 action fixed; /* indicates if adjustment or rollback is needed */ 1 21 dcl 1 blk_info based (addr (info)), /* info structure for blocked files */ 1 22 2 info_version fixed, 1 23 2 type fixed, /* =3 */ 1 24 2 end_pos fixed (34), /* record count */ 1 25 2 flags aligned, 1 26 3 lock_status bit (2) unal, /* same as seq_info.= */ 1 27 3 pad bit (34) unal, 1 28 2 version fixed, /* only one currently supported */ 1 29 2 action fixed, /* non-zero if truncation in progress, else =0 */ 1 30 2 max_rec_len fixed (21), /* bytes--determines characteristiWc block size */ 1 31 2 pad fixed, /* not used at this time */ 1 32 2 time_last_modified fixed (71); /* time stamp for synchronization */ 1 33 dcl 1 indx_info based (addr (info)), /* info structure for indexed files */ 1 34 2 info_version fixed, 1 35 2 type fixed, /* =4 */ 1 36 2 records fixed (34), /* record count */ 1 37 2 flags aligned, 1 38 3 lock_status bit (2) unal, /* same as seq_info.= */ 1 39 3 pad bit (34) unal, 1 40 2 version_info aligned, 1 41 3 file_version fixed (17) unal, /* headers differ */ 1 42 3 program_version fixed (17) unal, /* may indicate bugs */ 1 43 2 action fixed, /* non-zero code indicates update in progress */ 1 44 2 non_null_recs fixed (34), /* count of allocated recs */ 1 45 2 record_bytes fixed (34), /* total record length */ 1 46 2 free_blocks fixed, /* available record blocks */ 1 47 2 index_height fixed, /* height of index tree (0 if empty) */ 1 48 2 nodes fixed, /* nodes being used in the index */ 1 49 2 key_bytes fixed (34), /* total length of keys */ 1 50 2 change_count fixed (35), /* bumped on each file modification */ 1 51 2 num_keys fixed (34), /* number of index entries */ 1 52 2 dup_keys fixed (34), /* 0 if all keys are distinct, else 1 for each dup */ 1 53 2 dup_key_bytes fixed (34), /* total bytes of duplicate keys */ 1 54 2 word (1) fixed; /* reserved for future use */ 1 55 dcl 1 vbl_info based (addr (info)), /* info structure for variable files */ 1 56 2 info_version fixed, 1 57 2 type fixed, /* =5 */ 1 58 2 end_pos fixed (34), /* logical end of file--not necessarily allocation count */ 1 59 2 flags aligned, 1 60 3 lock_status bit (2) unal, /* same as seq_info.= */ 1 61 3 pad bit (34) unal, 1 62 2 version fixed, /* only one currently supported */ 1 63 2 action fixed, /* same as in indexed files */ 1 64 2 first_nz fixed (34), /* position (numeric key) for first allocated record */ 1 65 2 last_nz fixed (34), /* last allocated record position */ 1 66 2 change_count fixed (35); /* used for synchronization */ 1 67 dcl vfs_version_1 static internal fixed init (1); 1 68 /* should be used in 1 69* assignments to info_version */ 222 2 1 declare /* Structure returned by hcs_$status_long */ 2 2 2 3 1 branch_status aligned, /* automatic: hcs_$status uses a pointer */ 2 4 2 5 2 type bit(2) unaligned, /* type of entry: link, segment, dir */ 2 6 2 number_names bit(16) unaligned, /* unused by directory_status_ */ 2 7 2 names_rel_pointer bit(18) unaligned, /* unused by directory_status_ */ 2 8 2 date_time_modified bit(36) unaligned, /* date time modified */ 2 9 2 date_time_used bit(36) unaligned, /* date time entry used */ 2 10 2 mode bit(5) unaligned, /* effective access of caller */ 2 11 2 raw_mode bit(5) unaligned, 2 12 2 pad1 bit(8) unaligned, 2 13 2 records bit(18) unaligned, /* number of records in use */ 2 14 2 date_time_dumped bit(36) unaligned, /* date time last dumped */ 2 15 2 date_time_entry_modified bit(36) unaligned, /* date time entry modified */ 2 16 2 lvid bit(36) unaligned, /* logical volume id */ 2 17 2 current_length bit(12) unaligned, /* number of blocks currently allocated */ 2 18 2 bit_count bit(24) unaligned, /* bit count of entry */ 2 19 2 pad3 bit(8) unaligned, 2 20 2 copy_switch bit(1) unaligned, /* the copy switch */ 2 21 2 tpd bit(1) unaligned, /* transparent to paging device */ 2 22 2 mdir bit(1) unaligned, /* master directory switch */ 2 23 2 damaged_switch bit (1) unaligned, /* true if contents damaged */ 2 24 2 synchronized_switch bit (1) unaligned, /* true if a DM synchronized file */ 2 25 2 pad4 bit(5) unaligned, 2 26 2 ring_brackets (0:2) bit(6) unaligned, /* branch ring brackets */ 2 27 2 unique_id bit(36) unaligned, /* entry unique id */ 2 28 2 29 2 30 /* The types of each class of branch */ 2 31 segment_type bit(2) aligned internal static initial ("01"b), 2 32 directory_type bit(2) aligned internal static initial ("10"b), 2 33 msf_type bit(2) aligned internal static initial ("10"b), /* will eventually be different */ 2 34 link_type bit(2) aligned internal static initial ("00"b); 2 35 2 36 223 3 1 /* BEGIN INCLUDE FILE . . . star_structures.incl.pl1 */ 3 2 3 3 /* This include file contains structures for the hcs_$star_, 3 4* hcs_$star_list_ and hcs_$star_dir_list_ entry points. 3 5* 3 6* Written 23 October 1978 by Monte Davidoff. 3 7* Modified January 1979 by Michael R. Jordan to use unsigned and different pointers for different structures. 3 8* Modified June 1981 by C. Hornig to count link pathnames more efficiently. 3 9**/ 3 10 3 11 /* automatic */ 3 12 3 13 declare star_branch_count fixed binary; /* hcs_$star_list_, hcs_$star_dir_list_: matching branch count */ 3 14 declare star_entry_count fixed binary; /* hcs_$star_: number of matching entries */ 3 15 declare star_entry_ptr pointer; /* hcs_$star_: pointer to array of entry information */ 3 16 declare star_list_branch_ptr pointer; /* hcs_$star_list_, hcs_$star_dir_list_: ptr to array of info */ 3 17 declare star_link_count fixed binary; /* hcs_$star_list_, hcs_$star_dir_list_: matching link count */ 3 18 declare star_linkx fixed binary; /* hcs_$star_list_, hcs_$star_dir_list_: index into star_links */ 3 19 declare star_names_ptr pointer; /* hcs_$star_: pointer to array of entry names */ 3 20 declare star_list_names_ptr pointer; /* hcs_$star_list_, hcs_$star_dir_list_: ptr to entry names */ 3 21 declare star_select_sw fixed binary (3); /* hcs_$star_list_, hcs_$star_dir_list_: what info to return */ 3 22 3 23 /* based */ 3 24 3 25 /* hcs_$star_ entry structure */ 3 26 3 27 declare 1 star_entries (star_entry_count) aligned based (star_entry_ptr), 3 28 2 type fixed binary (2) unsigned unaligned, 3 29 /* storage system type */ 3 30 2 nnames fixed binary (16) unsigned unaligned, 3 31 /* number of names of entry that match star_name */ 3 32 2 nindex fixed binary (18) unsigned unaligned; 3 33 /* index of first name in star_names */ 3 34 3 35 /* hcs_$star_ name structure */ 3 36 3 37 declare star_names (sum (star_entries (*).nnames)) char (32) based (star_names_ptr); 3 38 3 39 /* hcs_$star_list_ branch structure */ 3 40 3 41 declare 1 star_list_branch (star_branch_count + star_link_count) aligned based (star_list_branch_ptr), 3 42 2 type fixed binary (2) unsigned unaligned, 3 43 /* storage system type */ 3 44 2 nnames fixed binary (16) unsigned unaligned, 3 45 /* number of names of entry that match star_name */ 3 46 2 nindex fixed binary (18) unsigned unaligned, 3 47 /* index of first name in star_list_names */ 3 48 2 dtcm bit (36) unaligned, /* date-time contents of branch were last modified */ 3 49 2 dtu bit (36) unaligned, /* date-time branch was last used */ 3 50 2 mode bit (5) unaligned, /* user's access mode to the branch */ 3 51 2 raw_mode bit (5) unaligned, /* user's ACL access mode */ 3 52 2 master_dir bit (1) unaligned, /* is branch a master directory */ 3 53 2 pad bit (7) unaligned, 3 54 2 records fixed binary (18) unsigned unaligned; 3 55 /* records used by branch */ 3 56 3 57 /* hcs_$star_dir_list_ branch structure */ 3 58 3 59 declare 1 star_dir_list_branch (star_branch_count + star_link_count) aligned based (star_list_branch_ptr), 3 60 2 type fixed binary (2) unsigned unaligned, 3 61 /* storage system type */ 3 62 2 nnames fixed binary (16) unsigned unaligned, 3 63 /* number of names of entry that match star_name */ 3 64 2 nindex fixed binary (18) unsigned unaligned, 3 65 /* index of first name in star_list_names */ 3 66 2 dtem bit (36) unaligned, /* date-time directory entry of branch was last modified */ 3 67 2 pad bit (36) unaligned, 3 68 2 mode bit (5) unaligned, /* user's access mode to the branch */ 3 69 2 raw_mode bit (5) unaligned, /* user's ACL access mode */ 3 70 2 master_dir bit (1) unaligned, /* is branch a master directory */ 3 71 2 bit_count fixed binary (24) unaligned; 3 72 /* bit count of the branch */ 3 73 3 74 /* hcs_$star_list_ and hcs_$star_dir_list_ link structure */ 3 75 3 76 declare 1 star_links (star_branch_count + star_link_count) aligned based (star_list_branch_ptr), 3 77 2 type fixed binary (2) unsigned unaligned, 3 78 /* storage system type */ 3 79 2 nnames fixed binary (16) unsigned unaligned, 3 80 /* number of names of entry that match star_name */ 3 81 2 nindex fixed binary (18) unsigned unaligned, 3 82 /* index of first name in star_list_names */ 3 83 2 dtem bit (36) unaligned, /* date-time link was last modified */ 3 84 2 dtd bit (36) unaligned, /* date-time the link was last dumped */ 3 85 2 pathname_len fixed binary (18) unsigned unaligned, 3 86 /* length of the pathname of the link */ 3 87 2 pathname_index fixed binary (18) unsigned unaligned; 3 88 /* index of start of pathname in star_list_names */ 3 89 3 90 /* hcs_$star_list_ and hcs_$star_dir_list_ name array */ 3 91 3 92 declare star_list_names char (32) based (star_list_names_ptr) 3 93 dimension (star_links (star_branch_count + star_link_count).nindex 3 94 + star_links (star_branch_count + star_link_count).nnames 3 95 + divide (star_links (star_branch_count + star_link_count).pathname_len + 31, 32, 17, 0) 3 96 * binary ( 3 97 (star_links (star_branch_count + star_link_count).type = star_LINK) 3 98 & (star_select_sw >= star_LINKS_ONLY_WITH_LINK_PATHS), 1)); 3 99 3 100 /* hcs_$star_list_ and hcs_$star_dir_list_ link pathname */ 3 101 3 102 declare star_link_pathname char (star_links (star_linkx).pathname_len) 3 103 based (addr (star_list_names (star_links (star_linkx).pathname_index))); 3 104 3 105 /* internal static */ 3 106 3 107 /* star_select_sw values */ 3 108 3 109 declare star_LINKS_ONLY fixed binary (2) internal static options (constant) initial (1); 3 110 declare star_BRANCHES_ONLY fixed binary (2) internal static options (constant) initial (2); 3 111 declare star_ALL_ENTRIES fixed binary (2) internal static options (constant) initial (3); 3 112 declare star_LINKS_ONLY_WITH_LINK_PATHS 3 113 fixed binary (3) internal static options (constant) initial (5); 3 114 declare star_ALL_ENTRIES_WITH_LINK_PATHS 3 115 fixed binary (3) internal static options (constant) initial (7); 3 116 3 117 /* storage system types */ 3 118 3 119 declare star_LINK fixed binary (2) unsigned internal static options (constant) initial (0); 3 120 declare star_SEGMENT fixed binary (2) unsigned internal static options (constant) initial (1); 3 121 declare star_DIRECTORY fixed binary (2) unsigned internal static options (constant) initial (2); 3 122 3 123 /* END INCLUDE FILE . . . star_structures.incl.pl1 */ 224 4 1 /* Begin include file ..... iox_modes.incl.pl1 */ 4 2 4 3 /* Written by C. D. Tavares, 03/17/75 */ 4 4 /* Updated 10/31/77 by CDT to include short iox mode strings */ 4 5 4 6 dcl iox_modes (13) char (24) int static options (constant) aligned initial 4 7 ("stream_input", "stream_output", "stream_input_output", 4 8 "sequential_input", "sequential_output", "sequential_input_output", "sequential_update", 4 9 "keyed_sequential_input", "keyed_sequential_output", "keyed_sequential_update", 4 10 "direct_input", "direct_output", "direct_update"); 4 11 4 12 dcl short_iox_modes (13) char (4) int static options (constant) aligned initial 4 13 ("si", "so", "sio", "sqi", "sqo", "sqio", "squ", "ksqi", "ksqo", "ksqu", "di", "do", "du"); 4 14 4 15 dcl (Stream_input initial (1), 4 16 Stream_output initial (2), 4 17 Stream_input_output initial (3), 4 18 Sequential_input initial (4), 4 19 Sequential_output initial (5), 4 20 Sequential_input_output initial (6), 4 21 Sequential_update initial (7), 4 22 Keyed_sequential_input initial (8), 4 23 Keyed_sequential_output initial (9), 4 24 Keyed_sequential_update initial (10), 4 25 Direct_input initial (11), 4 26 Direct_output initial (12), 4 27 Direct_update initial (13)) fixed bin int static options (constant); 4 28 4 29 /* End include file ..... iox_modes.incl.pl1 */ 225 5 1 /* ====== BEGIN INCLUDE SEGMENT apl_number_data.incl.pl1 ================================== */ 5 2 5 3 /* 5 4* This include file contains information about the machine representation of numbers. 5 5* In all programs numbers should simply be declared 'float'. 5 6* All default statements should be in this include file. 5 7* 5 8* This is the binary version. The manifest constant Binary should be used by programs 5 9* that need to know whether we are using binary or decimal. 5 10* */ 5 11 5 12 /* format: style3,initlm0,idind30 */ 5 13 5 14 default (float & ^decimal & ^binary & ^precision & ^constant) float binary (63); 5 15 5 16 declare ( 5 17 TheBiggestNumberWeveGot float initial (0.1701411834604692317e+39), 5 18 TheSmallestNumberWeveGot float initial (.1469367938527859385e-38), 5 19 Binary bit (1) aligned initial ("1"b) 5 20 ) internal static options (constant); 5 21 5 22 /* Number of characters in a number datum entry; used for copying float number arrays as strings. 5 23* (Obsolete! use array copies!) */ 5 24 5 25 declare NumberSize fixed binary precision (4) internal static initial (8); 5 26 5 27 /* ------ END INCLUDE SEGMENT apl_number_data.incl.pl1 ---------------------------------- */ 226 6 1 /* ====== BEGIN INCLUDE SEGMENT apl_ws_info.incl.pl1 ====================================== */ 6 2 6 3 /* This structure contains all of the global data (or pointers to it) for the APL subsystem */ 6 4 6 5 /* automatic */ 6 6 6 7 declare ws_info_ptr ptr initial (apl_static_$ws_info_ptr.static_ws_info_ptr); 6 8 6 9 /* external static */ 6 10 6 11 declare 1 apl_static_$ws_info_ptr external static aligned structure, 6 12 2 static_ws_info_ptr unaligned pointer; 6 13 6 14 /* based */ 6 15 6 16 declare 1 ws_info aligned based (ws_info_ptr), 6 17 2 version_number fixed bin, /* version of this structure (3) */ 6 18 2 switches unaligned, /* mainly ws parameters */ 6 19 3 long_error_mode bit, /* if 1, long Multics format, else APL/360 format */ 6 20 3 debug_mode bit, /* if 1, system error causes escape to command level */ 6 21 3 canonicalize_mode bit, /* if 1, the editor canonicalizes user input */ 6 22 3 restrict_exec_command bit, /* if 1, the )EXEC command may not be used */ 6 23 3 restrict_debug_command bit, /* if 1, the )DEBUG command may not be used */ 6 24 3 restrict_external_functions 6 25 bit, /* if 1, the )ZFN, )MFN, and )DFN commands may not be used */ 6 26 3 restrict_load bit, /* if 1, the )LOAD and )COPY commands may not be used */ 6 27 3 restrict_load_directory bit, /* if 1, no directory allowed in )LOAD or )COPY pathnames */ 6 28 3 restrict_save bit, /* if 1, the )SAVE command may not be used */ 6 29 3 restrict_save_directory bit, /* if 1, no directory allowed in )SAVE pathnames */ 6 30 3 off_hold bit, /* if 1, )OFF HOLD was typed, else just )OFF */ 6 31 3 transparent_to_signals bit, /* if 1, any conditions slip right past APL */ 6 32 3 meter_mode bit, /* if 1, metering may be done, else speed is all-important */ 6 33 3 restrict_msg_command bit, /* if 1, the )MSG command may not be used. */ 6 34 3 compatibility_check_mode 6 35 bit, /* if 1, check for incompatible operators */ 6 36 3 no_quit_handler bit, /* if 1, do not trap QUITs. */ 6 37 /* remaining 20 bits not presently used */ 6 38 6 39 2 values, /* attributes of the workspace */ 6 40 3 digits fixed bin, /* number of digits of precision printed on output */ 6 41 3 width fixed bin, /* line length for formatted output */ 6 42 3 index_origin fixed bin, /* the index origin (0 or 1) */ 6 43 3 random_link fixed bin(35), /* seed for random number generator */ 6 44 3 fuzz float, /* comparison tolerance (relative fuzz) */ 6 45 3 float_index_origin float, /* the index origin in floating point */ 6 46 3 number_of_symbols fixed bin, /* the number of symbol_beads currently in existence */ 6 47 3 maximum_value_stack_size 6 48 fixed bin (18), /* maximum number of words in one segment of value stack */ 6 49 6 50 2 pointers, /* pointers to various internal tables */ 6 51 3 symbol_table_ptr unaligned pointer, /* -> symbol_table (apl_symbol_table.incl.pl1) */ 6 52 3 current_parse_frame_ptr unaligned pointer, /* -> topmost parse frame */ 6 53 3 value_stack_ptr unaligned pointer, /* -> next free location on value stack */ 6 54 3 alloc_free_info_ptr unaligned pointer, /* -> apl_storage_mngr_ data (apl_storage_system_data.incl.pl1) */ 6 55 6 56 2 time_invoked fixed bin(71), /* clock time that APL was entered */ 6 57 2 integer_fuzz float, /* the absolute fuzz used in checking for integers */ 6 58 2 user_number fixed bin(35), /* number under which the user is signed on */ 6 59 2 latent_expression unaligned pointer, /* -> value_bead for QuadLX */ 6 60 2 lock char(32), /* the lock currently set on this workspace (password) */ 6 61 2 wsid char(100), /* the workspace identification: name, number name, or clear ws */ 6 62 2 last_error_code fixed bin(35), /* last code passed to apl_error_ */ 6 63 2 signoff_lock character (32), 6 64 6 65 2 interrupt_info aligned, /* bits used by apl_interpreter_ to tell when to abort */ 6 66 3 dont_interrupt_parse bit, /* if 1, don't do a dirty stop because the parser is running */ 6 67 3 dont_interrupt_operator bit, /* if 1, don't do a dirty stop because an operator is running */ 6 68 3 dont_interrupt_storage_manager /* if 1, don't stop because apl_storage_mngr_ is */ 6 69 bit, /* munging his tables */ 6 70 3 unused_interrupt_bit bit, /* not presently used */ 6 71 3 dont_interrupt_command bit, 6 72 3 can_be_interrupted bit, /* if 1, OK to do a clean stop (we are between lines, reading) */ 6 73 3 clean_interrupt_pending bit, /* interrupt occured, break cleanly (between lines) */ 6 74 3 dirty_interrupt_pending bit, /* interrupt occured, break as soon as not inhibited */ 6 75 6 76 2 user_name char (32), /* process group id of user */ 6 77 2 immediate_input_prompt char (32) varying, /* normal input */ 6 78 2 evaluated_input_prompt char (32) varying, /* quad input */ 6 79 2 character_input_prompt char (32) varying, /* quad-quote input */ 6 80 2 vcpu_time aligned, 6 81 3 total fixed bin (71), 6 82 3 setup fixed bin (71), 6 83 3 parse fixed bin (71), 6 84 3 lex fixed bin (71), 6 85 3 operator fixed bin (71), 6 86 3 storage_manager fixed bin (71), 6 87 2 output_info aligned, /* data pertaining to output buffer */ 6 88 3 output_buffer_ptr unal ptr, /* ptr to output buffer */ 6 89 3 output_buffer_len fixed bin (21), /* length (bytes) of output buffer */ 6 90 3 output_buffer_pos fixed bin (21), /* index of next byte to write in */ 6 91 3 output_buffer_ll fixed bin (21), /* print positions used up so far */ 6 92 2 tab_width fixed bin (21); /* number of columns a tabs moves cursor */ 6 93 6 94 declare output_buffer char (ws_info.output_buffer_len) based (ws_info.output_buffer_ptr); 6 95 6 96 /* internal static */ 6 97 6 98 declare max_parse_stack_depth fixed bin int static init(64536); 6 99 6 100 /* ------ END INCLUDE SEGMENT apl_ws_info.incl.pl1 -------------------------------------- */ 227 7 1 /* ====== BEGIN INCLUDE SEGMENT apl_bead_format.incl.pl1 ================================== */ 7 2 7 3 declare 1 general_bead aligned based, /* The Venerable Bead */ 7 4 2 type unaligned, 7 5 3 bead_type unaligned, 7 6 4 operator bit (1), /* ON if operator bead */ 7 7 4 symbol bit (1), /* ON if symbol bead */ 7 8 4 value bit (1), /* ON if value bead */ 7 9 4 function bit (1), /* ON if function bead */ 7 10 4 group bit (1), /* ON if group bead */ 7 11 4 label bit (1), /* ON if label bead */ 7 12 4 shared_variable bit (1), /* ON if shared variable bead */ 7 13 4 lexed_function bit (1), /* ON if lexed function bead */ 7 14 3 data_type unaligned, 7 15 4 list_value bit (1), /* ON if a list value bead */ 7 16 4 character_value bit (1), /* ON if a character value bead */ 7 17 4 numeric_value bit (1), /* ON if a numeric value bead */ 7 18 4 integral_value bit (1), /* ON if an integral value bead */ 7 19 4 zero_or_one_value bit (1), /* ON if a boolean value bead */ 7 20 4 complex_value bit (1), /* ON if a complex, numeric value bead */ 7 21 3 unused_bits bit (4) unaligned, /* pad to 18 bits (for future use) */ 7 22 2 size bit (18) unaligned, /* Number of words this bead occupies 7 23* (used by bead storage manager) */ 7 24 2 reference_count fixed binary (29); /* Number of pointers which point 7 25* to this bead (used by bead manager) */ 7 26 7 27 7 28 /* constant strings for initing type field in various beads */ 7 29 7 30 declare ( 7 31 operator_type init("100000000000000000"b), 7 32 symbol_type init("010000000000000000"b), 7 33 value_type init("001000000000000000"b), 7 34 function_type init("000100000000000000"b), 7 35 group_type init("000010000000000000"b), 7 36 label_type init("001001000011000000"b), 7 37 shared_variable_type init("001000100000000000"b), 7 38 lexed_function_type init("000000010000000000"b), 7 39 7 40 list_value_type init("000000001000000000"b), 7 41 character_value_type init("001000000100000000"b), 7 42 numeric_value_type init("001000000010000000"b), 7 43 integral_value_type init("001000000011000000"b), 7 44 zero_or_one_value_type init("001000000011100000"b), 7 45 complex_value_type init("001000000000010000"b), 7 46 7 47 not_integer_mask init("111111111110011111"b), /* to clear integral, zero_or_one bits */ 7 48 not_zero_or_one_mask init("111111111111011111"b) /* to clear zero_or_one bit */ 7 49 ) bit(18) internal static; 7 50 7 51 /* ------ END INCLUDE SEGMENT apl_bead_format.incl.pl1 ---------------------------------- */ 228 8 1 /* ====== BEGIN INCLUDE SEGMENT apl_value_bead.incl.pl1 =================================== */ 8 2 8 3 declare 8 4 number_of_dimensions fixed bin, 8 5 8 6 1 value_bead aligned based, 8 7 2 header aligned like general_bead, 8 8 2 total_data_elements fixed binary (21), /* length of ,[value] in APL */ 8 9 2 rhorho fixed binary, /* number of dimensions of value */ 8 10 2 data_pointer pointer unaligned, /* packed pointer to the data in value */ 8 11 2 rho fixed binary (21) dimension (number_of_dimensions refer (value_bead.rhorho)); 8 12 /* dimensions of value (zero-origin) */ 8 13 8 14 8 15 declare 1 character_data_structure aligned based, /* alignment trick for PL/I compiler */ 8 16 2 character_datum character (1) unaligned dimension (0:data_elements - 1); 8 17 /* actual elements of character array */ 8 18 8 19 declare character_string_overlay character (data_elements) aligned based; 8 20 /* to overlay on above structure */ 8 21 8 22 8 23 declare numeric_datum float aligned dimension (0:data_elements - 1) based; 8 24 /* actual elements of numeric array */ 8 25 8 26 declare complex_datum complex float aligned dimension (0:data_elements -1) based; 8 27 8 28 declare MAX_VALUE_BEAD_SIZE fixed bin (19) init (261120) int static options (constant); 8 29 8 30 /* ------ END INCLUDE SEGMENT apl_value_bead.incl.pl1 ----------------------------------- */ 229 9 1 /* ====== BEGIN INCLUDE SEGEMENT apl_operators_argument.incl.pl1 =========================== */ 9 2 9 3 declare 1 operators_argument aligned, 9 4 2 operands (2) aligned, /* these are the operands to the operator to be executed. 9 5* if operand (1).value is null, operator is monadic */ 9 6 3 value pointer unaligned, /* a pointer to the value bead for this operand */ 9 7 3 on_stack bit (1) aligned, /* ON if this value resides on the value stack */ 9 8 2 operator aligned, /* information about the operator to be executed */ 9 9 3 dimension fixed bin, /* (optional) dimension along which to operate */ 9 10 3 padding bit (18) unaligned, /* unused part of operator bead */ 9 11 3 op2 fixed bin (8) unal, /* a modifier for op1, or a 2nd operator if inner product */ 9 12 3 op1 fixed bin (8) unal, /* code for the actual operator to be executed */ 9 13 2 result pointer unal, /* (output) set by operator to point to result bead in stack */ 9 14 2 error_code fixed bin (35), /* (output) set before signaling apl_operator_error_ */ 9 15 2 where_error fixed bin; /* parseme index of where error was - parse sets to operator */ 9 16 9 17 /* ------ END INCLUDE SEGMENT apl_operators_argument.incl.pl1 --------------------------- */ 230 231 232 /* All calls to file system functions are made through the main 233* procedure, apl_file_system_. The following transfer vector picks 234* the appropriate entry and starts it off. */ 235 236 /* Pop argument(s) off stack */ 237 238 if operators_argument.operands(2).on_stack 239 then ws_info.value_stack_ptr = operators_argument.operands(2).value; 240 else if operators_argument.operands(1).on_stack 241 then ws_info.value_stack_ptr = operators_argument.operands(1).value; 242 243 goto file_operation(operators_argument.op1); 244 245 niladic_functions: 246 entry (operators_argument); 247 248 goto file_operation(operators_argument.op1); 249 250 /* The three entries following all deal with file opening. They merely 251* set some state bits, then call open_file which does all the real work. */ 252 253 file_operation(75): /* qFCREATE */ 254 255 share = "0"b; /* exclusive open */ 256 create_if_not_found = "1"b; /* create a new file */ 257 goto decode_args; 258 259 file_operation(92): /* qFTIE */ 260 share = "0"b; 261 create_if_not_found = "0"b; 262 goto decode_args; 263 264 file_operation(91): /* qFSTIE */ 265 share = "1"b; 266 create_if_not_found = "0"b; 267 goto decode_args; 268 269 decode_args: 270 call decode_file_id; 271 call decode_right_arg (1, 1); 272 273 /* If the maximum number of files are already tied, complain. */ 274 275 if number_of_files_tied >= dimension (tied_files, 1) 276 then call file_error (apl_error_table_$too_many_files); 277 278 call open_file (share, create_if_not_found); 279 280 operators_argument.result = null(); 281 282 error_return: /* All errors return through here. */ 283 return; 284 285 286 /* FUNTIE unties (i.e. closes and detaches) all APL files given in its 287* right argument, updating the file header information if necessary. */ 288 289 file_operation(121): /* qFUNTIE */ 290 291 call decode_right_arg (0, -1); /* allow infinite number */ 292 293 /* Check each tie number for validity and untie them. */ 294 295 call check_integers (right_vb, code); 296 if code ^= 0 297 then call file_error (code); 298 299 untie_error = "0"b; 300 do count = 0 to (right_vb -> value_bead.total_data_elements - 1); 301 302 tie_num = integerize (right -> numeric_datum (count)); 303 304 tied_array_idx = get_tie_index (tie_num, code); 305 306 if code = 0 307 then call untie_file (tied_array_idx, code); 308 309 /* If that number is not tied, go to next. Any other error 310* is fatal. */ 311 312 else if code = apl_error_table_$bad_tie_num 313 then untie_error = "1"b; 314 else call file_error (code); 315 316 end; /* do for all tie nums */ 317 318 if untie_error 319 then call file_error (apl_error_table_$bad_tie_num); 320 321 operators_argument.result = null; 322 return; 323 324 /* FERASE unties and deletes a file. */ 325 326 file_operation(78): /* qFERASE */ 327 328 call decode_file_id; 329 call decode_right_arg (1, 1); 330 331 /* Find the array index of the specified file. */ 332 333 tied_array_idx = get_tie_index (tie_num, code); 334 if code ^= 0 335 then call file_error (code); 336 337 /* Get the full pathnames of both the specified file and 338* the file tied to the specified tie number. */ 339 340 call expand_pathname_ (file_pathname, new_dname, new_ename, code); 341 if code ^= 0 342 then call file_error (code); 343 344 call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); 345 if code ^= 0 346 then call file_error (code); 347 348 /* Get unique ids of the file specified by name and the file 349* tied to the specified number. */ 350 351 call hcs_$status_long (new_dname, new_ename, 1, addr (branch_status), null (), code); 352 if code ^= 0 353 then call file_error (code); 354 355 uid = branch_status.unique_id; 356 357 call hcs_$status_long (file_dname, file_ename, 1, addr (branch_status), null (), code); 358 if code ^= 0 359 then call file_error (code); 360 361 if branch_status.unique_id ^= uid 362 then call file_error (apl_error_table_$bad_fname_match); 363 364 call untie_file (tied_array_idx, code); 365 366 call delete_$path (file_dname, file_ename, "000100"b, "apl", code); 367 if code ^= 0 368 then call file_error (code); 369 370 operators_argument.result = null(); 371 return; /* from ferase */ 372 373 374 /* FRENAME changes the filename of a tied APL file. */ 375 376 file_operation(87): /* qFRENAME */ 377 378 call decode_file_id; 379 call decode_right_arg (1, 1); 380 381 tied_array_idx = get_tie_index (tie_num, code); 382 if code ^= 0 383 then call file_error (code); 384 385 /* Get the full pathnames of both the given filename and the 386* filename of the file tied to the given number. */ 387 388 call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); 389 if code ^= 0 390 then call file_error (code); 391 392 call expand_pathname_ (file_pathname, new_dname, new_ename, code); 393 if code ^= 0 394 then call file_error (code); 395 396 /* If the names are not the same, rename the file (hcs_$chname_file 397* complains if the names are identical). */ 398 399 if new_ename ^= file_ename 400 then do; 401 call hcs_$chname_file (file_dname, file_ename, file_ename, new_ename, code); 402 if code ^= 0 403 then call file_error (code); 404 405 tied_files(tied_array_idx).file_name = file_pathname; 406 end; 407 408 operators_argument.result = null (); 409 return; /* from frename */ 410 411 /* FAPPEND writes the given APL value to the logical end of the APL file. */ 412 413 file_operation(74): /* qFAPPEND */ 414 415 call decode_right_arg (1, 1); 416 417 left_vb = operators_argument(1).value; 418 419 tied_array_idx = get_tie_index (tie_num, code); 420 if code ^= 0 421 then call file_error (code); 422 423 iocb_ptr = tied_files(tied_array_idx).iocb_ptr; 424 425 /* if file is sharable, read header from file */ 426 427 if tied_files(tied_array_idx).shared 428 then do; 429 file_header_size = size (file_header) * 4; 430 431 call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); 432 if code ^= 0 433 then call file_error (code); 434 435 /* Prevent interference from other users of the shared 436* file */ 437 438 call lock_file (tied_array_idx, lock); 439 440 call iox_$read_record (iocb_ptr, addr (file_header), file_header_size, size_read, code); 441 if code ^= 0 442 then call file_error (code); 443 444 component_number = file_header.last_component + 1; 445 end; 446 else component_number = tied_files(tied_array_idx).last_component + 1; 447 448 component_key = component_number; /* convert to string */ 449 450 call iox_$seek_key (iocb_ptr, (component_key), size_read, code); 451 452 /* Component must not already be there. */ 453 454 if code ^= error_table_$no_record 455 then call file_error (apl_error_table_$bad_apl_file); 456 457 if operators_argument(1).on_stack 458 then bead_size = compute_length (left_vb); 459 else bead_size = binary (left_vb -> value_bead.size) * 4; 460 461 /* Write the bead out wholesale. The one pointer in it 462* (value_bead.data_pointer) will br reconstructed by FREAD */ 463 464 call iox_$write_record (iocb_ptr, left_vb, bead_size, code); 465 if code ^= 0 466 then call file_error (code); 467 468 /* Update component header */ 469 470 /* Get info to write to component header... */ 471 472 component_header.user_id = group_id; 473 component_header.user_number = ws_info.user_number; 474 component_header.time = clock (); 475 component_header.size = bead_size; 476 477 component_header_size = size (component_header) * 4; 478 479 /* ...and write it out */ 480 481 call iox_$seek_key (iocb_ptr, component_key || "info", size_read, code); 482 483 if code = error_table_$no_record 484 then call iox_$write_record (iocb_ptr, addr (component_header), component_header_size, code); 485 else call iox_$rewrite_record (iocb_ptr, addr (component_header), component_header_size, code); 486 487 if code ^= 0 488 then call file_error (code); 489 490 /* Update file header information, either in the file or in the array */ 491 492 if tied_files(tied_array_idx).shared 493 then do; 494 file_header_size = size (file_header) * 4; 495 file_header.version = file_header_version; 496 file_header.last_component = component_number; 497 if file_header.first_component = 0 498 then file_header.first_component = component_number; 499 500 call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); 501 if code ^= 0 502 then call file_error (code); 503 504 call iox_$rewrite_record (iocb_ptr, addr (file_header), file_header_size, code); 505 if code ^= 0 506 then call file_error (code); 507 508 /* Unlock the file. */ 509 510 call lock_file (tied_array_idx, unlock); 511 512 end; 513 else do; 514 tied_files(tied_array_idx).last_component = component_number; 515 if tied_files(tied_array_idx).first_component = 0 516 then tied_files(tied_array_idx).first_component = component_number; 517 end; 518 519 operators_argument.result = null(); 520 521 return; /* from fappend */ 522 523 524 /* FREPLACE replaces the value of a given APL file component with a 525* new value. */ 526 527 file_operation(88): /* qFREPLACE */ 528 529 /* Get tie number and component number. */ 530 531 call decode_right_arg (2, 2); 532 533 tied_array_idx = get_tie_index (tie_num, code); 534 if code ^= 0 535 then call file_error (code); 536 537 /* Check range of component number if possible. */ 538 539 if ^(tied_files(tied_array_idx).shared) 540 then if (component_number < tied_files(tied_array_idx).first_component) | 541 (component_number > tied_files(tied_array_idx).last_component) 542 then call file_error (apl_error_table_$bad_component_num); 543 544 /* Get pointer to APL value. */ 545 546 left_vb = operators_argument(1).value; 547 548 iocb_ptr = tied_files(tied_array_idx).iocb_ptr; 549 550 component_key = component_number; 551 552 /* Seek component with given number. If it does not exist, the 553* component number is out of range. */ 554 555 call iox_$seek_key (iocb_ptr, (component_key), size_read, code); 556 if code = error_table_$no_record 557 then call file_error (apl_error_table_$bad_component_num); 558 else if code ^= 0 559 then call file_error (code); 560 561 /* Compute total size of the bead. */ 562 563 if operators_argument(1).on_stack 564 then bead_size = compute_length (left_vb); 565 else bead_size = binary (left_vb -> value_bead.size) * 4; 566 567 /* Write the new value. */ 568 569 if tied_files(tied_array_idx).shared 570 then call lock_file (tied_array_idx, lock); 571 572 call iox_$rewrite_record (iocb_ptr, left_vb, bead_size, code); 573 if code ^= 0 574 then call file_error (code); 575 576 /* Update the component header. */ 577 578 /* Get info to write to component header... */ 579 580 component_header.user_id = group_id; 581 component_header.user_number = ws_info.user_number; 582 component_header.time = clock (); 583 component_header.size = bead_size; 584 585 component_header_size = size (component_header) * 4; 586 587 /* ...and write it out */ 588 589 call iox_$seek_key (iocb_ptr, component_key || "info", size_read, code); 590 if code ^= 0 591 then call file_error (code); 592 593 call iox_$rewrite_record (iocb_ptr, addr (component_header), component_header_size, code); 594 if code ^= 0 595 then call file_error (code); 596 597 /* As we are replacing a component the total number of components 598* remains the same, and we don't have to update the file header. */ 599 600 if tied_files(tied_array_idx).shared 601 then call lock_file (tied_array_idx, unlock); 602 603 operators_argument.result = null(); 604 605 return; /* from freplace */ 606 607 608 /* FDROP deletes components from either end of an APL file. */ 609 610 file_operation(77): /* qFDROP */ 611 612 call decode_right_arg (2, 2); 613 614 tied_array_idx = get_tie_index (tie_num, code); 615 if code ^= 0 616 then call file_error (code); 617 618 iocb_ptr = tied_files(tied_array_idx).iocb_ptr; 619 620 /* If file is opened for sharing, we must read header info from 621* file header. */ 622 623 if tied_files(tied_array_idx).shared 624 then do; 625 call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); 626 if code ^= 0 627 then call file_error (code); 628 629 file_header_size = size (file_header) * 4; 630 631 call lock_file (tied_array_idx, lock); 632 633 call iox_$read_record (iocb_ptr, addr (file_header), file_header_size, size_read, code); 634 if code ^= 0 635 then call file_error (code); 636 637 start_component = file_header.first_component; 638 end_component = file_header.last_component; 639 end; 640 else do; 641 start_component = tied_files(tied_array_idx).first_component; 642 end_component = tied_files(tied_array_idx).last_component; 643 end; 644 645 /* Check to see that there are as many components to drop as 646* specified. */ 647 648 if drop_number > (end_component - start_component + 1) 649 then call file_error (apl_error_table_$not_enough_components); 650 651 /* If drop_number is positve, drop components from the low numbered 652* end of the file. Update static file information now so that even 653* if something goes wrong, the file will look like the components 654* were dropped. */ 655 656 if drop_number > 0 657 then do; 658 end_component = (start_component + drop_number - 1); 659 increment = 1; 660 tied_files(tied_array_idx).first_component = end_component + 1; 661 end; 662 else do; 663 start_component = end_component; /* start from high end */ 664 end_component = (start_component + drop_number + 1); 665 increment = -1; 666 tied_files(tied_array_idx).last_component = end_component - 1; 667 end; 668 669 /* Check to see if any components remain. If not, reset the 670* static information to the same state as for an empty file. It 671* is not certain that this is done in the APL*PLUS file system, 672* but it seems reasonable. */ 673 674 if tied_files(tied_array_idx).first_component > tied_files(tied_array_idx).last_component 675 then do; 676 tied_files(tied_array_idx).first_component = 0; 677 tied_files(tied_array_idx).last_component = 0; 678 end; 679 680 /* Update the shared file information. If this is done here, 681* the components will appear to be gone even if something goes 682* wrong below. */ 683 684 if tied_files(tied_array_idx).shared 685 then do; 686 file_header.first_component = tied_files(tied_array_idx).first_component; 687 file_header.last_component = tied_files(tied_array_idx).last_component; 688 689 call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); 690 if code ^= 0 691 then call file_error (code); 692 693 call iox_$rewrite_record (iocb_ptr, addr (file_header), file_header_size, code); 694 if code ^= 0 695 then call file_error (code); 696 697 call lock_file (tied_array_idx, unlock); 698 end; 699 700 /* Do the real work. */ 701 702 do component_number = start_component to end_component by increment; 703 704 component_key = component_number; 705 706 call iox_$seek_key (iocb_ptr, (component_key), size_read, code); 707 if code ^= 0 708 then call file_error (code); 709 710 call iox_$delete_record (iocb_ptr, code); 711 if code ^= 0 712 then call file_error (code); 713 end; 714 715 operators_argument.result = null(); 716 return; /* from fdrop */ 717 718 /* FREAD reads an APL value from an APL file and returns it. */ 719 720 file_operation(86): /* qFREAD */ 721 722 /* Get tie number and component number */ 723 724 call decode_right_arg (2, 2); 725 726 tied_array_idx = get_tie_index (tie_num, code); 727 if code ^= 0 728 then call file_error (code); 729 730 /* Check component number for proper range of values if info is available */ 731 732 if ^(tied_files(tied_array_idx).shared) 733 then if (component_number > tied_files(tied_array_idx).last_component) | 734 (component_number < tied_files(tied_array_idx).first_component) 735 then call file_error (apl_error_table_$bad_component_num); 736 737 iocb_ptr = tied_files(tied_array_idx).iocb_ptr; 738 739 component_key = component_number; 740 741 /* Find file component with designated key. If none exists, 742* component number must have been out of range. */ 743 744 call iox_$seek_key (iocb_ptr, (component_key), size_read, code); 745 if code = error_table_$no_record 746 then call file_error (apl_error_table_$bad_component_num); 747 else if code ^= 0 748 then call file_error (code); 749 750 bead_size = divide ((size_read + 3), 4, 21, 0); /* convert bytes to words */ 751 752 /* Get storage to hold value bead... */ 753 754 result_vb = apl_push_stack_ ((bead_size)); 755 756 /* ...and read file component into it. */ 757 758 call iox_$read_record (iocb_ptr, (result_vb), size_read, size_read, code); 759 if code ^= 0 760 then call file_error (code); 761 762 /* Find pointer to actual data. It starts after the last element 763* of value_bead.rho. */ 764 765 data_ptr = addrel (addr (result_vb -> value_bead.rho (result_vb -> value_bead.rhorho)), 1); 766 767 /* If data is numeric, it is guarenteed to be even word aligned. 768* Adjust the pointer accordingly. */ 769 770 if result_vb -> value_bead.numeric_value 771 then if substr (rel (data_ptr), 18, 1) /* even or odd word? */ 772 then data_ptr = addrel (data_ptr, 1); 773 774 /* Assign value into bead header... */ 775 776 result_vb -> value_bead.data_pointer = data_ptr; 777 778 /* ...and return value bead. */ 779 780 operators_argument.result = result_vb; 781 782 return; /* from fread */ 783 784 /* FRDCI returns information about a given component in an APL file. */ 785 786 file_operation(85): /* qFRDCI */ 787 788 call decode_right_arg (2, 2); 789 790 tied_array_idx = get_tie_index (tie_num, code); 791 if code ^= 0 792 then call file_error (code); 793 794 /* Check component number for proper range of values if info is available */ 795 796 if ^tied_files(tied_array_idx).shared 797 then if (component_number > tied_files(tied_array_idx).last_component) | 798 (component_number < tied_files(tied_array_idx).first_component) 799 then call file_error (apl_error_table_$bad_component_num); 800 801 iocb_ptr = tied_files(tied_array_idx).iocb_ptr; 802 803 component_key = component_number; 804 805 /* Find file component with designated key. If none exists, 806* component number must have been out of range. */ 807 808 call iox_$seek_key (iocb_ptr, component_key || "info", size_read, code); 809 if code = error_table_$no_record 810 then call file_error (apl_error_table_$bad_component_num); 811 else if code ^= 0 812 then call file_error (code); 813 814 component_header_size = size (component_header) * 4; 815 call iox_$read_record (iocb_ptr, addr (component_header), component_header_size, size_read, code); 816 if code ^= 0 817 then call file_error (code); 818 819 /* Set global infomation on bead size, to be used to calculate 820* how much storage to ask for. */ 821 822 data_elements = 3; 823 number_of_dimensions = 1; 824 bead_size = size (value_bead) + size (numeric_datum) + 1; 825 826 /* Get storage for bead. */ 827 828 result_vb = apl_push_stack_ ((bead_size)); 829 830 /* Fix up bead. */ 831 832 string (result_vb -> value_bead.type) = integral_value_type; /* from incl file */ 833 result_vb -> value_bead.total_data_elements = data_elements; 834 result_vb -> value_bead.rhorho = number_of_dimensions; 835 result_vb -> value_bead.rho(1) = data_elements; 836 837 result = addrel (result_vb, size (value_bead)); 838 839 /* even word align data */ 840 841 if substr (rel (result), 18, 1) 842 then result = addrel (result, 1); 843 844 result_vb -> value_bead.data_pointer = result; 845 846 result -> numeric_datum(0) = component_header.size; 847 result -> numeric_datum(1) = component_header.user_number; 848 result -> numeric_datum(2) = component_header.time; 849 850 operators_argument.result = result_vb; 851 return; /* from frdci */ 852 853 854 /* FNUMS returns the tie numbers of all tied files. */ 855 856 file_operation(84): /* qFNUMS */ 857 858 /* We don't need to call decode_right_arg as this is a niladic 859* function, and is guaranteed to have no args (by APL) */ 860 861 /* Set global data used to compute length of bead. */ 862 863 data_elements = number_of_files_tied; 864 number_of_dimensions = 1; 865 866 bead_size = size (value_bead) + size (numeric_datum) + 1; 867 868 result_vb = apl_push_stack_ ((bead_size)); 869 870 string (result_vb -> value_bead.type) = integral_value_type; 871 result_vb -> value_bead.total_data_elements = data_elements; 872 result_vb -> value_bead.rhorho = number_of_dimensions; 873 result_vb -> value_bead.rho(1) = data_elements; 874 875 /* Find pointer to data. */ 876 877 result = addrel (result_vb, size (value_bead)); 878 879 /* Even word align the data pointer. */ 880 881 if substr (rel (result), 18, 1) 882 then result = addrel (result, 1); 883 884 result_vb -> value_bead.data_pointer = result; 885 886 /* Fill in result bead with tie numbers of tied files. */ 887 888 idx = 0; 889 do count = lbound (tied_files, 1) to hbound (tied_files, 1); 890 if tied_files(count).iocb_ptr ^= null () 891 then do; 892 result -> numeric_datum(idx) = tied_files(count).tie_number; 893 idx = idx + 1; 894 end; 895 end; 896 897 operators_argument.result = result_vb; 898 return; /* from fnums */ 899 900 /* FNAMES returns the names of the currently tied files in a character 901* matrix. */ 902 903 file_operation(83): /* qFNAMES */ 904 905 /* We don't need to call decode_right_arg because we are 906* guaranteed to have no arguments. */ 907 908 /* Set global data used for bead size computation. */ 909 910 data_elements = number_of_files_tied * 168; /* max length of one pathname */ 911 number_of_dimensions = 2; 912 913 bead_size = size (value_bead) + size (character_data_structure); 914 915 result_vb = apl_push_stack_ ((bead_size)); /* allocate storage */ 916 917 string (result_vb -> value_bead.type) = character_value_type; 918 result_vb -> value_bead.total_data_elements = data_elements; 919 result_vb -> value_bead.rhorho = number_of_dimensions; 920 result_vb -> value_bead.rho(1) = number_of_files_tied; 921 result_vb -> value_bead.rho(2) = 168; 922 923 /* Find pointer to data in bead */ 924 925 result = addrel (result_vb, size (value_bead)); 926 927 result_vb -> value_bead.data_pointer = result; 928 929 /* Fill in result bead with file pathnames. */ 930 931 idx = 0; 932 do count = lbound (tied_files, 1) to hbound (tied_files, 1); 933 if tied_files(count).iocb_ptr ^= null () 934 then do; 935 substr (result -> character_string_overlay, (idx * 168 + 1), 168) = 936 tied_files(count).file_name; 937 idx = idx + 1; 938 end; 939 end; 940 941 operators_argument.result = result_vb; 942 return; /* from fnames */ 943 944 /* FLIB returns a character matrix of all of the files on the working dir */ 945 946 file_operation(80): /* qFLIB */ 947 948 right_vb = operators_argument.operands(2).value; 949 950 data_elements = right_vb -> value_bead.total_data_elements; 951 952 file_pathname = right_vb -> value_bead.data_pointer -> character_string_overlay; 953 954 /* Ask apl_translate_pathname_ for a directory (signified by passing 955* it a null string ename). */ 956 957 call apl_translate_pathname_$file_system_pathname (file_pathname, file_dname, (""), null (), code); 958 if code ^= 0 959 then call file_error (code); 960 961 file_ename = "**.cf.apl"; 962 963 area_ptr = get_system_free_area_ (); 964 965 call hcs_$star_ (file_dname, file_ename, 3, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); 966 967 if code = 0 968 then data_elements = star_entry_count * 32; 969 else if code = error_table_$nomatch 970 then data_elements = 0; 971 else call file_error (code); 972 973 number_of_dimensions = 2; 974 975 bead_size = size (value_bead) + size (character_data_structure); 976 977 result_vb = apl_push_stack_ ((bead_size)); 978 979 string (result_vb -> value_bead.type) = character_value_type; 980 result_vb -> value_bead.total_data_elements = data_elements; 981 result_vb -> value_bead.rhorho = number_of_dimensions; 982 result_vb -> value_bead.rho(1) = star_entry_count; 983 result_vb -> value_bead.rho(2) = 32; 984 985 /* Find pointer to data in bead */ 986 987 result = addrel (result_vb, size (value_bead)); 988 989 result_vb -> value_bead.data_pointer = result; 990 991 do count = 1 to star_entry_count; /* star_entry_count will be 0 for no matches. */ 992 993 substr (result -> character_string_overlay, (count - 1) * 32 + 1, 32) = star_names(star_entries(count).nindex); 994 end; 995 996 /* If no matches were found, ptr's are null */ 997 998 if star_names_ptr ^= null() 999 then free star_names in (system_area); 1000 if star_entry_ptr ^= null() 1001 then free star_entries in (system_area); 1002 1003 operators_argument.result = result_vb; 1004 return; /* from flib */ 1005 1006 /* FLISTACL returns a character matrix of the Access Control List for 1007* the msf containing the APL file. */ 1008 1009 file_operation(82): /* qFLISTACL */ 1010 1011 call decode_right_arg (1, 1); 1012 1013 tied_array_idx = get_tie_index (tie_num, code); 1014 if code ^= 0 1015 then call file_error (code); 1016 1017 iocb_ptr = tied_files(tied_array_idx).iocb_ptr; 1018 1019 /* Get pointer to area in which to write data. */ 1020 1021 area_ptr = get_system_free_area_ (); 1022 1023 /* Get ACL */ 1024 1025 call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); 1026 if code ^= 0 1027 then call file_error (code); 1028 1029 call msf_manager_$open (file_dname, file_ename, fcb_ptr, code); 1030 if code ^= 0 1031 then call file_error (code); 1032 1033 call msf_manager_$acl_list (fcb_ptr, area_ptr, acl_ptr, null(), acl_count, code); 1034 if code ^= 0 1035 then call file_error (code); 1036 1037 call msf_manager_$close (fcb_ptr); 1038 1039 /* Set global data used to compute bead length. */ 1040 1041 data_elements = 36 * acl_count; 1042 number_of_dimensions = 2; 1043 1044 bead_size = size (value_bead) + size (character_data_structure); 1045 1046 result_vb = apl_push_stack_ ((bead_size)); 1047 1048 string (result_vb -> value_bead.type) = character_value_type; 1049 result_vb -> value_bead.total_data_elements = data_elements; 1050 result_vb -> value_bead.rhorho = number_of_dimensions; 1051 result_vb -> value_bead.rho(1) = acl_count; 1052 result_vb -> value_bead.rho(2) = 36; 1053 1054 /* Find pointer to data in bead */ 1055 1056 result = addrel (result_vb, size (value_bead)); 1057 1058 result_vb -> value_bead.data_pointer = result; 1059 1060 do count = 1 to acl_count; 1061 1062 substr (result -> character_string_overlay, (((count - 1) * 36) + 5), 32) = segment_acl(count).access_name; 1063 1064 if substr (segment_acl(count).modes, 1, 1) 1065 then substr (mode_string, 1, 1) = "r"; 1066 else substr (mode_string, 1, 1) = " "; 1067 1068 if substr (segment_acl(count).modes, 2, 1) 1069 then substr (mode_string, 2, 1) = "e"; 1070 else substr (mode_string, 2, 1) = " "; 1071 1072 if substr (segment_acl(count).modes, 3, 1) 1073 then substr (mode_string, 3, 2) = "w "; 1074 else substr (mode_string, 3, 2) = " "; 1075 1076 substr (result -> character_string_overlay, (((count - 1) * 36) + 1), 4) = mode_string; 1077 1078 end; 1079 1080 free segment_acl in (system_area); 1081 1082 operators_argument.result = result_vb; 1083 return; /* from flistacl */ 1084 1085 /* FSETACL sets the Access Control List for an APL file. */ 1086 1087 file_operation(89): /* qFSETACL */ 1088 1089 fsetacl_not_faddacl = "1"b; 1090 goto common_acl_hacker; 1091 1092 /* FADDACL adds acl entries to the APL file acl. */ 1093 1094 file_operation(73): /* qFADDACL */ 1095 1096 fsetacl_not_faddacl = "0"b; 1097 goto common_acl_hacker; 1098 1099 common_acl_hacker: 1100 1101 call decode_right_arg (1, 1); 1102 1103 tied_array_idx = get_tie_index (tie_num, code); 1104 if code ^= 0 1105 then call file_error (code); 1106 1107 /* Decode the left argument */ 1108 1109 left_vb = operators_argument.operands(1).value; 1110 1111 /* Validate the character matrix */ 1112 1113 if ^left_vb -> general_bead.value 1114 then call file_error (apl_error_table_$domain); 1115 1116 if ^left_vb -> value_bead.character_value /* Must be characters */ 1117 then call file_error (apl_error_table_$domain); 1118 1119 /* Check for correct dimensionality. Must be vector or 2-dimensional 1120* array. */ 1121 1122 if (left_vb -> value_bead.rhorho > 2 | 1123 left_vb -> value_bead.rhorho < 1) 1124 then call file_error (apl_error_table_$rank); 1125 1126 /* If value is a matrix, it must be n by 36 */ 1127 1128 if left_vb -> value_bead.rhorho = 2 1129 then if left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) ^= 36 1130 then call file_error (apl_error_table_$length); 1131 else; 1132 1133 /* If it is a vector, it must have at least 5 elements ("rew *") */ 1134 1135 else if left_vb -> value_bead.total_data_elements < 5 1136 then call file_error (apl_error_table_$length); 1137 1138 left = left_vb -> value_bead.data_pointer; 1139 1140 /* Get space to put acl structure in. */ 1141 1142 area_ptr = get_system_free_area_ (); 1143 1144 if left_vb -> value_bead.rhorho = 1 1145 then acl_count = 1; 1146 else acl_count = left_vb -> value_bead.rho(1); 1147 1148 allocate segment_acl in (system_area); 1149 1150 data_elements = left_vb -> value_bead.total_data_elements; 1151 1152 /* Fill in acl structure. */ 1153 1154 code = 0; 1155 do count = 1 to acl_count; 1156 1157 if substr (left -> character_string_overlay, 4, 1) ^= " " /* space */ 1158 then do; 1159 code = apl_error_table_$bad_access_matrix; 1160 goto bad_matrix_syntax_exit; 1161 end; 1162 1163 /* The following statement is designed to allow the user to 1164* not bother to pad to 36 characters if his entry is a 1165* vector. Basically it uses rho(rhorho) of the value, which 1166* is rho(1) for a vector and rho(2) for a matrix, to compute 1167* the length of the current row of the value. The rho(2) of 1168* the matrix will always be 36 (see code above), the rho(1) 1169* of the vector will be the actual length of the vector. 1170* The substring of the line from the 5th char for 1171* length_of_line - 4 chars is the user id. cv_userid_ 1172* converts this into the canonical form. */ 1173 1174 segment_acl(count).access_name = cv_userid_ (ltrim (substr (left -> character_string_overlay, 1175 ((count - 1) * 36) + 5, 1176 left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) - 4))); 1177 1178 mode_string = substr (left -> character_string_overlay, ((count - 1) * 36) + 1, 3); 1179 1180 if verify (mode_string, "rew ") ^= 0 1181 then do; 1182 code = apl_error_table_$bad_access_modes; 1183 goto bad_matrix_syntax_exit; 1184 end; 1185 1186 substr (segment_acl(count).modes, 1, 1) = (index (mode_string, "r") > 0); 1187 substr (segment_acl(count).modes, 2, 1) = (index (mode_string, "e") > 0); 1188 substr (segment_acl(count).modes, 3, 1) = (index (mode_string, "w") > 0); 1189 1190 end; 1191 1192 /* Get the APL file pathname, then do the actual ACL rearranging. */ 1193 1194 call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename,code); 1195 if code ^= 0 1196 then call file_error (code); 1197 1198 call msf_manager_$open (file_dname, file_ename, fcb_ptr, code); 1199 if code ^= 0 1200 then call file_error (code); 1201 1202 if fsetacl_not_faddacl 1203 then call msf_manager_$acl_replace (fcb_ptr, acl_ptr, acl_count, "0"b, code); 1204 else call msf_manager_$acl_add (fcb_ptr, acl_ptr, acl_count, code); 1205 1206 call msf_manager_$close (fcb_ptr); 1207 1208 bad_matrix_syntax_exit: 1209 if code ^= 0 1210 then call file_error (code); 1211 1212 free segment_acl in (system_area); 1213 1214 operators_argument.result = null(); 1215 return; /* from fsetacl or faddacl */ 1216 1217 /* FDELETEACL removes the specified access names from the ACL list for an 1218* APL file. */ 1219 1220 file_operation(76): /* qFDELETEACL */ 1221 1222 call decode_right_arg (1, 1); 1223 1224 tied_array_idx = get_tie_index (tie_num, code); 1225 if code ^= 0 1226 then call file_error (code); 1227 1228 /* Decode the left argument */ 1229 1230 left_vb = operators_argument.operands(1).value; 1231 1232 /* Validate the character matrix */ 1233 1234 if ^left_vb -> general_bead.value 1235 then call file_error (apl_error_table_$domain); 1236 1237 if ^left_vb -> value_bead.character_value /* Must be characters */ 1238 then call file_error (apl_error_table_$domain); 1239 1240 /* Check for correct dimensionality. Must be vector or 2-dimensional 1241* array. */ 1242 1243 if (left_vb -> value_bead.rhorho > 2 | 1244 left_vb -> value_bead.rhorho < 1) 1245 then call file_error (apl_error_table_$rank); 1246 1247 /* Character matrix must be n by 32 */ 1248 1249 if left_vb -> value_bead.rhorho = 2 1250 then if left_vb -> value_bead.rho(left_vb -> value_bead.rhorho) ^= 32 1251 then call file_error (apl_error_table_$length); 1252 else; 1253 1254 /* If it is a vector, it must have at least 1 element. */ 1255 1256 else if left_vb -> value_bead.total_data_elements < 1 1257 then call file_error (apl_error_table_$length); 1258 1259 left = left_vb -> value_bead.data_pointer; 1260 1261 /* Get space to put acl structure in. */ 1262 1263 area_ptr = get_system_free_area_ (); 1264 1265 if left_vb -> value_bead.rhorho = 1 1266 then acl_count = 1; 1267 else acl_count = left_vb -> value_bead.rho(1); 1268 1269 allocate delete_acl in (system_area); 1270 1271 /* Fill in acl structure. */ 1272 1273 do count = 1 to acl_count; 1274 1275 /* For an explanation of the following statement, see the 1276* similar code in fsetacl. */ 1277 1278 delete_acl(count).access_name = cv_userid_ (substr (left -> character_string_overlay, 1279 ((count - 1) * 32) + 1, 1280 left_vb -> value_bead.rho(left_vb -> value_bead.rhorho))); 1281 1282 end; 1283 1284 /* Get the APL file pathname, then do the actual ACL rearranging. */ 1285 1286 call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); 1287 if code ^= 0 1288 then call file_error (code); 1289 1290 call msf_manager_$open (file_dname, file_ename, fcb_ptr, code); 1291 if code ^= 0 1292 then call file_error (code); 1293 1294 call msf_manager_$acl_delete (fcb_ptr, acl_ptr, acl_count, code); 1295 if code ^= 0 1296 then call file_error (code); 1297 1298 call msf_manager_$close (fcb_ptr); 1299 1300 free delete_acl in (system_area); 1301 1302 operators_argument.result = null(); 1303 return; /* from fdeleteacl */ 1304 1305 /* FLIM returns the number of the first component and 1 greater than the 1306* number of the last component. */ 1307 1308 file_operation(81): /* qFLIM */ 1309 1310 flim_not_fsize = "1"b; 1311 goto flim_fsize_common; 1312 1313 /* FSIZE returns the same information as FLIM, plus the storage used and 1314* storage reservation of the file */ 1315 1316 file_operation(90): /* qFSIZE */ 1317 1318 flim_not_fsize = "0"b; 1319 goto flim_fsize_common; 1320 1321 flim_fsize_common: 1322 1323 call decode_right_arg (1, 1); 1324 1325 tied_array_idx = get_tie_index (tie_num, code); 1326 if code ^= 0 1327 then call file_error (code); 1328 1329 iocb_ptr = tied_files(tied_array_idx).iocb_ptr; 1330 1331 /* Set global data used to compute bead length. */ 1332 1333 if flim_not_fsize then do; 1334 data_elements = 2; 1335 number_of_dimensions = 1; 1336 end; 1337 else do; 1338 data_elements = 4; 1339 number_of_dimensions = 1; 1340 end; 1341 1342 bead_size = size (value_bead) + size (numeric_datum) + 1; 1343 1344 result_vb = apl_push_stack_ ((bead_size)); 1345 1346 string (result_vb -> value_bead.type) = integral_value_type; 1347 result_vb -> value_bead.total_data_elements = data_elements; 1348 result_vb -> value_bead.rhorho = number_of_dimensions; 1349 result_vb -> value_bead.rho(1) = data_elements; 1350 1351 /* Find pointer to data. */ 1352 1353 result = addrel (result_vb, size (value_bead)); 1354 1355 /* Even word align the data pointer. */ 1356 1357 if substr (rel (result), 18, 1) 1358 then result = addrel (result, 1); 1359 1360 result_vb -> value_bead.data_pointer = result; 1361 /* Fill in the result bead with the first and last component 1362* numbers of the file. */ 1363 1364 if tied_files(tied_array_idx).shared 1365 then do; 1366 call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); 1367 if code ^= 0 1368 then call file_error (code); 1369 1370 file_header_size = size (file_header) * 4; 1371 1372 call iox_$read_record (iocb_ptr, addr (file_header), file_header_size, size_read, code); 1373 if code ^= 0 1374 then call file_error (code); 1375 1376 result -> numeric_datum(0) = file_header.first_component; 1377 result -> numeric_datum(1) = file_header.last_component + 1; 1378 end; 1379 else do; 1380 result -> numeric_datum(0) = tied_files(tied_array_idx).first_component; 1381 result -> numeric_datum(1) = tied_files(tied_array_idx).last_component + 1; 1382 end; 1383 1384 /* Fill in storage used and storage reservation. */ 1385 1386 if ^flim_not_fsize 1387 then do; 1388 call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); 1389 if code ^= 0 1390 then call file_error (code); 1391 1392 area_ptr = get_system_free_area_ (); 1393 1394 allocate index_info in (system_area); 1395 1396 index_info.info_version = 1; 1397 1398 call vfile_status_ (file_dname, file_ename, info_ptr, code); 1399 if code ^= 0 1400 then call file_error (code); 1401 1402 result -> numeric_datum(2) = index_info.record_bytes; 1403 result -> numeric_datum(3) = TheBiggestNumberWeveGot; 1404 1405 free index_info in (system_area); 1406 end; 1407 1408 operators_argument.result = result_vb; 1409 1410 return; /* from flim */ 1411 1412 /* FHOLD locks all of the files specified by the user in the right argument 1413* after unlocking all of the files the user currently has locked. */ 1414 1415 file_operation(79): /* qFHOLD */ 1416 1417 /* Allow as many tie nums as the maximum tieable. */ 1418 1419 call decode_right_arg (0, hbound (tied_files, 1)); 1420 1421 call check_integers (right_vb, code); 1422 if code ^= 0 1423 then call file_error (code); 1424 1425 /* Unlock all currently locked files. */ 1426 1427 do count = lbound (tied_files, 1) to hbound (tied_files, 1); 1428 1429 if tied_files(count).iocb_ptr ^= null () 1430 then call lock_file (count, unlock); 1431 end; 1432 1433 /* Check to see that all specified files are tied, and get 1434* their UID's to determine locking order. */ 1435 1436 do count = 0 to (right_vb -> value_bead.total_data_elements - 1); 1437 1438 tie_num = integerize (right -> numeric_datum (count)); 1439 1440 tied_array_idx = get_tie_index (tie_num, code); 1441 if code ^= 0 1442 then call file_error (code); 1443 1444 call expand_pathname_ (tied_files(tied_array_idx).file_name, file_dname, file_ename, code); 1445 if code ^= 0 1446 then call file_error (code); 1447 1448 call hcs_$status_long (file_dname, file_ename, 1, addr (branch_status), null (), code); 1449 if code ^= 0 1450 then call file_error (code); 1451 1452 file_uids(count + 1) = branch_status.unique_id; 1453 array_idxs(count + 1) = tied_array_idx; 1454 end; 1455 1456 /* Sort the files by unique id. This ensures that every process 1457* using shared files will lock them in the same order, thus 1458* preventing deadlocks. */ 1459 1460 do count = (right_vb -> value_bead.total_data_elements - 1) to 1 by -1; 1461 1462 switched_one = "0"b; 1463 1464 do idx = 1 to count; 1465 1466 /* If the current entry is greater than the next, switch 1467* them, and switch the corresponding array indecies. */ 1468 1469 if file_uids(idx) > file_uids(idx + 1) 1470 then do; 1471 uid = file_uids(idx); 1472 file_uids(idx) = file_uids(idx + 1); 1473 file_uids(idx + 1) = uid; 1474 1475 tied_array_idx = array_idxs(idx); 1476 array_idxs(idx) = array_idxs(idx + 1); 1477 array_idxs(idx + 1) = tied_array_idx; 1478 1479 switched_one = "1"b; /* note that switching was done */ 1480 end; 1481 end; 1482 1483 /* If no entries were exchanged this pass, everything is in 1484* order. */ 1485 1486 if ^switched_one 1487 then goto exit_early; 1488 end; 1489 1490 exit_early: 1491 1492 /* Do the actual file locking. If somebody else has one of the 1493* files locked, we will sleep until we can lock it (see 1494* attachment and opening modes in open_file). All the preceding 1495* UID hair is to ensure that no deadly embraces can occur 1496* (everybody locks them in the same order). */ 1497 1498 do count = 1 to (right_vb -> value_bead.total_data_elements); 1499 1500 call lock_file (array_idxs(count), lock); 1501 end; 1502 1503 operators_argument.result = null(); 1504 return; /* from fhold */ 1505 1506 /* open_file is the routine that does all the real work of attaching and 1507* opening files. */ 1508 1509 open_file: 1510 procedure (share, create_if_not_found); 1511 1512 dcl (share, create_if_not_found) bit(1) aligned parameter; 1513 1514 dcl attach_desc char(256) varying; /* attach description */ 1515 1516 dcl record_quota_overflow condition; 1517 dcl any_other condition; 1518 1519 dcl apl_error_table_$rqo_on_file fixed bin(35) external; 1520 1521 1522 /* Take advantage of the fact that this code MUST be executed 1523* before any other file system functions can run. */ 1524 1525 if first_file_open 1526 then do; 1527 call user_info_$whoami (user_name, user_project, ("")); 1528 group_id = rtrim (user_name) || "." || user_project; 1529 first_file_open = "0"b; 1530 end; 1531 1532 /* See if the specified tie number is already tied to a file, 1533* and if so, complain. */ 1534 1535 tied_array_idx = get_tie_index (tie_num, code); 1536 if code = 0 1537 then call file_error (apl_error_table_$tie_num_in_use); 1538 1539 /* Find a free array slot. */ 1540 1541 tied_array_idx = get_free_index (tie_num, code); 1542 if code ^= 0 1543 then call file_error (code); 1544 1545 /* Build the attach description based on previously gathered information. */ 1546 1547 attach_desc = "vfile_ " || file_pathname; 1548 1549 /* Check to see if file already exists when creating. */ 1550 1551 if create_if_not_found 1552 then do; 1553 call hcs_$status_minf (file_dname, file_ename, 1, (0), (0), code); 1554 if code = 0 /* status_minf found the file */ 1555 then call file_error (apl_error_table_$file_already_exists); 1556 if code ^= error_table_$noentry /* if it was not there, it's OK */ 1557 then call file_error (code); 1558 end; 1559 1560 /* Otherwise, make sure it will not be created. */ 1561 1562 else attach_desc = attach_desc || " -old"; 1563 1564 /* If the file is to be opened in shared mode, set the wait time 1565* for a locked file to -1, forever. This means that any attempt 1566* to operate on a file locked by another APL user will wait until 1567* the other user unlocks the file, then proceed. */ 1568 1569 if share 1570 then attach_desc = attach_desc || " -share -1"; 1571 else attach_desc = attach_desc || " -exclusive"; 1572 1573 /* File information is kept in an internal static array, indexed by 1574* tie number. The "shared" bit is the definitive test for 1575* determining whether or not file header information may be kept 1576* in the static storage or must be written to the file header. */ 1577 1578 tied_files(tied_array_idx).shared = share; 1579 1580 /* set up any_other handler to catch vfile_ complaints when 1581* quota is exhausted. It sometimes gets null pointer faults */ 1582 1583 on any_other 1584 begin; 1585 1586 call iox_$close (iocb_ptr, code); 1587 call iox_$detach_iocb (iocb_ptr, code); 1588 1589 call file_error (apl_error_table_$rqo_on_file); 1590 end; 1591 1592 /* Attach the APL file. */ 1593 1594 call iox_$attach_name (unique_chars_ (""b), iocb_ptr, 1595 (attach_desc), codeptr(apl_file_system_), code); 1596 if code ^= 0 1597 then call file_error (code); 1598 1599 /* All APL value files are indexed files, and are opened in the 1600* same way */ 1601 1602 call iox_$open (iocb_ptr, Keyed_sequential_update, "0"b, code); 1603 1604 if code = error_table_$moderr 1605 then do; 1606 call iox_$detach_iocb (iocb_ptr, code); 1607 1608 /* Since the open failed due to insufficient access, 1609* we are going to try to open for read only. This code 1610* first takes out the attach description information 1611* pertaining to sharable openings, then tries again. */ 1612 1613 if share 1614 then temp_string = "-share -1"; 1615 else temp_string = "-exclusive"; 1616 1617 idx = index (attach_desc, temp_string); /* if idx = 0 we are in trouble */ 1618 attach_desc = substr (attach_desc, 1, idx - 1) || 1619 substr (attach_desc, idx + length (temp_string)); 1620 1621 call iox_$attach_name (unique_chars_ (""b), iocb_ptr, 1622 (attach_desc), codeptr(apl_file_system_), code); 1623 if code ^= 0 1624 then call file_error (code); 1625 1626 call iox_$open (iocb_ptr, Keyed_sequential_input, "0"b, code); 1627 if code ^= 0 1628 then call iox_$detach_iocb (iocb_ptr, code2); 1629 1630 if code = error_table_$moderr 1631 then call file_error (apl_error_table_$no_access_to_file); 1632 1633 /* Remember that this is a read only file. */ 1634 1635 tied_files(tied_array_idx).read_only = "1"b; 1636 end; 1637 else tied_files(tied_array_idx).read_only = "0"b; 1638 1639 if code ^= 0 1640 then call iox_$detach_iocb (iocb_ptr, code2); 1641 1642 if code ^= 0 1643 then call file_error (code); 1644 1645 /* Find the file header record. If it isn't there, assume 1646* this is the first write to this file and continue. */ 1647 1648 call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); 1649 1650 /* If there is no such record, this is a new file. Use write_record 1651* to write header info... */ 1652 1653 if code = error_table_$no_record 1654 then do; 1655 file_header_size = size (file_header) * 4; 1656 file_header.version = file_header_version; 1657 file_header.first_component = 0; 1658 file_header.last_component = 0; 1659 1660 call iox_$write_record (iocb_ptr, addr (file_header), file_header_size, code); 1661 1662 if code ^= 0 1663 then call file_error (code); 1664 1665 if ^share 1666 then do; 1667 tied_files(tied_array_idx).first_component = 0; 1668 tied_files(tied_array_idx).last_component = 0; 1669 end; 1670 end; 1671 1672 /* ...otherwise read the existing header info */ 1673 1674 else do; 1675 if code ^= 0 1676 then call file_error (code); 1677 1678 file_header_size = size (file_header) * 4; 1679 1680 call iox_$read_record (iocb_ptr, addr (file_header), 1681 file_header_size, size_read, code); 1682 if code ^= 0 1683 then call file_error (code); 1684 1685 if file_header.version ^= file_header_version 1686 then call file_error (apl_error_table_$old_file_header); 1687 1688 /* If file is exclusively tied, header info may be kept 1689* in static storage */ 1690 1691 if ^share 1692 then do; 1693 tied_files(tied_array_idx).first_component = 1694 file_header.first_component; 1695 tied_files(tied_array_idx).last_component = 1696 file_header.last_component; 1697 end; 1698 end; 1699 1700 revert any_other; 1701 1702 /* Set up static data array entry for this file. */ 1703 1704 tied_files(tied_array_idx).iocb_ptr = iocb_ptr; 1705 tied_files(tied_array_idx).tie_number = tie_num; 1706 tied_files(tied_array_idx).file_name = file_pathname; 1707 tied_files(tied_array_idx).locked = "0"b; 1708 number_of_files_tied = number_of_files_tied + 1; 1709 1710 return; 1711 end; /* open_file */ 1712 1713 1714 /* untie_all_files is intended to be called by APL to untie all of the 1715* user's files. This is done when he quits APL. */ 1716 1717 untie_all_files: 1718 entry; 1719 1720 dcl found_one bit(1); 1721 1722 found_one = "0"b; 1723 1724 do count = lbound (tied_files, 1) to hbound (tied_files, 1); 1725 1726 if tied_files(count).iocb_ptr ^= null() 1727 then do; 1728 call untie_file (count, code); 1729 found_one = "1"b; 1730 end; 1731 end; 1732 1733 if found_one 1734 then call ioa_$ioa_switch (apl_static_$apl_output, "files untied - some files automatically untied"); 1735 return; 1736 1737 /* untie_file closes and detaches a file given its tied_files array index, 1738* updating the tied file database if necessary. If the specified array 1739* index does not refer to a file, untie_file returns. */ 1740 1741 untie_file: 1742 procedure (tied_array_idx, code); 1743 1744 dcl tied_array_idx fixed bin parameter; 1745 dcl code fixed bin(35) parameter; 1746 1747 dcl iocb_ptr pointer; 1748 1749 code = 0; 1750 1751 if tied_files(tied_array_idx).iocb_ptr = null() 1752 then return; 1753 1754 iocb_ptr = tied_files(tied_array_idx).iocb_ptr; 1755 1756 /* If the file is exclusively tied, update the header 1757* in the file. */ 1758 1759 if (^tied_files(tied_array_idx).shared & 1760 ^tied_files(tied_array_idx).read_only) 1761 then do; 1762 file_header_size = size (file_header) * 4; 1763 file_header.version = file_header_version; 1764 file_header.first_component = 1765 tied_files(tied_array_idx).first_component; 1766 file_header.last_component = 1767 tied_files(tied_array_idx).last_component; 1768 1769 call iox_$seek_key (iocb_ptr, file_header_key, size_read, code); 1770 if code ^= 0 1771 then return; 1772 1773 call iox_$rewrite_record (iocb_ptr, addr (file_header), 1774 file_header_size, code); 1775 if code ^= 0 1776 then return; 1777 1778 end; /* if not shared */ 1779 1780 tied_files(tied_array_idx).iocb_ptr = null(); 1781 number_of_files_tied = number_of_files_tied - 1; 1782 1783 call iox_$close (iocb_ptr, code); 1784 call iox_$detach_iocb (iocb_ptr, code); 1785 1786 end; /* untie_file */ 1787 1788 1789 /* decode_file_id parses a filename of an APL file. It also sets the global 1790* variables "left_vb" (a pointer to the left value bead), "left" (a pointer 1791* to the data in the left vb), "file_dname", "file_ename", and 1792* "file_pathname". */ 1793 1794 decode_file_id: 1795 procedure; 1796 1797 /* automatic */ 1798 1799 dcl file_id char (168); 1800 dcl (libx, strx) fixed bin; 1801 1802 1803 /* program */ 1804 1805 left_vb = operators_argument.operands (1).value; 1806 1807 if ^left_vb -> general_bead.value 1808 then call file_error (apl_error_table_$domain); 1809 1810 if ^left_vb -> value_bead.character_value 1811 then call file_error (apl_error_table_$domain); 1812 1813 if (left_vb -> value_bead.total_data_elements = 0) 1814 then call file_error (apl_error_table_$length); 1815 1816 if (left_vb -> value_bead.rhorho > 1) & (left_vb -> value_bead.total_data_elements ^= 1) 1817 then call file_error (apl_error_table_$rank); 1818 1819 /* data_elements is a global variable used in based dcls 1820* (see declarations of character_datum and 1821* character_string_overlay for a better understanding of 1822* this code). Set here for length computations. */ 1823 1824 data_elements = left_vb -> value_bead.total_data_elements; 1825 1826 left = left_vb -> value_bead.data_pointer; 1827 1828 /* Strip leading spaces. */ 1829 1830 do strx = lbound (left -> character_datum, 1) to hbound (left -> character_datum, 1) 1831 while (left -> character_datum (strx) = " "); 1832 end; 1833 1834 /* If strx is off the end of the array, no non-white characters 1835* were found. Report an error. */ 1836 1837 if strx > hbound (left -> character_datum, 1) 1838 then call file_error (apl_error_table_$bad_file_name); 1839 1840 libx = strx; /* index of first non-blank */ 1841 1842 /* Does file-id include a library number? */ 1843 1844 if index ("0123456789", left -> character_datum (strx)) ^= 0 1845 then do; 1846 do strx = strx + 1 to hbound (left -> character_datum, 1) 1847 while (left -> character_datum (strx) >= "0" & 1848 left -> character_datum (strx) <= "9"); 1849 end; 1850 1851 /* Skip blanks */ 1852 1853 do strx = strx to hbound (left -> character_datum, 1) 1854 while (left -> character_datum (strx) = " "); 1855 end; 1856 1857 /* If strx is off the end of the array, no file name was 1858* found after the library number. */ 1859 1860 if strx > hbound (left -> character_datum, 1) 1861 then call file_error (apl_error_table_$bad_file_name); 1862 end; 1863 1864 /* Scan file name */ 1865 1866 do strx = strx to hbound (left -> character_datum, 1) 1867 while (left -> character_datum (strx) ^= " "); 1868 end; 1869 1870 /* Skip trailing blanks. */ 1871 1872 do idx = strx to hbound (left -> character_datum, 1) 1873 while (left -> character_datum (idx) = " "); 1874 end; 1875 1876 /* If idx is not one greater than the length of the string, 1877* there is cruft after the file name (possibly a "storage 1878* reservation", a number accepted by other APL file systems, 1879* but meaningless in Multics APL. */ 1880 1881 if idx <= hbound (left -> character_datum, 1) 1882 then call file_error (apl_error_table_$bad_file_name); 1883 1884 /* strx is now one greater than the last char in the file name. 1885* Note that the apparent off-by-one error in using libx + 1 1886* instead of libx is due to the fact the the array character_datum 1887* is dimensioned to be 0:data_elements-1 (zero-origin) while the 1888* string character_string_overlay is char (data_elements), 1889* (one-origin). */ 1890 1891 file_id = substr (left -> character_string_overlay, libx + 1, strx - libx); 1892 call apl_translate_pathname_$file_system_pathname (file_id, file_dname, file_ename, null, code); 1893 1894 file_pathname = rtrim (file_dname) || ">" || file_ename; 1895 return; 1896 1897 end; /* decode_file_id */ 1898 1899 /* decode_right_arg checks to make sure the right number of 1900* elements were supplied in the right hand vector. The global 1901* variables "tie_num", "component_number", and "drop_number" 1902* are set to the 1st, 2nd and 2nd elements of the argument vector. 1903* The global variables "right_vb" (a pointer to the right value 1904* bead) and "right" (pointer to the actual data in the right 1905* vb) are also set. */ 1906 1907 decode_right_arg: procedure (min_arg_len, max_arg_len); 1908 1909 /* parameters */ 1910 1911 dcl (min_arg_len, max_arg_len) fixed bin parameter; 1912 1913 /* program */ 1914 1915 right_vb = operators_argument.operands(2).value; 1916 1917 if ^right_vb -> general_bead.value /* must be a value bead */ 1918 then call file_error (apl_error_table_$domain); 1919 1920 if ^right_vb -> value_bead.numeric_value /* must be numeric */ 1921 then call file_error (apl_error_table_$domain); 1922 1923 /* Set global variable used for based objects reference below */ 1924 1925 data_elements = right_vb -> value_bead.total_data_elements; 1926 1927 /* If we have more than 1 dimension, there better be only one 1928* element in the matrix. */ 1929 1930 if (right_vb -> value_bead.rhorho > 1) & (data_elements ^= 1) 1931 then call file_error (apl_error_table_$rank); 1932 1933 /* Check range for length. -1 signifies no limit on values */ 1934 1935 if (data_elements < min_arg_len) | 1936 ((max_arg_len ^= -1) & (data_elements > max_arg_len)) 1937 then call file_error (apl_error_table_$length); 1938 1939 right = right_vb -> value_bead.data_pointer; 1940 1941 /* If we don't have "real" integers, check for fuzz tolerance. */ 1942 1943 if right_vb -> value_bead.integral_value 1944 then do; 1945 tie_num = fixed (right -> numeric_datum (0)); 1946 if data_elements > 1 1947 then do; 1948 component_number = fixed (right -> numeric_datum (1)); 1949 drop_number = fixed (right -> numeric_datum(1)); 1950 end; 1951 end; 1952 else do; 1953 tie_num = integerize (right -> numeric_datum(0)); 1954 if data_elements > 1 1955 then do; 1956 component_number = integerize (right -> numeric_datum(1)); 1957 drop_number = integerize (right -> numeric_datum(1)); 1958 end; 1959 end; 1960 1961 return; 1962 end; /* decode_right_arg */ 1963 1964 /* integerize converts a floating number to a fixed one if it is within 1965* integer fuzz of an integer. If not, an error is reported. */ 1966 1967 integerize: 1968 procedure (number) returns (fixed bin); 1969 1970 dcl number float aligned parameter; 1971 1972 /* Check for tolerance outside of integer fuzz range. */ 1973 1974 if abs (floor (number + 0.5) - number) < ws_info.integer_fuzz 1975 then return (fixed (floor (number + 0.5))); 1976 else call file_error (apl_error_table_$not_within_int_fuzz); 1977 1978 end; /* integerp */ 1979 1980 /* check_integers makes sure that all of the numbers in a numeric value_bead 1981* are within integer fuzz of an integer. If they are not, a status code 1982* is returned. It is the caller's responsibility to act upon the error. */ 1983 1984 check_integers: 1985 procedure (bead_ptr, code); 1986 1987 dcl bead_ptr ptr parameter; 1988 dcl code fixed bin(35); 1989 1990 dcl count fixed bin; 1991 dcl data_ptr ptr; 1992 dcl data_elements fixed bin; 1993 1994 code = 0; 1995 1996 data_ptr = bead_ptr -> value_bead.data_pointer; 1997 data_elements = bead_ptr -> value_bead.total_data_elements; 1998 1999 do count = 0 to hbound (data_ptr -> numeric_datum, 1); 2000 if abs (floor (data_ptr -> numeric_datum(count) + 0.5) - 2001 data_ptr -> numeric_datum(count)) >= integer_fuzz 2002 then do; 2003 code = apl_error_table_$not_within_int_fuzz; 2004 return; 2005 end; 2006 end; 2007 end; /* check_integers */ 2008 2009 /* unlock_all_files unlocks all of the currently locked files. It is 2010* used by APL each time "desk calcualtor" level is reached. */ 2011 2012 unlock_all_files: 2013 entry; 2014 2015 do count = lbound (tied_files, 1) to hbound (tied_files, 1); 2016 2017 if tied_files(count).iocb_ptr ^= null() 2018 then call lock_file (count, unlock); 2019 end; 2020 return; 2021 2022 /* lock_file locks or unlocks a file given its tied_files array index, 2023* updating the static information. */ 2024 2025 lock_file: 2026 procedure (tied_array_idx, mode); 2027 2028 dcl tied_array_idx fixed bin parameter; 2029 dcl mode bit(2) parameter; 2030 2031 if tied_files(tied_array_idx).iocb_ptr = null() 2032 then return; 2033 2034 /* Indicate that some locking action has occurred in this 2035* call to the file system. This allows file_error to win. 2036* First mode bit is "1"b for lock, "0"b for unlock. */ 2037 2038 current_file_locked = substr (mode, 1, 1); 2039 2040 /* If state is already right, punt. */ 2041 2042 if tied_files(tied_array_idx).locked = current_file_locked 2043 then return; 2044 2045 /* Set info to reflect given locking state. */ 2046 2047 tied_files(tied_array_idx).locked = current_file_locked; 2048 2049 lock_info = mode; 2050 2051 call iox_$control (tied_files(tied_array_idx).iocb_ptr, "set_file_lock", addr (lock_info), code); 2052 2053 if (code ^= 0) & (code ^= error_table_$lock_not_locked) & (code ^= error_table_$locked_by_this_process) 2054 then call file_error (code); 2055 2056 return; 2057 end; /* lock_file */ 2058 2059 2060 /* file_error takes care of reporting all errors pertaining to the file system. 2061* Some standard error codes are converted wholesale to file system errors. */ 2062 2063 file_error: 2064 procedure (status_code); 2065 2066 dcl status_code fixed bin(35) parameter; 2067 2068 if status_code = 0 /* nothing to report */ 2069 then return; 2070 2071 operators_argument.error_code = status_code; 2072 2073 /* file_busy means somebody already has the file exclusively tied. */ 2074 2075 if status_code = error_table_$file_busy 2076 then operators_argument.error_code = apl_error_table_$file_already_tied; 2077 2078 /* These codes just get APL flavoring. */ 2079 2080 if status_code = error_table_$noentry 2081 then operators_argument.error_code = apl_error_table_$no_such_file; 2082 2083 if status_code = error_table_$moderr 2084 then operators_argument.error_code = apl_error_table_$no_write_permission; 2085 2086 if status_code = error_table_$no_info 2087 then operators_argument.error_code = apl_error_table_$no_access_to_file; 2088 2089 if status_code = error_table_$no_operation 2090 then operators_argument.error_code = apl_error_table_$no_write_permission; 2091 2092 if current_file_locked 2093 then call lock_file (tied_array_idx, unlock); 2094 2095 goto error_return; 2096 2097 end; /* file_error */ 2098 2099 /* get_tie_index and get_free_index manage the array containing information 2100* about tied files. */ 2101 2102 get_tie_index: 2103 procedure (tie_num, code) returns (fixed bin); 2104 2105 dcl tie_num fixed bin parameter; 2106 dcl code fixed bin(35) parameter; 2107 2108 dcl count fixed bin; 2109 2110 /* get_tie_index finds the array index of an already tied file. 2111* If the given tie number is not tied to a file, an error is 2112* reported. */ 2113 2114 code = 0; 2115 2116 /* Find the array slot holding the info on the specified tie 2117* num. Checking for non-null iocb_ptr is the definitive test 2118* of whether or not a slot contains info about a currently 2119* tied file. Tie numbers between 1 and 20 (inclusive) are 2120* optimized on the grounds that users use them most often. */ 2121 2122 if (tie_num < 21) & (tie_num > 0) 2123 & (tied_files(tie_num).iocb_ptr ^= null()) /* test for tiedness */ 2124 then return (tie_num); 2125 else do count = 21 to hbound (tied_files, 1); 2126 if (tied_files(count).tie_number = tie_num) /* find matching tie num */ 2127 & (tied_files(count).iocb_ptr ^= null()) /* and check for tiedness */ 2128 then return (count); 2129 end; 2130 code = apl_error_table_$bad_tie_num; 2131 return (-1); 2132 2133 end; /* get_tie_index */ 2134 2135 2136 get_free_index: 2137 procedure (tie_num, code) returns (fixed bin); 2138 2139 dcl tie_num fixed bin parameter; 2140 dcl code fixed bin(35) parameter; 2141 2142 dcl count fixed bin; 2143 2144 /* get_free_index finds a free array entry to use for a newly 2145* tied file. */ 2146 2147 code = 0; 2148 2149 /* Find the array slot not currently holding info about a 2150* file. Checking for non-null iocb_ptr is the definitive test 2151* of whether or not a slot is in use. Tie numbers between 1 2152* and 20 (inclusive) are optimized on the grounds that users 2153* use them most often. */ 2154 2155 if (tie_num < 21) & (tie_num > 0) 2156 then if tied_files(tie_num).iocb_ptr = null() 2157 then return (tie_num); 2158 else do; 2159 code = apl_error_table_$tie_num_in_use; 2160 return (-1); 2161 end; 2162 else do count = 21 to hbound (tied_files, 1); 2163 if tied_files(count).iocb_ptr = null() 2164 then return (count); 2165 end; 2166 code = apl_error_table_$too_many_files; 2167 return (-1); 2168 2169 end; /* get_free_index */ 2170 2171 2172 /* compute_length calculates the size of an APL value bead. */ 2173 2174 compute_length: 2175 procedure (value_bead_ptr) returns (fixed bin (21)); 2176 2177 /* parameter */ 2178 2179 declare value_bead_ptr ptr parameter; 2180 2181 /* automatic */ 2182 2183 declare data_size fixed bin (19), 2184 temp_vb ptr; 2185 2186 /* program */ 2187 2188 temp_vb = value_bead_ptr; 2189 2190 /* set global information used to compute length */ 2191 2192 data_elements = temp_vb -> value_bead.total_data_elements; 2193 2194 if temp_vb -> value_bead.numeric_value 2195 then data_size = size (numeric_datum) + 1; 2196 else data_size = size (character_string_overlay); 2197 2198 return (4 * (currentsize (temp_vb -> value_bead) + data_size)); 2199 2200 end /* compute_length */; 2201 2202 2203 /* apl_push_stack_ is a utility program to allocate space on the APL stack. */ 2204 10 1 /* ====== BEGIN INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 =============================== */ 10 2 10 3 /* format: style3 */ 10 4 apl_push_stack_: 10 5 procedure (P_n_words) returns (ptr); 10 6 10 7 /* Function to (1) double-word align ws_info.value_stack_ptr, and 10 8* (2) make sure allocation request will fit on current value stack. 10 9* 10 10* Written 770413 by PG 10 11* Modified 780210 by PG to round allocations up to an even number of words. 10 12**/ 10 13 10 14 /* parameters */ 10 15 10 16 declare P_n_words fixed bin (19) parameter; 10 17 10 18 /* automatic */ 10 19 10 20 declare block_ptr ptr, 10 21 num_words fixed bin (19); 10 22 10 23 /* builtins */ 10 24 10 25 declare (addrel, binary, rel, substr, unspec) 10 26 builtin; 10 27 10 28 /* entries */ 10 29 10 30 declare apl_get_value_stack_ 10 31 entry (fixed bin (19)); 10 32 10 33 /* program */ 10 34 10 35 num_words = P_n_words; 10 36 10 37 if substr (unspec (num_words), 36, 1) = "1"b /* num_words odd */ 10 38 then num_words = num_words + 1; 10 39 10 40 if binary (rel (ws_info.value_stack_ptr), 18) + num_words > ws_info.maximum_value_stack_size 10 41 then call apl_get_value_stack_ (num_words); 10 42 10 43 block_ptr = ws_info.value_stack_ptr; 10 44 ws_info.value_stack_ptr = addrel (ws_info.value_stack_ptr, num_words); 10 45 return (block_ptr); 10 46 10 47 end apl_push_stack_; 10 48 10 49 /* ------ END INCLUDE SEGMENT apl_push_stack_fcn.incl.pl1 ------------------------------- */ 2205 2206 2207 end; /* apl_file_system */ SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/29/83 1346.4 apl_file_system_.pl1 >special_ldd>on>apl.1129>apl_file_system_.pl1 222 1 07/19/79 1547.0 vfs_info.incl.pl1 >ldd>include>vfs_info.incl.pl1 223 2 11/22/82 0955.6 branch_status.incl.pl1 >ldd>include>branch_status.incl.pl1 224 3 06/10/82 1045.5 star_structures.incl.pl1 >ldd>include>star_structures.incl.pl1 225 4 02/02/78 1229.7 iox_modes.incl.pl1 >ldd>include>iox_modes.incl.pl1 226 5 03/27/82 0429.8 apl_number_data.incl.pl1 >ldd>include>apl_number_data.incl.pl1 227 6 03/27/82 0439.2 apl_ws_info.incl.pl1 >ldd>include>apl_ws_info.incl.pl1 228 7 03/27/82 0438.5 apl_bead_format.incl.pl1 >ldd>include>apl_bead_format.incl.pl1 229 8 03/27/82 0439.2 apl_value_bead.incl.pl1 >ldd>include>apl_value_bead.incl.pl1 230 9 03/27/82 0439.0 apl_operators_argument.incl.pl1 >ldd>include>apl_operators_argument.incl.pl1 2205 10 03/27/82 0429.8 apl_push_stack_fcn.incl.pl1 >ldd>include>apl_push_stack_fcn.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. Keyed_sequential_input 000114 constant fixed bin(17,0) initial dcl 4-15 set ref 1626* Keyed_sequential_update 000072 constant fixed bin(17,0) initial dcl 4-15 set ref 1602* P_n_words parameter fixed bin(19,0) dcl 10-16 ref 10-4 10-35 TheBiggestNumberWeveGot 000062 constant float bin(63) initial dcl 5-16 ref 1403 abs builtin function dcl 179 ref 1974 2000 access_name based char(32) array level 2 in structure "segment_acl" dcl 82 in procedure "apl_file_system_" set ref 1062 1174* access_name based char(32) array level 2 in structure "delete_acl" dcl 88 in procedure "apl_file_system_" set ref 1278* acl_count 000414 automatic fixed bin(17,0) dcl 74 set ref 1033* 1041 1051 1060 1080 1144* 1146* 1148 1155 1202* 1204* 1212 1265* 1267* 1269 1273 1294* 1300 acl_ptr 000412 automatic pointer dcl 73 set ref 1033* 1062 1064 1068 1072 1080 1148* 1174 1186 1187 1188 1202* 1204* 1212 1269* 1278 1294* 1300 addr builtin function dcl 179 ref 351 351 357 357 440 440 483 483 485 485 504 504 593 593 633 633 693 693 765 815 815 1372 1372 1448 1448 1660 1660 1680 1680 1773 1773 2051 2051 addrel builtin function dcl 179 in procedure "apl_file_system_" ref 765 770 837 841 877 881 925 987 1056 1353 1357 addrel builtin function dcl 10-25 in procedure "apl_push_stack_" ref 10-44 any_other 000202 stack reference condition dcl 1517 ref 1583 1700 apl_error_table_$bad_access_matrix 011502 external static fixed bin(35,0) dcl 198 ref 1159 apl_error_table_$bad_access_modes 011504 external static fixed bin(35,0) dcl 198 ref 1182 apl_error_table_$bad_apl_file 011476 external static fixed bin(35,0) dcl 198 set ref 454* apl_error_table_$bad_component_num 011472 external static fixed bin(35,0) dcl 198 set ref 539* 556* 732* 745* 796* 809* apl_error_table_$bad_file_name 011466 external static fixed bin(35,0) dcl 198 set ref 1837* 1860* 1881* apl_error_table_$bad_fname_match 011470 external static fixed bin(35,0) dcl 198 set ref 361* apl_error_table_$bad_tie_num 011464 external static fixed bin(35,0) dcl 198 set ref 312 318* 2130 apl_error_table_$domain 011440 external static fixed bin(35,0) dcl 198 set ref 1113* 1116* 1234* 1237* 1807* 1810* 1917* 1920* apl_error_table_$file_already_exists 011452 external static fixed bin(35,0) dcl 198 set ref 1554* apl_error_table_$file_already_tied 011450 external static fixed bin(35,0) dcl 198 ref 2075 apl_error_table_$length 011446 external static fixed bin(35,0) dcl 198 set ref 1128* 1135* 1249* 1256* 1813* 1935* apl_error_table_$no_access_to_file 011456 external static fixed bin(35,0) dcl 198 set ref 1630* 2086 apl_error_table_$no_such_file 011462 external static fixed bin(35,0) dcl 198 ref 2080 apl_error_table_$no_write_permission 011454 external static fixed bin(35,0) dcl 198 ref 2083 2089 apl_error_table_$not_enough_components 011474 external static fixed bin(35,0) dcl 198 set ref 648* apl_error_table_$not_within_int_fuzz 011442 external static fixed bin(35,0) dcl 198 set ref 1976* 2003 apl_error_table_$old_file_header 011500 external static fixed bin(35,0) dcl 198 set ref 1685* apl_error_table_$rank 011444 external static fixed bin(35,0) dcl 198 set ref 1122* 1243* 1816* 1930* apl_error_table_$rqo_on_file 011512 external static fixed bin(35,0) dcl 1519 set ref 1589* apl_error_table_$tie_num_in_use 011460 external static fixed bin(35,0) dcl 198 set ref 1536* 2159 apl_error_table_$too_many_files 011506 external static fixed bin(35,0) dcl 198 set ref 275* 2166 apl_file_system_static 000010 internal static structure level 1 unaligned dcl 123 apl_get_value_stack_ 011514 constant entry external dcl 10-30 ref 10-40 apl_static_$apl_output 011322 external static pointer dcl 140 set ref 1733* apl_static_$ws_info_ptr 011510 external static structure level 1 dcl 6-11 apl_translate_pathname_$file_system_pathname 011352 constant entry external dcl 155 ref 957 1892 area_ptr 000410 automatic pointer dcl 71 set ref 963* 965* 998 1000 1021* 1033* 1080 1142* 1148 1212 1263* 1269 1300 1392* 1394 1405 array_idxs 000567 automatic fixed bin(17,0) array dcl 98 set ref 1453* 1475 1476* 1476 1477* 1500* attach_desc 000100 automatic varying char(256) dcl 1514 set ref 1547* 1562* 1562 1569* 1569 1571* 1571 1594 1617 1618* 1618 1618 1621 bead_ptr parameter pointer dcl 1987 ref 1984 1996 1997 bead_size 000117 automatic fixed bin(21,0) dcl 39 set ref 457* 459* 464* 475 563* 565* 572* 583 750* 754 824* 828 866* 868 913* 915 975* 977 1044* 1046 1342* 1344 bead_type based structure level 3 packed unaligned dcl 7-3 binary builtin function dcl 10-25 in procedure "apl_push_stack_" ref 10-40 binary builtin function dcl 179 in procedure "apl_file_system_" ref 459 565 block_ptr 001270 automatic pointer dcl 10-20 set ref 10-43* 10-45 branch_status 001057 automatic structure level 1 dcl 2-1 set ref 351 351 357 357 1448 1448 character_data_structure based structure level 1 dcl 8-15 ref 913 975 1044 character_datum based char(1) array level 2 packed unaligned dcl 8-15 ref 1830 1830 1830 1837 1844 1846 1846 1846 1853 1853 1860 1866 1866 1872 1872 1881 character_string_overlay based char dcl 8-19 set ref 935* 952 993* 1062* 1076* 1157 1174 1174 1178 1278 1278 1891 2196 character_value 0(09) based bit(1) level 5 packed unaligned dcl 8-3 set ref 1116 1237 1810 character_value_type constant bit(18) initial unaligned dcl 7-30 ref 917 979 1048 clock builtin function dcl 179 ref 474 582 code 000420 automatic fixed bin(35,0) dcl 78 in procedure "apl_file_system_" set ref 295* 296 296* 304* 306 306* 312 314* 333* 334 334* 340* 341 341* 344* 345 345* 351* 352 352* 357* 358 358* 364* 366* 367 367* 381* 382 382* 388* 389 389* 392* 393 393* 401* 402 402* 419* 420 420* 431* 432 432* 440* 441 441* 450* 454 464* 465 465* 481* 483 483* 485* 487 487* 500* 501 501* 504* 505 505* 533* 534 534* 555* 556 558 558* 572* 573 573* 589* 590 590* 593* 594 594* 614* 615 615* 625* 626 626* 633* 634 634* 689* 690 690* 693* 694 694* 706* 707 707* 710* 711 711* 726* 727 727* 744* 745 747 747* 758* 759 759* 790* 791 791* 808* 809 811 811* 815* 816 816* 957* 958 958* 965* 967 969 971* 1013* 1014 1014* 1025* 1026 1026* 1029* 1030 1030* 1033* 1034 1034* 1103* 1104 1104* 1154* 1159* 1182* 1194* 1195 1195* 1198* 1199 1199* 1202* 1204* 1208 1208* 1224* 1225 1225* 1286* 1287 1287* 1290* 1291 1291* 1294* 1295 1295* 1325* 1326 1326* 1366* 1367 1367* 1372* 1373 1373* 1388* 1389 1389* 1398* 1399 1399* 1421* 1422 1422* 1440* 1441 1441* 1444* 1445 1445* 1448* 1449 1449* 1535* 1536 1541* 1542 1542* 1553* 1554 1556 1556* 1586* 1587* 1594* 1596 1596* 1602* 1604 1606* 1621* 1623 1623* 1626* 1627 1630 1639 1642 1642* 1648* 1653 1660* 1662 1662* 1675 1675* 1680* 1682 1682* 1728* 1892* 2051* 2053 2053 2053 2053* code parameter fixed bin(35,0) dcl 2140 in procedure "get_free_index" set ref 2136 2147* 2159* 2166* code parameter fixed bin(35,0) dcl 1988 in procedure "check_integers" set ref 1984 1994* 2003* code parameter fixed bin(35,0) dcl 2106 in procedure "get_tie_index" set ref 2102 2114* 2130* code parameter fixed bin(35,0) dcl 1745 in procedure "untie_file" set ref 1741 1749* 1769* 1770 1773* 1775 1783* 1784* code2 000421 automatic fixed bin(35,0) dcl 78 set ref 1627* 1639* codeptr builtin function dcl 179 ref 1594 1594 1621 1621 component_header 001042 automatic structure level 1 unaligned dcl 113 set ref 477 483 483 485 485 585 593 593 814 815 815 component_header_size 001056 automatic fixed bin(21,0) dcl 119 set ref 477* 483* 485* 585* 593* 814* 815* component_key 000133 automatic picture(11) unaligned dcl 48 set ref 448* 450 481 550* 555 589 704* 706 739* 744 803* 808 component_number 000132 automatic fixed bin(17,0) dcl 47 set ref 444* 446* 448 496 497 514 515 539 539 550 702* 704* 732 732 739 796 796 803 1948* 1956* count 000216 automatic fixed bin(17,0) dcl 2142 in procedure "get_free_index" set ref 2162* 2163 2163* count 000370 automatic fixed bin(17,0) dcl 60 in procedure "apl_file_system_" set ref 300* 302* 889* 890 892* 932* 933 935* 991* 993 993* 1060* 1062 1062 1064 1068 1072 1076* 1155* 1174 1174 1174 1178 1186 1187 1188* 1273* 1278 1278 1278* 1427* 1429 1429* 1436* 1438 1452 1453* 1460* 1464* 1490* 1500* 1724* 1726 1728* 2015* 2017 2017* count 001242 automatic fixed bin(17,0) dcl 1990 in procedure "check_integers" set ref 1999* 2000 2000* count 000100 automatic fixed bin(17,0) dcl 2108 in procedure "get_tie_index" set ref 2125* 2126 2126 2126* create_if_not_found 000101 automatic bit(1) dcl 30 in procedure "apl_file_system_" set ref 256* 261* 266* 278* create_if_not_found parameter bit(1) dcl 1512 in procedure "open_file" ref 1509 1551 current_file_locked 000407 automatic bit(1) initial unaligned dcl 68 set ref 68* 2038* 2042 2047 2092 currentsize builtin function dcl 179 ref 2198 cv_userid_ 011364 constant entry external dcl 160 ref 1174 1278 data_elements 000131 automatic fixed bin(17,0) dcl 46 in procedure "apl_file_system_" set ref 822* 824 833 835 856* 866 871 873 903* 913 918 935 950* 952 967* 969* 975 980 993 1041* 1044 1049 1062 1076 1150* 1157 1174 1174 1178 1278 1278 1334* 1338* 1342 1347 1349 1824* 1830 1837 1846 1853 1860 1866 1872 1881 1891 1925* 1930 1935 1935 1946 1954 2192* 2194 2196 2196 data_elements 001246 automatic fixed bin(17,0) dcl 1992 in procedure "check_integers" set ref 1997* 1999 data_pointer 4 based pointer level 2 packed unaligned dcl 8-3 set ref 776* 844* 884* 927* 952 989* 1058* 1138 1259 1360* 1826 1939 1996 data_ptr 000122 automatic pointer dcl 41 in procedure "apl_file_system_" set ref 765* 770 770* 770 776 data_ptr 001244 automatic pointer dcl 1991 in procedure "check_integers" set ref 1996* 1999 2000 2000 data_size 001256 automatic fixed bin(19,0) dcl 2183 set ref 2194* 2196* 2198 data_type 0(08) based structure level 4 packed unaligned dcl 8-3 delete_$path 011356 constant entry external dcl 157 ref 366 delete_acl based structure array level 1 dcl 88 set ref 1269 1300 dimension builtin function dcl 179 ref 275 divide builtin function dcl 179 ref 750 drop_number 000140 automatic fixed bin(17,0) dcl 51 set ref 648 656 658 664 1949* 1957* end_component 000137 automatic fixed bin(17,0) dcl 50 set ref 638* 642* 648 658* 660 663 664* 666 702 error_code 7 parameter fixed bin(35,0) level 2 dcl 9-3 set ref 2071* 2075* 2080* 2083* 2086* 2089* error_table_$file_busy 011422 external static fixed bin(35,0) dcl 187 ref 2075 error_table_$lock_not_locked 011424 external static fixed bin(35,0) dcl 187 ref 2053 error_table_$locked_by_this_process 011426 external static fixed bin(35,0) dcl 187 ref 2053 error_table_$moderr 011430 external static fixed bin(35,0) dcl 187 ref 1604 1630 2083 error_table_$no_info 011432 external static fixed bin(35,0) dcl 187 ref 2086 error_table_$no_operation 011434 external static fixed bin(35,0) dcl 187 ref 2089 error_table_$no_record 011436 external static fixed bin(35,0) dcl 187 ref 454 483 556 745 809 1653 error_table_$noentry 011416 external static fixed bin(35,0) dcl 187 ref 1556 2080 error_table_$nomatch 011420 external static fixed bin(35,0) dcl 187 ref 969 expand_pathname_ 011354 constant entry external dcl 156 ref 340 344 388 392 1025 1194 1286 1388 1444 fcb_ptr 000416 automatic pointer dcl 76 set ref 1029* 1033* 1037* 1198* 1202* 1204* 1206* 1290* 1294* 1298* file_dname 000213 automatic char(168) unaligned dcl 54 set ref 344* 357* 366* 388* 401* 957* 965* 1025* 1029* 1194* 1198* 1286* 1290* 1388* 1398* 1444* 1448* 1553* 1892* 1894 file_ename 000337 automatic char(32) unaligned dcl 55 set ref 344* 357* 366* 388* 399 401* 401* 961* 965* 1025* 1029* 1194* 1198* 1286* 1290* 1388* 1398* 1444* 1448* 1553* 1892* 1894 file_header 000733 automatic structure level 1 unaligned dcl 102 set ref 429 440 440 494 504 504 629 633 633 693 693 1370 1372 1372 1655 1660 1660 1678 1680 1680 1762 1773 1773 file_header_key 000740 automatic varying char(256) initial dcl 109 set ref 109* 431* 500* 625* 689* 1366* 1648* 1769* file_header_size 000737 automatic fixed bin(21,0) dcl 108 set ref 429* 440* 494* 504* 629* 633* 693* 1370* 1372* 1655* 1660* 1678* 1680* 1762* 1773* file_header_version 000736 automatic fixed bin(17,0) initial dcl 107 set ref 107* 495 1656 1685 1763 file_id 001136 automatic char(168) unaligned dcl 1799 set ref 1891* 1892* file_name 15 000010 internal static char(168) array level 3 packed unaligned dcl 123 set ref 344* 388* 405* 935 1025* 1194* 1286* 1388* 1444* 1706* file_pathname 000141 automatic char(168) unaligned dcl 53 set ref 340* 392* 405 952* 957* 1547 1706 1894* file_uids 000423 automatic bit(36) array unaligned dcl 97 set ref 1452* 1469 1469 1471 1472* 1472 1473* first_component 70 000010 internal static fixed bin(17,0) array level 3 in structure "apl_file_system_static" dcl 123 in procedure "apl_file_system_" set ref 515 515* 539 641 660* 674 676* 686 732 796 1380 1667* 1693* 1764 first_component 1 000733 automatic fixed bin(17,0) level 2 in structure "file_header" dcl 102 in procedure "apl_file_system_" set ref 497 497* 637 686* 1376 1657* 1693 1764* first_file_open 1 000010 internal static bit(1) initial level 2 dcl 123 set ref 1525 1529* fixed builtin function dcl 179 ref 1945 1948 1949 1974 flim_not_fsize 000103 automatic bit(1) dcl 32 set ref 1308* 1316* 1333 1386 floor builtin function dcl 179 ref 1974 1974 2000 found_one 001101 automatic bit(1) unaligned dcl 1720 set ref 1722* 1729* 1733 fsetacl_not_faddacl 000104 automatic bit(1) dcl 33 set ref 1087* 1094* 1202 general_bead based structure level 1 dcl 7-3 get_system_free_area_ 011366 constant entry external dcl 161 ref 963 1021 1142 1263 1392 group_id 2 000010 internal static char(32) level 2 packed unaligned dcl 123 set ref 472 580 1528* hbound builtin function dcl 179 ref 889 932 1415 1415 1427 1724 1830 1837 1846 1853 1860 1866 1872 1881 1999 2015 2125 2162 hcs_$chname_file 011334 constant entry external dcl 148 ref 401 hcs_$star_ 011326 constant entry external dcl 145 ref 965 hcs_$status_long 011332 constant entry external dcl 147 ref 351 357 1448 hcs_$status_minf 011330 constant entry external dcl 146 ref 1553 header based structure level 2 dcl 8-3 idx 000371 automatic fixed bin(17,0) dcl 60 set ref 888* 892 893* 893 931* 935 937* 937 1464* 1469 1469 1471 1472 1472 1473 1475 1476 1476 1477* 1617* 1618 1618 1872* 1872* 1881 increment 000372 automatic fixed bin(17,0) dcl 61 set ref 659* 665* 702 index builtin function dcl 179 ref 1186 1187 1188 1617 1844 index_info based structure level 1 unaligned dcl 80 set ref 1394 1405 indx_info based structure level 1 unaligned dcl 1-33 info_ptr 000402 automatic pointer dcl 63 set ref 1394* 1396 1398* 1402 1405 info_version based fixed bin(17,0) level 2 dcl 80 set ref 1396* integer_fuzz 22 based float bin(63) level 2 dcl 6-16 ref 1974 2000 integral_value 0(11) based bit(1) level 5 packed unaligned dcl 8-3 set ref 1943 integral_value_type constant bit(18) initial unaligned dcl 7-30 ref 832 870 1346 ioa_$ioa_switch 011370 constant entry external dcl 162 ref 1733 iocb_ptr 12 000010 internal static pointer initial array level 3 in structure "apl_file_system_static" dcl 123 in procedure "apl_file_system_" set ref 423 548 618 737 801 890 933 1017 1329 1429 1704* 1726 1751 1754 1780* 2017 2031 2051* 2122 2126 2155 2163 iocb_ptr 001126 automatic pointer dcl 1747 in procedure "untie_file" set ref 1754* 1769* 1773* 1783* 1784* iocb_ptr 000126 automatic pointer dcl 44 in procedure "apl_file_system_" set ref 423* 431* 440* 450* 464* 481* 483* 485* 500* 504* 548* 555* 572* 589* 593* 618* 625* 633* 689* 693* 706* 710* 737* 744* 758* 801* 808* 815* 1017* 1329* 1366* 1372* 1586* 1587* 1594* 1602* 1606* 1621* 1626* 1627* 1639* 1648* 1660* 1680* 1704 iox_$attach_name 011372 constant entry external dcl 166 ref 1594 1621 iox_$close 011376 constant entry external dcl 168 ref 1586 1783 iox_$control 011414 constant entry external dcl 175 ref 2051 iox_$delete_record 011412 constant entry external dcl 174 ref 710 iox_$detach_iocb 011400 constant entry external dcl 169 ref 1587 1606 1627 1639 1784 iox_$open 011374 constant entry external dcl 167 ref 1602 1626 iox_$read_record 011404 constant entry external dcl 171 ref 440 633 758 815 1372 1680 iox_$rewrite_record 011410 constant entry external dcl 173 ref 485 504 572 593 693 1773 iox_$seek_key 011402 constant entry external dcl 170 ref 431 450 481 500 555 589 625 689 706 744 808 1366 1648 1769 iox_$write_record 011406 constant entry external dcl 172 ref 464 483 1660 last_component 71 000010 internal static fixed bin(17,0) array level 3 in structure "apl_file_system_static" dcl 123 in procedure "apl_file_system_" set ref 446 514* 539 642 666* 674 677* 687 732 796 1381 1668* 1695* 1766 last_component 2 000733 automatic fixed bin(17,0) level 2 in structure "file_header" dcl 102 in procedure "apl_file_system_" set ref 444 496* 638 687* 1377 1658* 1695 1766* lbound builtin function dcl 179 ref 889 932 1427 1724 1830 2015 left 000112 automatic pointer dcl 37 set ref 1138* 1157 1174 1174 1178 1259* 1278 1278 1826* 1830 1830 1830 1837 1844 1846 1846 1846 1853 1853 1860 1866 1866 1872 1872 1881 1891 left_vb 000106 automatic pointer dcl 36 set ref 417* 457* 459 464* 546* 563* 565 572* 1109* 1113 1116 1122 1122 1128 1128 1128 1135 1138 1144 1146 1150 1174 1174 1174 1174 1230* 1234 1237 1243 1243 1249 1249 1249 1256 1259 1265 1267 1278 1278 1278 1278 1805* 1807 1810 1813 1816 1816 1824 1826 length builtin function dcl 179 ref 1618 libx 001210 automatic fixed bin(17,0) dcl 1800 set ref 1840* 1891 1891 lock 000405 automatic bit(2) initial unaligned dcl 66 set ref 66* 438* 569* 631* 1500* lock_info 000404 automatic bit(2) dcl 65 set ref 2049* 2051 2051 locked 67(01) 000010 internal static bit(1) array level 3 packed unaligned dcl 123 set ref 1707* 2042 2047* ltrim builtin function dcl 179 ref 1174 1174 max_arg_len parameter fixed bin(17,0) dcl 1911 ref 1907 1935 1935 maximum_value_stack_size 13 based fixed bin(18,0) level 3 dcl 6-16 ref 10-40 min_arg_len parameter fixed bin(17,0) dcl 1911 ref 1907 1935 mode parameter bit(2) unaligned dcl 2029 ref 2025 2038 2049 mode_string 000415 automatic char(4) unaligned dcl 75 set ref 1064* 1066* 1068* 1070* 1072* 1074* 1076 1178* 1180 1186 1187 1188 modes 10 based bit(36) array level 2 dcl 82 set ref 1064 1068 1072 1186* 1187* 1188* msf_manager_$acl_add 011344 constant entry external dcl 152 ref 1204 msf_manager_$acl_delete 011346 constant entry external dcl 153 ref 1294 msf_manager_$acl_list 011340 constant entry external dcl 150 ref 1033 msf_manager_$acl_replace 011342 constant entry external dcl 151 ref 1202 msf_manager_$close 011350 constant entry external dcl 154 ref 1037 1206 1298 msf_manager_$open 011336 constant entry external dcl 149 ref 1029 1198 1290 new_dname 000265 automatic char(168) unaligned dcl 54 set ref 340* 351* 392* new_ename 000347 automatic char(32) unaligned dcl 55 set ref 340* 351* 392* 399 401* nindex 0(18) based fixed bin(18,0) array level 2 packed unsigned unaligned dcl 3-27 ref 993 nnames 0(02) based fixed bin(16,0) array level 2 packed unsigned unaligned dcl 3-27 ref 998 null builtin function dcl 179 ref 280 321 351 351 357 357 370 408 519 603 715 890 933 957 957 998 1000 1033 1033 1214 1302 1429 1448 1448 1503 1726 1751 1780 1892 1892 2017 2031 2122 2126 2155 2163 num_words 001272 automatic fixed bin(19,0) dcl 10-20 set ref 10-35* 10-37 10-37* 10-37 10-40 10-40* 10-44 number parameter float bin(63) dcl 1970 ref 1967 1974 1974 1974 number_of_dimensions 001100 automatic fixed bin(17,0) dcl 8-3 set ref 823* 824 834 837 864* 866 872 877 911* 913 919 925 973* 975 981 987 1042* 1044 1050 1056 1335* 1339* 1342 1348 1353 number_of_files_tied 000010 internal static fixed bin(17,0) initial level 2 dcl 123 set ref 275 856 903 920 1708* 1708 1781* 1781 numeric_datum based float bin(63) array dcl 8-23 set ref 302* 824 846* 847* 848* 866 892* 1342 1376* 1377* 1380* 1381* 1402* 1403* 1438* 1945 1948 1949 1953* 1956* 1957* 1999 2000 2000 2194 numeric_value 0(10) based bit(1) level 5 packed unaligned dcl 8-3 set ref 770 1920 2194 on_stack 1 parameter bit(1) array level 3 dcl 9-3 ref 238 240 457 563 op1 5(27) parameter fixed bin(8,0) level 3 packed unaligned dcl 9-3 ref 243 248 operands parameter structure array level 2 dcl 9-3 operator 4 parameter structure level 2 dcl 9-3 operators_argument parameter structure level 1 dcl 9-3 set ref 10 245 pointers 14 based structure level 2 dcl 6-16 read_only 67(02) 000010 internal static bit(1) array level 3 packed unaligned dcl 123 set ref 1635* 1637* 1759 record_bytes 7 based fixed bin(34,0) level 2 dcl 80 ref 1402 rel builtin function dcl 10-25 in procedure "apl_push_stack_" ref 10-40 rel builtin function dcl 179 in procedure "apl_file_system_" ref 770 841 881 1357 result 6 parameter pointer level 2 packed unaligned dcl 9-3 set ref 280* 321* 370* 408* 519* 603* 715* 780* 837* 841 841* 841 844 846 847 848 850* 877* 881 881* 881 884 892 897* 925* 927 935 941* 987* 989 993 1003* 1056* 1058 1062 1076 1082* 1214* 1302* 1353* 1357 1357* 1357 1360 1376 1377 1380 1381 1402 1403 1408* 1503* result_vb 000116 automatic pointer unaligned dcl 38 set ref 754* 758 765 765 770 776 780 828* 832 833 834 835 837 844 850 868* 870 871 872 873 877 884 897 915* 917 918 919 920 921 925 927 941 977* 979 980 981 982 983 987 989 1003 1046* 1048 1049 1050 1051 1052 1056 1058 1082 1344* 1346 1347 1348 1349 1353 1360 1408 rho 5 based fixed bin(21,0) array level 2 dcl 8-3 set ref 765 835* 873* 920* 921* 982* 983* 1051* 1052* 1128 1146 1174 1174 1249 1267 1278 1278 1349* rhorho 3 based fixed bin(17,0) level 2 dcl 8-3 set ref 765 834* 872* 919* 981* 1050* 1122 1122 1128 1128 1144 1174 1174 1243 1243 1249 1249 1265 1278 1278 1348* 1816 1930 2198 right 000114 automatic pointer dcl 37 set ref 302 1438 1939* 1945 1948 1949 1953 1956 1957 right_vb 000110 automatic pointer dcl 36 set ref 295* 300 946* 950 952 1421* 1436 1460 1490 1915* 1917 1920 1925 1930 1939 1943 rtrim builtin function dcl 179 ref 1528 1894 segment_acl based structure array level 1 dcl 82 set ref 1080 1148 1212 share parameter bit(1) dcl 1512 in procedure "open_file" ref 1509 1569 1578 1613 1665 1691 share 000100 automatic bit(1) dcl 29 in procedure "apl_file_system_" set ref 253* 259* 264* 278* shared 67 000010 internal static bit(1) array level 3 packed unaligned dcl 123 set ref 427 492 539 569 600 623 684 732 796 1364 1578* 1759 size 0(18) based bit(18) level 3 in structure "value_bead" packed unaligned dcl 8-3 in procedure "apl_file_system_" ref 459 565 size 001042 automatic fixed bin(17,0) level 2 in structure "component_header" dcl 113 in procedure "apl_file_system_" set ref 475* 583* 846 size builtin function dcl 179 in procedure "apl_file_system_" ref 429 477 494 585 629 814 824 824 837 866 866 877 913 913 925 975 975 987 1044 1044 1056 1342 1342 1353 1370 1655 1678 1762 2194 2196 size_read 000120 automatic fixed bin(21,0) dcl 40 set ref 431* 440* 450* 481* 500* 555* 589* 625* 633* 689* 706* 744* 750 758* 758* 808* 815* 1366* 1372* 1648* 1680* 1769* star_entries based structure array level 1 dcl 3-27 ref 1000 star_entry_count 001071 automatic fixed bin(17,0) dcl 3-14 set ref 965* 967 982 991 998 1000 star_entry_ptr 001072 automatic pointer dcl 3-15 set ref 965* 993 998 1000 1000 star_names based char(32) array unaligned dcl 3-37 ref 993 998 star_names_ptr 001074 automatic pointer dcl 3-19 set ref 965* 993 998 998 start_component 000136 automatic fixed bin(17,0) dcl 49 set ref 637* 641* 648 658 663* 664 702 static_ws_info_ptr 011510 external static pointer level 2 packed unaligned dcl 6-11 ref 6-7 status_code parameter fixed bin(35,0) dcl 2066 ref 2063 2068 2071 2075 2080 2083 2086 2089 string builtin function dcl 179 set ref 832* 870* 917* 979* 1048* 1346* strx 001211 automatic fixed bin(17,0) dcl 1800 set ref 1830* 1830* 1837 1840 1844 1846* 1846 1846 1846* 1853* 1853 1853* 1860 1866* 1866 1866* 1872 1891 substr builtin function dcl 179 in procedure "apl_file_system_" set ref 770 841 881 935* 993* 1062* 1064 1064* 1066* 1068 1068* 1070* 1072 1072* 1074* 1076* 1157 1174 1174 1178 1186* 1187* 1188* 1278 1278 1357 1618 1618 1891 2038 substr builtin function dcl 10-25 in procedure "apl_push_stack_" ref 10-37 sum builtin function dcl 179 ref 998 switched_one 000105 automatic bit(1) dcl 34 set ref 1462* 1479* 1486 system_area based area(261120) dcl 70 ref 998 1000 1080 1148 1212 1269 1300 1394 1405 temp_string 000373 automatic varying char(20) dcl 62 set ref 1613* 1615* 1617 1618 temp_vb 001260 automatic pointer dcl 2183 set ref 2188* 2192 2194 2198 tie_num 000124 automatic fixed bin(17,0) dcl 43 in procedure "apl_file_system_" set ref 302* 304* 333* 381* 419* 533* 614* 726* 790* 1013* 1103* 1224* 1325* 1438* 1440* 1535* 1541* 1705 1945* 1953* tie_num parameter fixed bin(17,0) dcl 2139 in procedure "get_free_index" ref 2136 2155 2155 2155 2155 tie_num parameter fixed bin(17,0) dcl 2105 in procedure "get_tie_index" ref 2102 2122 2122 2122 2122 2126 tie_number 14 000010 internal static fixed bin(17,0) array level 3 dcl 123 set ref 892 1705* 2126 tied_array_idx 000130 automatic fixed bin(17,0) dcl 45 in procedure "apl_file_system_" set ref 304* 306* 333* 344 364* 381* 388 405 419* 423 427 438* 446 492 510* 514 515 515 533* 539 539 539 548 569 569* 600 600* 614* 618 623 631* 641 642 660 666 674 674 676 677 684 686 687 697* 726* 732 732 732 737 790* 796 796 796 801 1013* 1017 1025 1103* 1194 1224* 1286 1325* 1329 1364 1380 1381 1388 1440* 1444 1453 1475* 1477 1535* 1541* 1578 1635 1637 1667 1668 1693 1695 1704 1705 1706 1707 2092* tied_array_idx parameter fixed bin(17,0) dcl 2028 in procedure "lock_file" ref 2025 2031 2042 2047 2051 tied_array_idx parameter fixed bin(17,0) dcl 1744 in procedure "untie_file" ref 1741 1751 1754 1759 1759 1764 1766 1780 tied_files 12 000010 internal static structure array level 2 unaligned dcl 123 set ref 275 889 889 932 932 1415 1415 1427 1427 1724 1724 2015 2015 2125 2162 time 12 001042 automatic fixed bin(71,0) level 2 dcl 113 set ref 474* 582* 848 total_data_elements 2 based fixed bin(21,0) level 2 dcl 8-3 set ref 300 833* 871* 918* 950 980* 1049* 1135 1150 1256 1347* 1436 1460 1490 1813 1816 1824 1925 1997 2192 type based structure level 3 in structure "value_bead" packed unaligned dcl 8-3 in procedure "apl_file_system_" set ref 832* 870* 917* 979* 1048* 1346* type based structure level 2 in structure "general_bead" packed unaligned dcl 7-3 in procedure "apl_file_system_" uid 000422 automatic bit(36) unaligned dcl 93 set ref 355* 361 1471* 1473 unique_chars_ 011360 constant entry external dcl 158 ref 1594 1594 1621 1621 unique_id 11 001057 automatic bit(36) level 2 packed unaligned dcl 2-1 set ref 355 361 1452 unlock 000406 automatic bit(2) initial unaligned dcl 67 set ref 67* 510* 600* 697* 1429* 2017* 2092* unspec builtin function dcl 10-25 ref 10-37 untie_error 000102 automatic bit(1) dcl 31 set ref 299* 312* 318 user_id 1 001042 automatic char(32) level 2 packed unaligned dcl 113 set ref 472* 580* user_info_$whoami 011362 constant entry external dcl 159 ref 1527 user_name 000357 automatic char(22) unaligned dcl 57 set ref 1527* 1528 user_number 24 based fixed bin(35,0) level 2 in structure "ws_info" dcl 6-16 in procedure "apl_file_system_" ref 473 581 user_number 11 001042 automatic fixed bin(17,0) level 2 in structure "component_header" dcl 113 in procedure "apl_file_system_" set ref 473* 581* 847 user_project 000365 automatic char(9) unaligned dcl 58 set ref 1527* 1528 value 0(02) based bit(1) level 4 in structure "general_bead" packed unaligned dcl 7-3 in procedure "apl_file_system_" ref 1113 1234 1807 1917 value parameter pointer array level 3 in structure "operators_argument" packed unaligned dcl 9-3 in procedure "apl_file_system_" ref 238 240 417 546 946 1109 1230 1805 1915 value_bead based structure level 1 dcl 8-3 set ref 824 837 866 877 913 925 975 987 1044 1056 1342 1353 2198 value_bead_ptr parameter pointer dcl 2179 ref 2174 2188 value_stack_ptr 16 based pointer level 3 packed unaligned dcl 6-16 set ref 238* 240* 10-40 10-43 10-44* 10-44 values 2 based structure level 2 dcl 6-16 verify builtin function dcl 179 ref 1180 version 000733 automatic fixed bin(17,0) level 2 dcl 102 set ref 495* 1656* 1685 1763* vfile_status_ 011324 constant entry external dcl 144 ref 1398 ws_info based structure level 1 dcl 6-16 ws_info_ptr 001076 automatic pointer initial dcl 6-7 set ref 238 240 473 581 6-7* 1974 2000 10-40 10-40 10-43 10-44 10-44 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Binary internal static bit(1) initial dcl 5-16 Direct_input internal static fixed bin(17,0) initial dcl 4-15 Direct_output internal static fixed bin(17,0) initial dcl 4-15 Direct_update internal static fixed bin(17,0) initial dcl 4-15 Keyed_sequential_output internal static fixed bin(17,0) initial dcl 4-15 MAX_VALUE_BEAD_SIZE internal static fixed bin(19,0) initial dcl 8-28 NumberSize internal static fixed bin(4,0) initial dcl 5-25 Sequential_input internal static fixed bin(17,0) initial dcl 4-15 Sequential_input_output internal static fixed bin(17,0) initial dcl 4-15 Sequential_output internal static fixed bin(17,0) initial dcl 4-15 Sequential_update internal static fixed bin(17,0) initial dcl 4-15 Stream_input internal static fixed bin(17,0) initial dcl 4-15 Stream_input_output internal static fixed bin(17,0) initial dcl 4-15 Stream_output internal static fixed bin(17,0) initial dcl 4-15 TheSmallestNumberWeveGot internal static float bin(63) initial dcl 5-16 blk_info based structure level 1 unaligned dcl 1-21 complex_datum based complex float bin(63) array dcl 8-26 complex_value_type internal static bit(18) initial unaligned dcl 7-30 directory_type internal static bit(2) initial dcl 2-1 function_type internal static bit(18) initial unaligned dcl 7-30 group_type internal static bit(18) initial unaligned dcl 7-30 iox_modes internal static char(24) initial array dcl 4-6 label_type internal static bit(18) initial unaligned dcl 7-30 lexed_function_type internal static bit(18) initial unaligned dcl 7-30 link_type internal static bit(2) initial dcl 2-1 list_value_type internal static bit(18) initial unaligned dcl 7-30 max_parse_stack_depth internal static fixed bin(17,0) initial dcl 6-98 msf_type internal static bit(2) initial dcl 2-1 not_integer_mask internal static bit(18) initial unaligned dcl 7-30 not_zero_or_one_mask internal static bit(18) initial unaligned dcl 7-30 numeric_value_type internal static bit(18) initial unaligned dcl 7-30 operator_type internal static bit(18) initial unaligned dcl 7-30 output_buffer based char unaligned dcl 6-94 record_quota_overflow 000000 stack reference condition dcl 1516 segment_type internal static bit(2) initial dcl 2-1 seq_info based structure level 1 unaligned dcl 1-11 shared_variable_type internal static bit(18) initial unaligned dcl 7-30 short_iox_modes internal static char(4) initial array dcl 4-12 star_ALL_ENTRIES internal static fixed bin(2,0) initial dcl 3-111 star_ALL_ENTRIES_WITH_LINK_PATHS internal static fixed bin(3,0) initial dcl 3-114 star_BRANCHES_ONLY internal static fixed bin(2,0) initial dcl 3-110 star_DIRECTORY internal static fixed bin(2,0) initial unsigned dcl 3-121 star_LINK internal static fixed bin(2,0) initial unsigned dcl 3-119 star_LINKS_ONLY internal static fixed bin(2,0) initial dcl 3-109 star_LINKS_ONLY_WITH_LINK_PATHS internal static fixed bin(3,0) initial dcl 3-112 star_SEGMENT internal static fixed bin(2,0) initial unsigned dcl 3-120 star_branch_count automatic fixed bin(17,0) dcl 3-13 star_dir_list_branch based structure array level 1 dcl 3-59 star_link_count automatic fixed bin(17,0) dcl 3-17 star_link_pathname based char unaligned dcl 3-102 star_links based structure array level 1 dcl 3-76 star_linkx automatic fixed bin(17,0) dcl 3-18 star_list_branch based structure array level 1 dcl 3-41 star_list_branch_ptr automatic pointer dcl 3-16 star_list_names based char(32) array unaligned dcl 3-92 star_list_names_ptr automatic pointer dcl 3-20 star_select_sw automatic fixed bin(3,0) dcl 3-21 symbol_type internal static bit(18) initial unaligned dcl 7-30 uns_info based structure level 1 unaligned dcl 1-1 value_type internal static bit(18) initial unaligned dcl 7-30 vbl_info based structure level 1 unaligned dcl 1-55 vfs_version_1 internal static fixed bin(17,0) initial dcl 1-67 zero_or_one_value_type internal static bit(18) initial unaligned dcl 7-30 NAMES DECLARED BY EXPLICIT CONTEXT. apl_file_system_ 000266 constant entry external dcl 10 ref 1594 1594 1621 1621 apl_push_stack_ 011701 constant entry internal dcl 10-4 ref 754 828 868 915 977 1046 1344 bad_matrix_syntax_exit 005371 constant label dcl 1208 ref 1160 1183 check_integers 011245 constant entry internal dcl 1984 ref 295 1421 common_acl_hacker 004640 constant label dcl 1099 ref 1090 1097 compute_length 011652 constant entry internal dcl 2174 ref 457 563 decode_args 000350 constant label dcl 269 ref 257 262 267 decode_file_id 010455 constant entry internal dcl 1794 ref 269 326 376 decode_right_arg 011041 constant entry internal dcl 1907 ref 271 289 329 379 413 527 610 720 786 1009 1099 1220 1321 1415 error_return 000404 constant label dcl 282 set ref 2095 exit_early 006710 constant label dcl 1490 ref 1486 file_error 011426 constant entry internal dcl 2063 ref 275 296 314 318 334 341 345 352 358 361 367 382 389 393 402 420 432 441 454 465 487 501 505 534 539 556 558 573 590 594 615 626 634 648 690 694 707 711 727 732 745 747 759 791 796 809 811 816 958 971 1014 1026 1030 1034 1104 1113 1116 1122 1128 1135 1195 1199 1208 1225 1234 1237 1243 1249 1256 1287 1291 1295 1326 1367 1373 1389 1399 1422 1441 1445 1449 1536 1542 1554 1556 1589 1596 1623 1630 1642 1662 1675 1682 1685 1807 1810 1813 1816 1837 1860 1881 1917 1920 1930 1935 1976 2053 file_operation 000000 constant label array(73:121) dcl 253 ref 243 248 flim_fsize_common 006015 constant label dcl 1321 ref 1311 1319 get_free_index 011573 constant entry internal dcl 2136 ref 1541 get_tie_index 011512 constant entry internal dcl 2102 ref 304 333 381 419 533 614 726 790 1013 1103 1224 1325 1440 1535 integerize 011212 constant entry internal dcl 1967 ref 302 1438 1953 1956 1957 lock_file 011311 constant entry internal dcl 2025 ref 438 510 569 600 631 697 1429 1500 2017 2092 niladic_functions 000321 constant entry external dcl 245 open_file 007053 constant entry internal dcl 1509 ref 278 unlock_all_files 007015 constant entry external dcl 2012 untie_all_files 006741 constant entry external dcl 1717 untie_file 010317 constant entry internal dcl 1741 ref 306 364 1728 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 13320 25036 12324 13330 Length 25716 12324 11516 644 774 11312 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME apl_file_system_ 960 external procedure is an external procedure. open_file 190 internal procedure enables or reverts conditions. on unit on line 1583 70 on unit untie_file internal procedure shares stack frame of external procedure apl_file_system_. decode_file_id internal procedure shares stack frame of external procedure apl_file_system_. decode_right_arg internal procedure shares stack frame of external procedure apl_file_system_. integerize internal procedure shares stack frame of external procedure apl_file_system_. check_integers internal procedure shares stack frame of external procedure apl_file_system_. lock_file 90 internal procedure is called by several nonquick procedures. file_error 72 internal procedure is called by several nonquick procedures. get_tie_index 66 internal procedure is called by several nonquick procedures. get_free_index internal procedure shares stack frame of internal procedure open_file. compute_length internal procedure shares stack frame of external procedure apl_file_system_. apl_push_stack_ internal procedure shares stack frame of external procedure apl_file_system_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 apl_file_system_static apl_file_system_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME apl_file_system_ 000100 share apl_file_system_ 000101 create_if_not_found apl_file_system_ 000102 untie_error apl_file_system_ 000103 flim_not_fsize apl_file_system_ 000104 fsetacl_not_faddacl apl_file_system_ 000105 switched_one apl_file_system_ 000106 left_vb apl_file_system_ 000110 right_vb apl_file_system_ 000112 left apl_file_system_ 000114 right apl_file_system_ 000116 result_vb apl_file_system_ 000117 bead_size apl_file_system_ 000120 size_read apl_file_system_ 000122 data_ptr apl_file_system_ 000124 tie_num apl_file_system_ 000126 iocb_ptr apl_file_system_ 000130 tied_array_idx apl_file_system_ 000131 data_elements apl_file_system_ 000132 component_number apl_file_system_ 000133 component_key apl_file_system_ 000136 start_component apl_file_system_ 000137 end_component apl_file_system_ 000140 drop_number apl_file_system_ 000141 file_pathname apl_file_system_ 000213 file_dname apl_file_system_ 000265 new_dname apl_file_system_ 000337 file_ename apl_file_system_ 000347 new_ename apl_file_system_ 000357 user_name apl_file_system_ 000365 user_project apl_file_system_ 000370 count apl_file_system_ 000371 idx apl_file_system_ 000372 increment apl_file_system_ 000373 temp_string apl_file_system_ 000402 info_ptr apl_file_system_ 000404 lock_info apl_file_system_ 000405 lock apl_file_system_ 000406 unlock apl_file_system_ 000407 current_file_locked apl_file_system_ 000410 area_ptr apl_file_system_ 000412 acl_ptr apl_file_system_ 000414 acl_count apl_file_system_ 000415 mode_string apl_file_system_ 000416 fcb_ptr apl_file_system_ 000420 code apl_file_system_ 000421 code2 apl_file_system_ 000422 uid apl_file_system_ 000423 file_uids apl_file_system_ 000567 array_idxs apl_file_system_ 000733 file_header apl_file_system_ 000736 file_header_version apl_file_system_ 000737 file_header_size apl_file_system_ 000740 file_header_key apl_file_system_ 001042 component_header apl_file_system_ 001056 component_header_size apl_file_system_ 001057 branch_status apl_file_system_ 001071 star_entry_count apl_file_system_ 001072 star_entry_ptr apl_file_system_ 001074 star_names_ptr apl_file_system_ 001076 ws_info_ptr apl_file_system_ 001100 number_of_dimensions apl_file_system_ 001101 found_one apl_file_system_ 001126 iocb_ptr untie_file 001136 file_id decode_file_id 001210 libx decode_file_id 001211 strx decode_file_id 001242 count check_integers 001244 data_ptr check_integers 001246 data_elements check_integers 001256 data_size compute_length 001260 temp_vb compute_length 001270 block_ptr apl_push_stack_ 001272 num_words apl_push_stack_ get_tie_index 000100 count get_tie_index open_file 000100 attach_desc open_file 000216 count get_free_index THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 r_g_a alloc_cs cat_realloc_cs call_ext_out_desc call_ext_out call_int_this call_int_other return fl2_to_fx2 tra_ext mpfx2 signal enable shorten_stack ext_entry int_entry floor_fl set_cs_eis index_cs_eis alloc_based free_based clock THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. apl_get_value_stack_ apl_translate_pathname_$file_system_pathname cv_userid_ delete_$path expand_pathname_ get_system_free_area_ hcs_$chname_file hcs_$star_ hcs_$status_long hcs_$status_minf ioa_$ioa_switch iox_$attach_name iox_$close iox_$control iox_$delete_record iox_$detach_iocb iox_$open iox_$read_record iox_$rewrite_record iox_$seek_key iox_$write_record msf_manager_$acl_add msf_manager_$acl_delete msf_manager_$acl_list msf_manager_$acl_replace msf_manager_$close msf_manager_$open unique_chars_ user_info_$whoami vfile_status_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. apl_error_table_$bad_access_matrix apl_error_table_$bad_access_modes apl_error_table_$bad_apl_file apl_error_table_$bad_component_num apl_error_table_$bad_file_name apl_error_table_$bad_fname_match apl_error_table_$bad_tie_num apl_error_table_$domain apl_error_table_$file_already_exists apl_error_table_$file_already_tied apl_error_table_$length apl_error_table_$no_access_to_file apl_error_table_$no_such_file apl_error_table_$no_write_permission apl_error_table_$not_enough_components apl_error_table_$not_within_int_fuzz apl_error_table_$old_file_header apl_error_table_$rank apl_error_table_$rqo_on_file apl_error_table_$tie_num_in_use apl_error_table_$too_many_files apl_static_$apl_output apl_static_$ws_info_ptr error_table_$file_busy error_table_$lock_not_locked error_table_$locked_by_this_process error_table_$moderr error_table_$no_info error_table_$no_operation error_table_$no_record error_table_$noentry error_table_$nomatch LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 66 000243 67 000245 68 000246 107 000247 109 000251 6 7 000256 10 000263 238 000274 240 000305 243 000313 245 000317 248 000327 253 000335 256 000336 257 000340 259 000341 261 000342 262 000343 264 000344 266 000346 267 000347 269 000350 271 000351 275 000356 278 000370 280 000400 282 000404 289 000405 295 000412 296 000414 299 000424 300 000425 302 000435 304 000446 306 000460 312 000465 314 000473 316 000501 318 000503 321 000514 322 000520 326 000521 329 000522 333 000527 334 000541 340 000551 341 000575 344 000605 345 000633 351 000643 352 000705 355 000715 357 000717 358 000761 361 000771 364 001003 366 001005 367 001042 370 001052 371 001056 376 001057 379 001060 381 001065 382 001077 388 001107 389 001136 392 001146 393 001172 399 001202 401 001206 402 001234 405 001244 408 001253 409 001257 413 001260 417 001265 419 001270 420 001302 423 001312 427 001317 429 001323 431 001325 432 001341 438 001351 440 001361 441 001402 444 001412 445 001415 446 001416 448 001421 450 001430 454 001452 457 001464 459 001474 464 001503 465 001520 472 001530 473 001534 474 001537 475 001541 477 001543 481 001545 483 001576 485 001622 487 001640 492 001650 494 001657 495 001661 496 001663 497 001665 500 001671 501 001705 504 001715 505 001734 510 001744 512 001754 514 001755 515 001760 519 001764 521 001770 527 001771 533 001776 534 002010 539 002020 546 002043 548 002046 550 002053 555 002062 556 002103 558 002116 563 002126 565 002136 569 002145 572 002163 573 002200 580 002210 581 002214 582 002217 583 002221 585 002223 589 002225 590 002256 593 002267 594 002306 600 002316 603 002334 605 002340 610 002341 614 002346 615 002360 618 002370 623 002375 625 002401 626 002415 629 002425 631 002427 633 002437 634 002460 637 002470 638 002472 639 002474 641 002475 642 002477 648 002502 656 002515 658 002517 659 002522 660 002524 661 002533 663 002534 664 002536 665 002541 666 002543 674 002552 676 002561 677 002562 684 002563 686 002566 687 002570 689 002572 690 002606 693 002616 694 002635 697 002645 702 002655 704 002676 706 002705 707 002727 710 002737 711 002750 713 002760 715 002763 716 002767 720 002770 726 002775 727 003007 732 003017 737 003042 739 003047 744 003056 745 003077 747 003112 750 003122 754 003126 758 003133 759 003153 765 003163 770 003171 776 003204 780 003205 782 003211 786 003212 790 003217 791 003231 796 003241 801 003264 803 003271 808 003300 809 003330 811 003344 814 003354 815 003356 816 003377 822 003407 823 003411 824 003413 828 003423 832 003430 833 003433 834 003435 835 003437 837 003441 841 003450 844 003466 846 003472 847 003476 848 003501 850 003505 851 003507 856 003510 864 003513 866 003515 868 003525 870 003532 871 003535 872 003537 873 003541 877 003543 881 003552 884 003570 888 003574 889 003575 890 003603 892 003612 893 003624 895 003625 897 003627 898 003633 903 003634 911 003640 913 003642 915 003652 917 003657 918 003662 919 003664 920 003666 921 003671 925 003673 927 003702 931 003704 932 003705 933 003714 935 003723 937 003735 939 003736 941 003740 942 003744 946 003745 950 003747 952 003751 957 003755 958 004007 961 004017 963 004022 965 004031 967 004076 969 004104 971 004111 973 004117 975 004121 977 004131 979 004136 980 004141 981 004143 982 004145 983 004147 987 004151 989 004160 991 004162 993 004172 994 004214 998 004216 1000 004250 1003 004256 1004 004262 1009 004263 1013 004270 1014 004302 1017 004312 1021 004317 1025 004325 1026 004354 1029 004364 1030 004411 1033 004421 1034 004444 1037 004454 1041 004463 1042 004466 1044 004470 1046 004500 1048 004505 1049 004510 1050 004512 1051 004514 1052 004516 1056 004520 1058 004527 1060 004531 1062 004542 1064 004560 1066 004571 1068 004573 1070 004601 1072 004603 1074 004611 1076 004613 1078 004620 1080 004622 1082 004626 1083 004632 1087 004633 1090 004635 1094 004636 1097 004637 1099 004640 1103 004645 1104 004657 1109 004667 1113 004672 1116 004704 1122 004716 1128 004733 1131 004751 1135 004752 1138 004764 1142 004767 1144 004776 1146 005005 1148 005007 1150 005015 1154 005020 1155 005021 1157 005031 1159 005035 1160 005040 1174 005041 1178 005126 1180 005136 1182 005150 1183 005153 1186 005154 1187 005171 1188 005206 1190 005223 1194 005225 1195 005254 1198 005264 1199 005311 1202 005321 1204 005345 1206 005362 1208 005371 1212 005401 1214 005405 1215 005411 1220 005412 1224 005417 1225 005431 1230 005441 1234 005444 1237 005456 1243 005470 1249 005505 1252 005523 1256 005524 1259 005536 1263 005541 1265 005550 1267 005557 1269 005561 1273 005567 1278 005577 1282 005644 1286 005647 1287 005676 1290 005706 1291 005733 1294 005743 1295 005760 1298 005770 1300 005777 1302 006003 1303 006007 1308 006010 1311 006012 1316 006013 1319 006014 1321 006015 1325 006022 1326 006034 1329 006044 1333 006051 1334 006053 1335 006055 1336 006057 1338 006060 1339 006062 1342 006064 1344 006074 1346 006101 1347 006104 1348 006106 1349 006110 1353 006112 1357 006121 1360 006137 1364 006143 1366 006152 1367 006166 1370 006176 1372 006200 1373 006221 1376 006231 1377 006237 1378 006243 1380 006244 1381 006250 1386 006255 1388 006257 1389 006306 1392 006316 1394 006325 1396 006332 1398 006334 1399 006361 1402 006371 1403 006400 1405 006402 1408 006404 1410 006410 1415 006411 1421 006416 1422 006420 1427 006430 1429 006435 1431 006453 1436 006455 1438 006465 1440 006476 1441 006510 1444 006520 1445 006547 1448 006557 1449 006621 1452 006631 1453 006634 1454 006636 1460 006640 1462 006647 1464 006650 1469 006657 1471 006663 1472 006664 1473 006666 1475 006670 1476 006672 1477 006675 1479 006677 1481 006701 1486 006703 1488 006705 1490 006710 1500 006721 1501 006731 1503 006733 1504 006737 1717 006740 1722 006747 1724 006750 1726 006755 1728 006763 1729 006765 1731 006767 1733 006771 1735 007013 2012 007014 2015 007023 2017 007031 2019 007047 2020 007051 1509 007052 1525 007060 1527 007062 1528 007103 1529 007144 1535 007146 1536 007162 1541 007175 1542 007210 1547 007222 1551 007237 1553 007244 1554 007305 1556 007320 1558 007334 1562 007335 1569 007347 1571 007367 1578 007401 1583 007411 1586 007425 1587 007437 1589 007452 1590 007462 1594 007463 1596 007543 1602 007556 1604 007576 1606 007603 1613 007613 1615 007626 1617 007634 1618 007643 1621 007676 1623 007757 1626 007772 1627 010012 1630 010026 1635 010042 1636 010050 1637 010051 1639 010055 1642 010067 1648 010101 1653 010117 1655 010124 1656 010126 1657 010130 1658 010131 1660 010132 1662 010150 1665 010162 1667 010166 1668 010173 1670 010174 1675 010175 1678 010206 1680 010211 1682 010232 1685 010244 1691 010260 1693 010264 1695 010273 1700 010275 1704 010276 1705 010304 1706 010307 1707 010313 1708 010315 1710 010316 1741 010317 1749 010321 1751 010322 1754 010333 1759 010336 1762 010341 1763 010343 1764 010345 1766 010351 1769 010355 1770 010372 1773 010376 1775 010415 1780 010421 1781 010430 1783 010432 1784 010442 1786 010454 1794 010455 1805 010456 1807 010461 1810 010473 1813 010505 1816 010517 1824 010535 1826 010540 1830 010542 1832 010556 1837 010560 1840 010573 1844 010575 1846 010607 1849 010631 1853 010633 1855 010650 1860 010652 1866 010665 1868 010702 1872 010704 1874 010722 1881 010724 1891 010737 1892 010746 1894 011000 1895 011037 1907 011041 1915 011043 1917 011047 1920 011061 1925 011073 1930 011076 1935 011113 1939 011133 1943 011136 1945 011141 1946 011144 1948 011147 1949 011152 1951 011153 1953 011154 1954 011164 1956 011167 1957 011200 1961 011211 1967 011212 1974 011214 1976 011232 1978 011241 1984 011245 1994 011247 1996 011250 1997 011254 1999 011256 2000 011265 2003 011300 2004 011304 2006 011305 2007 011307 2025 011310 2031 011316 2038 011326 2042 011334 2047 011341 2049 011346 2051 011352 2053 011405 2056 011424 2063 011425 2068 011433 2071 011436 2075 011442 2080 011447 2083 011454 2086 011461 2089 011466 2092 011473 2095 011506 2102 011511 2114 011517 2122 011521 2125 011536 2126 011543 2129 011562 2130 011564 2131 011570 2136 011573 2147 011575 2155 011576 2159 011614 2160 011616 2162 011621 2163 011627 2165 011641 2166 011643 2167 011647 2174 011652 2188 011654 2192 011657 2194 011661 2196 011670 2198 011673 10 4 011701 10 35 011703 10 37 011705 10 40 011712 10 43 011727 10 44 011732 10 45 011741 ----------------------------------------------------------- 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