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 1100.0 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: gcu: proc; 12 13 /* 14* * This command copies GCOS card image files, changing their format, 15* * content and medium as specified by the control arguments given. 16* * 17* * USAGE: gcu input_specification output_specification 18* * 19* * The input and output specifications are composed of pathnames and 20* * control arguments. The list of arguments that can be used is very long, 21* * and is documented in the MPM, so it will not be repeated here. 22* * 23* * This procedure only processes the command line. It calls the subroutine 24* * gcos_card_utility_ to do the real work. 25**/ 26 27 /* 28* * WRITTEN BY T. CASEY MAY 1973 29* * MODIFIED BY T. CASEY 30* * SEPTEMBER 1973 31* * OCTOBER 1973 32* * MARCH 1974 33* * AUGUST 1974 34* * NOVEMBER 1974 35* * JULY 1975 36* * MARCH 1976 37* * 38* * MODIFIED BY S. AKERS AUGUST, 1981: 39* * Fix range errors in suffix checking. 40* * Make suffix checking more efficient. 41* * 42* * Add "-canonicalize" "-can" "-ncan" 43* * "-gcos_bcd" "-gcb" control_args. 44* * Change handling of canonicalization, 45* * new default is to NOT do it. Ignore 46* * the "-no" control_arg. 47* * 48* * Changed formfeed to %page; 49* * 50* * Fixed control_arg checker so it 51* * doesn't generate stringrange errors. 52* * Modified: Ron Barstad 82-09-28 Fixed typo error in label err(68) 53* * Modified: Ron Barstad 2.0 83-02-08 Fix nested if in -tape arg processing 54* * Added version in "me", started with 2.0 55* * Modified: Ron Barstad 2.1 83-06-09 Allowed conversion to ascii or gcos_ascii 56* * from BCD media code 0 to be over 80 chars 57* * Modified: Ron Barstad 2.2 83-07-13 Fixed -tape group again, find bad -args >4 chars 58* */ 59 60 /* D E C L A R A T I O N S */ 61 62 /* External Entries */ 63 64 dcl com_err_ ext entry options (variable); 65 dcl cu_$arg_count entry (fixed bin, fixed bin(35)); 66 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); 67 dcl cv_dec_check_ ext entry (char (*), fixed bin(35)) returns (fixed bin); 68 dcl db ext entry; 69 dcl decode_nstd_status_ ext entry (bit (72) aligned, char (*) varying); 70 dcl expand_path_ entry (ptr, fixed bin(21), ptr, ptr, fixed bin(35)); 71 dcl get_system_free_area_ ext entry returns (ptr); 72 dcl gcos_card_utility_ ext entry (ptr, ptr, fixed bin(35)); 73 dcl hcs_$initiate_count ext entry 74 (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin(24), fixed bin(2), ptr, fixed bin(35)); 75 dcl hcs_$terminate_noname ext entry (ptr, fixed bin(35)); 76 dcl (ioa_, ioa_$nnl) ext entry options (variable); 77 dcl ios_$attach ext entry 78 (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); 79 dcl ios_$detach ext entry 80 (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); 81 82 dcl ( 83 error_table_$badopt 84 , error_table_$inconsistent 85 , error_table_$ioname_not_found 86 , error_table_$noarg 87 ) ext fixed bin(35); 88 89 /* Builtin */ 90 91 dcl (addr, baseno, divide, length, 92 max, null, substr, index, reverse, rtrim, unspec) builtin; 93 94 dcl cleanup condition; 95 96 /* For argument processing */ 97 98 dcl ap ptr; 99 dcl al fixed bin(21); 100 dcl arg char (al) based (ap); 101 dcl (nargs, argno) fixed bin; 102 103 dcl (i, j, k, l, m, n) fixed bin(24); 104 dcl (starting_line_no, ending_line_no, no_of_lines) fixed bin(24)init (0); 105 106 dcl status bit (72) aligned; 107 dcl code fixed bin(35) aligned based (addr (status)); 108 dcl numeric_arg fixed bin(24); 109 dcl tab_index fixed bin(24)init (0); 110 111 dcl expected_arg fixed bin(24)init (0); 112 113 /* For program readability, we assign names to the numeric values 114* that the multi-valued switch - expected_arg - can have */ 115 116 dcl ( /* names in alphabetic order */ 117 first_line init (31) 118 , last_line init (32) 119 , line_count init (33) 120 , list init (34) 121 , list_file init (35) 122 , tabs init (36) 123 , tape_id init (37) 124 , tape_label init (38) 125 ) fixed bin(24)int static; 126 127 dcl ( /* switches init off */ 128 io_spec_given (2), /* on when input or output spec is completed */ 129 io_source_given (2), /* on after a tape or file name has been given */ 130 list_finished (2) /* on when a list has been given - only one is allowed */ 131 ) bit (1) aligned init ((2) (1) "0"b); 132 133 dcl ( 134 fixed_in_db 135 , list_started /* on while reading list elements from arg list */ 136 , verify_suffix /* on if we must check for consistent suffixes 137* in a list of pathnames */ 138 , detach_tapes /* on if only detaching tapes left attached 139* from previous use of this command */ 140 , normal_termination /* distinguish cleanup condition from normal termination */ 141 ) bit (1) aligned init ("0"b); 142 143 dcl me char (23) aligned int static options (constant) init ("gcos_card_utility (2.2)"); 144 145 dcl dirname char (168) aligned; 146 dcl ename char (32) aligned; 147 dcl bitcount fixed bin(24); 148 dcl segptr ptr init (null); 149 dcl seglen fixed bin(24); 150 dcl seg_olay char (seglen) based (segptr); 151 152 dcl rw char (1) aligned; /* "r" or " " (rw) for tape attachments */ 153 154 dcl newline char (1) unaligned int static init (" 155 "); 156 157 dcl word_string_len fixed bin(24)init (1); 158 dcl word_string (word_string_len) bit (36) aligned based; 159 dcl (numeric, control) bit (1) init ("0"b); 160 161 dcl free_ptr ptr based (free_ptr_ptr); /* used in cleanup_proc to free allocated storage */ 162 dcl free_ptr_ptr ptr; /* this is NOT a typing error */ 163 164 dcl system_free_ptr ptr init (get_system_free_area_ ()); 165 dcl system_free_area area based (system_free_ptr); 166 167 /* For calling gcos_card_utility_ */ 168 169 dcl 1 input_structure_area like input automatic; /* place to put input structure */ 170 dcl 1 output_structure_area like output automatic; /* place to put output structure */ 171 172 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 */ 173 174 175 /* P R O C E D U R E */ 176 177 call cu_$arg_count (nargs,code); 178 if nargs = 0 then do; 179 code = error_table_$noarg; 180 call com_err_ (code, me, 181 "^/Usage: gcu input_specification output_specification"); 182 return; 183 end; 184 185 /* Initialize */ 186 187 input_ptr = addr (input_structure_area); 188 output_ptr = addr (output_structure_area); 189 unspec (input) = ""b; /* zero out the structures */ 190 unspec (output) = ""b; /* to avoid problems with garbage */ 191 192 input.list_ptr, input.tape_ptr = null; /* don't want zeros there, though */ 193 output.list_ptr, output.tape_ptr = null; 194 input.sw = input_code; 195 output.sw = output_code; 196 197 input.com_err = "1"b; /* tell gcos_card_utility_ subroutine to 198* call com_err_ if any errors occur */ 199 200 io_ptr = input_ptr; /* start with input spec unless user says -output */ 201 input.no_canon = "1"b; /* Default is no canonicalization */ 202 203 on condition (cleanup) call cleanup_proc; 204 205 206 arg_loop: do argno = 1 to nargs; 207 208 call cu_$arg_ptr (argno, ap, al, code); 209 if code ^= 0 then call arg_error (2); 210 211 numeric_arg = cv_dec_check_ (arg, code); /* see if it's a numeric arg */ 212 if code = 0 then numeric = "1"b; 213 else numeric = "0"b; 214 code = 0; /* to avoid confusion if errors later */ 215 216 if substr (arg, 1, 1) = "-" then control = "1"b; /* see if it's a control arg */ 217 else control = "0"b; 218 219 if expected_arg ^= 0 then /* if we are expecting anything specific */ 220 interpret_expected_arg: do; 221 222 /* In alphabetic order by name */ 223 224 if expected_arg = first_line then do; 225 if ^numeric then call arg_error (3); /* numeric arg missing */ 226 starting_line_no = numeric_arg; 227 expected_arg = 0; 228 end; 229 230 else if expected_arg = last_line then do; 231 if ^numeric then call arg_error (4); /* expected numeric arg missing */ 232 ending_line_no = numeric_arg; 233 expected_arg = 0; 234 end; 235 236 else if expected_arg = line_count then do; 237 if ^numeric then call arg_error (5); /* numeric arg missing */ 238 no_of_lines = numeric_arg; 239 expected_arg = 0; 240 end; 241 242 else if expected_arg = list then do; 243 if list_started then do; /* if not first time */ 244 if control then do; /* control arg signals end of list */ 245 expected_arg = 0; /* back to looking for ctl args */ 246 list_finished (io.sw) = "1"b; /* remember that list was read */ 247 goto interpret_control_arg; /* go process this arg */ 248 end; 249 250 if al > io.list_name_size then call arg_error (6); /* name too long */ 251 io.list_count = io.list_count + 1; /* bump count */ 252 253 if io.set = multiple_files /* if pathname */ 254 then do; 255 io_list (io.list_count).names = get_io_pathname (arg); 256 call check_suffix (arg); 257 end; 258 else io_list (io.list_count).names = arg; /* else snumb or edit name */ 259 260 end; 261 262 else do; /* first argument in list - it could be the first name, 263* or one of -all, -name, or -file_input */ 264 if control then do; 265 if arg = "-fi" | arg = "-file" | arg = "-file_input" then 266 expected_arg = list_file; /* next arg will be pathname */ 267 else if arg = "-all" then do; 268 if io.sw = output_code then 269 call arg_error (7); /* -all only allowed in input list */ 270 if input.set = multiple_files then 271 call arg_error (8); /* -all only allowed after -gmap ot -library or -imcv */ 272 input.all = "1"b; 273 input.list_count = 99999; /* arbitrary large number */ 274 expected_arg = 0; 275 end; 276 else if arg = "-nm" | arg = "-name" | arg = "-names" then do; 277 if io.sw = input_code then 278 call arg_error (9); /* -name only allowed in output list */ 279 output.name_files = "1"b; 280 output.list_count = 99999; /* arbitrary large number */ 281 expected_arg = 0; 282 end; 283 else call arg_error (10); /* expected arg missing */ 284 end; 285 286 else do; /* allocate and initialize list */ 287 if al > io.list_name_size then call arg_error (11); /* name too long */ 288 list_started = "1"b; 289 io.list_count = nargs - argno + 1; /* max list length is rest of args */ 290 allocate io_list in (system_free_area) set (io.list_ptr); 291 unspec (io_list) = ""b; /* clear it */ 292 io.list_count = 1; 293 io_list (1).names = arg; /* save first item in list */ 294 end; /* end alloc and init list */ 295 end; /* end first time */ 296 end; /* end expecting list item */ 297 298 else if expected_arg = list_file then do; 299 300 expected_arg = 0; /* turn off the expected switch */ 301 302 call expand_path_ (addr (arg), al, addr (dirname), addr (ename), code); 303 if code ^= 0 then call arg_error (12); /* from a file system call */ 304 call hcs_$initiate_count (dirname, ename, "", bitcount, 0, segptr, code); 305 if segptr = null then call arg_error (13); /* from a file system call */ 306 code = 0; /* clear possble error_table_$segknown, 307* to avoid confusion if a real error occurs later */ 308 309 seglen = divide (bitcount, 9, 17, 0); 310 k = 0; /* counter for newlines */ 311 n = 1; /* start with first char */ 312 l = seglen; /* have whole seg left to search */ 313 314 do while (l > 0); /* search whole seg */ 315 m = index (substr (seg_olay, n, l), newline); /* for newlines */ 316 if m ^= 0 then do; /* if we found one */ 317 if m > 1 then /* don't blow up on blank lines */ 318 k = k + 1; /* count newlines (actually counting names) */ 319 if m > io.list_name_size + 1 then call arg_error (14); /* name too long */ 320 l = l - m; /* shorten string yet to be searched */ 321 n = n + m; /* move past this newline */ 322 end; 323 else l = 0; /* no newline at end - but end of segment anyway */ 324 end; /* end of name counting loop */ 325 326 io.list_count = k; /* actual length of list */ 327 allocate io_list in (system_free_area) set (io.list_ptr); /* allocate storage for list */ 328 unspec (io_list) = ""b; /* clear it */ 329 330 l = seglen; /* re init length of string to be processed */ 331 n = 1; /* and starting char of the string */ 332 do k = 1 to io.list_count; /* copy names from seg to structure */ 333 indx: m = index (substr (seg_olay, n, l), newline); 334 if m > 1 then do; /* check for blank lines */ 335 if io.set = multiple_files /* if pathname */ 336 then do; 337 io_list (k).names = get_io_pathname (substr (seg_olay, n, m-1)); 338 call check_suffix (substr (seg_olay, n, m-1)); 339 end; 340 else /* else must be snumb or edit name */ 341 io_list (k).names = substr (seg_olay, n, m-1); /* name, less the newline */ 342 end; 343 n = n + m; /* move past name */ 344 l = l - m; /* shorten the string */ 345 if m = 1 then goto indx; /* dont increment k if it was a blank line */ 346 end; 347 list_finished (io.sw) = "1"b; /* remember that we already have the list */ 348 call hcs_$terminate_noname (segptr, code); 349 if code ^= 0 then 350 call arg_error (67); /* OUT OF ORDER - ADDED LATER */ 351 end; /* end of expecting list file do group */ 352 353 else if expected_arg = tabs then do; 354 355 if ^numeric then do; /* can't be a tabstop if not numeric */ 356 if tab_index = 0 then 357 call arg_error (15); /* tabstop arguments missing */ 358 else do; /* end of tabstop list is signified by any non numeric arg */ 359 expected_arg = 0; 360 if control then 361 goto interpret_control_arg; 362 else goto interpret_path; 363 end; 364 end; /* end of non numeric do group */ 365 366 else do; /* it was numeric - see if it is a legal tabstop */ 367 if numeric_arg < 2 368 | numeric_arg > 80 then 369 call arg_error (16); /* tabstop can't be before col 2 or past col 80 */ 370 if tab_index > 0 then /* if not first tabstop */ 371 if numeric_arg ^> input.tabstops (tab_index) then /* it must be > previous one */ 372 call arg_error (17); /* tabstops not in increasing numeric order */ 373 374 tab_index = tab_index + 1; 375 if tab_index > 10 then 376 call arg_error (18); /* only 10 tabstops allowed */ 377 input.tabstops (tab_index) = numeric_arg; 378 end; /* end of numeric arg do group */ 379 end; /* end of expecting tabstops do group */ 380 381 else if expected_arg = tape_id then do; 382 if al > 32 then call arg_error (19); /* tape id too long */ 383 io_tape.id = arg; 384 if control then 385 if arg = "-att" | arg = "-attached" then 386 io_tape.attached = "1"b; 387 expected_arg = 0; 388 end; 389 390 else if expected_arg = tape_label then do; 391 expected_arg = 0; 392 if numeric then /* check for easiest case first */ 393 io_tape.position = numeric_arg; 394 else do; /* check for label or n,label or label,n */ 395 i = index (arg, ","); /* look for comma */ 396 if i = 0 then do; /* no comma - all label */ 397 m = 1; /* set up substr parameters to pick up whole arg */ 398 n = al; 399 goto check_label; /* and go see if its an ok label */ 400 end; 401 /* set up substring parameters */ 402 k = 1;l = i-1; /* part before comma */ 403 m = i+1;n = al-i; /* part after comma */ 404 j = index (substr (arg, m, n), ","); /* look for extra comma */ 405 if j ^= 0 then 406 call arg_error (20); /* bad tape label format - 2 commas */ 407 cv_dec_label: j = cv_dec_check_ (substr (arg, k, l), code); 408 if code ^= 0 then do; 409 code = 0; /* not an error_table_ code - clear it */ 410 if m = 1 then /* if we already switched */ 411 call arg_error (21); /* bad tape label format - comma but no numeric field */ 412 else do; /* switch fields */ 413 k = m;l = n; /* maybe the second part is numeric */ 414 m = 1;n = i-1; /* and the first is the label */ 415 goto cv_dec_label; /* go try to convert it */ 416 end; /* end switch fields */ 417 end; /* end code = 0 */ 418 io_tape.position = j; /* save position */ 419 check_label: if n > 12 then 420 call arg_error (22); /* bad tape label format - label > 12 chars */ 421 io_tape.label = substr (arg, m, n); 422 end; /* end of check for label or n,label do group */ 423 end; /* end of expecting label do group */ 424 425 426 else /* expected arg has bad value */ 427 call arg_error (-1); /* -1 means "program bug" */ 428 429 end interpret_expected_arg; 430 431 432 else if control then /* not expecting anything */ 433 interpret_control_arg: do; /* if control arg, see what it is */ 434 435 /* In alphabetic order by the long spelling of the argument */ 436 437 /* -all only allowed in a list; checked for after all legal args, below */ 438 439 if arg = "-app" | arg = "-append" then do; 440 if io.sw = input_code then call arg_error (23); /* -append legal only for output */ 441 output.append = "1"b; 442 end; 443 444 else if arg = "-aci" | arg = "-ascii" then do; 445 if io.format ^= 0 then 446 if io.format ^= ascii then 447 call arg_error (24); /* inconsistent format spec */ 448 io.format = ascii; 449 if io.medium ^= 0 then /* DON'T THINK THIS CAN EVER HAPPEN - */ 450 if io.medium ^= file then /* BUT LET'S BE SAFE */ 451 call arg_error (25); /* inconsistent medium spec */ 452 io.medium = file; 453 end; 454 455 else if arg = "-att" | arg = "-attached" then do; 456 if io.medium ^= tape then 457 call arg_error (50); /* OUT OF ORDER - MESSAGE CHANGED */ 458 io_tape.attached = "1"b; 459 end; 460 461 else if arg = "-bf" | arg = "-brief" then 462 io.brief = "1"b; 463 464 else if arg = "-cdk" | arg = "-comdk" then do; 465 io.comdk = "1"b; 466 if io.format ^= 0 then 467 if io.format ^= gcos then 468 call arg_error (26); /* inconsistent format spec */ 469 io.format = gcos; 470 end; 471 472 else if arg = "-ct" | arg = "-count" then do; 473 if io.sw = output_code then call arg_error (27); /* not allowed for output */ 474 if no_of_lines ^= 0 | ending_line_no ^= 0 then /* if that info already given */ 475 call arg_error (28); /* inconsistent args */ 476 expected_arg = line_count; 477 end; 478 479 else if arg = "-db" | arg = "-debug" then 480 input.debug = "1"b; 481 482 else if arg = "-det" | arg = "-detach" then do; 483 if argno = nargs then /* check for special case */ 484 if argno = 1 /* -detach the only argument */ 485 | (argno = 2 & input.debug) then /* or just preceeded by -debug */ 486 detach_tapes = "1"b; /* if so detach tapes and quit */ 487 detach_tape: 488 call ios_$detach (tape_stream (io.sw), "", "", status); 489 if code ^= 0 then 490 if code ^= error_table_$ioname_not_found then 491 call arg_error (29); /* error detaching tape */ 492 if detach_tapes then do; /* if detaching both tapes */ 493 if io.sw = input_code then do; 494 io_ptr = output_ptr; 495 goto detach_tape; 496 end; 497 else return; /* all done - just called to detach tapes */ 498 end; /* end of just detaching do group */ 499 end; /* end of -detach do group */ 500 501 /* -file_input only allowed in a list; checked for after all legal args, below */ 502 503 else if arg = "-ft" | arg = "-first" then do; 504 if io.sw = output_code then call arg_error (30); /* not legal for output */ 505 if starting_line_no ^= 0 then call arg_error (31); 506 expected_arg = first_line; 507 end; 508 509 else if arg = "-gc" | arg = "-gcos" then do; 510 gcos_arg: if io.format ^= 0 then 511 if io.format ^= gcos then 512 call arg_error (32); /* inconsistent format spec */ 513 io.format = gcos; 514 end; 515 516 else if arg = "-gca" | arg = "-gcos_ascii" then do; 517 if io.sw = input_code then call arg_error (72); /* OUT OF ORDER - ADDED LATER */ 518 output.gcos_ascii = "1"b; 519 goto gcos_arg; 520 end; 521 522 else if arg = "-gcb" | arg = "-gcos_bcd" then do; 523 if io.sw = input_code then call arg_error (72); /* OUT OF ORDER - ADDED LATER */ 524 output.gcos_bcd = "1"b; 525 goto gcos_arg; 526 end; 527 528 else if arg = "-gmap" | arg = "-lib" | arg = "-library" then do; 529 input.set = library; 530 input.list_name_size = 4; /* library edit names are 4 chars */ 531 set_up_for_list: /* come here from -imcv to finish setting up for list */ 532 if io.sw = output_code then call arg_error (33); 533 if list_finished (io.sw) then call arg_error (34); /* already given */ 534 expected_arg = list; 535 list_started = "0"b; /* we want to special-case the first list element */ 536 end; 537 538 else if arg = "-imcv" then do; 539 input.set = imcv; 540 input.list_name_size = 5; /* snumbs are 5 chars max */ 541 goto set_up_for_list; /* go share code with -library */ 542 end; 543 544 else if arg = "-in" | arg = "-input" then do; 545 if argno > 1 then /* except for first argument, when io.sw is 546* initialized to the default (input_code) */ 547 if argno ^= 2 | ^input.debug then /* (or if first arg was -db and this is the 2nd) */ 548 io_spec_given (io.sw) = "1"b; /* remember that input or output (io.sw says which) 549* specs have already been given */ 550 if io_spec_given (input_code) then /* if input specs have already been given */ 551 call arg_error (35); /* do not allow them to be given again */ 552 io_ptr = input_ptr; /* switch to processing the input specification */ 553 end; 554 555 else if arg = "-lbl" | arg = "-label" then do; 556 if io.medium ^= tape then 557 call arg_error (36); /* -tape must preceed -retain or -label */ 558 expected_arg = tape_label; 559 end; 560 561 /* -library is a generalization of -gmap, and is processed above, with -gmap */ 562 563 else if arg = "-lt" | arg = "-last" then do; 564 if io.sw = output_code then call arg_error (37); /* not allowed for output */ 565 if no_of_lines ^= 0 | ending_line_no ^= 0 then /* if that info already given */ 566 call arg_error (38); /* inconsistent args */ 567 expected_arg = last_line; 568 end; 569 570 else if arg = "-ls" | arg = "-list" then do; 571 if io_source_given (io.sw) then 572 call arg_error (39); /* can't say -list if -tape or pathname already given */ 573 io_source_given (io.sw) = "1"b; 574 if list_finished (io.sw) then 575 call arg_error (40); /* only one list allowed */ 576 list_started = "0"b; /* so we can special case the first list item */ 577 expected_arg = list; 578 io.list_name_size = 168; /* max length of pathname */ 579 io.set = multiple_files; 580 if io.medium ^= raw then 581 io.medium = file; 582 if io.format ^= 0 then /* if format already given */ 583 verify_suffix = "0"b; /* ignore suffixes */ 584 else verify_suffix = "1"b; /* otherwise first suffix determines format, 585* and the rest must be consistent with it */ 586 end; 587 588 else if arg = "-lg" | arg = "-long" then 589 io.long = "1"b; 590 591 else if arg = "-no" | arg = "-no_canonicalize" 592 | arg = "-ncan" 593 then do; 594 if io.sw = output_code then call arg_error (41); /* legal only for input */ 595 input.no_canon = "1"b; 596 end; 597 598 else if arg = "-can" | arg = "-canonicalize" 599 then do; 600 if io.sw = output_code then call arg_error (41); /* legal only for input */ 601 input.no_canon = "0"b; 602 end; 603 604 /* -name only allowed in a list; checked for after all legal args, below */ 605 606 else if arg = "-out" | arg = "-output" then do; 607 if argno > 1 then 608 if argno ^= 2 | ^input.debug then 609 io_spec_given (io.sw) = "1"b; /* same logic as for input */ 610 if io_spec_given (output_code) then call arg_error (42); 611 io_ptr = output_ptr; /* switch to processing output specification */ 612 end; 613 614 else if arg = "-raw" then do; 615 if io.medium = tape then 616 call arg_error (43); /* inconsistent medium spec */ 617 io.medium = raw; 618 if io.format ^= 0 then 619 if io.format ^= gcos then 620 call arg_error (44); /* inconsistent format spec */ 621 io.format = gcos; 622 end; 623 624 else if arg = "-ret" | arg = "-retain" then do; 625 if io.medium ^= tape then 626 call arg_error (45); /* -tape must preceed -retain or -label */ 627 io_tape.retain = "1"b; 628 end; 629 630 else if arg = "-tabs" then do; 631 if io.sw = output_code then 632 call arg_error (66); /* OUT OF ORDER - ADDED LATER */ 633 if input.tabs_given then 634 call arg_error (46); /* can't give tabs twice */ 635 input.tabs_given = "1"b; 636 expected_arg = tabs; 637 end; 638 639 else if (arg = "-tape") | (arg = "-tape7") | (arg = "-tape9") then do; 640 if io_source_given (io.sw) then 641 call arg_error (47); /* can't say -tape after giving file name */ 642 io_source_given (io.sw) = "1"b; 643 if io.medium ^= 0 then /* possible -raw -tape */ 644 call arg_error (69); /* OUT OF ORDER - ADDED LATER */ 645 io.medium = tape; 646 if io.format ^= 0 then 647 if io.format ^= gcos then 648 call arg_error (48); /* inconsistent format spec */ 649 io.format = gcos; /* can only be gcos files on tape */ 650 allocate io_tape in (system_free_area) set (io.tape_ptr); 651 unspec (io_tape) = ""b; /* clear it */ 652 io_tape.label = ""; /* want blanks (not zeros) in label field */ 653 if al > 5 then do; /* see if a 7 or 9 on the end */ 654 io_tape.tracks = substr (arg, 6, 1); 655 if (io_tape.tracks ^= "7" 656 & io_tape.tracks ^= "9") 657 |al ^= 6 658 then call arg_error (49); 659 end; 660 else io_tape.tracks = " "; 661 expected_arg = tape_id; 662 end; /* end of -tape do group */ 663 664 else if arg = "-tc" | arg = "-tnc" | arg = "-truncate" then 665 io.truncate_ascii = "1"b; 666 667 668 /* The following control arguments are only allowed in place of some expected 669* argument, and their occurrence out of context is an error */ 670 671 else if arg = "-fi" | arg = "-file" | arg = "-file_input" 672 | arg = "-all" | arg = "-nm" | arg = "-name" then 673 call arg_error (51); /* only allowed in place of a list */ 674 675 else /* bad control arg */ 676 call arg_error (52); 677 678 end interpret_control_arg; 679 680 681 /* interpret non-control arg - i.e. pathname not preceeded by ctl arg */ 682 683 else 684 interpret_path: do; 685 686 check_if_given: if io_source_given (io.sw) then /* if a pathname or tape number was already given */ 687 switch_io: do; /* for the current spec, switch to the other one */ 688 /* if -in and -out not given, the default is -in, then -out, with 689* the switch being made when the second pathname is found */ 690 if io.sw = input_code then 691 io_ptr = output_ptr; 692 else call arg_error (53); 693 goto check_if_given; /* in case both have been given */ 694 end switch_io; 695 696 io.set = single_file; 697 if io.medium ^= raw then /* unless -raw preceeded this */ 698 io.medium = file; 699 io_source_given (io.sw) = "1"b; 700 701 io.file_name = get_io_pathname (arg); /* expand the pathname */ 702 call check_suffix (arg); /* validate the suffix, if there is one */ 703 704 end interpret_path; 705 706 end arg_loop; 707 708 /* Check input and output specification for completeness and consistency */ 709 710 if expected_arg ^= 0 then do; /* still expecting an argument? */ 711 if list_started then /* were we in a list, with first item already given? */ 712 list_finished (io.sw) = "1"b; /* it's ok for arg list to end in a list */ 713 else if expected_arg ^= tabs then /* also ok to end with list of tabstops */ 714 call arg_error (54); /* expected arg missing after last arg on line */ 715 end; 716 717 /* check io stuff */ 718 do io_ptr = input_ptr, output_ptr; 719 720 if io.format = 0 then 721 io.format = ascii; /* the default */ 722 723 if io.set = 0 then 724 io.set = single_file; /* if no list was given, this is still zero */ 725 726 if ^io_source_given (io.sw) then 727 call arg_error (55); /* io spec incomplete - must give tape or file name */ 728 729 if io.format ^= ascii then 730 if io.truncate_ascii then 731 call arg_error (56); /* -truncate only allowed for ascii */ 732 733 /* check input-only stuff */ 734 735 if io.sw = input_code 736 then do; 737 738 input.first_line = starting_line_no; /* will be zero if -ft not given */ 739 if no_of_lines ^= 0 /* if -ct given */ 740 then input.last_line = max (input.first_line, 1) + no_of_lines -1; /* then compute last line no */ 741 else input.last_line = ending_line_no; /* will be zero if -lt not given */ 742 743 end; 744 745 /* check output-only stuff */ 746 if io.sw = output_code 747 then do; 748 if output.append 749 then if output.medium = tape 750 then call arg_error (58); /* can not append to a tape file */ 751 if output.name_files 752 then if input.set ^= library 753 then if input.set ^= imcv 754 then call arg_error (70); /* OUT OF ORDER - ADDED LATER */ 755 end; 756 end; 757 758 /* Check for tape to disk copy, to avoid deblocking if possible */ 759 760 do io_ptr = input_ptr, output_ptr; 761 if io.format ^= gcos then goto not_blocks; 762 if io.comdk then goto not_blocks; 763 if io.medium = raw then goto not_blocks; 764 if io.set ^= single_file then goto not_blocks; 765 end; 766 if output.append then goto not_blocks; 767 if output.gcos_ascii then goto not_blocks; 768 if output.gcos_bcd then goto not_blocks; 769 if input.first_line ^= 0 then goto not_blocks; 770 if input.last_line ^= 0 then goto not_blocks; 771 772 input.format, output.format = blocks; /* We can copy without deblocking */ 773 774 not_blocks: 775 776 777 /* Attach tapes here to minimize mounting and dismounting */ 778 779 do io_ptr = input_ptr, output_ptr; 780 if io.sw = input_code then 781 rw = "r"; /* attach input tape in read-only mode */ 782 else rw = " "; /* equivalent to "rw" for ios_$attach */ 783 if io.medium = tape then 784 if ^io_tape.attached then do; 785 786 /* ***** NOTE ***** 787* The method of specifying tracks and density is undergoing some changes 788* (July 1975). The validity of this code must be reviewed periodically. */ 789 if io_tape.tracks ^= " " then do; /* if tracks given by -tape7 or -tape9 */ 790 i = index (io_tape.id, " "); /* find end of tape name and append ",Ntrack" */ 791 if substr (io_tape.id, i-5, 5) ^= "track" then /* but make sure it's not there already */ 792 if i <= 26 then /* and there's room to put it there */ 793 substr (io_tape.id, i, 7) = "," || io_tape.tracks || "track"; 794 end; 795 io_tape.attached = "1"b; /* for cleanup_proc; turn on BEFORE calling attach */ 796 call ios_$attach (tape_stream (io.sw), "nstd_", io_tape.id, rw, status); 797 if code ^= 0 then 798 call arg_error (59); /* error attaching tape */ 799 end; /* end tape and not attached do group */ 800 end; /* end attach tapes do loop */ 801 802 /* now call subroutine to do the real work */ 803 call gcos_card_utility_ (input_ptr, output_ptr, code); 804 if code ^= 0 then 805 if ^input.com_err then /* if subroutine did not call com_err_ */ 806 call com_err_ (code, me); 807 808 revert cleanup; 809 810 normal_termination = "1"b; /* tell cleanup_proc that this is not cleanup condition */ 811 call cleanup_proc; /* used for cleanup and normal termination */ 812 quit: return; 813 814 /* I N T E R N A L P R O C E D U R E S */ 815 816 817 /* Procedure to format and print error messages */ 818 819 arg_error: proc (error_code); 820 821 dcl error_code fixed bin(24); /* identifies the place where the error occurred. Each call 822* has a different number, even if the message is the same. 823* The first 64 are in order in the program. Those above 64 824* were added later and are out of order. */ 825 826 dcl max_error_code fixed bin(24)init (71); /* next available error_code value is 72 */ 827 828 dcl bad_arg char (168) varying; /* the bad argument or pathname */ 829 dcl (err_msg, msg2) char (200) varying; /* portions of message text */ 830 831 dcl mnames (11:20) char (8) aligned int static init ( 832 "filename", 833 "snumb", 834 "editname", 835 "filename", 836 "ascii", 837 "gcos", 838 "blocks", 839 "raw", 840 "tape", 841 "file"); 842 843 844 bad_arg = arg; /* the bad thing is the current argument */ 845 goto arg_error_common; 846 847 /* Entry called from get_io_pathname - second argument is the bad pathname */ 848 path_error: entry (error_code, err_path); 849 850 dcl err_path char (*); /* might be from a file instead of an argument */ 851 852 bad_arg = err_path; /* argment or file item to be printed */ 853 854 arg_error_common: 855 856 if error_code < 2 | error_code > max_error_code then do; 857 err_msg = "Program bug. ^a"; 858 goto call_com_err; 859 end; 860 861 /* Use error_code as an index into a transfer vector that the compiler 862* will build for us. This is implemented efficiently in the v2pl1 compiler */ 863 864 goto err (error_code); 865 866 /* Since we checked the upper and lower bound of error code above, no problems can arise */ 867 868 err (2): 869 err_msg = "^a From cu_$arg_ptr."; 870 goto call_com_err; 871 872 err (3): err (4): err (5): 873 err_msg = "Numeric, before ^a"; 874 goto et_noarg; /* go set code = error_table_$noarg */ 875 876 err (6): err (11): 877 err_msg = "Name in list is too long: ^a^/Max length of ^a is ^d."; 878 msg2 = mnames (io.set); 879 numeric_arg = io.list_name_size; 880 goto call_com_err; 881 882 err (7): err (27): err (30): err (33): err (37): err (41): err (66): 883 err_msg = "This argument is only allowed in the input specification: ^a"; 884 goto call_com_err; 885 886 err (8): 887 err_msg = "-all only allowed immediately following -gmap, -library, or -imcv"; 888 goto call_com_err; 889 890 err (9): err (23): err (72): 891 err_msg = "This argument is only allowed in the output specification: ^a"; 892 goto call_com_err; 893 894 err (10): 895 err_msg = "list item, before ^a"; 896 goto et_noarg; 897 898 err (12): err (60): 899 err_msg = "From expand_path_ ^a"; 900 goto call_com_err; 901 902 err (13): 903 err_msg = "From hcs_$initiate_count ^a"; 904 goto call_com_err; 905 906 err (14): 907 bad_arg = substr (seg_olay, n, m-1); /* pick up bad name from file */ 908 goto err (6); /* and go set up the "too long" message */ 909 910 err (15): 911 err_msg = "Tabstops, before ^a"; 912 goto et_noarg; 913 914 err (16): 915 err_msg = "Illegal tabstop value: ^a^/Value must be 2 thru 80."; 916 goto call_com_err; 917 918 err (17): 919 err_msg = "Tabstop value out of order: ^a^/Previous value was ^s^d"; 920 numeric_arg = input.tabstops (tab_index); 921 goto call_com_err; 922 923 err (18): 924 err_msg = "Only 10 tabstops allowed: ^a is the 11th."; 925 goto call_com_err; 926 927 err (19): 928 err_msg = "Tape number too long: ^a^/Max length is 32 characters."; 929 goto call_com_err; 930 931 err (20): 932 err_msg = "Bad tape label format - 2 commas: ^a"; 933 goto call_com_err; 934 935 err (21): 936 err_msg = "Bad tape label format - comma but no numeric field: ^a"; 937 goto call_com_err; 938 939 err (22): 940 err_msg = "Bad tape label format - file name too long: ^a^/Max length is 12 characters."; 941 bad_arg = substr (bad_arg, m, n); 942 goto call_com_err; 943 944 err (24): err (26): err (32): err (44): err (48): err (61): err (62): err (63): err (64): 945 msg2 = mnames (io.format); 946 goto inconsistent_message; /* go set err_msg and error_table_$inconsistent */ 947 948 err (25): err (43): err (69): 949 msg2 = mnames (io.medium); 950 goto inconsistent_message; 951 952 err (28): err (31): err (38): 953 err_msg = "^a and the previously specified -first, -last, or -count."; 954 goto et_inconsistent; 955 956 err (29): 957 err_msg = "From ios_$detach the previously retained tape."; 958 goto tape_message; /* check for and decode tape hardware status */ 959 960 err (34): err (40): 961 err_msg = "Only one list is allowed in the input or output specification: ^a"; 962 goto call_com_err; 963 964 err (35): 965 msg2 = "the input specification"; 966 goto given_message; 967 968 err (36): err (45): 969 err_msg = "-tape must preceed ^a"; 970 goto call_com_err; 971 972 err (39): err (47): 973 msg2 = "a pathname or tape number"; 974 goto given_message; 975 976 err (42): err (53): 977 msg2 = "the output specification"; 978 goto given_message; 979 980 err (46): 981 msg2 = "a set of tabstops"; 982 goto given_message; 983 984 err (49): 985 err_msg = "Illegal form of -tape argument: ^a"; 986 goto call_com_err; 987 988 err (50): 989 err_msg = "^a only allowed after -tape, in place of, or in addition to, tape number"; 990 goto call_com_err; 991 992 err (51): 993 err_msg = "^a only allowed in place of a list."; 994 goto call_com_err; 995 996 err (52): 997 code = error_table_$badopt; 998 err_msg = "^a"; 999 goto call_com_err; 1000 1001 err (54): 1002 err_msg = "After ^a"; 1003 goto et_noarg; 1004 1005 err (55): 1006 err_msg = "^a pathname or tape number"; 1007 bad_arg = io_names (io.sw); 1008 goto et_noarg; 1009 1010 err (56): 1011 err_msg = "-truncate only allowed for an ASCII file"; 1012 goto call_com_err; 1013 1014 err (57): 1015 err_msg = "-no_canonicalize only allowed for an ASCII file."; 1016 goto call_com_err; 1017 1018 err (58): 1019 err_msg = "-append is not allowed for a tape output file."; 1020 goto call_com_err; 1021 1022 err (59): 1023 err_msg = "from ios_$attach ^a"; 1024 goto tape_id_message; 1025 1026 err (65): 1027 err_msg = "From ios_$detach ^a"; 1028 goto tape_id_message; 1029 1030 err (67): err (68): 1031 err_msg = "From hcs_$terminate_noname ^a"; 1032 goto call_com_err; 1033 1034 err (70): 1035 err_msg = "-name only allowed when input is gmap, library, or imcv."; 1036 goto call_com_err; 1037 1038 /* Set up error codes and messages common to several of the above */ 1039 1040 et_noarg: 1041 code = error_table_$noarg; 1042 goto call_com_err; 1043 1044 inconsistent_message: 1045 err_msg = "^/^a and ^a (previously specified or implied)."; 1046 et_inconsistent: 1047 code = error_table_$inconsistent; 1048 goto call_com_err; 1049 1050 given_message: 1051 err_msg = "^a is an error because ^a was previously given."; 1052 goto call_com_err; 1053 1054 tape_id_message: 1055 bad_arg = io_tape.id; 1056 tape_message: 1057 if substr (status, 1, 1) then do; /* hardware status */ 1058 msg2 = bad_arg; /* save the tape id */ 1059 call decode_nstd_status_ (status, bad_arg); 1060 err_msg = "^a^/" || err_msg; /* print decoded status before rest of message */ 1061 end; 1062 goto call_com_err; 1063 1064 call_com_err: call com_err_ (code, me, err_msg, bad_arg, msg2, numeric_arg); 1065 1066 if argno <= nargs then /* if not past end of arglist */ 1067 call ioa_$nnl ("Argument number ^d. ", argno); 1068 if nargs > 0 then 1069 call ioa_ ("^a specification.", io_names (io.sw)); 1070 1071 1072 if input.debug then do; 1073 call ioa_ ("arg error number ^d", error_code); 1074 call ioa_ ("CALLING DB"); 1075 call db; 1076 end; 1077 1078 if ^fixed_in_db then do; 1079 normal_termination = ^normal_termination; /* by flipping the switch instead of turning it on, 1080* we avoid an infinite loop in the case where cleanup_proc 1081* gets an error detaching tape, and if the switch is on, 1082* it calls us back again to print an error message */ 1083 call cleanup_proc; /* detach tapes and free allocated storage */ 1084 goto quit; 1085 end; 1086 1087 fixed_in_db = "0"b; /* turn off switch for next time */ 1088 return; 1089 end arg_error; 1090 1091 1092 check_suffix: proc (given_path); 1093 1094 /* 1095* 1096* This procedure checks the suffix (if any) in the pathname, and 1097* complains to the user if the suffix does not match the control 1098* arguments which were specified. If the suffix is acceptable, it 1099* is used to provide gcos_card_utility_ with the data type contained 1100* in the file. 1101* 1102**/ 1103 1104 dcl given_path char (*) parm; 1105 dcl suffix_string char (32) varying; 1106 1107 call get_suffix (given_path, suffix_string); 1108 if length (suffix_string) ^= 0 /* only if suffix exists */ 1109 then do; 1110 if io.format = 0 /* If format not given, get it from suffix. */ 1111 then do; 1112 1113 if suffix_string = ".ascii" then io.format = ascii; 1114 else if suffix_string = ".gcos" then io.format = gcos; 1115 else if suffix_string = ".raw" 1116 then do; 1117 io.format = gcos; 1118 io.medium = raw; 1119 end; 1120 else if suffix_string = ".comdk" 1121 then do; 1122 io.format = gcos; 1123 io.comdk = "1"b; 1124 end; 1125 1126 if io.medium = 0 then io.medium = file; /* If not raw or tape, then file. */ 1127 1128 end; 1129 1130 else if verify_suffix 1131 then do; /* check for consistent suffixes within a list */ 1132 if suffix_string = ".ascii" 1133 then do; 1134 if io.format ^= ascii 1135 then call path_error (61, given_path); /* inconsistent suffixes */ 1136 end; 1137 else if suffix_string = ".gcos" 1138 then do; 1139 if io.format ^= gcos 1140 then call path_error (62, given_path); /* inconsistent suffixes */ 1141 end; 1142 else if suffix_string = ".raw" 1143 then do; 1144 if io.format ^= gcos | io.medium ^= raw 1145 then call path_error (63, given_path); /* inconsistent suffixes */ 1146 end; 1147 else if suffix_string = ".comdk" 1148 then do; 1149 /* comdk is not inconsistent with gcos - 1150* but if it was not the first suffix given, 1151* then the gcos suffix determines the format */ 1152 if io.format ^= gcos 1153 then call path_error (64, given_path); /* inconsistent suffixes */ 1154 end; 1155 end; /* end of verify suffix do group */ 1156 end; /* end of suffix-checker */ 1157 return; 1158 end check_suffix; 1159 1160 /* Procedure to detach tapes and free allocated storage. 1161* Called on cleanup condition, and also for normal termination. 1162* The switch, normal_termination, tells us which it is. */ 1163 1164 cleanup_proc: proc; 1165 1166 /* Detach tapes (unless user said -retain) */ 1167 1168 do io_ptr = input_ptr, output_ptr; 1169 if io.tape_ptr ^= null then do; /* there is a tape */ 1170 if io_tape.retain then do; /* but user said retain */ 1171 if io_tape.attached then /* if the tape is really attached */ 1172 if ^io.brief then /* and user did not say -brief */ 1173 call com_err_ (0, me, "Tape ^a will remain attached.", io_tape.id); 1174 end; /* end retain */ 1175 else do; /* detach it */ 1176 if io_tape.attached then do; /* only if it is already attached */ 1177 call ios_$detach (tape_stream (io.sw), "", "", status); 1178 if code ^= 0 then do; 1179 if normal_termination then /* avoid infinite loop */ 1180 call arg_error (65); /* OUT OF ORDER - ADDED LATER */ 1181 end; /* end code ^= 0 */ 1182 end; /* end attached */ 1183 end; /* end ^retain */ 1184 end; /* end io.tape_ptr ^= null */ 1185 end; /* end detach tapes do loop */ 1186 1187 1188 /* Free allocated storage */ 1189 do free_ptr_ptr = 1190 addr (input.list_ptr), 1191 addr (input.tape_ptr), 1192 addr (output.list_ptr), 1193 addr (output.tape_ptr); 1194 1195 if free_ptr ^= null then 1196 if baseno (system_free_ptr) = baseno (free_ptr) then /* make sure it is in free area */ 1197 free free_ptr -> word_string; /* can point to any old thing - 1198* only the pointer is passed to the free routine */ 1199 end; 1200 1201 if segptr ^= null then do; 1202 call hcs_$terminate_noname (segptr, code); 1203 if code ^= 0 then 1204 if normal_termination then 1205 call arg_error (68); /* OUT OF ORDER- ADDED LATER */ 1206 end; 1207 1208 end cleanup_proc; 1209 1210 /* Procedure to expand pathname */ 1211 1212 get_io_pathname: proc (given_path) returns (char (168)); 1213 1214 dcl given_path char (*); 1215 dcl expanded_path char (168); 1216 dcl pl fixed bin(21); 1217 1218 pl = length (given_path); 1219 1220 call expand_path_ (addr (given_path), pl, addr (expanded_path), null, code); 1221 if code ^= 0 then 1222 call path_error (60, given_path); 1223 return (expanded_path); 1224 1225 end get_io_pathname; 1226 1227 get_suffix: proc (input_string, return_suffix); 1228 1229 /* 1230* 1231* This procedure returns the suffix of an input_string 1232* (.gcos, .ascii, etc.). If there are more than two 1233* components in an input_string, the last one is returned. 1234* If there is no suffix, the suffix field is returned null. 1235* 1236**/ 1237 1238 dcl input_string char(*) parm; 1239 dcl return_suffix char(*) varying parm; 1240 1241 dcl work_string char(168) varying; 1242 dcl dot_index fixed bin (24); 1243 dcl dot char(1) 1244 internal static 1245 options(constant) 1246 init("."); 1247 1248 work_string = reverse (rtrim (input_string)); 1249 dot_index = index (work_string, dot); 1250 1251 if dot_index ^= 0 1252 1253 then return_suffix = reverse (substr (work_string, 1, dot_index)); 1254 1255 else return_suffix = ""; 1256 1257 return; 1258 1259 end get_suffix; 1260 1261 end gcos_card_utility; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 09/12/83 0913.6 gcos_card_utility.pl1 >special_ldd>on>09/12/83>gcos_card_utility.pl1 173 1 03/27/82 0424.8 gcos_utility_args_.incl.pl1 >ldd>include>gcos_utility_args_.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. addr builtin function dcl 91 ref 177 179 180 187 188 208 209 211 212 214 302 302 302 302 302 302 302 303 304 306 348 349 407 408 409 489 489 797 803 804 804 996 1040 1046 1064 1178 1189 1189 1189 1189 1202 1203 1220 1220 1220 1220 1220 1221 al 000110 automatic fixed bin(21,0) dcl 99 set ref 208* 211 211 216 250 255 255 256 256 258 265 265 265 267 276 276 276 287 293 302 302 302* 382 383 384 384 395 398 403 404 407 407 421 439 439 444 444 455 455 461 461 464 464 472 472 479 479 482 482 503 503 509 509 516 516 522 522 528 528 528 538 544 544 555 555 563 563 570 570 588 588 591 591 591 598 598 606 606 614 624 624 630 639 639 639 653 654 655 664 664 664 671 671 671 671 671 671 701 701 702 702 844 all 73 based bit(1) level 2 dcl 1-13 set ref 272* ap 000106 automatic pointer dcl 98 set ref 208* 211 216 255 256 258 265 265 265 267 276 276 276 293 302 302 383 384 384 395 404 407 407 421 439 439 444 444 455 455 461 461 464 464 472 472 479 479 482 482 503 503 509 509 516 516 522 522 528 528 528 538 544 544 555 555 563 563 570 570 588 588 591 591 591 598 598 606 606 614 624 624 630 639 639 639 654 664 664 664 671 671 671 671 671 671 701 702 844 append 71 based bit(1) level 2 dcl 1-58 set ref 441* 748 766 arg based char unaligned dcl 100 set ref 211* 216 255* 256* 258 265 265 265 267 276 276 276 293 302 302 383 384 384 395 404 407 407 421 439 439 444 444 455 455 461 461 464 464 472 472 479 479 482 482 503 503 509 509 516 516 522 522 528 528 528 538 544 544 555 555 563 563 570 570 588 588 591 591 591 598 598 606 606 614 624 624 630 639 639 639 654 664 664 664 671 671 671 671 671 671 701* 702* 844 argno 000112 automatic fixed bin(17,0) dcl 101 set ref 206* 208* 289 483 483 483 545 545 607 607* 1066 1066* ascii constant fixed bin(17,0) initial dcl 1-97 ref 445 448 720 729 1113 1134 attached 15 based bit(1) level 2 dcl 1-122 set ref 384* 458* 783 795* 1171 1176 bad_arg 000101 automatic varying char(168) dcl 828 set ref 844* 852* 906* 941* 941 1007* 1054* 1058 1059* 1064* baseno builtin function dcl 91 ref 1195 1195 bitcount 000227 automatic fixed bin(24,0) dcl 147 set ref 304* 309 blocks constant fixed bin(17,0) initial dcl 1-97 ref 772 brief 65 based bit(1) level 2 dcl 1-121 set ref 461* 1171 cleanup 000100 stack reference condition dcl 94 ref 203 808 code based fixed bin(35,0) dcl 107 set ref 177* 179* 180* 208* 209 211* 212 214* 302* 303 304* 306* 348* 349 407* 408 409* 489 489 797 803* 804 804* 996* 1040* 1046* 1064* 1178 1202* 1203 1220* 1221 com_err 72 based bit(1) level 2 dcl 1-13 set ref 197* 804 com_err_ 000034 constant entry external dcl 64 ref 180 804 1064 1171 comdk 67 based bit(1) level 2 dcl 1-121 set ref 465* 762 1123* control 000236 automatic bit(1) initial unaligned dcl 159 set ref 159* 216* 217* 244 264 360 384 432 cu_$arg_count 000036 constant entry external dcl 65 ref 177 cu_$arg_ptr 000040 constant entry external dcl 66 ref 208 cv_dec_check_ 000042 constant entry external dcl 67 ref 211 407 db 000044 constant entry external dcl 68 ref 1075 debug 71 based bit(1) level 2 dcl 1-13 set ref 479* 483 545 607 1072 decode_nstd_status_ 000046 constant entry external dcl 69 ref 1059 detach_tapes 000143 automatic bit(1) initial dcl 133 set ref 133* 483* 492 dirname 000145 automatic char(168) dcl 145 set ref 302 302 304* divide builtin function dcl 91 ref 309 dot constant char(1) initial unaligned dcl 1243 ref 1249 dot_index 000173 automatic fixed bin(24,0) dcl 1242 set ref 1249* 1251 1251 ename 000217 automatic char(32) dcl 146 set ref 302 302 304* ending_line_no 000122 automatic fixed bin(24,0) initial dcl 104 set ref 104* 232* 474 565 741 err_msg 000154 automatic varying char(200) dcl 829 set ref 857* 868* 872* 876* 882* 886* 890* 894* 898* 902* 910* 914* 918* 923* 927* 931* 935* 939* 952* 956* 960* 968* 984* 988* 992* 998* 1001* 1005* 1010* 1014* 1018* 1022* 1026* 1030* 1034* 1044* 1050* 1060* 1060 1064* err_path parameter char unaligned dcl 850 ref 848 852 error_code parameter fixed bin(24,0) dcl 821 set ref 819 848 854 854 864 1073* error_table_$badopt 000072 external static fixed bin(35,0) dcl 82 ref 996 error_table_$inconsistent 000074 external static fixed bin(35,0) dcl 82 ref 1046 error_table_$ioname_not_found 000076 external static fixed bin(35,0) dcl 82 ref 489 error_table_$noarg 000100 external static fixed bin(35,0) dcl 82 ref 179 1040 expand_path_ 000050 constant entry external dcl 70 ref 302 1220 expanded_path 000100 automatic char(168) unaligned dcl 1215 set ref 1220 1220 1223 expected_arg 000130 automatic fixed bin(24,0) initial dcl 111 set ref 111* 219 224 227* 230 233* 236 239* 242 245* 265* 274* 281* 298 300* 353 359* 381 387* 390 391* 476* 506* 534* 558* 567* 577* 636* 661* 710 713 file constant fixed bin(17,0) initial dcl 1-97 ref 449 452 580 697 1126 file_name 1 based char(168) level 2 dcl 1-121 set ref 701* first_line constant fixed bin(24,0) initial dcl 116 in procedure "gcu" ref 224 506 first_line 76 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcu" set ref 738* 739 769 fixed_in_db 000140 automatic bit(1) initial dcl 133 set ref 133* 1078 1087* format 63 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcu" set ref 772* format 63 based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcu" set ref 445 445 448* 466 466 469* 510 510 513* 582 618 618 621* 646 646 649* 720 720* 729 761 944 1110 1113* 1114* 1117* 1122* 1134 1139 1144 1152 format 63 based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcu" set ref 772* free_ptr based pointer dcl 161 ref 1195 1195 1195 free_ptr_ptr 000240 automatic pointer dcl 162 set ref 1189* 1195 1195 1195* gcos constant fixed bin(17,0) initial dcl 1-97 ref 466 469 510 513 618 621 646 649 761 1114 1117 1122 1139 1144 1152 gcos_ascii 73 based bit(1) level 2 dcl 1-58 set ref 518* 767 gcos_bcd 74 based bit(1) level 2 dcl 1-58 set ref 524* 768 gcos_card_utility_ 000054 constant entry external dcl 72 ref 803 get_system_free_area_ 000052 constant entry external dcl 71 ref 164 given_path parameter char unaligned dcl 1104 in procedure "check_suffix" set ref 1092 1107* 1134* 1139* 1144* 1152* given_path parameter char unaligned dcl 1214 in procedure "get_io_pathname" set ref 1212 1218 1220 1220 1221* hcs_$initiate_count 000056 constant entry external dcl 73 ref 304 hcs_$terminate_noname 000060 constant entry external dcl 75 ref 348 1202 i 000113 automatic fixed bin(24,0) dcl 103 set ref 395* 396 402 403 403 414 790* 791 791 791 id based char(32) level 2 dcl 1-122 set ref 383* 790 791 791* 796* 1054 1171* imcv constant fixed bin(17,0) initial dcl 1-97 ref 539 751 index builtin function dcl 91 ref 315 333 395 404 790 1249 input based structure level 1 dcl 1-13 set ref 189* input_code constant fixed bin(17,0) initial dcl 1-97 ref 194 277 440 493 517 523 550 690 735 780 input_ptr 000454 automatic pointer dcl 1-11 set ref 187* 189 192 192 194 197 200 201 270 272 273 370 377 479 483 529 530 539 540 545 552 595 601 607 633 635 718 738 739 739 741 751 751 760 769 770 772 774 803* 804 920 1072 1168 1189 1189 input_string parameter char unaligned dcl 1238 ref 1227 1248 input_structure_area 000244 automatic structure level 1 unaligned dcl 169 set ref 187 input_tape based structure level 1 dcl 1-46 io based structure level 1 dcl 1-121 io_list based structure array level 1 dcl 1-123 set ref 290 291* 327 328* io_names 000030 internal static char(8) initial array dcl 1-138 set ref 1007 1068* io_ptr 000460 automatic pointer dcl 1-120 set ref 200* 246 250 251 251 253 255 255 255 255 255 258 258 258 258 258 268 277 287 289 290 290 290 291 291 291 292 293 293 293 293 319 326 327 327 327 328 328 328 332 335 337 337 337 337 340 340 340 340 347 383 384 392 418 421 440 445 445 448 449 449 452 456 458 461 465 466 466 469 473 487 493 494* 504 510 510 513 517 523 531 533 545 552* 556 564 571 573 574 578 579 580 580 582 588 594 600 607 611* 615 617 618 618 621 625 627 631 640 642 643 645 646 646 649 650 651 652 654 655 655 660 664 686 690 690* 696 697 697 699 701 711 718* 720 720 723 723 726 729 729 735 746* 760* 761 762 763 764* 774* 780 783 783 789 790 791 791 791 795 796 796* 878 879 944 948 1007 1054 1068 1110 1113 1114 1117 1118 1122 1123 1126 1126 1134 1139 1144 1144 1152 1168* 1169 1170 1171 1171 1171 1176 1177* io_source_given 000134 automatic bit(1) initial array dcl 127 set ref 127* 127* 571 573* 640 642* 686 699* 726 io_spec_given 000132 automatic bit(1) initial array dcl 127 set ref 127* 127* 545* 550 607* 610 io_tape based structure level 1 dcl 1-122 set ref 650 651* ioa_ 000062 constant entry external dcl 76 ref 1068 1073 1074 ioa_$nnl 000064 constant entry external dcl 76 ref 1066 ios_$attach 000066 constant entry external dcl 77 ref 796 ios_$detach 000070 constant entry external dcl 79 ref 487 1177 j 000114 automatic fixed bin(24,0) dcl 103 set ref 404* 405 407* 418 k 000115 automatic fixed bin(24,0) dcl 103 set ref 310* 317* 317 326 332* 337 340* 402* 407 407 413* l 000116 automatic fixed bin(24,0) dcl 103 set ref 312* 314 315 320* 320 323* 330* 333 344* 344 402* 407 407 413* label 10 based char(12) level 2 dcl 1-122 set ref 421* 652* last_line constant fixed bin(24,0) initial dcl 116 in procedure "gcu" ref 230 567 last_line 77 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcu" set ref 739* 741* 770 length builtin function dcl 91 ref 1108 1218 library constant fixed bin(17,0) initial dcl 1-97 ref 529 751 line_count constant fixed bin(24,0) initial dcl 116 ref 236 476 list constant fixed bin(24,0) initial dcl 116 ref 242 534 577 list_count 56 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcu" set ref 273* list_count 56 based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcu" set ref 251* 251 255 258 289* 290 291 292* 326* 327 328 332 list_count 56 based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcu" set ref 280* list_file constant fixed bin(24,0) initial dcl 116 ref 265 298 list_finished 000136 automatic bit(1) initial array dcl 127 set ref 127* 127* 246* 347* 533 574 711* list_name_size 57 based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcu" set ref 250 255 255 255 258 258 258 287 290 291 293 293 293 319 327 328 337 337 337 340 340 340 578* 879 list_name_size 57 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcu" set ref 530* 540* list_ptr 54 based pointer level 2 in structure "output" dcl 1-58 in procedure "gcu" set ref 193* 1189 list_ptr 54 based pointer level 2 in structure "io" dcl 1-121 in procedure "gcu" set ref 255 258 290* 291 293 327* 328 337 340 list_ptr 54 based pointer level 2 in structure "input" dcl 1-13 in procedure "gcu" set ref 192* 1189 list_started 000141 automatic bit(1) initial dcl 133 set ref 133* 243 288* 535* 576* 711 long 70 based bit(1) level 2 dcl 1-121 set ref 588* m 000117 automatic fixed bin(24,0) dcl 103 set ref 315* 316 317 319 320 321 333* 334 337 337 338 338 340 343 344 345 397* 403* 404 410 413 414* 421 906 941 max builtin function dcl 91 ref 739 max_error_code 000100 automatic fixed bin(24,0) initial dcl 826 set ref 826* 854 me 000133 constant char(23) initial dcl 143 set ref 180* 804* 1064* 1171* medium 64 based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcu" set ref 748 medium 64 based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcu" set ref 449 449 452* 456 556 580 580* 615 617* 625 643 645* 697 697* 763 783 948 1118* 1126 1126* 1144 mnames 000107 constant char(8) initial array dcl 831 ref 878 944 948 msg2 000237 automatic varying char(200) dcl 829 set ref 878* 944* 948* 964* 972* 976* 980* 1058* 1064* multiple_files constant fixed bin(17,0) initial dcl 1-97 ref 253 270 335 579 n 000120 automatic fixed bin(24,0) dcl 103 set ref 311* 315 321* 321 331* 333 337 337 338 338 340 343* 343 398* 403* 404 413 414* 419 421 906 941 name_files 72 based bit(1) level 2 dcl 1-58 set ref 279* 751 names 1 based char array level 2 dcl 1-123 set ref 255* 258* 293* 337* 340* nargs 000111 automatic fixed bin(17,0) dcl 101 set ref 177* 178 206 289 483 1066 1068 newline constant char(1) initial unaligned dcl 154 ref 315 333 no_canon 74 based bit(1) level 2 dcl 1-13 set ref 201* 595* 601* no_of_lines 000123 automatic fixed bin(24,0) initial dcl 104 set ref 104* 238* 474 565 739 739 normal_termination 000144 automatic bit(1) initial dcl 133 set ref 133* 810* 1079* 1079 1179 1203 null builtin function dcl 91 ref 148 192 193 305 1169 1195 1201 1220 1220 numeric 000235 automatic bit(1) initial unaligned dcl 159 set ref 159* 212* 213* 225 231 237 355 392 numeric_arg 000126 automatic fixed bin(24,0) dcl 108 set ref 211* 226 232 238 367 367 370 377 392 879* 920* 1064* output based structure level 1 dcl 1-58 set ref 190* output_code constant fixed bin(17,0) initial dcl 1-97 ref 195 268 473 504 531 564 594 600 610 631 746 output_ptr 000456 automatic pointer dcl 1-56 set ref 188* 190 193 193 195 279 280 441 494 518 524 611 690 718 748 748 751 760 766 767 768 772 774 803* 1168 1189 1189 output_structure_area 000356 automatic structure level 1 unaligned dcl 170 set ref 188 pl 000152 automatic fixed bin(21,0) dcl 1216 set ref 1218* 1220* position 16 based fixed bin(17,0) level 2 dcl 1-122 set ref 392* 418* raw constant fixed bin(17,0) initial dcl 1-97 ref 580 617 697 763 1118 1144 retain 14 based bit(1) level 2 dcl 1-122 set ref 627* 1170 return_suffix parameter varying char dcl 1239 set ref 1227 1251* 1255* reverse builtin function dcl 91 ref 1248 1251 rtrim builtin function dcl 91 ref 1248 rw 000233 automatic char(1) dcl 152 set ref 780* 782* 796* seg_olay based char unaligned dcl 150 ref 315 333 337 337 338 338 340 906 seglen 000232 automatic fixed bin(24,0) dcl 149 set ref 309* 312 315 330 333 337 337 338 338 340 906 segptr 000230 automatic pointer initial dcl 148 set ref 148* 304* 305 315 333 337 337 338 338 340 348* 906 1201 1202* set 62 based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcu" set ref 253 335 579* 696* 723 723* 764 878 set 62 based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcu" set ref 270 529* 539* 751 751 single_file constant fixed bin(17,0) initial dcl 1-97 ref 696 723 764 starting_line_no 000121 automatic fixed bin(24,0) initial dcl 104 set ref 104* 226* 505 738 status 000124 automatic bit(72) dcl 106 set ref 177 179 180 208 209 211 212 214 302 303 304 306 348 349 407 408 409 487* 489 489 796* 797 803 804 804 996 1040 1046 1056 1059* 1064 1177* 1178 1202 1203 1220 1221 substr builtin function dcl 91 set ref 216 315 333 337 337 338 338 340 404 407 407 421 654 791 791* 906 941 1056 1251 suffix_string 000100 automatic varying char(32) dcl 1105 set ref 1107* 1108 1113 1114 1115 1120 1132 1137 1142 1147 sw based fixed bin(17,0) level 2 in structure "output" dcl 1-58 in procedure "gcu" set ref 195* sw based fixed bin(17,0) level 2 in structure "io" dcl 1-121 in procedure "gcu" ref 246 268 277 347 440 473 487 493 504 517 523 531 533 545 564 571 573 574 594 600 607 631 640 642 686 690 699 711 726 735 746 780 796 1007 1068 1177 sw based fixed bin(17,0) level 2 in structure "input" dcl 1-13 in procedure "gcu" set ref 194* system_free_area based area(1024) dcl 165 ref 290 327 650 system_free_ptr 000242 automatic pointer initial dcl 164 set ref 164* 290 327 650 1195 tab_index 000127 automatic fixed bin(24,0) initial dcl 109 set ref 109* 356 370 370 374* 374 375 377 920 tabs constant fixed bin(24,0) initial dcl 116 ref 353 636 713 tabs_given 75 based bit(1) level 2 dcl 1-13 set ref 633 635* tabstops 100 based fixed bin(17,0) array level 2 dcl 1-13 set ref 370 377* 920 tape constant fixed bin(17,0) initial dcl 1-97 ref 456 556 615 625 645 748 783 tape_id constant fixed bin(24,0) initial dcl 116 ref 381 661 tape_label constant fixed bin(24,0) initial dcl 116 ref 390 558 tape_ptr 60 based pointer level 2 in structure "output" dcl 1-58 in procedure "gcu" set ref 193* 1189 tape_ptr 60 based pointer level 2 in structure "input" dcl 1-13 in procedure "gcu" set ref 192* 1189 tape_ptr 60 based pointer level 2 in structure "io" dcl 1-121 in procedure "gcu" set ref 383 384 392 418 421 458 627 650* 651 652 654 655 655 660 783 789 790 791 791 791 795 796 1054 1169 1170 1171 1171 1176 tape_stream 000010 internal static char(32) initial array dcl 1-130 set ref 487* 796* 1177* tracks 13 based char(1) level 2 dcl 1-122 set ref 654* 655 655 660* 789 791 truncate_ascii 66 based bit(1) level 2 dcl 1-121 set ref 664* 729 unspec builtin function dcl 91 set ref 189* 190* 291* 328* 651* verify_suffix 000142 automatic bit(1) initial dcl 133 set ref 133* 582* 584* 1130 word_string based bit(36) array dcl 158 ref 1195 word_string_len 000234 automatic fixed bin(24,0) initial dcl 157 set ref 157* 1195 work_string 000120 automatic varying char(168) dcl 1241 set ref 1248* 1249 1251 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. file_stream internal static char(32) initial array unaligned dcl 1-133 input_list based structure array level 1 dcl 1-42 output_list based structure array level 1 dcl 1-82 output_tape based structure level 1 dcl 1-86 NAMES DECLARED BY EXPLICIT CONTEXT. arg_error 005575 constant entry internal dcl 819 ref 209 225 231 237 250 268 270 277 283 287 303 305 319 349 356 367 370 375 382 405 410 419 426 440 445 449 456 466 473 474 489 504 505 510 517 523 531 533 550 556 564 565 571 574 594 600 610 615 618 625 631 633 640 643 646 655 671 675 692 713 726 729 748 751 797 1179 1203 arg_error_common 005645 constant label dcl 854 ref 845 arg_loop 001471 constant label dcl 206 call_com_err 006443 constant label dcl 1064 ref 858 870 880 884 888 892 900 904 916 921 925 929 933 937 942 962 970 986 990 994 999 1012 1016 1020 1032 1036 1042 1048 1052 1062 check_if_given 005036 constant label dcl 686 ref 693 check_label 003222 constant label dcl 419 ref 399 check_suffix 006647 constant entry internal dcl 1092 ref 256 338 702 cleanup_proc 007127 constant entry internal dcl 1164 ref 203 811 1083 cv_dec_label 003131 constant label dcl 407 ref 415 detach_tape 003563 constant label dcl 487 ref 495 err 000000 constant label array(2:72) dcl 868 ref 864 908 et_inconsistent 006347 constant label dcl 1046 ref 954 et_noarg 006335 constant label dcl 1040 ref 874 896 912 1003 1008 gcos_arg 003710 constant label dcl 510 ref 519 525 gcos_card_utility 001347 constant entry external dcl 11 gcu 001337 constant entry external dcl 11 get_io_pathname 007401 constant entry internal dcl 1212 ref 255 337 701 get_suffix 007475 constant entry internal dcl 1227 ref 1107 given_message 006354 constant label dcl 1050 ref 966 974 978 982 inconsistent_message 006342 constant label dcl 1044 set ref 946 950 indx 002473 constant label dcl 333 ref 345 interpret_control_arg 003261 constant label dcl 432 set ref 247 360 interpret_expected_arg 001602 constant label dcl 219 interpret_path 005036 constant label dcl 683 ref 362 not_blocks 005362 constant label dcl 774 ref 761 762 763 764 766 767 768 769 770 path_error 005617 constant entry internal dcl 848 ref 1134 1139 1144 1152 1221 quit 005566 constant label dcl 812 ref 1084 set_up_for_list 004030 constant label dcl 531 ref 541 switch_io 005041 constant label dcl 686 tape_id_message 006362 constant label dcl 1054 ref 1024 1028 tape_message 006372 constant label dcl 1056 ref 958 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 10102 10204 7601 10112 Length 10452 7601 102 231 301 24 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME gcu 410 external procedure is an external procedure. on unit on line 203 64 on unit arg_error 248 internal procedure is called by several nonquick procedures. check_suffix 141 internal procedure is called during a stack extension. cleanup_proc 96 internal procedure is called by several nonquick procedures. get_io_pathname 127 internal procedure is called during a stack extension. get_suffix internal procedure shares stack frame of internal procedure check_suffix. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 tape_stream gcu 000030 io_names gcu STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME arg_error 000100 max_error_code arg_error 000101 bad_arg arg_error 000154 err_msg arg_error 000237 msg2 arg_error check_suffix 000100 suffix_string check_suffix 000120 work_string get_suffix 000173 dot_index get_suffix gcu 000106 ap gcu 000110 al gcu 000111 nargs gcu 000112 argno gcu 000113 i gcu 000114 j gcu 000115 k gcu 000116 l gcu 000117 m gcu 000120 n gcu 000121 starting_line_no gcu 000122 ending_line_no gcu 000123 no_of_lines gcu 000124 status gcu 000126 numeric_arg gcu 000127 tab_index gcu 000130 expected_arg gcu 000132 io_spec_given gcu 000134 io_source_given gcu 000136 list_finished gcu 000140 fixed_in_db gcu 000141 list_started gcu 000142 verify_suffix gcu 000143 detach_tapes gcu 000144 normal_termination gcu 000145 dirname gcu 000217 ename gcu 000227 bitcount gcu 000230 segptr gcu 000232 seglen gcu 000233 rw gcu 000234 word_string_len gcu 000235 numeric gcu 000236 control gcu 000240 free_ptr_ptr gcu 000242 system_free_ptr gcu 000244 input_structure_area gcu 000356 output_structure_area gcu 000454 input_ptr gcu 000456 output_ptr gcu 000460 io_ptr gcu get_io_pathname 000100 expanded_path get_io_pathname 000152 pl get_io_pathname THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_cs call_ext_out_desc call_ext_out call_int_this_desc call_int_this call_int_other_desc call_int_other return tra_ext enable shorten_stack ext_entry int_entry int_entry_desc reverse_cs set_cs_eis alloc_based free_based THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. com_err_ cu_$arg_count cu_$arg_ptr cv_dec_check_ db decode_nstd_status_ expand_path_ gcos_card_utility_ get_system_free_area_ hcs_$initiate_count hcs_$terminate_noname ioa_ ioa_$nnl ios_$attach ios_$detach THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$badopt error_table_$inconsistent error_table_$ioname_not_found error_table_$noarg LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 104 001260 109 001263 111 001264 127 001265 133 001312 148 001317 157 001321 159 001323 164 001325 11 001336 177 001355 178 001366 179 001370 180 001373 182 001416 187 001417 188 001421 189 001423 190 001426 192 001431 193 001434 194 001437 195 001441 197 001443 200 001445 201 001446 203 001447 206 001471 208 001501 209 001516 211 001530 212 001556 213 001565 214 001566 216 001567 217 001577 219 001600 224 001602 225 001604 226 001616 227 001620 228 001621 230 001622 231 001624 232 001636 233 001640 234 001641 236 001642 237 001644 238 001656 239 001660 240 001661 242 001662 243 001664 244 001666 245 001670 246 001671 247 001674 250 001675 251 001711 253 001713 255 001716 256 001757 257 001772 258 001773 260 002013 264 002014 265 002016 267 002036 268 002042 270 002055 272 002071 273 002074 274 002076 275 002077 276 002100 277 002114 279 002127 280 002132 281 002134 282 002135 283 002136 284 002146 287 002147 288 002163 289 002165 290 002172 291 002205 292 002220 293 002222 296 002230 298 002231 300 002233 302 002234 303 002261 304 002273 305 002335 306 002351 309 002352 310 002355 311 002356 312 002360 314 002362 315 002364 316 002377 317 002400 319 002403 320 002420 321 002422 322 002424 323 002425 324 002426 326 002427 327 002432 328 002445 330 002460 331 002462 332 002464 333 002473 334 002507 335 002511 337 002515 338 002565 339 002611 340 002613 343 002635 344 002637 345 002641 346 002644 347 002646 348 002651 349 002662 351 002674 353 002675 355 002677 356 002701 359 002714 360 002715 362 002717 364 002720 367 002721 370 002736 374 002755 375 002756 377 002771 379 002775 381 002776 382 003000 383 003013 384 003022 387 003037 388 003040 390 003041 391 003043 392 003044 395 003053 396 003065 397 003066 398 003070 399 003072 402 003073 402 003075 403 003100 403 003103 404 003106 405 003120 407 003131 408 003165 409 003170 410 003171 413 003205 413 003206 414 003210 414 003212 415 003215 418 003216 419 003222 421 003235 423 003245 426 003246 429 003256 432 003257 439 003261 440 003272 441 003305 442 003310 444 003311 445 003321 448 003336 449 003341 452 003355 453 003360 455 003361 456 003371 458 003405 459 003411 461 003412 464 003426 465 003436 466 003441 469 003455 470 003460 472 003461 473 003471 474 003504 476 003520 477 003522 479 003523 482 003537 483 003547 487 003563 489 003611 492 003626 493 003630 494 003633 495 003635 497 003636 499 003637 503 003640 504 003650 505 003663 506 003675 507 003677 509 003700 510 003710 513 003725 514 003730 516 003731 517 003741 518 003754 519 003757 522 003760 523 003770 524 004003 525 004006 528 004007 529 004023 530 004026 531 004030 533 004043 534 004056 535 004060 536 004061 538 004062 539 004066 540 004071 541 004073 544 004074 545 004104 550 004117 552 004132 553 004134 555 004135 556 004145 558 004161 559 004163 563 004164 564 004174 565 004207 567 004223 568 004225 570 004226 571 004236 573 004251 574 004254 576 004266 577 004267 578 004271 579 004274 580 004276 582 004303 584 004307 586 004311 588 004312 591 004326 594 004342 595 004355 596 004360 598 004361 600 004371 601 004404 602 004406 606 004407 607 004417 610 004432 611 004445 612 004447 614 004450 615 004454 617 004470 618 004473 621 004507 622 004512 624 004513 625 004523 627 004537 628 004543 630 004544 631 004550 633 004563 635 004576 636 004601 637 004603 639 004604 640 004620 642 004633 643 004636 645 004651 646 004654 649 004670 650 004673 651 004701 652 004704 653 004707 654 004712 655 004717 659 004736 660 004737 661 004741 662 004743 664 004744 671 004764 675 005025 678 005035 686 005036 690 005041 692 005047 693 005057 696 005060 697 005063 699 005070 701 005073 702 005116 706 005131 710 005133 711 005135 713 005143 718 005155 720 005161 723 005166 726 005172 729 005205 735 005223 738 005226 739 005231 741 005243 746 005245 748 005250 751 005266 756 005307 760 005315 761 005321 762 005325 763 005327 764 005332 765 005335 766 005343 767 005346 768 005350 769 005352 770 005355 772 005357 774 005362 780 005366 782 005374 783 005376 789 005405 790 005410 791 005421 795 005442 796 005444 797 005502 800 005514 803 005522 804 005535 808 005557 810 005560 811 005562 812 005566 826 005570 819 005574 844 005603 845 005615 848 005616 852 005633 854 005645 857 005653 858 005660 864 005661 868 005662 870 005667 872 005670 874 005675 876 005676 878 005703 879 005714 880 005716 882 005717 884 005724 886 005725 888 005732 890 005733 892 005740 894 005741 896 005746 898 005747 900 005754 902 005755 904 005762 906 005763 908 005777 910 006000 912 006005 914 006006 916 006013 918 006014 920 006021 921 006026 923 006027 925 006034 927 006035 929 006042 931 006043 933 006050 935 006051 937 006056 939 006057 941 006064 942 006076 944 006077 946 006110 948 006111 950 006122 952 006123 954 006130 956 006131 958 006136 960 006137 962 006144 964 006145 966 006152 968 006153 970 006160 972 006161 974 006166 976 006167 978 006174 980 006175 982 006202 984 006203 986 006210 988 006211 990 006216 992 006217 994 006224 996 006225 998 006231 999 006235 1001 006236 1003 006243 1005 006244 1007 006251 1008 006262 1010 006263 1012 006270 1014 006271 1016 006276 1018 006277 1020 006304 1022 006305 1024 006312 1026 006313 1028 006320 1030 006321 1032 006326 1034 006327 1036 006334 1040 006335 1042 006341 1044 006342 1046 006347 1048 006353 1050 006354 1052 006361 1054 006362 1056 006372 1058 006376 1059 006403 1060 006420 1061 006441 1062 006442 1064 006443 1066 006500 1068 006527 1072 006554 1073 006560 1074 006604 1075 006621 1078 006626 1079 006631 1083 006634 1084 006641 1087 006644 1088 006645 1092 006646 1107 006662 1108 006677 1110 006701 1113 006705 1114 006715 1115 006725 1117 006732 1118 006734 1119 006736 1120 006737 1122 006744 1123 006746 1126 006750 1128 006754 1130 006755 1132 006757 1134 006764 1136 007007 1137 007010 1139 007015 1141 007040 1142 007041 1144 007046 1146 007074 1147 007075 1152 007102 1157 007125 1164 007126 1168 007134 1169 007142 1170 007150 1171 007153 1174 007210 1176 007211 1177 007213 1178 007241 1179 007244 1185 007257 1189 007267 1195 007275 1199 007315 1201 007343 1202 007350 1203 007361 1208 007377 1212 007400 1218 007414 1220 007415 1221 007443 1223 007467 1227 007475 1248 007513 1249 007543 1251 007556 1255 007574 1257 007577 ----------------------------------------------------------- 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