COMPILATION LISTING OF SEGMENT lister_compile_listin_ Compiled by: Multics PL/I Compiler, Release 33a, of May 30, 1990 Compiled at: ACTC Technologies Inc. Compiled on: 10/17/90 0941.9 mdt Wed Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1990 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1981 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* *********************************************************** */ 11 12 13 14 /****^ HISTORY COMMENTS: 15* 1) change(90-08-15,Gray), approve(90-08-15,MCR8157), audit(90-10-12,Bubric), 16* install(90-10-17,MR12.4-1046): 17* Prevent infinite loop when no comment end. Wordpro 1154 18* END HISTORY COMMENTS */ 19 20 21 /* LISTER_COMPILE_LISTIN_ - Program to convert a Lister listin segment into a compiled lister segment. 22* Written 771011 by PG 23* Modified 780407 by PG to fix bug 17 (wrong line number for duplicate fieldnames) 24* Modified 780504 by PG to fix bug 22 (bug in removing doubled quotes) 25* Modified 780909 by PG to keep going after errors in main loop (bug 018), and to fix bug 26* 23 (error msg says line 0 if listin seg begins with delimiter). 27* Modified 800513 by PB to detect missing rdelim after "Records:" 28* Modified 800825 by PB to handle addition of unique ids. 29* Modified 800904 by PB to implement listin comment feature. 30* Modified 801028 by PB to fix bug where infinite loop occurs in reporting error of file ending in 2 rdelims. 31* Modified 801201 by PB to allow non-quoted string to begin with a quote character. 32* Modified 801222 by PB to fix bug where no records causes program to loop. 33* Modified 810213 by PB to fix bug where no colon following Records causes 34* fatal process error or storage condition. 35* Modified 810407 by PB to fix bug where no record_delimiter can cause fatal 36* process error or storage condition. 37* Modified 810501 by PB to fix bug where / character gets lost when using 38* pl1-style comments. 39* Modified 810710 by PB to fix another bug where no record_delimiter can cause 40* fatal process error or storage condition. 41* Modified 811109 by PB to change the calling sequences of comment_scan and 42* comment_end_scan to make them more efficient. 43* Modified 830907 by PB to initialize temp_field_ptr to null. 44* Modified 830907 by PB to fix bug (phx12793) where a file that ends in a 45* fdelim causes an endless loop. 46**/ 47 48 /* format: style3 */ 49 lister_compile_listin_: 50 procedure (bv_out_file_ptr, bv_input_ptr, bv_input_length, bv_area_ptr, bv_n_records, bv_error_token, bv_code) 51 options (packed_decimal); 52 53 /* parameters */ 54 55 declare ( 56 bv_out_file_ptr ptr, 57 bv_input_ptr ptr, /* Input - ptr to listin segment. */ 58 bv_input_length fixed bin (21), /* Input - length in chars of listin segment. */ 59 bv_area_ptr ptr, /* Input - ptr to system free area */ 60 bv_n_records fixed bin, 61 bv_error_token char (*), 62 bv_code fixed bin (35) 63 ) parameter; 64 65 /* automatic */ 66 67 declare cdelim char (1), 68 ce_pos fixed bin, 69 comment_start char (20) varying, 70 commenting bit (1) aligned, 71 comment_pos_adjust fixed bin(21), 72 cs_len fixed bin, 73 cs_start fixed bin, 74 fatal_error bit (1) aligned, 75 fdelim char (1), 76 fdelim_or_rdelim char (2), 77 field_index fixed bin, 78 field_len fixed bin (21), 79 field_ptr ptr, 80 fieldname_start fixed bin (21), 81 in_comment bit (1) aligned, 82 input_length fixed bin (21), 83 input_ptr ptr, 84 keyx fixed bin, 85 more_fields bit (1) aligned, 86 n_fieldnames fixed bin, 87 rdelim char (1), 88 saved_source_index fixed bin (21), 89 scan_index fixed bin (21), 90 source_index fixed bin (21), 91 temp_char char (1), 92 temp_field_len fixed bin (21), 93 temp_field_ptr ptr, 94 temp_temp_field_len fixed bin (21), 95 temp_temp_field_ptr ptr, 96 token char (256) varying, 97 token_start fixed bin (21); 98 99 /* based */ 100 101 declare field_value char (field_len) based (field_ptr), 102 source_string char (input_length) based (input_ptr), 103 source_string_array (input_length) char (1) based (input_ptr), 104 static_buffer char (static_buffer_len) varying based (static_buffer_ptr), 105 temp_field_value char (temp_field_len) based (temp_field_ptr), 106 temp_temp_field_value 107 char (temp_temp_field_len) based (temp_temp_field_ptr); 108 109 /* builtins */ 110 111 declare (addr, addrel, binary, empty, hbound, index, lbound, length, ltrim, maxlength, min, null, offset, pointer, rtrim, 112 search, substr, verify) 113 builtin; 114 115 /* conditions */ 116 117 declare cleanup condition; 118 119 /* entries */ 120 121 declare hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)); 122 123 /* external static */ 124 125 declare ( 126 error_table_$translation_failed, 127 lister_codes_$bad_cdelim, 128 lister_codes_$bad_fdelim, 129 lister_codes_$bad_rdelim, 130 lister_codes_$cdelim_eq_rdelim, 131 lister_codes_$dup_fieldname, 132 lister_codes_$fdelim_eq_cdelim, 133 lister_codes_$fdelim_eq_rdelim, 134 lister_codes_$fieldname_not_alpha_start, 135 lister_codes_$fieldname_not_alphanumeric, 136 lister_codes_$listin_dup_field, 137 lister_codes_$listin_fn_missing_comma, 138 lister_codes_$listin_invalid_char, 139 lister_codes_$listin_misplaced_fieldname, 140 lister_codes_$listin_missing_colon, 141 lister_codes_$listin_missing_fdelim, 142 lister_codes_$listin_missing_fieldnames, 143 lister_codes_$listin_missing_rdelim, 144 lister_codes_$listin_missing_semicolon, 145 lister_codes_$listin_premature_eof, 146 lister_codes_$listin_unknown_fieldname, 147 lister_codes_$listin_unknown_keyword, 148 lister_codes_$long_fdelim, 149 lister_codes_$long_fieldname, 150 lister_codes_$long_rdelim 151 ) fixed bin (35) external static; 152 153 /* internal static */ 154 155 declare ( 156 keywords (9) char (17) varying 157 initial ("Fd", "Field_delimiter", "Rd", "Record_delimiter", "Fn", "Field_names", "Records", "Comment_delimiter", "Cd"), 158 NL_HT_SP_VT_NP char (5) initial (" 159 "), 160 permissible_delimiters 161 char (12) initial ("=%*&!$|^?~#@"), 162 QUOTE char (1) initial (""""), 163 static_buffer_len fixed bin (21) initial (0), 164 static_buffer_ptr ptr initial (null) 165 ) internal static; 166 167 /* include files */ 168 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 ----------------------------------- */ 169 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 -------------------------------- */ 170 171 172 /* program */ 173 174 temp_field_ptr = null (); 175 out_file_ptr = bv_out_file_ptr; 176 input_ptr = bv_input_ptr; 177 input_length = bv_input_length; 178 area_ptr = bv_area_ptr; 179 bv_n_records = 0; 180 bv_code = 0; 181 182 on cleanup 183 call clean_up; 184 185 source_index = 1; 186 fatal_error = "0"b; 187 rdelim = "$"; /* defaults */ 188 fdelim = "="; /* .. */ 189 field_table_ptr = null; /* .. */ 190 commenting = "0"b; /* .. */ 191 in_comment = "0"b; 192 193 /* Initialize output segment */ 194 195 call hcs_$truncate_seg (out_file_ptr, 0, bv_code); 196 if bv_code ^= 0 197 then do; 198 bv_error_token = "Unable to truncate output segment."; 199 go to cleanup_and_return; 200 end; 201 202 output_file.field_table_offset = null; 203 output_file.record_head = null; 204 output_file.record_tail = null; 205 output_file.unused (1) = null; 206 output_file.unused (2) = null; 207 output_file.next_uid = 1; 208 output_file.n_records = 0; 209 output_file.area = empty (); 210 output_file.version = lister_file_version_2; 211 212 op_end: 213 call get_token; 214 215 do keyx = lbound (keywords, 1) to hbound (keywords, 1) while (token ^= keywords (keyx)); 216 end; 217 218 if keyx > hbound (keywords, 1) 219 then do; 220 bv_code = lister_codes_$listin_unknown_keyword; 221 bv_error_token = token || cv_index_to_line (token_start); 222 go to cleanup_and_return; 223 end; 224 225 go to op (keyx); 226 227 op (1): /* Fd */ 228 op (2): /* Field_delimiter */ 229 call get_token; 230 231 if token ^= ":" 232 then go to missing_colon; 233 234 call get_token; 235 236 if length (token) ^= 1 237 then do; 238 bv_code = lister_codes_$long_fdelim; 239 bv_error_token = token || cv_index_to_line (token_start); 240 go to cleanup_and_return; 241 end; 242 243 if verify (token, permissible_delimiters) ^= 0 244 then do; 245 bv_code = lister_codes_$bad_fdelim; 246 bv_error_token = token || cv_index_to_line (token_start); 247 go to cleanup_and_return; 248 end; 249 250 fdelim = token; 251 252 call get_token; 253 if token ^= ";" 254 then go to missing_semicolon; 255 256 go to op_end; 257 258 op (3): /* Rd */ 259 op (4): /* Record_delimiter */ 260 call get_token; 261 262 if token ^= ":" 263 then go to missing_colon; 264 265 call get_token; 266 267 if length (token) ^= 1 268 then do; 269 bv_code = lister_codes_$long_rdelim; 270 bv_error_token = token || cv_index_to_line (token_start); 271 go to cleanup_and_return; 272 end; 273 274 if verify (token, permissible_delimiters) ^= 0 275 then do; 276 bv_code = lister_codes_$bad_rdelim; 277 bv_error_token = token || cv_index_to_line (token_start); 278 go to cleanup_and_return; 279 end; 280 281 rdelim = token; 282 283 call get_token; 284 if token ^= ";" 285 then go to missing_semicolon; 286 287 go to op_end; 288 289 op (8): /* Comment_delimiter */ 290 op (9): /* Cd */ 291 call get_token; 292 293 if token ^= ":" 294 then goto missing_colon; 295 296 call get_token; 297 298 if token = "pl1" 299 then cdelim = "/"; 300 else do; 301 if length (token) ^= 1 | verify (token, permissible_delimiters) ^= 0 302 then do; 303 bv_code = lister_codes_$bad_cdelim; 304 bv_error_token = token || cv_index_to_line (token_start); 305 goto cleanup_and_return; 306 end; 307 cdelim = token; 308 end; 309 310 commenting = "1"b; 311 312 call get_token; 313 if token ^= ";" 314 then goto missing_semicolon; 315 316 goto op_end; 317 318 op (5): /* Fn */ 319 op (6): /* Field_names */ 320 call get_token; 321 322 if token ^= ":" 323 then go to missing_colon; 324 325 saved_source_index = source_index; /* Save so we can process twice */ 326 n_fieldnames = 0; 327 328 call get_token; 329 330 do while (token ^= ";"); 331 n_fieldnames = n_fieldnames + 1; 332 333 if length (token) > 32 334 then do; 335 bv_code = lister_codes_$long_fieldname; 336 bv_error_token = token || cv_index_to_line (token_start); 337 go to cleanup_and_return; 338 end; 339 340 if verify (substr (token, 1, 1), "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") > 0 341 then do; 342 bv_code = lister_codes_$fieldname_not_alpha_start; 343 bv_error_token = token || cv_index_to_line (token_start); 344 go to cleanup_and_return; 345 end; 346 347 if verify (token, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") > 0 348 then do; 349 bv_code = lister_codes_$fieldname_not_alphanumeric; 350 bv_error_token = token || cv_index_to_line (token_start); 351 go to cleanup_and_return; 352 end; 353 354 call get_token; 355 if token ^= ";" 356 then if token ^= "," 357 then do; 358 bv_code = lister_codes_$listin_fn_missing_comma; 359 bv_error_token = token || cv_index_to_line (token_start); 360 go to cleanup_and_return; 361 end; 362 else call get_token; 363 end; 364 365 source_index = saved_source_index; 366 367 /* Allocate fieldname table */ 368 369 n = n_fieldnames - 1; 370 allocate field_table in (output_file.area) set (field_table_ptr); 371 output_file.field_table_offset = field_table_ptr; 372 field_table.hash_field_id_to_index (*) = null; 373 field_table.index_to_field_id (*) = null; 374 375 n = 0; 376 call get_token; 377 378 do while (token ^= ";"); 379 fidp = lister_hash_fid_$enter (out_file_ptr, (token)); 380 if fidp = null 381 then do; 382 bv_code = lister_codes_$dup_fieldname; 383 bv_error_token = token || cv_index_to_line (token_start); 384 go to cleanup_and_return; 385 end; 386 else do; 387 field_table.index_to_field_id (n) = offset (fidp, output_file.area); 388 fidp -> field_identifier.field_index = n; 389 n = n + 1; 390 end; 391 392 call get_token; /* skip comma */ 393 394 if token = "," 395 then call get_token; /* get next fieldname */ 396 end; 397 398 go to op_end; 399 400 op (7): /* Records */ 401 /* Do some validity checks on data so far */ 402 if rdelim = fdelim 403 then do; 404 bv_code = lister_codes_$fdelim_eq_rdelim; 405 bv_error_token = rdelim; 406 go to cleanup_and_return; 407 end; 408 409 if commenting 410 then if cdelim = fdelim 411 then do; 412 bv_code = lister_codes_$fdelim_eq_cdelim; 413 bv_error_token = cdelim; 414 go to cleanup_and_return; 415 end; 416 417 if commenting 418 then if rdelim = cdelim 419 then do; 420 bv_code = lister_codes_$cdelim_eq_rdelim; 421 bv_error_token = rdelim; 422 go to cleanup_and_return; 423 end; 424 425 if field_table_ptr = null 426 then do; 427 bv_code = lister_codes_$listin_missing_fieldnames; 428 bv_error_token = ""; 429 go to cleanup_and_return; 430 end; 431 432 fdelim_or_rdelim = fdelim || rdelim; 433 field_table.record_delimiter = rdelim; 434 field_table.field_delimiter = fdelim; 435 436 find_colon: 437 scan_index = index (substr (source_string, source_index), ":"); 438 if scan_index = 0 439 then goto missing_colon; 440 if verify (substr (source_string, source_index, scan_index - 1), NL_HT_SP_VT_NP) ^= 0 441 then do; 442 if commenting 443 then do; 444 call comment_scan (addr (source_string_array (source_index)), (scan_index - 1)); 445 if cs_start ^= 0 /* found comment */ 446 then if verify (substr (source_string, source_index, cs_start - 1), NL_HT_SP_VT_NP) ^= 0 447 then goto missing_colon; 448 else if in_comment /* no end to comment */ 449 then do; 450 call comment_end_scan (addr (source_string_array (source_index + cs_start)), 451 input_length - (source_index + cs_start - 1)); 452 if ce_pos = 0 453 then do; 454 comment_start = cv_index_to_line (source_index + cs_start); 455 goto premature_eof; 456 end; 457 source_index = source_index + ce_pos + cs_start; 458 goto find_colon; 459 end; 460 else do; 461 source_index = source_index + cs_start + cs_len - 1; 462 goto find_colon; 463 end; 464 end; 465 else goto missing_colon; 466 end; 467 468 source_index = source_index + scan_index; 469 call skip_over_blanks; 470 if source_index >= length (source_string) /* file with no records. */ 471 then goto no_more_data; 472 473 find_rdelim: 474 scan_index = index (substr (source_string, source_index), rdelim); 475 if scan_index = 0 476 then goto no_rdelim; 477 if verify (substr (source_string, source_index, scan_index - 1), NL_HT_SP_VT_NP) ^= 0 478 then do; 479 if commenting 480 then do; 481 call comment_scan (addr (source_string_array (source_index)), (scan_index - 1)); 482 if cs_start ^= 0 /* found comment */ 483 then if verify (substr (source_string, source_index, cs_start - 1), NL_HT_SP_VT_NP) ^= 0 484 then goto missing_colon; 485 else if in_comment /* no end to comment */ 486 then do; 487 call comment_end_scan (addr (source_string_array (source_index + cs_start)), 488 input_length - (source_index + cs_start - 1)); 489 if ce_pos = 0 490 then do; 491 comment_start = cv_index_to_line (source_index + cs_start); 492 goto premature_eof; 493 end; 494 source_index = source_index + ce_pos + cs_start; 495 goto find_rdelim; 496 end; 497 else do; 498 source_index = source_index + cs_start + cs_len - 1; 499 goto find_rdelim; 500 end; 501 end; 502 else do; 503 no_rdelim: bv_code = lister_codes_$listin_missing_rdelim; 504 bv_error_token = cv_index_to_line (source_index + 2); 505 goto cleanup_and_return; 506 end; 507 end; 508 509 source_index = source_index + scan_index; 510 511 do while (source_index <= length (source_string)); /* while there are more records... */ 512 recordp = null; 513 call skip_over_blanks; 514 515 if source_index > length (source_string) 516 then more_fields = "0"b; 517 else more_fields = "1"b; 518 519 do while (more_fields); /* while there are fields... */ 520 find_fdelim: if substr (source_string, source_index, 1) ^= fdelim 521 then do; 522 if substr (source_string, source_index, 1) = rdelim 523 then do; /* to accommodate emacs lister-mode kluge. */ 524 source_index = source_index + 1; 525 call skip_over_blanks; 526 if source_index > length (source_string) 527 then goto no_more_data; 528 goto find_fdelim; 529 end; 530 else if commenting 531 then do; 532 if substr (source_string, source_index, 1) = cdelim 533 then do; 534 call comment_scan (addr (source_string_array (source_index)), input_length - (source_index - 1)); 535 if in_comment 536 then do; 537 comment_start = cv_index_to_line (source_index + cs_start); 538 goto premature_eof; 539 end; 540 source_index = source_index + cs_start + cs_len - 1; 541 call skip_over_blanks; 542 goto find_fdelim; 543 end; 544 end; 545 else do; 546 bv_code = lister_codes_$listin_missing_fdelim; 547 bv_error_token = substr (source_string, source_index, 1) || cv_index_to_line (source_index); 548 goto cleanup_and_return; 549 end; 550 end; 551 552 553 fieldname_start, source_index = source_index + 1; 554 /* step over fdelim */ 555 if source_index > length (source_string) 556 then do; /* stepped past EOF */ 557 source_index = source_index - 1; 558 scan_index = 0; 559 end; 560 561 else scan_index = search (substr (source_string, source_index), NL_HT_SP_VT_NP) - 1; 562 563 if scan_index = 0 /* Fieldname followed by whitespace or eof */ 564 then do; 565 bv_code = lister_codes_$listin_misplaced_fieldname; 566 bv_error_token = cv_index_to_line (source_index); 567 goto cleanup_and_return; 568 end; 569 570 if scan_index = -1 /* The remainder of the file is the field name */ 571 then scan_index = length (source_string) - source_index + 1; 572 573 field_index = lister_hash_fid_ (out_file_ptr, substr (source_string, source_index, scan_index)); 574 if field_index = -1 575 then do; 576 fatal_error = "1"b; 577 call error (lister_codes_$listin_unknown_fieldname, 578 substr (source_string, source_index, scan_index) || cv_index_to_line (source_index)); 579 end; 580 581 source_index = source_index + scan_index; 582 /* step over field name */ 583 call skip_over_blanks; 584 585 if source_index > length (source_string) 586 then field_len = 0; 587 else if substr (source_string, source_index, 1) = QUOTE 588 then do; 589 saved_source_index = source_index; 590 call scan_quoted_string (field_ptr, field_len); 591 resume_qs_checking: if source_index <= length (source_string) 592 then if substr (source_string, source_index, 1) ^= rdelim & substr (source_string, source_index, 1) ^= fdelim 593 then do; 594 if ^commenting 595 then do; 596 source_index = saved_source_index; 597 goto not_a_quoted_string; 598 end; 599 if substr (source_string, source_index, 1) ^= cdelim 600 then do; 601 source_index = saved_source_index; 602 goto not_a_quoted_string; 603 end; 604 if cdelim = "/" 605 then do; 606 if index (substr (source_string, source_index), "*/") ^= 0 607 then source_index = source_index + index (substr (source_string, source_index), "*/") + 2; 608 else do; 609 in_comment = "1"b; 610 comment_start = cv_index_to_line (source_index); 611 goto premature_eof; 612 end; 613 end; 614 else do; 615 if index (substr (source_string, source_index + 1), cdelim) ^= 0 616 then source_index = source_index + index (substr (source_string, source_index + 1), cdelim) + 2; 617 else do; 618 in_comment = "1"b; 619 comment_start = cv_index_to_line (source_index); 620 goto premature_eof; 621 end; 622 end; 623 call skip_over_blanks; 624 goto resume_qs_checking; 625 end; 626 end; 627 else do; 628 not_a_quoted_string: field_ptr = addr (source_string_array (source_index)); 629 scan_index = search (substr (source_string, source_index), fdelim_or_rdelim) - 1; 630 if scan_index = -1 631 then scan_index = length (source_string) - source_index + 1; 632 633 field_len = scan_index; 634 field_len = length (rtrim (field_value, NL_HT_SP_VT_NP)); 635 source_index = source_index + scan_index; 636 temp_field_ptr = null (); 637 if commenting 638 then do; 639 call comment_scan (field_ptr, field_len); 640 do while (cs_start ^= 0); 641 if temp_field_ptr = null () /* just entered loop. */ 642 then do; 643 temp_field_len = field_len; 644 allocate temp_field_value; 645 temp_field_value = field_value; 646 comment_start = ""; 647 comment_pos_adjust = 0; 648 end; 649 if ^in_comment 650 then do; 651 temp_field_value = substr (temp_field_value, 1, cs_start - 1) || substr (temp_field_value, cs_start + cs_len); 652 temp_field_len = temp_field_len - cs_len; 653 comment_pos_adjust = comment_pos_adjust + cs_len; 654 call comment_scan (temp_field_ptr, temp_field_len); 655 comment_start = ""; 656 end; 657 else do; 658 if comment_start = "" 659 then comment_start = cv_index_to_line (source_index + cs_start + comment_pos_adjust - scan_index); 660 temp_char = substr (source_string, source_index, 1); 661 source_index = source_index + 1; 662 comment_pos_adjust = comment_pos_adjust - scan_index - 1; 663 scan_index = search (substr (source_string, source_index), fdelim_or_rdelim) - 1; 664 if scan_index = -1 665 then goto premature_eof; 666 temp_temp_field_len = temp_field_len + scan_index + 1; 667 allocate temp_temp_field_value; 668 temp_temp_field_value = temp_field_value || temp_char || substr (source_string, source_index, scan_index); 669 free temp_field_value; 670 temp_field_len = temp_temp_field_len; 671 allocate temp_field_value; 672 temp_field_value = temp_temp_field_value; 673 free temp_temp_field_value; 674 call comment_scan (temp_field_ptr, temp_field_len); 675 source_index = source_index + scan_index; 676 end; 677 end; 678 end; 679 end; 680 681 if field_len > 0 & field_index ^= -1 & (temp_field_ptr = null () | (temp_field_ptr ^= null () & temp_field_len ^= 0)) 682 then do; 683 if recordp = null 684 then recordp = lister_create_record_ (out_file_ptr); 685 686 if recordp -> output_record.field (field_index) ^= null 687 then do; 688 call error (lister_codes_$listin_dup_field, 689 pointer (field_table.index_to_field_id (field_index), output_file.area) 690 -> field_identifier.string || cv_index_to_line (fieldname_start)); 691 end; 692 else do; 693 if temp_field_ptr ^= null 694 then atom_length = length (rtrim (temp_field_value, NL_HT_SP_VT_NP)); 695 else atom_length = field_len; 696 allocate atom in (output_file.area) set (atomp); 697 if temp_field_ptr ^= null 698 then atom = temp_field_value; 699 else atom = field_value; 700 recordp -> output_record.field (field_index) = atomp; 701 end; 702 end; 703 704 if temp_field_ptr ^= null () 705 then free temp_field_value; 706 707 if source_index <= length (source_string) 708 then if substr (source_string, source_index, 1) = rdelim 709 then do; 710 more_fields = "0"b; 711 source_index = source_index + 1; 712 /* step over record delimiter */ 713 end; 714 else ; 715 else more_fields = "0"b; 716 end; 717 no_more_data: 718 end; 719 720 bv_n_records = output_file.n_records; 721 722 cleanup_and_return: 723 if fatal_error 724 then do; 725 bv_code = error_table_$translation_failed; 726 bv_error_token = ""; 727 end; 728 729 call clean_up; 730 return; 731 732 missing_colon: 733 bv_code = lister_codes_$listin_missing_colon; 734 bv_error_token = token || cv_index_to_line (source_index); 735 go to cleanup_and_return; 736 737 missing_semicolon: 738 bv_code = lister_codes_$listin_missing_semicolon; 739 bv_error_token = token || cv_index_to_line (source_index); 740 go to cleanup_and_return; 741 742 premature_eof: 743 bv_code = lister_codes_$listin_premature_eof; 744 if in_comment 745 then bv_error_token = "While processing comment beginning" || comment_start; 746 else bv_error_token = ""; 747 go to cleanup_and_return; 748 749 invalid_char: 750 bv_code = lister_codes_$listin_invalid_char; 751 bv_error_token = substr (source_string, source_index, 1) || cv_index_to_line (source_index); 752 go to cleanup_and_return; 753 754 clean_up: 755 procedure (); 756 757 /* program */ 758 759 if static_buffer_ptr ^= null 760 then do; 761 free static_buffer in (system_area); 762 static_buffer_ptr = null; 763 static_buffer_len = 0; 764 end; 765 766 end clean_up; 767 768 cv_index_to_line: 769 procedure (bv_source_index) returns (char (20) varying); 770 771 /* parameters */ 772 773 declare bv_source_index fixed bin (21) parameter; 774 775 /* automatic */ 776 777 declare line_number fixed bin (21), 778 line_string char (20) varying, 779 nl_index fixed bin (21), 780 src_index fixed bin (21); 781 782 /* internal static */ 783 784 declare NL char (1) initial (" 785 ") internal static; 786 787 /* pictures */ 788 789 declare seven_digits picture "zzzzzz9"; 790 791 /* program */ 792 793 line_number = 1; 794 795 do src_index = 1 repeat (src_index + nl_index) while (src_index <= bv_source_index); 796 nl_index = index (substr (source_string, src_index), NL); 797 if nl_index = 0 /* No final newline */ 798 then nl_index = bv_source_index - src_index + 1; 799 800 line_number = line_number + 1; 801 end; 802 803 seven_digits = line_number - 1; 804 line_string = " on line " || ltrim (seven_digits); 805 return (line_string); 806 807 end cv_index_to_line; 808 809 comment_end_scan: 810 procedure (bv_ces_ptr, bv_ces_len); 811 812 /* parameters */ 813 814 dcl bv_ces_ptr ptr parameter; 815 dcl bv_ces_len fixed bin (21); 816 817 /* automatic */ 818 819 dcl cei fixed bin; 820 821 /* based */ 822 823 dcl ces_string char (bv_ces_len) based (bv_ces_ptr); 824 825 /* program */ 826 827 if index (ces_string, cdelim) = 0 828 then do; 829 ce_pos = 0; 830 return; 831 end; 832 else do cei = 1 to length (ces_string) while (in_comment); 833 if substr (ces_string, cei, 1) = cdelim 834 then do; 835 in_comment = "0"b; 836 ce_pos = cei; 837 if cdelim = "/" 838 then if substr (ces_string, cei - 1, 1) = "*" 839 then in_comment = "1"b; 840 end; 841 end; 842 end comment_end_scan; 843 844 comment_scan: 845 procedure (bv_cs_ptr, bv_cs_len); 846 847 /* parameters */ 848 849 declare bv_cs_ptr ptr parameter; 850 declare bv_cs_len fixed bin (21) parameter; 851 852 /* automatic */ 853 854 declare ci fixed bin; 855 856 /* based */ 857 858 declare cs_string char (bv_cs_len) based (bv_cs_ptr); 859 860 /* program */ 861 862 if cdelim = "/" 863 then do; 864 if index (cs_string, "/*") = 0 865 then do; 866 cs_start = 0; 867 cs_len = 0; 868 return; 869 end; 870 end; 871 else do; 872 if index (cs_string, cdelim) = 0 873 then do; 874 cs_start = 0; 875 cs_len = 0; 876 return; 877 end; 878 end; 879 880 do ci = 1 to length (cs_string) while (^in_comment); 881 if substr (cs_string, ci, 1) = cdelim 882 then do; 883 in_comment = "1"b; 884 cs_start = ci; 885 if cdelim = "/" 886 then if substr (cs_string, ci + 1, 1) ^= "*" 887 then in_comment = "0"b; 888 end; 889 end; 890 if cdelim = "/" 891 then cs_len = index (substr (cs_string, cs_start), "*/") + 1; 892 else cs_len = index (substr (cs_string, cs_start + 1), cdelim) + 1; 893 if cs_len > 1 894 then in_comment = "0"b; 895 end comment_scan; 896 897 error: 898 procedure (bv_status_code, bv_message); 899 900 /* parameters */ 901 902 declare ( 903 bv_status_code fixed bin (35), 904 bv_message char (*) 905 ) parameter; 906 907 /* automatic */ 908 909 declare long_msg char (100), 910 short_msg char (8); 911 912 /* entries */ 913 914 declare convert_status_code_ 915 entry (fixed bin (35), char (8), char (100)), 916 ioa_$ioa_switch entry options (variable); 917 918 919 /* external static */ 920 921 declare iox_$error_output ptr external static; 922 923 /* program */ 924 925 call convert_status_code_ (bv_status_code, short_msg, long_msg); 926 call ioa_$ioa_switch (iox_$error_output, "^a ^a", long_msg, bv_message); 927 return; 928 929 end error; 930 931 get_token: 932 procedure; 933 934 /* program */ 935 936 /* Skip leading white space */ 937 938 try_again: 939 scan_index = verify (substr (source_string, source_index), NL_HT_SP_VT_NP) - 1; 940 if scan_index = -1 /* rest of segment is blank */ 941 then go to premature_eof; 942 943 source_index = source_index + scan_index; /* step over blanks */ 944 token_start = source_index; /* remember in case of errors */ 945 946 /* Check for simple delimiter tokens */ 947 948 scan_index = index ("!""#$%&'()*+,-./:;<=>?@[\]^_`{|}~", substr (source_string, source_index, 1)); 949 if scan_index > 0 950 then do; 951 if commenting 952 then if substr (source_string, source_index, 1) = cdelim 953 then do; 954 comment_start = cv_index_to_line (token_start); 955 if cdelim = "/" 956 then do; 957 if substr (source_string, source_index + 1, 1) = "*" 958 then do; 959 in_comment = "1"b; 960 scan_index = index (substr (source_string, source_index + 2), "*/"); 961 if scan_index = 0 962 then goto premature_eof; 963 source_index = source_index + scan_index + 3; 964 in_comment = "0"b; 965 goto try_again; 966 end; 967 end; /* slash w/o asterisk--pass as token. */ 968 else do; 969 in_comment = "1"b; 970 scan_index = index (substr (source_string, source_index + 1), cdelim); 971 if scan_index = 0 972 then goto premature_eof; 973 source_index = source_index + scan_index + 1; 974 in_comment = "0"b; 975 goto try_again; 976 end; 977 end; 978 token = substr (source_string, source_index, 1); 979 source_index = source_index + 1; 980 return; 981 end; 982 983 /* See if it is a non-printing char. */ 984 985 if substr (source_string, source_index, 1) < " " | substr (source_string, source_index, 1) > "~" 986 then go to invalid_char; 987 988 /* It is an alphanumeric token. Find the end of it. */ 989 990 scan_index = 991 verify (substr (source_string, source_index), 992 "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz") - 1; 993 if scan_index = -1 /* rest of segment is alphanumerics */ 994 then scan_index = length (source_string) - source_index; 995 996 token = substr (source_string, source_index, scan_index); 997 source_index = source_index + scan_index; /* step over it */ 998 return; 999 1000 end get_token; 1001 1002 /* Internal procedure to scan a quoted field value, removing doubled quotes. 1003* Implicit input arguments: source_string, source_index. 1004**/ 1005 1006 scan_quoted_string: 1007 procedure (bv_field_ptr, bv_field_len); 1008 1009 /* parameters */ 1010 1011 declare ( 1012 bv_field_ptr ptr, /* Output - ptr to dequoted string */ 1013 bv_field_len fixed bin (21) /* Output - length of dequoted string */ 1014 ) parameter; 1015 1016 /* automatic */ 1017 1018 declare buffer_len fixed bin (21), 1019 buffer_ptr ptr, 1020 string_len fixed bin (21), 1021 string_start fixed bin (21), 1022 using_automatic_buffer 1023 bit (1) aligned; 1024 1025 /* based */ 1026 1027 declare buffer char (buffer_len) varying based (buffer_ptr); 1028 1029 /* program */ 1030 1031 source_index = source_index + 1; /* step over opening quote */ 1032 string_start = source_index; 1033 string_len = 0; 1034 using_automatic_buffer = "1"b; /* The default... */ 1035 buffer_ptr = addr (token); 1036 buffer_len = maxlength (token); 1037 1038 rescan: 1039 scan_index = index (substr (source_string, source_index), QUOTE) - 1; 1040 if scan_index = -1 /* No closing quote */ 1041 then go to premature_eof; 1042 1043 if string_start = 0 1044 then do; 1045 call check_buffer_len (scan_index); 1046 buffer = buffer || substr (source_string, source_index, scan_index); 1047 end; 1048 else string_len = string_len + scan_index; 1049 1050 source_index = source_index + scan_index + 1; /* step over chars scanned and quote */ 1051 1052 if source_index <= length (source_string) 1053 then if substr (source_string, source_index, 1) = QUOTE 1054 then do; 1055 if string_start > 0 /* if not copied, do it now */ 1056 then do; 1057 call check_buffer_len (string_len); 1058 buffer = substr (source_string, string_start, string_len); 1059 string_start = 0; 1060 end; 1061 1062 call check_buffer_len (1); 1063 buffer = buffer || QUOTE; 1064 source_index = source_index + 1; /* step over quote */ 1065 go to rescan; 1066 end; 1067 1068 call skip_over_blanks; 1069 1070 if string_start > 0 1071 then do; 1072 bv_field_ptr = addr (source_string_array (string_start)); 1073 bv_field_len = string_len; 1074 return; 1075 end; 1076 1077 bv_field_ptr = addrel (buffer_ptr, 1); 1078 bv_field_len = length (buffer); 1079 return; 1080 1081 check_buffer_len: 1082 procedure (bv_additional_chars); 1083 1084 /* parameters */ 1085 1086 declare bv_additional_chars fixed bin (21) parameter; /* Input - number of chars being concatenated on */ 1087 1088 /* automatic */ 1089 1090 declare new_buffer_len fixed bin (21), 1091 new_buffer_ptr ptr; 1092 1093 /* based */ 1094 1095 declare new_buffer char (new_buffer_len) varying based (new_buffer_ptr); 1096 1097 /* program */ 1098 1099 if length (buffer) + bv_additional_chars <= maxlength (buffer) 1100 then return; 1101 1102 /* Buffer too small. Switch to a bigger one. */ 1103 1104 if using_automatic_buffer 1105 then do; 1106 if static_buffer_ptr ^= null /* Have we already allocated a buffer? */ 1107 then if length (buffer) + bv_additional_chars <= static_buffer_len 1108 then do; 1109 using_automatic_buffer = "0"b; 1110 static_buffer = buffer; 1111 buffer_ptr = static_buffer_ptr; 1112 buffer_len = static_buffer_len; 1113 return; 1114 end; 1115 end; 1116 1117 /* Calculate new buffer length. It can be as big as a 255K segment, minus the area header size. */ 1118 1119 new_buffer_len = min (1044480 - 96, binary (1.5e0 * (length (buffer) + bv_additional_chars), 35)); 1120 allocate new_buffer in (system_area) set (new_buffer_ptr); 1121 1122 new_buffer = buffer; 1123 1124 if ^using_automatic_buffer 1125 then if static_buffer_ptr ^= null 1126 then free static_buffer in (system_area); 1127 else ; 1128 else using_automatic_buffer = "0"b; 1129 1130 static_buffer_ptr, buffer_ptr = new_buffer_ptr; 1131 static_buffer_len, buffer_len = new_buffer_len; 1132 return; 1133 1134 end check_buffer_len; 1135 1136 end scan_quoted_string; 1137 1138 /* Internal procedure to skip over "white space" characters */ 1139 1140 skip_over_blanks: 1141 procedure; 1142 1143 skip_again: 1144 scan_index = verify (substr (source_string, source_index), NL_HT_SP_VT_NP) - 1; 1145 if scan_index = -1 1146 then scan_index = length (source_string) - source_index + 1; 1147 1148 source_index = source_index + scan_index; 1149 if commenting 1150 then if (substr (source_string, source_index, 1) = cdelim & cdelim ^= "/") 1151 | (substr (source_string, source_index, 2) = "/*" & cdelim = "/") 1152 then do; 1153 call comment_scan (addr (source_string_array (source_index)), input_length - (source_index - 1)); 1154 if in_comment 1155 then do; 1156 comment_start = cv_index_to_line (source_index + cs_start); 1157 goto premature_eof; 1158 end; 1159 source_index = source_index + cs_start + cs_len - 1; 1160 goto skip_again; 1161 end; 1162 return; 1163 1164 end skip_over_blanks; 1165 1166 end /* lister_compile_listin_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/17/90 0941.9 lister_compile_listin_.pl1 >spec>install>1046>lister_compile_listin_.pl1 169 1 04/25/81 0828.4 lister_entries.incl.pl1 >ldd>include>lister_entries.incl.pl1 170 2 11/06/84 1047.7 lister_structures.incl.pl1 >ldd>include>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. NL constant char(1) initial packed unaligned dcl 784 ref 796 NL_HT_SP_VT_NP 000014 constant char(5) initial packed unaligned dcl 155 ref 440 445 477 482 561 634 693 938 1143 QUOTE 006226 constant char(1) initial packed unaligned dcl 155 ref 587 1038 1052 1063 addr builtin function dcl 111 ref 444 444 450 450 481 481 487 487 534 534 628 1035 1072 1153 1153 addrel builtin function dcl 111 ref 1077 area 10 based area(261112) level 2 dcl 2-38 set ref 209* 370 371 387 688 696 700 area_ptr 000300 automatic pointer dcl 2-96 set ref 178* 761 1120 1124 atom based varying char dcl 2-71 set ref 696 697* 699* atom_length 000262 automatic fixed bin(17,0) initial dcl 2-71 set ref 693* 695* 696 697 699 2-71* atomp 000264 automatic pointer dcl 2-71 set ref 696* 697 699 700 binary builtin function dcl 111 ref 1119 buffer based varying char dcl 1027 set ref 1046* 1046 1058* 1063* 1063 1078 1099 1099 1106 1110 1119 1122 buffer_len 000362 automatic fixed bin(21,0) dcl 1018 set ref 1036* 1046 1058 1063 1099 1112* 1131* buffer_ptr 000364 automatic pointer dcl 1018 set ref 1035* 1046 1046 1058 1063 1063 1077 1078 1099 1099 1106 1110 1111* 1119 1122 1130* bv_additional_chars parameter fixed bin(21,0) dcl 1086 ref 1081 1099 1106 1119 bv_area_ptr parameter pointer dcl 55 ref 49 178 bv_ces_len parameter fixed bin(21,0) dcl 815 ref 809 827 832 833 837 bv_ces_ptr parameter pointer dcl 814 ref 809 827 832 833 837 bv_code parameter fixed bin(35,0) dcl 55 set ref 49 180* 195* 196 220* 238* 245* 269* 276* 303* 335* 342* 349* 358* 382* 404* 412* 420* 427* 503* 546* 565* 725* 732* 737* 742* 749* bv_cs_len parameter fixed bin(21,0) dcl 850 ref 844 864 872 880 881 885 890 892 bv_cs_ptr parameter pointer dcl 849 ref 844 864 872 880 881 885 890 892 bv_error_token parameter char packed unaligned dcl 55 set ref 49 198* 221* 239* 246* 270* 277* 304* 336* 343* 350* 359* 383* 405* 413* 421* 428* 504* 547* 566* 726* 734* 739* 744* 746* 751* bv_field_len parameter fixed bin(21,0) dcl 1011 set ref 1006 1073* 1078* bv_field_ptr parameter pointer dcl 1011 set ref 1006 1072* 1077* bv_input_length parameter fixed bin(21,0) dcl 55 ref 49 177 bv_input_ptr parameter pointer dcl 55 ref 49 176 bv_message parameter char packed unaligned dcl 902 set ref 897 926* bv_n_records parameter fixed bin(17,0) dcl 55 set ref 49 179* 720* bv_out_file_ptr parameter pointer dcl 55 ref 49 175 bv_source_index parameter fixed bin(21,0) dcl 773 ref 768 795 797 bv_status_code parameter fixed bin(35,0) dcl 902 set ref 897 925* cdelim 000100 automatic char(1) packed unaligned dcl 67 set ref 298* 307* 409 413 417 532 599 604 615 615 827 833 837 862 872 881 885 890 892 951 955 970 1149 1149 1149 ce_pos 000101 automatic fixed bin(17,0) dcl 67 set ref 452 457 489 494 829* 836* cei 000334 automatic fixed bin(17,0) dcl 819 set ref 832* 833 836 837* ces_string based char packed unaligned dcl 823 ref 827 832 833 837 ci 000344 automatic fixed bin(17,0) dcl 854 set ref 880* 881 884 885* cleanup 000254 stack reference condition dcl 117 ref 182 comment_pos_adjust 000111 automatic fixed bin(21,0) dcl 67 set ref 647* 653* 653 658 662* 662 comment_start 000102 automatic varying char(20) dcl 67 set ref 454* 491* 537* 610* 619* 646* 655* 658 658* 744 954* 1156* commenting 000110 automatic bit(1) dcl 67 set ref 190* 310* 409 417 442 479 530 594 637 951 1149 convert_status_code_ 000106 constant entry external dcl 914 ref 925 cs_len 000112 automatic fixed bin(17,0) dcl 67 set ref 461 498 540 651 652 653 867* 875* 890* 892* 893 1159 cs_start 000113 automatic fixed bin(17,0) dcl 67 set ref 445 445 450 450 450 454 457 461 482 482 487 487 487 491 494 498 537 540 640 651 651 658 866* 874* 884* 890 892 1156 1159 cs_string based char packed unaligned dcl 858 ref 864 872 880 881 885 890 892 empty builtin function dcl 111 ref 209 error_table_$translation_failed 000016 external static fixed bin(35,0) dcl 125 ref 725 fatal_error 000114 automatic bit(1) dcl 67 set ref 186* 576* 722 fdelim 000115 automatic char(1) packed unaligned dcl 67 set ref 188* 250* 400 409 432 434 520 591 fdelim_or_rdelim 000116 automatic char(2) packed unaligned dcl 67 set ref 432* 629 663 fidp 000266 automatic pointer dcl 2-75 set ref 379* 380 387 388 field 2 based offset array level 2 dcl 2-64 set ref 686 700* field_delimiter 0(09) based char(1) level 2 packed packed unaligned dcl 2-79 set ref 434* field_identifier based structure level 1 dcl 2-89 field_index 1 based fixed bin(17,0) level 2 in structure "field_identifier" packed packed unaligned dcl 2-89 in procedure "lister_compile_listin_" set ref 388* field_index 000117 automatic fixed bin(17,0) dcl 67 in procedure "lister_compile_listin_" set ref 573* 574 681 686 688 700 field_len 000120 automatic fixed bin(21,0) dcl 67 set ref 585* 590* 633* 634* 634 639* 643 645 681 695 699 field_ptr 000122 automatic pointer dcl 67 set ref 590* 628* 634 639* 645 699 field_table based structure level 1 dcl 2-79 set ref 370 field_table_offset based offset level 2 dcl 2-38 set ref 202* 371* field_table_ptr 000270 automatic pointer dcl 2-75 set ref 189* 370* 371 372 373 387 425 433 434 688 field_value based char packed unaligned dcl 101 ref 634 645 699 fieldname_start 000124 automatic fixed bin(21,0) dcl 67 set ref 553* 688* hash_field_id_to_index 1 based offset array level 2 dcl 2-79 set ref 372* hbound builtin function dcl 111 ref 215 218 hcs_$truncate_seg 000014 constant entry external dcl 121 ref 195 in_comment 000125 automatic bit(1) dcl 67 set ref 191* 448 485 535 609* 618* 649 744 832 835* 837* 880 883* 885* 893* 959* 964* 969* 974* 1154 index builtin function dcl 111 ref 436 473 606 606 615 615 796 827 864 872 890 892 948 960 970 1038 index_to_field_id 24 based offset array level 2 dcl 2-79 set ref 373* 387* 688 input_length 000126 automatic fixed bin(21,0) dcl 67 set ref 177* 436 440 445 450 470 473 477 482 487 511 515 520 522 526 532 534 547 555 561 570 573 573 577 585 587 591 591 591 599 606 606 615 615 629 630 660 663 668 707 707 751 796 938 948 951 957 960 970 978 985 985 990 993 996 1038 1046 1052 1052 1058 1143 1145 1149 1149 1153 input_ptr 000130 automatic pointer dcl 67 set ref 176* 436 440 444 444 445 450 450 470 473 477 481 481 482 487 487 511 515 520 522 526 532 534 534 547 555 561 570 573 573 577 585 587 591 591 591 599 606 606 615 615 628 629 630 660 663 668 707 707 751 796 938 948 951 957 960 970 978 985 985 990 993 996 1038 1046 1052 1052 1058 1072 1143 1145 1149 1149 1153 1153 ioa_$ioa_switch 000110 constant entry external dcl 914 ref 926 iox_$error_output 000112 external static pointer dcl 921 set ref 926* keywords 000016 constant varying char(17) initial array dcl 155 ref 215 215 215 218 keyx 000132 automatic fixed bin(17,0) dcl 67 set ref 215* 215* 218 225 lbound builtin function dcl 111 ref 215 length builtin function dcl 111 ref 236 267 301 333 470 511 515 526 555 570 585 591 630 634 693 707 832 880 993 1052 1078 1099 1106 1119 1145 line_number 000312 automatic fixed bin(21,0) dcl 777 set ref 793* 800* 800 803 line_string 000313 automatic varying char(20) dcl 777 set ref 804* 805 lister_codes_$bad_cdelim 000020 external static fixed bin(35,0) dcl 125 ref 303 lister_codes_$bad_fdelim 000022 external static fixed bin(35,0) dcl 125 ref 245 lister_codes_$bad_rdelim 000024 external static fixed bin(35,0) dcl 125 ref 276 lister_codes_$cdelim_eq_rdelim 000026 external static fixed bin(35,0) dcl 125 ref 420 lister_codes_$dup_fieldname 000030 external static fixed bin(35,0) dcl 125 ref 382 lister_codes_$fdelim_eq_cdelim 000032 external static fixed bin(35,0) dcl 125 ref 412 lister_codes_$fdelim_eq_rdelim 000034 external static fixed bin(35,0) dcl 125 ref 404 lister_codes_$fieldname_not_alpha_start 000036 external static fixed bin(35,0) dcl 125 ref 342 lister_codes_$fieldname_not_alphanumeric 000040 external static fixed bin(35,0) dcl 125 ref 349 lister_codes_$listin_dup_field 000042 external static fixed bin(35,0) dcl 125 set ref 688* lister_codes_$listin_fn_missing_comma 000044 external static fixed bin(35,0) dcl 125 ref 358 lister_codes_$listin_invalid_char 000046 external static fixed bin(35,0) dcl 125 ref 749 lister_codes_$listin_misplaced_fieldname 000050 external static fixed bin(35,0) dcl 125 ref 565 lister_codes_$listin_missing_colon 000052 external static fixed bin(35,0) dcl 125 ref 732 lister_codes_$listin_missing_fdelim 000054 external static fixed bin(35,0) dcl 125 ref 546 lister_codes_$listin_missing_fieldnames 000056 external static fixed bin(35,0) dcl 125 ref 427 lister_codes_$listin_missing_rdelim 000060 external static fixed bin(35,0) dcl 125 ref 503 lister_codes_$listin_missing_semicolon 000062 external static fixed bin(35,0) dcl 125 ref 737 lister_codes_$listin_premature_eof 000064 external static fixed bin(35,0) dcl 125 ref 742 lister_codes_$listin_unknown_fieldname 000066 external static fixed bin(35,0) dcl 125 set ref 577* lister_codes_$listin_unknown_keyword 000070 external static fixed bin(35,0) dcl 125 ref 220 lister_codes_$long_fdelim 000072 external static fixed bin(35,0) dcl 125 ref 238 lister_codes_$long_fieldname 000074 external static fixed bin(35,0) dcl 125 ref 335 lister_codes_$long_rdelim 000076 external static fixed bin(35,0) dcl 125 ref 269 lister_create_record_ 000100 constant entry external dcl 1-70 ref 683 lister_file_version_2 constant fixed bin(17,0) initial dcl 2-11 ref 210 lister_hash_fid_ 000102 constant entry external dcl 1-105 ref 573 lister_hash_fid_$enter 000104 constant entry external dcl 1-112 ref 379 long_msg 000100 automatic char(100) packed unaligned dcl 909 set ref 925* 926* ltrim builtin function dcl 111 ref 804 max_field_index 0(18) based fixed bin(17,0) level 2 packed packed unaligned dcl 2-79 set ref 370* 373 maxlength builtin function dcl 111 ref 1036 1099 min builtin function dcl 111 ref 1119 more_fields 000133 automatic bit(1) dcl 67 set ref 515* 517* 519 710* 715* n 000276 automatic fixed bin(17,0) dcl 2-75 set ref 369* 370 370 375* 387 388 389* 389 n_fieldnames 000134 automatic fixed bin(17,0) dcl 67 set ref 326* 331* 331 369 n_records 7 based fixed bin(17,0) level 2 dcl 2-38 set ref 208* 720 new_buffer based varying char dcl 1095 set ref 1120 1122* new_buffer_len 000400 automatic fixed bin(21,0) dcl 1090 set ref 1119* 1120 1122 1131 new_buffer_ptr 000402 automatic pointer dcl 1090 set ref 1120* 1122 1130 next_uid 5 based fixed bin(24,0) level 2 unsigned dcl 2-38 set ref 207* nl_index 000321 automatic fixed bin(21,0) dcl 777 set ref 796* 797 797* 801 null builtin function dcl 111 ref 174 189 202 203 204 205 206 372 373 380 425 512 636 641 681 681 683 686 693 697 704 759 762 1106 1124 offset builtin function dcl 111 ref 387 out_file_ptr 000274 automatic pointer dcl 2-75 set ref 175* 195* 202 203 204 205 206 207 208 209 210 370 371 371 379* 387 573* 683* 688 696 700 720 output_file based structure level 1 dcl 2-38 output_record based structure level 1 dcl 2-64 permissible_delimiters 000011 constant char(12) initial packed unaligned dcl 155 ref 243 274 301 pointer builtin function dcl 111 ref 688 rdelim 000135 automatic char(1) packed unaligned dcl 67 set ref 187* 281* 400 405 417 421 432 433 473 522 591 707 record_delimiter based char(1) level 2 packed packed unaligned dcl 2-79 set ref 433* record_head 1 based offset level 2 dcl 2-38 set ref 203* record_tail 2 based offset level 2 dcl 2-38 set ref 204* recordp 000272 automatic pointer dcl 2-75 set ref 512* 683 683* 686 700 rtrim builtin function dcl 111 ref 634 693 saved_source_index 000136 automatic fixed bin(21,0) dcl 67 set ref 325* 365 589* 596 601 scan_index 000137 automatic fixed bin(21,0) dcl 67 set ref 436* 438 440 444 468 473* 475 477 481 509 558* 561* 563 570 570* 573 573 577 581 629* 630 630* 633 635 658 662 663* 664 666 668 675 938* 940 943 948* 949 960* 961 963 970* 971 973 990* 993 993* 996 997 1038* 1040 1045* 1046 1048 1050 1143* 1145 1145* 1148 search builtin function dcl 111 ref 561 629 663 seven_digits 000324 automatic picture(7) packed unaligned dcl 789 set ref 803* 804 short_msg 000132 automatic char(8) packed unaligned dcl 909 set ref 925* size 1(18) based fixed bin(17,0) level 2 packed packed unaligned dcl 2-89 ref 688 source_index 000140 automatic fixed bin(21,0) dcl 67 set ref 185* 325 365* 436 440 444 444 445 450 450 450 454 457* 457 461* 461 468* 468 470 473 477 481 481 482 487 487 487 491 494* 494 498* 498 504 509* 509 511 515 520 522 524* 524 526 532 534 534 534 537 540* 540 547 547* 553 553* 555 557* 557 561 566* 570 573 573 577 577* 581* 581 585 587 589 591 591 591 596* 599 601* 606 606* 606 606 610* 615 615* 615 615 619* 628 629 630 635* 635 658 660 661* 661 663 668 675* 675 707 707 711* 711 734* 739* 751 751* 938 943* 943 944 948 951 957 960 963* 963 970 973* 973 978 979* 979 985 985 990 993 996 997* 997 1031* 1031 1032 1038 1046 1050* 1050 1052 1052 1064* 1064 1143 1145 1148* 1148 1149 1149 1153 1153 1153 1156 1159* 1159 source_string based char packed unaligned dcl 101 ref 436 440 445 470 473 477 482 511 515 520 522 526 532 547 555 561 570 573 573 577 585 587 591 591 591 599 606 606 615 615 629 630 660 663 668 707 707 751 796 938 948 951 957 960 970 978 985 985 990 993 996 1038 1046 1052 1052 1058 1143 1145 1149 1149 source_string_array based char(1) array packed unaligned dcl 101 set ref 444 444 450 450 481 481 487 487 534 534 628 1072 1153 1153 src_index 000322 automatic fixed bin(21,0) dcl 777 set ref 795* 795* 796 797* 801 static_buffer based varying char dcl 101 set ref 761 1110* 1124 static_buffer_len 000010 internal static fixed bin(21,0) initial dcl 155 set ref 761 763* 1106 1110 1112 1124 1131* static_buffer_ptr 000012 internal static pointer initial dcl 155 set ref 759 761 762* 1106 1110 1111 1124 1124 1130* string 2 based char level 2 packed packed unaligned dcl 2-89 ref 688 string_len 000366 automatic fixed bin(21,0) dcl 1018 set ref 1033* 1048* 1048 1057* 1058 1073 string_start 000367 automatic fixed bin(21,0) dcl 1018 set ref 1032* 1043 1055 1058 1059* 1070 1072 substr builtin function dcl 111 ref 340 436 440 445 473 477 482 520 522 532 547 561 573 573 577 587 591 591 599 606 606 615 615 629 651 651 660 663 668 707 751 796 833 837 881 885 890 892 938 948 951 957 960 970 978 985 985 990 996 1038 1046 1052 1058 1143 1149 1149 system_area based area(261120) dcl 2-95 ref 761 1120 1124 temp_char 000141 automatic char(1) packed unaligned dcl 67 set ref 660* 668 temp_field_len 000142 automatic fixed bin(21,0) dcl 67 set ref 643* 644 644 645 651 651 651 652* 652 654* 666 668 669 669 670* 671 671 672 674* 681 693 697 704 704 temp_field_ptr 000144 automatic pointer dcl 67 set ref 174* 636* 641 644* 645 651 651 651 654* 668 669 671* 672 674* 681 681 693 693 697 697 704 704 temp_field_value based char packed unaligned dcl 101 set ref 644 645* 651* 651 651 668 669 671 672* 693 697 704 temp_temp_field_len 000146 automatic fixed bin(21,0) dcl 67 set ref 666* 667 667 668 670 672 673 673 temp_temp_field_ptr 000150 automatic pointer dcl 67 set ref 667* 668 672 673 temp_temp_field_value based char packed unaligned dcl 101 set ref 667 668* 672 673 token 000152 automatic varying char(256) dcl 67 set ref 215 221 231 236 239 243 246 250 253 262 267 270 274 277 281 284 293 298 301 301 304 307 313 322 330 333 336 340 343 347 350 355 355 359 378 379 383 394 734 739 978* 996* 1035 1036 token_start 000253 automatic fixed bin(21,0) dcl 67 set ref 221* 239* 246* 270* 277* 304* 336* 343* 350* 359* 383* 944* 954* unused 3 based offset array level 2 dcl 2-38 set ref 205* 206* using_automatic_buffer 000370 automatic bit(1) dcl 1018 set ref 1034* 1104 1109* 1124 1128* verify builtin function dcl 111 ref 243 274 301 340 347 440 445 477 482 938 990 1143 version 6 based fixed bin(17,0) level 2 dcl 2-38 set ref 210* 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 center internal static bit(2) initial dcl 2-129 element automatic structure level 1 dcl 2-143 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 in_file_ptr automatic pointer dcl 2-75 input_file based structure level 1 dcl 2-14 input_record based structure level 1 dcl 2-50 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_file_head_ 000000 constant entry external dcl 1-52 lister_copy_records_ 000000 constant entry external dcl 1-57 lister_create_record_$after 000000 constant entry external dcl 1-76 lister_create_record_$retain_uid 000000 constant entry external dcl 1-83 lister_delete_ 000000 constant entry external dcl 1-90 lister_expand_ 000000 constant entry external dcl 1-95 lister_format_parse_ 000000 constant entry external dcl 1-119 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_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 up_file_ptr automatic pointer dcl 2-75 update_file based structure level 1 dcl 2-26 update_record based structure level 1 dcl 2-57 NAMES DECLARED BY EXPLICIT CONTEXT. check_buffer_len 004626 constant entry internal dcl 1081 ref 1045 1057 1062 clean_up 003545 constant entry internal dcl 754 ref 182 729 cleanup_and_return 003351 constant label dcl 722 ref 199 222 240 247 271 278 305 337 344 351 360 384 406 414 422 429 505 548 567 735 740 747 752 comment_end_scan 003711 constant entry internal dcl 809 ref 450 487 comment_scan 003770 constant entry internal dcl 844 ref 444 481 534 639 654 674 1153 cv_index_to_line 003571 constant entry internal dcl 768 ref 221 239 246 270 277 304 336 343 350 359 383 454 491 504 537 547 566 577 610 619 658 688 734 739 751 954 1156 error 004145 constant entry internal dcl 897 ref 577 688 find_colon 001603 constant label dcl 436 ref 458 462 find_fdelim 002142 constant label dcl 520 ref 528 542 find_rdelim 001743 constant label dcl 473 ref 495 499 get_token 004225 constant entry internal dcl 931 ref 212 227 234 252 258 265 283 289 296 312 318 328 354 362 376 392 394 invalid_char 003512 constant label dcl 749 ref 985 lister_compile_listin_ 000252 constant entry external dcl 49 missing_colon 003371 constant label dcl 732 ref 231 262 293 322 438 442 445 482 missing_semicolon 003423 constant label dcl 737 set ref 253 284 313 no_more_data 003344 constant label dcl 717 ref 470 526 no_rdelim 002076 constant label dcl 503 ref 475 not_a_quoted_string 002566 constant label dcl 628 ref 597 602 op 000000 constant label array(9) dcl 227 ref 225 op_end 000411 constant label dcl 212 ref 256 287 316 398 premature_eof 003455 constant label dcl 742 ref 455 492 538 611 620 664 940 961 971 1040 1157 rescan 004462 constant label dcl 1038 ref 1065 resume_qs_checking 002452 constant label dcl 591 ref 624 scan_quoted_string 004446 constant entry internal dcl 1006 ref 590 skip_again 004752 constant label dcl 1143 ref 1160 skip_over_blanks 004751 constant entry internal dcl 1140 ref 469 513 525 541 583 623 1068 try_again 004226 constant label dcl 938 ref 965 975 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 6724 7040 6235 6734 Length 7340 6235 114 264 467 4 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME lister_compile_listin_ 310 external procedure is an external procedure. on unit on line 182 64 on unit clean_up 64 internal procedure is called by several nonquick procedures. cv_index_to_line internal procedure shares stack frame of external procedure lister_compile_listin_. comment_end_scan internal procedure shares stack frame of external procedure lister_compile_listin_. comment_scan internal procedure shares stack frame of external procedure lister_compile_listin_. error 122 internal procedure is called during a stack extension. get_token internal procedure shares stack frame of external procedure lister_compile_listin_. scan_quoted_string internal procedure shares stack frame of external procedure lister_compile_listin_. check_buffer_len internal procedure shares stack frame of external procedure lister_compile_listin_. skip_over_blanks internal procedure shares stack frame of external procedure lister_compile_listin_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 static_buffer_len lister_compile_listin_ 000012 static_buffer_ptr lister_compile_listin_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME error 000100 long_msg error 000132 short_msg error lister_compile_listin_ 000100 cdelim lister_compile_listin_ 000101 ce_pos lister_compile_listin_ 000102 comment_start lister_compile_listin_ 000110 commenting lister_compile_listin_ 000111 comment_pos_adjust lister_compile_listin_ 000112 cs_len lister_compile_listin_ 000113 cs_start lister_compile_listin_ 000114 fatal_error lister_compile_listin_ 000115 fdelim lister_compile_listin_ 000116 fdelim_or_rdelim lister_compile_listin_ 000117 field_index lister_compile_listin_ 000120 field_len lister_compile_listin_ 000122 field_ptr lister_compile_listin_ 000124 fieldname_start lister_compile_listin_ 000125 in_comment lister_compile_listin_ 000126 input_length lister_compile_listin_ 000130 input_ptr lister_compile_listin_ 000132 keyx lister_compile_listin_ 000133 more_fields lister_compile_listin_ 000134 n_fieldnames lister_compile_listin_ 000135 rdelim lister_compile_listin_ 000136 saved_source_index lister_compile_listin_ 000137 scan_index lister_compile_listin_ 000140 source_index lister_compile_listin_ 000141 temp_char lister_compile_listin_ 000142 temp_field_len lister_compile_listin_ 000144 temp_field_ptr lister_compile_listin_ 000146 temp_temp_field_len lister_compile_listin_ 000150 temp_temp_field_ptr lister_compile_listin_ 000152 token lister_compile_listin_ 000253 token_start lister_compile_listin_ 000262 atom_length lister_compile_listin_ 000264 atomp lister_compile_listin_ 000266 fidp lister_compile_listin_ 000270 field_table_ptr lister_compile_listin_ 000272 recordp lister_compile_listin_ 000274 out_file_ptr lister_compile_listin_ 000276 n lister_compile_listin_ 000300 area_ptr lister_compile_listin_ 000312 line_number cv_index_to_line 000313 line_string cv_index_to_line 000321 nl_index cv_index_to_line 000322 src_index cv_index_to_line 000324 seven_digits cv_index_to_line 000334 cei comment_end_scan 000344 ci comment_scan 000362 buffer_len scan_quoted_string 000364 buffer_ptr scan_quoted_string 000366 string_len scan_quoted_string 000367 string_start scan_quoted_string 000370 using_automatic_buffer scan_quoted_string 000400 new_buffer_len check_buffer_len 000402 new_buffer_ptr check_buffer_len THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 alloc_char_temp cat_realloc_chars call_ext_out_desc call_ext_out call_int_this_desc call_int_this call_int_other return_mac fl2_to_fx1 enable_op shorten_stack ext_entry_desc int_entry int_entry_desc pointer_hard offset_hard search_eis op_alloc_ alloc_storage op_freen_ op_empty_ THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. convert_status_code_ hcs_$truncate_seg ioa_$ioa_switch lister_create_record_ lister_hash_fid_ lister_hash_fid_$enter THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$translation_failed iox_$error_output lister_codes_$bad_cdelim lister_codes_$bad_fdelim lister_codes_$bad_rdelim lister_codes_$cdelim_eq_rdelim lister_codes_$dup_fieldname lister_codes_$fdelim_eq_cdelim lister_codes_$fdelim_eq_rdelim lister_codes_$fieldname_not_alpha_start lister_codes_$fieldname_not_alphanumeric lister_codes_$listin_dup_field lister_codes_$listin_fn_missing_comma lister_codes_$listin_invalid_char lister_codes_$listin_misplaced_fieldname lister_codes_$listin_missing_colon lister_codes_$listin_missing_fdelim lister_codes_$listin_missing_fieldnames lister_codes_$listin_missing_rdelim lister_codes_$listin_missing_semicolon lister_codes_$listin_premature_eof lister_codes_$listin_unknown_fieldname lister_codes_$listin_unknown_keyword lister_codes_$long_fdelim lister_codes_$long_fieldname lister_codes_$long_rdelim LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 49 000244 2 71 000265 174 000266 175 000270 176 000274 177 000277 178 000301 179 000304 180 000305 182 000306 185 000330 186 000332 187 000333 188 000335 189 000337 190 000341 191 000342 195 000343 196 000360 198 000363 199 000370 202 000371 203 000373 204 000375 205 000376 206 000377 207 000400 208 000402 209 000403 210 000406 212 000411 215 000412 216 000427 218 000431 220 000434 221 000440 222 000464 225 000466 227 000467 231 000470 234 000475 236 000476 238 000501 239 000505 240 000531 243 000533 245 000546 246 000552 247 000576 250 000600 252 000605 253 000606 256 000613 258 000614 262 000615 265 000622 267 000623 269 000626 270 000632 271 000656 274 000660 276 000673 277 000677 278 000723 281 000725 283 000732 284 000733 287 000740 289 000741 293 000742 296 000747 298 000750 301 000760 303 000776 304 001002 305 001026 307 001030 310 001035 312 001037 313 001040 316 001045 318 001046 322 001047 325 001054 326 001056 328 001057 330 001060 331 001065 333 001066 335 001071 336 001075 337 001121 340 001123 342 001133 343 001137 344 001163 347 001165 349 001200 350 001204 351 001230 354 001232 355 001233 358 001245 359 001251 360 001275 362 001277 363 001300 365 001301 369 001303 370 001306 371 001317 372 001324 373 001335 375 001354 376 001355 378 001356 379 001363 380 001413 382 001420 383 001424 384 001450 387 001452 388 001461 389 001465 392 001466 394 001467 396 001475 398 001476 400 001477 404 001502 405 001506 406 001513 409 001514 412 001521 413 001525 414 001532 417 001533 420 001540 421 001544 422 001551 425 001552 427 001556 428 001562 429 001567 432 001570 433 001574 434 001577 436 001603 438 001623 440 001624 442 001637 444 001641 445 001653 448 001672 450 001674 452 001713 454 001715 455 001722 457 001723 458 001726 461 001727 462 001734 468 001735 469 001737 470 001740 473 001743 475 001763 477 001764 479 001777 481 002001 482 002013 485 002032 487 002034 489 002053 491 002055 492 002062 494 002063 495 002066 498 002067 499 002074 501 002075 503 002076 504 002102 505 002116 509 002117 511 002121 512 002125 513 002127 515 002130 517 002135 519 002137 520 002142 522 002152 524 002154 525 002155 526 002156 528 002161 530 002162 532 002164 534 002167 535 002204 537 002206 538 002213 540 002214 541 002221 542 002222 544 002223 546 002224 547 002230 548 002252 553 002254 555 002260 557 002262 558 002264 559 002265 561 002266 563 002305 565 002307 566 002313 567 002324 570 002325 573 002333 574 002364 576 002370 577 002372 579 002431 581 002432 583 002434 585 002435 587 002442 589 002447 590 002450 591 002452 594 002466 596 002470 597 002472 599 002473 601 002476 602 002500 604 002501 606 002504 609 002527 610 002531 611 002533 613 002534 615 002535 618 002556 619 002560 620 002562 623 002563 624 002564 626 002565 628 002566 629 002572 630 002610 633 002616 634 002617 635 002631 636 002633 637 002635 639 002637 640 002641 641 002644 643 002650 644 002652 645 002660 646 002666 647 002667 649 002670 651 002672 652 002725 653 002730 654 002732 655 002734 656 002735 658 002736 660 002752 661 002760 662 002761 663 002765 664 003003 666 003005 667 003010 668 003016 669 003055 670 003063 671 003065 672 003073 673 003101 674 003105 675 003107 677 003111 681 003112 683 003131 686 003146 688 003153 691 003222 693 003224 695 003245 696 003247 697 003260 699 003276 700 003307 704 003316 707 003327 710 003337 711 003340 714 003341 715 003342 716 003343 717 003344 720 003345 722 003351 725 003353 726 003357 729 003364 730 003370 732 003371 734 003375 735 003421 737 003423 739 003427 740 003453 742 003455 744 003461 746 003503 747 003511 749 003512 751 003516 752 003542 754 003544 759 003552 761 003556 762 003564 763 003567 766 003570 768 003571 793 003573 795 003575 796 003602 797 003621 800 003626 801 003627 803 003631 804 003644 805 003701 809 003711 827 003713 829 003727 830 003730 832 003731 833 003743 835 003752 836 003753 837 003754 841 003765 842 003767 844 003770 862 003772 864 003775 866 004011 867 004012 868 004013 870 004014 872 004015 874 004031 875 004032 876 004033 880 004034 881 004047 883 004056 884 004060 885 004061 889 004071 890 004073 892 004121 893 004140 895 004143 897 004144 925 004160 926 004173 927 004224 931 004225 938 004226 940 004246 943 004250 944 004251 948 004253 949 004265 951 004266 954 004275 955 004277 957 004302 959 004310 960 004312 961 004330 963 004331 964 004334 965 004335 967 004336 969 004337 970 004341 971 004356 973 004357 974 004362 975 004363 978 004364 979 004373 980 004374 985 004375 990 004407 993 004426 996 004433 997 004443 998 004445 1006 004446 1031 004450 1032 004451 1033 004453 1034 004454 1035 004456 1036 004460 1038 004462 1040 004501 1043 004503 1045 004505 1046 004507 1047 004527 1048 004530 1050 004532 1052 004536 1055 004545 1057 004547 1058 004551 1059 004564 1062 004565 1063 004571 1064 004601 1065 004602 1068 004603 1070 004604 1072 004606 1073 004614 1074 004616 1077 004617 1078 004623 1079 004625 1081 004626 1099 004630 1104 004636 1106 004640 1109 004650 1110 004651 1111 004663 1112 004664 1113 004666 1119 004667 1120 004701 1122 004711 1124 004722 1127 004737 1128 004740 1130 004741 1131 004745 1132 004750 1140 004751 1143 004752 1145 004772 1148 005000 1149 005001 1153 005022 1154 005036 1156 005040 1157 005045 1159 005046 1160 005053 1162 005054 ----------------------------------------------------------- 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