COMPILATION LISTING OF SEGMENT lister_merge_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell Multics Op. - System M Compiled on: 11/05/84 1154.4 mst Mon Options: optimize map 1 /* *********************************************************** 2* * * 3* * * 4* * Copyright, (C) Honeywell Information Systems Inc., 1981 * 5* * * 6* * * 7* *********************************************************** */ 8 9 /* ****************************************************** 10* * * 11* * * 12* * Copyright (c) 1972 by Massachusetts Institute of * 13* * Technology and Honeywell Information Systems, Inc. * 14* * * 15* * * 16* ****************************************************** */ 17 18 /* Procedure to merge two Lister files into a new Lister file. 19* Written 760415 by PG after several false starts. 20* Modified 761116 by PG to rename from assist_merge_ to lister_merge_. 21* Modified 800522 by PB to abort processing when 2 files don't have same fields 22* in the same order. This is an interim fix, future 23* implementation will resolve differences. 24* Modified 800523 by PB to make field comparison case-insensitive. 25* Modified 800825 by PB to handle unique ids. 26* Modified 800923 by PB to allow update file to have a subset of master file's 27* fields and to have fields in different order. 28**/ 29 30 /* format: style3 */ 31 lister_merge_: 32 procedure (bv_input_file_ptr, bv_update_file_ptr, bv_output_file_ptr, bv_field_list, bv_n_fields, bv_merge_type, bv_code) 33 returns ((3) fixed bin) options (packed_decimal); 34 35 /* external static */ 36 37 dcl lister_codes_$master_not_like_update ext static fixed bin (35); 38 39 /* parameters */ 40 41 dcl ( 42 (bv_input_file_ptr, bv_output_file_ptr, bv_update_file_ptr) 43 ptr, 44 bv_field_list fixed bin dim (*), 45 bv_n_fields fixed bin, 46 bv_merge_type fixed bin, 47 bv_code fixed bin (35) 48 ) parameter; 49 50 /* automatic */ 51 52 dcl (ifp, inftptr, irp, equiv_table_ptr, previous_irp, ufp, upftptr, urp) 53 ptr, 54 counts (3) fixed bin, 55 (flx, fx, i, j, equiv, merge_type, n_fields, rel) 56 fixed bin; 57 58 /* based */ 59 60 dcl equiv_table (0:inftptr -> field_table.max_field_index) 61 fixed bin based (equiv_table_ptr); 62 63 /* builtin */ 64 65 dcl (hbound, lbound, length, null, pointer, translate) 66 builtin; 67 68 /* internal static */ 69 70 dcl ( 71 ( 72 LESS_THAN initial (1), 73 EQUAL initial (2), 74 GREATER_THAN initial (3) 75 ) fixed bin, 76 ( 77 lower_case initial ("abcdefghijklmnopqrstuvwxyz"), 78 upper_case initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") 79 ) char (26) aligned 80 ) internal static options (constant); 81 82 /* include files */ 83 1 1 /* ====== BEGIN INCLUDE FILE lister_entries.incl.pl1 =================================== */ 1 2 1 3 /* 1 4* Modified 800521 by PB to add code to calling sequence for lister_merge_. 1 5* Modified 800702 by PB to add lister_status_. 1 6* Modified 800813 by PB to add lister_assign_. 1 7* Modified 800826 by PB to add lister_create_record_$retain_uid. 1 8* Modified 801008 by PB to add display to calling sequence for lister_print_. 1 9* Modified 801024 by PB to add lister_convert_. 1 10* Modified 810226 by PB to add listform_path to calling sequence for lister_print_. 1 11**/ 1 12 1 13 dcl lister_assign_ 1 14 entry (ptr, bit (1) aligned, ptr, ptr); 1 15 /* param 1 (input) ptr to lister segment */ 1 16 /* param 2 (input) "1"b iff all records are to be modified */ 1 17 /* param 3 (input) ptr to selected records */ 1 18 /* param 4 (input) ptr to assign info structure */ 1 19 1 20 dcl lister_compile_listin_ 1 21 entry (ptr, ptr, fixed bin (21), ptr, fixed bin, char (*), fixed bin (35)); 1 22 /* param 1 (input) ptr to new file segment */ 1 23 /* param 2 (input) ptr to listin segment */ 1 24 /* param 3 (input) length in chars of listin segment */ 1 25 /* param 4 (input) ptr to system free area */ 1 26 /* param 5 (output) number of records parsed */ 1 27 /* param 6 (output) error token, if any errors */ 1 28 /* param 7 (output) status code */ 1 29 1 30 dcl lister_compile_select_ 1 31 entry (char (*), ptr, ptr, ptr, char (*), fixed bin (35)); 1 32 /* param 1 (input) select expression to be parsed */ 1 33 /* param 2 (input) ptr to file that will be searched */ 1 34 /* param 3 (input) ptr to area */ 1 35 /* param 4 (output) ptr to compiled select expression */ 1 36 /* param 5 (output) error token */ 1 37 /* param 6 (output) standard status code */ 1 38 1 39 dcl lister_compile_sort_ 1 40 entry (char (*), ptr, ptr, ptr, char (*), fixed bin (35)); 1 41 /* param 1 (input) sort string to be parsed */ 1 42 /* param 2 (input) ptr to file */ 1 43 /* param 3 (input) ptr to area */ 1 44 /* param 4 (output) ptr to compiled sort expression */ 1 45 /* param 5 (output) token in error (if any error) */ 1 46 /* param 6 (output) standard status code */ 1 47 1 48 dcl lister_convert_ entry (ptr, fixed bin (35)); 1 49 /* param 1 (input) input file ptr */ 1 50 /* param 2 (output) standard status code */ 1 51 1 52 dcl lister_copy_file_head_ 1 53 entry (ptr, ptr); 1 54 /* param 1 (input) input file ptr */ 1 55 /* param 2 (input) output file ptr */ 1 56 1 57 dcl lister_copy_records_ 1 58 entry (ptr, ptr, ptr); 1 59 /* param 1 (input) ptr to input file */ 1 60 /* param 2 (input) ptr to output file */ 1 61 /* param 3 (input) ptr to list of records to be copied */ 1 62 1 63 dcl lister_compare_field_tables_ 1 64 entry (ptr, ptr) 1 65 returns (bit (1) aligned); 1 66 /* param 1 (input) ptr to file 1 */ 1 67 /* param 2 (input) ptr to file 2 */ 1 68 /* return (output) "1"b if field tables are equal */ 1 69 1 70 dcl lister_create_record_ 1 71 entry (ptr) 1 72 returns (ptr); 1 73 /* param 1 (input) file ptr */ 1 74 /* return (output) record ptr */ 1 75 1 76 dcl lister_create_record_$after 1 77 entry (ptr, ptr) 1 78 returns (ptr); 1 79 /* param 1 (input) ptr to file to create record in */ 1 80 /* param 2 (input) ptr to record that is to be just before created record */ 1 81 /* return (output) ptr to created record */ 1 82 1 83 dcl lister_create_record_$retain_uid 1 84 entry (ptr, fixed bin (24) unsigned unaligned) 1 85 returns (ptr); 1 86 /* param 1 (input) file ptr */ 1 87 /* param 2 (input) uid to be retained */ 1 88 /* return (output) record ptr */ 1 89 1 90 dcl lister_delete_ 1 91 entry (ptr, ptr); 1 92 /* param 1 (input) file ptr */ 1 93 /* param 2 (input) ptr to list of record to be deleted */ 1 94 1 95 dcl lister_expand_ 1 96 entry (ptr, ptr, fixed bin (21), fixed bin, bit (1) aligned) 1 97 returns (fixed bin); 1 98 /* param 1 (input) file ptr */ 1 99 /* param 2 (input) ptr to output segment */ 1 100 /* param 3 (in/out) 1-origin char index of next free char in output segment */ 1 101 /* param 4 (input) line length to use */ 1 102 /* param 5 (input) "1"b iff field names are always to appear */ 1 103 /* return (output) number of records expanded */ 1 104 1 105 dcl lister_hash_fid_ reducible 1 106 entry (ptr, char (*)) 1 107 returns (fixed bin); 1 108 /* param 1 (input) file ptr */ 1 109 /* param 2 (input) field identifier */ 1 110 /* return (output) field index */ 1 111 1 112 dcl lister_hash_fid_$enter irreducible 1 113 entry (ptr, char (*)) 1 114 returns (ptr); 1 115 /* param 1 (input) file ptr */ 1 116 /* param 2 (input) field identifier */ 1 117 /* return (output) field identifier node offset */ 1 118 1 119 dcl lister_format_parse_ 1 120 entry (ptr, ptr, char (*), ptr, char (*), fixed bin (35)); 1 121 /* param 1 (input) ptr to file containing field table */ 1 122 /* param 2 (input) ptr to area */ 1 123 /* param 3 (input) listform string */ 1 124 /* param 4 (output) format table ptr */ 1 125 /* param 5 (output) error token */ 1 126 /* param 6 (output) status code */ 1 127 1 128 dcl lister_merge_ entry (ptr, ptr, ptr, (*) fixed bin, fixed bin, fixed bin, fixed bin(35)) 1 129 returns ((3) fixed bin); 1 130 /* param 1 (input) input file ptr */ 1 131 /* param 2 (input) update file ptr */ 1 132 /* param 3 (input) output file ptr */ 1 133 /* param 4 (input) array of fields to merge on */ 1 134 /* param 5 (input) 1-origin number of elements in field_list */ 1 135 /* param 6 (input) type of merge */ 1 136 /* param 7 (output) status code */ 1 137 /* return (output) count of number of input, update, output records */ 1 138 1 139 dcl lister_print_ entry (ptr, ptr, ptr, fixed bin (21), bit (1) aligned, 1 140 ptr, ptr, fixed bin, bit (1) aligned, bit (1) aligned, char (*)); 1 141 /* param 1 (input) ptr to file to be printed */ 1 142 /* param 2 (input) format table ptr */ 1 143 /* param 3 (input) ptr to base of output segment */ 1 144 /* param 4 (in/out) index of next output character */ 1 145 /* param 5 (input) "1"b iff all records are to be printed */ 1 146 /* param 6 (input) ptr to list of records to print */ 1 147 /* null => print no records */ 1 148 /* param 7 (input) ptr to argument list for -ag */ 1 149 /* param 8 (input) index of -ag in above argument list */ 1 150 /* param 9 (input) brief error flag */ 1 151 /* param 10 (input) "1"b iff called by display_list af */ 1 152 /* param 11 (input) pathname of listform segment */ 1 153 1 154 dcl lister_select_ entry (ptr, ptr, ptr, ptr) 1 155 returns (fixed bin); 1 156 /* param 1 (input) ptr to file to be searched */ 1 157 /* param 2 (input) ptr to select_expression */ 1 158 /* param 3 (input) ptr to area */ 1 159 /* param 4 (output) ptr to list of selected records */ 1 160 /* return (output) number of records found */ 1 161 1 162 dcl lister_sort_ entry (ptr, ptr, ptr); 1 163 /* param 1 (input) file ptr */ 1 164 /* param 2 (input) ptr to list of records */ 1 165 /* param 3 (input) ptr to sort list array */ 1 166 1 167 dcl lister_status_ entry (ptr, char (*), bit (1) aligned, ptr); 1 168 /* param 1 (input) ptr to lister segment */ 1 169 /* param 2 (input) entryname of lister segment */ 1 170 /* param 3 (input) on if no selection expression given */ 1 171 /* param 4 (input) ptr to status info structure */ 1 172 1 173 /* ------ END INCLUDE FILE lister_entries.incl.pl1 ----------------------------------- */ 84 2 1 /* ====== BEGIN INCLUDE FILE lister_structures.incl.pl1 ================================ */ 2 2 2 3 /* 2 4* Modified 800813 by PB to add PUT_UID to listform declarations. 2 5* Modified 800825 by PB for version 2 lister file. 2 6* Modified 840523 by PB to add SELECT_BEG and SELECT_END. 2 7**/ 2 8 /* MASTER DECLARATIONS */ 2 9 2 10 /* format: style3 */ 2 11 dcl lister_file_version_2 2 12 fixed bin initial (2) internal static options (constant); 2 13 2 14 dcl 1 input_file based (in_file_ptr) aligned, 2 15 2 ( 2 16 field_table_offset, 2 17 record_head, 2 18 record_tail, 2 19 unused (2) 2 20 ) offset (input_file.area), 2 21 2 next_uid fixed bin (24) unsigned, 2 22 2 version fixed bin, 2 23 2 n_records fixed bin (17), 2 24 2 area area (261112); 2 25 2 26 dcl 1 update_file based (up_file_ptr) aligned, 2 27 2 ( 2 28 field_table_offset, 2 29 record_head, 2 30 record_tail, 2 31 unused (2) 2 32 ) offset (update_file.area), 2 33 2 next_uid fixed bin (24) unsigned, 2 34 2 version fixed bin, 2 35 2 n_records fixed bin (17), 2 36 2 area area (261112); 2 37 2 38 dcl 1 output_file based (out_file_ptr) aligned, 2 39 2 ( 2 40 field_table_offset, 2 41 record_head, 2 42 record_tail, 2 43 unused (2) 2 44 ) offset (output_file.area), 2 45 2 next_uid fixed bin (24) unsigned, 2 46 2 version fixed bin, 2 47 2 n_records fixed bin (17), 2 48 2 area area (261112); 2 49 2 50 dcl 1 input_record based (recordp) aligned, 2 51 2 next offset (input_file.area), 2 52 2 uid fixed bin (24) unsigned unaligned, 2 53 2 max_field_index fixed bin (12) unsigned unaligned, 2 54 2 field dim (0:field_table.max_field_index refer (input_record.max_field_index)) 2 55 offset (input_file.area); 2 56 2 57 dcl 1 update_record based aligned, 2 58 2 next offset (update_file.area), 2 59 2 uid fixed bin (24) unsigned unaligned, 2 60 2 max_field_index fixed bin (12) unsigned unaligned, 2 61 2 field dim (0:field_table.max_field_index refer (update_record.max_field_index)) 2 62 offset (update_file.area); 2 63 2 64 dcl 1 output_record based aligned, 2 65 2 next offset (output_file.area), 2 66 2 uid fixed bin (24) unsigned unaligned, 2 67 2 max_field_index fixed bin (12) unsigned unaligned, 2 68 2 field dim (0:field_table.max_field_index refer (output_record.max_field_index)) 2 69 offset (output_file.area); 2 70 2 71 dcl atom char (atom_length) based (atomp) varying aligned, 2 72 atom_length fixed bin initial (0), /* for table option */ 2 73 atomp ptr; 2 74 2 75 dcl (fidp, field_table_ptr, format_table_ptr, in_file_ptr, ltp, recordp, select_ptr, out_file_ptr, up_file_ptr) 2 76 ptr, 2 77 n fixed bin; 2 78 2 79 dcl 1 field_table based (field_table_ptr) aligned, 2 80 2 record_delimiter 2 81 unal char (1), 2 82 2 field_delimiter unal char (1), 2 83 2 max_field_index unal fixed bin (17), 2 84 2 hash_field_id_to_index 2 85 dimension (0:18) offset, 2 86 2 index_to_field_id 2 87 dimension (0:n refer (field_table.max_field_index)) offset; 2 88 2 89 dcl 1 field_identifier based (fidp) aligned, 2 90 2 next offset, 2 91 2 field_index unal fixed bin (17), 2 92 2 size unal fixed bin (17), 2 93 2 string unal char (n refer (field_identifier.size)); 2 94 2 95 dcl system_area area (261120) based (area_ptr); 2 96 dcl area_ptr ptr; 2 97 2 98 /* LISTFORM DECLARATIONS */ 2 99 2 100 declare ( 2 101 PUT_LITERAL initial (-1), 2 102 PUT_SPACES initial (-2), 2 103 PUT_END initial (-3), 2 104 PUT_DATE initial (-4), 2 105 PUT_TIME initial (-5), 2 106 PUT_RECORD_COUNT initial (-6), 2 107 PUT_ARGUMENT initial (-7), 2 108 PUT_UID initial (-8) 2 109 ) fixed bin internal static; 2 110 2 111 dcl 1 format_table aligned based (format_table_ptr), 2 112 2 size fixed bin (17) unal, 2 113 2 before fixed bin (17) unal, 2 114 2 after fixed bin (17) unal, 2 115 2 record fixed bin (17) unal, 2 116 2 literal_table ptr, 2 117 2 item dim (n refer (format_table.size)), 2 118 3 action fixed bin (17) unal, 2 119 3 justification bit (2) unal, 2 120 3 argument_number 2 121 fixed bin (15) unal, 2 122 3 width fixed bin (21); 2 123 2 124 dcl 1 literal_table aligned based (ltp), 2 125 2 size fixed bin, /* number of slots allocated */ 2 126 2 n_literals fixed bin, /* number of slots in use */ 2 127 2 literal dim (n refer (literal_table.size)) ptr unal; 2 128 2 129 dcl ( 2 130 flush_left initial ("00"b), 2 131 center initial ("01"b), 2 132 flush_right initial ("10"b) 2 133 ) bit (2) aligned internal static options (constant); 2 134 2 135 dcl MIN_FIELD_INDEX fixed bin initial (0) internal static options (constant); 2 136 2 137 dcl 1 list_node aligned based, 2 138 2 size fixed bin, 2 139 2 list dimension (n refer (list_node.size)) ptr; 2 140 2 141 /* SELECT DECLARATIONS */ 2 142 2 143 dcl 1 select_expression based (select_ptr) aligned, 2 144 2 literal_table_ptr 2 145 ptr, 2 146 2 size fixed bin, 2 147 2 last_element fixed bin, 2 148 2 element dim (n refer (select_expression.size)), 2 149 3 opcode unal bit (9), 2 150 3 not unal bit (1), 2 151 3 top unal bit (1), 2 152 3 unused unal bit (7), 2 153 3 field_index unal fixed bin (8), 2 154 3 literal_index unal fixed bin (8), 2 155 1 element aligned, 2 156 2 opcode fixed bin, 2 157 2 not bit (1) aligned, 2 158 2 top bit (1) aligned, 2 159 2 field_index fixed bin, 2 160 2 literal_index fixed bin, 2 161 operand1 fixed bin defined (element.field_index), 2 162 operand2 fixed bin defined (element.literal_index); 2 163 2 164 dcl ( 2 165 SELECT_AND init ("000000001"b), 2 166 SELECT_OR init ("000000010"b), 2 167 SELECT_NOT init ("000000011"b), 2 168 SELECT_FIND init ("000000100"b), 2 169 SELECT_EQ init ("000000101"b), 2 170 SELECT_LT init ("000000110"b), 2 171 SELECT_GT init ("000000111"b), 2 172 SELECT_LE init ("000001000"b), 2 173 SELECT_GE init ("000001001"b), 2 174 SELECT_NEQ init ("000001010"b), 2 175 SELECT_NLT init ("000001011"b), 2 176 SELECT_NGT init ("000001100"b), 2 177 SELECT_NLE init ("000001101"b), 2 178 SELECT_NGE init ("000001110"b), 2 179 SELECT_BEG init ("000001111"b), 2 180 SELECT_END init ("000010000"b) 2 181 ) bit (9) aligned internal static; 2 182 2 183 dcl ( 2 184 ANY_FIELD init (-1), 2 185 NULL_FIELD init (-2), 2 186 NUMERIC_FIELD init (-3), 2 187 UID init (-4) 2 188 ) aligned fixed bin (8) static; 2 189 2 190 dcl 1 numeric_atom aligned based (atomp), 2 191 2 flag fixed bin (35), /* must be -1 */ 2 192 2 value float dec (29) unal; 2 193 2 194 dcl numeric_flag fixed bin (35) internal static initial (-1) options (constant); 2 195 2 196 /* SORT DECLARATIONS */ 2 197 2 198 declare n_items_to_sort fixed bin, 2 199 sort_list_ptr ptr; 2 200 2 201 declare 1 sort_list aligned based (sort_list_ptr), 2 202 2 n_keys fixed bin, 2 203 2 key (n_items_to_sort refer (sort_list.n_keys)), 2 204 3 field_index fixed bin, 2 205 3 ascending bit (1) aligned, 2 206 3 numeric bit (1) aligned; 2 207 2 208 /* MERGE DECLARATIONS */ 2 209 2 210 dcl ( 2 211 MERGE_ADD init (0), 2 212 MERGE_AND init (1), 2 213 MERGE_OR init (2), 2 214 MERGE_SUBTRACT init (3) 2 215 ) fixed bin internal static options (constant); 2 216 2 217 /* ------ END INCLUDE FILE lister_structures.incl.pl1 -------------------------------- */ 85 86 87 /* program */ 88 89 in_file_ptr = bv_input_file_ptr; 90 up_file_ptr = bv_update_file_ptr; 91 out_file_ptr = bv_output_file_ptr; 92 merge_type = bv_merge_type; 93 n_fields = bv_n_fields; 94 bv_code = 0; 95 96 counts (1) = 0; 97 counts (2) = 0; 98 counts (3) = 0; 99 previous_irp = null; /* old value of irp */ 100 inftptr = input_file.field_table_offset; 101 upftptr = update_file.field_table_offset; 102 allocate equiv_table; 103 do i = 0 to inftptr -> field_table.max_field_index; 104 equiv_table (i) = -1; 105 end; 106 call compare_field_tables; 107 if bv_code ^= 0 then do; 108 free equiv_table; 109 return (counts); 110 end; 111 112 call lister_copy_file_head_ (in_file_ptr, out_file_ptr); 113 114 output_file.next_uid = input_file.next_uid; 115 116 irp = input_file.record_head; 117 urp = update_file.record_head; 118 119 merge_loop: 120 if irp ^= null 121 then if urp ^= null 122 then do; 123 do flx = lbound (bv_field_list, 1) to n_fields; 124 fx = bv_field_list (flx); 125 ifp = irp -> input_record.field (fx); 126 if equiv_table (fx) = -1 127 then ufp = null; 128 else ufp = urp -> update_record.field (equiv_table (fx)); 129 130 if ifp = null 131 then if ufp = null 132 then ; 133 else do; 134 rel = LESS_THAN; 135 go to no_match (merge_type); 136 end; 137 else if ufp = null 138 then do; 139 rel = GREATER_THAN; 140 go to no_match (merge_type); 141 end; 142 else do; 143 rel = compare (ifp, ufp); 144 if rel ^= EQUAL 145 then go to no_match (merge_type); 146 end; 147 end; 148 149 rel = EQUAL; 150 go to match (merge_type); 151 end; 152 else rel = LESS_THAN; /* irp ^= null, urp = null */ 153 else if urp = null /* irp = null, urp = null */ 154 then do; 155 free equiv_table; 156 return (counts); /* ALL DONE. */ 157 end; 158 else rel = GREATER_THAN; /* irp = null, urp ^= null */ 159 160 go to no_match (merge_type); 161 162 match (0): /* ADD */ 163 match (1): /* AND */ 164 write_input: 165 call copy_record (in_file_ptr, irp, "1"b); 166 167 match (2): /* OR */ 168 match (3): /* SUBTRACT */ 169 discard_input: 170 previous_irp = irp; /* save old value */ 171 irp = irp -> input_record.next; /* step to next input record */ 172 counts (1) = counts (1) + 1; /* one more input record processed. */ 173 go to merge_loop; 174 175 no_match (0): /* ADD */ 176 no_match (2): /* OR */ 177 if rel = LESS_THAN 178 then go to write_input; 179 180 call copy_record (up_file_ptr, urp, "0"b); /* write_update */ 181 go to discard_update; 182 183 no_match (1): /* AND */ 184 if rel = LESS_THAN 185 then go to discard_input; 186 187 go to discard_update; 188 189 no_match (3): /* SUBTRACT */ 190 if rel = LESS_THAN 191 then go to write_input; 192 193 discard_update: 194 urp = urp -> update_record.next; 195 counts (2) = counts (2) + 1; /* one more update record processed. */ 196 go to merge_loop; 197 198 compare_field_tables: 199 proc; 200 dcl (infidp, upfidp) ptr; 201 if inftptr -> field_table.max_field_index < upftptr -> field_table.max_field_index 202 then bv_code = lister_codes_$master_not_like_update; 203 else do i = 0 to upftptr -> field_table.max_field_index; 204 upfidp = pointer (upftptr -> field_table.index_to_field_id (i), update_file.area); 205 equiv = -1; 206 do j = 0 to inftptr -> field_table.max_field_index; 207 infidp = pointer (inftptr -> field_table.index_to_field_id (j), input_file.area); 208 if infidp -> field_identifier.string = upfidp -> field_identifier.string 209 then do; 210 equiv = j; 211 j = inftptr -> field_table.max_field_index; 212 end; 213 end; 214 if equiv = -1 215 then do; 216 bv_code = lister_codes_$master_not_like_update; 217 return; 218 end; 219 equiv_table (equiv) = i; 220 end; 221 end; 222 223 224 compare: 225 procedure (p1, p2) returns (fixed bin); 226 227 /* parameters */ 228 229 dcl (p1, p2) ptr parameter; 230 231 /* automatic adjustable */ 232 233 dcl s1 char (length (p1 -> atom)) aligned, 234 s2 char (length (p2 -> atom)) aligned; 235 236 /* program */ 237 238 s1 = translate (p1 -> atom, lower_case, upper_case); 239 s2 = translate (p2 -> atom, lower_case, upper_case); 240 241 if s1 = s2 242 then return (EQUAL); 243 else if s1 < s2 244 then return (LESS_THAN); 245 else return (GREATER_THAN); 246 247 end compare; 248 249 copy_record: 250 procedure (bv_file_ptr, bv_record_ptr, bv_retain_uid); 251 252 /* parameters */ 253 254 dcl (bv_file_ptr, bv_record_ptr) 255 ptr parameter, 256 bv_retain_uid bit (1) aligned parameter; 257 258 /* automatic */ 259 260 dcl (filep, out_rp, out_atomp) 261 ptr, 262 fieldx fixed bin; 263 264 /* program */ 265 266 recordp = bv_record_ptr; 267 filep = bv_file_ptr; 268 269 if bv_retain_uid 270 then out_rp = lister_create_record_$retain_uid (out_file_ptr, input_record.uid); 271 else out_rp = lister_create_record_ (out_file_ptr); 272 273 /* The following reference to input_record should really to be to a declaration of 274* a record that references "filep" , not input_file. */ 275 276 do fieldx = lbound (input_record.field, 1) to hbound (input_record.field, 1); 277 if bv_file_ptr = up_file_ptr 278 then do; 279 if equiv_table (fieldx) = -1 280 then atomp = null; 281 else atomp = pointer (input_record.field (equiv_table (fieldx)), filep -> input_file.area); 282 end; 283 else atomp = pointer (input_record.field (fieldx), filep -> input_file.area); 284 if atomp ^= null 285 then do; 286 atom_length = length (atom); 287 allocate atom in (output_file.area) set (out_atomp); 288 out_atomp -> atom = atom; 289 out_rp -> output_record.field (fieldx) = out_atomp; 290 end; 291 end; 292 293 counts (3) = counts (3) + 1; /* one more output record */ 294 return; 295 296 end copy_record; 297 298 end; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/05/84 1151.5 lister_merge_.pl1 >special_ldd>online>6883-11/02/84>lister_merge_.pl1 84 1 04/25/81 0728.4 lister_entries.incl.pl1 >ldd>include>lister_entries.incl.pl1 85 2 11/02/84 1208.5 lister_structures.incl.pl1 >special_ldd>online>6883-11/02/84>lister_structures.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. EQUAL constant fixed bin(17,0) initial dcl 70 ref 144 149 241 GREATER_THAN constant fixed bin(17,0) initial dcl 70 ref 139 158 245 LESS_THAN constant fixed bin(17,0) initial dcl 70 ref 134 152 175 183 189 243 area 10 based area(261112) level 2 in structure "update_file" dcl 2-26 in procedure "lister_merge_" ref 101 117 128 193 204 area 10 based area(261112) level 2 in structure "output_file" dcl 2-38 in procedure "lister_merge_" ref 287 289 area 10 based area(261112) level 2 in structure "input_file" dcl 2-14 in procedure "lister_merge_" ref 100 116 125 171 207 281 283 atom based varying char dcl 2-71 set ref 233 233 238 239 286 287 288* 288 atom_length 000133 automatic fixed bin(17,0) initial dcl 2-71 set ref 2-71* 286* 287 288 atomp 000134 automatic pointer dcl 2-71 set ref 279* 281* 283* 284 286 288 bv_code parameter fixed bin(35,0) dcl 41 set ref 31 94* 107 201* 216* bv_field_list parameter fixed bin(17,0) array dcl 41 ref 31 123 124 bv_file_ptr parameter pointer dcl 254 ref 249 267 277 bv_input_file_ptr parameter pointer dcl 41 ref 31 89 bv_merge_type parameter fixed bin(17,0) dcl 41 ref 31 92 bv_n_fields parameter fixed bin(17,0) dcl 41 ref 31 93 bv_output_file_ptr parameter pointer dcl 41 ref 31 91 bv_record_ptr parameter pointer dcl 254 ref 249 266 bv_retain_uid parameter bit(1) dcl 254 ref 249 269 bv_update_file_ptr parameter pointer dcl 41 ref 31 90 counts 000120 automatic fixed bin(17,0) array dcl 52 set ref 96* 97* 98* 109 156 172* 172 195* 195 293* 293 equiv 000127 automatic fixed bin(17,0) dcl 52 set ref 205* 210* 214 219 equiv_table based fixed bin(17,0) array dcl 60 set ref 102 104* 108 126 128 155 219* 279 281 equiv_table_ptr 000106 automatic pointer dcl 52 set ref 102* 104 108 126 128 155 219 279 281 field 2 based offset array level 2 in structure "update_record" dcl 2-57 in procedure "lister_merge_" ref 128 field 2 based offset array level 2 in structure "output_record" dcl 2-64 in procedure "lister_merge_" set ref 289* field 2 based offset array level 2 in structure "input_record" dcl 2-50 in procedure "lister_merge_" ref 125 276 276 281 283 field_identifier based structure level 1 dcl 2-89 field_table based structure level 1 dcl 2-79 field_table_offset based offset level 2 in structure "input_file" dcl 2-14 in procedure "lister_merge_" ref 100 field_table_offset based offset level 2 in structure "update_file" dcl 2-26 in procedure "lister_merge_" ref 101 fieldx 000264 automatic fixed bin(17,0) dcl 260 set ref 276* 279 281 283 289* filep 000256 automatic pointer dcl 260 set ref 267* 281 283 flx 000123 automatic fixed bin(17,0) dcl 52 set ref 123* 124* fx 000124 automatic fixed bin(17,0) dcl 52 set ref 124* 125 126 128 hbound builtin function dcl 65 ref 276 i 000125 automatic fixed bin(17,0) dcl 52 set ref 103* 104* 203* 204 219* ifp 000100 automatic pointer dcl 52 set ref 125* 130 143* in_file_ptr 000136 automatic pointer dcl 2-75 set ref 89* 100 100 112* 114 116 116 125 162* 171 207 index_to_field_id 24 based offset array level 2 dcl 2-79 ref 204 207 infidp 000200 automatic pointer dcl 200 set ref 207* 208 inftptr 000102 automatic pointer dcl 52 set ref 100* 102 103 108 155 201 206 207 211 input_file based structure level 1 dcl 2-14 input_record based structure level 1 dcl 2-50 irp 000104 automatic pointer dcl 52 set ref 116* 119 125 162* 167 171* 171 j 000126 automatic fixed bin(17,0) dcl 52 set ref 206* 207 210 211* lbound builtin function dcl 65 ref 123 276 length builtin function dcl 65 ref 233 233 286 lister_codes_$master_not_like_update 000010 external static fixed bin(35,0) dcl 37 ref 201 216 lister_copy_file_head_ 000012 constant entry external dcl 1-52 ref 112 lister_create_record_ 000014 constant entry external dcl 1-70 ref 271 lister_create_record_$retain_uid 000016 constant entry external dcl 1-83 ref 269 lower_case 000017 constant char(26) initial dcl 70 ref 238 239 max_field_index 0(18) based fixed bin(17,0) level 2 in structure "field_table" packed unaligned dcl 2-79 in procedure "lister_merge_" ref 102 103 108 155 201 201 203 206 211 max_field_index 1(24) based fixed bin(12,0) level 2 in structure "input_record" packed unsigned unaligned dcl 2-50 in procedure "lister_merge_" ref 276 merge_type 000130 automatic fixed bin(17,0) dcl 52 set ref 92* 135 140 144 150 160 n_fields 000131 automatic fixed bin(17,0) dcl 52 set ref 93* 123 next based offset level 2 in structure "update_record" dcl 2-57 in procedure "lister_merge_" ref 193 next based offset level 2 in structure "input_record" dcl 2-50 in procedure "lister_merge_" ref 171 next_uid 5 based fixed bin(24,0) level 2 in structure "output_file" unsigned dcl 2-38 in procedure "lister_merge_" set ref 114* next_uid 5 based fixed bin(24,0) level 2 in structure "input_file" unsigned dcl 2-14 in procedure "lister_merge_" ref 114 null builtin function dcl 65 ref 99 119 119 126 130 130 137 153 279 284 out_atomp 000262 automatic pointer dcl 260 set ref 287* 288 289 out_file_ptr 000142 automatic pointer dcl 2-75 set ref 91* 112* 114 269* 271* 287 289 out_rp 000260 automatic pointer dcl 260 set ref 269* 271* 289 output_file based structure level 1 dcl 2-38 output_record based structure level 1 dcl 2-64 p1 parameter pointer dcl 229 ref 224 233 238 p2 parameter pointer dcl 229 ref 224 233 239 pointer builtin function dcl 65 ref 204 207 281 283 previous_irp 000110 automatic pointer dcl 52 set ref 99* 167* record_head 1 based offset level 2 in structure "update_file" dcl 2-26 in procedure "lister_merge_" ref 117 record_head 1 based offset level 2 in structure "input_file" dcl 2-14 in procedure "lister_merge_" ref 116 recordp 000140 automatic pointer dcl 2-75 set ref 266* 269 276 276 281 283 rel 000132 automatic fixed bin(17,0) dcl 52 set ref 134* 139* 143* 144 149* 152* 158* 175 183 189 s1 000100 automatic char dcl 233 set ref 238* 241 243 s2 000100 automatic char dcl 233 set ref 239* 241 243 size 1(18) based fixed bin(17,0) level 2 packed unaligned dcl 2-89 ref 208 208 string 2 based char level 2 packed unaligned dcl 2-89 ref 208 208 translate builtin function dcl 65 ref 238 239 ufp 000112 automatic pointer dcl 52 set ref 126* 128* 130 137 143* uid 1 based fixed bin(24,0) level 2 packed unsigned unaligned dcl 2-50 set ref 269* up_file_ptr 000144 automatic pointer dcl 2-75 set ref 90* 101 101 117 117 128 180* 193 204 277 update_file based structure level 1 dcl 2-26 update_record based structure level 1 dcl 2-57 upfidp 000202 automatic pointer dcl 200 set ref 204* 208 upftptr 000114 automatic pointer dcl 52 set ref 101* 201 203 204 upper_case 000010 constant char(26) initial dcl 70 ref 238 239 urp 000116 automatic pointer dcl 52 set ref 117* 119 128 153 180* 193* 193 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. ANY_FIELD internal static fixed bin(8,0) initial dcl 2-183 MERGE_ADD internal static fixed bin(17,0) initial dcl 2-210 MERGE_AND internal static fixed bin(17,0) initial dcl 2-210 MERGE_OR internal static fixed bin(17,0) initial dcl 2-210 MERGE_SUBTRACT internal static fixed bin(17,0) initial dcl 2-210 MIN_FIELD_INDEX internal static fixed bin(17,0) initial dcl 2-135 NULL_FIELD internal static fixed bin(8,0) initial dcl 2-183 NUMERIC_FIELD internal static fixed bin(8,0) initial dcl 2-183 PUT_ARGUMENT internal static fixed bin(17,0) initial dcl 2-100 PUT_DATE internal static fixed bin(17,0) initial dcl 2-100 PUT_END internal static fixed bin(17,0) initial dcl 2-100 PUT_LITERAL internal static fixed bin(17,0) initial dcl 2-100 PUT_RECORD_COUNT internal static fixed bin(17,0) initial dcl 2-100 PUT_SPACES internal static fixed bin(17,0) initial dcl 2-100 PUT_TIME internal static fixed bin(17,0) initial dcl 2-100 PUT_UID internal static fixed bin(17,0) initial dcl 2-100 SELECT_AND internal static bit(9) initial dcl 2-164 SELECT_BEG internal static bit(9) initial dcl 2-164 SELECT_END internal static bit(9) initial dcl 2-164 SELECT_EQ internal static bit(9) initial dcl 2-164 SELECT_FIND internal static bit(9) initial dcl 2-164 SELECT_GE internal static bit(9) initial dcl 2-164 SELECT_GT internal static bit(9) initial dcl 2-164 SELECT_LE internal static bit(9) initial dcl 2-164 SELECT_LT internal static bit(9) initial dcl 2-164 SELECT_NEQ internal static bit(9) initial dcl 2-164 SELECT_NGE internal static bit(9) initial dcl 2-164 SELECT_NGT internal static bit(9) initial dcl 2-164 SELECT_NLE internal static bit(9) initial dcl 2-164 SELECT_NLT internal static bit(9) initial dcl 2-164 SELECT_NOT internal static bit(9) initial dcl 2-164 SELECT_OR internal static bit(9) initial dcl 2-164 UID internal static fixed bin(8,0) initial dcl 2-183 area_ptr automatic pointer dcl 2-96 center internal static bit(2) initial dcl 2-129 element automatic structure level 1 dcl 2-143 fidp automatic pointer dcl 2-75 field_table_ptr automatic pointer dcl 2-75 flush_left internal static bit(2) initial dcl 2-129 flush_right internal static bit(2) initial dcl 2-129 format_table based structure level 1 dcl 2-111 format_table_ptr automatic pointer dcl 2-75 list_node based structure level 1 dcl 2-137 lister_assign_ 000000 constant entry external dcl 1-13 lister_compare_field_tables_ 000000 constant entry external dcl 1-63 lister_compile_listin_ 000000 constant entry external dcl 1-20 lister_compile_select_ 000000 constant entry external dcl 1-30 lister_compile_sort_ 000000 constant entry external dcl 1-39 lister_convert_ 000000 constant entry external dcl 1-48 lister_copy_records_ 000000 constant entry external dcl 1-57 lister_create_record_$after 000000 constant entry external dcl 1-76 lister_delete_ 000000 constant entry external dcl 1-90 lister_expand_ 000000 constant entry external dcl 1-95 lister_file_version_2 internal static fixed bin(17,0) initial dcl 2-11 lister_format_parse_ 000000 constant entry external dcl 1-119 lister_hash_fid_ 000000 constant entry external dcl 1-105 lister_hash_fid_$enter 000000 constant entry external dcl 1-112 lister_merge_ 000000 constant entry external dcl 1-128 lister_print_ 000000 constant entry external dcl 1-139 lister_select_ 000000 constant entry external dcl 1-154 lister_sort_ 000000 constant entry external dcl 1-162 lister_status_ 000000 constant entry external dcl 1-167 literal_table based structure level 1 dcl 2-124 ltp automatic pointer dcl 2-75 n automatic fixed bin(17,0) dcl 2-75 n_items_to_sort automatic fixed bin(17,0) dcl 2-198 numeric_atom based structure level 1 dcl 2-190 numeric_flag internal static fixed bin(35,0) initial dcl 2-194 operand1 defined fixed bin(17,0) dcl 2-143 operand2 defined fixed bin(17,0) dcl 2-143 select_expression based structure level 1 dcl 2-143 select_ptr automatic pointer dcl 2-75 sort_list based structure level 1 dcl 2-201 sort_list_ptr automatic pointer dcl 2-198 system_area based area(261120) dcl 2-95 NAMES DECLARED BY EXPLICIT CONTEXT. compare 000557 constant entry internal dcl 224 ref 143 compare_field_tables 000445 constant entry internal dcl 198 ref 106 copy_record 000663 constant entry internal dcl 249 ref 162 180 discard_input 000411 constant label dcl 167 ref 183 discard_update 000436 constant label dcl 193 ref 181 187 lister_merge_ 000053 constant entry external dcl 31 match 000000 constant label array(0:3) dcl 162 ref 150 merge_loop 000216 constant label dcl 119 ref 173 196 no_match 000004 constant label array(0:3) dcl 175 ref 135 140 144 160 write_input 000405 constant label dcl 162 set ref 175 189 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1350 1370 1251 1360 Length 1610 1251 20 204 77 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME lister_merge_ 212 external procedure is an external procedure. compare_field_tables internal procedure shares stack frame of external procedure lister_merge_. compare 72 internal procedure uses auto adjustable storage. copy_record internal procedure shares stack frame of external procedure lister_merge_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME compare 000100 s2 compare 000100 s1 compare lister_merge_ 000100 ifp lister_merge_ 000102 inftptr lister_merge_ 000104 irp lister_merge_ 000106 equiv_table_ptr lister_merge_ 000110 previous_irp lister_merge_ 000112 ufp lister_merge_ 000114 upftptr lister_merge_ 000116 urp lister_merge_ 000120 counts lister_merge_ 000123 flx lister_merge_ 000124 fx lister_merge_ 000125 i lister_merge_ 000126 j lister_merge_ 000127 equiv lister_merge_ 000130 merge_type lister_merge_ 000131 n_fields lister_merge_ 000132 rel lister_merge_ 000133 atom_length lister_merge_ 000134 atomp lister_merge_ 000136 in_file_ptr lister_merge_ 000140 recordp lister_merge_ 000142 out_file_ptr lister_merge_ 000144 up_file_ptr lister_merge_ 000200 infidp compare_field_tables 000202 upfidp compare_field_tables 000256 filep copy_record 000260 out_rp copy_record 000262 out_atomp copy_record 000264 fieldx copy_record THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_cs call_ext_out call_int_this return alloc_auto_adj shorten_stack ext_entry_desc int_entry pointer_hard offset_hard alloc_based alloc_based_storage free_based THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. lister_copy_file_head_ lister_create_record_ lister_create_record_$retain_uid THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. lister_codes_$master_not_like_update LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 31 000044 2 71 000060 89 000061 90 000065 91 000070 92 000073 93 000075 94 000077 96 000100 97 000101 98 000102 99 000103 100 000105 101 000111 102 000115 103 000124 104 000135 105 000140 106 000142 107 000143 108 000146 109 000154 112 000170 114 000201 116 000205 117 000211 119 000216 123 000226 124 000237 125 000252 126 000260 128 000267 130 000275 134 000306 135 000310 136 000312 137 000313 139 000317 140 000321 143 000323 144 000335 147 000342 149 000344 150 000346 152 000350 153 000353 155 000357 156 000365 158 000401 160 000403 162 000405 167 000411 171 000413 172 000420 173 000421 175 000422 180 000424 181 000430 183 000431 187 000433 189 000434 193 000436 195 000443 196 000444 198 000445 201 000446 203 000464 204 000473 205 000501 206 000503 207 000513 208 000521 210 000530 211 000532 213 000536 214 000540 216 000543 217 000547 219 000550 220 000553 221 000555 224 000556 233 000564 238 000605 239 000622 241 000640 243 000652 245 000657 249 000663 266 000665 267 000670 269 000673 271 000712 276 000723 277 000733 279 000740 281 000747 282 000755 283 000756 284 000765 286 000770 287 000772 288 001003 289 001014 291 001023 293 001025 294 001026 ----------------------------------------------------------- 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