COMPILATION LISTING OF SEGMENT lister_select_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell Multics Op. - System M Compiled on: 11/05/84 1152.5 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 /* Program to search a Lister file and create a list of those records which 19* match the search criteria. 20* 21* Written by Paul A. Green, July 29, 1973. 22* Modified 740604 by PG to finish implementation. 23* Modified 740605 by PG to get around pl1_operators_ bug in converting packed ptr to offset. 24* Modified 740731 by PG to return number of records found. 25* Modified 741110 by PG to add delete option. 26* Modified 761105 by PG to rename from assist_search_ to lister_select_. 27* Modified 770718 by PG to have a null select_ptr mean select everything, and to take advantage of n_records. 28* Modified 770921 by PG to get program to agree with revised documentation. 29* Modified 791128 by PG to add numeric selection (sugg 037) 30* Modified 800813 by PB to handle :uid. 31* Modified 800326 by PB to make less and greater completely case-sensitive. 32* Modified 810805 by PB to compare numerically on ":uid less/greater NNN" 33* Modified 811022 by PB to make 0-length fields match :null 34* Modified 840523 by PB to add begins and ends operators. 35**/ 36 37 /* format: style3 */ 38 lister_select_: 39 procedure (bv_in_file_ptr, bv_select_ptr, bv_area_ptr, bv_selected_records_ptr) returns (fixed bin) 40 options (packed_decimal); 41 42 /* parameters */ 43 44 dcl ( 45 bv_in_file_ptr ptr, 46 bv_select_ptr ptr, 47 bv_area_ptr ptr, 48 bv_selected_records_ptr 49 ptr 50 ) parameter; 51 52 /* automatic */ 53 54 declare (expr_succeeded_ptr, found_list_ptr, lp, p, selected_records_ptr) 55 ptr, 56 (n_records, i, j, k, select_depth) 57 fixed bin; 58 59 /* based */ 60 61 declare expression_succeeded 62 (select_depth) bit (1) aligned based (expr_succeeded_ptr), 63 found_list (n_records) ptr unaligned based (found_list_ptr); 64 65 /* builtins */ 66 67 declare (binary, bool, convert, hbound, index, lbound, length, null, ptr, translate) 68 builtin; 69 70 /* conditions */ 71 72 declare (cleanup, conversion) 73 condition; 74 75 /* internal static initial */ 76 77 declare ( 78 lower_case char (26) aligned initial ("abcdefghijklmnopqrstuvwxyz"), 79 upper_case char (26) aligned initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ") 80 ) internal static; 81 82 /* include files */ 83 1 1 /* ====== BEGIN INCLUDE FILE lister_structures.incl.pl1 ================================ */ 1 2 1 3 /* 1 4* Modified 800813 by PB to add PUT_UID to listform declarations. 1 5* Modified 800825 by PB for version 2 lister file. 1 6* Modified 840523 by PB to add SELECT_BEG and SELECT_END. 1 7**/ 1 8 /* MASTER DECLARATIONS */ 1 9 1 10 /* format: style3 */ 1 11 dcl lister_file_version_2 1 12 fixed bin initial (2) internal static options (constant); 1 13 1 14 dcl 1 input_file based (in_file_ptr) aligned, 1 15 2 ( 1 16 field_table_offset, 1 17 record_head, 1 18 record_tail, 1 19 unused (2) 1 20 ) offset (input_file.area), 1 21 2 next_uid fixed bin (24) unsigned, 1 22 2 version fixed bin, 1 23 2 n_records fixed bin (17), 1 24 2 area area (261112); 1 25 1 26 dcl 1 update_file based (up_file_ptr) aligned, 1 27 2 ( 1 28 field_table_offset, 1 29 record_head, 1 30 record_tail, 1 31 unused (2) 1 32 ) offset (update_file.area), 1 33 2 next_uid fixed bin (24) unsigned, 1 34 2 version fixed bin, 1 35 2 n_records fixed bin (17), 1 36 2 area area (261112); 1 37 1 38 dcl 1 output_file based (out_file_ptr) aligned, 1 39 2 ( 1 40 field_table_offset, 1 41 record_head, 1 42 record_tail, 1 43 unused (2) 1 44 ) offset (output_file.area), 1 45 2 next_uid fixed bin (24) unsigned, 1 46 2 version fixed bin, 1 47 2 n_records fixed bin (17), 1 48 2 area area (261112); 1 49 1 50 dcl 1 input_record based (recordp) aligned, 1 51 2 next offset (input_file.area), 1 52 2 uid fixed bin (24) unsigned unaligned, 1 53 2 max_field_index fixed bin (12) unsigned unaligned, 1 54 2 field dim (0:field_table.max_field_index refer (input_record.max_field_index)) 1 55 offset (input_file.area); 1 56 1 57 dcl 1 update_record based aligned, 1 58 2 next offset (update_file.area), 1 59 2 uid fixed bin (24) unsigned unaligned, 1 60 2 max_field_index fixed bin (12) unsigned unaligned, 1 61 2 field dim (0:field_table.max_field_index refer (update_record.max_field_index)) 1 62 offset (update_file.area); 1 63 1 64 dcl 1 output_record based aligned, 1 65 2 next offset (output_file.area), 1 66 2 uid fixed bin (24) unsigned unaligned, 1 67 2 max_field_index fixed bin (12) unsigned unaligned, 1 68 2 field dim (0:field_table.max_field_index refer (output_record.max_field_index)) 1 69 offset (output_file.area); 1 70 1 71 dcl atom char (atom_length) based (atomp) varying aligned, 1 72 atom_length fixed bin initial (0), /* for table option */ 1 73 atomp ptr; 1 74 1 75 dcl (fidp, field_table_ptr, format_table_ptr, in_file_ptr, ltp, recordp, select_ptr, out_file_ptr, up_file_ptr) 1 76 ptr, 1 77 n fixed bin; 1 78 1 79 dcl 1 field_table based (field_table_ptr) aligned, 1 80 2 record_delimiter 1 81 unal char (1), 1 82 2 field_delimiter unal char (1), 1 83 2 max_field_index unal fixed bin (17), 1 84 2 hash_field_id_to_index 1 85 dimension (0:18) offset, 1 86 2 index_to_field_id 1 87 dimension (0:n refer (field_table.max_field_index)) offset; 1 88 1 89 dcl 1 field_identifier based (fidp) aligned, 1 90 2 next offset, 1 91 2 field_index unal fixed bin (17), 1 92 2 size unal fixed bin (17), 1 93 2 string unal char (n refer (field_identifier.size)); 1 94 1 95 dcl system_area area (261120) based (area_ptr); 1 96 dcl area_ptr ptr; 1 97 1 98 /* LISTFORM DECLARATIONS */ 1 99 1 100 declare ( 1 101 PUT_LITERAL initial (-1), 1 102 PUT_SPACES initial (-2), 1 103 PUT_END initial (-3), 1 104 PUT_DATE initial (-4), 1 105 PUT_TIME initial (-5), 1 106 PUT_RECORD_COUNT initial (-6), 1 107 PUT_ARGUMENT initial (-7), 1 108 PUT_UID initial (-8) 1 109 ) fixed bin internal static; 1 110 1 111 dcl 1 format_table aligned based (format_table_ptr), 1 112 2 size fixed bin (17) unal, 1 113 2 before fixed bin (17) unal, 1 114 2 after fixed bin (17) unal, 1 115 2 record fixed bin (17) unal, 1 116 2 literal_table ptr, 1 117 2 item dim (n refer (format_table.size)), 1 118 3 action fixed bin (17) unal, 1 119 3 justification bit (2) unal, 1 120 3 argument_number 1 121 fixed bin (15) unal, 1 122 3 width fixed bin (21); 1 123 1 124 dcl 1 literal_table aligned based (ltp), 1 125 2 size fixed bin, /* number of slots allocated */ 1 126 2 n_literals fixed bin, /* number of slots in use */ 1 127 2 literal dim (n refer (literal_table.size)) ptr unal; 1 128 1 129 dcl ( 1 130 flush_left initial ("00"b), 1 131 center initial ("01"b), 1 132 flush_right initial ("10"b) 1 133 ) bit (2) aligned internal static options (constant); 1 134 1 135 dcl MIN_FIELD_INDEX fixed bin initial (0) internal static options (constant); 1 136 1 137 dcl 1 list_node aligned based, 1 138 2 size fixed bin, 1 139 2 list dimension (n refer (list_node.size)) ptr; 1 140 1 141 /* SELECT DECLARATIONS */ 1 142 1 143 dcl 1 select_expression based (select_ptr) aligned, 1 144 2 literal_table_ptr 1 145 ptr, 1 146 2 size fixed bin, 1 147 2 last_element fixed bin, 1 148 2 element dim (n refer (select_expression.size)), 1 149 3 opcode unal bit (9), 1 150 3 not unal bit (1), 1 151 3 top unal bit (1), 1 152 3 unused unal bit (7), 1 153 3 field_index unal fixed bin (8), 1 154 3 literal_index unal fixed bin (8), 1 155 1 element aligned, 1 156 2 opcode fixed bin, 1 157 2 not bit (1) aligned, 1 158 2 top bit (1) aligned, 1 159 2 field_index fixed bin, 1 160 2 literal_index fixed bin, 1 161 operand1 fixed bin defined (element.field_index), 1 162 operand2 fixed bin defined (element.literal_index); 1 163 1 164 dcl ( 1 165 SELECT_AND init ("000000001"b), 1 166 SELECT_OR init ("000000010"b), 1 167 SELECT_NOT init ("000000011"b), 1 168 SELECT_FIND init ("000000100"b), 1 169 SELECT_EQ init ("000000101"b), 1 170 SELECT_LT init ("000000110"b), 1 171 SELECT_GT init ("000000111"b), 1 172 SELECT_LE init ("000001000"b), 1 173 SELECT_GE init ("000001001"b), 1 174 SELECT_NEQ init ("000001010"b), 1 175 SELECT_NLT init ("000001011"b), 1 176 SELECT_NGT init ("000001100"b), 1 177 SELECT_NLE init ("000001101"b), 1 178 SELECT_NGE init ("000001110"b), 1 179 SELECT_BEG init ("000001111"b), 1 180 SELECT_END init ("000010000"b) 1 181 ) bit (9) aligned internal static; 1 182 1 183 dcl ( 1 184 ANY_FIELD init (-1), 1 185 NULL_FIELD init (-2), 1 186 NUMERIC_FIELD init (-3), 1 187 UID init (-4) 1 188 ) aligned fixed bin (8) static; 1 189 1 190 dcl 1 numeric_atom aligned based (atomp), 1 191 2 flag fixed bin (35), /* must be -1 */ 1 192 2 value float dec (29) unal; 1 193 1 194 dcl numeric_flag fixed bin (35) internal static initial (-1) options (constant); 1 195 1 196 /* SORT DECLARATIONS */ 1 197 1 198 declare n_items_to_sort fixed bin, 1 199 sort_list_ptr ptr; 1 200 1 201 declare 1 sort_list aligned based (sort_list_ptr), 1 202 2 n_keys fixed bin, 1 203 2 key (n_items_to_sort refer (sort_list.n_keys)), 1 204 3 field_index fixed bin, 1 205 3 ascending bit (1) aligned, 1 206 3 numeric bit (1) aligned; 1 207 1 208 /* MERGE DECLARATIONS */ 1 209 1 210 dcl ( 1 211 MERGE_ADD init (0), 1 212 MERGE_AND init (1), 1 213 MERGE_OR init (2), 1 214 MERGE_SUBTRACT init (3) 1 215 ) fixed bin internal static options (constant); 1 216 1 217 /* ------ END INCLUDE FILE lister_structures.incl.pl1 -------------------------------- */ 84 85 86 /* program */ 87 88 in_file_ptr = bv_in_file_ptr; 89 select_ptr = bv_select_ptr; 90 area_ptr = bv_area_ptr; 91 expr_succeeded_ptr = null; 92 found_list_ptr = null; 93 selected_records_ptr = null; 94 n_records = input_file.n_records; 95 96 on cleanup call cleanup_handler ("1"b); 97 98 if select_ptr = null /* flag to mean select all records */ 99 then do; 100 n = n_records; 101 102 if n = 0 103 then do; 104 bv_selected_records_ptr = null; 105 return (0); 106 end; 107 108 allocate list_node in (system_area) set (selected_records_ptr); 109 110 k = 0; 111 do recordp = input_file.record_head repeat input_record.next while (recordp ^= null); 112 k = k + 1; 113 selected_records_ptr -> list_node.list (k) = recordp; 114 end; 115 116 bv_selected_records_ptr = selected_records_ptr; 117 return (k); 118 end; 119 120 k = 0; 121 allocate found_list in (system_area) set (found_list_ptr); 122 123 ltp = select_expression.literal_table_ptr; 124 select_depth = select_expression.size; 125 allocate expression_succeeded in (system_area) set (expr_succeeded_ptr); 126 127 /* Main loop...inspect each record in the file. Test it against the selection criteria. 128* If the expression evaluates to "1"b, add it to the list of selected records. */ 129 130 /* Note that the collating sequence explicitly includes null fields...they come before non-null fields. */ 131 132 on conversion 133 begin; 134 expression_succeeded (i) = "0"b; 135 go to op_end; 136 end; 137 138 do recordp = input_file.record_head repeat recordp -> input_record.next while (recordp ^= null); 139 140 do i = lbound (select_expression.element (*), 1) to select_expression.last_element; 141 142 element.opcode = binary (select_expression.element (i).opcode, 9); 143 element.not = select_expression.element (i).not; 144 element.top = select_expression.element (i).top; 145 element.field_index = select_expression.element (i).field_index; 146 element.literal_index = select_expression.element (i).literal_index; 147 148 expression_succeeded (i) = "0"b; 149 150 go to op (element.opcode); /* fan out to correct operator */ 151 /* Note that 8, 9, 13 & 14 are not possible. */ 152 153 op (4): /* CONTAINS */ 154 op (15): /* BEGINS */ 155 op (16): /* ENDS */ 156 157 if element.field_index >= 0 /* FINDEX [NOT] CONTAINS/BEGINS/ENDS LITERAL */ 158 then do; 159 p = input_record.field (element.field_index); 160 lp = ltp -> literal_table.literal (element.literal_index); 161 162 if p = null 163 then expression_succeeded (i) = element.not; 164 else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b); 165 /* bool with "0110"b => (a & ^b) | (^a & b) */ 166 end; 167 else if element.field_index = UID /* UID [NOT] CONTAINS/BEGINS/ENDS LITERAL */ 168 then expression_succeeded (i) = ^element.not; 169 else do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i)); 170 p = input_record.field (j); /* ANYFIELD [NOT] CONTAINS/BEGINS/ENDS LITERAL */ 171 lp = ltp -> literal_table.literal (element.literal_index); 172 173 if p = null 174 then expression_succeeded (i) = element.not; 175 else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b); 176 end; 177 go to op_end; 178 179 op (1): /* AND */ 180 expression_succeeded (i) = expression_succeeded (operand1) & expression_succeeded (operand2); 181 go to op_end; 182 183 op (2): /* OR */ 184 expression_succeeded (i) = expression_succeeded (operand1) | expression_succeeded (operand2); 185 go to op_end; 186 187 op (3): /* NOT */ 188 expression_succeeded (i) = ^expression_succeeded (operand1); 189 go to op_end; 190 191 op (5): /* EQUAL */ 192 op (10): /* NEQUAL */ 193 if element.literal_index = NULL_FIELD /* ... EQUAL NULL */ 194 then if element.field_index >= 0 /* FINDEX [NOT] EQUAL NULL */ 195 then expression_succeeded (i) = 196 bool (element.not, compare (0, ptr (input_record.field (element.field_index), input_file.area), null), "0110"b); 197 else if element.field_index = UID /* UID [NOT] EQUAL NULL */ 198 then expression_succeeded (i) = element.not; 199 else /* ANYFIELD [NOT] EQUAL NULL */ 200 do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i)); 201 expression_succeeded (i) = bool (element.not, compare (0, ptr (input_record.field (j), input_file.area), null), "0110"b); 202 end; 203 else if element.literal_index = NUMERIC_FIELD 204 /* ... [NOT] NEQUAL :NUMERIC */ 205 then if element.field_index >= 0 /* FINDEX [NOT] NEQUAL :NUMERIC */ 206 then do; 207 p = input_record.field (element.field_index); 208 expression_succeeded (i) = bool (element.not, valid_number (p), "0110"b); 209 end; 210 else if element.field_index = UID /* UID [NOT] NEQUAL :NUMERIC */ 211 then expression_succeeded (i) = ^element.not; 212 else do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i)); 213 /* :ANY [NOT] NEQUAL :NUMERIC */ 214 p = input_record.field (j); 215 expression_succeeded (i) = bool (element.not, valid_number (p), "0110"b); 216 end; 217 else if element.field_index >= 0 /* FINDEX [NOT] EQUAL LITERAL */ 218 | element.field_index = UID /* UID [NOT] LITERAL */ 219 then do; 220 if element.field_index ^= UID 221 then p = input_record.field (element.field_index); 222 lp = ltp -> literal_table.literal (element.literal_index); 223 224 if p = null 225 then expression_succeeded (i) = element.not; 226 else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b); 227 end; 228 else /* ANYFIELD [NOT] EQUAL LITERAL */ 229 do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i)); 230 p = input_record.field (j); 231 lp = ltp -> literal_table.literal (element.literal_index); 232 233 if p = null 234 then expression_succeeded (i) = element.not; 235 else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b); 236 end; 237 go to op_end; 238 239 op (6): /* LESS */ 240 op (11): /* NLESS */ 241 if element.field_index >= 0 /* FINDEX [NOT] LESS LITERAL */ 242 | element.field_index = UID /* UID [NOT] LESS LITERAL */ 243 then do; 244 if element.field_index ^= UID 245 then p = input_record.field (element.field_index); 246 lp = ltp -> literal_table.literal (element.literal_index); 247 248 if p = null 249 then expression_succeeded (i) = ^element.not; 250 else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b); 251 end; 252 else /* ANYFIELD [NOT] LESS LITERAL */ 253 do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i)); 254 p = input_record.field (j); 255 lp = ltp -> literal_table.literal (element.literal_index); 256 257 if p = null 258 then expression_succeeded (i) = ^element.not; 259 else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b); 260 end; 261 go to op_end; 262 263 op (7): /* GREATER */ 264 op (12): /* NGREATER */ 265 if element.field_index >= 0 /* FINDEX [NOT] GREATER LITERAL */ 266 | element.field_index = UID /* UID [NOT] GREATER LITERAL */ 267 then do; 268 if element.field_index ^= UID 269 then p = input_record.field (element.field_index); 270 lp = ltp -> literal_table.literal (element.literal_index); 271 272 if p = null 273 then expression_succeeded (i) = element.not; 274 else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b); 275 end; 276 else /* ANYFIELD [NOT] GREATER LITERAL */ 277 do j = 0 to hbound (input_record.field, 1) while (^expression_succeeded (i)); 278 p = input_record.field (j); 279 lp = ltp -> literal_table.literal (element.literal_index); 280 281 if p = null 282 then expression_succeeded (i) = element.not; 283 else expression_succeeded (i) = bool (element.not, compare (element.opcode, p, lp), "0110"b); 284 end; 285 go to op_end; 286 287 op_end: 288 end; /* of expression evaluation loop */ 289 290 if expression_succeeded (i - 1) /* last expression */ 291 then do; 292 k = k + 1; 293 found_list (k) = recordp; 294 end; 295 end; /* of record loop */ 296 297 if k ^= 0 298 then do; 299 n = k; 300 allocate list_node in (system_area) set (selected_records_ptr); 301 302 do i = 1 to k; 303 selected_records_ptr -> list_node.list (i) = found_list (i); 304 end; 305 end; 306 307 bv_selected_records_ptr = selected_records_ptr; 308 call cleanup_handler ("0"b); 309 return (k); 310 311 compare: 312 procedure (bv_compare_type, bv_fp, bv_lp) returns (bit (1) aligned); 313 314 /* parameters */ 315 316 declare ( 317 bv_compare_type fixed bin, 318 bv_fp ptr, 319 bv_lp ptr 320 ) parameter; 321 322 /* automatic */ 323 324 declare field_value_len fixed bin (21), 325 literal_value_len fixed bin (21), 326 numeric_field_value float dec (29) unal; 327 328 /* based */ 329 330 declare field_value char (field_value_len) varying based (bv_fp), 331 literal_value char (literal_value_len) varying based (bv_lp), 332 1 numeric_literal aligned based (bv_lp), 333 2 flag fixed bin (35), 334 2 value float dec (29) unal; 335 336 /* program */ 337 338 if bv_compare_type = 0 339 then goto compare_type (0); 340 literal_value_len = length (literal_value); 341 if element.field_index = UID 342 then goto compare_uid (bv_compare_type); /* Note that 1-4, 8, 9 are not possible */ 343 field_value_len = length (field_value); 344 go to compare_type (bv_compare_type); /* Note that 1-3, 8, 9 are not possible */ 345 346 compare_type (0): /* NULL */ 347 if bv_fp = null 348 then return ("1"b); /* either a null field */ 349 field_value_len = length (field_value); 350 if field_value_len = 0 /* or a zero length field */ 351 then return ("1"b); /* should match :null */ 352 else return ("0"b); 353 354 compare_type (4): /* CONTAINS */ 355 return (index (translate (field_value, lower_case, upper_case), translate (literal_value, lower_case, upper_case)) 356 ^= 0); 357 358 compare_type (15): /* BEGINS */ 359 if literal_value_len > field_value_len 360 then return ("0"b); 361 else return 362 (substr 363 (translate (field_value, lower_case, upper_case), 364 1, 365 literal_value_len) 366 = translate (literal_value, lower_case, upper_case)); 367 368 compare_type (16): /* ENDS */ 369 if literal_value_len > field_value_len 370 then return ("0"b); 371 else return 372 (substr 373 (translate (field_value, lower_case, upper_case), 374 (field_value_len - literal_value_len) + 1, 375 literal_value_len) 376 = translate (literal_value, lower_case, upper_case)); 377 378 compare_type (6): /* LESS */ 379 return (field_value < literal_value); 380 381 compare_type (5): /* EQUAL */ 382 return (field_value = literal_value); 383 384 compare_type (7): /* GREATER */ 385 return (field_value > literal_value); 386 387 (conversion): 388 compare_type (10): /* NEQUAL */ 389 numeric_field_value = convert (numeric_field_value, field_value); 390 return (numeric_field_value = numeric_literal.value); 391 392 (conversion): 393 compare_type (11): /* NLESS */ 394 numeric_field_value = convert (numeric_field_value, field_value); 395 return (numeric_field_value < numeric_literal.value); 396 397 (conversion): 398 compare_type (12): /* NGREATER */ 399 numeric_field_value = convert (numeric_field_value, field_value); 400 return (numeric_field_value > numeric_literal.value); 401 402 compare_uid (5): /* EQUAL */ 403 return (input_record.uid = binary (literal_value)); 404 405 compare_uid (6): /* LESS */ 406 return (input_record.uid < binary (literal_value)); 407 408 compare_uid (7): /* GREATER */ 409 return (input_record.uid > binary (literal_value)); 410 411 compare_uid (10): /* NEQUAL */ 412 return (input_record.uid = numeric_literal.value); 413 414 compare_uid (11): /* NLESS */ 415 return (input_record.uid < numeric_literal.value); 416 417 compare_uid (12): /* NGREATER */ 418 return (input_record.uid > numeric_literal.value); 419 420 end compare; 421 422 valid_number: 423 procedure (P_fp) returns (bit (1) aligned); 424 425 /* parameters */ 426 427 declare P_fp ptr; 428 429 /* automatic */ 430 431 declare field_value_len fixed bin (21), 432 numeric_field_value float dec (29) unal; 433 434 /* based */ 435 436 declare field_value char (field_value_len) varying based (P_fp); 437 438 /* program */ 439 440 if P_fp = null 441 then return ("0"b); 442 443 field_value_len = length (field_value); 444 445 on conversion go to fail; 446 447 numeric_field_value = convert (numeric_field_value, field_value); 448 return ("1"b); 449 450 fail: 451 return ("0"b); 452 453 end valid_number; 454 455 cleanup_handler: 456 procedure (bv_free_selected_records); 457 458 /* parameters */ 459 460 declare bv_free_selected_records 461 bit (1) aligned parameter; 462 463 /* program */ 464 465 if found_list_ptr ^= null 466 then do; 467 free found_list in (system_area); 468 found_list_ptr = null; 469 end; 470 471 if expr_succeeded_ptr ^= null 472 then do; 473 free expression_succeeded in (system_area); 474 expr_succeeded_ptr = null; 475 end; 476 477 if bv_free_selected_records & selected_records_ptr ^= null 478 then do; 479 free selected_records_ptr -> list_node in (system_area); 480 selected_records_ptr = null; 481 end; 482 483 end cleanup_handler; 484 485 end /* lister_select_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/02/84 1204.9 lister_select_.pl1 >special_ldd>online>6883-11/02/84>lister_select_.pl1 84 1 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. NULL_FIELD 002434 constant fixed bin(8,0) initial dcl 1-183 ref 191 NUMERIC_FIELD 002433 constant fixed bin(8,0) initial dcl 1-183 ref 203 P_fp parameter pointer dcl 427 ref 422 440 443 447 UID 002432 constant fixed bin(8,0) initial dcl 1-183 ref 167 197 210 217 220 239 244 263 268 341 area 10 based area(261112) level 2 dcl 1-14 ref 111 114 138 159 170 191 191 201 201 207 214 220 230 244 254 268 278 295 area_ptr 000150 automatic pointer dcl 1-96 set ref 90* 108 121 125 300 467 473 479 atom_length 000134 automatic fixed bin(17,0) initial dcl 1-71 set ref 1-71* binary builtin function dcl 67 ref 142 402 405 408 bool builtin function dcl 67 ref 164 175 191 201 208 215 226 235 250 259 274 283 bv_area_ptr parameter pointer dcl 44 ref 38 90 bv_compare_type parameter fixed bin(17,0) dcl 316 ref 311 338 341 344 bv_fp parameter pointer dcl 316 ref 311 343 346 349 354 361 371 378 381 384 387 392 397 bv_free_selected_records parameter bit(1) dcl 460 ref 455 477 bv_in_file_ptr parameter pointer dcl 44 ref 38 88 bv_lp parameter pointer dcl 316 ref 311 340 354 361 371 378 381 384 390 395 400 402 405 408 411 414 417 bv_select_ptr parameter pointer dcl 44 ref 38 89 bv_selected_records_ptr parameter pointer dcl 44 set ref 38 104* 116* 307* cleanup 000120 stack reference condition dcl 72 ref 96 conversion 000126 stack reference condition dcl 72 ref 132 445 convert builtin function dcl 67 ref 387 392 397 447 element 000152 automatic structure level 1 dcl 1-143 in procedure "lister_select_" element 4 based structure array level 2 in structure "select_expression" dcl 1-143 in procedure "lister_select_" ref 140 expr_succeeded_ptr 000100 automatic pointer dcl 54 set ref 91* 125* 134 148 162 164 167 169 173 175 179 179 179 183 183 183 187 187 191 197 199 201 208 210 212 215 224 226 228 233 235 248 250 252 257 259 272 274 276 281 283 290 471 473 474* expression_succeeded based bit(1) array dcl 61 set ref 125 134* 148* 162* 164* 167* 169 173* 175* 179* 179 179 183* 183 183 187* 187 191* 197* 199 201* 208* 210* 212 215* 224* 226* 228 233* 235* 248* 250* 252 257* 259* 272* 274* 276 281* 283* 290 473 field 2 based offset array level 2 dcl 1-50 ref 159 169 170 191 191 199 201 201 207 212 214 220 228 230 244 252 254 268 276 278 field_index 3 000152 automatic fixed bin(17,0) level 2 in structure "element" dcl 1-143 in procedure "lister_select_" set ref 145* 153 159 167 179 179 183 183 187 187 191 191 191 197 203 207 210 217 217 220 220 239 239 244 244 263 263 268 268 341 field_index 4(18) based fixed bin(8,0) array level 3 in structure "select_expression" packed unaligned dcl 1-143 in procedure "lister_select_" ref 145 field_value based varying char dcl 436 in procedure "valid_number" ref 443 447 field_value based varying char dcl 330 in procedure "compare" ref 343 349 354 361 371 378 381 384 387 392 397 field_value_len 000176 automatic fixed bin(21,0) dcl 324 in procedure "compare" set ref 343* 349* 350 358 368 371 field_value_len 000100 automatic fixed bin(21,0) dcl 431 in procedure "valid_number" set ref 443* found_list based pointer array unaligned dcl 61 set ref 121 293* 303 467 found_list_ptr 000102 automatic pointer dcl 54 set ref 92* 121* 293 303 465 467 468* hbound builtin function dcl 67 ref 169 199 212 228 252 276 i 000113 automatic fixed bin(17,0) dcl 54 set ref 134 140* 142 143 144 145 146 148 162 164 167 169 173 175 179 183 187 191 197 199 201 208 210 212 215 224 226 228 233 235 248 250 252 257 259 272 274 276 281 283* 290 302* 303 303* in_file_ptr 000136 automatic pointer dcl 1-75 set ref 88* 94 111 111 114 138 138 159 170 191 191 201 201 207 214 220 230 244 254 268 278 295 index builtin function dcl 67 ref 354 input_file based structure level 1 dcl 1-14 input_record based structure level 1 dcl 1-50 j 000114 automatic fixed bin(17,0) dcl 54 set ref 169* 170* 199* 201 201* 212* 214* 228* 230* 252* 254* 276* 278* k 000115 automatic fixed bin(17,0) dcl 54 set ref 110* 112* 112 113 117 120* 292* 292 293 297 299 302 309 last_element 3 based fixed bin(17,0) level 2 dcl 1-143 ref 140 lbound builtin function dcl 67 ref 140 length builtin function dcl 67 ref 340 343 349 443 list 2 based pointer array level 2 dcl 1-137 set ref 113* 303* list_node based structure level 1 dcl 1-137 set ref 108 300 479 literal 2 based pointer array level 2 packed unaligned dcl 1-124 ref 160 171 222 231 246 255 270 279 literal_index 4 000152 automatic fixed bin(17,0) level 2 in structure "element" dcl 1-143 in procedure "lister_select_" set ref 146* 160 171 179 179 183 183 191 203 222 231 246 255 270 279 literal_index 4(27) based fixed bin(8,0) array level 3 in structure "select_expression" packed unaligned dcl 1-143 in procedure "lister_select_" ref 146 literal_table based structure level 1 dcl 1-124 literal_table_ptr based pointer level 2 dcl 1-143 ref 123 literal_value based varying char dcl 330 ref 340 354 361 371 378 381 384 402 405 408 literal_value_len 000177 automatic fixed bin(21,0) dcl 324 set ref 340* 358 361 368 371 371 lower_case 000060 constant char(26) initial dcl 77 ref 354 354 361 361 371 371 lp 000104 automatic pointer dcl 54 set ref 160* 164* 171* 175* 222* 226* 231* 235* 246* 250* 255* 259* 270* 274* 279* 283* ltp 000140 automatic pointer dcl 1-75 set ref 123* 160 171 222 231 246 255 270 279 max_field_index 1(24) based fixed bin(12,0) level 2 packed unsigned unaligned dcl 1-50 ref 169 199 212 228 252 276 n 000146 automatic fixed bin(17,0) dcl 1-75 set ref 100* 102 108 108 299* 300 300 n_records 000112 automatic fixed bin(17,0) dcl 54 in procedure "lister_select_" set ref 94* 100 121 467 n_records 7 based fixed bin(17,0) level 2 in structure "input_file" dcl 1-14 in procedure "lister_select_" ref 94 next based offset level 2 dcl 1-50 ref 114 295 not 1 000152 automatic bit(1) level 2 in structure "element" dcl 1-143 in procedure "lister_select_" set ref 143* 162 164 167 173 175 191 197 201 208 210 215 224 226 233 235 248 250 257 259 272 274 281 283 not 4(09) based bit(1) array level 3 in structure "select_expression" packed unaligned dcl 1-143 in procedure "lister_select_" ref 143 null builtin function dcl 67 ref 91 92 93 98 104 111 138 162 173 191 191 201 201 224 233 248 257 272 281 346 440 465 468 471 474 477 480 numeric_field_value 000200 automatic float dec(29) unaligned dcl 324 in procedure "compare" set ref 387* 387 390 392* 392 395 397* 397 400 numeric_field_value 000101 automatic float dec(29) unaligned dcl 431 in procedure "valid_number" set ref 447* 447 numeric_literal based structure level 1 dcl 330 opcode 4 based bit(9) array level 3 in structure "select_expression" packed unaligned dcl 1-143 in procedure "lister_select_" ref 142 opcode 000152 automatic fixed bin(17,0) level 2 in structure "element" dcl 1-143 in procedure "lister_select_" set ref 142* 150 164* 175* 226* 235* 250* 259* 274* 283* operand1 defined fixed bin(17,0) dcl 1-143 ref 179 183 187 operand2 defined fixed bin(17,0) dcl 1-143 ref 179 183 p 000106 automatic pointer dcl 54 set ref 159* 162 164* 170* 173 175* 207* 208* 214* 215* 220* 224 226* 230* 233 235* 244* 248 250* 254* 257 259* 268* 272 274* 278* 281 283* ptr builtin function dcl 67 ref 191 191 201 201 record_head 1 based offset level 2 dcl 1-14 ref 111 138 recordp 000142 automatic pointer dcl 1-75 set ref 111* 111* 113* 114 138* 138* 159 169 170 191 191 199 201 201 207 212 214 220 228 230 244 252 254 268 276 278 293* 295 402 405 408 411 414 417 select_depth 000116 automatic fixed bin(17,0) dcl 54 set ref 124* 125 473 select_expression based structure level 1 dcl 1-143 select_ptr 000144 automatic pointer dcl 1-75 set ref 89* 98 123 124 140 140 142 143 144 145 146 selected_records_ptr 000110 automatic pointer dcl 54 set ref 93* 108* 113 116 300* 303 307 477 479 480* size based fixed bin(17,0) level 2 in structure "list_node" dcl 1-137 in procedure "lister_select_" set ref 108* 300* 479 size 2 based fixed bin(17,0) level 2 in structure "select_expression" dcl 1-143 in procedure "lister_select_" ref 124 system_area based area(261120) dcl 1-95 ref 108 121 125 300 467 473 479 top 4(10) based bit(1) array level 3 in structure "select_expression" packed unaligned dcl 1-143 in procedure "lister_select_" ref 144 top 2 000152 automatic bit(1) level 2 in structure "element" dcl 1-143 in procedure "lister_select_" set ref 144* translate builtin function dcl 67 ref 354 354 361 361 371 371 uid 1 based fixed bin(24,0) level 2 packed unsigned unaligned dcl 1-50 ref 402 405 408 411 414 417 upper_case 000051 constant char(26) initial dcl 77 ref 354 354 361 361 371 371 value 1 based float dec(29) level 2 packed unaligned dcl 330 ref 390 395 400 411 414 417 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. ANY_FIELD internal static fixed bin(8,0) initial dcl 1-183 MERGE_ADD internal static fixed bin(17,0) initial dcl 1-210 MERGE_AND internal static fixed bin(17,0) initial dcl 1-210 MERGE_OR internal static fixed bin(17,0) initial dcl 1-210 MERGE_SUBTRACT internal static fixed bin(17,0) initial dcl 1-210 MIN_FIELD_INDEX internal static fixed bin(17,0) initial dcl 1-135 PUT_ARGUMENT internal static fixed bin(17,0) initial dcl 1-100 PUT_DATE internal static fixed bin(17,0) initial dcl 1-100 PUT_END internal static fixed bin(17,0) initial dcl 1-100 PUT_LITERAL internal static fixed bin(17,0) initial dcl 1-100 PUT_RECORD_COUNT internal static fixed bin(17,0) initial dcl 1-100 PUT_SPACES internal static fixed bin(17,0) initial dcl 1-100 PUT_TIME internal static fixed bin(17,0) initial dcl 1-100 PUT_UID internal static fixed bin(17,0) initial dcl 1-100 SELECT_AND internal static bit(9) initial dcl 1-164 SELECT_BEG internal static bit(9) initial dcl 1-164 SELECT_END internal static bit(9) initial dcl 1-164 SELECT_EQ internal static bit(9) initial dcl 1-164 SELECT_FIND internal static bit(9) initial dcl 1-164 SELECT_GE internal static bit(9) initial dcl 1-164 SELECT_GT internal static bit(9) initial dcl 1-164 SELECT_LE internal static bit(9) initial dcl 1-164 SELECT_LT internal static bit(9) initial dcl 1-164 SELECT_NEQ internal static bit(9) initial dcl 1-164 SELECT_NGE internal static bit(9) initial dcl 1-164 SELECT_NGT internal static bit(9) initial dcl 1-164 SELECT_NLE internal static bit(9) initial dcl 1-164 SELECT_NLT internal static bit(9) initial dcl 1-164 SELECT_NOT internal static bit(9) initial dcl 1-164 SELECT_OR internal static bit(9) initial dcl 1-164 atom based varying char dcl 1-71 atomp automatic pointer dcl 1-71 center internal static bit(2) initial dcl 1-129 fidp automatic pointer dcl 1-75 field_identifier based structure level 1 dcl 1-89 field_table based structure level 1 dcl 1-79 field_table_ptr automatic pointer dcl 1-75 flush_left internal static bit(2) initial dcl 1-129 flush_right internal static bit(2) initial dcl 1-129 format_table based structure level 1 dcl 1-111 format_table_ptr automatic pointer dcl 1-75 lister_file_version_2 internal static fixed bin(17,0) initial dcl 1-11 n_items_to_sort automatic fixed bin(17,0) dcl 1-198 numeric_atom based structure level 1 dcl 1-190 numeric_flag internal static fixed bin(35,0) initial dcl 1-194 out_file_ptr automatic pointer dcl 1-75 output_file based structure level 1 dcl 1-38 output_record based structure level 1 dcl 1-64 sort_list based structure level 1 dcl 1-201 sort_list_ptr automatic pointer dcl 1-198 up_file_ptr automatic pointer dcl 1-75 update_file based structure level 1 dcl 1-26 update_record based structure level 1 dcl 1-57 NAMES DECLARED BY EXPLICIT CONTEXT. cleanup_handler 002123 constant entry internal dcl 455 ref 96 308 compare 001343 constant entry internal dcl 311 ref 164 175 191 201 226 235 250 259 274 283 compare_type 000020 constant label array(0:16) dcl 346 ref 338 344 compare_uid 000041 constant label array(5:12) dcl 402 ref 341 fail 002117 constant label dcl 450 ref 445 lister_select_ 000106 constant entry external dcl 38 op 000000 constant label array(16) dcl 153 ref 150 op_end 001242 constant label dcl 287 ref 135 177 181 185 189 237 261 285 valid_number 002042 constant entry internal dcl 422 ref 208 215 NAME DECLARED BY CONTEXT OR IMPLICATION. substr builtin function ref 361 371 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 2524 2534 2435 2534 Length 2736 2435 10 165 67 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME lister_select_ 314 external procedure is an external procedure. on unit on line 96 72 on unit on unit on line 132 64 on unit compare internal procedure shares stack frame of external procedure lister_select_. valid_number 234 internal procedure enables or reverts conditions. on unit on line 445 64 on unit cleanup_handler 64 internal procedure is called by several nonquick procedures. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME lister_select_ 000100 expr_succeeded_ptr lister_select_ 000102 found_list_ptr lister_select_ 000104 lp lister_select_ 000106 p lister_select_ 000110 selected_records_ptr lister_select_ 000112 n_records lister_select_ 000113 i lister_select_ 000114 j lister_select_ 000115 k lister_select_ 000116 select_depth lister_select_ 000134 atom_length lister_select_ 000136 in_file_ptr lister_select_ 000140 ltp lister_select_ 000142 recordp lister_select_ 000144 select_ptr lister_select_ 000146 n lister_select_ 000150 area_ptr lister_select_ 000152 element lister_select_ 000176 field_value_len compare 000177 literal_value_len compare 000200 numeric_field_value compare valid_number 000100 field_value_len valid_number 000101 numeric_field_value valid_number THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 r_l_a r_g_s r_g_a r_l_s r_e_as r_ne_as alloc_cs call_int_this call_int_other return tra_ext enable shorten_stack ext_entry int_entry pointer_hard index_cs_eis any_to_any_rd any_to_any_tr alloc_based free_based NO EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 38 000101 1 71 000113 88 000114 89 000120 90 000123 91 000126 92 000130 93 000131 94 000132 96 000134 98 000162 100 000166 102 000170 104 000171 105 000174 108 000176 110 000207 111 000210 112 000222 113 000223 114 000227 116 000235 117 000240 120 000243 121 000244 123 000251 124 000254 125 000257 132 000264 134 000300 135 000304 138 000307 140 000320 142 000331 143 000335 144 000342 145 000346 146 000352 148 000356 150 000360 153 000362 159 000364 160 000372 162 000376 164 000404 166 000414 167 000415 169 000423 170 000437 171 000445 173 000451 175 000457 176 000467 177 000471 179 000472 181 000477 183 000500 185 000505 187 000506 189 000512 191 000513 197 000541 199 000546 201 000563 202 000604 203 000607 207 000613 208 000621 209 000637 210 000640 212 000646 214 000663 215 000671 216 000707 217 000712 220 000716 222 000726 224 000732 226 000741 227 000751 228 000752 230 000767 231 000775 233 001001 235 001007 236 001017 237 001021 239 001022 244 001026 246 001036 248 001042 250 001052 251 001062 252 001063 254 001077 255 001105 257 001111 259 001120 260 001130 261 001132 263 001133 268 001137 270 001147 272 001153 274 001162 275 001172 276 001173 278 001207 279 001215 281 001221 283 001227 284 001237 285 001241 287 001242 290 001244 292 001247 293 001250 295 001260 297 001266 299 001270 300 001271 302 001302 303 001311 304 001322 307 001324 308 001327 309 001337 311 001343 338 001345 340 001347 341 001352 343 001357 344 001362 346 001364 349 001373 350 001376 352 001402 354 001404 358 001435 361 001441 368 001473 371 001477 378 001536 381 001550 384 001562 387 001574 390 001605 392 001616 395 001627 397 001640 400 001651 402 001662 405 001705 408 001730 411 001753 414 001775 417 002017 422 002041 440 002047 443 002056 445 002061 447 002100 448 002113 450 002117 455 002122 465 002130 467 002135 468 002137 471 002142 473 002146 474 002150 477 002153 479 002163 480 002170 483 002173 ----------------------------------------------------------- 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