COMPILATION LISTING OF SEGMENT gcos_card_utility_ Compiled by: Multics PL/I Compiler, Release 28b, of April 11, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 09/12/83 1101.4 mst Mon Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* *********************************************************** */ 9 10 11 gcos_card_utility_: proc (a_input_ptr, a_output_ptr, a_code); 12 13 14 /* 15* 16* This subroutine does the work of the gcu (gcos_card_utility) 17* command. 18* 19* It is called with pointers to two structures in the argument 20* list, one containing all information pertaining to input, the 21* other, all information pertaining to output. 22* 23* These structures contain pointers to other structures, which 24* contain information about magnetic tape I/O, or lists of 25* input or output items. These structures are only allocated 26* if needed. Otherwise, the pointers to them are null. 27* 28* All these structures are described by the include file: 29* gcos_utility_args_.incl.pl1 30* 31* Actual space for these structures is allocated in 32* gcos_card_utility.pl1 33* 34* This procedure is composed of a large number of internal 35* procedures, for the purpose of making it easily extensible, 36* and to allow the flow of control to be easily followed by 37* readers of the code. The procedures are arranged in 38* alphabetic order by name, following the main procedure. 39**/ 40 41 /* 42* WRITTEN BY T. CASEY MAY 1973 43* MODIFIED BY T. CASEY SEPTEMBER 1973 44* * OCTOBER 1973 45* * MARCH 1974 46* * AUGUST 1974 47* * DECEMBER 1974 48* * JULY 1975 49* * MARCH 1976 50* * JANUARY 1977 51* * 52* MODIFIED BY D. WARD APRIL 1981: 53* * Changed to octal bit constants. 54* * Changed \014 to %page; 55* * 56* MODIFIED BY S. AKERS AUGUST 1981: 57* * Fixed problem of writing zero-length 58* * BCWs to tapes when prior input block 59* * is exactly 320 words. 60* * 61* * Added conversion from gcos_ascii to 62* * gcos_bcd. 63* * 64* * Cleaned up format of program, putting 65* * more stuff into internal procedures. 66* * 67* * Fixed bug which caused an EOF RCW to 68* * be written to a tape. 69* * 70* * Changed Multics ASCII output to 71* * omit trailing blanks. 72* * 73* * Fixed bug in converting GCOS ASCII 74* * to GCOS BCD. 75* * 76* * Modified: Ron Barstad 2.1 83-06-09 Allowed conversion to ascii or gcos_ascii 77* * from BCD media code 0 to be over 80 chars 78* * Modified: Ron Barstad 2.2 83-07-13 Read and believe "char position" field of rcw of gcos records. 79* */ 80 81 /* D E C L A R A T I O N S */ 82 83 84 /* Arguments */ 85 86 dcl a_code fixed bin(35) parm; 87 dcl a_input_ptr ptr parm; 88 dcl a_output_ptr ptr parm; 89 90 /* Argument Structures */ 91 1 1 /* BEGIN INCLUDE FILE gcos_utility_args_.incl.pl1 TAC, December, 1974 1 2* SCA, August, 1981 1 3* 1 4**/ 1 5 1 6 /* Declarations of structures used to pass information from gcos_card_utility, 1 7* the command line interpreter, to the processing subroutine, gcos_card_utility_. */ 1 8 1 9 /* INPUT */ 1 10 1 11 dcl input_ptr ptr; 1 12 1 13 dcl 1 input aligned based (input_ptr), 1 14 1 15 /* following elements are in both input and output structures */ 1 16 2 sw fixed bin aligned, /* = input_code */ 1 17 2 file_name char (168) aligned, /* name of single input file */ 1 18 2 list_ptr ptr, /* ptr to list of input file names, snumbs, or edit names */ 1 19 2 list_count fixed bin aligned, /* number of names in list */ 1 20 2 list_name_size fixed bin aligned, /* length of names (168, 5, or 4) */ 1 21 2 tape_ptr ptr, /* ptr to input tape information structure */ 1 22 2 set fixed bin aligned, /* single_file, imcv, library, or multiple_files */ 1 23 2 format fixed bin aligned, /* ascii, gcos, or blocks */ 1 24 2 medium fixed bin aligned, /* raw, tape, or file */ 1 25 2 brief bit (1) aligned, /* suppress warning messages on input errors */ 1 26 2 truncate_ascii bit (1) aligned, /* truncate ascii input lines to 80 chars if necessary */ 1 27 2 comdk bit (1) aligned, /* decompress any comdks in input */ 1 28 2 long bit (1) aligned, /* display input list item names */ 1 29 1 30 /* following elements are only in input structure, but apply to all processing */ 1 31 2 debug bit (1) aligned, /* call db if any errors - both input and output */ 1 32 2 com_err bit (1) aligned, /* tells subroutine to call com_err_ if errors occur */ 1 33 1 34 /* following elements apply only to input processing */ 1 35 2 all bit (1) aligned, /* copy all jobs or library decks, into separate output files */ 1 36 2 no_canon bit (1) aligned, /* do not canonicalize ascii input */ 1 37 2 tabs_given bit (1) aligned, /* tabstops array (below) contains meaningful values */ 1 38 2 first_line fixed bin aligned, /* number of first input line to be copied */ 1 39 2 last_line fixed bin aligned, /* number of last input line to be copied */ 1 40 2 tabstops (10) fixed bin aligned; /* tabstops to use in canonicalization */ 1 41 1 42 dcl 1 input_list (input.list_count) aligned based (input.list_ptr), 1 43 2 used bit (1) aligned, /* on when item found and copied */ 1 44 2 names char (input.list_name_size) aligned; 1 45 1 46 dcl 1 input_tape aligned based (input.tape_ptr), 1 47 2 id char (32) aligned, /* tape reel number and optional ",Ntrack" */ 1 48 2 label char (12) aligned, /* file name to be found in tape label */ 1 49 2 tracks char (1) aligned, /* 7, 9, or blank if not given */ 1 50 2 retain bit (1) aligned, /* do not dismount tape at end of processing */ 1 51 2 attached bit (1) aligned, /* tape is still mounted from previous use of command */ 1 52 2 position fixed bin; /* file position, or 0 if not given */ 1 53 1 54 /* OUTPUT */ 1 55 1 56 dcl output_ptr ptr; 1 57 1 58 dcl 1 output aligned based (output_ptr), 1 59 1 60 /* following elements are in both input and output structures */ 1 61 2 sw fixed bin aligned, /* = output_code */ 1 62 2 file_name char (168) aligned, /* name of single output file */ 1 63 2 list_ptr ptr, /* ptr to list of output file names */ 1 64 2 list_count fixed bin aligned, /* number of names in list */ 1 65 2 list_name_size fixed bin aligned, /* length of names (will always be 168 - 1 66* included here to keep structures the same */ 1 67 2 tape_ptr ptr, /* ptr to output tape information structure */ 1 68 2 set fixed bin aligned, /* single_file, or multiple_files */ 1 69 2 format fixed bin aligned, /* ascii, gcos, or blocks */ 1 70 2 medium fixed bin aligned, /* raw, tape, or file */ 1 71 2 brief bit (1) aligned, /* suppress warning messages on output errors */ 1 72 2 truncate_ascii bit (1) aligned, /* remove trailing blanks from ascii output lines */ 1 73 2 comdk bit (1) aligned, /* compress all nondollar output cards */ 1 74 2 long bit (1) aligned, /* display names of items written to output */ 1 75 1 76 /* following elements apply only to output processing */ 1 77 2 append bit (1) aligned, /* append to existing output file */ 1 78 2 name_files bit (1) aligned, /* use snumbs or edit names for output file names */ 1 79 2 gcos_ascii bit (1) aligned, /* create gcos_ascii (media code 6) output from ASCII input */ 1 80 2 gcos_bcd bit (1) aligned; /* create gcos_bcd (media code 2) output from ASCII input */ 1 81 1 82 dcl 1 output_list (output.list_count) aligned based (output.list_ptr), 1 83 2 used bit (1) aligned, /* on when item has been written into */ 1 84 2 names char (output.list_name_size) aligned; 1 85 1 86 dcl 1 output_tape aligned based (output.tape_ptr), 1 87 2 id char (32) aligned, /* tape reel number, and optional ",Ntrack" */ 1 88 2 label char (12) aligned, /* file name to put into tape label */ 1 89 2 tracks char (1) aligned, /* 7, 9, or blank if not given */ 1 90 2 retain bit (1) aligned, /* do not dismount tape at end of processing */ 1 91 2 attached bit (1) aligned, /* tape is still mounted from previous use of command */ 1 92 2 position fixed bin; /* file position, or 0 if not given */ 1 93 1 94 /* For program readability, we assign names to the numeric values that the 1 95* multi-valued switches - sw, set, format, and medium - can have */ 1 96 1 97 dcl ( 1 98 input_code init (1), /* sw */ 1 99 output_code init (2), /* sw */ 1 100 1 101 single_file init (11), /* set */ 1 102 imcv init (12), /* set */ 1 103 library init (13), /* set */ 1 104 multiple_files init (14), /* set */ 1 105 1 106 ascii init (15), /* format */ 1 107 gcos init (16), /* format */ 1 108 blocks init (17), /* format */ 1 109 1 110 raw init (18), /* medium */ 1 111 tape init (19), /* medium */ 1 112 file init (20)) /* medium */ 1 113 1 114 int static fixed bin; 1 115 1 116 /* Overlays for input and output structures, 1 117* to allow the same code to set and examine either input or output information, 1 118* depending on the value of io_ptr */ 1 119 1 120 dcl io_ptr ptr; /* = either input_ptr or output_ptr */ 1 121 dcl 1 io like input aligned based (io_ptr); 1 122 dcl 1 io_tape like input_tape aligned based (io.tape_ptr); 1 123 dcl 1 io_list (io.list_count) aligned based (io.list_ptr), 1 124 2 used bit (1) aligned, 1 125 2 names char (io.list_name_size) aligned; 1 126 1 127 /* Stream names for tape and file attachments; selectable by io.sw */ 1 128 1 129 1 130 dcl tape_stream (2) char (32) int static aligned init ( "gcu_tape_input", 1 131 "gcu_tape_output"); 1 132 1 133 dcl file_stream (2) char (32) int static init ( "gcu_file_input", 1 134 "gcu_file_output"); 1 135 1 136 /* Names for messages; selectable by io.sw */ 1 137 1 138 dcl io_names (2) char (8) int static aligned init ( 1 139 "input", 1 140 "output"); 1 141 1 142 /* END INCLUDE FILE gcos_utility_args_.incl.pl1 */ 92 93 94 95 96 /* Error Table Entries */ 97 98 dcl error_table_$action_not_performed ext fixed bin(35); 99 100 101 /* External Static */ 102 103 dcl (gcos_control_tables_$activity_table, 104 gcos_control_tables_$cardtable (8) char (8), 105 gcos_control_tables_$exc_offset fixed bin(17), 106 gcos_control_tables_$nonact fixed bin(24), 107 gcos_control_tables_$tablelen fixed bin(17), 108 gcos_control_tables_$tabstops) external static; 109 110 111 /* External Entries */ 112 113 dcl ( 114 clock_ entry returns (fixed bin(71)), 115 com_err_ entry options (variable), 116 command_query_ entry options (variable), 117 db entry, 118 decode_clock_value_ entry (fixed bin(71), fixed bin(24), fixed bin(24), fixed bin(24), fixed bin(71), fixed bin(24), char (3) aligned), 119 decode_nstd_status_ entry (bit (72) aligned, char (*) varying), 120 gcos_cv_ascii_gebcd_check_ entry (ptr, fixed bin(24), ptr, fixed bin(35)), 121 gcos_cv_gebcd_ascii_ entry (ptr, fixed bin(24), ptr), 122 ioa_ entry options (variable), 123 124 ios_$attach entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned), 125 ios_$detach entry (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned), 126 ios_$order entry (char (*) aligned, char (*) aligned, ptr, bit (72) aligned), 127 ios_$read entry (char (*) aligned, ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned), 128 ios_$seek entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(24), bit (72) aligned), 129 ios_$setdelim entry (char (*) aligned, fixed bin(24), bit (9), fixed bin(24), bit (9), bit (72) aligned), 130 ios_$setsize entry (char (*) aligned, fixed bin(24), bit (72) aligned), 131 ios_$tell entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(24), bit (72) aligned), 132 ios_$write entry (char (*) aligned, ptr, fixed bin(24), fixed bin(24), fixed bin(24), bit (72) aligned), 133 system_info_$installation_id entry (char (*)) 134 ) external; 135 136 dcl (addr, addrel, before, bin, bit, divide, fixed, hbound, index, length, max, min, mod, 137 null, reverse, rtrim, string, substr, unspec, verify) builtin; 138 139 dcl cleanup condition; 140 141 142 143 /* Work areas and overlays for them */ 144 145 146 dcl ascii_block char (input_block_len) based (input_block_ptr); 147 dcl input_block (320) bit (36) aligned /* PLACE FOR ios_$read TO PUT THE DATA */; 148 dcl input_block_len fixed bin(24); 149 dcl input_block_ptr ptr; 150 151 dcl 1 bcw aligned based, 152 153 2 bsn bit (18) unaligned, 154 2 length bit (18) unaligned; 155 156 dcl 1 bcw_word based (input_block_ptr) aligned, 157 158 2 bcw_num fixed bin (18) unsigned unaligned, 159 2 bcw_len fixed bin (18) unsigned unaligned; 160 161 dcl ascii_card char (ascii_line_len) aligned based (addr (ascii_line)); 162 dcl ascii_line char (1280) aligned /* PLACE TO PUT ASCII LINE TRANSLATED FROM BCD */; 163 164 dcl ascii_line_ptr ptr; 165 dcl ascii_line_len fixed bin(24)init (80); /* a variable, in case we ever want to 166* create variable length output lines */ 167 168 dcl gcos_work_area (320) bit (36) aligned; /* PLACE TO PUT GCOS RECORD, 169* TRANSLATED FROM ASCII OR RAW INPUT */ 170 dcl gcos_work_area_ptr ptr; 171 172 dcl 1 bcd_card aligned based (bcd_work_area_ptr), 173 2 rcw bit (36) unaligned, 174 2 column (84) bit (6) unaligned; 175 176 dcl 1 bin_card aligned based, 177 2 rcw bit (36) unaligned, 178 2 column (80) bit (12) unaligned; 179 180 dcl comdk_card_ptr ptr; 181 dcl 1 comdk_card aligned based (comdk_card_ptr), /* for decoding input comdk cards */ 182 2 rcw bit (36) unaligned, 183 2 col1 bit (12) unaligned, /* col 1 */ 184 2 seq_no bit (24) unaligned, /* cols 2, 3 */ 185 2 checksum bit (36) unaligned, /* cols 4-6 */ 186 2 char (132) bit (6) unaligned, /* cols 7-72 */ 187 2 seq_col (8) bit (12) unaligned; /* col 73-80 */ 188 189 dcl 1 k_card like comdk_card aligned based (comdk_work_area_ptr) /* for encoding output comdk cards */; 190 191 dcl bit_string bit (bit_string_len) unaligned based /* overlay for moving bcd chars */; 192 dcl bit_string_len fixed bin(24); 193 194 dcl char_string char (char_string_len) unaligned based /* overlay for moving ASCII chars */; 195 dcl char_string_len fixed bin(24); 196 197 dcl word_string (word_string_len) bit (36) aligned based /* overlay for moving words */; 198 dcl word_string_len fixed bin(24); 199 200 dcl bcd_work_area (15) bit (36) aligned /* PLACE TO BUILD BCD RECORD FROM COMDK CARDS */; 201 dcl bcd_work_area_ptr ptr; 202 203 dcl gcos_record_len fixed bin(24); 204 dcl gcos_record_ptr ptr; 205 dcl 1 gcos_record aligned based (gcos_record_ptr), /* overlay for wherever a gcos record is - in input_block, 206* in gcos_work_area, or in bcd_work_area */ 207 2 rcw bit (36) aligned, 208 2 data_words (gcos_record_len) bit (36) aligned; 209 210 dcl 1 rcw aligned based, 211 2 length bit (18) unaligned, 212 2 char_pos bin (2) unsigned unaligned, 213 2 eof bit (4) unaligned, 214 2 zeroes bit (2) unaligned, 215 2 media_code bit (4) unaligned, 216 2 report_code bit (6) unaligned; 217 218 dcl raw_card (80) bit (12) unaligned /* PLACE TO BUILD RAW OUTPUT CARD TRANSLATED FROM BCD */; 219 dcl raw_card_ptr ptr; 220 221 dcl comdk_work_area (28) bit (36) aligned /* PLACE TO BUILD OUTPUT COMDK CARDS */; 222 dcl comdk_work_area_ptr ptr; 223 224 dcl write_buffer (320) bit (36) aligned /* PLACE TO ACCUMULATE OUTPUT RECORDS FOR ios_$write */; 225 dcl write_buffer_ptr ptr; 226 227 dcl act_ptr ptr /* to look up tabstops for an activity */; 228 dcl 1 act_table_entry aligned based (act_ptr), /* overlay for table entry for one activity */ 229 2 fill1 fixed bin(24), 230 2 fill2 char (4), 231 2 tab_index fixed bin(24); /* position in tabstops table of settings for this activity */ 232 233 dcl tabstop_ptr ptr /* pointer to external static tabstop table */; 234 dcl 1 tabstops aligned based (tabstop_ptr), 235 2 count fixed bin(24)aligned, /* number of sets of tabstops */ 236 2 tab (0:tabstops.count - 1), 237 3 stop (10) fixed bin(24)aligned; /* each set is 10 or fewer stops */ 238 239 240 241 /* Tape label structures */ 242 243 dcl 1 header_label aligned based (label_ptr), 244 2 btl bit (72) aligned, /* GE/b/b600/bBTL/b */ 245 2 installation bit (36) aligned, 246 2 reel_ser_no bit (36) aligned, /* /bxxxxx */ 247 2 file_ser_no bit (36) aligned, /* must = reel_ser_no, for single-reel files */ 248 2 reel_seq_no bit (36) aligned, /* /b/bxxxx - xxxx=1 for single-reel files */ 249 2 creation_date bit (36) aligned, /* /byyddd */ 250 2 retention_days bit (36) aligned, /* /b/b/bxxx */ 251 2 file_name bit (72) aligned, 252 2 unused (3) bit (36) aligned, 253 2 prverr bit (36) aligned; /* /b/b/b/b/b/b */ 254 255 dcl 1 saved_header_label like header_label aligned automatic; 256 257 dcl 1 partial_label aligned based (label_ptr), 258 2 btl bit (72) aligned, 259 2 installation bit (36) aligned, 260 2 reel_ser_no bit (36) aligned, 261 2 zero_words (6) bit (36) aligned, /* must be zero, for partial label */ 262 2 unused (4) bit (36) aligned; 263 264 dcl 1 trailer_label aligned based (label_ptr), 265 2 eof bit (36) aligned, /* /bEOF/b/b or /bEOR/b/b */ 266 2 block_count bit (36) aligned, 267 2 unused (11) bit (36) aligned, 268 2 next_reel bit (36) aligned; /* /b/b/b/b/b/b */ 269 270 /* Switches */ 271 272 dcl ( 273 appending_to_output, 274 eof, 275 eoj, 276 file_eob, 277 file_eof, 278 found_last_line, 279 input_comdk_open, 280 just_looking, 281 looking_for_first_line, 282 looking_for_last_line, 283 no_end_card, 284 output_comdk_open, 285 rcw_eof 286 ) bit (1) aligned init ("0"b); 287 288 dcl no_label (2) bit (1) aligned init ((2) (1)"0"b); 289 290 291 /* Error Handling Variables */ 292 293 dcl code fixed bin(35) based (addr (status)); 294 dcl status bit (72) aligned; 295 296 297 /* Fixed Bin */ 298 299 dcl tod fixed bin(71); 300 301 dcl ( 302 bcd_col_index, 303 bin_cards_skipped, 304 block_serial_number, 305 comdk_char_index, 306 comdk_error_count, 307 comdk_out_index, 308 dom, 309 dow, 310 element_size, 311 elements_wanted, 312 elements_written, 313 err_num, 314 field_len, 315 file_record_count, 316 first_key, 317 i, 318 input_block_count, 319 input_record_count, 320 item_index, 321 item_length, 322 j, 323 k, 324 last_key, 325 list_index, 326 month, 327 next_input_index, 328 next_output_index, 329 nondollar_tab_index, 330 offset, 331 output_block_count, 332 output_block_len, 333 output_record_count, 334 path_len, 335 prev_comdk_seq_no, 336 raw_cards_bad, 337 raw_chars_bad, 338 remaining_block_len, 339 remaining_output_words, 340 string_len, 341 year 342 ) fixed bin(24)init (0); 343 344 dcl chase fixed bin(1) init (1); 345 dcl seq_col (5:8) fixed bin(24)/* numeric values of punches in cols 77-80 */; 346 347 348 /* Pointers - Additional pointers are declared adjacent to the variables whose addresses they are initialized to */ 349 350 dcl ( 351 label_ptr, 352 output_word_ptr, 353 saved_record_ptr) 354 ptr; 355 356 357 /* Strings */ 358 359 /* ASCII strings */ 360 361 dcl punches char (36) varying; 362 363 dcl punch (12) char (3) int static init ("-12", "-11", "-0", "-1", "-2", "-3", "-4", "-5", "-6", "-7", "-8", "-9"); 364 365 366 dcl inst char (32); 367 dcl me char (20) int static init ("gcos_card_utility_"); 368 dcl tape_status_message char (50) varying; 369 dcl (input_stream_name, output_stream_name) char (32) aligned; 370 371 dcl ascii_search_key (15) char (15) aligned int static init ( 372 "$ snumb ", 373 "$ gmap ", 374 "$ 355map ", 375 "$ object ", 376 "$ forty ", 377 "$ fortran ", 378 "$ ids ", 379 "$ pl1 ", 380 "$ cobol ", 381 "$ asm66 ", 382 "$ cbl74 ", 383 "$ cbl68 ", 384 "$ malt ", 385 "$ ilang ", 386 "$ ids2 "); 387 388 dcl answer char (8) varying init (""); 389 dcl card_type char (8) aligned; 390 dcl edit_name char (8); 391 dcl item_name char (8) aligned /* edit name or snumb */; 392 dcl next_output_suffix char (6) aligned; 393 dcl zone char (3) aligned; 394 dcl ascii_newline char (1) int static init (" 395 "); 396 dcl ascii_backspace char (1) int static init (""); 397 dcl ascii_pads char (4) int static init ("") /* four octal 177's */; 398 dcl ascii_tab char (1) int static init (" "); 399 400 /* BCD and binary strings */ 401 402 dcl bcd_blank_card (14) bit (36) aligned int static init 403 ((13) (6) "010000"b, "010000010000"b); /* we HOPE this puts blanks in 80 6-bit chars, 404* and fills the rest of the last word with zeros */ 405 406 dcl bcd_btl bit(72)static int options(constant) init("272520200600002022634320"b3) /* GEbb600bBTLb (BCD). */; 407 408 dcl bcd_beofbb bit(36)static int options(constant)init("202546262020"b3) /* bEOFbb (BCD). */; 409 410 dcl bcd_beorbb bit(36)static int options(constant)init("202546512020"b3) /* bEORbb (BCD). */; 411 412 dcl bcd_b1 bit(36)static int options(constant)init("200000000000"b3) /* b00000 (BCD). */; 413 414 dcl bcd_b2 bit(36)static int options(constant)init("202000000000"b3) /* bb0000 (BCD). */; 415 416 dcl bcd_b3 bit(36)static int options(constant)init("202020000000"b3) /* bbb000 (BCD). */; 417 418 dcl bcd_b6 bit(36)static init options(constant)init((6)"20"b3) /* 6 blanks (BCD). */; 419 420 dcl ascii_header_rcw bit(36) static int options(constant) init("000024001000"b3); 421 /* rec len = 20; media code = 8 */ 422 423 dcl bcd_rcw bit(36)static int options(constant)init("000016000200"b3); 424 /* rec len = 14; media code = 0010 (bcd card) */ 425 426 dcl bin_rcw bit(36)static int options(constant)init( "000033000100"b3); 427 /* rec len = 27; media code = 0001 (binary card) */ 428 429 dcl eof_rcw bit(36)static int options(constant)init( "000000170000"b3); 430 /* rec len = 0; eof = bcd_eof; media code,report code = 0 */ 431 dcl bcd_endjob bit(36)static int options(constant)init( "254524414622"b3) /* ENDJOB (BCD). */; 432 dcl gcd_star_eof bit(36)static int options(constant)init( "545454254626"b3) /* ***EOF (BCD). */; 433 dcl bcd_search_key (15)bit(36)static int options(constant)init( 434 "624564442220"b3 /* SNUMBb (BCD). */ 435 ,"274421472020"b3 /* GMAPbb (BCD). */ 436 ,"030505442147"b3 /* 355MAP (BCD). */ 437 ,"462241252363"b3 /* OBJECT (BCD). */ 438 ,"264651637020"b3 /* FORTYb (BCD). */ 439 ,"264651635121"b3 /* FORTRA (BCD). */ 440 ,"312462202020"b3 /* IDSbbb (BCD). */ 441 ,"474301202020"b3 /* PL1bbb (BCD). */ 442 ,"234622464320"b3 /* COBOLb (BCD). */ 443 ,"216244060620"b3 /* ASM66b (BCD). */ 444 ,"232243070420"b3 /* CBL74b (BCD). */ 445 ,"232243061020"b3 /* CBL68b (BCD). */ 446 ,"442143632020"b3 /* MALTbb (BCD). */ 447 ,"314321452720"b3 /* ILANGb (BCD). */ 448 ,"312462022020"b3 /* IDS2bb (BCD). */ 449 ); 450 451 dcl bcd_dkend bit(36)static int options(constant)init( "244225452420"b3) /* DKENDb (BCD). */; 452 453 dcl bcd_edit_name (8) bit (6) unaligned; 454 455 dcl comdk_col_1 bit(12)static int options(constant)init("5005"b3); 456 457 dcl ascii_header_media_code bit (4) unaligned int static init ("1000"b) /* media code 8 - header for gcos TSS ascii file */; 458 dcl ascii_media_code bit (4) unal int static init ("0110"b) /* media code 6 - ASCII */; 459 dcl bcd_blank bit(6)static int options(constant)init("20"b3) /* blank (BCD). */; 460 dcl bcd_dollar bit(6)static int options(constant)init( "53"b3) /* $ (BCD). */; 461 dcl bcd_eof bit(4)static int options(constant)init("1111"b); 462 dcl bcd_media_code bit (4) unaligned int static init ("0010"b) /* media code 2 - BCD card */; 463 dcl plain_bcd_media_code bit (4) unal int static init ("0000"b) /* media code 0 - BCD variable length record */; 464 465 466 dcl pten (0:5) int static fixed bin(24)init (1, 10, 100, 1000, 10000, 100000); 467 468 469 470 471 /* TRANSLATION TABLES FOR CONVERSION FROM-TO RAW CARD IMAGES */ 472 473 474 /* BCD characters, in same order as their corresponding card punch codes in bin_table, below */ 475 476 dcl bcd_table (0:63) bit (6) aligned internal static init ( 477 "010000"b, /* " " */ 478 "001001"b, /* "9" */ 479 "001000"b, /* "8" */ 480 "000111"b, /* "7" */ 481 "001111"b, /* "?" */ 482 "000110"b, /* "6" */ 483 "001110"b, /* ">" */ 484 "000101"b, /* "5" */ 485 "001101"b, /* ":" */ 486 "000100"b, /* "4" */ 487 "001100"b, /* "@" */ 488 "000011"b, /* "3" */ 489 "001011"b, /* "#" */ 490 "000010"b, /* "2" */ 491 "001010"b, /* "[" */ 492 "000001"b, /* "1" */ 493 "000000"b, /* "0" */ 494 "111001"b, /* "z" */ 495 "111000"b, /* "y" */ 496 "110111"b, /* "x" */ 497 "111111"b, /* "!" */ 498 "110110"b, /* "w" */ 499 "111110"b, /* """ */ 500 "110101"b, /* "v" */ 501 "111101"b, /* "=" */ 502 "110100"b, /* "u" */ 503 "111100"b, /* "%" */ 504 "110011"b, /* "t" */ 505 "111011"b, /* "," */ 506 "110010"b, /* "s" */ 507 "111010"b, /* "<-" */ 508 "110001"b, /* "/" */ 509 "101010"b, /* "-" */ 510 "101001"b, /* "r" */ 511 "101000"b, /* "q" */ 512 "100111"b, /* "p" */ 513 "101111"b, /* "'" */ 514 "100110"b, /* "o" */ 515 "101110"b, /* ";" */ 516 "100101"b, /* "n" */ 517 "101101"b, /* ")" */ 518 "100100"b, /* "m" */ 519 "101100"b, /* "*" */ 520 "100011"b, /* "l" */ 521 "101011"b, /* "$" */ 522 "100010"b, /* "k" */ 523 "100001"b, /* "j" */ 524 "100000"b, /* "|" */ 525 "011010"b, /* "&" */ 526 "011001"b, /* "i" */ 527 "011000"b, /* "h" */ 528 "010111"b, /* "g" */ 529 "011111"b, /* "\" */ 530 "010110"b, /* "f" */ 531 "011110"b, /* "<" */ 532 "010101"b, /* "e" */ 533 "011101"b, /* "(" */ 534 "010100"b, /* "d" */ 535 "011100"b, /* "]" */ 536 "010011"b, /* "c" */ 537 "011011"b, /* "." */ 538 "010010"b, /* "b" */ 539 "010001"b, /* "a" */ 540 "110000"b /* "+" */ 541 ); 542 543 /* card punch codes for the GEBCD characters, arranged in ascending order of their 544* numeric values, to allow lookup of INPUT raw card column contents, using a 545* half-interval (binary) search */ 546 547 dcl bin_table (0: 63) bit (12) aligned internal static init ( 548 "000000000000"b, /* " " */ 549 "000000000001"b, /* "9" */ 550 "000000000010"b, /* "8" */ 551 "000000000100"b, /* "7" */ 552 "000000000110"b, /* "?" */ 553 "000000001000"b, /* "6" */ 554 "000000001010"b, /* ">" */ 555 "000000010000"b, /* "5" */ 556 "000000010010"b, /* ":" */ 557 "000000100000"b, /* "4" */ 558 "000000100010"b, /* "@" */ 559 "000001000000"b, /* "3" */ 560 "000001000010"b, /* "#" */ 561 "000010000000"b, /* "2" */ 562 "000010000010"b, /* "[" */ 563 "000100000000"b, /* "1" */ 564 "001000000000"b, /* "0" */ 565 "001000000001"b, /* "z" */ 566 "001000000010"b, /* "y" */ 567 "001000000100"b, /* "x" */ 568 "001000000110"b, /* "!" */ 569 "001000001000"b, /* "w" */ 570 "001000001010"b, /* """ */ 571 "001000010000"b, /* "v" */ 572 "001000010010"b, /* "=" */ 573 "001000100000"b, /* "u" */ 574 "001000100010"b, /* "%" */ 575 "001001000000"b, /* "t" */ 576 "001001000010"b, /* "," */ 577 "001010000000"b, /* "s" */ 578 "001010000010"b, /* "<-" */ 579 "001100000000"b, /* "/" */ 580 "010000000000"b, /* "-" */ 581 "010000000001"b, /* "r" */ 582 "010000000010"b, /* "q" */ 583 "010000000100"b, /* "p" */ 584 "010000000110"b, /* "'" */ 585 "010000001000"b, /* "o" */ 586 "010000001010"b, /* ";" */ 587 "010000010000"b, /* "n" */ 588 "010000010010"b, /* ")" */ 589 "010000100000"b, /* "m" */ 590 "010000100010"b, /* "*" */ 591 "010001000000"b, /* "l" */ 592 "010001000010"b, /* "$" */ 593 "010010000000"b, /* "k" */ 594 "010100000000"b, /* "j" */ 595 "011000000000"b, /* "|" */ 596 "100000000000"b, /* "&" */ 597 "100000000001"b, /* "i" */ 598 "100000000010"b, /* "h" */ 599 "100000000100"b, /* "g" */ 600 "100000000110"b, /* "\" */ 601 "100000001000"b, /* "f" */ 602 "100000001010"b, /* "<" */ 603 "100000010000"b, /* "e" */ 604 "100000010010"b, /* "(" */ 605 "100000100000"b, /* "d" */ 606 "100000100010"b, /* "]" */ 607 "100001000000"b, /* "c" */ 608 "100001000010"b, /* "." */ 609 "100010000000"b, /* "b" */ 610 "100100000000"b, /* "a" */ 611 "101000000000"b /* "+" */ 612 ); 613 614 /* card punch codes for the GEBCD characters, arranged in order of the numeric 615* values of their corresponding 6-bit BCD codes, to allow OUTPUT raw card column 616* contents to be obtained using the BCD character as an index into the table */ 617 618 dcl raw_table (0:63) bit (12) aligned int static init ( 619 "001000000000"b, /* 0 */ 620 "000100000000"b, /* 1 */ 621 "000010000000"b, /* 2 */ 622 "000001000000"b, /* 3 */ 623 "000000100000"b, /* 4 */ 624 "000000010000"b, /* 5 */ 625 "000000001000"b, /* 6 */ 626 "000000000100"b, /* 7 */ 627 "000000000010"b, /* 8 */ 628 "000000000001"b, /* 9 */ 629 "000010000010"b, /* [ */ 630 "000001000010"b, /* # */ 631 "000000100010"b, /* @ */ 632 "000000010010"b, /* : */ 633 "000000001010"b, /* > */ 634 "000000000110"b, /* ? */ 635 "000000000000"b, /* blank */ 636 "100100000000"b, /* A */ 637 "100010000000"b, /* B */ 638 "100001000000"b, /* C */ 639 "100000100000"b, /* D */ 640 "100000010000"b, /* E */ 641 "100000001000"b, /* F */ 642 "100000000100"b, /* G */ 643 "100000000010"b, /* H */ 644 "100000000001"b, /* I */ 645 "100000000000"b, /* & */ 646 "100001000010"b, /* . */ 647 "100000100010"b, /* ] */ 648 "100000010010"b, /* ( */ 649 "100000001010"b, /* < */ 650 "100000000110"b, /* \ */ 651 "011000000000"b, /* | */ 652 "010100000000"b, /* J */ 653 "010010000000"b, /* K */ 654 "010001000000"b, /* L */ 655 "010000100000"b, /* M */ 656 "010000010000"b, /* N */ 657 "010000001000"b, /* O */ 658 "010000000100"b, /* P */ 659 "010000000010"b, /* Q */ 660 "010000000001"b, /* R */ 661 "010000000000"b, /* - */ 662 "010001000010"b, /* $ */ 663 "010000100010"b, /* * */ 664 "010000010010"b, /* ) */ 665 "010000001010"b, /* ; */ 666 "010000000110"b, /* ' */ 667 "101000000000"b, /* + */ 668 "001100000000"b, /* / */ 669 "001010000000"b, /* S */ 670 "001001000000"b, /* T */ 671 "001000100000"b, /* U */ 672 "001000010000"b, /* V */ 673 "001000001000"b, /* W */ 674 "001000000100"b, /* X */ 675 "001000000010"b, /* Y */ 676 "001000000001"b, /* Z */ 677 "001010000010"b, /* <- (left arrow) */ 678 "001001000010"b, /* , */ 679 "001000100010"b, /* % */ 680 "001000010010"b, /* = */ 681 "001000001010"b, /* " */ 682 "001000000110"b /* ! */ 683 ); 684 685 686 687 688 689 2 1 /* BEGIN INCLUDE FILE query_info.incl.pl1 TAC June 1, 1973 */ 2 2 /* Renamed to query_info.incl.pl1 and cp_escape_control added, 08/10/78 WOS */ 2 3 /* version number changed to 4, 08/10/78 WOS */ 2 4 /* Version 5 adds explanation_(ptr len) 05/08/81 S. Herbst */ 2 5 /* Version 6 adds literal_sw, prompt_after_explanation switch 12/15/82 S. Herbst */ 2 6 2 7 dcl 1 query_info aligned, /* argument structure for command_query_ call */ 2 8 2 version fixed bin, /* version of this structure - must be set, see below */ 2 9 2 switches aligned, /* various bit switch values */ 2 10 3 yes_or_no_sw bit (1) unaligned init ("0"b), /* not a yes-or-no question, by default */ 2 11 3 suppress_name_sw bit (1) unaligned init ("0"b), /* do not suppress command name */ 2 12 3 cp_escape_control bit (2) unaligned init ("00"b), /* obey static default value */ 2 13 /* "01" -> invalid, "10" -> don't allow, "11" -> allow */ 2 14 3 suppress_spacing bit (1) unaligned init ("0"b), /* whether to print extra spacing */ 2 15 3 literal_sw bit (1) unaligned init ("0"b), /* ON => do not strip leading/trailing white space */ 2 16 3 prompt_after_explanation bit (1) unaligned init ("0"b), /* ON => repeat question after explanation */ 2 17 3 padding bit (29) unaligned init (""b), /* pads it out to t word */ 2 18 2 status_code fixed bin (35) init (0), /* query not prompted by any error, by default */ 2 19 2 query_code fixed bin (35) init (0), /* currently has no meaning */ 2 20 2 21 /* Limit of data defined for version 2 */ 2 22 2 23 2 question_iocbp ptr init (null ()), /* IO switch to write question */ 2 24 2 answer_iocbp ptr init (null ()), /* IO switch to read answer */ 2 25 2 repeat_time fixed bin (71) init (0), /* repeat question every N seconds if no answer */ 2 26 /* minimum of 30 seconds required for repeat */ 2 27 /* otherwise, no repeat will occur */ 2 28 /* Limit of data defined for version 4 */ 2 29 2 30 2 explanation_ptr ptr init (null ()), /* explanation of question to be printed if */ 2 31 2 explanation_len fixed bin (21) init (0); /* user answers "?" (disabled if ptr=null or len=0) */ 2 32 2 33 dcl query_info_version_3 fixed bin int static options (constant) init (3); 2 34 dcl query_info_version_4 fixed bin int static options (constant) init (4); 2 35 dcl query_info_version_5 fixed bin int static options (constant) init (5); 2 36 dcl query_info_version_6 fixed bin int static options (constant) init (6); /* the current version number */ 2 37 2 38 /* END INCLUDE FILE query_info.incl.pl1 */ 690 691 3 1 /* BEGIN INCLUDE FILE gcos_xlate_bcd_ascii_.incl.pl1 5/19/76/ RHM */ 3 2 3 3 /* Change: Dave Ward 05/20/81 options constant. 3 4**/ 3 5 3 6 dcl xlate (0: 63) char(1) int static options(constant) init( /* bcd to ascii xlation table */ 3 7 3 8 "0","1","2","3","4","5","6","7","8","9","[","#","@",":",">","?", 3 9 3 10 " ","a","b","c","d","e","f","g","h","i","&",".","]","(","<","\", 3 11 3 12 "^","j","k","l","m","n","o","p","q","r","-","$","*",")",";","'", 3 13 3 14 "+","/","s","t","u","v","w","x","y","z","_",",","%","=","""","!" ); 3 15 3 16 /* END INCLUDE FILE gcos_xlate_bcd_ascii_.incl.pl1 */ 692 693 694 /* P R O C E D U R E */ 695 696 /* Initialization */ 697 698 input_ptr = a_input_ptr; /* copy argument structure pointers to */ 699 output_ptr = a_output_ptr; /* local storage, for better accessing code */ 700 nondollar_tab_index = -1; /* initialize to "no value assigned" code */ 701 query_info.yes_or_no_sw = "1"b; /* we ask only yes or no questions */ 702 703 on condition (cleanup) call cleanup_proc; 704 705 unspec (write_buffer) = ""b; /* zero the output buffer, 706* to avoid garbage at the ends of short records */ 707 if output.name_files 708 then do; /* set suffix for output file names */ 709 if output.format = ascii then 710 next_output_suffix = ".ascii"; 711 else if output.medium = raw then 712 next_output_suffix = ".raw"; 713 else if output.comdk then 714 next_output_suffix = ".comdk"; 715 else next_output_suffix = ".gcos"; 716 end; 717 718 do io_ptr = input_ptr, output_ptr; 719 if io.medium = tape then 720 if io_tape.label = "-nl" 721 | io_tape.label = "-no_label" 722 | io_tape.label = "-no_labels" 723 then no_label (io.sw) = "1"b; 724 end; 725 726 input_block_ptr = addr (input_block); /* get pointers to work areas */ 727 ascii_line_ptr = addr (ascii_line); 728 gcos_work_area_ptr = addr (gcos_work_area); 729 bcd_work_area_ptr = addr (bcd_work_area); 730 raw_card_ptr = addr (raw_card); 731 comdk_work_area_ptr = addr (comdk_work_area); 732 write_buffer_ptr = addr (write_buffer); 733 734 /* do not get ptr to ext static tabstop table now. wait to see if it is needed. 735* do it in open_input. */ 736 737 738 /* Processing (What there is of it...) */ 739 740 if input.set = single_file 741 then call process_single_file; 742 else if input.set = imcv 743 then call process_imcv; 744 else if input.set = library 745 then call process_library_file; 746 else if input.set = multiple_files 747 then call process_multiple_files; 748 else call fatal_error (1); /* error_table_$badcall */ 749 750 /* Just return normally, no fuss, no bother. */ 751 752 a_code = code; 753 return; 754 755 /* Whoops! Something went bust, so gotta clean up first. */ 756 757 cleanup_and_return: 758 call cleanup_proc; 759 a_code = code; 760 return; 761 762 /* END OF MAIN PROCEDURE. INTERNAL PROCEDURES AND DEBUGGING ENTRIES FOLLOW */ 763 764 bcd_string: proc (in_string, in_count) returns (bit (*) aligned); 765 766 dcl in_string char (*); 767 dcl ret_bits bit (ret_len) aligned based (addr (work_bits)); 768 dcl work_bits bit (72) aligned; 769 dcl work_chars char (12) aligned; 770 dcl (digit, i, in_count, in_no, indx, num, ret_len, xnum) fixed bin(24); 771 772 work_chars = in_string; /* align the input string */ 773 call gcos_cv_ascii_gebcd_check_ (addr (work_chars), in_count, addr (work_bits), code); 774 if code ^= 0 then do; 775 call ioa_ ("Error in character ^d of : ~a", code, in_string); 776 code = 0; /* code is position of bad char - not error table code */ 777 call fatal_error (2); /* bad string - can't convert to BCD */ 778 end; 779 780 return_string: /* come here from bcd_string_bin entry point */ 781 ret_len = in_count*6; /* compute length in bits of the BCD string */ 782 return (ret_bits); 783 784 bcd_string_bin: entry (in_no, in_count) returns (bit (*) aligned); 785 786 indx = 1; 787 num = in_no; 788 789 do i = in_count-1 by -1 to 0; /* convert digits left to right */ 790 xnum = mod (num, pten (i)); /* get digits to right of the one we want */ 791 /* pten(i) contains 10**i */ 792 digit = divide (num-xnum, pten (i), 17, 0); /* get digit we want */ 793 if indx = 1 then /* if first time around loop */ 794 if digit > 9 then /* check for number too large for field */ 795 call fatal_error (3); /* number to large for BCD field */ 796 substr (work_bits, indx, 6) = bit (fixed (digit, 6)); /* make BCD char from digit */ 797 indx = indx + 6; /* move to next digit in receiving field */ 798 num = xnum; /* work with digits to right of one just converted */ 799 end; 800 801 goto return_string; /* go return the string when done converting */ 802 803 end bcd_string; 804 805 canonicalizer: proc (input_string_ptr, initial_input_characters, 806 output_card_ptr, initial_output_columns); 807 808 /* NOTE: a copy of this internal procedure exists also in gcos_gein_pass1_. 809* The initialization is different, but the canonicalization is the same. 810* Any changes should be made to both copies, if appropriate. */ 811 812 dcl initial_input_characters fixed bin(24); 813 dcl input_string char (initial_input_characters) based (input_string_ptr); 814 dcl input_string_ptr ptr; 815 816 dcl initial_output_columns fixed bin(24); 817 dcl output_card char (initial_output_columns) based (output_card_ptr); 818 dcl output_card_ptr ptr; 819 820 dcl ( 821 next_input_character, 822 next_output_column, 823 next_backspace, /* relative to next_input_character */ 824 next_tab, /* relative to next_input_character */ 825 remaining_input_characters, 826 remaining_output_columns, 827 character_count, 828 blank_count, 829 first_blank, 830 i, 831 backspace_count 832 ) fixed bin(24); 833 834 dcl (more_backspaces, 835 more_tabs) bit (1) aligned; 836 837 dcl tabstop (10) fixed bin(24)based (tab_ptr) /* tabstops currently in use */; 838 dcl tab_ptr ptr /* pointer to tabs currently in use */; 839 840 841 842 /* INITIALIZE */ 843 844 next_input_character, next_output_column = 1; 845 remaining_input_characters = initial_input_characters; 846 remaining_output_columns = initial_output_columns; 847 848 more_backspaces, more_tabs = "1"b; /* we want to look for backspaces and tabs at the start */ 849 850 if substr (input_string, remaining_input_characters, 1) = ascii_newline /* if last char is a newline */ 851 then remaining_input_characters = remaining_input_characters - 1; /* then get rid of it */ 852 853 854 if substr (input_string, 1, 1) = "$" then 855 set_dollar_tabs: do; 856 857 tab_ptr = addr (tab (0)); /* get pointer to dollar tabs */ 858 859 end set_dollar_tabs; 860 861 else /* not a dollar card */ 862 set_nondollar_tabs: do; 863 864 if input.tabs_given then /* if user supplied nondollar tabstops */ 865 tab_ptr = addr (input.tabstops); /* get pointer to user-supplied tabstops */ 866 867 else do; /* otherwise use the ones we looked up */ 868 if nondollar_tab_index = -1 then call fatal_error (4); /* check for case of: 869* 1) not a complete job, 870* so no activity card to determine tabs from, and 871* 2) no tabs given by user, resulting in no tabstops to use */ 872 873 else tab_ptr = addr (tab (nondollar_tab_index)); /* get pointer to tabs for this activity */ 874 end; 875 876 end set_nondollar_tabs; 877 878 879 /* MAIN LOOP. FILL UP OUTPUT CARD */ 880 881 canon_loop: do while (remaining_output_columns > 0); /* keep going while there is any room on output card */ 882 883 if more_backspaces then /* if there MIGHT be more backspaces */ 884 find_next_backspace: do; /* then look for one */ 885 886 next_backspace = index (substr (input_string, next_input_character, 887 remaining_input_characters), ascii_backspace); 888 if next_backspace = 0 then more_backspaces = "0"b; /* if none found, remember not to look again */ 889 890 end find_next_backspace; 891 892 if more_tabs then /* if there MIGHT be more tabs */ 893 find_next_tab: do; /* then look for one */ 894 next_tab = index (substr (input_string, next_input_character, 895 remaining_input_characters), ascii_tab); 896 if next_tab = 0 then more_tabs = "0"b; /* if none found, remember not to look again */ 897 end find_next_tab; 898 899 if more_backspaces then /* if we found a backspace */ 900 look_at_backspace: do; /* see if it is in a legal position */ 901 /* maybe sometime allow backspaces to be in places other than 902* immediately following tabs, but for now, it's an error */ 903 904 if ^more_tabs | next_backspace ^= next_tab+1 then call fatal_error (5); 905 906 end look_at_backspace; 907 908 if more_tabs then /* if we found a tab, we want to move the characters before it */ 909 process_tab: do; /* to the output card, and fill with blanks to next tab stop */ 910 911 character_count = min ( /* compute the number of characters */ 912 next_tab - 1, /* before the tab */ 913 remaining_output_columns); /* but not more than there's room for on output card */ 914 915 first_blank = next_output_column + character_count; 916 917 do i = 1 to hbound (tabstop, 1) /* look for a tabstop */ 918 while (tabstop (i) <= first_blank); /* that's past the characters */ 919 /* if it's in the column immediately after the characters, 920* then go to the next one, the way a typewriter will */ 921 end; 922 923 if i <= hbound (tabstop, 1) then /* if we found one */ 924 925 blank_count = min ( /* compute the number of blanks */ 926 tabstop (i) - first_blank, /* needed to get there */ 927 remaining_output_columns); /* but not more than there's room for on output card */ 928 929 else /* if no more tabstops, replace tab with one blank */ 930 blank_count = min (1, remaining_output_columns); 931 932 933 end process_tab; 934 935 else 936 no_more_tabs: do; /* if there are no more tabs, 937* we want to move the rest of the input characters 938* to the output card, and fill the rest of it with blanks */ 939 940 character_count = min ( /* compute rest of characters to move */ 941 remaining_input_characters, /* all the rest, since no more tabs */ 942 remaining_output_columns); /* but not more than there's room for on output card */ 943 944 blank_count = max (0, /* compute blanks needed to fill rest of card */ 945 remaining_output_columns - remaining_input_characters); 946 947 end no_more_tabs; 948 949 if character_count > 0 then /* move characters to output card, if there are any */ 950 move_characters: do; 951 substr (output_card, next_output_column, character_count) = 952 substr (input_string, next_input_character, character_count); 953 954 remaining_input_characters = remaining_input_characters - character_count; 955 956 next_input_character = next_input_character + character_count; 957 958 remaining_output_columns = remaining_output_columns - character_count; 959 960 next_output_column = next_output_column + character_count; 961 962 end move_characters; 963 964 if blank_count > 0 then /* fill with blanks, if any */ 965 move_blanks: do; 966 967 substr (output_card, next_output_column, blank_count) = ""; 968 969 remaining_output_columns = remaining_output_columns - blank_count; 970 971 next_output_column = next_output_column + blank_count; 972 973 end move_blanks; 974 975 976 977 if more_tabs then do; /* move past tab in input string */ 978 remaining_input_characters = remaining_input_characters - 1; 979 next_input_character = next_input_character + 1; 980 end; 981 982 983 984 985 if more_backspaces then 986 backspace: do; /* if we found a backspace, we will: 987* 1) see if there's more than one of them, and 988* 2) move back that many columns, deleting whatever is there, 989* (probably only blanks ) */ 990 991 do i = next_input_character to initial_input_characters 992 while (substr (input_string, i, 1) = ascii_backspace); 993 end; 994 995 character_count = i - next_input_character; /* count backspace characters */ 996 997 backspace_count = min (character_count, /* count columns to backspace */ 998 next_output_column - 1); /* but don't backspace past beginning of card */ 999 1000 1001 /* skip over input backspace characters */ 1002 remaining_input_characters = remaining_input_characters - character_count; 1003 1004 next_input_character = next_input_character + character_count; 1005 1006 /* backspace on output card */ 1007 remaining_output_columns = remaining_output_columns + backspace_count; 1008 1009 next_output_column = next_output_column - backspace_count; 1010 1011 end backspace; 1012 1013 end canon_loop; 1014 1015 /* WE FALL THRU HERE WHEN remaining_output_columns BECOMES ZERO */ 1016 1017 1018 if remaining_input_characters > 0 then /* if input left over */ 1019 if ^input.truncate_ascii then /* and user did not say -truncate */ 1020 call fatal_error (6); /* complain */ 1021 1022 1023 if ^input.tabs_given then /* if user did not supply the nondollar tab stops */ 1024 if substr (output_card, 1, 1) = "$" then 1025 look_up_tabstops: do; /* we will determine them from the type of activity */ 1026 1027 card_type = substr (output_card, 8, 8); /* get card type */ 1028 1029 do i = 1 to gcos_control_tables_$tablelen /* look it up in cardtable */ 1030 while (card_type ^= gcos_control_tables_$cardtable (i)); 1031 end; /* fall thru if found, or end of table */ 1032 /* don't really care which */ 1033 if i >= gcos_control_tables_$exc_offset then /* if its not before the first activity card */ 1034 if i < gcos_control_tables_$nonact then /* and not after the last one */ 1035 act_card: do; /* then it must be one */ 1036 1037 act_ptr = addr (gcos_control_tables_$activity_table); /* pointer to data table */ 1038 act_ptr = addrel (act_ptr, (i - gcos_control_tables_$exc_offset)*3); 1039 /* pointer to data for this activity */ 1040 nondollar_tab_index = act_table_entry.tab_index; /* index to tabs for this activity */ 1041 end act_card; 1042 end look_up_tabstops; 1043 1044 1045 return; 1046 1047 end canonicalizer; 1048 1049 check_bin_cards: proc; 1050 1051 if bin_cards_skipped > 0 then do; 1052 call ioa_ ("^a: ^d non-bcd-card records skipped just before:^/^a", me, 1053 bin_cards_skipped, ascii_card); 1054 bin_cards_skipped = 0; 1055 end; 1056 1057 return; 1058 1059 end check_bin_cards; 1060 1061 check_for_eod: proc returns (bit (1)); /* check for end of library deck */ 1062 1063 dcl i fixed bin(24); 1064 1065 if eof then goto eod; 1066 1067 1068 if output.format = ascii | output.gcos_ascii then do; 1069 if substr (ascii_card, 1, 1) = "$" then do; /* a dollar card can indicate end of deck */ 1070 if substr (ascii_card, 1, 15) = "$ dkend " then goto eod; 1071 do i = 2 to 15; /* check for missing end card - 1072* this might be a GMAP, 355MAP, or OBJECT card */ 1073 if substr (ascii_card, 1, 15) = ascii_search_key (i) then goto noend; 1074 end; 1075 goto eod; /* NOTE - we are assuming that any other dollar card 1076* also ends the library deck, without starting a new one */ 1077 end; 1078 end; 1079 1080 else do; /* check it in BCD */ 1081 if gcos_record_ptr -> bcd_card.column (1) = bcd_dollar then do; 1082 if substr (string (gcos_record), 79, 36) = bcd_dkend then goto eod; 1083 do i = 2 to 15; 1084 if substr (string (gcos_record), 79, 36) = bcd_search_key (i) then goto noend; 1085 end; 1086 goto eod; /* see NOTE above */ 1087 end; 1088 end; 1089 1090 return ("0"b); 1091 1092 noend: no_end_card = "1"b; 1093 eod: return ("1"b); 1094 1095 end check_for_eod; 1096 1097 check_for_eoj: proc returns (bit (1)); 1098 1099 if eof then return ("1"b); 1100 1101 if output.format = ascii | output.gcos_ascii then do; /* check it in ascii */ 1102 if substr (ascii_card, 1, 15) = ascii_search_key (1) then do; /* $ snumb */ 1103 no_end_card = "1"b; 1104 return ("1"b); 1105 end; 1106 end; 1107 1108 else do; /* check it in BCD */ 1109 if gcos_record_ptr -> bcd_card.column (1) = bcd_dollar then do; 1110 if substr (string (gcos_record), 79, 36) = bcd_search_key (1) then do; /* SNUMB */ 1111 no_end_card = "1"b; 1112 return ("1"b); 1113 end; 1114 end; /* end dollar card */ 1115 end; /* end check it in BCD */ 1116 1117 return ("0"b); 1118 1119 end check_for_eoj; 1120 1121 cleanup_proc: proc; 1122 1123 dcl i fixed bin(24); 1124 1125 /* Detach file streams. Leave tapes for caller to detach or retain. */ 1126 1127 do i = 1 to 2; 1128 call ios_$detach ((file_stream (i)), "", "", status); 1129 end; 1130 1131 return; 1132 1133 end cleanup_proc; 1134 1135 close_comdk_output: proc; 1136 1137 k_card.char (comdk_out_index) = "111110"b; /* 76 octal - end of comdk */ 1138 call write_comdk_card; /* write out the last card */ 1139 output_comdk_open = "0"b; /* remember that comdk is no longer open */ 1140 1141 return; 1142 1143 end close_comdk_output; 1144 1145 close_input: proc; 1146 1147 io_ptr = input_ptr; /* in case of error, to indicate which file */ 1148 1149 if input.medium = tape then do; 1150 1151 if found_last_line then /* if we stopped because of -last or -count */ 1152 if ^file_eof then do; /* and the last block has not been read */ 1153 call ios_$order (output_stream_name, "forward_file", null, status); 1154 if code ^= 0 then 1155 call interpret_tape_status; 1156 if ^file_eof then 1157 call fatal_error (61); 1158 end; 1159 1160 if ^no_label (io.sw) then do; /* if labeled tape, read trailer label */ 1161 label_ptr = input_block_ptr; 1162 file_eof = "0"b; 1163 read_trailer: call read_block; /* read the trailer label */ 1164 if file_eof then do; 1165 if rcw_eof then do; /* if we had not yet read the eof tape mark */ 1166 rcw_eof = "0"b; /* we just did */ 1167 goto read_trailer; /* so go try to read trailer again */ 1168 end; 1169 call fatal_error (7); /* eof when trailer label expected */ 1170 end; /* end file_eof do group */ 1171 if input_block_len ^= 14 then 1172 call fatal_error (8); /* data record when trailer label expected */ 1173 if trailer_label.eof ^= bcd_beofbb then /* /bEOF/b/b */ 1174 if trailer_label.eof ^= bcd_beorbb then /* /bEOR/b/b */ 1175 call fatal_error (9); /* bad trailer label format */ 1176 1177 input_block_count = input_block_count - 2; /* deduct the eof and the trailer label */ 1178 if fixed (trailer_label.block_count) ^= input_block_count then 1179 if ^input.brief then 1180 call ioa_ ("^a: warning: block count in trailer label (^d) ^= blocks read (^d).", 1181 me, fixed (trailer_label.block_count), input_block_count); 1182 1183 call read_block; /* read the eof mark after the trailer label */ 1184 if ^file_eof then 1185 call fatal_error (10); /* expected eof after trailer not found */ 1186 end; /* end of labeled tape do group */ 1187 1188 else do; /* unlabeled tape */ 1189 if rcw_eof then do; /* if we have not yet read the eof tape mark */ 1190 file_eof, rcw_eof = "0"b; /* turn off switches */ 1191 call read_block; /* and read it now */ 1192 if ^file_eof then /* if eof tape mark not there */ 1193 call fatal_error (60); /* expected eof after unlabeled tape file missing */ 1194 end; 1195 end; 1196 1197 end; 1198 1199 else do; 1200 1201 call ios_$detach (input_stream_name, "", "", status); 1202 1203 if code ^= 0 then call fatal_error (11); 1204 1205 end; 1206 1207 tape_status_message = ""; 1208 return; 1209 1210 end close_input; 1211 1212 close_output: proc; 1213 1214 io_ptr = output_ptr; /* in case of error, to indicate which file */ 1215 1216 if output_comdk_open then /* if we were writing a comdk */ 1217 call close_comdk_output; /* put out the last card */ 1218 1219 if output.medium ^= raw /* if an ordinary GCOS file */ 1220 then if output.format ^= ascii 1221 then if output.format ^= blocks 1222 then if output.medium ^= tape /* and not a tape file, */ 1223 1224 then call write_gcos_record (addr (eof_rcw), 1); /* then write eof record */ 1225 1226 if output.medium = tape then do; 1227 1228 call write_tape_eof; /* write eof and check error code */ 1229 1230 if ^no_label (io.sw) then do; /* if labeled tape, build and write trailer label */ 1231 label_ptr = write_buffer_ptr; /* build it in the write buffer */ 1232 unspec (trailer_label) = ""b; /* clear it first */ 1233 trailer_label.eof = bcd_beofbb; /* /bEOF/b/b */ 1234 trailer_label.block_count = bit (fixed (output_block_count, 36)); 1235 trailer_label.next_reel = bcd_b6; /* six bcd blanks */ 1236 1237 call write_tape_label; /* write label and eof, checking error codes */ 1238 1239 /* build partial label */ 1240 word_string_len = 14; /* length of label */ 1241 /* use word_string overlay because structure assignment 1242* compiles into element-by-element assignment */ 1243 addr (header_label) -> word_string = addr (saved_header_label) -> word_string; 1244 /* partial label is header label, */ 1245 unspec (partial_label.zero_words) = ""b; /* with words 5-10 zeroed */ 1246 1247 call write_tape_label; /* write it and an eof, checking error codes */ 1248 1249 /* now, in case there is more to write on the tape, backspace to beginning of partial label, 1250* so it will be overwritten if there is more */ 1251 1252 do i = 1 to 2; 1253 file_eof = "0"b; 1254 call ios_$order (output_stream_name, "backspace_file", null, status); 1255 if code ^= 0 then 1256 call interpret_tape_status; 1257 if ^file_eof then /* should get eof status from backspace file */ 1258 call fatal_error (12); /* error while backspacing over partial label */ 1259 end; 1260 1261 /* read the eof before the partial label */ 1262 call ios_$read (output_stream_name, input_block_ptr, 0, elements_wanted, input_block_len, status); 1263 file_eof = "0"b; 1264 if code ^= 0 then 1265 call interpret_tape_status; 1266 if ^file_eof then 1267 call fatal_error (13); /* while positioning to partial label */ 1268 end; /* end of labeled tape do group */ 1269 1270 end; 1271 1272 else do; 1273 1274 call ios_$detach (output_stream_name, "", "", status); 1275 1276 if code ^= 0 then call fatal_error (14); 1277 1278 end; 1279 1280 tape_status_message = ""; 1281 return; 1282 1283 end close_output; 1284 1285 copy_jobs: proc; 1286 1287 do list_index = 1 to input.list_count while (^eof); 1288 call find_list_item; 1289 1290 if ^eof 1291 then do; 1292 1293 if output.set = multiple_files 1294 then call open_next_output; 1295 call copy_one_job; 1296 if output.set = multiple_files 1297 then call close_output; 1298 1299 end; 1300 end; 1301 end copy_jobs; 1302 1303 copy_one_deck: proc; /* procedure to copy one library deck */ 1304 dcl first_card bit (1) aligned; 1305 1306 eof, eoj = "0"b; 1307 first_card = "1"b; 1308 1309 do while (^eoj); 1310 if ^first_card then 1311 eoj = check_for_eod (); /* see if this card is an end of deck indicator */ 1312 else first_card = "0"b; 1313 if ^eof then /* if there is a card there */ 1314 if ^no_end_card then /* and its not the first card of the next deck, write it */ 1315 call write_output; /* first card was read by find_list_item */ 1316 if ^eoj then call read_and_convert_input; 1317 end; 1318 1319 end copy_one_deck; 1320 1321 copy_one_file: proc; 1322 1323 eof = "0"b; 1324 1325 do while (^eof); 1326 1327 call read_and_convert_input; 1328 if ^eof then call write_output; 1329 end; 1330 1331 return; 1332 end copy_one_file; 1333 1334 copy_one_job: proc; 1335 dcl first_card bit (1) aligned; 1336 1337 eof, eoj = "0"b; 1338 first_card = "1"b; 1339 1340 do while (^eoj); 1341 1342 if ^first_card then 1343 eoj = check_for_eoj (); 1344 else first_card = "0"b; 1345 if ^eof then /* if there is a card there */ 1346 if ^no_end_card then /* and its not the first card of the next job, write it */ 1347 call write_output; /* first card ( $ snumb) was read by find_list_item */ 1348 if ^eoj then call read_and_convert_input; 1349 end; 1350 1351 end copy_one_job; 1352 1353 cv_bin_to_bcd: proc (input_ptr, output_ptr); 1354 dcl ( 1355 direction, /* direction of half-interval search */ 1356 i, /* loop index */ 1357 interval, /* increment for half-interval search */ 1358 j, /* loop index */ 1359 k, 1360 search_index /* index into binary table */ 1361 ) fixed bin(24)aligned; 1362 1363 dcl ( 1364 input_ptr, /* pointer to binary data (argument) */ 1365 output_ptr /* pointer to bcd output (argument) */ 1366 ) ptr aligned; 1367 1368 dcl ( 1369 bad_card, /* turned on if a bad char is found */ 1370 bin_char_not_found /* ON until bin_table search is successful */ 1371 ) bit (1) aligned; 1372 1373 1374 dcl ( 1375 divide 1376 ) builtin; 1377 1378 1379 dcl 1 bcd_chars aligned based (output_ptr), /* bcd output structure */ 1380 2 bcd_char (0:79) bit (6) unaligned; 1381 1382 dcl bin_char (0:79) bit (12) unaligned based (input_ptr) /* mask for looking at binary input */; 1383 dcl this_char bit (12) aligned /* copy char to aligned string to avoid hardware bug in cmpb */; 1384 1385 1386 /* perform conversion */ 1387 1388 bad_card = "0"b; 1389 1390 cv_card: do i = 0 to 79; /* convert 80 characters */ 1391 1392 this_char = bin_char (i); /* copy to aligned string to avoid hardware bug */ 1393 if this_char = "0"b /* make quick check for blank */ 1394 then bcd_char (i) = bcd_blank; 1395 1396 else /* not binary blank */ 1397 translate_char: do; 1398 1399 direction = 1; /* set up half-interval search */ 1400 interval = 32; 1401 search_index = 0; 1402 bin_char_not_found = "1"b; 1403 1404 search_table: do j = 1 to 6 while (bin_char_not_found); 1405 1406 search_index = search_index + direction*interval; /* compute index into binary table */ 1407 1408 if this_char = bin_table (search_index) /* match found */ 1409 then do; 1410 bcd_char (i) = bcd_table (search_index); /* set bcd character */ 1411 bin_char_not_found = "0"b; 1412 end; 1413 1414 else /* not a match */ 1415 do; 1416 if this_char > bin_table (search_index) /* set direction of search increment */ 1417 then direction = 1; 1418 else direction = -1; 1419 interval = divide (interval, 2, 17, 0); /* set search increment magnitude */ 1420 end; 1421 1422 end search_table; 1423 1424 if bin_char_not_found then /* no match found */ 1425 illegal_char: do; /* not a GEBCD card code */ 1426 1427 bcd_char (i) = bcd_blank; /* leave column blank */ 1428 if ^bad_card then do; /* if first bad char on card */ 1429 bad_card = "1"b; /* remembr it */ 1430 raw_cards_bad = raw_cards_bad + 1; /* count cards */ 1431 end; 1432 1433 raw_chars_bad = raw_chars_bad + 1; /* count bad characters */ 1434 1435 if ^input.brief then do; /* tell user what's wrong, unless told not to */ 1436 1437 punches = ""; /* clear the string first */ 1438 1439 do k = 1 to 12; /* then tell user which rows were punched */ 1440 if substr (this_char, k, 1) then /* if this row punched */ 1441 punches = punches || punch (k); /* add row number to string to be printed */ 1442 end; 1443 substr (punches, 1, 1) = " "; /* get rid of leading "-" */ 1444 call ioa_ ("^a: raw card ^d, column ^d - not GEBCD punch:^a^/Processing continues.", 1445 me, input_block_count, i+1, punches); 1446 end; 1447 end illegal_char; 1448 1449 1450 end translate_char; 1451 1452 end cv_card; 1453 1454 return; 1455 end cv_bin_to_bcd; 1456 1457 fatal_error: proc (error_code); 1458 1459 dcl error_code fixed bin(24); /* identifies the place where the error occurred. Each call 1460* has a different number, even if the message is the same. 1461* The first 58 are in order in the program. Those above 58 1462* were added later and are out of order. */ 1463 dcl fixed_in_db bit (1) aligned init ("0"b); 1464 dcl max_error_code fixed bin(24)init (61) /* next available code is 62 */; 1465 dcl (err_msg, msg2) char (200) varying init (""); 1466 1467 if ^input.com_err then goto set_code; /* print only if caller said to */ 1468 1469 if error_code < 1 | error_code > max_error_code then do; 1470 err_msg = "Program error - bad internal error code: ^s^d"; 1471 err_num = error_code; 1472 goto call_com_err; 1473 end; 1474 1475 goto err (error_code); 1476 1477 err (1): err (44): err (55): 1478 err_msg = "Invalid input arguments."; 1479 goto call_com_err; 1480 1481 err (2): 1482 err_msg = "ASCII character without BCD equivalent in the above value from the command line."; 1483 goto call_com_err; 1484 1485 err (3): 1486 err_msg = "Program error - converting numeric to BCD for tape label."; 1487 goto call_com_err; 1488 1489 err (4): 1490 err_msg = "No activity card before data cards in ^a. 1491 Must give either -tabs or -no_canonicalize."; 1492 goto call_com_err; 1493 1494 err (5): 1495 err_msg = "Backspace not immediately preceeded by tab, in ^a, line ^d"; 1496 goto set_line_no; 1497 1498 err (6): err (41): 1499 err_msg = "Line > 80 characters and -truncate not given: 1500 ^a, line ^d."; 1501 goto set_line_no; 1502 1503 err (7): 1504 err_msg = "File mark where trailer label expected, on ^a ^s^a"; 1505 goto call_com_err; 1506 1507 err (8): 1508 err_msg = "Data record where trailer label expected, on ^a ^s^a"; 1509 goto call_com_err; 1510 1511 err (9): 1512 err_msg = "Bad trailer label on ^a ^s^a"; 1513 goto call_com_err; 1514 1515 err (10): 1516 err_msg = "Expected filemark after trailer not found on ^a ^s^a"; 1517 goto call_com_err; 1518 1519 err (11): err (14): 1520 err_msg = "From ios_$detach ^a"; /* detaching input or output file - not tape */ 1521 goto call_com_err; 1522 err (12): 1523 err_msg = "While backspacing over partial label on ^a ^s^a ^a"; 1524 goto call_com_err; 1525 1526 err (13): 1527 err_msg = "While positioning to partial label on ^a ^s^a ^a"; 1528 goto call_com_err; 1529 1530 err (15): 1531 err_msg = "End of file in middle of comdk: ^a, BCD card ^d"; 1532 goto set_line_no; 1533 1534 err (16): 1535 err_msg = "Non-comdk card in middle of comdk: ^a, BCD card ^d"; 1536 goto set_line_no; 1537 1538 err (17): err (22): 1539 err_msg = "Comdk sequence number error: ^a, BCD card ^d"; 1540 goto set_line_no; 1541 1542 err (18): 1543 err_msg = "Null comdk card: ^a, BCD card ^d"; 1544 goto set_line_no; 1545 1546 err (19): err (23): 1547 err_msg = "Bad comdk field length: ^a, BCD card ^d"; 1548 goto set_line_no; 1549 1550 err (20): 1551 err_msg = "Bad comdk string length: ^a, BCD card ^d"; 1552 goto set_line_no; 1553 1554 err (21): 1555 err_msg = "Comdk field > remainder of BCD card: ^a, BCD card ^d"; 1556 goto set_line_no; 1557 1558 err (24): err (27): 1559 err_msg = "From ios_$attach ^a"; 1560 goto call_com_err; 1561 1562 err (25): err (28): 1563 err_msg = "From ios_$setsize ^a"; 1564 goto call_com_err; 1565 1566 err (26): 1567 err_msg = "From ios_$setdelim ^a"; 1568 goto call_com_err; 1569 1570 err (29): 1571 err_msg = "From ios_$tell last ^a"; 1572 goto call_com_err; 1573 1574 err (30): 1575 err_msg = "From ios_$seek last first ^a"; 1576 goto call_com_err; 1577 1578 err (31): 1579 err_msg = "Program error - unable to append to existing gcos file ^a"; 1580 goto call_com_err; 1581 1582 err (32): 1583 err_msg = "While rewinding ^a ^s^a ^a"; 1584 goto call_com_err; 1585 1586 err (33): 1587 err_msg = "Unexpected filemark read while positioning ^a (file number ^d) ^a"; 1588 goto call_com_err; 1589 1590 err (34): 1591 err_msg = "While positioning ^a (file number ^d) ^a ^a"; 1592 goto call_com_err; 1593 1594 err (35): 1595 err_msg = "Partial label (end of information) read while positioning ^a ^s^a"; 1596 goto call_com_err; 1597 1598 err (36): 1599 err_msg = "Expected header label not found, while positioning ^a ^s^a"; 1600 goto call_com_err; 1601 1602 err (37): 1603 err_msg = "End of reel label (file continued on another reel) read while positioning ^a ^s^a"; 1604 goto call_com_err; 1605 1606 err (38): 1607 err_msg = "Expected trailer label not found, while positioning ^a ^s^a"; 1608 goto call_com_err; 1609 1610 err (39): 1611 err_msg = "Program error while positioning ^a ^s^a"; 1612 goto call_com_err; 1613 1614 err (40): 1615 err_msg = "No newline for over 1280 characters - not an ASCII file: ^a, line ^d"; 1616 goto set_line_no; 1617 1618 err (42): 1619 err_msg = "ASCII character without BCD equivalent: ^/^a, line ^d"; 1620 goto set_line_no; 1621 1622 err (43): 1623 err_msg = "BCD card record > 18 words: ^a, card ^d"; 1624 goto set_line_no; 1625 1626 err (45): err (46): 1627 err_msg = "From ios_$read:"; 1628 goto set_block_no; 1629 1630 err (47): 1631 err_msg = "Read error - wrong number of elements read:"; 1632 goto set_block_no; 1633 1634 err (48): 1635 err_msg = "Read error - zero length block:"; 1636 goto set_block_no; 1637 1638 err (49): 1639 err_msg = "Bad length in block control word:"; 1640 goto set_block_no; 1641 1642 err (50): 1643 err_msg = "Error while deblocking - bad block or record control word:"; 1644 goto set_block_no; 1645 1646 err (51): err (52): 1647 err_msg = "From ios_$write"; 1648 goto set_out_block_no; 1649 1650 err (53): 1651 err_msg = "Write error - wrong number of elements written:"; 1652 goto set_out_block_no; 1653 1654 err (54): 1655 err_msg = "Program error - attempt to write GCOS record > 319 words into"; 1656 goto set_out_block_no; 1657 1658 err (56): 1659 err_msg = "Program error - bad record length or media code for raw output file: ^a, card ^d"; 1660 err_num = output_block_count; 1661 goto call_com_err; 1662 1663 err (57): 1664 err_msg = "While writing filemark on ^a ^s^a ^a"; 1665 goto call_com_err; 1666 1667 err (58): 1668 err_msg = "While writing label on ^a ^s^a ^a"; 1669 goto call_com_err; 1670 1671 err (59): 1672 err_msg = "Program error - while encoding output comdk."; 1673 goto call_com_err; 1674 1675 err (60): 1676 err_msg = "Expected filemark after last block of unlabeled tape file not found on ^a^s^a"; 1677 goto call_com_err; 1678 1679 err (61): 1680 err_msg = "While skipping to trailer label."; 1681 goto set_block_no; 1682 1683 set_block_no: 1684 err_num = input_block_count; 1685 goto set_block_msg; 1686 1687 set_out_block_no: 1688 err_num = output_block_count; 1689 goto set_block_msg; 1690 1691 set_block_msg: 1692 err_msg = err_msg || " ^a, block ^d ^s^a"; 1693 goto call_com_err; 1694 1695 set_line_no: 1696 err_num = file_record_count; 1697 1698 if input.set = library then 1699 msg2 = " edit name = "; 1700 else if input.set = imcv then 1701 msg2 = " snumb = "; 1702 else goto call_com_err; 1703 1704 msg2 = msg2 || item_name; 1705 err_msg = err_msg || " ^a"; /* add control to print msg2 */ 1706 1707 call_com_err: 1708 call com_err_ (code, me, err_msg, io.file_name, err_num, msg2, tape_status_message); 1709 1710 if input.debug then do; 1711 call ioa_ ("error number gcu_^d", error_code); 1712 call ioa_ ("CALLING DB"); 1713 call db; 1714 1715 if fixed_in_db then return; 1716 end; 1717 set_code: if code = 0 then code = error_table_$action_not_performed; 1718 goto cleanup_and_return; 1719 1720 end fatal_error; 1721 1722 find_list_item: proc; /* procedure to find the next $ GMAP, $ 355MAP, $ OBJECT 1723* $ FORTRAN, $COBOL, or $ SNUMB card 1724* that has one of the selected item names on it */ 1725 1726 dcl i fixed bin(24); 1727 dcl saved_comdk_sw bit (1) aligned; 1728 1729 saved_comdk_sw = input.comdk; /* save value of comdk switch */ 1730 input.comdk = "0"b; /* and turn it off, to save the cost of 1731* uncoming decks that are not being copied */ 1732 just_looking = "1"b; /* suppress the "bin cards skipped" messages */ 1733 if no_end_card then do; /* if no end card in previous item */ 1734 no_end_card = "0"b; /* we already have one of the key cards in the buffer */ 1735 if output.format = ascii | output.gcos_ascii then goto have_aci; /* so go look at it */ 1736 else goto have_bcd; /* in ascii or bcd, as the case may be */ 1737 end; 1738 1739 find_item_read: call read_and_convert_input; /* read next record */ 1740 if eof then do; 1741 input.comdk = saved_comdk_sw; /* possible multiple file input */ 1742 just_looking = "0"b; /* so clean up */ 1743 1744 if looking_for_first_line then /* if we never found the -first card */ 1745 if saved_comdk_sw then /* and we were not uncompressing */ 1746 call ioa_ ("^a: Warning: comdks were NOT being uncompressed during the 1747 search for card ^d, resulting in a lower card count than you expected", me, input.first_line); 1748 return; 1749 end; 1750 1751 if output.format = ascii | output.gcos_ascii then do; /* ASCII card */ 1752 if substr (ascii_card, 1, 1) ^= "$" then /* if not a dollar card */ 1753 goto find_item_read; /* go read the next one */ 1754 do i = first_key to last_key; /* these indices select either: 1755* 1) $ SNUMB card, or 1756* 2) $ GMAP, $ 355MAP, or $ OBJECT card */ 1757 if substr (ascii_card, 1, 15) = ascii_search_key (i) then /* if this is one of those cards */ 1758 goto have_aci; /* go get the name off it */ 1759 end; /* if we fall thru here, it is not one of they key cards */ 1760 goto find_item_read; /* so go read the next card */ 1761 have_aci: item_name = substr (ascii_card, item_index, item_length); /* pick up edit name or snumb */ 1762 end; 1763 1764 else if gcos_record_ptr -> rcw.media_code = bcd_media_code then do; /* BCD card */ 1765 if gcos_record_ptr -> bcd_card.column (1) ^= bcd_dollar then /* if not dollar card */ 1766 goto find_item_read; /* go read next one */ 1767 do i = first_key to last_key; /* indices pick out either: 1768* 1) $ SNUMB card, or 1769* 2) $ GMAP, $ 355MAP, or $ OBJECT */ 1770 if substr (string (gcos_record), 79, 36) = bcd_search_key (i) then /* if this is one of them */ 1771 goto have_bcd; /* go get the name off it */ 1772 end; /* if we fall thru, it is not one of the key cards */ 1773 goto find_item_read; /* so go read the next one */ 1774 have_bcd: item_name = ""; /* blank out ascii item name */ 1775 do i = 0 to item_length-1; /* and convert BCD item name to ASCII */ 1776 substr (item_name, i+1, 1) = xlate (fixed (gcos_record_ptr -> bcd_card.column (item_index+i))); 1777 end; 1778 end; 1779 1780 else goto find_item_read; /* binary card. read next one */ 1781 1782 /* if we fall thru here, we have a key card, and we have gotten the item name from it */ 1783 1784 if item_length = 5 then do; /* if snumb card, check for short snumb */ 1785 i = index (item_name, ","); /* look for comma */ 1786 if i ^= 0 then /* if there was one */ 1787 substr (item_name, i) = ""; /* blank out it, and whatever follows */ 1788 end; 1789 1790 if input.all then goto print_being_copied; /* if user said -all, we copy all input items */ 1791 do i = 1 to input.list_count /* if not, look up this name in the input list */ 1792 /* comparing only the first N characters of the item name */ 1793 /* with the input list items */ 1794 while (input_list (i).names ^= substr (item_name, 1, input.list_name_size)); 1795 end; /* where N is the length of the input list items */ 1796 /* This is temporary until the command procedure and the input_list 1797* structure in the include file can be changed to allow variable length 1798* item names, longer than 4 characters (up to 8) */ 1799 if i = input.list_count + 1 then do; /* if not found */ 1800 if input.long then call ioa_ (item_name); 1801 goto find_item_read; /* keep reading */ 1802 end; 1803 1804 input_list (i).used = "1"b; /* keep track of which ones we found, 1805* for later error message printing */ 1806 /* It might be good to add code to check for 1807* a name appearing more than once in the input file, 1808* and warn the user, and ask if it should be copied again */ 1809 1810 print_being_copied: if input.long | output.long then call ioa_ ("^a being copied", item_name); 1811 1812 input.comdk = saved_comdk_sw; 1813 just_looking = "0"b; 1814 1815 return; /* we found one */ 1816 1817 end find_list_item; 1818 1819 get_comdk: proc (record_ptr, record_len); 1820 1821 dcl fb_temp fixed bin(24); 1822 dcl record_len fixed bin(24); 1823 dcl record_ptr ptr; 1824 1825 record_len = 14; /* we will always return a bcd card */ 1826 record_ptr = bcd_work_area_ptr; /* in the work area reserved for us */ 1827 word_string_len = 14; /* move 14 words */ 1828 addrel (record_ptr, 1) -> word_string = /* into the work area */ 1829 addr (bcd_blank_card) -> word_string; /* initializing it to 80 bcd blanks */ 1830 bcd_col_index = 1; /* start filling in card at col 1 */ 1831 1832 uncom_loop: if field_len = 0 then do; /* end of comdk card - read next one */ 1833 call read_record (comdk_card_ptr, fb_temp); 1834 if eof then call fatal_error (15); /* eof in middle of comdk */ 1835 if (fb_temp ^= 27 & fb_temp ^= 24) /* if not proper length */ 1836 | comdk_card.col1 ^= comdk_col_1 /* or not comdk code in col 1 */ 1837 then call fatal_error (16); /* non-comdk card in comdk */ 1838 fb_temp = fixed (comdk_card.seq_no); 1839 if fb_temp ^= prev_comdk_seq_no + 1 then 1840 call fatal_error (17); /* bad comdk sequence number */ 1841 prev_comdk_seq_no = fb_temp; 1842 field_len = fixed (comdk_card.char (1)); 1843 if field_len = 0 then 1844 call fatal_error (18); /* null comdk card */ 1845 comdk_char_index = 2; 1846 end; 1847 1848 1849 if field_len = 63 then do; /* end of bcd card */ 1850 field_len = fixed (comdk_card.char (comdk_char_index)); /* get next field length */ 1851 comdk_char_index = comdk_char_index + 1; 1852 if field_len = 62 then do; /* end of this comdk */ 1853 if comdk_error_count >0 then 1854 call ioa_ ("^d field length errors", comdk_error_count); 1855 if input.set = library then 1856 call ioa_ ("(in ^a)", item_name); 1857 input_comdk_open = "0"b; /* so don't come here next time */ 1858 end; 1859 return; 1860 end; 1861 1862 1863 if field_len > 55 then 1864 call fatal_error (19); /* bad comdk field length */ 1865 1866 string_len = fixed (comdk_card.char (comdk_char_index)); /* this string length */ 1867 comdk_char_index = comdk_char_index + 1; 1868 if comdk_char_index + string_len > 132 then /* first char after string */ 1869 call fatal_error (20); /* comdk string runs off comdk card */ 1870 if bcd_col_index + field_len > 85 then do; 1871 if input.debug then do; 1872 comdk_error_count = comdk_error_count + 1; 1873 if ^input.brief then do; 1874 call ioa_ ("Illegal comdk: field runs off end of BCD card"); 1875 call ioa_ ("comdk card number ^d, character ^d is field length of ^d", 1876 prev_comdk_seq_no, comdk_char_index-2, field_len); 1877 call ioa_ ("BCD card number ^d, column ^d is next col to fill", 1878 file_record_count, bcd_col_index); 1879 call ioa_ ("Skipping field and blanking rest of BCD card"); 1880 end; 1881 goto next_string; 1882 end; 1883 else call fatal_error (21); /* comdk field runs off bcd card */ 1884 end; 1885 1886 bcd_col_index = bcd_col_index + field_len - string_len; /* move past blanks */ 1887 bit_string_len = string_len*6; /* string length in bits, for move */ 1888 /* move the string into the bcd card */ 1889 addr (bcd_card.column (bcd_col_index)) -> bit_string = 1890 addr (comdk_card.char (comdk_char_index)) -> bit_string; 1891 1892 bcd_col_index = bcd_col_index + string_len; /* next vacant column */ 1893 next_string: comdk_char_index = comdk_char_index + string_len; /* index of next field length */ 1894 field_len = fixed (comdk_card.char (comdk_char_index)); /* next field length */ 1895 comdk_char_index = comdk_char_index + 1; /* next item on comdk card */ 1896 goto uncom_loop; 1897 1898 1899 end get_comdk; 1900 1901 interpret_tape_status: proc; 1902 1903 if substr (status, 1, 3) = "100"b then do; /* if this is hardware status, decode it */ 1904 if substr (status, 27, 4) = "0100"b /* major status End of File */ 1905 & (substr (status, 31, 6) = "001111"b /* EOF 7track */ 1906 | substr (status, 31, 6) = "010011"b) /* EOF 9track */ 1907 then file_eof = "1"b; 1908 1909 else call decode_nstd_status_ (status, tape_status_message); 1910 1911 end; /* if not hardware status, just return */ 1912 1913 return; 1914 1915 end interpret_tape_status; 1916 1917 julian_day: proc (month, dom, year) returns (fixed bin); 1918 1919 dcl mlen (12) fixed bin(24)int static init (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); 1920 dcl (i, month, dom, year, jday) fixed bin(24); 1921 1922 jday = 0; 1923 do i = 1 to month-1; /* add up days in preceeding months */ 1924 jday = jday+mlen (i); 1925 end; 1926 jday = jday + dom; /* add date in this month */ 1927 if month > 2 then /* if March or later */ 1928 if mod (year, 4) = 0 then /* and this is leap year */ 1929 jday = jday + 1; /* add in Feb 29 */ 1930 return (jday); 1931 end julian_day; 1932 1933 make_gcos_record: proc; /* come here to build gcos records */ 1934 1935 gcos_record_ptr = gcos_work_area_ptr; /* build record in gcos_work_area */ 1936 1937 if output.gcos_ascii then do; 1938 1939 char_string_len = ascii_line_len; /* length of ascii char string to move */ 1940 addrel (gcos_record_ptr, 1) -> char_string = ascii_card; /* move it into gcos record */ 1941 1942 i = mod (char_string_len, 4); /* number of chars in partially filled word */ 1943 if i ^= 0 then do; /* if there is a partially filled word */ 1944 i = 4-i; /* compute number of pad characters needed to fill it out */ 1945 char_string_len = char_string_len + i; /* lengthen string by that much */ 1946 substr (addrel (gcos_record_ptr, 1) -> char_string, ascii_line_len+1, i) = 1947 substr (ascii_pads, 1, i); 1948 end; /* and move in the pad characters */ 1949 1950 gcos_record.rcw = ""b; /* clear the rcw, and fill in some fields */ 1951 gcos_record_len = divide (char_string_len, 4, 17, 0); /* word length of record */ 1952 gcos_record_ptr -> rcw.length = bit (fixed (gcos_record_len, 18)); /* into rcw */ 1953 gcos_record_ptr -> rcw.media_code = ascii_media_code; /* media code = 6 */ 1954 1955 if i ^= 0 then do; /* if last word is partially filled */ 1956 i = 4-i; /* get back the number of chars in it */ 1957 substr (gcos_record.rcw, 19, 2) = bit (bin (i, 2)); /* and put it in the rcw, in a new field 1958* that used to be part of the eof indicator */ 1959 end; 1960 1961 end; 1962 1963 else do; /* regular BCD record wanted */ 1964 1965 gcos_record_len = 14; /* fixed bin(24)copy of rcw.length */ 1966 gcos_record.data_words = bcd_b6; /* fill with BCD spaces */ 1967 call gcos_cv_ascii_gebcd_check_ 1968 (ascii_line_ptr, ascii_line_len, addrel (gcos_record_ptr, 1), code); 1969 if code ^= 0 then do; 1970 call ioa_ ("Error on character ^d of:^/^a", code, ascii_card); 1971 code = 0; /* code is position of bad char - not error table code */ 1972 call fatal_error (42); 1973 end; 1974 1975 gcos_record.rcw = bcd_rcw; 1976 1977 end; 1978 1979 return; 1980 end make_gcos_record; 1981 1982 open_comdk_input: proc (record_ptr, record_len); 1983 1984 dcl record_len fixed bin(24); 1985 dcl record_ptr ptr; 1986 1987 comdk_error_count = 0; 1988 input_comdk_open = "1"b; /* remember that comdk is open */ 1989 comdk_card_ptr = record_ptr; /* point to first comdk card */ 1990 prev_comdk_seq_no = fixed (comdk_card.seq_no); 1991 if prev_comdk_seq_no ^= 1 then 1992 call fatal_error (22); /* bad initial comdk seq no */ 1993 field_len = fixed (comdk_card.char (1)); /* first field len */ 1994 if field_len < 1 | field_len > 55 then 1995 call fatal_error (23); /* bad initial comdk field len */ 1996 comdk_char_index = 2; /* since we got char 1 above */ 1997 bcd_work_area_ptr -> gcos_record.rcw = bcd_rcw; /* initialize the rcw */ 1998 1999 2000 return; 2001 2002 2003 end open_comdk_input; 2004 2005 open_comdk_output: proc; 2006 2007 dcl (i, j) fixed bin(24); 2008 2009 string (k_card) = ""b; /* clear the 28 word buffer used to build comdk cards */ 2010 2011 k_card.rcw = bin_rcw; /* rec len = 27, media code = 1 */ 2012 k_card.col1 = comdk_col_1; /* 5005 octal (12-0-7-9 punch) */ 2013 comdk_out_index = 1; /* start with first char on output card */ 2014 2015 k_card.seq_no = bit (bin (1, 24)); /* fixed bin(24)24 constant 1 */ 2016 2017 /* Initialize sequence columns (73-80) to "EEEE0000" where EEEE is the first 4 characters of the edit name */ 2018 2019 if input.set = library then 2020 edit_name = substr (item_name, 1, 4); 2021 else if input.medium = tape then 2022 edit_name = "...."; 2023 else do; /* get an edit name from the file name */ 2024 i, j = 1; /* don't want it to be ">udd", so find entry name */ 2025 find_edit_name: 2026 j = index (substr (input.file_name, i), ">"); /* look for another ">" */ 2027 if j ^= 0 then do; /* found one */ 2028 i = i + j; /* move past it */ 2029 goto find_edit_name; 2030 end; 2031 edit_name = substr (input.file_name, i, 4); 2032 end; 2033 2034 unspec (bcd_edit_name) = bcd_string (edit_name, 4); /* convert edit name to bcd */ 2035 do i = 1 to 4; /* use numeric value of bcd character as index into table */ 2036 k_card.seq_col (i) = raw_table (fixed (bcd_edit_name (i))); /* of card punch patterns for those chars */ 2037 end; 2038 2039 do i = 5 to 8; /* initialize col 77-80 to zeros */ 2040 k_card.seq_col (i) = raw_table (0); 2041 seq_col (i) = 0; /* fixed bin(24)copy of 77-80, for incrementing */ 2042 end; 2043 2044 output_comdk_open = "1"b; 2045 2046 return; 2047 2048 2049 end open_comdk_output; 2050 2051 open_input: proc; 2052 2053 io_ptr = input_ptr; /* for position tape, and to tell which file, if error */ 2054 2055 if input.medium = tape then do; /* the tape will already be attached */ 2056 2057 input_stream_name = tape_stream (input.sw); 2058 2059 element_size = 36; 2060 elements_wanted = 320; 2061 call position_tape; /* reads and verifies labels */ 2062 2063 end; /* end open tape */ 2064 2065 else do; 2066 2067 input_stream_name = file_stream (input.sw); 2068 2069 call ios_$attach (input_stream_name, "file_", input.file_name, "r", status); 2070 if code ^= 0 then call fatal_error (24); 2071 2072 if input.medium = raw then do; 2073 element_size = 960; /* 12 rows X 80 columns */ 2074 elements_wanted = 1; 2075 2076 input_block_ptr = addrel (gcos_work_area_ptr, 1); /* read directly into the record, after the rcw */ 2077 2078 /* by reading the record directly into gcos_work_area, we save copying it later */ 2079 /* input_block_ptr tells ios_$read where to put the input */ 2080 2081 end; 2082 2083 else if input.format = ascii then do; 2084 element_size = 9; /* the default - set in case changed previously */ 2085 elements_wanted = 1280; /* the buffer size */ 2086 end; 2087 2088 else do; /* all other possibilities */ 2089 element_size = 36; /* one word */ 2090 elements_wanted = 320; /* one block */ 2091 end; 2092 2093 call ios_$setsize (input_stream_name, element_size, status); 2094 if code ^= 0 then call fatal_error (25); 2095 2096 end; /* end open non tape */ 2097 2098 if input.format = ascii then do; 2099 2100 if ^input.no_canon then /* if we are going to call canonicalizer */ 2101 tabstop_ptr = addr (gcos_control_tables_$tabstops); /* get pointer to tab table */ 2102 /* by waiting to do it now, 2103* we avoid initiating segment gcos_control_tables_ in 2104* cases where we are not going to use anything in it */ 2105 2106 call ios_$setdelim (input_stream_name, 1, unspec (ascii_newline), 1, unspec (ascii_newline), status); 2107 if code ^= 0 then call fatal_error (26); 2108 /* we had to set the delimiter back to newline, since the 2109* ios_$setsize call removes the default delimiter */ 2110 2111 end; 2112 2113 file_eob = "1"b; /* always read a block on first read call */ 2114 file_eof = "0"b; /* not eof 'til we read an eof */ 2115 rcw_eof = "0"b; 2116 found_last_line = "0"b; 2117 2118 looking_for_first_line, looking_for_last_line = "0"b; 2119 if input.first_line > 0 then 2120 looking_for_first_line = "1"b; 2121 2122 else /* don't start looking for last line til first line found */ 2123 if input.last_line > 0 then 2124 looking_for_last_line = "1"b; 2125 2126 tape_status_message = ""; 2127 2128 if input.long then 2129 call ioa_ ("^a being read", input.file_name); 2130 2131 return; 2132 2133 end open_input; 2134 2135 open_next_input: proc; 2136 2137 next_input_index = next_input_index + 1; 2138 input.file_name = input_list (next_input_index).names; 2139 call open_input; 2140 input_list (next_input_index).used = "1"b; 2141 file_record_count = 0; /* causes -first, -last, -count to be 2142* applied separately to each input file */ 2143 2144 return; 2145 2146 end open_next_input; 2147 2148 open_next_output: proc; 2149 2150 next_output_index = next_output_index + 1; 2151 2152 if next_output_index > output.list_count then do; 2153 if ^input.brief then do; 2154 io_ptr = input_ptr; 2155 call report_missing_items; 2156 end; 2157 goto cleanup_and_return; 2158 end; 2159 2160 if output.name_files then do; 2161 if index (substr (item_name, 1, item_length), " ") > 1 then 2162 output.file_name = before (item_name, " ")||next_output_suffix; 2163 else output.file_name = substr (item_name, 1, item_length)||next_output_suffix; 2164 end; 2165 else do; 2166 output.file_name = output_list (next_output_index).names; 2167 output_list (next_output_index).used = "1"b; 2168 end; 2169 2170 call open_output; 2171 2172 return; 2173 2174 2175 end open_next_output; 2176 2177 open_output: proc; 2178 2179 io_ptr = output_ptr; /* for position_tape, and to tell which file, if error */ 2180 2181 if output.medium = tape then do; 2182 2183 output_stream_name = tape_stream (output.sw); 2184 2185 /* tape is already attached */ 2186 2187 call position_tape; 2188 2189 if ^no_label (io.sw) then do; /* if labeled tape, build and write header label */ 2190 label_ptr = write_buffer_ptr; /* build it in the write buffer */ 2191 unspec (header_label) = ""b; /* clear it first */ 2192 2193 header_label.btl = bcd_btl; /* GE/b/b600/bBTL/b */ 2194 2195 call system_info_$installation_id (inst); /* get installation id */ 2196 header_label.installation = bcd_string (inst, 6); /* first 6 chars of it in BCD */ 2197 2198 header_label.reel_ser_no = bcd_b1; /* blank first char */ 2199 substr (header_label.reel_ser_no, 7, 30) = bcd_string (string (output_tape.id), 5); 2200 /* ser no in last 5 chars */ 2201 2202 header_label.file_ser_no = header_label.reel_ser_no; /* always the same for single reel files */ 2203 2204 header_label.reel_seq_no = bcd_b2; /* blank first 2 chars */ 2205 substr (header_label.reel_seq_no, 36, 1) = "1"b; /* last 24 bits are the fixed binary number 1 */ 2206 2207 header_label.creation_date = bcd_b1; /* blank first char */ 2208 call decode_clock_value_ (clock_ (), month, dom, year, tod, dow, zone); /* get date */ 2209 substr (header_label.creation_date, 7, 12) = bcd_string_bin (mod (year, 100), 2); 2210 /* last 2 digits of year, in BCD */ 2211 substr (header_label.creation_date, 19, 18) = bcd_string_bin (julian_day (month, dom, year), 3); 2212 /* 3 digit julian day, in BCD */ 2213 2214 header_label.retention_days = bcd_b3; /* first 3 chars blank */ 2215 /* last 3 all zero - no retention days */ 2216 2217 header_label.file_name = bcd_string (string (output_tape.label), 12); 2218 2219 header_label.prverr = bcd_b6; /* 6 BCD blanks */ 2220 2221 word_string_len = 14; /* length of label */ 2222 addr (saved_header_label) -> word_string = addr (header_label) -> word_string; 2223 /* save it to use for building partial label later */ 2224 /* use word_string overlay, since structure assignment 2225* compiles into element-by-element assignment */ 2226 2227 call write_tape_label; /* write label and eof, checking error codes */ 2228 end; /* end of labeled tape do group */ 2229 2230 end; 2231 2232 else do; 2233 2234 output_stream_name = file_stream (output.sw); 2235 2236 call ios_$attach (output_stream_name, "file_", output.file_name, "rw", status); 2237 /* attach in "rw" mode, to allow reading to end of file 2238* to be appended to, if there is one */ 2239 if code ^= 0 then call fatal_error (27); 2240 2241 /* set element size */ 2242 2243 if output.medium = raw then 2244 element_size = 960; 2245 2246 else if output.format = ascii then 2247 element_size = 9; 2248 2249 else 2250 element_size = 36; 2251 2252 call ios_$setsize (output_stream_name, element_size, status); 2253 if code ^= 0 then call fatal_error (28); 2254 2255 2256 call ios_$tell (output_stream_name, "last", "first", offset, status); 2257 if code ^= 0 then call fatal_error (29); 2258 2259 appending_to_output = "0"b; /* initialize switch to off */ 2260 if offset ^= 0 then /* if output seg has something in it already */ 2261 if output.append then /* and user said -append */ 2262 appending_to_output = "1"b; /* then remember to do so */ 2263 2264 else do; /* else ask what to do */ 2265 call command_query_ (addr (query_info), answer, me, 2266 "^a already exists. Do you want to overwrite it?", output.file_name); 2267 2268 if answer = "no" then goto cleanup_and_return; 2269 2270 else do; /* truncate the output file */ 2271 call ios_$seek (output_stream_name, "last", "first", 0, status); 2272 if code ^= 0 then call fatal_error (30); 2273 end; 2274 2275 end; /* end ask user about existing file */ 2276 end; /* end attach non tape */ 2277 2278 if output.medium ^= raw then 2279 if output.format ^= ascii then 2280 if output.format ^= blocks then do; 2281 2282 if appending_to_output then do; 2283 2284 call ios_$read (output_stream_name, gcos_record_ptr, 0, 320, gcos_record_len, status); 2285 return; 2286 end; 2287 2288 else do; 2289 remaining_output_words = 319; 2290 output_word_ptr = addrel (write_buffer_ptr, 1); 2291 block_serial_number = 1; 2292 write_buffer_ptr -> bcw.bsn = bit (fixed (block_serial_number, 18)); 2293 output_block_len = 0; /* fixed bin(24)copy of bcw.length */ 2294 write_buffer_ptr -> bcw.length = (18)"0"b; 2295 2296 if output.gcos_ascii then do; /* write an empty 20-word record at the start of a gcos 2297* ascii file to be compatible in format with the real gcos */ 2298 output_block_len = output_block_len + 21; /* 20 words plus rcw */ 2299 write_buffer_ptr -> bcw.length = bit (bin (output_block_len, 18)); 2300 output_word_ptr -> word_string (1) = ascii_header_rcw; 2301 output_word_ptr = addrel (output_word_ptr, 21); 2302 remaining_output_words = remaining_output_words - 21; 2303 end; 2304 2305 end; 2306 2307 end; 2308 2309 tape_status_message = ""; 2310 2311 if output.long then 2312 call ioa_ ("^a being written", output.file_name); /* print file name or tape message */ 2313 2314 return; 2315 2316 end open_output; 2317 2318 position_tape: proc; 2319 2320 dcl expected_input fixed bin(24)/* next thing expected from tape */; 2321 dcl (header init (1), /* names for things expected from tape */ 2322 trailer init (2), 2323 eof_after_header init (3), 2324 eof_after_trailer init (4), 2325 eof_after_forward_file init (5) 2326 )int static fixed bin(24); 2327 dcl file_number fixed bin(17)init (0); 2328 dcl position_found bit (1) aligned init ("0"b); /* to remember that we found the position, 2329* while we are reading past the eof mark after a label */ 2330 dcl ascii_file_name char (12) aligned; 2331 dcl ascii_ser_no char (5) aligned; 2332 dcl i fixed bin(24); 2333 2334 dcl 1 hdr aligned based (label_ptr), /* overlay for header label */ 2335 2 fill1 (3) bit (36) aligned, /* to pick up chracters in reel_ser_no and file_name */ 2336 2 ser (0:5) bit (6) unaligned, /* one at a time */ 2337 2 fill2 (4) bit (36) aligned, 2338 2 fname (12) bit (6) unaligned; /* don't care about rest of it */ 2339 2340 dcl 1 tape_message aligned based (addr (io.file_name)), 2341 (2 io_name char (6), 2342 2 b1 char (1), 2343 2 tape char (4), 2344 2 b2 char (1), 2345 2 tape_id char (5), 2346 2 b3 char (1), 2347 2 file char (4), 2348 2 b4 char (1), 2349 2 fileno char (3), 2350 2 b5 char (1), 2351 2 filename char (12)) unaligned; 2352 2353 /* Put tape information into io.filename, for convenience of message printing */ 2354 io.file_name = ""; 2355 /* tape_message overlays beginning of io.file_name */ 2356 tape_message.tape = "tape"; 2357 tape_message.io_name = substr (io_names (io.sw), 1, length (tape_message.io_name)); /* "input" or "output" */ 2358 tape_message.tape_id = substr (io_tape.id, 1, length (tape_message.tape_id)); 2359 2360 2361 /* Check for nothing to do */ 2362 if io_tape.position = 0 then do; /* if user did not give position */ 2363 if io.sw = output_code then return; /* use current position for output */ 2364 else if no_label (io.sw) then return; /* do the same for input, if there are no labels */ 2365 else if io_tape.label = "" then /* or, if input file name not given */ 2366 goto omit_rewind; /* just read past the header label */ 2367 end; 2368 2369 /* Rewind tape */ 2370 call ios_$order ((tape_stream (io.sw)), "rewind", null, status); 2371 if code ^= 0 then 2372 call fatal_error (32); /* error rewinding tape */ 2373 if io.sw = output_code | no_label (io.sw) then 2374 if io_tape.position = 1 then goto set_fileno; /* we are already there */ 2375 omit_rewind: /* come here to just read past header label of current file */ 2376 2377 /* Initialize for search loop */ 2378 label_ptr = input_block_ptr; 2379 if no_label (io.sw) then do; /* if unlabeled tape */ 2380 expected_input = eof_after_forward_file; /* just skip to requested position */ 2381 file_number = 1; /* we are already at first file */ 2382 end; 2383 2384 else expected_input = header; 2385 2386 /* Search loop */ 2387 position_loop: file_eof = "0"b; 2388 err_num = file_number; /* in case of error while positioning */ 2389 2390 if expected_input = eof_after_forward_file then /* skip over data records */ 2391 call ios_$order ((tape_stream (io.sw)), "forward_file", null, status); 2392 else /* just read labels and eof marks */ 2393 call ios_$read ((tape_stream (io.sw)), input_block_ptr, 0, elements_wanted, input_block_len, status); 2394 2395 if code ^= 0 then do; 2396 2397 call interpret_tape_status; /* check for eof or other error */ 2398 2399 if file_eof then do; /* eof mark read */ 2400 2401 if expected_input = eof_after_forward_file then do; 2402 if ^no_label (io.sw) then /* unless this is an unlabeled tape, */ 2403 expected_input = trailer; /* the next thing will be a trailer label */ 2404 2405 else do; /* it is an unlabeled tape */ 2406 if io.long then /* tell user that previous file was skipped */ 2407 call ioa_ ("tape ^a, file ^d will be skipped", io_tape.id, file_number); 2408 file_number = file_number + 1; /* increment file number */ 2409 if file_number = io_tape.position then /* if this is the file we want */ 2410 goto set_fileno; /* go put its number into message and return */ 2411 end; 2412 2413 end; 2414 2415 else if expected_input = eof_after_trailer then 2416 if position_found then goto set_filename; /* positioned for writing label of output file */ 2417 else expected_input = header; 2418 2419 else if expected_input = eof_after_header then 2420 if position_found then goto set_filename; /* positioned for reading input data records */ 2421 else expected_input = eof_after_forward_file; /* skip over data records */ 2422 2423 else call fatal_error (33); /* unexpected eof while positioning tape */ 2424 2425 end; /* end eof mark read */ 2426 2427 else call fatal_error (34); /* io error while positioning tape */ 2428 2429 end; /* end code ^= 0 */ 2430 2431 else if expected_input = header then do; /* want header label */ 2432 if header_label.btl = bcd_btl then do; /* this is one */ 2433 expected_input = eof_after_header; 2434 file_number = file_number + 1; 2435 2436 if unspec (partial_label.zero_words) = ""b then /* check for partial label */ 2437 call fatal_error (35); /* partial label while positioning tape */ 2438 2439 if file_number = 1 then do; /* first file on tape */ 2440 do i = 1 to 5; /* convert reel serial number in label to ASCII */ 2441 substr (ascii_ser_no, i, 1) = xlate (fixed (hdr.ser (i))); 2442 end; 2443 2444 if substr (io_tape.id, 1, 4) = "-att" then /* if we did not know the serial no */ 2445 tape_message.tape_id, io_tape.id = ascii_ser_no; /* we do now */ 2446 2447 else do; /* if we already knew it, verify correct tape */ 2448 if substr (io_tape.id, 1, 5) ^= ascii_ser_no then do; /* need substr because of possible 2449* trailing ",Ntrack in id */ 2450 call command_query_ (addr (query_info), answer, me, 2451 "Label on ^a tape contains reel serial number ^a. 2452 You specified reel ^a. Do you wish to proceed?", io_names (io.sw), ascii_ser_no, io_tape.id); 2453 if answer = "no" then goto cleanup_and_return; 2454 end; /* end mismatched ser nos */ 2455 end; /* end we already knew ser no */ 2456 2457 end; /* end file number = 1 */ 2458 2459 do i = 1 to 12 ; /* convert file name in label to ASCII */ 2460 substr (ascii_file_name, i, 1) = xlate (fixed (hdr.fname (i))); 2461 end; 2462 2463 if io_tape.position ^= 0 then do; /* if user gave position */ 2464 if file_number = io_tape.position then do; /* and this is it */ 2465 if io_tape.label ^= "" then do; /* if file name also given */ 2466 if ascii_file_name ^= io_tape.label then do; /* compare them */ 2467 call command_query_ (addr (query_info), answer, me, 2468 "File ^d on tape ^a is named ^a. 2469 You specified the file name: ^a. Do you wish to proceed?", 2470 file_number, io_tape.id, ascii_file_name, io_tape.label); 2471 if answer = "no" then goto cleanup_and_return; 2472 io_tape.label = ascii_file_name; /* replace given name by one from tape label */ 2473 end; /* end names not the same */ 2474 end; /* end user gave label */ 2475 2476 position_found = "1"b; 2477 2478 end; /* end this is specified position */ 2479 end; /* end user gave position */ 2480 2481 else do; /* user did not give position */ 2482 /* this has to be input */ 2483 if io_tape.label = "" then /* we were just reading past header label */ 2484 goto found_input_position; /* of current file */ 2485 if ascii_file_name = io_tape.label then 2486 found_input_position: position_found = "1"b; 2487 end; 2488 2489 if io.long then do; 2490 if position_found then 2491 answer = "copied"; 2492 else answer = "skipped"; 2493 call ioa_ ("tape ^a, file ^d (^a) will be ^a." 2494 , ascii_ser_no, file_number, ascii_file_name, answer); 2495 end; 2496 2497 end; /* end this is a header label */ 2498 2499 else call fatal_error (36); /* expected header label not found */ 2500 end; /* end expecting header label */ 2501 2502 else if expected_input = trailer then do; 2503 if trailer_label.eof = bcd_beofbb then do; 2504 expected_input = eof_after_trailer; 2505 if io.sw = output_code then do; /* for output, stop after trailer of previous file */ 2506 if file_number = io_tape.position - 1 then do; 2507 /* if this file immediately preceeds the one to be written */ 2508 position_found = "1"b; 2509 if io.long then 2510 call ioa_ ("Output will be written on tape ^a after file ^d (^a).", 2511 ascii_ser_no, file_number, ascii_file_name); 2512 end; 2513 2514 end; /* end output */ 2515 end; /* end eof label */ 2516 2517 else if trailer_label.eof = bcd_beorbb then 2518 call fatal_error (37); /* eor label while positioning */ 2519 2520 else call fatal_error (38); /* expected trailer label missing while positioning */ 2521 2522 end; /* end expecting trailer */ 2523 2524 else call fatal_error (39); /* bug in position tape */ 2525 2526 goto position_loop; 2527 2528 set_filename: /* put file name into tape message */ 2529 tape_message.filename = io_tape.label; 2530 /* fall thru and put file number in it too */ 2531 set_fileno: ; 2532 dcl p13 pic "(12)z9"; 2533 dcl 1 p13_ovl based(addr(p13)) 2534 ,2 l10 char(10)unal 2535 ,2 r3 char( 3)unal 2536 ; 2537 p13 = file_number; 2538 tape_message.fileno = p13_ovl.r3; /* last 3 of the 10 digits returned 2539* by char for fixed bin(17) */ 2540 tape_message.file = "file"; 2541 return; 2542 2543 end position_tape; 2544 2545 process_imcv: proc; 2546 2547 call open_input; 2548 2549 if output.set ^= multiple_files then call open_output; 2550 2551 /* set up parameters for find_list_item */ 2552 2553 item_index = 16; /* snumb begins in col 16 */ 2554 item_length = 5; /* and can be up to 5 chars long */ 2555 first_key = 1; /* look for $ SNUMB */ 2556 last_key = 1; /* only */ 2557 eof = "0"b; 2558 2559 call copy_jobs; /* Now do the grubby work */ 2560 2561 if output.set ^= multiple_files then call close_output; 2562 2563 else if ^output.name_files then 2564 if next_output_index < output.list_count then 2565 if ^output.brief then do; 2566 io_ptr = output_ptr; 2567 call report_missing_items; 2568 end; 2569 2570 if eof then do; 2571 if ^input.all then 2572 if list_index ^= input.list_count + 1 then 2573 if ^input.brief then do; 2574 io_ptr = input_ptr; 2575 call report_missing_items; 2576 end; 2577 2578 if looking_for_first_line then 2579 call report_suspicious_eof; 2580 end; 2581 2582 call close_input; 2583 2584 end process_imcv; 2585 2586 process_library_file: proc; 2587 2588 call open_input; 2589 if output.set ^= multiple_files then call open_output; 2590 eof = "0"b; 2591 2592 2593 /* set up parameters for find_list_item */ 2594 2595 item_index = 73; /* edit name starts in col 73 */ 2596 item_length = 8; /* and is up to 8 chars long */ 2597 first_key = 2; /* look for $ GMAP (2) */ 2598 /* $ 355MAP (3) */ 2599 /* $ OBJECT (4) */ 2600 /* $ FORTRAN (5) */ 2601 last_key = 15; /* or $ IDS2 (15) */ 2602 2603 copy_library_decks: do list_index = 1 to input.list_count while (^eof); 2604 2605 call find_list_item; 2606 2607 if ^eof 2608 then do; 2609 if output.set = multiple_files then call open_next_output; 2610 call copy_one_deck; 2611 if output.set = multiple_files then call close_output; 2612 end; 2613 2614 end copy_library_decks; 2615 2616 if input.long then call ioa_ ("^/End of Library copy."); 2617 if output.set ^= multiple_files then call close_output; 2618 2619 else if ^output.name_files then 2620 if next_output_index < output.list_count then 2621 if ^output.brief then do; 2622 io_ptr = output_ptr; 2623 call report_missing_items; 2624 end; 2625 2626 if eof then do; 2627 if ^input.all then /* if all decks were not being copied */ 2628 if list_index ^= input.list_count + 1 then 2629 if ^input.brief then do; 2630 io_ptr = input_ptr; 2631 call report_missing_items; 2632 end; 2633 2634 if looking_for_first_line then 2635 call report_suspicious_eof; 2636 end; 2637 2638 call close_input; 2639 2640 end process_library_file; 2641 2642 process_multiple_files: proc; 2643 2644 if output.set ^= multiple_files then call open_output; 2645 2646 2647 copy_files: do list_index = 1 to input.list_count; 2648 2649 call open_next_input; 2650 if output.set = multiple_files then call open_next_output; 2651 2652 call copy_one_file; 2653 2654 call close_input; 2655 if output.set = multiple_files then call close_output; 2656 2657 end copy_files; 2658 2659 if output.set ^= multiple_files then call close_output; 2660 2661 else /* check for all of the output files written */ 2662 if ^output.name_files then /* but only if names were given */ 2663 if next_output_index ^= output.list_count then 2664 if ^output.brief then do; 2665 io_ptr = output_ptr; 2666 call report_missing_items; 2667 end; 2668 2669 end process_multiple_files; 2670 2671 process_single_file: proc; 2672 2673 call open_input; 2674 if output.set = multiple_files then /* if user did a dumb thing - i.e. 2675* gave several output files, but only one input file */ 2676 call open_next_output; /* we will be sensible, by writing into the first one, 2677* instead of trying to write into a file whose name is given 2678* by the garbage in an uninitialized variable */ 2679 2680 else call open_output; 2681 2682 call copy_one_file; 2683 2684 call close_input; 2685 call close_output; 2686 2687 if output.set = multiple_files then /* if user did a dumb thing */ 2688 if output.list_count > 1 then /* and it was a very dumb thing */ 2689 if ^output.brief then do; /* if he is willing to be told about it */ 2690 io_ptr = output_ptr; /* tell him */ 2691 call report_missing_items; 2692 end; 2693 2694 end process_single_file; 2695 2696 put_comdk: proc (record_ptr, record_len); 2697 2698 dcl record_len fixed bin(24); 2699 dcl record_ptr ptr; 2700 2701 dcl b_col fixed bin(24)/* current column from b_card */; 2702 dcl extra_chars fixed bin(24)/* number of chars past the limit of 55 per field */; 2703 dcl field_len fixed bin(24)/* length of compressed field, including leading blanks */; 2704 dcl saved_string_len fixed bin(24)/* remember nonblank count when limit of 55 is exceeded */; 2705 dcl string_len fixed bin(24)/* length of trailing nonblank string in compressed field */; 2706 dcl string_start fixed bin(24)/* b_col where nonblank string starts */; 2707 dcl 1 b_card like bcd_card aligned based (record_ptr); 2708 2709 dcl blank bit (1) aligned /* on if current char from b_card is blank */; 2710 dcl in_blanks bit (1) aligned /* on while in a string of 3 or more blanks */; 2711 dcl prev_blanks fixed bin(24)/* counter used to find 3 or more consecutive blanks */; 2712 2713 2714 prev_blanks, field_len, string_len = 0; 2715 string_start = 1; /* first string starts in col 1 */ 2716 in_blanks = "1"b; /* to compress 1 or 2 blanks at start of card */ 2717 2718 if comdk_out_index = 132 then /* if current output card is full */ 2719 call finish_comdk_card; /* write it out and initialize a new one */ 2720 2721 do b_col = 1 to 80; /* scan input card for compressible fields */ 2722 2723 if b_card.column (b_col) = bcd_blank 2724 then blank = "1"b; 2725 else blank = "0"b; 2726 2727 if ^blank then /* if in a nonblank string */ 2728 if comdk_out_index > 129 then /* but there is no room for another field */ 2729 /* on the current output card */ 2730 call finish_comdk_card; /* write it out and initialize another one */ 2731 2732 field_len = field_len + 1; /* add this char to length of field */ 2733 2734 if in_blanks then do; /* if already in a string of blanks */ 2735 if ^blank then do; /* not blank - end of blank string */ 2736 in_blanks = "0"b; 2737 string_len = 1; /* start a new nonblank string */ 2738 string_start = b_col; /* at this column */ 2739 end; 2740 end; /* end of in blanks do group */ 2741 2742 else do; /* not in blanks */ 2743 string_len = string_len + 1; /* add this char to length of nonblank string */ 2744 if blank then do; /* if this is a blank */ 2745 if prev_blanks = 2 then do; /* we found 3 consecutive blanks */ 2746 in_blanks = "1"b; 2747 prev_blanks = 0; 2748 if field_len > 3 then do; /* if there was a field before the blanks */ 2749 field_len = field_len - 3; /* remove the them from it */ 2750 string_len = string_len - 3; 2751 call put_comdk_string; /* and write it out */ 2752 end; 2753 string_len = 0; /* new field has no trailing nonblanks yet */ 2754 field_len = 3; /* but it has 3 leading blanks */ 2755 end; /* end found 3 blanks do group */ 2756 else 2757 prev_blanks = prev_blanks + 1; /* count blanks */ 2758 end; /* end this is a blank do group */ 2759 else /* not a blank */ 2760 prev_blanks = 0; /* reset, in case 1 or 2 blanks preceeded this nonblank */ 2761 end; /* end not in blanks do group */ 2762 2763 if ^in_blanks then do; /* we might not be in blanks now, although we were before */ 2764 2765 if field_len = 56 then /* if 1 char too many */ 2766 if b_col = 80 then /* but this is the last column */ 2767 /* the check for >=57, below, will fail */ 2768 goto field_too_long; /* so go write out the first 55 chars now */ 2769 2770 if field_len >= 57 then do; /* max field length is 55, but we let it go longer, 2771* in case the card ends in a long string of blanks, 2772* or there are 3 consecutive blanks in chars 54-57 */ 2773 field_too_long: /* come here if 56th char is in col 80 */ 2774 extra_chars = field_len - 55; 2775 call put_long_comdk_string; /* go put out first 55 chars, and adjust for extras */ 2776 end; /* end >=57 char do group */ 2777 2778 if ^blank then do; /* if no possibility of getting into blanks */ 2779 extra_chars = string_len + 2 + comdk_out_index -132; /* check for full output card */ 2780 if extra_chars >= 0 then do; /* if we will fill or overfill it */ 2781 if extra_chars = 0 then /* we might exactly fill the output card */ 2782 if field_len = 56 then /* with character 56 of a field (illegal) */ 2783 extra_chars = 1; /* because we let it grow to 57 (see above) */ 2784 call put_long_comdk_string; /* go put out first 55 chars and adjust for extras */ 2785 end; /* end of string-fills-card do group */ 2786 end; /* end of this-is-not-a-blank do group */ 2787 end; /* end not-in-blanks-now do group */ 2788 2789 end; /* end 1 to 80 loop on b_col */ 2790 2791 /* Fall thru here after looking at all 80 columns */ 2792 2793 if prev_blanks > 0 then do; /* discard 1 or 2 trailing blanks */ 2794 string_len = string_len - prev_blanks; 2795 field_len = field_len - prev_blanks; 2796 end; 2797 2798 if string_len > 0 then /* if the card ends in a nonblank string */ 2799 call put_comdk_string; /* put it out now */ 2800 k_card.char (comdk_out_index) = "111111"b; /* 77 octal - end of bcd card */ 2801 comdk_out_index = comdk_out_index + 1; 2802 2803 return; 2804 2805 /* * * * * * * * * * * 2806* 2807* INTERNAL PROCEDURES WITHIN THIS INTERNAL PROCEDURE */ 2808 2809 put_comdk_string: proc; 2810 2811 /* FOR DEBUGGING */ 2812 if field_len > 55 then goto k_len_err; 2813 if string_len + 2 > 132 - comdk_out_index then 2814 k_len_err: 2815 call fatal_error (59); /* program error while encoding output comdk */ 2816 2817 k_card.char (comdk_out_index) = bit (fixed (field_len, 6)); 2818 comdk_out_index = comdk_out_index + 1; 2819 k_card.char (comdk_out_index) = bit (fixed (string_len, 6)); 2820 comdk_out_index = comdk_out_index + 1; 2821 2822 if string_len > 0 then do; /* if there is a non blank string */ 2823 bit_string_len = string_len * 6; /* move it as based bit string */ 2824 addr (k_card.char (comdk_out_index)) -> bit_string = 2825 addr (b_card.column (string_start)) -> bit_string; 2826 comdk_out_index = comdk_out_index + string_len; 2827 end; 2828 2829 if comdk_out_index = 132 then /* if card completely full */ 2830 call finish_comdk_card; /* write it out */ 2831 /* however, if there is room for the end of bcd card and 2832* end of deck indicators, we will put off writing it out 2833* until we know if there is more data */ 2834 2835 return; 2836 2837 end put_comdk_string; 2838 2839 /* * * * * * * * * * * */ 2840 2841 put_long_comdk_string: proc; 2842 2843 field_len = field_len - extra_chars; /* get rid of the extra chars */ 2844 saved_string_len = string_len; /* remember how many nonblanks there were */ 2845 string_len = max (0, string_len - extra_chars); /* possibility of more than 55 blanks */ 2846 call put_comdk_string; /* put out the 55 char field */ 2847 field_len = extra_chars; /* the left over chars start a new field */ 2848 string_len = min (saved_string_len, extra_chars); /* if nonblank after many blanks, 2849* string_len will be 1, while extra_chars will be larger */ 2850 string_start = b_col - string_len + 1; /* position of first nonblank extra char */ 2851 2852 if comdk_out_index > 129 then /* if there is no room for another field 2853* on the current output card */ 2854 if string_len > 0 then /* but we have the makings of another field */ 2855 if prev_blanks ^= string_len then /* and there is no possibility of its being all blank */ 2856 call finish_comdk_card; /* write out the current output card and initialize another */ 2857 2858 if ^in_blanks then do; 2859 if prev_blanks = string_len then /* if first 1 or 2 chars of left over string are blank */ 2860 prev_blanks, string_len = 0; /* get rid of them */ 2861 if string_len = 0 then /* if there are no nonblank chars */ 2862 in_blanks = "1"b; /* any leading blanks get compressed out */ 2863 else if b_card.column (string_start) = bcd_blank then do; 2864 string_start = string_start + 1; 2865 string_len = string_len - 1; 2866 end; 2867 end; 2868 2869 end put_long_comdk_string; 2870 2871 2872 /* * * * * * * * * * * */ 2873 2874 finish_comdk_card: proc; 2875 2876 dcl i fixed bin(24); 2877 2878 k_card.char (comdk_out_index) = "000000"b; /* end of comdk card - more to come */ 2879 call write_comdk_card; /* write out the card */ 2880 string (k_card.char) = "0"b; /* clear the 132 output characters */ 2881 comdk_out_index = 1; /* and start with the first one */ 2882 k_card.seq_no = bit (fixed (1+fixed (k_card.seq_no), 24)); /* increment sequence number */ 2883 2884 /* Increment sequence field - columns 77-80 */ 2885 2886 i = 8; /* seq_col(1:8) correspond to card col(73:80) */ 2887 seq_carry: seq_col (i) = seq_col (i) + 1; 2888 if seq_col (i) = 10 then seq_col (i) = 0; /* check for carry */ 2889 k_card.seq_col (i) = raw_table (seq_col (i)); 2890 if seq_col (i) = 0 then do; /* if we carried 1 */ 2891 i = i - 1; /* add it to the column to the left */ 2892 if i >= 5 then goto seq_carry; /* but don't overflow into column 76 */ 2893 end; 2894 2895 return; 2896 end finish_comdk_card; 2897 2898 2899 end put_comdk; 2900 2901 read_and_convert_ascii: proc; 2902 2903 dcl i fixed bin(24); 2904 2905 call read_block; 2906 2907 /* read_block will return file_eof when it is returning the last block. 2908* read_and_convert_input checks file_eof before calling us, so we do not 2909* have to check for eof here */ 2910 2911 if input_block_len = elements_wanted then 2912 if substr (ascii_block, input_block_len, 1) ^= ascii_newline then 2913 call fatal_error (40); /* no newline for a long way in ascii file */ 2914 2915 if substr (ascii_block, input_block_len, 1) = ascii_newline then /* if there is a trailing newline */ 2916 input_block_len = input_block_len - 1; /* get rid of it */ 2917 2918 if input_block_len = 0 then do; /* check for empty line */ 2919 input_block_len = input_block_len + 1; /* aos instead of lda sta */ 2920 substr (ascii_block, 1, 1) = " "; /* put in 1 blank to avoid trouble later */ 2921 end; 2922 2923 if input.no_canon then do; /* if we are not canonicalizing, fix up line length here */ 2924 if (output.gcos_ascii) | (output.format = ascii) then 2925 ascii_line_len = input_block_len; /* records are variable length */ 2926 else do; /* otherwise they are fixed length 80 column card images */ 2927 ascii_line_len = 80; 2928 if input_block_len > 80 then do; /* if input line is too long */ 2929 if ^input.truncate_ascii then /* and user did not say truncate */ 2930 call fatal_error (41); /* complain */ 2931 input_block_len = 80; /* else truncate */ 2932 end; 2933 end; 2934 ascii_card = ascii_block; /* copy input line into work area */ 2935 end; /* end no_canonicalize do group */ 2936 2937 else do; /* we are canonicalizing */ 2938 if (output.gcos_ascii) | (output.format = ascii) then /* if variable length records */ 2939 ascii_line_len = length (ascii_line); /* allow max length for canonicalized line */ 2940 else ascii_line_len = 80; /* else make it 80 column card image */ 2941 call canonicalizer (input_block_ptr, input_block_len, ascii_line_ptr, ascii_line_len); 2942 if output.gcos_ascii then do; /* now get rid of the trailing blanks, if we 2943* allowed max length for variable length line */ 2944 i = verify (reverse (ascii_card), " "); /* i will be position of first nonblank */ 2945 ascii_line_len = ascii_line_len - i + 1; /* so get rid of i-1 trailing blanks */ 2946 end; 2947 end; /* end of canonicalize do group */ 2948 2949 2950 if output.format ^= ascii then call make_gcos_record; 2951 2952 return; 2953 2954 end read_and_convert_ascii; 2955 2956 read_and_convert_gcos: proc; 2957 2958 dcl i fixed bin(24); 2959 dcl fill_index fixed bin (24); 2960 dcl media_code bit (4) unaligned; 2961 2962 skip_card: ; /* come here after discarding a non-bcd card, 2963* to get another card */ 2964 if input.comdk then call read_comdk (gcos_record_ptr, gcos_record_len); 2965 else call read_record (gcos_record_ptr, gcos_record_len); 2966 2967 /* we now have a gcos record, complete with rcw */ 2968 2969 2970 if eof then do; /* maybe we don't have a record... */ 2971 2972 if output.format = ascii | output.gcos_ascii then 2973 if ^output.brief then do; 2974 2975 ascii_card = "END OF FILE"; /* supply something to print, since there is no card */ 2976 call check_bin_cards; /* and go see if deck ended with binary cards */ 2977 end; 2978 2979 return; 2980 2981 end; 2982 2983 media_code = gcos_record_ptr -> rcw.media_code; 2984 2985 2986 if media_code = ascii_header_media_code then do; 2987 if input.long then 2988 call ioa_ ("discarding gcos ascii header record"); 2989 goto skip_card; 2990 end; 2991 2992 else if media_code = ascii_media_code then do; /* if we have a gcos ascii record */ 2993 ascii_line_len = 4*fixed (gcos_record_ptr -> rcw.length); /* record length in chars */ 2994 if (gcos_record_ptr -> rcw.char_pos ^= 0) 2995 then ascii_line_len = ascii_line_len -4 +(gcos_record_ptr -> rcw.char_pos); 2996 char_string_len = ascii_line_len; /* length of string to move */ 2997 ascii_card = addrel (gcos_record_ptr, 1) -> char_string; /* move it out of record */ 2998 if ascii_line_len < 6 /* gotta pad first word */ 2999 then do; 3000 fill_index = ascii_line_len +1; 3001 ascii_line_len = 6; 3002 substr (ascii_card, fill_index, (7 - fill_index)) = " "; 3003 end; 3004 end; 3005 3006 3007 if output.format = ascii | output.gcos_ascii then do; 3008 3009 if (media_code = bcd_media_code) | (media_code = plain_bcd_media_code) then do; /* if bcd record */ 3010 /* or media code = 0 */ 3011 3012 if (gcos_record_len > 18) & (media_code = bcd_media_code) 3013 then call fatal_error (43); 3014 3015 if gcos_record_len <= 14 /* if this is an ordinary BCD card */ 3016 then ascii_line_len = 80; /* make it exactly 80 columns */ 3017 else ascii_line_len = gcos_record_len*6; /* if BCD record is longer than a card */ 3018 ascii_card = ""; /* blank out 'ascii_line_len' characters 3019* (the conversion routine doesn't) */ 3020 3021 call gcos_cv_gebcd_ascii_ (addrel (gcos_record_ptr, 1), min (ascii_line_len, gcos_record_len*6), ascii_line_ptr); 3022 3023 if ^input.brief then call check_bin_cards; /* go see if binary cards preceeded this one */ 3024 3025 if output.gcos_ascii /* chop off trailing blanks */ 3026 then do; 3027 ascii_line_len = length (rtrim (ascii_card)); 3028 if ascii_line_len = 0 /* but leave at least one char 3029* so we don't get shot down */ 3030 then do; 3031 ascii_line_len = ascii_line_len + 1; 3032 substr (ascii_card, ascii_line_len, 1) = " "; 3033 end; 3034 call make_gcos_record; 3035 end; 3036 3037 end; 3038 3039 else if media_code ^= ascii_media_code then do; /* if not BCD or ASCII record, 3040* we have to discard it on ASCII output */ 3041 3042 if ^input.brief then 3043 if ^just_looking then /* we skip thru comdks while looking for edit name or snumb */ 3044 bin_cards_skipped = bin_cards_skipped + 1; 3045 /* keep track of binary cards, to print in message later */ 3046 3047 goto skip_card; /* skip this binary card; go get next card */ 3048 3049 end; 3050 3051 end; 3052 3053 else /* output is BCD */ 3054 if media_code = ascii_media_code then /* if we have gcos_ascii input */ 3055 call make_gcos_record; /* go convert it to BCD */ 3056 3057 return; 3058 3059 end read_and_convert_gcos; 3060 3061 read_and_convert_input: proc; /* a call to this procedure will: 3062* 1) read next record from input file, whatever its type, and 3063* 2) convert it to proper format for output, except for 3064* compressing for comdk output, which is done in write_output */ 3065 3066 io_ptr = input_ptr; /* to tell which file, if error */ 3067 3068 read_next_record: /* come here while searching for first line */ 3069 file_record_count = file_record_count + 1; 3070 if looking_for_last_line then 3071 if file_record_count > input.last_line then do; 3072 found_last_line = "1"b; 3073 goto return_eof; 3074 end; 3075 3076 if looking_for_first_line then 3077 if file_record_count >= input.first_line then do; 3078 looking_for_first_line = "0"b; 3079 if input.last_line > 0 then 3080 looking_for_last_line = "1"b; 3081 end; 3082 3083 if file_eof then 3084 if file_eob then 3085 if ^input_comdk_open then do; 3086 return_eof: eof = "1"b; 3087 return; 3088 end; 3089 3090 if input.format = ascii then call read_and_convert_ascii; 3091 else if input.format = blocks then do; 3092 if file_eof then do; 3093 eof = "1"b; 3094 return; 3095 end; 3096 call read_block; 3097 if input.medium = tape then 3098 if file_eof then do; 3099 eof = "1"b; 3100 return; 3101 end; 3102 end; 3103 else if input.format = gcos then call read_and_convert_gcos; 3104 else call fatal_error (44); 3105 3106 input_record_count = input_record_count + 1; 3107 3108 if looking_for_first_line then 3109 goto read_next_record; 3110 3111 return; 3112 3113 end read_and_convert_input; 3114 3115 read_block: proc; /* procedure to call ios_$read and interpret status code */ 3116 3117 call ios_$read (input_stream_name, input_block_ptr, 0, elements_wanted, input_block_len, status); 3118 3119 input_block_count = input_block_count + 1; /* count blocks */ 3120 3121 if input.medium ^= tape then do; 3122 3123 file_eof = substr (status, 46, 1); 3124 if code ^= 0 then call fatal_error (45); 3125 if file_eof 3126 then if output.medium = tape /* chop off the EOF RCW if tape output */ 3127 then bcw_word.bcw_len = bcw_word.bcw_len - 1; 3128 3129 end; /* end check non-tape status */ 3130 3131 else do; 3132 3133 if code ^= 0 then do; 3134 file_eof = "0"b; 3135 call interpret_tape_status; 3136 if ^file_eof then /* if not just end of file */ 3137 call fatal_error (46); /* tape read error */ 3138 else do; /* skip block length checking if end of file */ 3139 if output.medium = tape /* chop off the EOF RCW if tape output */ 3140 then bcw_word.bcw_len = bcw_word.bcw_len - 1; 3141 return; 3142 end; 3143 end; 3144 3145 end; /* end check tape status */ 3146 3147 if input.format ^= ascii 3148 then if input.medium ^= tape 3149 then if elements_wanted ^= input_block_len 3150 then call fatal_error (47); 3151 3152 if input_block_len = 0 then call fatal_error (48); 3153 3154 return; 3155 3156 end read_block; 3157 3158 read_comdk: proc (record_ptr, record_len); /* returns a bcd or binary card in a gcos record; 3159* uncompresses any comdks that it reads */ 3160 3161 dcl record_len fixed bin(24); 3162 dcl record_ptr ptr; 3163 3164 3165 if input_comdk_open then call get_comdk (record_ptr, record_len); /* if already in a comdk */ 3166 3167 else do; 3168 3169 call read_record (record_ptr, record_len); 3170 3171 if eof then return; 3172 3173 if (record_len = 27|record_len = 24) then /* if the length is that of a binary card */ 3174 if record_ptr -> bin_card.column (1) = comdk_col_1 /* and col 1 has the comdk code in it */ 3175 then do; /* then this is the start of a comdk */ 3176 call open_comdk_input (record_ptr, record_len); /* send comdk card to open routine */ 3177 call get_comdk (record_ptr, record_len); /* now go get first uncomed card from it */ 3178 end; 3179 3180 end; 3181 3182 return; 3183 3184 end read_comdk; 3185 3186 read_gcos_record: proc (record_ptr, record_len); /* procedure to read next record from a 3187* standard system format gcos file */ 3188 3189 dcl record_len fixed bin(24); 3190 dcl record_ptr ptr; 3191 3192 if file_eob then do; /* if no more records in this block */ 3193 3194 3195 if file_eof then do; /* check for end of file from last read block call */ 3196 eof = "1"b; /* tell caller, if eof */ 3197 return; /* and return */ 3198 end; 3199 /* else keep reading */ 3200 call read_block; /* get next block */ 3201 /* End of file checking is made complicated by the fact that the file_ dim 3202* returns an EOF status from the same call that returns the last words in the file, 3203* and we have to remember that status and act on it the NEXT time we want to 3204* read a block. The nstd_ dim, however, returns EOF when there are no more 3205* tape records to be returned. If we are reading a tape, we have to check 3206* for EOF again, now. */ 3207 3208 if input.medium = tape then /* if reading tape */ 3209 if file_eof then do; /* and there are no more records */ 3210 eof = "1"b; /* tell caller */ 3211 return; /* and return to him immediately */ 3212 end; 3213 3214 remaining_block_len = fixed (input_block_ptr -> bcw.length); /* get block length */ 3215 if remaining_block_len > 319 | remaining_block_len < 1 then call fatal_error (49); 3216 3217 file_eob = "0"b; /* remember that we got block */ 3218 3219 record_ptr, saved_record_ptr = addrel (input_block_ptr, 1); /* get first record */ 3220 3221 end; 3222 3223 else /* else just get next record */ 3224 record_ptr, saved_record_ptr = addrel (saved_record_ptr, fixed (saved_record_ptr -> rcw.length) + 1); 3225 3226 if record_ptr -> rcw.eof = bcd_eof then do; /* check for eof record */ 3227 3228 rcw_eof, eof, file_eof, file_eob = "1"b; /* if so, turn on all end switches */ 3229 return; /* and return */ 3230 end; 3231 3232 record_len = fixed (record_ptr -> rcw.length); /* get record length */ 3233 3234 remaining_block_len = remaining_block_len - record_len - 1; /* decrement block length */ 3235 if remaining_block_len < 0 then call fatal_error (50); /* should never go negative */ 3236 if remaining_block_len = 0 then file_eob = "1"b; /* check for end of block */ 3237 3238 return; 3239 3240 end read_gcos_record; 3241 3242 read_raw_record: proc (record_ptr, record_len); /* procedure to get next card from a raw card file, 3243* and return it in a gcos standard record */ 3244 3245 3246 dcl record_len fixed bin(24); 3247 dcl record_ptr ptr; 3248 3249 if file_eof then do; 3250 eof = "1"b; 3251 return; 3252 end; 3253 3254 record_ptr = gcos_work_area_ptr; 3255 gcos_work_area = "0"b; /* clear work area */ 3256 call read_block; /* read one 960-bit string into it, in words 2-28 */ 3257 3258 if substr (gcos_work_area (2), 10, 3) = "101"b then do; /* 7-9 punch ? */ 3259 gcos_work_area (1) = bin_rcw; /* rcw for binary card */ 3260 record_len = 27; 3261 end; 3262 3263 else do; /* bcd card */ 3264 3265 call cv_bin_to_bcd (input_block_ptr, input_block_ptr); 3266 /* NOTE translation in place: output is half as long as input */ 3267 3268 gcos_work_area (1) = bcd_rcw; /* rcw for bcd record */ 3269 record_len = 14; 3270 end; 3271 3272 return; 3273 3274 3275 end read_raw_record; 3276 3277 read_record: proc (record_ptr, record_len); /* procedure to get the next gcos record; 3278* decides whether to read from a gcos file, or 3279* build one from the next card in a raw file; 3280* comdk cards are passed to the caller unchanged */ 3281 3282 dcl record_len fixed bin(24); 3283 dcl record_ptr ptr; 3284 3285 if input.medium = raw then call read_raw_record (record_ptr, record_len); 3286 else call read_gcos_record (record_ptr, record_len); 3287 3288 return; 3289 3290 end read_record; 3291 3292 report_missing_items: proc; 3293 3294 dcl i fixed bin(24); 3295 3296 if io.sw = input_code then do; 3297 3298 if ^eof then do; /* must have run out of output names */ 3299 call ioa_ ("^a: Output list exhausted while input items remain to be copied. 3300 The following input item(s) have not been copied:^/^a", me, item_name); 3301 end; 3302 else call ioa_ ("^a: The following input items were not found:", me); 3303 end; 3304 3305 else call ioa_ ("^a: Input list exhausted while output file names remain. 3306 The following output file(s) have not been written:", me); 3307 3308 if io.list_ptr = null then /* must be input -all, and there is no list */ 3309 call ioa_ ("^/And any that follow it in the input file."); 3310 3311 else do i = 1 to io.list_count; 3312 if ^io_list (i).used then 3313 call ioa_ (io_list (i).names); 3314 end; 3315 3316 return; 3317 3318 end report_missing_items; 3319 3320 report_suspicious_eof: proc; 3321 3322 call ioa_ ("^a: End of file after card ^d of ^a, while seeking card ^d", me, 3323 file_record_count, input.file_name, input.first_line); 3324 return; 3325 3326 end report_suspicious_eof; 3327 3328 write_block: proc (block_ptr, block_len); /* procedure to call ios_$write and interpret status code */ 3329 3330 dcl block_ptr ptr; 3331 dcl block_len fixed bin(24); /* THIS block_len IS THE TOTAL NUMBER OF ELEMENTS 3332* TO BE WRITTEN; FOR A GCOS BLOCK, THE CALLER MUST ADD 1 3333* TO bcw.length TO OBTAIN THE CORRECT VALUE */ 3334 3335 3336 /* Don't write a zero-length (BCW-only) block to a tape */ 3337 3338 if output.format = ascii 3339 | block_len > 1 3340 3341 then do; 3342 3343 output_block_count = output_block_count + 1; 3344 call ios_$write (output_stream_name, block_ptr, 0, block_len, elements_written, status); 3345 3346 if code ^= 0 3347 3348 then do; 3349 3350 if output.medium = tape 3351 3352 then do; 3353 3354 call interpret_tape_status; 3355 call fatal_error (51); /* tape write error */ 3356 end; 3357 3358 else call fatal_error (52); 3359 3360 end; 3361 3362 if elements_written ^= block_len 3363 then call fatal_error (53); 3364 end; 3365 3366 return; 3367 3368 end write_block; 3369 3370 write_comdk: proc (record_ptr, record_len); 3371 3372 dcl dont_compress bit (1) aligned; 3373 dcl record_len fixed bin(24); 3374 dcl record_ptr ptr; 3375 3376 dont_compress = "0"b; 3377 3378 if record_ptr -> rcw.media_code ^= bcd_media_code then 3379 dont_compress = "1"b; /* don't compress binary cards */ 3380 else /* it is a bcd card */ 3381 if record_ptr -> bcd_card.column (1) = bcd_dollar then 3382 dont_compress = "1"b; /* don't compress dollar cards, either */ 3383 3384 if output_comdk_open then do; 3385 if dont_compress then do; /* close it */ 3386 call close_comdk_output; 3387 call write_record (record_ptr, record_len); /* and then write this record */ 3388 end; 3389 3390 else call put_comdk (record_ptr, record_len); 3391 3392 end; /* end comdk open */ 3393 3394 else do; /* comdk not open */ 3395 if dont_compress then 3396 call write_record (record_ptr, record_len); 3397 3398 else do; 3399 call open_comdk_output; 3400 call put_comdk (record_ptr, record_len); 3401 end; 3402 3403 end; /* end comdk not open */ 3404 3405 return; 3406 3407 end write_comdk; 3408 3409 write_comdk_card: proc; 3410 3411 dcl checksum fixed bin(71); 3412 dcl i fixed bin(24); 3413 3414 /* compute checksum of word 1 and words 3-24 of the comdk record */ 3415 3416 checksum = fixed (comdk_work_area_ptr -> gcos_record.data_words (1), 36); 3417 3418 do i = 3 to 24; 3419 if checksum >= 68719476736 then /* 2**36 */ 3420 checksum = checksum - 68719476736 + 1; /* a carry into bit 37 gets added to bit 1 */ 3421 checksum = checksum + fixed (comdk_work_area_ptr -> gcos_record.data_words (i), 36); 3422 end; 3423 /* NOTE: a carry into bit 37 when the LAST word is added 3424* is ignored and not added to bit 1 - this is apparently 3425* the way GEFRC does it, so we will do the same */ 3426 3427 /* put checksum into record */ 3428 k_card.checksum = bit (fixed (checksum, 36)); 3429 3430 /* write it out */ 3431 call write_record (comdk_work_area_ptr, 27); 3432 3433 return; 3434 3435 end write_comdk_card; 3436 3437 write_gcos_record: proc (record_ptr, record_len); 3438 3439 dcl record_ptr ptr; 3440 dcl record_len fixed bin(24); /* THIS record_len INCLUDES THE RCW; THE CALLER MUST ADD 1 3441* TO rcw.length TO OBTAIN THE CORRECT VALUE */ 3442 dcl block_len fixed bin(24)/* to send block length to write block */; 3443 dcl record (record_len) bit (36) based; 3444 3445 if record_len > 319 then call fatal_error (54); 3446 3447 if record_len > remaining_output_words then do; /* write out the block */ 3448 3449 if output.medium = tape then /* for tape files */ 3450 block_len = output_block_len + 1; /* write 320 words or less */ 3451 else /* for disk files, we pad blocks to 320 words */ 3452 block_len = 320; /* so a read of 320 words will get exactly one block */ 3453 3454 call write_block (write_buffer_ptr, block_len); 3455 3456 unspec (write_buffer) = ""b; /* zero the output buffer, 3457* to avoid garbage at the ends of short blocks */ 3458 3459 remaining_output_words = 319; 3460 output_word_ptr = addrel (write_buffer_ptr, 1); 3461 3462 block_serial_number = block_serial_number + 1; 3463 write_buffer_ptr -> bcw.bsn = bit (fixed (block_serial_number, 18)); 3464 3465 output_block_len = 0; /* fixed bin(24)copy of bcw.length */ 3466 3467 end; 3468 3469 output_block_len = output_block_len + record_len; 3470 write_buffer_ptr -> bcw.length = bit (fixed (output_block_len, 18)); 3471 3472 output_word_ptr -> record = record_ptr -> record; 3473 3474 output_word_ptr = addrel (output_word_ptr, record_len); 3475 remaining_output_words = remaining_output_words - record_len; 3476 3477 if record_len = 1 then do; /* record_len of 1 must be an end-of-file word 3478* (000000170000 octal), so force out the block */ 3479 if output.medium = tape then do; /* tape files should not end with eof records */ 3480 write_buffer_ptr -> bcw.length = bit (bin (output_block_len-1, 18)); /* adjust bcw.length */ 3481 block_len = output_block_len; /* write one less word (omit the eof_rcw) */ 3482 end; 3483 3484 else block_len = 320; /* if not tape, write exactly 320 words */ 3485 call write_block (write_buffer_ptr, block_len); 3486 end; 3487 3488 return; 3489 3490 end write_gcos_record; 3491 3492 write_output: proc; 3493 3494 dcl i fixed bin(24); 3495 3496 io_ptr = output_ptr; /* to tell which file, if error */ 3497 3498 if output.format = gcos then do; 3499 if output.comdk then call write_comdk (gcos_record_ptr, gcos_record_len); 3500 else call write_record (gcos_record_ptr, gcos_record_len); 3501 end; 3502 else if output.format = ascii then do; 3503 i = length (rtrim (ascii_card)) + 1; /* get rid of trailing blanks */ 3504 3505 if output.truncate_ascii 3506 then if i > 81 3507 then i = 81; /* chop the line at 80 chars */ 3508 3509 substr (ascii_line, i, 1) = ascii_newline; /* last char must be newline */ 3510 call write_block (ascii_line_ptr, i); 3511 end; 3512 3513 else if output.format = blocks 3514 then do; 3515 if output.medium = tape 3516 then i = bcw_word.bcw_len + 1; /* pick up block length, including bcw */ 3517 3518 else if input.medium = tape /* if tape to segment copy */ 3519 then i = 320; /* pad output block to 320 words */ 3520 else i = input_block_len; /* if not tape, write out exactly what was read in */ 3521 call write_block (input_block_ptr, i); 3522 end; 3523 3524 else call fatal_error (55); 3525 3526 output_record_count = output_record_count + 1; 3527 3528 return; 3529 3530 end write_output; 3531 3532 write_raw_record: proc (record_ptr, record_len); 3533 3534 dcl record_len fixed bin(24); 3535 dcl record_ptr ptr; 3536 3537 dcl i fixed bin(24); 3538 dcl raw_ptr ptr; 3539 3540 if (record_len = 27|record_len = 24) /* if binary card */ 3541 &record_ptr -> rcw.media_code = "0001"b then do; 3542 raw_ptr = addrel (record_ptr, 1); /* data starts right after rcw */ 3543 goto write_raw; /* go write it out */ 3544 end; 3545 3546 else if record_len = 14 /* if BCD card */ 3547 &record_ptr -> rcw.media_code = "0010"b then do; 3548 do i = 1 to 80; 3549 raw_card (i) = raw_table (fixed (record_ptr -> bcd_card.column (i))); 3550 end; 3551 raw_ptr = raw_card_ptr; 3552 3553 write_raw: call write_block (raw_ptr, 1); /* write one 960-bit element */ 3554 return; 3555 end; 3556 3557 else call fatal_error (56); /* bad record length or media code */ 3558 3559 end write_raw_record; 3560 3561 write_record: proc (record_ptr, record_len); 3562 3563 dcl record_len fixed bin(24); 3564 dcl record_ptr ptr; 3565 3566 if output.medium = raw then call write_raw_record (record_ptr, record_len); 3567 else call write_gcos_record (record_ptr, record_len + 1); 3568 /* +1 because rcw not included in record_len, and 3569* write_gcos_record wants total number of words to be written */ 3570 3571 return; 3572 3573 end write_record; 3574 3575 write_tape_eof: proc; 3576 3577 call ios_$order (output_stream_name, "eof", null, status); 3578 if code ^= 0 then do; 3579 call interpret_tape_status; 3580 call fatal_error (57); /* error while writing tape eof */ 3581 end; 3582 3583 return; 3584 3585 end write_tape_eof; 3586 3587 write_tape_label: proc; /* write a label on magnetic tape */ 3588 3589 call write_block (label_ptr, 14); 3590 if code ^= 0 then do; 3591 call interpret_tape_status; 3592 call fatal_error (58); /* error writing tape label */ 3593 end; 3594 3595 output_block_count = output_block_count - 1; /* do not count label as a block - 3596* exact count is needed to put in trailer label */ 3597 call write_tape_eof; /* write eof mark and check error code */ 3598 3599 return; 3600 3601 end write_tape_label; 3602 3603 3604 /* ******************************************************************************************************************** */ 3605 /* ******************************************************************************************************************** */ 3606 /* ******************************************************************************************************************** */ 3607 /* ******************************************************************************************************************** */ 3608 3609 end gcos_card_utility_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 09/12/83 0913.7 gcos_card_utility_.pl1 >special_ldd>on>09/12/83>gcos_card_utility_.pl1 92 1 03/27/82 0424.8 gcos_utility_args_.incl.pl1 >ldd>include>gcos_utility_args_.incl.pl1 690 2 03/11/83 1204.3 query_info.incl.pl1 >ldd>include>query_info.incl.pl1 692 3 03/27/82 0424.8 gcos_xlate_bcd_ascii_.incl.pl1 >ldd>include>gcos_xlate_bcd_ascii_.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. a_code parameter fixed bin(35,0) dcl 86 set ref 11 752* 759* a_input_ptr parameter pointer dcl 87 ref 11 698 a_output_ptr parameter pointer dcl 88 ref 11 699 act_ptr 002656 automatic pointer dcl 227 set ref 1037* 1038* 1038 1040 act_table_entry based structure level 1 dcl 228 addr builtin function dcl 136 ref 726 727 728 729 730 731 732 752 759 773 773 773 773 773 774 775 776 782 857 864 873 1037 1052 1069 1070 1073 1102 1154 1203 1219 1219 1243 1243 1255 1264 1276 1707 1717 1717 1752 1757 1761 1828 1889 1889 1940 1967 1969 1970 1970 1971 2070 2094 2100 2107 2222 2222 2239 2253 2257 2265 2265 2272 2356 2357 2357 2358 2358 2371 2395 2444 2450 2450 2467 2467 2528 2538 2538 2540 2824 2824 2934 2944 2975 2997 3002 3018 3027 3032 3124 3133 3346 3503 3578 3590 addrel builtin function dcl 136 ref 1038 1828 1940 1946 1967 1967 2076 2290 2301 2997 3021 3021 3219 3223 3460 3474 3542 all 73 based bit(1) level 2 dcl 1-13 ref 1790 2571 2627 answer 003070 automatic varying char(8) initial dcl 388 set ref 388* 2265* 2268 2450* 2453 2467* 2471 2490* 2492* 2493* answer_iocbp 6 003110 automatic pointer initial level 2 dcl 2-7 set ref 2-7* append 71 based bit(1) level 2 dcl 1-58 ref 2260 appending_to_output 002700 automatic bit(1) initial dcl 272 set ref 272* 2259* 2260* 2282 ascii constant fixed bin(17,0) initial dcl 1-97 ref 709 1068 1101 1219 1735 1751 2083 2098 2246 2278 2924 2938 2950 2972 3007 3090 3147 3338 3502 ascii_backspace 017123 constant char(1) initial unaligned dcl 396 ref 886 991 ascii_block based char unaligned dcl 146 set ref 2911 2915 2920* 2934 ascii_card based char dcl 161 set ref 1052* 1069 1070 1073 1102 1752 1757 1761 1940 1970* 2934* 2944 2975* 2997* 3002* 3018* 3027 3032* 3503 ascii_file_name 003437 automatic char(12) dcl 2330 set ref 2460* 2466 2467* 2472 2485 2493* 2509* ascii_header_media_code constant bit(4) initial unaligned dcl 457 ref 2986 ascii_header_rcw 000462 constant bit(36) initial unaligned dcl 420 ref 2300 ascii_line 000620 automatic char(1280) dcl 162 set ref 727 1052 1069 1070 1073 1102 1752 1757 1761 1940 1970 2934 2938 2944 2975 2997 3002 3018 3027 3032 3503 3509* ascii_line_len 001322 automatic fixed bin(24,0) initial dcl 165 set ref 165* 1052 1052 1069 1070 1073 1102 1752 1757 1761 1939 1940 1946 1967* 1970 1970 2924* 2927* 2934 2938* 2940* 2941* 2944 2945* 2945 2975 2993* 2994* 2994 2996 2997 2998 3000 3001* 3002 3015* 3017* 3018 3021 3021 3027* 3027 3028 3031* 3031 3032 3032 3503 ascii_line_ptr 001320 automatic pointer dcl 164 set ref 727* 1967* 2941* 3021* 3510* ascii_media_code constant bit(4) initial unaligned dcl 458 ref 1953 2992 3039 3053 ascii_newline 017124 constant char(1) initial unaligned dcl 394 ref 850 2106 2106 2106 2106 2911 2915 3509 ascii_pads 000470 constant char(4) initial unaligned dcl 397 ref 1946 ascii_search_key 000471 constant char(15) initial array dcl 371 ref 1073 1102 1757 ascii_ser_no 003442 automatic char(5) dcl 2331 set ref 2441* 2444 2448 2450* 2493* 2509* ascii_tab constant char(1) initial unaligned dcl 398 ref 894 b_card based structure level 1 dcl 2707 b_col 003514 automatic fixed bin(24,0) dcl 2701 set ref 2721* 2723 2738 2765* 2850 backspace_count 003150 automatic fixed bin(24,0) dcl 820 set ref 997* 1007 1009 bad_card 003300 automatic bit(1) dcl 1368 set ref 1388* 1428 1429* bcd_b1 constant bit(36) initial unaligned dcl 412 ref 2198 2207 bcd_b2 constant bit(36) initial unaligned dcl 414 ref 2204 bcd_b3 constant bit(36) initial unaligned dcl 416 ref 2214 bcd_b6 000463 constant bit(36) initial unaligned dcl 418 ref 1235 1966 2219 bcd_beofbb 000465 constant bit(36) initial unaligned dcl 408 ref 1173 1233 2503 bcd_beorbb 000464 constant bit(36) initial unaligned dcl 410 ref 1173 2517 bcd_blank 017122 constant bit(6) initial unaligned dcl 459 ref 1393 1427 2723 2863 bcd_blank_card 000021 internal static bit(36) initial array dcl 402 set ref 1828 bcd_btl 000466 constant bit(72) initial unaligned dcl 406 ref 2193 2432 bcd_card based structure level 1 dcl 172 bcd_char based bit(6) array level 2 packed unaligned dcl 1379 set ref 1393* 1410* 1427* bcd_chars based structure level 1 dcl 1379 bcd_col_index 002724 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1830* 1870 1877* 1886* 1886 1889 1892* 1892 bcd_dkend 000437 constant bit(36) initial unaligned dcl 451 ref 1082 bcd_dollar constant bit(6) initial unaligned dcl 460 ref 1081 1109 1765 3380 bcd_edit_name 003106 automatic bit(6) array unaligned dcl 453 set ref 2034* 2036 bcd_eof constant bit(4) initial unaligned dcl 461 ref 3226 bcd_media_code constant bit(4) initial unaligned dcl 462 ref 1764 3009 3012 3378 bcd_rcw 000461 constant bit(36) initial unaligned dcl 423 ref 1975 1997 3268 bcd_search_key 000440 constant bit(36) initial array unaligned dcl 433 ref 1084 1110 1770 bcd_table 000331 constant bit(6) initial array dcl 476 ref 1410 bcd_work_area 002033 automatic bit(36) array dcl 200 set ref 729 bcd_work_area_ptr 002052 automatic pointer dcl 201 set ref 729* 1826 1889 1997 bcw based structure level 1 dcl 151 bcw_len 0(18) based fixed bin(18,0) level 2 packed unsigned unaligned dcl 156 set ref 3125* 3125 3139* 3139 3515 bcw_word based structure level 1 dcl 156 before builtin function dcl 136 ref 2161 bin builtin function dcl 136 ref 1957 2015 2299 3480 bin_card based structure level 1 dcl 176 bin_cards_skipped 002725 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1051 1052* 1054* 3042* 3042 bin_char based bit(12) array unaligned dcl 1382 ref 1392 bin_char_not_found 003301 automatic bit(1) dcl 1368 set ref 1402* 1404 1411* 1424 bin_rcw 000460 constant bit(36) initial unaligned dcl 426 ref 2011 3259 bin_table 000231 constant bit(12) initial array dcl 547 ref 1408 1416 bit builtin function dcl 136 ref 796 1234 1952 1957 2015 2292 2299 2817 2819 2882 3428 3463 3470 3480 bit_string based bit unaligned dcl 191 set ref 1889* 1889 2824* 2824 bit_string_len 002030 automatic fixed bin(24,0) dcl 192 set ref 1887* 1889 1889 2823* 2824 2824 blank 003522 automatic bit(1) dcl 2709 set ref 2723* 2725* 2727 2735 2744 2778 blank_count 003145 automatic fixed bin(24,0) dcl 820 set ref 923* 929* 944* 964 967 969 971 block_count 1 based bit(36) level 2 dcl 264 set ref 1178 1178 1178 1234* block_len 003714 automatic fixed bin(24,0) dcl 3442 in procedure "write_gcos_record" set ref 3449* 3451* 3454* 3481* 3484* 3485* block_len parameter fixed bin(24,0) dcl 3331 in procedure "write_block" set ref 3328 3338 3344* 3362 block_ptr parameter pointer dcl 3330 set ref 3328 3344* block_serial_number 002726 automatic fixed bin(24,0) initial dcl 301 set ref 301* 2291* 2292 3462* 3462 3463 blocks constant fixed bin(17,0) initial dcl 1-97 ref 1219 2278 3091 3513 brief 65 based bit(1) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 2563 2619 2661 2687 2972 brief 65 based bit(1) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 1178 1435 1873 2153 2571 2627 3023 3042 bsn based bit(18) level 2 packed unaligned dcl 151 set ref 2292* 3463* btl based bit(72) level 2 dcl 243 set ref 2193* 2432 card_type 003074 automatic char(8) dcl 389 set ref 1027* 1029 char 3 based bit(6) array level 2 in structure "comdk_card" packed unaligned dcl 181 in procedure "gcos_card_utility_" set ref 1842 1850 1866 1889 1894 1993 char 3 based bit(6) array level 2 in structure "k_card" packed unaligned dcl 189 in procedure "gcos_card_utility_" set ref 1137* 2800* 2817* 2819* 2824 2878* 2880* char_pos 0(18) based fixed bin(2,0) level 2 packed unsigned unaligned dcl 210 ref 2994 2994 char_string based char unaligned dcl 194 set ref 1940* 1946* 2997 char_string_len 002031 automatic fixed bin(24,0) dcl 195 set ref 1939* 1940 1942 1945* 1945 1946 1951 2996* 2997 character_count 003144 automatic fixed bin(24,0) dcl 820 set ref 911* 915 940* 949 951 951 954 956 958 960 995* 997 1002 1004 chase 002774 automatic fixed bin(1,0) initial dcl 344 set ref 344* checksum 003702 automatic fixed bin(71,0) dcl 3411 in procedure "write_comdk_card" set ref 3416* 3419 3419* 3419 3421* 3421 3428 checksum 2 based bit(36) level 2 in structure "k_card" packed unaligned dcl 189 in procedure "gcos_card_utility_" set ref 3428* cleanup 000106 stack reference condition dcl 139 ref 703 clock_ 000056 constant entry external dcl 113 ref 2208 2208 code based fixed bin(35,0) dcl 293 set ref 752 759 773* 774 775* 776* 1154 1203 1255 1264 1276 1707* 1717 1717* 1967* 1969 1970* 1971* 2070 2094 2107 2239 2253 2257 2272 2371 2395 3124 3133 3346 3578 3590 col1 1 based bit(12) level 2 in structure "k_card" packed unaligned dcl 189 in procedure "gcos_card_utility_" set ref 2012* col1 1 based bit(12) level 2 in structure "comdk_card" packed unaligned dcl 181 in procedure "gcos_card_utility_" ref 1835 column 1 based bit(12) array level 2 in structure "bin_card" packed unaligned dcl 176 in procedure "gcos_card_utility_" ref 3173 column 1 based bit(6) array level 2 in structure "bcd_card" packed unaligned dcl 172 in procedure "gcos_card_utility_" set ref 1081 1109 1765 1776 1889 3380 3549 column 1 based bit(6) array level 2 in structure "b_card" packed unaligned dcl 2707 in procedure "put_comdk" set ref 2723 2824 2863 com_err 72 based bit(1) level 2 dcl 1-13 ref 1467 com_err_ 000060 constant entry external dcl 113 ref 1707 comdk 67 based bit(1) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" set ref 1729 1730* 1741* 1812* 2964 comdk 67 based bit(1) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 713 3499 comdk_card based structure level 1 dcl 181 comdk_card_ptr 002026 automatic pointer dcl 180 set ref 1833* 1835 1838 1842 1850 1866 1889 1894 1989* 1990 1993 comdk_char_index 002727 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1845* 1850 1851* 1851 1866 1867* 1867 1868 1875 1889 1893* 1893 1894 1895* 1895 1996* comdk_col_1 constant bit(12) initial unaligned dcl 455 ref 1835 2012 3173 comdk_error_count 002730 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1853 1853* 1872* 1872 1987* comdk_out_index 002731 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1137 2013* 2718 2727 2779 2800 2801* 2801 2813 2817 2818* 2818 2819 2820* 2820 2824 2826* 2826 2829 2852 2878 2881* comdk_work_area 002116 automatic bit(36) array dcl 221 set ref 731 comdk_work_area_ptr 002152 automatic pointer dcl 222 set ref 731* 1137 2009 2011 2012 2015 2036 2040 2800 2817 2819 2824 2878 2880 2882 2882 2889 3416 3421 3428 3431* command_query_ 000062 constant entry external dcl 113 ref 2265 2450 2467 cp_escape_control 1(02) 003110 automatic bit(2) initial level 3 packed unaligned dcl 2-7 set ref 2-7* creation_date 6 based bit(36) level 2 dcl 243 set ref 2207* 2209* 2211* data_words 1 based bit(36) array level 2 dcl 205 set ref 1966* 3416 3421 db 000064 constant entry external dcl 113 ref 1713 debug 71 based bit(1) level 2 dcl 1-13 ref 1710 1871 decode_clock_value_ 000066 constant entry external dcl 113 ref 2208 decode_nstd_status_ 000070 constant entry external dcl 113 ref 1909 digit 000105 automatic fixed bin(24,0) dcl 770 set ref 792* 793 796 direction 003272 automatic fixed bin(24,0) dcl 1354 set ref 1399* 1406 1416* 1418* divide builtin function dcl 136 in procedure "gcos_card_utility_" ref 792 1951 divide builtin function dcl 1374 in procedure "cv_bin_to_bcd" ref 1419 dom 002732 automatic fixed bin(24,0) initial dcl 301 in procedure "gcos_card_utility_" set ref 301* 2208* 2211* 2211* dom parameter fixed bin(24,0) dcl 1920 in procedure "julian_day" ref 1917 1926 dont_compress 003672 automatic bit(1) dcl 3372 set ref 3376* 3378* 3380* 3385 3395 dow 002733 automatic fixed bin(24,0) initial dcl 301 set ref 301* 2208* edit_name 003076 automatic char(8) unaligned dcl 390 set ref 2019* 2021* 2031* 2034* element_size 002734 automatic fixed bin(24,0) initial dcl 301 set ref 301* 2059* 2073* 2084* 2089* 2093* 2243* 2246* 2249* 2252* elements_wanted 002735 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1262* 2060* 2074* 2085* 2090* 2392* 2911 3117* 3147 elements_written 002736 automatic fixed bin(24,0) initial dcl 301 set ref 301* 3344* 3362 eof 0(20) based bit(4) level 2 in structure "rcw" packed unaligned dcl 210 in procedure "gcos_card_utility_" ref 3226 eof based bit(36) level 2 in structure "trailer_label" dcl 264 in procedure "gcos_card_utility_" set ref 1173 1173 1233* 2503 2517 eof 002701 automatic bit(1) initial dcl 272 in procedure "gcos_card_utility_" set ref 272* 1065 1099 1287 1290 1306* 1313 1323* 1325 1328 1337* 1345 1740 1834 2557* 2570 2590* 2603 2607 2626 2970 3086* 3093* 3099* 3171 3196* 3210* 3228* 3250* 3298 eof_after_forward_file constant fixed bin(24,0) initial dcl 2321 ref 2380 2390 2401 2421 eof_after_header constant fixed bin(24,0) initial dcl 2321 ref 2419 2433 eof_after_trailer constant fixed bin(24,0) initial dcl 2321 ref 2415 2504 eof_rcw 000457 constant bit(36) initial unaligned dcl 429 set ref 1219 1219 eoj 002702 automatic bit(1) initial dcl 272 set ref 272* 1306* 1309 1310* 1316 1337* 1340 1342* 1348 err_msg 000102 automatic varying char(200) initial dcl 1465 set ref 1465* 1470* 1477* 1481* 1485* 1489* 1494* 1498* 1503* 1507* 1511* 1515* 1519* 1522* 1526* 1530* 1534* 1538* 1542* 1546* 1550* 1554* 1558* 1562* 1566* 1570* 1574* 1578* 1582* 1586* 1590* 1594* 1598* 1602* 1606* 1610* 1614* 1618* 1622* 1626* 1630* 1634* 1638* 1642* 1646* 1650* 1654* 1658* 1663* 1667* 1671* 1675* 1679* 1691* 1691 1705* 1705 1707* err_num 002737 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1471* 1660* 1683* 1687* 1695* 1707* 2388* error_code parameter fixed bin(24,0) dcl 1459 set ref 1457 1469 1469 1471 1475 1711* error_table_$action_not_performed 000040 external static fixed bin(35,0) dcl 98 ref 1717 expected_input 003434 automatic fixed bin(24,0) dcl 2320 set ref 2380* 2384* 2390 2401 2402* 2415 2417* 2419 2421* 2431 2433* 2502 2504* explanation_len 14 003110 automatic fixed bin(21,0) initial level 2 dcl 2-7 set ref 2-7* explanation_ptr 12 003110 automatic pointer initial level 2 dcl 2-7 set ref 2-7* extra_chars 003515 automatic fixed bin(24,0) dcl 2702 set ref 2773* 2779* 2780 2781 2781* 2843 2845 2847 2848 fb_temp 003326 automatic fixed bin(24,0) dcl 1821 set ref 1833* 1835 1835 1838* 1839 1841 field_len 003516 automatic fixed bin(24,0) dcl 2703 in procedure "put_comdk" set ref 2714* 2732* 2732 2748 2749* 2749 2754* 2765 2770 2773 2781 2795* 2795 2812 2817 2843* 2843 2847* field_len 002740 automatic fixed bin(24,0) initial dcl 301 in procedure "gcos_card_utility_" set ref 301* 1832 1842* 1843 1849 1850* 1852 1863 1870 1875* 1886 1894* 1993* 1994 1994 file 4(18) based char(4) level 2 packed unaligned dcl 2340 set ref 2540* file_eob 002703 automatic bit(1) initial dcl 272 set ref 272* 2113* 3083 3192 3217* 3228* 3236* file_eof 002704 automatic bit(1) initial dcl 272 set ref 272* 1151 1156 1162* 1164 1184 1190* 1192 1253* 1257 1263* 1266 1904* 2114* 2387* 2399 3083 3092 3097 3123* 3125 3134* 3136 3195 3208 3228* 3249 file_name 1 based char(168) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" set ref 2161* 2163* 2166* 2236* 2265* 2311* file_name 1 based char(168) level 2 in structure "io" dcl 1-121 in procedure "gcos_card_utility_" set ref 1707* 2354* 2356 2357 2357 2358 2358 2444 2528 2538 2540 file_name 1 based char(168) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" set ref 2025 2031 2069* 2128* 2138* 3322* file_name 10 based bit(72) level 2 in structure "header_label" dcl 243 in procedure "gcos_card_utility_" set ref 2217* file_number 003435 automatic fixed bin(17,0) initial dcl 2327 set ref 2327* 2381* 2388 2406* 2408* 2408 2409 2434* 2434 2439 2464 2467* 2493* 2506 2509* 2537 file_record_count 002741 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1695 1877* 2141* 3068* 3068 3070 3076 3322* file_ser_no 4 based bit(36) level 2 dcl 243 set ref 2202* file_stream 000576 constant char(32) initial array unaligned dcl 1-133 ref 1128 2067 2234 filename 6(27) based char(12) level 2 packed unaligned dcl 2340 set ref 2528* fileno 5(27) based char(3) level 2 packed unaligned dcl 2340 set ref 2538* fill_index 003570 automatic fixed bin(24,0) dcl 2959 set ref 3000* 3002 3002 first_blank 003146 automatic fixed bin(24,0) dcl 820 set ref 915* 917 923 first_card 003244 automatic bit(1) dcl 1304 in procedure "copy_one_deck" set ref 1307* 1310 1312* first_card 003262 automatic bit(1) dcl 1335 in procedure "copy_one_job" set ref 1338* 1342 1344* first_key 002742 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1754 1767 2555* 2597* first_line 76 based fixed bin(17,0) level 2 dcl 1-13 set ref 1744* 2119 3076 3322* fixed builtin function dcl 136 ref 796 1178 1178 1178 1234 1776 1838 1842 1850 1866 1894 1952 1990 1993 2036 2292 2441 2460 2817 2819 2882 2882 2993 3214 3223 3232 3416 3421 3428 3463 3470 3549 fixed_in_db 000100 automatic bit(1) initial dcl 1463 set ref 1463* 1715 fname 10 based bit(6) array level 2 packed unaligned dcl 2334 ref 2460 format 63 based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 709 1068 1101 1219 1219 1735 1751 2246 2278 2278 2924 2938 2950 2972 3007 3338 3498 3502 3513 format 63 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 2083 2098 3090 3091 3103 3147 found_last_line 002705 automatic bit(1) initial dcl 272 set ref 272* 1151 2116* 3072* gcos constant fixed bin(17,0) initial dcl 1-97 ref 3103 3498 gcos_ascii 73 based bit(1) level 2 dcl 1-58 ref 1068 1101 1735 1751 1937 2296 2924 2938 2942 2972 3007 3025 gcos_control_tables_$activity_table 000042 external static fixed bin(17,0) dcl 103 set ref 1037 gcos_control_tables_$cardtable 000044 external static char(8) array unaligned dcl 103 ref 1029 gcos_control_tables_$exc_offset 000046 external static fixed bin(17,0) dcl 103 ref 1033 1038 gcos_control_tables_$nonact 000050 external static fixed bin(24,0) dcl 103 ref 1033 gcos_control_tables_$tablelen 000052 external static fixed bin(17,0) dcl 103 ref 1029 gcos_control_tables_$tabstops 000054 external static fixed bin(17,0) dcl 103 set ref 2100 gcos_cv_ascii_gebcd_check_ 000072 constant entry external dcl 113 ref 773 1967 gcos_cv_gebcd_ascii_ 000074 constant entry external dcl 113 ref 3021 gcos_record based structure level 1 dcl 205 set ref 1082 1084 1110 1770 gcos_record_len 002054 automatic fixed bin(24,0) dcl 203 set ref 1082 1084 1110 1770 1951* 1952 1965* 1966 2284* 2964* 2965* 3012 3015 3017 3021 3021 3499* 3500* gcos_record_ptr 002056 automatic pointer dcl 204 set ref 1081 1082 1084 1109 1110 1764 1765 1770 1776 1935* 1940 1946 1950 1952 1953 1957 1966 1967 1967 1975 2284* 2964* 2965* 2983 2993 2994 2994 2997 3021 3021 3499* 3500* gcos_work_area 001323 automatic bit(36) array dcl 168 set ref 728 3255* 3258 3259* 3268* gcos_work_area_ptr 002024 automatic pointer dcl 170 set ref 728* 1935 2076 3254 hbound builtin function dcl 136 ref 917 923 hdr based structure level 1 dcl 2334 header constant fixed bin(24,0) initial dcl 2321 ref 2384 2417 2431 header_label based structure level 1 dcl 243 set ref 1243 2191* 2222 i 003273 automatic fixed bin(24,0) dcl 1354 in procedure "cv_bin_to_bcd" set ref 1390* 1392 1393 1410 1427 1444* i 003734 automatic fixed bin(24,0) dcl 3537 in procedure "write_raw_record" set ref 3548* 3549 3549* i 003704 automatic fixed bin(24,0) dcl 3412 in procedure "write_comdk_card" set ref 3418* 3421* i 000106 automatic fixed bin(24,0) dcl 770 in procedure "bcd_string" set ref 789* 790 792* i 002743 automatic fixed bin(24,0) initial dcl 301 in procedure "gcos_card_utility_" set ref 301* 1252* 1942* 1943 1944* 1944 1945 1946 1946 1955 1956* 1956 1957 i 003444 automatic fixed bin(24,0) dcl 2332 in procedure "position_tape" set ref 2440* 2441 2441* 2459* 2460 2460* i 003724 automatic fixed bin(24,0) dcl 3494 in procedure "write_output" set ref 3503* 3505 3505* 3509 3510* 3515* 3518* 3520* 3521* i 003560 automatic fixed bin(24,0) dcl 2903 in procedure "read_and_convert_ascii" set ref 2944* 2945 i 003174 automatic fixed bin(24,0) dcl 1063 in procedure "check_for_eod" set ref 1071* 1073* 1083* 1084* i 003312 automatic fixed bin(24,0) dcl 1726 in procedure "find_list_item" set ref 1754* 1757* 1767* 1770* 1775* 1776 1776* 1785* 1786 1786 1791* 1791* 1799 1804 i 003147 automatic fixed bin(24,0) dcl 820 in procedure "canonicalizer" set ref 917* 917* 923 923 991* 991* 995 1029* 1029* 1033 1033 1038 i 003550 automatic fixed bin(24,0) dcl 2876 in procedure "finish_comdk_card" set ref 2886* 2887 2887 2888 2888 2889 2889 2890 2891* 2891 2892 i 003374 automatic fixed bin(24,0) dcl 2007 in procedure "open_comdk_output" set ref 2024* 2025 2028* 2028 2031 2035* 2036 2036* 2039* 2040 2041* i 003344 automatic fixed bin(24,0) dcl 1920 in procedure "julian_day" set ref 1923* 1924* i 000100 automatic fixed bin(24,0) dcl 1123 in procedure "cleanup_proc" set ref 1127* 1128* i 003646 automatic fixed bin(24,0) dcl 3294 in procedure "report_missing_items" set ref 3311* 3312 3312* id based char(32) level 2 in structure "io_tape" dcl 1-122 in procedure "gcos_card_utility_" set ref 2358 2406* 2444 2444* 2448 2450* 2467* id based char(32) level 2 in structure "output_tape" dcl 1-86 in procedure "gcos_card_utility_" ref 2199 2199 imcv constant fixed bin(17,0) initial dcl 1-97 ref 742 1700 in_blanks 003523 automatic bit(1) dcl 2710 set ref 2716* 2734 2736* 2746* 2763 2858 2861* in_count parameter fixed bin(24,0) dcl 770 set ref 764 773* 780 784 789 in_no parameter fixed bin(24,0) dcl 770 ref 784 787 in_string parameter char unaligned dcl 766 set ref 764 772 775* index builtin function dcl 136 ref 886 894 1785 2025 2161 indx 000107 automatic fixed bin(24,0) dcl 770 set ref 786* 793 796 797* 797 initial_input_characters parameter fixed bin(24,0) dcl 812 ref 805 845 850 854 886 894 951 991 991 initial_output_columns parameter fixed bin(24,0) dcl 816 ref 805 846 951 967 1023 1027 input based structure level 1 dcl 1-13 input_block 000114 automatic bit(36) array dcl 147 set ref 726 input_block_count 002744 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1177* 1177 1178 1178* 1444* 1683 3119* 3119 input_block_len 000614 automatic fixed bin(24,0) dcl 148 set ref 1171 1262* 2392* 2911 2911 2911 2915 2915 2915* 2915 2918 2919* 2919 2920 2924 2928 2931* 2934 2941* 3117* 3147 3152 3520 input_block_ptr 000616 automatic pointer dcl 149 set ref 726* 1161 1262* 2076* 2375 2392* 2911 2915 2920 2934 2941* 3117* 3125 3125 3139 3139 3214 3219 3265* 3265* 3515 3521* input_code constant fixed bin(17,0) initial dcl 1-97 ref 3296 input_comdk_open 002706 automatic bit(1) initial dcl 272 set ref 272* 1857* 1988* 3083 3165 input_list based structure array level 1 dcl 1-42 input_ptr 000100 automatic pointer dcl 1-11 in procedure "gcos_card_utility_" set ref 698* 718 740 742 744 746 864 864 1018 1023 1147 1149 1178 1287 1435 1467 1698 1700 1710 1729 1730 1741 1744 1790 1791 1791 1791 1791 1791 1791 1799 1800 1804 1804 1804 1810 1812 1855 1871 1873 2019 2021 2025 2031 2053 2055 2057 2067 2069 2072 2083 2098 2100 2119 2122 2128 2128 2138 2138 2138 2138 2138 2140 2140 2140 2153 2154 2571 2571 2571 2574 2603 2616 2627 2627 2627 2630 2647 2923 2929 2964 2987 3023 3042 3066 3070 3076 3079 3090 3091 3097 3103 3121 3147 3147 3208 3285 3322 3322 3518 input_ptr parameter pointer dcl 1363 in procedure "cv_bin_to_bcd" ref 1353 1392 input_record_count 002745 automatic fixed bin(24,0) initial dcl 301 set ref 301* 3106* 3106 input_stream_name 003050 automatic char(32) dcl 369 set ref 1201* 2057* 2067* 2069* 2093* 2106* 3117* input_string based char unaligned dcl 813 ref 850 854 886 894 951 991 input_string_ptr parameter pointer dcl 814 ref 805 850 854 886 894 951 991 input_tape based structure level 1 dcl 1-46 inst 003022 automatic char(32) unaligned dcl 366 set ref 2195* 2196* installation 2 based bit(36) level 2 dcl 243 set ref 2196* interval 003274 automatic fixed bin(24,0) dcl 1354 set ref 1400* 1406 1419* 1419 io based structure level 1 dcl 1-121 io_list based structure array level 1 dcl 1-123 io_name based char(6) level 2 packed unaligned dcl 2340 set ref 2357* 2357 io_names 000010 internal static char(8) initial array dcl 1-138 set ref 2357 2450* io_ptr 000104 automatic pointer dcl 1-120 set ref 718* 719 719 719 719 719* 1147* 1160 1214* 1230 1707 2053* 2154* 2179* 2189 2354 2356 2357 2357 2357 2358 2358 2358 2362 2363 2364 2365 2370 2373 2373 2373 2379 2390 2392 2402 2406 2406 2409 2444 2444 2444 2448 2450 2450 2463 2464 2465 2466 2467 2467 2472 2483 2485 2489 2505 2506 2509 2528 2528 2538 2540 2566* 2574* 2622* 2630* 2665* 2690* 3066* 3296 3308 3311 3312 3312 3312 3312 3312 3312 3312 3312 3496* io_tape based structure level 1 dcl 1-122 ioa_ 000076 constant entry external dcl 113 ref 775 1052 1178 1444 1711 1712 1744 1800 1810 1853 1855 1874 1875 1877 1879 1970 2128 2311 2406 2493 2509 2616 2987 3299 3302 3305 3308 3312 3322 ios_$attach 000100 constant entry external dcl 113 ref 2069 2236 ios_$detach 000102 constant entry external dcl 113 ref 1128 1201 1274 ios_$order 000104 constant entry external dcl 113 ref 1153 1254 2370 2390 3577 ios_$read 000106 constant entry external dcl 113 ref 1262 2284 2392 3117 ios_$seek 000110 constant entry external dcl 113 ref 2271 ios_$setdelim 000112 constant entry external dcl 113 ref 2106 ios_$setsize 000114 constant entry external dcl 113 ref 2093 2252 ios_$tell 000116 constant entry external dcl 113 ref 2256 ios_$write 000120 constant entry external dcl 113 ref 3344 item_index 002746 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1761 1776 2553* 2595* item_length 002747 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1761 1775 1784 2161 2163 2554* 2596* item_name 003100 automatic char(8) dcl 391 set ref 1704 1761* 1774* 1776* 1785 1786* 1791 1800* 1810* 1855* 2019 2161 2161 2163 3299* j 003375 automatic fixed bin(24,0) dcl 2007 in procedure "open_comdk_output" set ref 2024* 2025* 2027 2028 j 002750 automatic fixed bin(24,0) initial dcl 301 in procedure "gcos_card_utility_" set ref 301* j 003275 automatic fixed bin(24,0) dcl 1354 in procedure "cv_bin_to_bcd" set ref 1404* jday 003345 automatic fixed bin(24,0) dcl 1920 set ref 1922* 1924* 1924 1926* 1926 1927* 1927 1930 just_looking 002707 automatic bit(1) initial dcl 272 set ref 272* 1732* 1742* 1813* 3042 k 002751 automatic fixed bin(24,0) initial dcl 301 in procedure "gcos_card_utility_" set ref 301* k 003276 automatic fixed bin(24,0) dcl 1354 in procedure "cv_bin_to_bcd" set ref 1439* 1440 1440* k_card based structure level 1 dcl 189 set ref 2009* label 10 based char(12) level 2 in structure "output_tape" dcl 1-86 in procedure "gcos_card_utility_" ref 2217 2217 label 10 based char(12) level 2 in structure "io_tape" dcl 1-122 in procedure "gcos_card_utility_" set ref 719 719 719 2365 2465 2466 2467* 2472* 2483 2485 2528 label_ptr 003002 automatic pointer dcl 350 set ref 1161* 1173 1173 1178 1178 1178 1231* 1232 1233 1234 1235 1243 1245 2190* 2191 2193 2196 2198 2199 2202 2202 2204 2205 2207 2209 2211 2214 2217 2219 2222 2375* 2432 2436 2441 2460 2503 2517 3589* last_key 002752 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1754 1767 2556* 2601* last_line 77 based fixed bin(17,0) level 2 dcl 1-13 ref 2122 3070 3079 length builtin function dcl 136 in procedure "gcos_card_utility_" ref 2357 2358 2938 3027 3503 length 0(18) based bit(18) level 2 in structure "bcw" packed unaligned dcl 151 in procedure "gcos_card_utility_" set ref 2294* 2299* 3214 3470* 3480* length based bit(18) level 2 in structure "rcw" packed unaligned dcl 210 in procedure "gcos_card_utility_" set ref 1952* 2993 3223 3232 library constant fixed bin(17,0) initial dcl 1-97 ref 744 1698 1855 2019 list_count 56 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 1287 1791 1799 2571 2603 2627 2647 list_count 56 based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcos_card_utility_" ref 3311 list_count 56 based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 2152 2563 2619 2661 2687 list_index 002753 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1287* 2571 2603* 2627 2647* list_name_size 57 based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcos_card_utility_" ref 3312 3312 3312 3312 3312 3312 list_name_size 57 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 1791 1791 1791 1791 1804 1804 2138 2138 2138 2140 2140 list_name_size 57 based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 2166 2166 2166 2167 2167 list_ptr 54 based pointer level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 1791 1804 2138 2140 list_ptr 54 based pointer level 2 in structure "io" dcl 1-121 in procedure "gcos_card_utility_" ref 3308 3312 3312 list_ptr 54 based pointer level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 2166 2167 literal_sw 1(05) 003110 automatic bit(1) initial level 3 packed unaligned dcl 2-7 set ref 2-7* long 70 based bit(1) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 1810 2311 long 70 based bit(1) level 2 in structure "io" dcl 1-121 in procedure "gcos_card_utility_" ref 2406 2489 2509 long 70 based bit(1) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 1800 1810 2128 2616 2987 looking_for_first_line 002710 automatic bit(1) initial dcl 272 set ref 272* 1744 2118* 2119* 2578 2634 3076 3078* 3108 looking_for_last_line 002711 automatic bit(1) initial dcl 272 set ref 272* 2118* 2122* 3070 3079* max builtin function dcl 136 ref 944 2845 max_error_code 000101 automatic fixed bin(24,0) initial dcl 1464 set ref 1464* 1469 me 000014 internal static char(20) initial unaligned dcl 367 set ref 1052* 1178* 1444* 1707* 1744* 2265* 2450* 2467* 3299* 3302* 3305* 3322* media_code 0(26) based bit(4) level 2 in structure "rcw" packed unaligned dcl 210 in procedure "gcos_card_utility_" set ref 1764 1953* 2983 3378 3540 3546 media_code 003571 automatic bit(4) unaligned dcl 2960 in procedure "read_and_convert_gcos" set ref 2983* 2986 2992 3009 3009 3012 3039 3053 medium 64 based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 711 1219 1219 1226 2181 2243 2278 3125 3139 3350 3449 3479 3515 3566 medium 64 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 1149 2021 2055 2072 3097 3121 3147 3208 3285 3518 medium 64 based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcos_card_utility_" ref 719 min builtin function dcl 136 ref 911 923 929 940 997 2848 3021 3021 mlen 000075 constant fixed bin(24,0) initial array dcl 1919 ref 1924 mod builtin function dcl 136 ref 790 1927 1942 2209 2209 month parameter fixed bin(24,0) dcl 1920 in procedure "julian_day" ref 1917 1923 1927 month 002754 automatic fixed bin(24,0) initial dcl 301 in procedure "gcos_card_utility_" set ref 301* 2208* 2211* 2211* more_backspaces 003151 automatic bit(1) dcl 834 set ref 848* 883 888* 899 985 more_tabs 003152 automatic bit(1) dcl 834 set ref 848* 892 896* 904 908 977 msg2 000165 automatic varying char(200) initial dcl 1465 set ref 1465* 1698* 1700* 1704* 1704 1707* multiple_files constant fixed bin(17,0) initial dcl 1-97 ref 746 1293 1296 2549 2561 2589 2609 2611 2617 2644 2650 2655 2659 2674 2687 name_files 72 based bit(1) level 2 dcl 1-58 ref 707 2160 2563 2619 2661 names 1 based char array level 2 in structure "io_list" dcl 1-123 in procedure "gcos_card_utility_" set ref 3312* names 1 based char array level 2 in structure "input_list" dcl 1-42 in procedure "gcos_card_utility_" ref 1791 2138 names 1 based char array level 2 in structure "output_list" dcl 1-82 in procedure "gcos_card_utility_" ref 2166 next_backspace 003140 automatic fixed bin(24,0) dcl 820 set ref 886* 888 904 next_input_character 003136 automatic fixed bin(24,0) dcl 820 set ref 844* 886 894 951 956* 956 979* 979 991 995 1004* 1004 next_input_index 002755 automatic fixed bin(24,0) initial dcl 301 set ref 301* 2137* 2137 2138 2140 next_output_column 003137 automatic fixed bin(24,0) dcl 820 set ref 844* 915 951 960* 960 967 971* 971 997 1009* 1009 next_output_index 002756 automatic fixed bin(24,0) initial dcl 301 set ref 301* 2150* 2150 2152 2166 2167 2563 2619 2661 next_output_suffix 003102 automatic char(6) dcl 392 set ref 709* 711* 713* 715* 2161 2163 next_reel 15 based bit(36) level 2 dcl 264 set ref 1235* next_tab 003141 automatic fixed bin(24,0) dcl 820 set ref 894* 896 904 911 no_canon 74 based bit(1) level 2 dcl 1-13 ref 2100 2923 no_end_card 002712 automatic bit(1) initial dcl 272 set ref 272* 1092* 1103* 1111* 1313 1345 1733 1734* no_label 002716 automatic bit(1) initial array dcl 288 set ref 288* 288* 719* 1160 1230 2189 2364 2373 2379 2402 nondollar_tab_index 002757 automatic fixed bin(24,0) initial dcl 301 set ref 301* 700* 868 873 1040* null builtin function dcl 136 ref 2-7 2-7 2-7 1153 1153 1254 1254 2370 2370 2390 2390 3308 3577 3577 num 000110 automatic fixed bin(24,0) dcl 770 set ref 787* 790 792 798* offset 002760 automatic fixed bin(24,0) initial dcl 301 set ref 301* 2256* 2260 output based structure level 1 dcl 1-58 output_block_count 002761 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1234 1660 1687 3343* 3343 3595* 3595 output_block_len 002762 automatic fixed bin(24,0) initial dcl 301 set ref 301* 2293* 2298* 2298 2299 3449 3465* 3469* 3469 3470 3480 3481 output_card based char unaligned dcl 817 set ref 951* 967* 1023 1027 output_card_ptr parameter pointer dcl 818 ref 805 951 967 1023 1027 output_code constant fixed bin(17,0) initial dcl 1-97 ref 2363 2373 2505 output_comdk_open 002713 automatic bit(1) initial dcl 272 set ref 272* 1139* 1216 2044* 3384 output_list based structure array level 1 dcl 1-82 output_ptr 000102 automatic pointer dcl 1-56 in procedure "gcos_card_utility_" set ref 699* 707 709 711 713 718 1068 1068 1101 1101 1214 1219 1219 1219 1219 1226 1293 1296 1735 1735 1751 1751 1810 1937 2152 2160 2161 2163 2166 2166 2166 2166 2166 2167 2167 2167 2179 2181 2183 2199 2199 2217 2217 2234 2236 2243 2246 2260 2265 2278 2278 2278 2296 2311 2311 2549 2561 2563 2563 2563 2566 2589 2609 2611 2617 2619 2619 2619 2622 2644 2650 2655 2659 2661 2661 2661 2665 2674 2687 2687 2687 2690 2924 2924 2938 2938 2942 2950 2972 2972 2972 3007 3007 3025 3125 3139 3338 3350 3449 3479 3496 3498 3499 3502 3505 3513 3515 3566 output_ptr parameter pointer dcl 1363 in procedure "cv_bin_to_bcd" ref 1353 1393 1410 1427 output_record_count 002763 automatic fixed bin(24,0) initial dcl 301 set ref 301* 3526* 3526 output_stream_name 003060 automatic char(32) dcl 369 set ref 1153* 1254* 1262* 1274* 2183* 2234* 2236* 2252* 2256* 2271* 2284* 3344* 3577* output_tape based structure level 1 dcl 1-86 output_word_ptr 003004 automatic pointer dcl 350 set ref 2290* 2300 2301* 2301 3460* 3472 3474* 3474 p13 003445 automatic picture(13) unaligned dcl 2532 set ref 2537* 2538 p13_ovl based structure level 1 packed unaligned dcl 2533 padding 1(07) 003110 automatic bit(29) initial level 3 packed unaligned dcl 2-7 set ref 2-7* partial_label based structure level 1 dcl 257 path_len 002764 automatic fixed bin(24,0) initial dcl 301 set ref 301* plain_bcd_media_code constant bit(4) initial unaligned dcl 463 ref 3009 position 16 based fixed bin(17,0) level 2 dcl 1-122 ref 2362 2373 2409 2463 2464 2506 position_found 003436 automatic bit(1) initial dcl 2328 set ref 2328* 2415 2419 2476* 2485* 2490 2508* prev_blanks 003524 automatic fixed bin(24,0) dcl 2711 set ref 2714* 2745 2747* 2756* 2756 2759* 2793 2794 2795 2852 2859 2859* prev_comdk_seq_no 002765 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1839 1841* 1875* 1990* 1991 prompt_after_explanation 1(06) 003110 automatic bit(1) initial level 3 packed unaligned dcl 2-7 set ref 2-7* prverr 15 based bit(36) level 2 dcl 243 set ref 2219* pten 000431 constant fixed bin(24,0) initial array dcl 466 ref 790 792 punch 000565 constant char(3) initial array unaligned dcl 363 ref 1440 punches 003010 automatic varying char(36) dcl 361 set ref 1437* 1440* 1440 1443* 1444* query_code 3 003110 automatic fixed bin(35,0) initial level 2 dcl 2-7 set ref 2-7* query_info 003110 automatic structure level 1 dcl 2-7 set ref 2265 2265 2450 2450 2467 2467 question_iocbp 4 003110 automatic pointer initial level 2 dcl 2-7 set ref 2-7* r3 2(18) based char(3) level 2 packed unaligned dcl 2533 ref 2538 raw constant fixed bin(17,0) initial dcl 1-97 ref 711 1219 2072 2243 2278 3285 3566 raw_card 002060 automatic bit(12) array unaligned dcl 218 set ref 730 3549* raw_card_ptr 002114 automatic pointer dcl 219 set ref 730* 3551 raw_cards_bad 002766 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1430* 1430 raw_chars_bad 002767 automatic fixed bin(24,0) initial dcl 301 set ref 301* 1433* 1433 raw_ptr 003736 automatic pointer dcl 3538 set ref 3542* 3551* 3553* raw_table 000131 constant bit(12) initial array dcl 618 ref 2036 2040 2889 3549 rcw based structure level 1 dcl 210 in procedure "gcos_card_utility_" rcw based bit(36) level 2 in structure "gcos_record" dcl 205 in procedure "gcos_card_utility_" set ref 1950* 1957* 1975* 1997* rcw based bit(36) level 2 in structure "k_card" packed unaligned dcl 189 in procedure "gcos_card_utility_" set ref 2011* rcw_eof 002714 automatic bit(1) initial dcl 272 set ref 272* 1165 1166* 1189 1190* 2115* 3228* record based bit(36) array unaligned dcl 3443 set ref 3472* 3472 record_len parameter fixed bin(24,0) dcl 3161 in procedure "read_comdk" set ref 3158 3165* 3169* 3173 3173 3176* 3177* record_len parameter fixed bin(24,0) dcl 1984 in procedure "open_comdk_input" ref 1982 record_len parameter fixed bin(24,0) dcl 3373 in procedure "write_comdk" set ref 3370 3387* 3390* 3395* 3400* record_len parameter fixed bin(24,0) dcl 3246 in procedure "read_raw_record" set ref 3242 3260* 3269* record_len parameter fixed bin(24,0) dcl 3440 in procedure "write_gcos_record" ref 3437 3445 3447 3469 3472 3472 3472 3474 3475 3477 record_len parameter fixed bin(24,0) dcl 3563 in procedure "write_record" set ref 3561 3566* 3567 record_len parameter fixed bin(24,0) dcl 1822 in procedure "get_comdk" set ref 1819 1825* record_len parameter fixed bin(24,0) dcl 3189 in procedure "read_gcos_record" set ref 3186 3232* 3234 record_len parameter fixed bin(24,0) dcl 3534 in procedure "write_raw_record" ref 3532 3540 3540 3546 record_len parameter fixed bin(24,0) dcl 2698 in procedure "put_comdk" ref 2696 record_len parameter fixed bin(24,0) dcl 3282 in procedure "read_record" set ref 3277 3285* 3286* record_ptr parameter pointer dcl 3283 in procedure "read_record" set ref 3277 3285* 3286* record_ptr parameter pointer dcl 3374 in procedure "write_comdk" set ref 3370 3378 3380 3387* 3390* 3395* 3400* record_ptr parameter pointer dcl 3439 in procedure "write_gcos_record" ref 3437 3472 record_ptr parameter pointer dcl 3162 in procedure "read_comdk" set ref 3158 3165* 3169* 3173 3176* 3177* record_ptr parameter pointer dcl 1985 in procedure "open_comdk_input" ref 1982 1989 record_ptr parameter pointer dcl 3247 in procedure "read_raw_record" set ref 3242 3254* record_ptr parameter pointer dcl 3190 in procedure "read_gcos_record" set ref 3186 3219* 3223* 3226 3232 record_ptr parameter pointer dcl 2699 in procedure "put_comdk" ref 2696 2723 2824 2863 record_ptr parameter pointer dcl 1823 in procedure "get_comdk" set ref 1819 1826* 1828 record_ptr parameter pointer dcl 3535 in procedure "write_raw_record" ref 3532 3540 3542 3546 3549 record_ptr parameter pointer dcl 3564 in procedure "write_record" set ref 3561 3566* 3567* reel_seq_no 5 based bit(36) level 2 dcl 243 set ref 2204* 2205* reel_ser_no 3 based bit(36) level 2 dcl 243 set ref 2198* 2199* 2202 remaining_block_len 002770 automatic fixed bin(24,0) initial dcl 301 set ref 301* 3214* 3215 3215 3234* 3234 3235 3236 remaining_input_characters 003142 automatic fixed bin(24,0) dcl 820 set ref 845* 850 850* 850 886 894 940 944 954* 954 978* 978 1002* 1002 1018 remaining_output_columns 003143 automatic fixed bin(24,0) dcl 820 set ref 846* 881 911 923 929 940 944 958* 958 969* 969 1007* 1007 remaining_output_words 002771 automatic fixed bin(24,0) initial dcl 301 set ref 301* 2289* 2302* 2302 3447 3459* 3475* 3475 repeat_time 10 003110 automatic fixed bin(71,0) initial level 2 dcl 2-7 set ref 2-7* ret_bits based bit dcl 767 ref 782 ret_len 000111 automatic fixed bin(24,0) dcl 770 set ref 780* 782 retention_days 7 based bit(36) level 2 dcl 243 set ref 2214* reverse builtin function dcl 136 ref 2944 rtrim builtin function dcl 136 ref 3027 3503 saved_comdk_sw 003313 automatic bit(1) dcl 1727 set ref 1729* 1741 1744 1812 saved_header_label 002662 automatic structure level 1 dcl 255 set ref 1243 2222 saved_record_ptr 003006 automatic pointer dcl 350 set ref 3219* 3223 3223 3223* saved_string_len 003517 automatic fixed bin(24,0) dcl 2704 set ref 2844* 2848 search_index 003277 automatic fixed bin(24,0) dcl 1354 set ref 1401* 1406* 1406 1408 1410 1416 seq_col 31 based bit(12) array level 2 in structure "k_card" packed unaligned dcl 189 in procedure "gcos_card_utility_" set ref 2036* 2040* 2889* seq_col 002775 automatic fixed bin(24,0) array dcl 345 in procedure "gcos_card_utility_" set ref 2041* 2887* 2887 2888 2888* 2889 2890 seq_no 1(12) based bit(24) level 2 in structure "k_card" packed unaligned dcl 189 in procedure "gcos_card_utility_" set ref 2015* 2882* 2882 seq_no 1(12) based bit(24) level 2 in structure "comdk_card" packed unaligned dcl 181 in procedure "gcos_card_utility_" ref 1838 1990 ser 3 based bit(6) array level 2 packed unaligned dcl 2334 ref 2441 set 62 based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 1293 1296 2549 2561 2589 2609 2611 2617 2644 2650 2655 2659 2674 2687 set 62 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 740 742 744 746 1698 1700 1855 2019 single_file constant fixed bin(17,0) initial dcl 1-97 ref 740 status 002720 automatic bit(72) dcl 294 set ref 752 759 773 774 775 776 1128* 1153* 1154 1201* 1203 1254* 1255 1262* 1264 1274* 1276 1707 1717 1717 1903 1904 1904 1904 1909* 1967 1969 1970 1971 2069* 2070 2093* 2094 2106* 2107 2236* 2239 2252* 2253 2256* 2257 2271* 2272 2284* 2370* 2371 2390* 2392* 2395 3117* 3123 3124 3133 3344* 3346 3577* 3578 3590 status_code 2 003110 automatic fixed bin(35,0) initial level 2 dcl 2-7 set ref 2-7* string builtin function dcl 136 set ref 1082 1084 1110 1770 2009* 2199 2199 2217 2217 2880* string_len 002772 automatic fixed bin(24,0) initial dcl 301 in procedure "gcos_card_utility_" set ref 301* 1866* 1868 1886 1887 1892 1893 string_len 003520 automatic fixed bin(24,0) dcl 2705 in procedure "put_comdk" set ref 2714* 2737* 2743* 2743 2750* 2750 2753* 2779 2794* 2794 2798 2813 2819 2822 2823 2826 2844 2845* 2845 2848* 2850 2852 2852 2859 2859* 2861 2865* 2865 string_start 003521 automatic fixed bin(24,0) dcl 2706 set ref 2715* 2738* 2824 2850* 2863 2864* 2864 substr builtin function dcl 136 set ref 796* 850 854 886 894 951* 951 967* 991 1023 1027 1069 1070 1073 1082 1084 1102 1110 1440 1443* 1752 1757 1761 1770 1776* 1786* 1791 1903 1904 1904 1904 1946* 1946 1957* 2019 2025 2031 2161 2163 2199* 2205* 2209* 2211* 2357 2358 2441* 2444 2448 2460* 2911 2915 2920* 3002* 3032* 3123 3258 3509* suppress_name_sw 1(01) 003110 automatic bit(1) initial level 3 packed unaligned dcl 2-7 set ref 2-7* suppress_spacing 1(04) 003110 automatic bit(1) initial level 3 packed unaligned dcl 2-7 set ref 2-7* sw based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcos_card_utility_" ref 719 1160 1230 2189 2357 2363 2364 2370 2373 2373 2379 2390 2392 2402 2450 2505 3296 sw based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 2183 2234 sw based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 2057 2067 switches 1 003110 automatic structure level 2 dcl 2-7 system_info_$installation_id 000122 constant entry external dcl 113 ref 2195 tab 1 based structure array level 2 dcl 234 set ref 857 873 tab_index 2 based fixed bin(24,0) level 2 dcl 228 ref 1040 tab_ptr 003154 automatic pointer dcl 838 set ref 857* 864* 873* 917 917 923 923 tabs_given 75 based bit(1) level 2 dcl 1-13 ref 864 1023 tabstop based fixed bin(24,0) array dcl 837 ref 917 917 923 923 tabstop_ptr 002660 automatic pointer dcl 233 set ref 857 873 2100* tabstops 100 based fixed bin(17,0) array level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" set ref 864 tabstops based structure level 1 dcl 234 in procedure "gcos_card_utility_" tape constant fixed bin(17,0) initial dcl 1-97 in procedure "gcos_card_utility_" ref 719 1149 1219 1226 2021 2055 2181 3097 3121 3125 3139 3147 3208 3350 3449 3479 3515 3518 tape 1(27) based char(4) level 2 in structure "tape_message" packed unaligned dcl 2340 in procedure "position_tape" set ref 2356* tape_id 3 based char(5) level 2 packed unaligned dcl 2340 set ref 2358* 2358 2444* tape_message based structure level 1 dcl 2340 tape_ptr 60 based pointer level 2 in structure "io" dcl 1-121 in procedure "gcos_card_utility_" ref 719 719 719 2358 2362 2365 2373 2406 2409 2444 2444 2448 2450 2463 2464 2465 2466 2467 2467 2472 2483 2485 2506 2528 tape_ptr 60 based pointer level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 2199 2199 2217 2217 tape_status_message 003032 automatic varying char(50) dcl 368 set ref 1207* 1280* 1707* 1909* 2126* 2309* tape_stream 000616 constant char(32) initial array dcl 1-130 ref 2057 2183 2370 2390 2392 this_char 003302 automatic bit(12) dcl 1383 set ref 1392* 1393 1408 1416 1440 tod 002722 automatic fixed bin(71,0) dcl 299 set ref 2208* trailer constant fixed bin(24,0) initial dcl 2321 ref 2402 2502 trailer_label based structure level 1 dcl 264 set ref 1232* truncate_ascii 66 based bit(1) level 2 in structure "output" dcl 1-58 in procedure "gcos_card_utility_" ref 3505 truncate_ascii 66 based bit(1) level 2 in structure "input" dcl 1-13 in procedure "gcos_card_utility_" ref 1018 2929 unspec builtin function dcl 136 set ref 705* 1232* 1245* 2034* 2106 2106 2106 2106 2191* 2436 3456* used based bit(1) array level 2 in structure "io_list" dcl 1-123 in procedure "gcos_card_utility_" ref 3312 used based bit(1) array level 2 in structure "output_list" dcl 1-82 in procedure "gcos_card_utility_" set ref 2167* used based bit(1) array level 2 in structure "input_list" dcl 1-42 in procedure "gcos_card_utility_" set ref 1804* 2140* verify builtin function dcl 136 ref 2944 word_string based bit(36) array dcl 197 set ref 1243* 1243 1828* 1828 2222* 2222 2300* word_string_len 002032 automatic fixed bin(24,0) dcl 198 set ref 1240* 1243 1827* 1828 2221* 2222 work_bits 000100 automatic bit(72) dcl 768 set ref 773 773 782 796* work_chars 000102 automatic char(12) dcl 769 set ref 772* 773 773 write_buffer 002154 automatic bit(36) array dcl 224 set ref 705* 732 3456* write_buffer_ptr 002654 automatic pointer dcl 225 set ref 732* 1231 2190 2290 2292 2294 2299 3454* 3460 3463 3470 3480 3485* xlate 000111 constant char(1) initial array unaligned dcl 3-6 ref 1776 2441 2460 xnum 000112 automatic fixed bin(24,0) dcl 770 set ref 790* 792 798 year 002773 automatic fixed bin(24,0) initial dcl 301 in procedure "gcos_card_utility_" set ref 301* 2208* 2209 2209 2211* 2211* year parameter fixed bin(24,0) dcl 1920 in procedure "julian_day" ref 1917 1927 yes_or_no_sw 1 003110 automatic bit(1) initial level 3 packed unaligned dcl 2-7 set ref 701* 2-7* zero_words 4 based bit(36) array level 2 dcl 257 set ref 1245* 2436 zone 003104 automatic char(3) dcl 393 set ref 2208* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. bcd_endjob internal static bit(36) initial unaligned dcl 431 file internal static fixed bin(17,0) initial dcl 1-97 gcd_star_eof internal static bit(36) initial unaligned dcl 432 i automatic fixed bin(24,0) dcl 2958 query_info_version_3 internal static fixed bin(17,0) initial dcl 2-33 query_info_version_4 internal static fixed bin(17,0) initial dcl 2-34 query_info_version_5 internal static fixed bin(17,0) initial dcl 2-35 query_info_version_6 internal static fixed bin(17,0) initial dcl 2-36 NAMES DECLARED BY EXPLICIT CONTEXT. act_card 004202 constant label dcl 1033 backspace 004055 constant label dcl 985 bcd_string 003336 constant entry internal dcl 764 ref 2034 2196 2199 2217 bcd_string_bin 003457 constant entry internal dcl 784 ref 2209 2211 call_com_err 006522 constant label dcl 1707 ref 1472 1479 1483 1487 1492 1505 1509 1513 1517 1521 1524 1528 1560 1564 1568 1572 1576 1580 1584 1588 1592 1596 1600 1604 1608 1612 1661 1665 1669 1673 1677 1693 1700 canon_loop 003632 constant label dcl 881 canonicalizer 003547 constant entry internal dcl 805 ref 2941 check_bin_cards 004213 constant entry internal dcl 1049 ref 2976 3023 check_for_eod 004253 constant entry internal dcl 1061 ref 1310 check_for_eoj 004365 constant entry internal dcl 1097 ref 1342 cleanup_and_return 003325 constant label dcl 757 ref 1718 2157 2268 2453 2471 cleanup_proc 004450 constant entry internal dcl 1121 ref 703 757 close_comdk_output 004520 constant entry internal dcl 1135 ref 1216 3386 close_input 004532 constant entry internal dcl 1145 ref 2582 2638 2654 2684 close_output 005036 constant entry internal dcl 1212 ref 1296 2561 2611 2617 2655 2659 2685 copy_files 013547 constant label dcl 2647 copy_jobs 005325 constant entry internal dcl 1285 ref 2559 copy_library_decks 013427 constant label dcl 2603 copy_one_deck 005362 constant entry internal dcl 1303 ref 2610 copy_one_file 005415 constant entry internal dcl 1321 ref 2652 2682 copy_one_job 005430 constant entry internal dcl 1334 ref 1295 cv_bin_to_bcd 005463 constant entry internal dcl 1353 ref 3265 cv_card 005466 constant label dcl 1390 eod 004357 constant label dcl 1093 ref 1065 1070 1075 1082 1086 err 000000 constant label array(61) dcl 1477 set ref 1475 fatal_error 005712 constant entry internal dcl 1457 ref 748 777 793 868 904 1018 1156 1169 1171 1173 1184 1192 1203 1257 1266 1276 1834 1835 1839 1843 1863 1868 1883 1972 1991 1994 2070 2094 2107 2239 2253 2257 2272 2371 2423 2427 2436 2499 2517 2520 2524 2813 2911 2929 3012 3104 3124 3136 3147 3152 3215 3235 3355 3358 3362 3445 3524 3557 3580 3592 field_too_long 013771 constant label dcl 2773 ref 2765 find_edit_name 010300 constant label dcl 2025 ref 2029 find_item_read 006673 constant label dcl 1739 ref 1752 1760 1764 1765 1773 1801 find_list_item 006652 constant entry internal dcl 1722 ref 1288 2605 find_next_backspace 003636 constant label dcl 883 find_next_tab 003660 constant label dcl 892 finish_comdk_card 014226 constant entry internal dcl 2874 ref 2718 2727 2829 2852 found_input_position 013077 constant label dcl 2485 ref 2483 gcos_card_utility_ 002767 constant entry external dcl 11 get_comdk 007231 constant entry internal dcl 1819 ref 3165 3177 have_aci 006766 constant label dcl 1761 ref 1735 1757 have_bcd 007027 constant label dcl 1774 ref 1736 1770 illegal_char 005574 constant label dcl 1424 interpret_tape_status 007672 constant entry internal dcl 1901 ref 1154 1255 1264 2397 3135 3354 3579 3591 julian_day 007735 constant entry internal dcl 1917 ref 2211 2211 k_len_err 014052 constant label dcl 2813 ref 2812 look_at_backspace 003702 constant label dcl 899 look_up_tabstops 004146 constant label dcl 1023 make_gcos_record 007773 constant entry internal dcl 1933 ref 2950 3034 3053 move_blanks 004033 constant label dcl 964 move_characters 004003 constant label dcl 949 next_string 007655 constant label dcl 1893 ref 1881 no_more_tabs 003766 constant label dcl 935 noend 004355 constant label dcl 1092 set ref 1073 1084 omit_rewind 012310 constant label dcl 2375 ref 2365 open_comdk_input 010164 constant entry internal dcl 1982 ref 3176 open_comdk_output 010236 constant entry internal dcl 2005 ref 3399 open_input 010431 constant entry internal dcl 2051 ref 2139 2547 2588 2673 open_next_input 010745 constant entry internal dcl 2135 ref 2649 open_next_output 011004 constant entry internal dcl 2148 ref 1293 2609 2650 2674 open_output 011122 constant entry internal dcl 2177 ref 2170 2549 2589 2644 2680 position_loop 012324 constant label dcl 2387 ref 2526 position_tape 012163 constant entry internal dcl 2318 ref 2061 2187 print_being_copied 007176 constant label dcl 1810 ref 1790 process_imcv 013326 constant entry internal dcl 2545 ref 742 process_library_file 013407 constant entry internal dcl 2586 ref 744 process_multiple_files 013541 constant entry internal dcl 2642 ref 746 process_single_file 013616 constant entry internal dcl 2671 ref 740 process_tab 003722 constant label dcl 908 put_comdk 013646 constant entry internal dcl 2696 ref 3390 3400 put_comdk_string 014037 constant entry internal dcl 2809 ref 2751 2798 2846 put_long_comdk_string 014140 constant entry internal dcl 2841 ref 2775 2784 read_and_convert_ascii 014305 constant entry internal dcl 2901 ref 3090 read_and_convert_gcos 014456 constant entry internal dcl 2956 ref 3103 read_and_convert_input 014745 constant entry internal dcl 3061 ref 1316 1327 1348 1739 read_block 015056 constant entry internal dcl 3115 ref 1163 1183 1191 2905 3096 3200 3256 read_comdk 015240 constant entry internal dcl 3158 ref 2964 read_gcos_record 015330 constant entry internal dcl 3186 ref 3286 read_next_record 014750 constant label dcl 3068 ref 3108 read_raw_record 015454 constant entry internal dcl 3242 ref 3285 read_record 015522 constant entry internal dcl 3277 ref 1833 2965 3169 read_trailer 004623 constant label dcl 1163 ref 1167 report_missing_items 015554 constant entry internal dcl 3292 ref 2155 2567 2575 2623 2631 2666 2691 report_suspicious_eof 015735 constant entry internal dcl 3320 ref 2578 2634 return_eof 015003 constant label dcl 3086 ref 3073 return_string 003443 constant label dcl 780 set ref 801 search_table 005524 constant label dcl 1404 seq_carry 014257 constant label dcl 2887 ref 2892 set_block_msg 006441 constant label dcl 1691 set ref 1685 1689 set_block_no 006433 constant label dcl 1683 ref 1628 1632 1636 1640 1644 1681 set_code 006637 constant label dcl 1717 ref 1467 set_dollar_tabs 003600 constant label dcl 854 set_filename 013300 constant label dcl 2528 ref 2415 2419 set_fileno 013305 constant label dcl 2531 set ref 2373 2409 set_line_no 006454 constant label dcl 1695 ref 1496 1501 1532 1536 1540 1544 1548 1552 1556 1616 1620 1624 set_nondollar_tabs 003604 constant label dcl 861 set_out_block_no 006436 constant label dcl 1687 ref 1648 1652 1656 skip_card 014457 constant label dcl 2962 ref 2989 3047 translate_char 005515 constant label dcl 1396 uncom_loop 007252 constant label dcl 1832 ref 1896 write_block 015774 constant entry internal dcl 3328 ref 3454 3485 3510 3521 3553 3589 write_comdk 016110 constant entry internal dcl 3370 ref 3499 write_comdk_card 016213 constant entry internal dcl 3409 ref 1138 2879 write_gcos_record 016255 constant entry internal dcl 3437 ref 1219 3567 write_output 016422 constant entry internal dcl 3492 ref 1313 1328 1345 write_raw 016611 constant label dcl 3553 ref 3543 write_raw_record 016532 constant entry internal dcl 3532 ref 3566 write_record 016627 constant entry internal dcl 3561 ref 3387 3395 3431 3500 write_tape_eof 016663 constant entry internal dcl 3575 ref 1228 3597 write_tape_label 016731 constant entry internal dcl 3587 ref 1237 1247 2227 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 17502 17626 17133 17512 Length 20202 17133 124 337 346 30 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME gcos_card_utility_ 2984 external procedure is an external procedure. on unit on line 703 64 on unit bcd_string 105 internal procedure uses returns(char(*)) or returns(bit(*)). canonicalizer internal procedure shares stack frame of external procedure gcos_card_utility_. check_bin_cards internal procedure shares stack frame of external procedure gcos_card_utility_. check_for_eod internal procedure shares stack frame of external procedure gcos_card_utility_. check_for_eoj internal procedure shares stack frame of external procedure gcos_card_utility_. cleanup_proc 94 internal procedure is called by several nonquick procedures. close_comdk_output internal procedure shares stack frame of external procedure gcos_card_utility_. close_input internal procedure shares stack frame of external procedure gcos_card_utility_. close_output internal procedure shares stack frame of external procedure gcos_card_utility_. copy_jobs internal procedure shares stack frame of external procedure gcos_card_utility_. copy_one_deck internal procedure shares stack frame of external procedure gcos_card_utility_. copy_one_file internal procedure shares stack frame of external procedure gcos_card_utility_. copy_one_job internal procedure shares stack frame of external procedure gcos_card_utility_. cv_bin_to_bcd internal procedure shares stack frame of external procedure gcos_card_utility_. fatal_error 210 internal procedure is called by several nonquick procedures. find_list_item internal procedure shares stack frame of external procedure gcos_card_utility_. get_comdk internal procedure shares stack frame of external procedure gcos_card_utility_. interpret_tape_status internal procedure shares stack frame of external procedure gcos_card_utility_. julian_day internal procedure shares stack frame of external procedure gcos_card_utility_. make_gcos_record internal procedure shares stack frame of external procedure gcos_card_utility_. open_comdk_input internal procedure shares stack frame of external procedure gcos_card_utility_. open_comdk_output internal procedure shares stack frame of external procedure gcos_card_utility_. open_input internal procedure shares stack frame of external procedure gcos_card_utility_. open_next_input internal procedure shares stack frame of external procedure gcos_card_utility_. open_next_output internal procedure shares stack frame of external procedure gcos_card_utility_. open_output internal procedure shares stack frame of external procedure gcos_card_utility_. position_tape internal procedure shares stack frame of external procedure gcos_card_utility_. process_imcv internal procedure shares stack frame of external procedure gcos_card_utility_. process_library_file internal procedure shares stack frame of external procedure gcos_card_utility_. process_multiple_files internal procedure shares stack frame of external procedure gcos_card_utility_. process_single_file internal procedure shares stack frame of external procedure gcos_card_utility_. put_comdk internal procedure shares stack frame of external procedure gcos_card_utility_. put_comdk_string internal procedure shares stack frame of external procedure gcos_card_utility_. put_long_comdk_string internal procedure shares stack frame of external procedure gcos_card_utility_. finish_comdk_card internal procedure shares stack frame of external procedure gcos_card_utility_. read_and_convert_ascii internal procedure shares stack frame of external procedure gcos_card_utility_. read_and_convert_gcos internal procedure shares stack frame of external procedure gcos_card_utility_. read_and_convert_input internal procedure shares stack frame of external procedure gcos_card_utility_. read_block internal procedure shares stack frame of external procedure gcos_card_utility_. read_comdk internal procedure shares stack frame of external procedure gcos_card_utility_. read_gcos_record internal procedure shares stack frame of external procedure gcos_card_utility_. read_raw_record internal procedure shares stack frame of external procedure gcos_card_utility_. read_record internal procedure shares stack frame of external procedure gcos_card_utility_. report_missing_items internal procedure shares stack frame of external procedure gcos_card_utility_. report_suspicious_eof internal procedure shares stack frame of external procedure gcos_card_utility_. write_block internal procedure shares stack frame of external procedure gcos_card_utility_. write_comdk internal procedure shares stack frame of external procedure gcos_card_utility_. write_comdk_card internal procedure shares stack frame of external procedure gcos_card_utility_. write_gcos_record internal procedure shares stack frame of external procedure gcos_card_utility_. write_output internal procedure shares stack frame of external procedure gcos_card_utility_. write_raw_record internal procedure shares stack frame of external procedure gcos_card_utility_. write_record internal procedure shares stack frame of external procedure gcos_card_utility_. write_tape_eof internal procedure shares stack frame of external procedure gcos_card_utility_. write_tape_label internal procedure shares stack frame of external procedure gcos_card_utility_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 io_names gcos_card_utility_ 000014 me gcos_card_utility_ 000021 bcd_blank_card gcos_card_utility_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME bcd_string 000100 work_bits bcd_string 000102 work_chars bcd_string 000105 digit bcd_string 000106 i bcd_string 000107 indx bcd_string 000110 num bcd_string 000111 ret_len bcd_string 000112 xnum bcd_string cleanup_proc 000100 i cleanup_proc fatal_error 000100 fixed_in_db fatal_error 000101 max_error_code fatal_error 000102 err_msg fatal_error 000165 msg2 fatal_error gcos_card_utility_ 000100 input_ptr gcos_card_utility_ 000102 output_ptr gcos_card_utility_ 000104 io_ptr gcos_card_utility_ 000114 input_block gcos_card_utility_ 000614 input_block_len gcos_card_utility_ 000616 input_block_ptr gcos_card_utility_ 000620 ascii_line gcos_card_utility_ 001320 ascii_line_ptr gcos_card_utility_ 001322 ascii_line_len gcos_card_utility_ 001323 gcos_work_area gcos_card_utility_ 002024 gcos_work_area_ptr gcos_card_utility_ 002026 comdk_card_ptr gcos_card_utility_ 002030 bit_string_len gcos_card_utility_ 002031 char_string_len gcos_card_utility_ 002032 word_string_len gcos_card_utility_ 002033 bcd_work_area gcos_card_utility_ 002052 bcd_work_area_ptr gcos_card_utility_ 002054 gcos_record_len gcos_card_utility_ 002056 gcos_record_ptr gcos_card_utility_ 002060 raw_card gcos_card_utility_ 002114 raw_card_ptr gcos_card_utility_ 002116 comdk_work_area gcos_card_utility_ 002152 comdk_work_area_ptr gcos_card_utility_ 002154 write_buffer gcos_card_utility_ 002654 write_buffer_ptr gcos_card_utility_ 002656 act_ptr gcos_card_utility_ 002660 tabstop_ptr gcos_card_utility_ 002662 saved_header_label gcos_card_utility_ 002700 appending_to_output gcos_card_utility_ 002701 eof gcos_card_utility_ 002702 eoj gcos_card_utility_ 002703 file_eob gcos_card_utility_ 002704 file_eof gcos_card_utility_ 002705 found_last_line gcos_card_utility_ 002706 input_comdk_open gcos_card_utility_ 002707 just_looking gcos_card_utility_ 002710 looking_for_first_line gcos_card_utility_ 002711 looking_for_last_line gcos_card_utility_ 002712 no_end_card gcos_card_utility_ 002713 output_comdk_open gcos_card_utility_ 002714 rcw_eof gcos_card_utility_ 002716 no_label gcos_card_utility_ 002720 status gcos_card_utility_ 002722 tod gcos_card_utility_ 002724 bcd_col_index gcos_card_utility_ 002725 bin_cards_skipped gcos_card_utility_ 002726 block_serial_number gcos_card_utility_ 002727 comdk_char_index gcos_card_utility_ 002730 comdk_error_count gcos_card_utility_ 002731 comdk_out_index gcos_card_utility_ 002732 dom gcos_card_utility_ 002733 dow gcos_card_utility_ 002734 element_size gcos_card_utility_ 002735 elements_wanted gcos_card_utility_ 002736 elements_written gcos_card_utility_ 002737 err_num gcos_card_utility_ 002740 field_len gcos_card_utility_ 002741 file_record_count gcos_card_utility_ 002742 first_key gcos_card_utility_ 002743 i gcos_card_utility_ 002744 input_block_count gcos_card_utility_ 002745 input_record_count gcos_card_utility_ 002746 item_index gcos_card_utility_ 002747 item_length gcos_card_utility_ 002750 j gcos_card_utility_ 002751 k gcos_card_utility_ 002752 last_key gcos_card_utility_ 002753 list_index gcos_card_utility_ 002754 month gcos_card_utility_ 002755 next_input_index gcos_card_utility_ 002756 next_output_index gcos_card_utility_ 002757 nondollar_tab_index gcos_card_utility_ 002760 offset gcos_card_utility_ 002761 output_block_count gcos_card_utility_ 002762 output_block_len gcos_card_utility_ 002763 output_record_count gcos_card_utility_ 002764 path_len gcos_card_utility_ 002765 prev_comdk_seq_no gcos_card_utility_ 002766 raw_cards_bad gcos_card_utility_ 002767 raw_chars_bad gcos_card_utility_ 002770 remaining_block_len gcos_card_utility_ 002771 remaining_output_words gcos_card_utility_ 002772 string_len gcos_card_utility_ 002773 year gcos_card_utility_ 002774 chase gcos_card_utility_ 002775 seq_col gcos_card_utility_ 003002 label_ptr gcos_card_utility_ 003004 output_word_ptr gcos_card_utility_ 003006 saved_record_ptr gcos_card_utility_ 003010 punches gcos_card_utility_ 003022 inst gcos_card_utility_ 003032 tape_status_message gcos_card_utility_ 003050 input_stream_name gcos_card_utility_ 003060 output_stream_name gcos_card_utility_ 003070 answer gcos_card_utility_ 003074 card_type gcos_card_utility_ 003076 edit_name gcos_card_utility_ 003100 item_name gcos_card_utility_ 003102 next_output_suffix gcos_card_utility_ 003104 zone gcos_card_utility_ 003106 bcd_edit_name gcos_card_utility_ 003110 query_info gcos_card_utility_ 003136 next_input_character canonicalizer 003137 next_output_column canonicalizer 003140 next_backspace canonicalizer 003141 next_tab canonicalizer 003142 remaining_input_characters canonicalizer 003143 remaining_output_columns canonicalizer 003144 character_count canonicalizer 003145 blank_count canonicalizer 003146 first_blank canonicalizer 003147 i canonicalizer 003150 backspace_count canonicalizer 003151 more_backspaces canonicalizer 003152 more_tabs canonicalizer 003154 tab_ptr canonicalizer 003174 i check_for_eod 003244 first_card copy_one_deck 003262 first_card copy_one_job 003272 direction cv_bin_to_bcd 003273 i cv_bin_to_bcd 003274 interval cv_bin_to_bcd 003275 j cv_bin_to_bcd 003276 k cv_bin_to_bcd 003277 search_index cv_bin_to_bcd 003300 bad_card cv_bin_to_bcd 003301 bin_char_not_found cv_bin_to_bcd 003302 this_char cv_bin_to_bcd 003312 i find_list_item 003313 saved_comdk_sw find_list_item 003326 fb_temp get_comdk 003344 i julian_day 003345 jday julian_day 003374 i open_comdk_output 003375 j open_comdk_output 003434 expected_input position_tape 003435 file_number position_tape 003436 position_found position_tape 003437 ascii_file_name position_tape 003442 ascii_ser_no position_tape 003444 i position_tape 003445 p13 position_tape 003514 b_col put_comdk 003515 extra_chars put_comdk 003516 field_len put_comdk 003517 saved_string_len put_comdk 003520 string_len put_comdk 003521 string_start put_comdk 003522 blank put_comdk 003523 in_blanks put_comdk 003524 prev_blanks put_comdk 003550 i finish_comdk_card 003560 i read_and_convert_ascii 003570 fill_index read_and_convert_gcos 003571 media_code read_and_convert_gcos 003646 i report_missing_items 003672 dont_compress write_comdk 003702 checksum write_comdk_card 003704 i write_comdk_card 003714 block_len write_gcos_record 003724 i write_output 003734 i write_raw_record 003736 raw_ptr write_raw_record THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as alloc_cs alloc_temp call_ext_out_desc call_ext_out call_int_this_desc call_int_this call_int_other return tra_ext mpfx2 mod_fx1 enable shorten_stack ext_entry int_entry int_entry_desc return_bits_eis THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. clock_ com_err_ command_query_ db decode_clock_value_ decode_nstd_status_ gcos_cv_ascii_gebcd_check_ gcos_cv_gebcd_ascii_ ioa_ ios_$attach ios_$detach ios_$order ios_$read ios_$seek ios_$setdelim ios_$setsize ios_$tell ios_$write system_info_$installation_id THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$action_not_performed gcos_control_tables_$activity_table gcos_control_tables_$cardtable gcos_control_tables_$exc_offset gcos_control_tables_$nonact gcos_control_tables_$tablelen gcos_control_tables_$tabstops LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 11 002763 165 002774 272 002776 288 003013 301 003022 344 003072 388 003074 2 7 003075 698 003125 699 003131 700 003134 701 003136 703 003140 705 003162 707 003165 709 003170 711 003176 713 003204 715 003211 718 003213 719 003217 724 003243 726 003251 727 003253 728 003255 729 003257 730 003261 731 003263 732 003265 740 003267 742 003275 744 003301 746 003305 748 003311 752 003321 753 003324 757 003325 759 003331 760 003334 764 003335 772 003351 773 003356 774 003377 775 003402 776 003430 777 003432 780 003443 782 003447 784 003456 786 003464 787 003466 789 003471 790 003476 792 003503 793 003507 796 003526 797 003537 798 003541 799 003543 801 003546 805 003547 844 003551 845 003554 846 003556 848 003560 850 003563 854 003574 857 003600 859 003603 864 003604 868 003612 873 003626 881 003632 883 003634 886 003636 888 003654 892 003656 894 003660 896 003676 899 003700 904 003702 908 003720 911 003722 915 003730 917 003732 921 003743 923 003745 929 003760 933 003765 940 003766 944 003773 949 004001 951 004003 954 004021 956 004023 958 004025 960 004027 964 004031 967 004033 969 004042 971 004044 977 004046 978 004050 979 004052 985 004053 991 004055 993 004074 995 004076 997 004100 1002 004106 1004 004110 1007 004112 1009 004114 1013 004116 1018 004117 1023 004134 1027 004146 1029 004151 1031 004172 1033 004174 1037 004202 1038 004204 1040 004210 1045 004212 1049 004213 1051 004214 1052 004216 1054 004251 1057 004252 1061 004253 1065 004255 1068 004257 1069 004265 1070 004271 1071 004275 1073 004303 1074 004311 1075 004313 1078 004314 1081 004315 1082 004322 1083 004327 1084 004335 1085 004344 1086 004346 1090 004347 1092 004355 1093 004357 1097 004365 1099 004367 1101 004376 1102 004404 1103 004410 1104 004412 1106 004417 1109 004420 1110 004425 1111 004432 1112 004434 1117 004441 1121 004447 1127 004455 1128 004463 1129 004515 1131 004517 1135 004520 1137 004521 1138 004527 1139 004530 1141 004531 1145 004532 1147 004533 1149 004535 1151 004540 1153 004544 1154 004600 1156 004603 1160 004615 1161 004620 1162 004622 1163 004623 1164 004624 1165 004626 1166 004630 1167 004631 1169 004632 1171 004642 1173 004655 1177 004672 1178 004674 1183 004742 1184 004743 1186 004755 1189 004756 1190 004760 1191 004762 1192 004763 1197 004775 1201 004776 1203 005022 1207 005034 1208 005035 1212 005036 1214 005037 1216 005041 1219 005044 1226 005066 1228 005072 1230 005073 1231 005076 1232 005100 1233 005104 1234 005106 1235 005114 1237 005116 1240 005117 1243 005121 1245 005126 1247 005131 1252 005132 1253 005137 1254 005140 1255 005173 1257 005176 1259 005210 1262 005212 1263 005246 1264 005247 1266 005252 1270 005264 1274 005265 1276 005311 1280 005323 1281 005324 1285 005325 1287 005326 1288 005341 1290 005342 1293 005344 1295 005351 1296 005352 1300 005357 1301 005361 1303 005362 1306 005363 1307 005365 1309 005367 1310 005372 1312 005402 1313 005403 1316 005410 1317 005413 1319 005414 1321 005415 1323 005416 1325 005417 1327 005422 1328 005423 1329 005426 1331 005427 1334 005430 1337 005431 1338 005433 1340 005435 1342 005440 1344 005450 1345 005451 1348 005456 1349 005461 1351 005462 1353 005463 1388 005465 1390 005466 1392 005473 1393 005503 1399 005515 1400 005517 1401 005521 1402 005522 1404 005524 1406 005533 1408 005537 1410 005543 1411 005554 1412 005555 1416 005556 1418 005563 1419 005565 1422 005570 1424 005572 1427 005574 1428 005604 1429 005606 1430 005610 1433 005611 1435 005612 1437 005615 1439 005616 1440 005623 1442 005643 1443 005645 1444 005647 1452 005706 1454 005710 1457 005711 1463 005717 1464 005720 1465 005722 1467 005724 1469 005730 1470 005736 1471 005743 1472 005745 1475 005746 1477 005747 1479 005754 1481 005755 1483 005762 1485 005763 1487 005770 1489 005771 1492 005776 1494 005777 1496 006004 1498 006005 1501 006012 1503 006013 1505 006020 1507 006021 1509 006026 1511 006027 1513 006034 1515 006035 1517 006042 1519 006043 1521 006050 1522 006051 1524 006056 1526 006057 1528 006064 1530 006065 1532 006072 1534 006073 1536 006100 1538 006101 1540 006106 1542 006107 1544 006114 1546 006115 1548 006122 1550 006123 1552 006130 1554 006131 1556 006136 1558 006137 1560 006144 1562 006145 1564 006152 1566 006153 1568 006160 1570 006161 1572 006166 1574 006167 1576 006174 1578 006175 1580 006202 1582 006203 1584 006210 1586 006211 1588 006216 1590 006217 1592 006224 1594 006225 1596 006232 1598 006233 1600 006240 1602 006241 1604 006246 1606 006247 1608 006254 1610 006255 1612 006262 1614 006263 1616 006270 1618 006271 1620 006276 1622 006277 1624 006304 1626 006305 1628 006312 1630 006313 1632 006320 1634 006321 1636 006326 1638 006327 1640 006334 1642 006335 1644 006342 1646 006343 1648 006350 1650 006351 1652 006356 1654 006357 1656 006364 1658 006365 1660 006372 1661 006374 1663 006375 1665 006402 1667 006403 1669 006410 1671 006411 1673 006416 1675 006417 1677 006424 1679 006425 1681 006432 1683 006433 1685 006435 1687 006436 1689 006440 1691 006441 1693 006453 1695 006454 1698 006456 1700 006467 1704 006476 1705 006510 1707 006522 1710 006562 1711 006566 1712 006612 1713 006630 1715 006635 1717 006637 1718 006647 1722 006652 1729 006653 1730 006656 1732 006657 1733 006661 1734 006663 1735 006664 1736 006672 1739 006673 1740 006674 1741 006676 1742 006701 1744 006702 1748 006732 1751 006733 1752 006741 1754 006745 1757 006755 1759 006763 1760 006765 1761 006766 1762 006773 1764 006774 1765 007001 1767 007006 1770 007015 1772 007024 1773 007026 1774 007027 1775 007031 1776 007041 1777 007057 1784 007061 1785 007064 1786 007075 1790 007106 1791 007111 1795 007141 1799 007143 1800 007150 1801 007163 1804 007164 1810 007176 1812 007224 1813 007227 1815 007230 1819 007231 1825 007233 1826 007235 1827 007237 1828 007240 1830 007250 1832 007252 1833 007254 1834 007256 1835 007270 1838 007312 1839 007316 1841 007332 1842 007334 1843 007340 1845 007352 1849 007354 1850 007357 1851 007370 1852 007371 1853 007373 1855 007415 1857 007440 1859 007441 1863 007442 1866 007454 1867 007465 1868 007466 1870 007501 1871 007505 1872 007510 1873 007511 1874 007513 1875 007527 1877 007561 1879 007604 1881 007620 1883 007621 1886 007631 1887 007635 1889 007640 1892 007653 1893 007655 1894 007657 1895 007670 1896 007671 1901 007672 1903 007673 1904 007677 1909 007717 1913 007734 1917 007735 1922 007737 1923 007740 1924 007751 1925 007753 1926 007755 1927 007760 1930 007770 1933 007773 1935 007774 1937 007776 1939 010001 1940 010003 1942 010010 1943 010014 1944 010015 1945 010017 1946 010021 1950 010026 1951 010027 1952 010032 1953 010040 1955 010044 1956 010046 1957 010050 1961 010060 1965 010061 1966 010063 1967 010077 1969 010117 1970 010121 1971 010150 1972 010151 1975 010161 1979 010163 1982 010164 1987 010166 1988 010167 1989 010171 1990 010174 1991 010177 1993 010211 1994 010215 1996 010231 1997 010233 2000 010235 2005 010236 2009 010237 2011 010243 2012 010245 2013 010247 2015 010251 2019 010256 2021 010267 2024 010275 2025 010300 2027 010320 2028 010321 2029 010322 2031 010323 2034 010326 2035 010360 2036 010367 2037 010405 2039 010407 2040 010415 2041 010422 2042 010424 2044 010426 2046 010430 2051 010431 2053 010432 2055 010434 2057 010437 2059 010445 2060 010447 2061 010451 2063 010452 2067 010453 2069 010461 2070 010516 2072 010530 2073 010534 2074 010536 2076 010540 2081 010543 2083 010544 2084 010547 2085 010551 2086 010553 2089 010554 2090 010556 2093 010560 2094 010601 2098 010613 2100 010617 2106 010624 2107 010667 2113 010701 2114 010703 2115 010704 2116 010705 2118 010706 2119 010710 2122 010715 2126 010720 2128 010721 2131 010744 2135 010745 2137 010746 2138 010747 2139 010766 2140 010767 2141 011002 2144 011003 2148 011004 2150 011005 2152 011006 2153 011012 2154 011015 2155 011016 2157 011017 2160 011020 2161 011022 2163 011060 2164 011076 2166 011100 2167 011116 2170 011120 2172 011121 2177 011122 2179 011123 2181 011125 2183 011130 2187 011136 2189 011137 2190 011142 2191 011144 2193 011150 2195 011153 2196 011164 2198 011217 2199 011222 2202 011262 2204 011265 2205 011267 2207 011271 2208 011273 2209 011325 2211 011363 2214 011422 2217 011425 2219 011467 2221 011472 2222 011474 2227 011500 2230 011501 2234 011502 2236 011510 2239 011545 2243 011557 2246 011566 2249 011574 2252 011576 2253 011617 2256 011631 2257 011666 2259 011700 2260 011701 2265 011711 2268 011747 2271 011754 2272 012012 2278 012024 2282 012035 2284 012037 2285 012075 2289 012076 2290 012100 2291 012103 2292 012105 2293 012113 2294 012114 2296 012116 2298 012120 2299 012122 2300 012130 2301 012132 2302 012134 2309 012136 2311 012137 2314 012162 2318 012163 2327 012164 2328 012165 2354 012166 2356 012172 2357 012175 2358 012204 2362 012211 2363 012213 2364 012217 2365 012222 2370 012226 2371 012264 2373 012276 2375 012310 2379 012312 2380 012315 2381 012317 2382 012321 2384 012322 2387 012324 2388 012325 2390 012327 2392 012375 2395 012437 2397 012441 2399 012442 2401 012444 2402 012447 2406 012455 2408 012503 2409 012504 2413 012511 2415 012512 2417 012516 2419 012521 2421 012525 2423 012530 2425 012540 2427 012541 2429 012551 2431 012552 2432 012555 2433 012562 2434 012564 2436 012565 2439 012601 2440 012604 2441 012611 2442 012626 2444 012630 2448 012646 2450 012657 2453 012727 2459 012734 2460 012741 2461 012756 2463 012760 2464 012764 2465 012766 2466 012772 2467 012776 2471 013047 2472 013054 2476 013064 2479 013066 2483 013067 2485 013073 2489 013101 2490 013103 2492 013113 2493 013120 2497 013154 2499 013155 2500 013165 2502 013166 2503 013170 2504 013173 2505 013175 2506 013200 2508 013206 2509 013210 2515 013242 2517 013243 2520 013256 2522 013266 2524 013267 2526 013277 2528 013300 2531 013305 2537 013306 2538 013315 2540 013322 2541 013325 2545 013326 2547 013327 2549 013330 2553 013335 2554 013337 2555 013341 2556 013343 2557 013344 2559 013345 2561 013346 2563 013354 2566 013363 2567 013364 2570 013365 2571 013367 2574 013400 2575 013401 2578 013402 2582 013405 2584 013406 2586 013407 2588 013410 2589 013411 2590 013416 2595 013417 2596 013421 2597 013423 2601 013425 2603 013427 2605 013441 2607 013442 2609 013444 2610 013451 2611 013452 2614 013457 2616 013461 2617 013500 2619 013506 2622 013515 2623 013516 2626 013517 2627 013521 2630 013532 2631 013533 2634 013534 2638 013537 2640 013540 2642 013541 2644 013542 2647 013547 2649 013557 2650 013560 2652 013565 2654 013566 2655 013567 2657 013574 2659 013576 2661 013604 2665 013613 2666 013614 2669 013615 2671 013616 2673 013617 2674 013620 2680 013626 2682 013627 2684 013630 2685 013631 2687 013632 2690 013643 2691 013644 2694 013645 2696 013646 2714 013650 2715 013653 2716 013655 2718 013657 2721 013663 2723 013671 2725 013704 2727 013705 2732 013713 2734 013714 2735 013716 2736 013720 2737 013721 2738 013723 2740 013725 2743 013726 2744 013727 2745 013731 2746 013734 2747 013736 2748 013737 2749 013742 2750 013744 2751 013746 2753 013747 2754 013750 2755 013752 2756 013753 2758 013754 2759 013755 2763 013756 2765 013760 2770 013766 2773 013771 2775 013774 2778 013775 2779 013777 2780 014004 2781 014005 2784 014013 2789 014014 2793 014016 2794 014020 2795 014022 2798 014024 2800 014027 2801 014035 2803 014036 2809 014037 2812 014040 2813 014043 2817 014062 2818 014075 2819 014076 2820 014110 2822 014111 2823 014113 2824 014115 2826 014131 2829 014133 2835 014137 2841 014140 2843 014141 2844 014143 2845 014145 2846 014152 2847 014153 2848 014155 2850 014161 2852 014165 2858 014175 2859 014177 2861 014204 2863 014211 2864 014222 2865 014223 2869 014225 2874 014226 2878 014227 2879 014235 2880 014236 2881 014242 2882 014244 2886 014255 2887 014257 2888 014261 2889 014265 2890 014275 2891 014277 2892 014301 2895 014304 2901 014305 2905 014306 2911 014307 2915 014327 2918 014337 2919 014341 2920 014342 2923 014345 2924 014350 2927 014361 2928 014363 2929 014366 2931 014400 2934 014402 2935 014410 2938 014411 2940 014422 2941 014424 2942 014426 2944 014431 2945 014444 2950 014450 2952 014455 2956 014456 2962 014457 2964 014460 2965 014466 2970 014470 2972 014472 2975 014502 2976 014506 2979 014507 2983 014510 2986 014514 2987 014516 2989 014535 2992 014536 2993 014540 2994 014547 2996 014560 2997 014562 2998 014567 3000 014571 3001 014573 3002 014575 3007 014603 3009 014611 3012 014620 3015 014635 3017 014643 3018 014645 3021 014650 3023 014674 3025 014700 3027 014703 3028 014715 3031 014717 3032 014720 3034 014724 3037 014725 3039 014726 3042 014730 3047 014736 3051 014737 3053 014740 3057 014744 3061 014745 3066 014746 3068 014750 3070 014751 3072 014757 3073 014761 3076 014762 3078 014770 3079 014771 3083 014775 3086 015003 3087 015005 3090 015006 3091 015014 3092 015016 3093 015020 3094 015022 3096 015023 3097 015024 3099 015032 3100 015034 3102 015035 3103 015036 3104 015042 3106 015052 3108 015053 3111 015055 3115 015056 3117 015057 3119 015113 3121 015114 3123 015120 3124 015124 3125 015136 3129 015151 3133 015152 3134 015154 3135 015155 3136 015156 3139 015171 3141 015202 3147 015203 3152 015225 3154 015237 3158 015240 3165 015242 3169 015256 3171 015267 3173 015272 3176 015306 3177 015316 3182 015327 3186 015330 3192 015332 3195 015334 3196 015336 3197 015340 3200 015341 3208 015342 3210 015350 3211 015352 3214 015353 3215 015356 3217 015372 3219 015373 3221 015401 3223 015402 3226 015412 3228 015421 3229 015426 3232 015427 3234 015432 3235 015436 3236 015447 3238 015453 3242 015454 3249 015456 3250 015460 3251 015462 3254 015463 3255 015465 3256 015476 3258 015477 3259 015504 3260 015506 3261 015511 3265 015512 3268 015514 3269 015516 3272 015521 3277 015522 3285 015524 3286 015542 3288 015553 3292 015554 3296 015555 3298 015560 3299 015562 3301 015606 3302 015607 3303 015627 3305 015630 3308 015650 3311 015672 3312 015701 3314 015732 3316 015734 3320 015735 3322 015736 3324 015773 3328 015774 3338 015776 3343 016005 3344 016006 3346 016043 3350 016045 3354 016051 3355 016052 3356 016062 3358 016063 3362 016073 3366 016107 3370 016110 3376 016112 3378 016113 3380 016124 3384 016133 3385 016135 3386 016137 3387 016140 3388 016151 3390 016152 3392 016163 3395 016164 3399 016200 3400 016201 3405 016212 3409 016213 3416 016214 3418 016220 3419 016225 3421 016233 3422 016240 3428 016242 3431 016250 3433 016254 3437 016255 3445 016257 3447 016272 3449 016276 3451 016306 3454 016310 3456 016312 3459 016315 3460 016317 3462 016322 3463 016323 3465 016331 3469 016332 3470 016335 3472 016343 3474 016362 3475 016370 3477 016372 3479 016375 3480 016401 3481 016412 3482 016414 3484 016415 3485 016417 3488 016421 3492 016422 3496 016423 3498 016425 3499 016430 3500 016435 3501 016437 3502 016440 3503 016442 3505 016456 3509 016464 3510 016467 3511 016471 3513 016472 3515 016474 3518 016504 3520 016513 3521 016515 3522 016517 3524 016520 3526 016530 3528 016531 3532 016532 3540 016534 3542 016550 3543 016553 3546 016554 3548 016560 3549 016565 3550 016605 3551 016607 3553 016611 3554 016615 3557 016616 3559 016626 3561 016627 3566 016631 3567 016647 3571 016662 3575 016663 3577 016664 3578 016715 3579 016717 3580 016720 3583 016730 3587 016731 3589 016732 3590 016736 3591 016740 3592 016741 3595 016751 3597 016753 3599 016754 ----------------------------------------------------------- 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