COMPILATION LISTING OF SEGMENT gcos_set_environment Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell Multics Op. - System M Compiled on: 12/10/84 1211.9 mst Mon Options: optimize map 1 /* ************************************************************* 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* * Copyright (c) 1979 by Honeywell Information Systems, Inc. * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* ************************************************************* */ 11 12 gcos_set_environment: gse: proc; 13 14 /* * Set process environment for GCOS TIME-SHARING on Multics 15* 16* Authors: Robert J. Grimes Created 17* Albert N. Kepner 1978 18* Robert M. May 19* David B. Ward 20* * */ 21 22 if gse_already_called then do; 23 call com_err_ ( 24 0 25 , "gcos_set_environment" 26 , "gse can not be recursively called.^/release or new_proc if not already in gse." 27 ); 28 return; 29 end; 30 on cleanup gse_already_called = "0"b; 31 gse_already_called = "1"b; 32 33 /* First-time-only initialization. */ 34 35 if ^gse_initialized then do; 36 gse_ext_$drm_rule = 0; 37 addr (gse_ext_$modes) -> mode_overlay = default_modes; 38 gse_ext_$umc_name = ""; 39 gse_ext_$smc_pathname = ""; 40 gse_ext_$gcos_debug_pathname = ""; 41 gse_initialized = "1"b; 42 end; 43 44 /* * Obtain list of arguments pointers and lengths. * */ 45 call cu_$arg_count (nargs); 46 if nargs>hbound (arg_p, 1) then do; 47 call com_err_ ( 48 0 49 , "gcos_set_environment" 50 , "Only ^i arguments allowed. Quitting." 51 , hbound (args 52 , 1) 53 ); 54 gse_already_called = "0"b; 55 return; 56 end; 57 do i = 1 to nargs; 58 call cu_$arg_ptr (i, arg_p (i), arg_l (i), code); 59 if code ^= 0 then do; 60 call com_err_ ( 61 code 62 , "gcos_set_environment" 63 , "Argument ^i. Quitting." 64 , i 65 ); 66 gse_already_called = "0"b; 67 return; 68 end; 69 end; 70 call arguments; 71 if ^argument_error then do; 72 on cleanup call record_static_changes; 73 call record_static_changes; 74 end; 75 if print then call print_environment_values; 76 gse_already_called = "0"b; 77 return; 78 79 dbpn: entry (dpn); 80 81 /* Return pathname of debug file. */ 82 dcl dpn char(168)var parm; 83 dpn = rtrim (gse_ext_$gcos_debug_pathname); 84 return; 85 86 set_dbpn: entry (new_dpn); 87 88 /* Reset pathname of debug file. */ 89 dcl new_dpn char(168)parm; 90 gse_ext_$gcos_debug_pathname = new_dpn; 91 return; 92 93 arguments: proc; 94 95 /* Initialization for processing arguments */ 96 usage_flag, argument_error = "0"b; 97 drm_rule = 0; 98 gcos_debug_pathname = ""; 99 expanded_table_name = ""; 100 string (modes_given) = "0"b; 101 print = "0"b; 102 reset = "0"b; 103 smc_pathname = ""; 104 umc_name = ""; 105 internal_modes = mode_array; 106 107 if nargs <= 0 then do; 108 usage_flag, argument_error = "1"b; 109 call com_err_ ( 110 error_table_$noarg 111 , "gcos_set_environment" 112 ); 113 end; 114 115 do i = 1 to nargs; 116 pp = arg_p (i); 117 lp = arg_l (i); 118 119 /* Make sure we have a control argument. */ 120 if lp <= 0 then go to end_arg_case; 121 if substr (option_arg, 1, 1) ^= "-" then do; 122 unrecognized_arg: ; 123 usage_flag, argument_error = "1"b; 124 call com_err_ ( 125 error_table_$bad_arg 126 , "gcos_set_environment" 127 , """^a""" 128 , option_arg 129 ); 130 go to end_arg_case; 131 end; 132 j = min (length (arg), lp-1); 133 arg = substr (option_arg, 2, j); 134 135 /* Perform a binary search for this control argument over the table T */ 136 f = 1; 137 l = hbound (T, 1); 138 do while (f <= l); 139 m = divide (f+l, 2, 24, 0); 140 if arg = T (m) then do; 141 j = Transfer (m); 142 go to arg_case (j); 143 end; 144 if arg < T (m) then l = m-1; 145 else f = m + 1; 146 end; 147 go to unrecognized_arg; 148 149 arg_case (1): ; /* -directory_mapping */ 150 151 if drm_rule ^= 0 then do; 152 argument_error = "1"b; 153 call com_err_ ( 154 error_table_$inconsistent 155 , "gcos_set_environment" 156 , "^/The -directory_mapping control argument may not" 157 ||"^/occur more than once in the argument list." 158 ); 159 i = i + 1; /* move on to next argument */ 160 go to end_arg_case; 161 end; 162 163 if i < nargs then do; 164 pp2 = arg_p (i+1); 165 lp2 = arg_l (i+1); 166 if lp2 <= 0 then go to missing_drm; 167 if substr (next_arg, 1, 1) = "-" 168 then go to missing_drm; 169 do j = 1 to hbound (drm_args, 1); 170 if drm_args (j) = next_arg then do; 171 drm_rule = j; 172 i = i + 1; /* move on to next argument */ 173 go to end_arg_case; 174 end; 175 end; 176 usage_flag, argument_error = "1"b; 177 call com_err_ ( 178 error_table_$bad_arg 179 , "gcos_set_environment" 180 , "^/The -directory_mapping control argument must be" 181 ||"^/followed by ""umc"", ""smc"", or ""wd""--not ""^a""." 182 , next_arg 183 ); 184 i = i + 1; /* move on to next argument */ 185 go to end_arg_case; 186 end; 187 missing_drm: ; 188 usage_flag, argument_error = "1"b; 189 call com_err_ ( 190 error_table_$noarg 191 , "gcos_set_environment" 192 , "^/The -directory_mapping control argument must be" 193 ||"^/followed by ""umc"",""smc"", or ""wd""." 194 ); 195 go to end_arg_case; 196 197 arg_case (2): ; /* -gcos_debug_pathname */ 198 199 if gcos_debug_pathname ^= "" then do; 200 argument_error = "1"b; 201 call com_err_ ( 202 error_table_$inconsistent 203 , "gcos_set_environment" 204 , "The -gcos_debug_pathname control argument may not" 205 ||"^/occur more than once in the argument list." 206 ); 207 i = i + 1; /* move on to next argument */ 208 go to end_arg_case; 209 end; 210 211 if i < nargs then do; 212 pp2 = arg_p (i+1); 213 lp2 = arg_l (i+1); 214 if lp2 <= 0 then go to default_gdbpn; 215 if substr (next_arg, 1, 1) = "-" 216 then go to default_gdbpn; 217 gcos_debug_pathname = next_arg; 218 if lp2 > 168 then do; 219 argument_error = "1"b; 220 call com_err_ ( 221 error_table_$pathlong 222 , "gcos_set_environment" 223 , """^a""" 224 , next_arg 225 ); 226 end; 227 i = i + 1; /* move on to next argument */ 228 go to end_arg_case; 229 end; 230 231 default_gdbpn: ; 232 233 /* Default gcos_debug control file is Person_id.gdb in user's home directory. */ 234 call default_debug_pathname; 235 go to end_arg_case; 236 237 arg_case (3): ; /* -modes */ 238 239 if i < nargs then do; 240 pp2 = arg_p (i+1); 241 lp2 = arg_l (i+1); 242 if lp2 <= 0 then go to modes_missing; 243 if substr (next_arg, 1, 1) = "-" then goto modes_missing; 244 j = 1; 245 remaining_modes = next_arg; 246 do while (j > 0); 247 j = index (remaining_modes, ","); 248 if j = 0 then this_mode = remaining_modes; 249 else do; 250 this_mode = substr (remaining_modes, 1, j-1); 251 remaining_modes = substr (remaining_modes, j+1); 252 end; 253 if this_mode = "" 254 then mode_name = ""; 255 else do; 256 mode_switch = (substr (this_mode, 1, 1) ^= "^"); 257 if mode_switch 258 then mode_name = this_mode; 259 else mode_name = substr (this_mode, 2); 260 end; 261 do k = 1 to hbound (modes, 1); 262 if mode_name = modes (k) then do; 263 if modes_given (k) then do; 264 argument_error = "1"b; 265 call com_err_ ( 266 error_table_$inconsistent 267 , "gcos_set_environment" 268 , "^/Mode ""^a"" is repeated in modes_string." 269 , mode_name 270 ); 271 end; 272 else modes_given (k) = "1"b; 273 internal_modes (k) = mode_switch; 274 go to next_mode; 275 end; 276 end; 277 argument_error = "1"b; 278 call com_err_ ( 279 error_table_$bad_arg 280 , "gcos_set_environment" 281 , "^/Mode ""^a"" not recognized." 282 ||"^/Valid modes are: ast,drl,gdb,mcmd,mquit,ss." 283 , this_mode 284 ); 285 next_mode: ; 286 end; 287 i = i + 1; /* move on to next argument */ 288 go to end_arg_case; 289 end; 290 modes_missing: ; 291 usage_flag, argument_error = "1"b; 292 call com_err_ ( 293 error_table_$noarg 294 , "gcos_set_environment" 295 , "^/The -modes control argument must be followed by a modes_string." 296 ||"^/Valid modes are: ast,drl,gdb,mcmd,mquit,ss." 297 ); 298 go to end_arg_case; 299 300 arg_case (4): ; /* -print */ 301 print = "1"b; 302 go to end_arg_case; 303 304 arg_case (5): ; /* -reset */ 305 reset = "1"b; 306 go to end_arg_case; 307 308 arg_case (6): ; /* -smc_pathname */ 309 310 if smc_pathname ^= "" then do; 311 argument_error = "1"b; 312 call com_err_ ( 313 error_table_$inconsistent 314 , "gcos_set_environment" 315 , "^/The -smc_pathname control argument may not occur" 316 ||"^/more than once in the argument list." 317 ); 318 i = i + 1; /* move on to next argument */ 319 go to end_arg_case; 320 end; 321 if i < nargs then do; 322 pp2 = arg_p (i + 1); 323 lp2 = arg_l (i + 1); 324 if lp2 <= 0 then go to missing_spn; 325 if substr (next_arg, 1, 1) = "-" 326 then go to missing_spn; 327 smc_pathname = next_arg; 328 if lp2 > 168 then do; 329 argument_error = "1"b; 330 call com_err_ ( 331 error_table_$pathlong 332 , "gcos_set_environment" 333 , """^a""" 334 , next_arg 335 ); 336 end; 337 i = i + 1; /* move on to next argument */ 338 go to end_arg_case; 339 end; 340 341 missing_spn: ; 342 usage_flag, argument_error = "1"b; 343 call com_err_ ( 344 error_table_$noarg 345 , "gcos_set_environment" 346 , "^/The -smc_pathname control argument must be" 347 ||"^/followed by the SMC directory name." 348 ); 349 go to end_arg_case; 350 351 arg_case (7): ; /* -umc_name */ 352 353 if umc_name ^= "" then do; 354 argument_error = "1"b; 355 call com_err_ ( 356 error_table_$inconsistent 357 , "gcos_set_environment" 358 , "^/The -umc_name control argument may not" 359 ||"^/occur more than once in the argument list." 360 ); 361 i = i + 1; /* move on to next argument */ 362 go to end_arg_case; 363 end; 364 if i < nargs then do; 365 pp2 = arg_p (i + 1); 366 lp2 = arg_l (i + 1); 367 if lp2 <= 0 then go to missing_unm; 368 if substr (next_arg, 1, 1) = "-" 369 then go to missing_unm; 370 umc_name = translate (next_arg, 371 "abcdefghijklmnopqrstuvwxyz", 372 "ABCDEFGHIJKLMNOPQRSTUVWXYZ"); 373 if lp2 > 12 then do; 374 argument_error = "1"b; 375 call com_err_ ( 376 error_table_$bigarg 377 , "gcos_set_environment" 378 , "^/The umc_name argument may not exceed 12 characters." 379 ); 380 end; 381 i = i + 1; /* move on to next argument */ 382 go to end_arg_case; 383 end; 384 385 missing_unm: ; 386 usage_flag, argument_error = "1"b; 387 call com_err_ ( 388 error_table_$noarg 389 , "gcos_set_environment" 390 , "^/The -umc_name control argument must" 391 ||"^/be followed by the UMC name." 392 ); 393 end_arg_case: ; 394 end; 395 396 397 /* Make sure all necessary control arguments have been given for the 398* directory mapping_rule specified (if any). Also check the user's access to the 399* root directory implied by the mapping_rule. */ 400 if argument_error then go to end_drm_case; 401 go to drm_case (drm_rule); 402 403 drm_case (0): ; /* no mapping rule */ 404 go to end_drm_case; 405 406 drm_case (1): ; /* umc_dir_mode */ 407 dir_name = ">udd>"||umc_name; 408 root_dir = ">udd>"||rtrim (umc_name)||">"||rtrim (umc_name); 409 if umc_name = "" then do; 410 argument_error = "1"b; 411 call com_err_ ( 412 error_table_$inconsistent 413 , "gcos_set_environment" 414 , "^/When -directory_mapping umc is specified the" 415 ||"^/-umc_name control argument must also be given." 416 ); 417 go to end_drm_case; 418 end; 419 420 check_root: ; 421 422 /* Validate the existence of and user's access to the root directory for 423* umc_dir_mode or smc_dir_mode. */ 424 entryname = umc_name; 425 call hcs_$get_user_effmode (dir_name, entryname, "", (get_ring_ ()), access_mode, code); 426 427 /* Make sure user has at least status access to root directory. */ 428 if code = 0 & access_mode < 8 429 then code = error_table_$moderr; 430 if code ^= 0 then do; 431 argument_error = "1"b; 432 call com_err_ ( 433 code 434 , "gcos_set_environment" 435 , "^/^a" 436 , root_dir 437 ); 438 end; 439 440 go to end_drm_case; 441 442 drm_case (2): ; /* working_dir_mode */ 443 go to end_drm_case; 444 445 drm_case (3): ; /* smc_dir_mode */ 446 root_dir = rtrim (smc_pathname)||">"||rtrim (umc_name); 447 call absolute_pathname_ (smc_pathname, dir_name, code); 448 if code ^= 0 then do; 449 argument_error = "1"b; 450 call com_err_ ( 451 code 452 , "gcos_set_environment" 453 , "^/^a" 454 , rtrim (smc_pathname) 455 ); 456 go to end_drm_case; 457 end; 458 if umc_name = "" | smc_pathname = "" then do; 459 argument_error = "1"b; 460 call com_err_ ( 461 error_table_$inconsistent 462 , "gcos_set_environment" 463 , "^/When -directory_mapping smc is specified the" 464 ||"^/-smc_pathname and -umc_name control arguments" 465 ||"^/must be given." 466 ); 467 go to end_drm_case; 468 end; 469 go to check_root; 470 end_drm_case: ; 471 if reset then do; 472 if string (modes_given) then do; 473 argument_error = "1"b; 474 call com_err_ ( 475 error_table_$inconsistent 476 , "gcos_set_environment" 477 , "^/The -modes and -reset control arguments are mutually exclusive." 478 ); 479 end; 480 else string (internal_modes) = default_modes; 481 end; 482 if gcos_debug_pathname ^= "" | 483 (modes_given (3) & internal_modes (3)) 484 then do; 485 if gcos_debug_pathname = "" 486 then if gse_ext_$gcos_debug_pathname = "" 487 then call default_debug_pathname; 488 else gcos_debug_pathname = gse_ext_$gcos_debug_pathname; 489 call expand_pathname_$add_suffix (gcos_debug_pathname, 490 "gdb", 491 dir_name, 492 entryname, 493 code); 494 if code ^= 0 then do; 495 argument_error = "1"b; 496 call com_err_ ( 497 code 498 , "gcos_set_environment" 499 , "^/^a" 500 , rtrim (gcos_debug_pathname) 501 ); 502 go to end_debug_code; 503 end; 504 expanded_table_name = rtrim (dir_name)||">"||entryname; 505 506 /* Create the break table if it does not already exist. */ 507 call hcs_$make_seg (dir_name, 508 entryname, 509 "", 510 10, /* rw access */ 511 seg_ptr, 512 code); 513 if code = 0 514 then do; 515 call ioa_ ("gcos_set_environment: Break table created.^/^a", 516 rtrim (expanded_table_name)); 517 call hcs_$truncate_seg (seg_ptr, 0, code); 518 if code ^= 0 then do; 519 argument_error = "1"b; 520 call com_err_ ( 521 code 522 , "gcos_set_environment" 523 , "^/^a" 524 , rtrim (expanded_table_name) 525 ); 526 go to end_debug_code; 527 end; 528 end; 529 else if seg_ptr = null () 530 then do; 531 argument_error = "1"b; 532 call com_err_ ( 533 code 534 , "gcos_set_environment" 535 , "^/^a" 536 , rtrim (expanded_table_name) 537 ); 538 go to end_debug_code; 539 end; 540 541 /* Make sure user has read and write access to break table. */ 542 call hcs_$fs_get_mode (seg_ptr, 543 access_mode, 544 code); 545 if code ^= 0 then do; 546 argument_error = "1"b; 547 call com_err_ ( 548 code 549 , "gcos_set_environment" 550 , "^/^a" 551 , rtrim (expanded_table_name) 552 ); 553 go to end_debug_code; 554 end; 555 if ^ access_mode_overlay.read | 556 ^access_mode_overlay.write then do; 557 argument_error = "1"b; 558 call com_err_ ( 559 code 560 , "gcos_set_environment" 561 , "^/^a^/The user must have read and write access on the break table segment.", 562 rtrim (expanded_table_name)); 563 end; 564 end_debug_code: ; 565 end; 566 if usage_flag then 567 call ioa_$ioa_switch ( 568 iox_$error_output 569 , "Usage: gcos_set_environment {-directory_mapping [umc|smc|wd]}" 570 ||"^/^5x{-gcos_debug_pathname path} {-modes modes_string} {-print} {-reset}" 571 ||"^/^5x{-smc_pathname path} {-umc_name name}" 572 ||"^2/At least 1 argument is required." 573 ); 574 end /* arguments */; 575 576 default_debug_pathname: proc; 577 578 /* Default gcos_debug control file is Person_id.gdb in user's home directory. */ 579 580 dcl p1 char (22); 581 dcl p2 char (9); 582 call user_info_$whoami (p1, p2, ""); 583 Person_id = rtrim (p1); 584 call user_info_$homedir (gcos_debug_pathname); 585 gcos_debug_pathname = rtrim (gcos_debug_pathname)||">"||Person_id||".gdb"; 586 end /* default_debug_pathname */; 587 588 print_environment_values: proc; 589 do i = 1 to hbound (mode_array, 1); 590 mode_name = modes (i); 591 if mode_array (i) 592 then this_mode = mode_name; 593 else this_mode = "^"||mode_name; 594 if i = 1 then remaining_modes = this_mode; 595 else remaining_modes = remaining_modes||","||this_mode; 596 end; 597 598 call ioa_ ( 599 "^/Current GCOS environment values:" 600 ||"^/^5x-modes ^a" 601 ||"^/^5x-directory_mapping ^a" 602 , remaining_modes 603 , drm_args (gse_ext_$drm_rule) 604 ); 605 if gse_ext_$drm_rule = 3 606 then call ioa_ ("^5x-smc_pathname ^a", rtrim (gse_ext_$smc_pathname)); 607 if gse_ext_$drm_rule = 1 | gse_ext_$drm_rule = 3 608 then call ioa_ ("^5x-umc_name ^a", rtrim (gse_ext_$umc_name)); 609 if gse_ext_$gcos_debug_pathname ^= "" 610 then call ioa_ ("^5x-gcos_debug_pathname ^a", rtrim (gse_ext_$gcos_debug_pathname)); 611 end; /* print_environment_values */ 612 613 record_static_changes: proc; 614 if drm_rule ^= 0 then gse_ext_$drm_rule = drm_rule; 615 mode_array = internal_modes; 616 if umc_name ^= "" then gse_ext_$umc_name = umc_name; 617 else if umc_name = "" & drm_rule = 2 then gse_ext_$umc_name = ""; 618 if smc_pathname ^= "" then gse_ext_$smc_pathname = smc_pathname; 619 if expanded_table_name ^= "" then gse_ext_$gcos_debug_pathname = expanded_table_name; 620 gse_already_called = "0"b; 621 end; /* record_static_changes */ 622 623 /* * Variables for gse: * */ 624 dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); 625 dcl access_mode fixed bin (5); 626 dcl arg char (40); 627 dcl argument_error bit (1); 628 dcl cleanup condition; 629 dcl code fixed bin (35); 630 dcl com_err_ entry options (variable); 631 dcl cu_$arg_count ext entry (fixed bin (24)); 632 dcl cu_$arg_ptr ext entry (fixed bin (24), pointer, fixed bin (24), fixed bin (35)); 633 dcl default_modes bit (6) int static options (constant) init ("100000"b); /* ast mode is on by default--others off */ 634 dcl dir_name char (168); 635 dcl drm_args (0:3) char (7) int static options (constant) init ("not_set", "umc", "wd", "smc"); 636 dcl drm_rule fixed bin (24); 637 dcl entryname char (32); 638 dcl error_table_$bad_arg fixed bin (35) ext; 639 dcl error_table_$bigarg fixed bin (35) ext; 640 dcl error_table_$inconsistent fixed bin (35) ext; 641 dcl error_table_$mdc_no_access fixed bin (35) ext; 642 dcl error_table_$moderr fixed bin (35) ext; 643 dcl error_table_$noarg fixed bin (35) ext; 644 dcl error_table_$pathlong fixed bin (35) ext; 645 dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); 646 dcl expanded_table_name char (168); 647 dcl f fixed bin (24); 648 dcl gcos_debug_pathname char (168); 649 dcl get_ring_ entry returns (fixed bin (3)); 650 dcl gse_already_called bit (1) static int init ("0"b); 651 dcl gse_initialized bit (1) static int init ("0"b); 652 dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)); 653 dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, 654 fixed bin (5), fixed bin (35)); 655 dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); 656 dcl hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)); 657 dcl i fixed bin (24); 658 dcl internal_modes (6) bit (1) int unal automatic; 659 dcl ioa_ entry options (variable); 660 dcl ioa_$ioa_switch entry options (variable); 661 dcl iox_$error_output ext ptr; 662 dcl j fixed bin (24); 663 dcl k fixed bin (24); 664 dcl l fixed bin (24); 665 dcl lp fixed bin (24); 666 dcl lp2 fixed bin (24); 667 dcl m fixed bin (24); 668 dcl mode_array (6) bit (1) unal based (addr (gse_ext_$modes)); 669 dcl mode_name char (10) varying; 670 dcl mode_overlay bit (6) unal based (addr (gse_ext_$modes)); 671 dcl mode_switch bit (1); 672 dcl modes_given (6) bit (1) unal; 673 dcl nargs fixed bin (24); 674 dcl next_arg char (lp2) based (pp2); 675 dcl option_arg char (lp) based (pp); 676 dcl pp ptr; 677 dcl pp2 ptr; 678 dcl print bit (1); 679 dcl Person_id char (22) varying; 680 dcl remaining_modes char (60) varying; 681 dcl reset bit (1); 682 dcl root_dir char (168) varying; 683 dcl seg_ptr ptr; 684 dcl smc_pathname char (168); 685 dcl this_mode char (11) varying; 686 dcl umc_name char (12) int automatic; 687 dcl usage_flag bit (1); 688 dcl user_info_$homedir entry (char (*)); 689 dcl user_info_$whoami entry (char (*), char (*), char (*)); 690 691 dcl 1 access_mode_overlay aligned based (addr (access_mode)), 692 2 fill bit (32) unal, 693 2 read bit (1) unal, 694 2 execute bit (1) unal, 695 2 write bit (1) unal, 696 2 fill2 bit (1) unal; 697 698 dcl modes (6) char (10) varying int static options (constant) 699 init ("ast", "drl", "gdb", "mcmd", "mquit", "ss"); 700 701 dcl T (13) char (20) int static options (constant) init ( /* This list must be ordered by the ascii collating seq. */ 702 /* The ordering is needed for binary search. */ 703 "directory_mapping", /* arg_case 1 */ 704 "drm", /* arg_case 1 */ 705 "gcos_debug_pathname", /* arg_case 2 */ 706 "gdbpn", /* arg_case 2 */ 707 "modes", /* arg_case 3 */ 708 "pr", /* arg_case 4 */ 709 "print", /* arg_case 4 */ 710 "reset", /* arg_case 5 */ 711 "rs", /* arg_case 5 */ 712 "smc_pathname", /* arg_case 6 */ 713 "spn", /* arg_case 6 */ 714 "umc_name", /* arg_case 7 */ 715 "unm") /* arg_case 7 */ 716 ; 717 718 dcl Transfer (13) fixed bin (24) int static options (constant) init ( 719 1, /* -directory_mapping */ 720 1, /* -drm */ 721 2, /* -gcos_debug_pathname */ 722 2, /* -gdbpn */ 723 3, /* -modes */ 724 4, /* -pr */ 725 4, /* -print */ 726 5, /* -reset */ 727 5, /* -rs */ 728 6, /* -smc_pathname */ 729 6, /* -spn */ 730 7, /* -umc_name */ 731 7) /* -unm */ 732 ; 733 734 dcl 1 args (300), 735 2 arg_p ptr, 736 2 arg_l fixed bin (24); 737 1 1 /* BEGIN INCLUDE FILE gse_ext_.incl.pl1 */ 1 2 /* 1 3* Created: Kepner 78-12-01 1 4**/ 1 5 1 6 dcl gse_ext_$drm_rule fixed bin(24) ext; 1 7 1 8 /* $drm_rule: 1 9* 0 => rule not set 1 10* 1 => umc_dir_mode 1 11* 2 => working_dir_mode 1 12* 3 => smc_dir_mode 1 13**/ 1 14 1 15 dcl gse_ext_$gcos_debug_pathname char(168) /* pathname for the gcos debugger control file */ ext; 1 16 dcl gse_ext_$smc_pathname char(168) /* root directory used with smc_dir mapping rule */ ext; 1 17 dcl gse_ext_$umc_name char(12) /* User Master Catalog name specified by user with gse command */ ext; 1 18 dcl 1 gse_ext_$modes aligned ext, 1 19 3 ast bit(01) unal, /* 1 => use asterisk as prompt character */ 1 20 3 drl bit(01) unal, /* 1 => cause trace info on each derail to be printed */ 1 21 3 gdb bit(01) unal, /* 1 => use gcos debugger (gdb) */ 1 22 3 mcmd bit(01) unal, /* 1 => allow use of e request at GTSS command level */ 1 23 3 mquit bit(01) unal, /* 1 => quit causes entry to new Multics command level */ 1 24 3 ss bit(01) unal, /* 1 => cause trace info on each subsystem to be printed */ 1 25 3 fill bit(30) unal; 1 26 1 27 /* END INCLUDE FILE gse_ext_.incl.pl1 */ 738 739 end /* gse */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 12/10/84 1042.4 gcos_set_environment.pl1 >spec>on>7105>gcos_set_environment.pl1 738 1 09/09/83 1713.4 gse_ext_.incl.pl1 >ldd>include>gse_ext_.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. Person_id 000357 automatic varying char(22) dcl 679 set ref 583* 585 T 000030 constant char(20) initial array unaligned dcl 701 ref 137 140 144 Transfer 000013 constant fixed bin(24,0) initial array dcl 718 ref 141 absolute_pathname_ 000012 constant entry external dcl 624 ref 447 access_mode 000100 automatic fixed bin(5,0) dcl 625 set ref 425* 428 542* 555 555 access_mode_overlay based structure level 1 dcl 691 arg 000101 automatic char(40) unaligned dcl 626 set ref 132 133* 140 144 arg_l 2 000546 automatic fixed bin(24,0) array level 2 dcl 734 set ref 58* 117 165 213 241 323 366 arg_p 000546 automatic pointer array level 2 dcl 734 set ref 46 58* 116 164 212 240 322 365 args 000546 automatic structure array level 1 unaligned dcl 734 set ref 47 47 argument_error 000113 automatic bit(1) unaligned dcl 627 set ref 71 96* 108* 123* 152* 176* 188* 200* 219* 264* 277* 291* 311* 329* 342* 354* 374* 386* 400 410* 431* 449* 459* 473* 495* 519* 531* 546* 557* cleanup 000114 stack reference condition dcl 628 ref 30 72 code 000122 automatic fixed bin(35,0) dcl 629 set ref 58* 59 60* 425* 428 428* 430 432* 447* 448 450* 489* 494 496* 507* 513 517* 518 520* 532* 542* 545 547* 558* com_err_ 000014 constant entry external dcl 630 ref 23 47 60 109 124 153 177 189 201 220 265 278 292 312 330 343 355 375 387 411 432 450 460 474 496 520 532 547 558 cu_$arg_count 000016 constant entry external dcl 631 ref 45 cu_$arg_ptr 000020 constant entry external dcl 632 ref 58 default_modes constant bit(6) initial unaligned dcl 633 ref 37 480 dir_name 000123 automatic char(168) unaligned dcl 634 set ref 407* 425* 447* 489* 504 507* dpn parameter varying char(168) dcl 82 set ref 79 83* drm_args 000161 constant char(7) initial array unaligned dcl 635 set ref 169 170 598* drm_rule 000175 automatic fixed bin(24,0) dcl 636 set ref 97* 151 171* 401 614 614 617 entryname 000176 automatic char(32) unaligned dcl 637 set ref 424* 425* 489* 504 507* error_table_$bad_arg 000022 external static fixed bin(35,0) dcl 638 set ref 124* 177* 278* error_table_$bigarg 000024 external static fixed bin(35,0) dcl 639 set ref 375* error_table_$inconsistent 000026 external static fixed bin(35,0) dcl 640 set ref 153* 201* 265* 312* 355* 411* 460* 474* error_table_$moderr 000030 external static fixed bin(35,0) dcl 642 ref 428 error_table_$noarg 000032 external static fixed bin(35,0) dcl 643 set ref 109* 189* 292* 343* 387* error_table_$pathlong 000034 external static fixed bin(35,0) dcl 644 set ref 220* 330* expand_pathname_$add_suffix 000036 constant entry external dcl 645 ref 489 expanded_table_name 000206 automatic char(168) unaligned dcl 646 set ref 99* 504* 515 515 520 520 532 532 547 547 558 558 619 619 f 000260 automatic fixed bin(24,0) dcl 647 set ref 136* 138 139 145* gcos_debug_pathname 000261 automatic char(168) unaligned dcl 648 set ref 98* 199 217* 482 485 488* 489* 496 496 584* 585* 585 get_ring_ 000040 constant entry external dcl 649 ref 425 gse_already_called 000010 internal static bit(1) initial unaligned dcl 650 set ref 22 30* 31* 54* 66* 76* 620* gse_ext_$drm_rule 000064 external static fixed bin(24,0) dcl 1-6 set ref 36* 598 605 607 607 614* gse_ext_$gcos_debug_pathname 000066 external static char(168) unaligned dcl 1-15 set ref 40* 83 90* 485 488 609 609 609 619* gse_ext_$modes 000074 external static structure level 1 dcl 1-18 set ref 37 105 589 591 615 gse_ext_$smc_pathname 000070 external static char(168) unaligned dcl 1-16 set ref 39* 605 605 618* gse_ext_$umc_name 000072 external static char(12) unaligned dcl 1-17 set ref 38* 607 607 616* 617* gse_initialized 000011 internal static bit(1) initial unaligned dcl 651 set ref 35 41* hcs_$fs_get_mode 000042 constant entry external dcl 652 ref 542 hcs_$get_user_effmode 000044 constant entry external dcl 653 ref 425 hcs_$make_seg 000046 constant entry external dcl 655 ref 507 hcs_$truncate_seg 000050 constant entry external dcl 656 ref 517 i 000333 automatic fixed bin(24,0) dcl 657 set ref 57* 58* 58 58 60* 115* 116 117 159* 159 163 164 165 172* 172 184* 184 207* 207 211 212 213 227* 227 239 240 241 287* 287 318* 318 321 322 323 337* 337 361* 361 364 365 366 381* 381* 589* 590 591 594* internal_modes 000334 automatic bit(1) array unaligned dcl 658 set ref 105* 273* 480* 482 615 ioa_ 000052 constant entry external dcl 659 ref 515 598 605 607 609 ioa_$ioa_switch 000054 constant entry external dcl 660 ref 566 iox_$error_output 000056 external static pointer dcl 661 set ref 566* j 000335 automatic fixed bin(24,0) dcl 662 set ref 132* 133 141* 142 169* 170 171* 244* 246 247* 248 250 251 k 000336 automatic fixed bin(24,0) dcl 663 set ref 261* 262 263 272 273* l 000337 automatic fixed bin(24,0) dcl 664 set ref 137* 138 139 144* lp 000340 automatic fixed bin(24,0) dcl 665 set ref 117* 120 121 124 124 132 133 lp2 000341 automatic fixed bin(24,0) dcl 666 set ref 165* 166 167 170 177 177 213* 214 215 217 218 220 220 241* 242 243 245 323* 324 325 327 328 330 330 366* 367 368 370 373 m 000342 automatic fixed bin(24,0) dcl 667 set ref 139* 140 141 144 144 145 mode_array based bit(1) array unaligned dcl 668 set ref 105 589 591 615* mode_name 000343 automatic varying char(10) dcl 669 set ref 253* 257* 259* 262 265* 590* 591 593 mode_overlay based bit(6) unaligned dcl 670 set ref 37* mode_switch 000347 automatic bit(1) unaligned dcl 671 set ref 256* 257 273 modes 000131 constant varying char(10) initial array dcl 698 ref 261 262 590 modes_given 000350 automatic bit(1) array unaligned dcl 672 set ref 100* 263 272* 472 482 nargs 000351 automatic fixed bin(24,0) dcl 673 set ref 45* 46 57 107 115 163 211 239 321 364 new_dpn parameter char(168) unaligned dcl 89 ref 86 90 next_arg based char unaligned dcl 674 set ref 167 170 177* 215 217 220* 243 245 325 327 330* 368 370 option_arg based char unaligned dcl 675 set ref 121 124* 133 p1 003046 automatic char(22) unaligned dcl 580 set ref 582* 583 p2 003054 automatic char(9) unaligned dcl 581 set ref 582* pp 000352 automatic pointer dcl 676 set ref 116* 121 124 133 pp2 000354 automatic pointer dcl 677 set ref 164* 167 170 177 212* 215 217 220 240* 243 245 322* 325 327 330 365* 368 370 print 000356 automatic bit(1) unaligned dcl 678 set ref 75 101* 301* read 0(32) based bit(1) level 2 packed unaligned dcl 691 ref 555 remaining_modes 000366 automatic varying char(60) dcl 680 set ref 245* 247 248 250 251* 251 594* 595* 595 598* reset 000406 automatic bit(1) unaligned dcl 681 set ref 102* 305* 471 root_dir 000407 automatic varying char(168) dcl 682 set ref 408* 432* 446* seg_ptr 000462 automatic pointer dcl 683 set ref 507* 517* 529 542* smc_pathname 000464 automatic char(168) unaligned dcl 684 set ref 103* 310 327* 446 447* 450 450 458 618 618 this_mode 000536 automatic varying char(11) dcl 685 set ref 248* 250* 253 256 257 259 278* 591* 593* 594 595 umc_name 000542 automatic char(12) unaligned dcl 686 set ref 104* 353 370* 407 408 408 409 424 446 458 616 616 617 usage_flag 000545 automatic bit(1) unaligned dcl 687 set ref 96* 108* 123* 176* 188* 291* 342* 386* 566 user_info_$homedir 000060 constant entry external dcl 688 ref 584 user_info_$whoami 000062 constant entry external dcl 689 ref 582 write 0(34) based bit(1) level 2 packed unaligned dcl 691 ref 555 NAME DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. error_table_$mdc_no_access external static fixed bin(35,0) dcl 641 NAMES DECLARED BY EXPLICIT CONTEXT. arg_case 000000 constant label array(7) dcl 149 ref 142 arguments 001617 constant entry internal dcl 93 ref 70 check_root 003406 constant label dcl 420 set ref 469 dbpn 001544 constant entry external dcl 79 default_debug_pathname 004704 constant entry internal dcl 576 ref 234 485 default_gdbpn 002347 constant label dcl 231 ref 214 215 drm_case 000007 constant label array(0:3) dcl 403 ref 401 end_arg_case 003245 constant label dcl 393 ref 120 130 160 173 185 195 208 228 235 288 298 302 306 319 338 349 362 382 end_debug_code 004660 constant label dcl 564 ref 502 526 538 553 end_drm_case 003754 constant label dcl 470 ref 400 404 417 440 443 456 467 gcos_set_environment 001232 constant entry external dcl 12 gse 001223 constant entry external dcl 12 missing_drm 002171 constant label dcl 187 ref 166 167 missing_spn 003033 constant label dcl 341 ref 324 325 missing_unm 003212 constant label dcl 385 ref 367 368 modes_missing 002645 constant label dcl 290 set ref 242 243 next_mode 002641 constant label dcl 285 ref 274 print_environment_values 005031 constant entry internal dcl 588 ref 75 record_static_changes 005400 constant entry internal dcl 613 ref 72 73 set_dbpn 001602 constant entry external dcl 86 unrecognized_arg 001717 constant label dcl 122 ref 147 NAMES DECLARED BY CONTEXT OR IMPLICATION. addr builtin function ref 37 105 555 555 589 591 615 divide builtin function ref 139 hbound builtin function ref 46 47 47 137 169 261 589 index builtin function ref 247 length builtin function ref 132 min builtin function ref 132 null builtin function ref 529 rtrim builtin function ref 83 408 408 446 446 450 450 496 496 504 515 515 520 520 532 532 547 547 558 558 583 585 605 605 607 607 609 609 string builtin function set ref 100 472 480* substr builtin function ref 121 133 167 215 243 250 251 256 259 325 368 translate builtin function ref 370 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 6244 6342 5667 6254 Length 6654 5667 76 276 354 2 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME gse 1830 external procedure is an external procedure. on unit on line 30 64 on unit on unit on line 72 64 on unit arguments internal procedure shares stack frame of external procedure gse. default_debug_pathname internal procedure shares stack frame of external procedure gse. print_environment_values internal procedure shares stack frame of external procedure gse. record_static_changes 64 internal procedure is called by several nonquick procedures. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 gse_already_called gse 000011 gse_initialized gse STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME gse 000100 access_mode gse 000101 arg gse 000113 argument_error gse 000122 code gse 000123 dir_name gse 000175 drm_rule gse 000176 entryname gse 000206 expanded_table_name gse 000260 f gse 000261 gcos_debug_pathname gse 000333 i gse 000334 internal_modes gse 000335 j gse 000336 k gse 000337 l gse 000340 lp gse 000341 lp2 gse 000342 m gse 000343 mode_name gse 000347 mode_switch gse 000350 modes_given gse 000351 nargs gse 000352 pp gse 000354 pp2 gse 000356 print gse 000357 Person_id gse 000366 remaining_modes gse 000406 reset gse 000407 root_dir gse 000462 seg_ptr gse 000464 smc_pathname gse 000536 this_mode gse 000542 umc_name gse 000545 usage_flag gse 000546 args gse 003046 p1 default_debug_pathname 003054 p2 default_debug_pathname THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_ne_as alloc_cs cat_realloc_cs call_ext_out_desc call_ext_out call_int_this call_int_other return enable shorten_stack ext_entry int_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. absolute_pathname_ com_err_ cu_$arg_count cu_$arg_ptr expand_pathname_$add_suffix get_ring_ hcs_$fs_get_mode hcs_$get_user_effmode hcs_$make_seg hcs_$truncate_seg ioa_ ioa_$ioa_switch user_info_$homedir user_info_$whoami THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$bad_arg error_table_$bigarg error_table_$inconsistent error_table_$moderr error_table_$noarg error_table_$pathlong gse_ext_$drm_rule gse_ext_$gcos_debug_pathname gse_ext_$modes gse_ext_$smc_pathname gse_ext_$umc_name iox_$error_output LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 12 001222 22 001237 23 001241 28 001270 30 001271 31 001307 35 001312 36 001314 37 001315 38 001320 39 001324 40 001330 41 001334 45 001336 46 001344 47 001347 54 001405 55 001407 57 001410 58 001417 59 001435 60 001437 66 001475 67 001477 69 001500 70 001502 71 001503 72 001505 73 001527 75 001533 76 001536 77 001540 79 001541 83 001551 84 001576 86 001577 90 001607 91 001616 93 001617 96 001620 97 001622 98 001623 99 001626 100 001631 101 001633 102 001634 103 001635 104 001640 105 001643 107 001651 108 001653 109 001656 115 001675 116 001705 117 001710 120 001712 121 001713 122 001717 123 001720 124 001723 130 001760 132 001761 133 001766 136 001771 137 001773 138 001775 139 002001 140 002004 141 002013 142 002016 144 002017 145 002024 146 002027 147 002030 149 002031 151 002032 152 002034 153 002036 159 002065 160 002066 163 002067 164 002072 165 002075 166 002077 167 002100 169 002104 170 002111 171 002120 172 002122 173 002123 175 002124 176 002126 177 002131 184 002167 185 002170 187 002171 188 002172 189 002175 195 002224 197 002225 199 002226 200 002232 201 002234 207 002263 208 002264 211 002265 212 002270 213 002273 214 002275 215 002276 217 002302 218 002305 219 002307 220 002311 227 002345 228 002346 231 002347 234 002350 235 002351 237 002352 239 002353 240 002356 241 002361 242 002363 243 002364 244 002370 245 002372 246 002402 247 002404 248 002416 250 002430 251 002440 253 002452 256 002461 257 002466 259 002500 261 002511 262 002517 263 002527 264 002534 265 002536 271 002571 272 002572 273 002575 274 002601 276 002602 277 002604 278 002606 285 002641 286 002642 287 002643 288 002644 290 002645 291 002646 292 002651 298 002700 300 002701 301 002702 302 002704 304 002705 305 002706 306 002710 308 002711 310 002712 311 002716 312 002720 318 002747 319 002750 321 002751 322 002754 323 002757 324 002761 325 002762 327 002766 328 002771 329 002773 330 002775 337 003031 338 003032 341 003033 342 003034 343 003037 349 003066 351 003067 353 003070 354 003074 355 003076 361 003125 362 003126 364 003127 365 003132 366 003135 367 003137 368 003140 370 003144 373 003154 374 003157 375 003161 381 003210 382 003211 385 003212 386 003213 387 003216 393 003245 394 003246 400 003250 401 003252 403 003254 404 003255 406 003256 407 003257 408 003272 409 003347 410 003354 411 003356 417 003405 420 003406 424 003407 425 003412 428 003460 430 003470 431 003472 432 003474 440 003526 442 003527 443 003530 445 003531 446 003532 447 003610 448 003631 449 003633 450 003635 456 003707 458 003711 459 003721 460 003723 467 003752 469 003753 470 003754 471 003755 472 003757 473 003762 474 003764 479 004013 480 004014 482 004016 485 004030 488 004044 489 004047 494 004101 495 004103 496 004105 502 004157 504 004161 507 004220 513 004260 515 004262 517 004322 518 004337 519 004341 520 004343 526 004415 528 004417 529 004420 531 004424 532 004426 538 004500 542 004502 545 004515 546 004517 547 004521 553 004573 555 004575 557 004602 558 004604 563 004657 564 004660 566 004661 574 004703 576 004704 582 004705 583 004726 584 004746 585 004757 586 005027 588 005031 589 005032 590 005037 591 005047 593 005064 594 005105 595 005117 596 005153 598 005156 605 005205 607 005255 609 005326 611 005375 613 005377 614 005405 615 005411 616 005416 617 005431 618 005440 619 005450 620 005460 621 005461 ----------------------------------------------------------- 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