COMPILATION LISTING OF SEGMENT gcos_label_tape Compiled by: Multics PL/I Compiler, Release 27d, of October 11, 1982 Compiled at: Honeywell LISD Phoenix, System M Compiled on: 11/19/82 1103.1 mst Fri Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* *********************************************************** */ 6 gcos_label_tape: 7 gclt: proc; 8 9 10 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 11 /* */ 12 /* Written: Scott C. Akers FEB 82 */ 13 /* Changed: Ron Barstad Oct 1982 To accept only 5 char for tape label */ 14 /* */ 15 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 16 17 /* 18*Syntax: gcos_label_tape REEL_NUM {NEW_NUM} {-control_args} 19* 20* 21*Function: Writes a GCOS label on a tape. 22* 23* 24*Arguments: 25* 26*REEL_NUM 27* is the number on the label of the tape reel to be used. 28*NEW_NUM 29* is the new serial number to be written on the tape. If it is the 30* same as the REEL_NUM, it may be omitted. 31* 32* 33*Control arguments: 34* 35*-density N, -den N 36* Specify the tape density. Default is 1600 BPI. 37*-track N, -tk N 38* Specify 7- or 9-track tape. Default is 9-track. 39*-erase | -no_erase 40* Erase/don't erase the tape before labeling it. Default is to 41* overwrite the old label (if it exists), and leave the remaining 42* data intact (-no_erase). 43* 44* 45*Notes: 46* 47*If no control arguments are given, the command: 48* gclt xyz12 49*is equivalent to the command: 50* gclt xyz12 xyz12 -tk 9 -den 1600 -no_erase 51* 52*If conflicting control arguments are given, the rightmost control 53*argument is used (e.g. "gclt m1266 -tk 7 -tk 9" will label a 9-track 54*tape.) 55**/ 56 57 call init_routine; /* Set default values. */ 58 59 on condition (cleanup) 60 begin; 61 call close_file; 62 goto exit_gclt; 63 end; 64 65 call cu_$arg_list_ptr (arg_list_ptr); /* Get an argument pointer. */ 66 if get_args (arg_list_ptr) /* Validate the args. */ 67 then if built_label () /* Try to build the label. */ 68 then if tape_labeled () /* Attempt to do the labeling. */ 69 then if label_ok () /* Make sure it matches. */ 70 then call goodie_message; /* Tell user it succeeded. */ 71 72 call close_file; /* Close and detach the tape. */ 73 74 exit_gclt: ; 75 76 return; 77 78 asc_to_bcd: proc (in_string, out_string, field_length) returns (bit (1)); 79 80 /* Translates an ASCII character 81* /* string to its BCD equivalent, 82* /* padding on the right to fill 83* /* output field. */ 84 85 dcl field_length fixed bin parm; 86 dcl in_string char (*) parm; 87 dcl out_string bit (*) parm; 88 89 90 error = "0"b; 91 fill_count = 0; 92 max_xlate = min (length (rtrim (in_string)), field_length); 93 94 95 do counter = 1 to max_xlate 96 while (^error); 97 98 if in_char (counter) <= hbound (asc_to_bcd_table, 1) 99 then do; 100 out_char (counter) = asc_to_bcd_table (in_char (counter)); 101 fill_count = fill_count + 1; 102 end; 103 else do; 104 call com_err_ (error_table_$bad_conversion, MYNAME, 105 "^/ASCII character ""^o"" has no BCD counterpart.", 106 in_char (counter)); 107 error = "1"b; 108 end; 109 end; 110 111 if ^error 112 then do counter = fill_count+1 to field_length; 113 out_char (counter) = "20"b3; 114 end; 115 116 return (^error); 117 118 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 119 120 dcl error bit (1); 121 dcl in_char (length (rtrim (in_string))) fixed bin (9) 122 unsigned unaligned based (addr (in_string)); 123 dcl max_xlate fixed bin; 124 dcl out_char (field_length) bit (6) 125 unaligned based (addr (out_string)); 126 127 end asc_to_bcd; 128 129 built_label: proc returns (bit (1)); /* Fills in label structure. */ 130 131 if new_vol_id = " " 132 then new_vol_id = atd_structure.vol_id; /* Use old VOL_ID if new one not given. */ 133 134 if asc_to_bcd ("ge 600 btl", tape_label.label_id, 12) 135 then if asc_to_bcd (ascii_inst_id, tape_label.installation_id, 6) 136 then if asc_to_bcd (" " || new_vol_id, tape_label.tape_serial_number, 6) 137 then if asc_to_bcd (" " || new_vol_id, tape_label.file_serial_number, 6) 138 then if asc_to_bcd (" 0001", tape_label.reel_sequence_number, 6) 139 then if asc_to_bcd (" " || ascii_cr_date, tape_label.creation_date, 6) 140 then if asc_to_bcd (" ", tape_label.file_name, 12) 141 then if asc_to_bcd ("gcos env simulator", tape_label.blurb, 18) 142 then if asc_to_bcd (" ", tape_label.blanks, 6) 143 then return ("1"b); 144 return ("0"b); 145 146 end built_label; 147 148 close_file: proc; 149 150 code = 0; 151 152 if iocb_ptr ^= null () 153 then do; 154 155 call iox_$close (iocb_ptr, code); 156 call iox_$detach_iocb (iocb_ptr, code); 157 call iox_$destroy_iocb (iocb_ptr, code); 158 159 if code ^= 0 160 then call com_err_ (code, MYNAME, 161 "^/Error while trying to detach/close ^a", 162 stream_name); 163 end; 164 165 return; 166 167 end close_file; 168 169 day_of_year: proc returns (char (3)); 170 171 call datebin_$dayr_clk (clock_reading, num_day); 172 173 return (ltrim (char (num_day,17))); 174 175 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 176 177 dcl num_day fixed bin; 178 179 end day_of_year; 180 181 get_args: proc (arg_list_ptr) returns (bit(1)); /* Does the argument processing. */ 182 183 dcl arg_list_ptr ptr parm; 184 185 error = "0"b; 186 call cu_$arg_count_rel (arg_count, arg_list_ptr, code); 187 188 if code ^= 0 189 then do; 190 call com_err_ (code, MYNAME); 191 error = "1"b; 192 end; 193 194 if arg_count > 0 195 then do arg_no = 1 to arg_count while (^error); 196 call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr); 197 if code = 0 198 then do; 199 if substr (arg, 1, 1) = "-" 200 then do; 201 error = ^valid_ctl_arg (arg); 202 expect.new_vol_id = "0"b; 203 end; 204 else error = ^valid_vanilla_arg (arg); 205 end; 206 end; 207 208 else do; 209 call com_err_ (error_table_$noarg, MYNAME, 210 "^/You must supply a reel number."); 211 212 error = "1"b; 213 end; 214 215 return (^error); 216 217 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 218 219 dcl arg char (arg_len) based (arg_ptr); 220 dcl error bit (1); 221 end get_args; 222 223 goodie_message: proc; /* Tells user labeling succeeded. */ 224 225 call ioa_ ("^/Tape# ^a labeled as ""^a""^/", 226 atd_structure.vol_id, 227 new_vol_id); 228 229 return; 230 end goodie_message; 231 232 init_routine: proc; /* Sets up default values. */ 233 234 clock_reading = clock_ (); 235 236 erase = "0"b; /* Default is to not erase. */ 237 238 iocb_ptr = null (); 239 240 unspec (compare_buffer) = "0"b; 241 242 unspec (tape_label) = "0"b; 243 244 unspec (expect) = "0"b; 245 expect.reel_id = "1"b; 246 247 new_vol_id = " "; 248 249 atd_string = " "; /* Fill with blanks first. */ 250 atd_structure.dim = "tape_nstd_"; /* Now fill in the goodies. */ 251 atd_structure.tracks = "-track 9"; 252 atd_structure.write = "-write"; 253 atd_structure.block_size = "-block 2800"; 254 atd_structure.density = "-density 1600"; 255 256 ascii_cr_date = year_num () || day_of_year (); 257 258 call system_info_$installation_id (ascii_inst_id); 259 260 return; 261 262 end init_routine; 263 264 label_ok: proc returns (bit (1)); 265 266 call iox_$control (iocb_ptr, "rewind", (null ()), code); 267 268 if code = 0 269 then call iox_$read_record (iocb_ptr, (addr (compare_buffer)), 270 (14*4), return_count, code); 271 272 if code = 0 273 then do; 274 if tape_label_string ^= compare_buffer 275 then do; 276 code = error_table_$bad_label; 277 call print_label_contents; 278 end; 279 end; 280 281 else call com_err_ (code, MYNAME, 282 "^/Error attempting to verify label."); 283 284 return (code = 0); 285 286 end label_ok; 287 288 print_label_contents: proc; 289 290 call com_err_ (code, MYNAME, 291 "^/Error while verifying label"); 292 293 overlay_ptr = addr (tape_label); 294 295 call com_err_$suppress_name (0,MYNAME, "^2^/^-EXPECTED DATA" 296 ||"^/^w ^w ^w ^w" 297 ||"^/^w ^w ^w ^w" 298 ||"^/^w ^w ^w ^w" 299 ||"^/^w ^w", 300 dump_overlay (1), dump_overlay (2), 301 dump_overlay (3), dump_overlay (4), 302 dump_overlay (5), dump_overlay (6), 303 dump_overlay (7), dump_overlay (8), 304 dump_overlay (9), dump_overlay (10), 305 dump_overlay (11), dump_overlay (12), 306 dump_overlay (13), dump_overlay (14)); 307 308 overlay_ptr = addr (compare_buffer); 309 310 call com_err_$suppress_name (0,MYNAME, "^2^/^-ACTUAL DATA" 311 ||"^/^w ^w ^w ^w" 312 ||"^/^w ^w ^w ^w" 313 ||"^/^w ^w ^w ^w" 314 ||"^/^w ^w", 315 dump_overlay (1), dump_overlay (2), 316 dump_overlay (3), dump_overlay (4), 317 dump_overlay (5), dump_overlay (6), 318 dump_overlay (7), dump_overlay (8), 319 dump_overlay (9), dump_overlay (10), 320 dump_overlay (11), dump_overlay (12), 321 dump_overlay (13), dump_overlay (14)); 322 323 return; 324 325 end print_label_contents; 326 327 tape_attached: proc returns (bit (1)); 328 329 stream_name = "lbl_" || rtrim (atd_structure.vol_id); 330 call iox_$attach_name (stream_name, iocb_ptr, atd_string, null (), code); 331 if code = 0 332 then call iox_$open (iocb_ptr, (6), ("0"b), code); 333 334 if code = 0 335 then call iox_$control (iocb_ptr, "rewind", (null ()), code); 336 337 if code = 0 338 then if tape_erased () 339 then code = 0; 340 341 if code ^= 0 342 then call com_err_ (code, MYNAME, 343 "^/Error while attaching/positioning tape."); 344 345 return (code = 0); 346 347 end tape_attached; 348 349 tape_erased: proc returns (bit (1)); 350 351 code = 0; 352 353 if erase 354 then do; 355 356 do while (code = 0); 357 call iox_$control ( iocb_ptr, "erase", null (), code); 358 end; 359 360 if code = error_table_$tape_error 361 then code = 0; 362 363 if code = 0 364 then call iox_$control (iocb_ptr, "rewind", (null ()), code); 365 366 if code ^= 0 367 then call com_err_ (code, MYNAME, "^/Error while erasing tape."); 368 369 end; 370 371 return (code = 0); 372 373 end tape_erased; 374 375 tape_labeled: proc returns (bit (1)); 376 377 if tape_attached () 378 then do; 379 call iox_$write_record (iocb_ptr, addr (tape_label), (14*4), code); 380 if code ^= 0 381 then call com_err_ (code, MYNAME, 382 "^/Error while trying to write new label."); 383 384 else do; 385 call iox_$control (iocb_ptr, "write_eof", (null ()), code); 386 if code ^= 0 387 then call com_err_ (code, MYNAME, 388 "^/Error while writing EOF. "); 389 end; 390 end; 391 392 else code = error_table_$not_attached; 393 394 return (code = 0); 395 396 end tape_labeled; 397 398 valid_ctl_arg: proc (ctl_arg) returns (bit (1)); 399 400 dcl ctl_arg char (*) parm; 401 402 error = "0"b; 403 404 if arg_no < 2 405 then do; 406 call com_err_ (error_table_$noarg, MYNAME, 407 "^/You must supply a reel number."); 408 error = "1"b; 409 end; 410 411 else do; 412 413 if ctl_arg = "-density" 414 | ctl_arg = "-den" 415 then expect.density = "1"b; 416 else if ctl_arg = "-track" 417 | ctl_arg = "-tk" 418 then expect.track = "1"b; 419 else if ctl_arg = "-erase" 420 then erase = "1"b; 421 else if ctl_arg = "-no_erase" 422 then erase = "0"b; 423 else do; 424 call com_err_ (error_table_$bad_arg, MYNAME, 425 "^/Argument: ^a",ctl_arg); 426 error = "1"b; 427 end; 428 429 end; 430 431 return (^error); 432 433 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 434 435 dcl error bit (1); 436 437 end valid_ctl_arg; 438 439 valid_vanilla_arg: proc (vanilla_arg) returns (bit (1)); 440 441 dcl vanilla_arg char (*) parm; 442 443 error = "0"b; 444 445 if expect.reel_id 446 then do; 447 if length (rtrim (vanilla_arg)) > 5 448 then do; 449 call com_err_ (error_table_$bigarg, MYNAME, 450 "^/Maximum of 5 characters for reel_id."); 451 error = "1"b; 452 end; 453 454 else do; 455 atd_structure.vol_id = rtrim (vanilla_arg); 456 expect.new_vol_id = "1"b; 457 expect.reel_id = "0"b; 458 end; 459 end; 460 461 else if expect.new_vol_id 462 then do; 463 if length (rtrim (vanilla_arg)) > 5 464 then do; 465 call com_err_ (error_table_$bigarg, MYNAME, 466 "^/Maximum of 5 characters for new vol_id."); 467 error = "1"b; 468 end; 469 470 else do; 471 new_vol_id = rtrim (vanilla_arg); 472 expect.new_vol_id = "0"b; 473 end; 474 end; 475 476 else if expect.track 477 then do; 478 if vanilla_arg = "9" 479 | vanilla_arg = "7" 480 then do; 481 atd_structure.tracks = "-track " || rtrim (vanilla_arg); 482 expect.track = "0"b; 483 end; 484 485 else do; 486 call com_err_ (0, MYNAME, "Only 7- or 9-track tapes may be specified."); 487 error = "1"b; 488 end; 489 end; 490 491 else if expect.density 492 then do; 493 if vanilla_arg = "6250" 494 | vanilla_arg = "1600" 495 | vanilla_arg = "800" 496 | vanilla_arg = "556" 497 | vanilla_arg = "200" 498 499 then do; 500 atd_structure.density = "-density " || rtrim (vanilla_arg); 501 expect.density = "0"b; 502 end; 503 else do; 504 call com_err_ (0, MYNAME, 505 "Bad density specification: ^a" 506 || "^/Valid densities:^-6250^-1600^-800^-556^-200", 507 vanilla_arg); 508 error = "1"b; 509 end; 510 end; 511 512 513 return (^error); 514 515 end valid_vanilla_arg; 516 517 year_num: proc returns (char (2)); 518 519 call date_time_ (clock_reading, date_string); 520 521 return (substr (date_string, 7, 2)); 522 523 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 524 525 dcl date_string char (50); 526 527 end year_num; 528 529 dcl addr builtin; 530 dcl arg_count fixed bin; 531 dcl arg_len fixed bin (21); 532 dcl arg_list_ptr pointer; 533 dcl arg_no fixed bin; 534 dcl arg_ptr pointer; 535 dcl ascii_cr_date char (6); 536 dcl ascii_inst_id char (20); 537 dcl atd_string char (60) 538 based (addr (atd_structure)); 539 dcl char builtin; 540 dcl cleanup condition; 541 dcl clock_ entry() returns(fixed bin(71)); 542 dcl clock_reading fixed bin (71); 543 dcl code fixed bin (35); 544 dcl com_err_ entry() options(variable); 545 dcl com_err_$suppress_name entry() options(variable); 546 dcl compare_buffer bit (14*36) aligned; 547 dcl counter fixed bin; 548 dcl cu_$arg_count_rel entry (fixed bin, ptr, fixed bin(35)); 549 dcl cu_$arg_list_ptr entry (ptr); 550 dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr); 551 dcl datebin_$dayr_clk entry (fixed bin(71), fixed bin); 552 dcl date_time_ entry (fixed bin(71), char(*)); 553 dcl dump_overlay (14) bit (36) based (overlay_ptr); 554 dcl erase bit (1); 555 dcl error bit (1); 556 dcl error_table_$bad_arg fixed bin (35) ext static; 557 dcl error_table_$bad_conversion fixed bin (35) ext static; 558 dcl error_table_$bad_label fixed bin (35) ext static; 559 dcl error_table_$bigarg fixed bin (35) ext static; 560 dcl error_table_$noarg fixed bin (35) ext static; 561 dcl error_table_$not_attached fixed bin (35) ext static; 562 dcl error_table_$tape_error fixed bin (35) ext static; 563 dcl fill_count fixed bin; 564 dcl hbound builtin; 565 dcl ioa_ entry() options(variable); 566 dcl iocb_ptr pointer; 567 dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)); 568 dcl iox_$close entry (ptr, fixed bin(35)); 569 dcl iox_$control entry (ptr, char(*), ptr, fixed bin(35)); 570 dcl iox_$destroy_iocb entry (ptr, fixed bin(35)); 571 dcl iox_$detach_iocb entry (ptr, fixed bin(35)); 572 dcl iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)); 573 dcl iox_$read_record entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)); 574 dcl iox_$write_record entry (ptr, ptr, fixed bin(21), fixed bin(35)); 575 dcl length builtin; 576 dcl ltrim builtin; 577 dcl min builtin; 578 dcl MYNAME char (10) internal static 579 options (constant) 580 init ("gclt"); 581 dcl new_vol_id char (6); 582 dcl null builtin; 583 dcl overlay_ptr pointer; 584 dcl return_count fixed bin (21); 585 dcl rtrim builtin; 586 dcl stream_name char (12); 587 dcl system_info_$installation_id entry (char(*)); 588 dcl substr builtin; 589 dcl tape_label_string bit (14*36) based (addr (tape_label)); 590 dcl unspec builtin; 591 592 dcl 1 tape_label aligned, 593 2 label_id bit (72) unaligned, 594 2 installation_id bit (36) unaligned, 595 2 tape_serial_number bit (36) unaligned, 596 2 file_serial_number bit (36) unaligned, 597 2 reel_sequence_number bit (36) unaligned, 598 2 creation_date bit (36) unaligned, 599 2 retention_days bit (36) unaligned, 600 2 file_name bit (72) unaligned, 601 2 blurb bit (108) unaligned, 602 2 blanks bit (36) unaligned; 603 604 605 dcl 1 atd_structure aligned, 606 2 dim char (11) unaligned, 607 2 fill_1 char (1) unaligned, 608 2 vol_id char (6) unaligned, 609 2 fill_2 char (1) unaligned, 610 2 tracks char (8) unaligned, 611 2 fill_3 char (1) unaligned, 612 2 write char (6) unaligned, 613 2 fill_4 char (1) unaligned, 614 2 block_size char (11) unaligned, 615 2 fill_5 char (1) unaligned, 616 2 density char (13) unaligned; 617 618 dcl 1 expect aligned, 619 2 reel_id bit (1) unaligned, 620 2 new_vol_id bit (1) unaligned, 621 2 density bit (1) unaligned, 622 2 track bit (1) unaligned; 623 1 1 /* START OF: asc_to_bcd_table.incl.pl1 * * * * * * * * * * * * * * * * */ 1 2 1 3 dcl asc_to_bcd_table (0:127) bit (6) unaligned 1 4 internal static 1 5 options (constant) 1 6 init ( 1 7 1 8 /* 000 NUL SPC */ "20"b3, 1 9 /* 001 SOH SPC */ "20"b3, 1 10 /* 002 STX SPC */ "20"b3, 1 11 /* 003 ETX SPC */ "20"b3, 1 12 /* 004 EOT SPC */ "20"b3, 1 13 /* 005 ENQ SPC */ "20"b3, 1 14 /* 006 ACK SPC */ "20"b3, 1 15 /* 007 BEL SPC */ "20"b3, 1 16 /* 010 BSP SPC */ "20"b3, 1 17 /* 011 HT SPC */ "20"b3, 1 18 /* 012 LF SPC */ "20"b3, 1 19 /* 013 VT SPC */ "20"b3, 1 20 /* 014 FF SPC */ "20"b3, 1 21 /* 015 CR SPC */ "20"b3, 1 22 /* 016 SO SPC */ "20"b3, 1 23 /* 017 SI SPC */ "20"b3, 1 24 /* 020 DLE SPC */ "20"b3, 1 25 /* 021 DC1 SPC */ "20"b3, 1 26 /* 022 DC2 SPC */ "20"b3, 1 27 /* 023 DC3 SPC */ "20"b3, 1 28 /* 024 DC4 SPC */ "20"b3, 1 29 /* 025 NAK SPC */ "20"b3, 1 30 /* 026 SYN SPC */ "20"b3, 1 31 /* 027 ETB SPC */ "20"b3, 1 32 /* 030 CAN SPC */ "20"b3, 1 33 /* 031 EOM SPC */ "20"b3, 1 34 /* 032 SUB SPC */ "20"b3, 1 35 /* 033 ESC SPC */ "20"b3, 1 36 /* 034 FS SPC */ "20"b3, 1 37 /* 035 GS SPC */ "20"b3, 1 38 /* 036 RS SPC */ "20"b3, 1 39 /* 037 US SPC */ "20"b3, 1 40 /* 040 SPC SPC */ "20"b3, 1 41 /* 041 "!" "!" */ "77"b3, 1 42 /* 042 """ """ */ "76"b3, 1 43 /* 043 "#" "#" */ "13"b3, 1 44 /* 044 "$" "$" */ "53"b3, 1 45 /* 045 "%" "%" */ "74"b3, 1 46 /* 046 "&" "&" */ "32"b3, 1 47 /* 047 "'" "'" */ "57"b3, 1 48 /* 050 "(" "(" */ "35"b3, 1 49 /* 051 ")" ")" */ "55"b3, 1 50 /* 052 "*" "*" */ "54"b3, 1 51 /* 053 "+" "+" */ "60"b3, 1 52 /* 054 "," "," */ "73"b3, 1 53 /* 055 "-" "-" */ "52"b3, 1 54 /* 056 "." "." */ "33"b3, 1 55 /* 057 "/" "/" */ "61"b3, 1 56 /* 060 "0" "0" */ "00"b3, 1 57 /* 061 "1" "1" */ "01"b3, 1 58 /* 062 "2" "2" */ "02"b3, 1 59 /* 063 "3" "3" */ "03"b3, 1 60 /* 064 "4" "4" */ "04"b3, 1 61 /* 065 "5" "5" */ "05"b3, 1 62 /* 066 "6" "6" */ "06"b3, 1 63 /* 067 "7" "7" */ "07"b3, 1 64 /* 070 "8" "8" */ "10"b3, 1 65 /* 071 "9" "9" */ "11"b3, 1 66 /* 072 ":" ":" */ "15"b3, 1 67 /* 073 ";" ";" */ "56"b3, 1 68 /* 074 "<" "<" */ "36"b3, 1 69 /* 075 "=" "=" */ "75"b3, 1 70 /* 076 ">" ">" */ "16"b3, 1 71 /* 077 "?" "?" */ "17"b3, 1 72 /* 100 "@" "@" */ "14"b3, 1 73 /* 101 "A" "A" */ "21"b3, 1 74 /* 102 "B" "B" */ "22"b3, 1 75 /* 103 "C" "C" */ "23"b3, 1 76 /* 104 "D" "D" */ "24"b3, 1 77 /* 105 "E" "E" */ "25"b3, 1 78 /* 106 "F" "F" */ "26"b3, 1 79 /* 107 "G" "G" */ "27"b3, 1 80 /* 110 "H" "H" */ "30"b3, 1 81 /* 111 "I" "I" */ "31"b3, 1 82 /* 112 "J" "J" */ "41"b3, 1 83 /* 113 "K" "K" */ "42"b3, 1 84 /* 114 "L" "L" */ "43"b3, 1 85 /* 115 "M" "M" */ "44"b3, 1 86 /* 116 "N" "N" */ "45"b3, 1 87 /* 117 "O" "O" */ "46"b3, 1 88 /* 120 "P" "P" */ "47"b3, 1 89 /* 121 "Q" "Q" */ "50"b3, 1 90 /* 122 "R" "R" */ "51"b3, 1 91 /* 123 "S" "S" */ "62"b3, 1 92 /* 124 "T" "T" */ "63"b3, 1 93 /* 125 "U" "U" */ "64"b3, 1 94 /* 126 "V" "V" */ "65"b3, 1 95 /* 127 "W" "W" */ "66"b3, 1 96 /* 130 "X" "X" */ "67"b3, 1 97 /* 131 "Y" "Y" */ "70"b3, 1 98 /* 132 "Z" "Z" */ "71"b3, 1 99 /* 133 "[" "[" */ "12"b3, 1 100 /* 134 "\" "\" */ "37"b3, 1 101 /* 135 "]" "]" */ "34"b3, 1 102 /* 136 "^" "^" */ "40"b3, 1 103 /* 137 "_" "_" */ "72"b3, 1 104 /* 140 "`" "@" */ "14"b3, 1 105 /* 141 "a" "A" */ "21"b3, 1 106 /* 142 "b" "B" */ "22"b3, 1 107 /* 143 "c" "C" */ "23"b3, 1 108 /* 144 "d" "D" */ "24"b3, 1 109 /* 145 "e" "E" */ "25"b3, 1 110 /* 146 "f" "F" */ "26"b3, 1 111 /* 147 "g" "G" */ "27"b3, 1 112 /* 150 "h" "H" */ "30"b3, 1 113 /* 151 "i" "I" */ "31"b3, 1 114 /* 152 "j" "J" */ "41"b3, 1 115 /* 153 "k" "K" */ "42"b3, 1 116 /* 154 "l" "L" */ "43"b3, 1 117 /* 155 "m" "M" */ "44"b3, 1 118 /* 156 "n" "N" */ "45"b3, 1 119 /* 157 "o" "O" */ "46"b3, 1 120 /* 160 "p" "P" */ "47"b3, 1 121 /* 161 "q" "Q" */ "50"b3, 1 122 /* 162 "r" "R" */ "51"b3, 1 123 /* 163 "s" "S" */ "62"b3, 1 124 /* 164 "t" "T" */ "63"b3, 1 125 /* 165 "u" "U" */ "64"b3, 1 126 /* 166 "v" "V" */ "65"b3, 1 127 /* 167 "w" "W" */ "66"b3, 1 128 /* 170 "x" "X" */ "67"b3, 1 129 /* 171 "y" "Y" */ "70"b3, 1 130 /* 172 "z" "Z" */ "71"b3, 1 131 /* 173 "{" "[" */ "12"b3, 1 132 /* 174 "|" SPC */ "20"b3, 1 133 /* 175 "}" "]" */ "34"b3, 1 134 /* 176 "~" SPC */ "20"b3, 1 135 /* 177 DEL SPC */ "20"b3 1 136 1 137 ); 1 138 1 139 /* END OF: asc_to_bcd_table.incl.pl1 * * * * * * * * * * * * * * * * */ 624 625 626 627 end gcos_label_tape; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/19/82 0918.5 gcos_label_tape.pl1 >spec>on>11/19/82>gcos_label_tape.pl1 624 1 06/07/82 1626.8 asc_to_bcd_table.incl.pl1 >ldd>include>asc_to_bcd_table.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. MYNAME 000026 constant char(10) initial unaligned dcl 578 set ref 104* 159* 190* 209* 281* 290* 295* 310* 341* 366* 380* 386* 406* 424* 449* 465* 486* 504* addr builtin function dcl 529 ref 98 100 100 104 113 249 268 274 293 308 330 379 379 arg based char unaligned dcl 219 set ref 199 201* 204* arg_count 000100 automatic fixed bin(17,0) dcl 530 set ref 186* 194 194 arg_len 000101 automatic fixed bin(21,0) dcl 531 set ref 196* 199 201 201 204 204 arg_list_ptr parameter pointer dcl 183 in procedure "get_args" set ref 181 186* 196* arg_list_ptr 000102 automatic pointer dcl 532 in procedure "gclt" set ref 65* 66* arg_no 000104 automatic fixed bin(17,0) dcl 533 set ref 194* 196* 404 arg_ptr 000106 automatic pointer dcl 534 set ref 196* 199 201 204 asc_to_bcd_table 000000 constant bit(6) initial array unaligned dcl 1-3 ref 98 100 ascii_cr_date 000110 automatic char(6) unaligned dcl 535 set ref 134 256* ascii_inst_id 000112 automatic char(20) unaligned dcl 536 set ref 134* 258* atd_string based char(60) unaligned dcl 537 set ref 249* 330* atd_structure 000204 automatic structure level 1 dcl 605 set ref 249 330 blanks 15 000166 automatic bit(36) level 2 packed unaligned dcl 592 set ref 134* block_size 10(27) 000204 automatic char(11) level 2 packed unaligned dcl 605 set ref 253* blurb 12 000166 automatic bit(108) level 2 packed unaligned dcl 592 set ref 134* char builtin function dcl 539 ref 173 cleanup 000120 stack reference condition dcl 540 ref 59 clock_ 000010 constant entry external dcl 541 ref 234 clock_reading 000126 automatic fixed bin(71,0) dcl 542 set ref 171* 234* 519* code 000130 automatic fixed bin(35,0) dcl 543 set ref 150* 155* 156* 157* 159 159* 186* 188 190* 196* 197 266* 268 268* 272 276* 281* 284 290* 330* 331 331* 334 334* 337 337* 341 341* 345 351* 356 357* 360 360* 363 363* 366 366* 371 379* 380 380* 385* 386 386* 392* 394 com_err_ 000012 constant entry external dcl 544 ref 104 159 190 209 281 290 341 366 380 386 406 424 449 465 486 504 com_err_$suppress_name 000014 constant entry external dcl 545 ref 295 310 compare_buffer 000131 automatic bit(504) dcl 546 set ref 240* 268 274 308 counter 000147 automatic fixed bin(17,0) dcl 547 set ref 95* 98 100 100 104* 111* 113* creation_date 6 000166 automatic bit(36) level 2 packed unaligned dcl 592 set ref 134* ctl_arg parameter char unaligned dcl 400 set ref 398 413 413 416 416 419 421 424* cu_$arg_count_rel 000016 constant entry external dcl 548 ref 186 cu_$arg_list_ptr 000020 constant entry external dcl 549 ref 65 cu_$arg_ptr_rel 000022 constant entry external dcl 550 ref 196 date_string 000362 automatic char(50) unaligned dcl 525 set ref 519* 521 date_time_ 000026 constant entry external dcl 552 ref 519 datebin_$dayr_clk 000024 constant entry external dcl 551 ref 171 density 13(27) 000204 automatic char(13) level 2 in structure "atd_structure" packed unaligned dcl 605 in procedure "gclt" set ref 254* 500* density 0(02) 000223 automatic bit(1) level 2 in structure "expect" packed unaligned dcl 618 in procedure "gclt" set ref 413* 491 501* dim 000204 automatic char(11) level 2 packed unaligned dcl 605 set ref 250* dump_overlay based bit(36) array unaligned dcl 553 set ref 295* 295* 295* 295* 295* 295* 295* 295* 295* 295* 295* 295* 295* 295* 310* 310* 310* 310* 310* 310* 310* 310* 310* 310* 310* 310* 310* 310* erase 000150 automatic bit(1) unaligned dcl 554 set ref 236* 353 419* 421* error 000151 automatic bit(1) unaligned dcl 555 in procedure "gclt" set ref 443* 451* 467* 487* 508* 513 error 000262 automatic bit(1) unaligned dcl 220 in procedure "get_args" set ref 185* 191* 194 201* 204* 212* 215 error 000344 automatic bit(1) unaligned dcl 435 in procedure "valid_ctl_arg" set ref 402* 408* 426* 431 error 000232 automatic bit(1) unaligned dcl 120 in procedure "asc_to_bcd" set ref 90* 95 107* 111 116 error_table_$bad_arg 000030 external static fixed bin(35,0) dcl 556 set ref 424* error_table_$bad_conversion 000032 external static fixed bin(35,0) dcl 557 set ref 104* error_table_$bad_label 000034 external static fixed bin(35,0) dcl 558 ref 276 error_table_$bigarg 000036 external static fixed bin(35,0) dcl 559 set ref 449* 465* error_table_$noarg 000040 external static fixed bin(35,0) dcl 560 set ref 209* 406* error_table_$not_attached 000042 external static fixed bin(35,0) dcl 561 ref 392 error_table_$tape_error 000044 external static fixed bin(35,0) dcl 562 ref 360 expect 000223 automatic structure level 1 dcl 618 set ref 244* field_length parameter fixed bin(17,0) dcl 85 ref 78 92 111 file_name 10 000166 automatic bit(72) level 2 packed unaligned dcl 592 set ref 134* file_serial_number 4 000166 automatic bit(36) level 2 packed unaligned dcl 592 set ref 134* fill_count 000152 automatic fixed bin(17,0) dcl 563 set ref 91* 101* 101 111 hbound builtin function dcl 564 ref 98 in_char based fixed bin(9,0) array unsigned unaligned dcl 121 set ref 98 100 104* in_string parameter char unaligned dcl 86 set ref 78 92 98 100 104 installation_id 2 000166 automatic bit(36) level 2 packed unaligned dcl 592 set ref 134* ioa_ 000046 constant entry external dcl 565 ref 225 iocb_ptr 000154 automatic pointer dcl 566 set ref 152 155* 156* 157* 238* 266* 268* 330* 331* 334* 357* 363* 379* 385* iox_$attach_name 000050 constant entry external dcl 567 ref 330 iox_$close 000052 constant entry external dcl 568 ref 155 iox_$control 000054 constant entry external dcl 569 ref 266 334 357 363 385 iox_$destroy_iocb 000056 constant entry external dcl 570 ref 157 iox_$detach_iocb 000060 constant entry external dcl 571 ref 156 iox_$open 000062 constant entry external dcl 572 ref 331 iox_$read_record 000064 constant entry external dcl 573 ref 268 iox_$write_record 000066 constant entry external dcl 574 ref 379 label_id 000166 automatic bit(72) level 2 packed unaligned dcl 592 set ref 134* length builtin function dcl 575 ref 92 447 463 ltrim builtin function dcl 576 ref 173 max_xlate 000233 automatic fixed bin(17,0) dcl 123 set ref 92* 95 min builtin function dcl 577 ref 92 new_vol_id 0(01) 000223 automatic bit(1) level 2 in structure "expect" packed unaligned dcl 618 in procedure "gclt" set ref 202* 456* 461 472* new_vol_id 000156 automatic char(6) unaligned dcl 581 in procedure "gclt" set ref 131 131* 134 134 225* 247* 471* null builtin function dcl 582 ref 152 238 266 330 330 334 357 357 363 385 num_day 000252 automatic fixed bin(17,0) dcl 177 set ref 171* 173 out_char based bit(6) array unaligned dcl 124 set ref 100* 113* out_string parameter bit unaligned dcl 87 set ref 78 100 113 overlay_ptr 000160 automatic pointer dcl 583 set ref 293* 295 295 295 295 295 295 295 295 295 295 295 295 295 295 308* 310 310 310 310 310 310 310 310 310 310 310 310 310 310 reel_id 000223 automatic bit(1) level 2 packed unaligned dcl 618 set ref 245* 445 457* reel_sequence_number 5 000166 automatic bit(36) level 2 packed unaligned dcl 592 set ref 134* return_count 000162 automatic fixed bin(21,0) dcl 584 set ref 268* rtrim builtin function dcl 585 ref 92 329 447 455 463 471 481 500 stream_name 000163 automatic char(12) unaligned dcl 586 set ref 159* 329* 330* substr builtin function dcl 588 ref 199 521 system_info_$installation_id 000070 constant entry external dcl 587 ref 258 tape_label 000166 automatic structure level 1 dcl 592 set ref 242* 274 293 379 379 tape_label_string based bit(504) unaligned dcl 589 ref 274 tape_serial_number 3 000166 automatic bit(36) level 2 packed unaligned dcl 592 set ref 134* track 0(03) 000223 automatic bit(1) level 2 packed unaligned dcl 618 set ref 416* 476 482* tracks 4(27) 000204 automatic char(8) level 2 packed unaligned dcl 605 set ref 251* 481* unspec builtin function dcl 590 set ref 240* 242* 244* vanilla_arg parameter char unaligned dcl 441 set ref 439 447 455 463 471 478 478 481 493 493 493 493 493 500 504* vol_id 3 000204 automatic char(6) level 2 packed unaligned dcl 605 set ref 131 225* 329 455* write 7 000204 automatic char(6) level 2 packed unaligned dcl 605 set ref 252* NAMES DECLARED BY EXPLICIT CONTEXT. asc_to_bcd 000567 constant entry internal dcl 78 ref 134 134 134 134 134 134 134 134 134 built_label 000770 constant entry internal dcl 129 ref 66 close_file 001173 constant entry internal dcl 148 ref 61 72 day_of_year 001276 constant entry internal dcl 169 ref 256 exit_gclt 000565 constant label dcl 74 ref 62 gclt 000464 constant entry external dcl 6 gcos_label_tape 000473 constant entry external dcl 6 get_args 001343 constant entry internal dcl 181 ref 66 goodie_message 001557 constant entry internal dcl 223 ref 66 init_routine 001604 constant entry internal dcl 232 ref 57 label_ok 001705 constant entry internal dcl 264 ref 66 print_label_contents 002034 constant entry internal dcl 288 ref 277 tape_attached 002270 constant entry internal dcl 327 ref 377 tape_erased 002477 constant entry internal dcl 349 ref 337 tape_labeled 002633 constant entry internal dcl 375 ref 66 valid_ctl_arg 003007 constant entry internal dcl 398 ref 201 valid_vanilla_arg 003166 constant entry internal dcl 439 ref 204 year_num 003565 constant entry internal dcl 517 ref 256 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 4440 4532 4126 4450 Length 5014 4126 72 245 312 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME gclt 812 external procedure is an external procedure. on unit on line 59 64 on unit asc_to_bcd internal procedure shares stack frame of external procedure gclt. built_label internal procedure shares stack frame of external procedure gclt. close_file 98 internal procedure is called by several nonquick procedures. day_of_year internal procedure shares stack frame of external procedure gclt. get_args internal procedure shares stack frame of external procedure gclt. goodie_message internal procedure shares stack frame of external procedure gclt. init_routine internal procedure shares stack frame of external procedure gclt. label_ok internal procedure shares stack frame of external procedure gclt. print_label_contents internal procedure shares stack frame of external procedure gclt. tape_attached internal procedure shares stack frame of external procedure gclt. tape_erased internal procedure shares stack frame of external procedure gclt. tape_labeled internal procedure shares stack frame of external procedure gclt. valid_ctl_arg internal procedure shares stack frame of external procedure gclt. valid_vanilla_arg internal procedure shares stack frame of external procedure gclt. year_num internal procedure shares stack frame of external procedure gclt. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME gclt 000100 arg_count gclt 000101 arg_len gclt 000102 arg_list_ptr gclt 000104 arg_no gclt 000106 arg_ptr gclt 000110 ascii_cr_date gclt 000112 ascii_inst_id gclt 000126 clock_reading gclt 000130 code gclt 000131 compare_buffer gclt 000147 counter gclt 000150 erase gclt 000151 error gclt 000152 fill_count gclt 000154 iocb_ptr gclt 000156 new_vol_id gclt 000160 overlay_ptr gclt 000162 return_count gclt 000163 stream_name gclt 000166 tape_label gclt 000204 atd_structure gclt 000223 expect gclt 000232 error asc_to_bcd 000233 max_xlate asc_to_bcd 000252 num_day day_of_year 000262 error get_args 000344 error valid_ctl_arg 000362 date_string year_num THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as alloc_cs call_ext_out_desc call_ext_out call_int_this call_int_other return tra_ext enable shorten_stack ext_entry int_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. clock_ com_err_ com_err_$suppress_name cu_$arg_count_rel cu_$arg_list_ptr cu_$arg_ptr_rel date_time_ datebin_$dayr_clk ioa_ iox_$attach_name iox_$close iox_$control iox_$destroy_iocb iox_$detach_iocb iox_$open iox_$read_record iox_$write_record system_info_$installation_id THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$bad_arg error_table_$bad_conversion error_table_$bad_label error_table_$bigarg error_table_$noarg error_table_$not_attached error_table_$tape_error LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 6 000463 57 000500 59 000501 61 000515 62 000522 65 000525 66 000534 72 000561 74 000565 76 000566 78 000567 90 000605 91 000606 92 000607 95 000627 98 000637 100 000654 101 000667 102 000670 104 000671 107 000727 109 000731 111 000733 113 000746 114 000755 116 000757 129 000770 131 000772 134 001007 144 001164 148 001172 150 001200 152 001202 155 001206 156 001216 157 001230 159 001242 165 001275 169 001276 171 001300 173 001311 181 001343 185 001345 186 001346 188 001362 190 001364 191 001401 194 001403 196 001415 197 001435 199 001437 201 001444 202 001467 203 001471 204 001472 206 001515 209 001520 212 001544 215 001546 223 001557 225 001560 229 001603 232 001604 234 001605 236 001614 238 001615 240 001617 242 001622 244 001625 245 001626 247 001630 249 001633 250 001636 251 001641 252 001644 253 001647 254 001652 256 001655 258 001673 260 001704 264 001705 266 001707 268 001737 272 001764 274 001766 276 001772 277 001775 279 001776 281 001777 284 002023 288 002034 290 002035 293 002061 295 002063 308 002164 310 002166 323 002267 327 002270 329 002272 330 002320 331 002353 334 002376 337 002430 341 002440 345 002466 349 002477 351 002501 353 002502 356 002504 357 002506 358 002536 360 002537 363 002543 366 002574 371 002622 375 002633 377 002635 379 002642 380 002663 385 002712 386 002744 390 002772 392 002773 394 002776 398 003007 402 003020 404 003021 406 003024 408 003050 409 003052 413 003053 416 003071 419 003104 421 003113 424 003121 426 003153 431 003155 439 003166 443 003177 445 003200 447 003203 449 003221 451 003245 452 003247 455 003250 456 003253 457 003255 459 003257 461 003260 463 003263 465 003301 467 003325 468 003327 471 003330 472 003333 474 003335 476 003336 478 003341 481 003353 482 003401 483 003404 486 003405 487 003432 489 003434 491 003435 493 003440 500 003466 501 003514 502 003517 504 003520 508 003552 513 003554 517 003565 519 003567 521 003604 ----------------------------------------------------------- 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