COMPILATION LISTING OF SEGMENT copy_cards Compiled by: Multics PL/I Compiler, Release 27d, of October 11, 1982 Compiled at: Honeywell LISD Phoenix, System M Compiled on: 11/04/82 1837.4 mst Thu 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 copy_cards: ccd: proc; 11 /* Written by S. Vestal */ 12 /* modified by J. Stern 7/9/75 */ 13 dcl cu_$arg_count entry returns (fixed bin); 14 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); 15 dcl get_authorization_ entry returns (bit (72) aligned); 16 dcl get_group_id_ entry returns (char (32)); 17 dcl pool_manager_$find_pool entry (char (*), bit (72) aligned, char (*), char (*), fixed bin (35)); 18 dcl check_star_name_$entry entry (char (*), fixed bin (35)); 19 dcl get_system_free_area_ entry returns (ptr); 20 dcl hcs_$star_ entry (char (*), char (*), fixed bin, ptr, fixed bin, 21 ptr, ptr, fixed bin (35)); 22 dcl (ioa_, com_err_) entry options (variable); 23 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); 24 dcl get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35)); 25 dcl copy_seg_ entry (char (*), char (*), char (*), char (*), char (*), bit (1), fixed bin (35)); 26 dcl get_wdir_ entry returns (char (168)); 27 dcl error_table_$noentry fixed bin (35) ext; 28 dcl error_table_$nomatch fixed bin (35) ext; 29 dcl error_table_$entlong fixed bin (35) ext; 30 dcl error_table_$bad_equal_name fixed bin (35) ext; 31 dcl error_table_$longeql fixed bin (35) ext; 32 dcl (addr, substr, before, null, fixed, index, verify, reverse) builtin; 33 dcl id char (10) int static init ("copy_cards"); 34 dcl latest bit (1); 35 dcl warn_flag bit (1) init ("0"b); 36 dcl code fixed bin (35); /* error return code */ 37 dcl equal bit (1) init ("0"b); /* on if equal(=) in path */ 38 dcl star bit (1) init ("0"b); /* on if stars in path */ 39 dcl arg char (argl) based (argp); 40 dcl argp ptr; 41 dcl argl fixed bin; 42 dcl ename char (32); 43 dcl deck_name char (32); /* search name for card decks */ 44 dcl caller char (22); /* Person name of the caller */ 45 dcl sysdir char (168) int static init ("System_Card_Pool"); 46 dcl caller_auth bit (72) aligned; /* callers authorization */ 47 dcl pool_path char (168); /* pathname of the card pool */ 48 dcl areap ptr; /* area pointer */ 49 dcl system_area area (65560) based (areap); /* area overlay */ 50 dcl ecount fixed bin; /* entry count */ 51 dcl eptr ptr init (null); /* pointer to entry structure */ 52 dcl nptr ptr init (null); /* pointer to name array */ 53 dcl names (200) char (32) based (nptr); /* name array */ 54 dcl new_deck_dirname char (168); /* directory portion of pathname for new_deck */ 55 dcl new_deck_ename char (32); /* name of new deck */ 56 dcl dir char (168); /* directory name used in error message */ 57 dcl ent char (32); /* entry name used in error message */ 58 dcl nind fixed bin; /* name index */ 59 dcl new_ename char (32); /* entry name */ 60 dcl suffix char (4) ; /* suffix of ename */ 61 dcl prefix char (32); 62 dcl errsw bit (1) ; /* error switch */ 63 dcl (i, j) fixed bin; /* loop index */ 64 dcl 1 entries (100) based (eptr) aligned, 65 2 type bit (2) unal, 66 2 nname bit (16) unal, 67 2 nindex bit (18) unal; 68 dcl cleanup condition; 69 70 71 if cu_$arg_count () = 0 then do; 72 call ioa_ ("^a: Usage: ^a deck_name [newdeck_name] ", id, id); 73 return; 74 end; 75 new_deck_ename = "=="; 76 new_deck_dirname = get_wdir_ (); 77 latest = "0"b; 78 i = 1; 79 do while (i <= cu_$arg_count ()); 80 call cu_$arg_ptr (i, argp, argl, code); 81 if code ^= 0 then goto error; 82 if i = 1 then deck_name = arg; 83 else if arg = "-latest" then latest = "1"b; 84 else do; 85 call expand_pathname_ (arg, new_deck_dirname, new_deck_ename, code); 86 if code ^= 0 then goto error; 87 end; 88 i = i + 1; 89 end; 90 call check_star_name_$entry (deck_name, code); /* check legality of starname */ 91 if code > 2 then do; /* illegal */ 92 call com_err_ (code, id, deck_name); 93 return; 94 end; 95 if code > 0 then /* deck_name contains stars */ 96 if length (rtrim (deck_name)) >= 2 then 97 if substr (deck_name, length (rtrim (deck_name))-1, 2) = "**" then /* deck_name ends in "**" */ 98 go to get_auth; 99 substr (deck_name, length (rtrim (deck_name)) + 1, 2) = ".*"; 100 get_auth: 101 caller = before (get_group_id_ (), "."); /* get the callers name and level */ 102 caller_auth = get_authorization_ (); 103 call pool_manager_$find_pool (sysdir, caller_auth, caller, pool_path, code); 104 if code ^= 0 then 105 if code = error_table_$noentry then /* no pool, cards probably not read yet */ 106 go to not_found; /* treat like pool exists but deck missing */ 107 else do; /* uh oh */ 108 call com_err_ (code, id, "Cannot find user card pool."); 109 return; 110 end; 111 areap = get_system_free_area_ (); 112 on cleanup call clean_up; 113 call hcs_$star_ ((pool_path), (deck_name), 2, areap, ecount, eptr, nptr, code); 114 if code ^= 0 then /* anything in the caller's pool */ 115 if code = error_table_$nomatch then do; 116 not_found: call com_err_ (0, id, "^a not found in card pool.", substr (deck_name, 1, argl)); 117 return; 118 end; 119 else do; 120 call com_err_ (code, id, "^a>^a", pool_path, deck_name); 121 return; 122 end; 123 j = 0; 124 do i = 1 to ecount; /* look at every entry */ 125 nind = fixed (eptr -> entries (i).nindex, 18); /* build the name */ 126 ename = nptr -> names (nind); 127 suffix = reverse (before (reverse (ename), ".")); 128 prefix = reverse (after (reverse (ename), ".")); /* erase suffix to compute equal reverse(ename) */ 129 call get_equal_name_ (prefix, new_deck_ename, new_ename, code); /* build an equal name for it */ 130 if code ^= 0 then 131 if code = error_table_$bad_equal_name then do; 132 call com_err_ (code, id, new_deck_ename); 133 go to finish; 134 end; 135 else do; 136 long_equal: call com_err_ (code, id, "converting ^a to ^a", ename, new_deck_ename); 137 go to end_loop; 138 end; 139 if suffix ^= "0" then do; /* must have been a namedup during card input */ 140 if length (rtrim (new_ename)) + length (rtrim (suffix)) + 1 > 32 then goto long_equal; 141 new_ename = substr (new_ename, 1, length (rtrim (new_ename))) || "." || suffix; 142 warn_flag = "1"b; 143 end; 144 call copy_seg_ (pool_path, ename, new_deck_dirname, new_ename, "copy_cards", errsw, code); /* copy the segment */ 145 if code ^= 0 then do; 146 if ^errsw then do; /* problem with source seg */ 147 dir = pool_path; 148 ent = ename; 149 end; 150 else do; /* problem with target seg */ 151 dir = new_deck_dirname; 152 ent = new_ename; 153 end; 154 call com_err_ (code, id, "^a>^a", dir, ent); 155 go to end_loop; 156 end; 157 j = j+1; /* increment the copy count */ 158 end_loop: end; 159 if warn_flag then 160 call com_err_ (0, id, "Multiple decks of the same name may have been entered. Check for numbered copies."); 161 call ioa_ ("^d card decks copied.", j); /* inform the caller and exit */ 162 finish: call clean_up; 163 return; 164 test: entry (dirname); /* test entry point for defining pool pathname */ 165 dcl dirname char (*); 166 sysdir = dirname; /* should be the only argument */ 167 return; 168 169 clean_up: proc; /* trap to cleanup */ 170 if eptr ^= null then free entries in (system_area); /* free system storage */ 171 if nptr ^= null then free names in (system_area); 172 return; /* and return */ 173 end; 174 error: if code ^= 0 then call com_err_ (code, id); 175 call clean_up; 176 return; 177 end copy_cards; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/04/82 1631.3 copy_cards.pl1 >dumps>old>recomp>copy_cards.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. areap 000214 automatic pointer dcl 48 set ref 111* 113* 170 171 arg based char unaligned dcl 39 set ref 82 83 85* argl 000110 automatic fixed bin(17,0) dcl 41 set ref 80* 82 83 85 85 116 116 argp 000106 automatic pointer dcl 40 set ref 80* 82 83 85 before builtin function dcl 32 ref 100 127 caller 000131 automatic char(22) unaligned dcl 44 set ref 100* 103* caller_auth 000140 automatic bit(72) dcl 46 set ref 102* 103* check_star_name_$entry 000100 constant entry external dcl 18 ref 90 cleanup 000416 stack reference condition dcl 68 ref 112 code 000102 automatic fixed bin(35,0) dcl 36 set ref 80* 81 85* 86 90* 91 92* 95 103* 104 104 108* 113* 114 114 120* 129* 130 130 132* 136* 144* 145 154* 174 174* com_err_ 000110 constant entry external dcl 22 ref 92 108 116 120 132 136 154 159 174 copy_seg_ 000116 constant entry external dcl 25 ref 144 cu_$arg_count 000066 constant entry external dcl 13 ref 71 79 cu_$arg_ptr 000070 constant entry external dcl 14 ref 80 deck_name 000121 automatic char(32) unaligned dcl 43 set ref 82* 90* 92* 95 95 95 99 99* 113 116 116 120* dir 000306 automatic char(168) unaligned dcl 56 set ref 147* 151* 154* dirname parameter char unaligned dcl 165 ref 164 166 ecount 000216 automatic fixed bin(17,0) dcl 50 set ref 113* 124 ename 000111 automatic char(32) unaligned dcl 42 set ref 126* 127 128 136* 144* 148 ent 000360 automatic char(32) unaligned dcl 57 set ref 148* 152* 154* entries based structure array level 1 dcl 64 ref 170 eptr 000220 automatic pointer initial dcl 51 set ref 51* 113* 125 170 170 equal 000103 automatic bit(1) initial unaligned dcl 37 set ref 37* error_table_$bad_equal_name 000126 external static fixed bin(35,0) dcl 30 ref 130 error_table_$noentry 000122 external static fixed bin(35,0) dcl 27 ref 104 error_table_$nomatch 000124 external static fixed bin(35,0) dcl 28 ref 114 errsw 000412 automatic bit(1) unaligned dcl 62 set ref 144* 146 expand_pathname_ 000112 constant entry external dcl 23 ref 85 fixed builtin function dcl 32 ref 125 get_authorization_ 000072 constant entry external dcl 15 ref 102 get_equal_name_ 000114 constant entry external dcl 24 ref 129 get_group_id_ 000074 constant entry external dcl 16 ref 100 get_system_free_area_ 000102 constant entry external dcl 19 ref 111 get_wdir_ 000120 constant entry external dcl 26 ref 76 hcs_$star_ 000104 constant entry external dcl 20 ref 113 i 000413 automatic fixed bin(17,0) dcl 63 set ref 78* 79 80* 82 88* 88 124* 125* id 000010 internal static char(10) initial unaligned dcl 33 set ref 72* 72* 92* 108* 116* 120* 132* 136* 154* 159* 174* ioa_ 000106 constant entry external dcl 22 ref 72 161 j 000414 automatic fixed bin(17,0) dcl 63 set ref 123* 157* 157 161* latest 000100 automatic bit(1) unaligned dcl 34 set ref 77* 83* names based char(32) array unaligned dcl 53 ref 126 171 new_deck_dirname 000224 automatic char(168) unaligned dcl 54 set ref 76* 85* 144* 151 new_deck_ename 000276 automatic char(32) unaligned dcl 55 set ref 75* 85* 129* 132* 136* new_ename 000371 automatic char(32) unaligned dcl 59 set ref 129* 140 141* 141 141 144* 152 nind 000370 automatic fixed bin(17,0) dcl 58 set ref 125* 126 nindex 0(18) based bit(18) array level 2 packed unaligned dcl 64 ref 125 nptr 000222 automatic pointer initial dcl 52 set ref 52* 113* 126 171 171 null builtin function dcl 32 ref 51 52 170 171 pool_manager_$find_pool 000076 constant entry external dcl 17 ref 103 pool_path 000142 automatic char(168) unaligned dcl 47 set ref 103* 113 120* 144* 147 prefix 000402 automatic char(32) unaligned dcl 61 set ref 128* 129* reverse builtin function dcl 32 ref 127 127 128 128 star 000104 automatic bit(1) initial unaligned dcl 38 set ref 38* substr builtin function dcl 32 set ref 95 99* 116 116 141 suffix 000401 automatic char(4) unaligned dcl 60 set ref 127* 139 140 141 sysdir 000013 internal static char(168) initial unaligned dcl 45 set ref 103* 166* system_area based area(65560) dcl 49 ref 170 171 warn_flag 000101 automatic bit(1) initial unaligned dcl 35 set ref 35* 142* 159 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. addr builtin function dcl 32 error_table_$entlong external static fixed bin(35,0) dcl 29 error_table_$longeql external static fixed bin(35,0) dcl 31 index builtin function dcl 32 verify builtin function dcl 32 NAMES DECLARED BY EXPLICIT CONTEXT. ccd 000145 constant entry external dcl 10 clean_up 001524 constant entry internal dcl 169 ref 112 162 175 copy_cards 000155 constant entry external dcl 10 end_loop 001370 constant label dcl 158 ref 137 155 error 001500 constant label dcl 174 ref 81 86 finish 001444 constant label dcl 162 ref 133 get_auth 000443 constant label dcl 100 ref 95 long_equal 001124 constant label dcl 136 ref 140 not_found 000662 constant label dcl 116 ref 104 test 001454 constant entry external dcl 164 NAMES DECLARED BY CONTEXT OR IMPLICATION. after builtin function ref 128 length builtin function ref 95 95 99 140 140 141 rtrim builtin function ref 95 95 99 140 140 141 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 2020 2150 1554 2030 Length 2362 1554 130 176 243 56 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME ccd 427 external procedure is an external procedure. on unit on line 112 64 on unit clean_up 64 internal procedure is called by several nonquick procedures. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 id ccd 000013 sysdir ccd STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME ccd 000100 latest ccd 000101 warn_flag ccd 000102 code ccd 000103 equal ccd 000104 star ccd 000106 argp ccd 000110 argl ccd 000111 ename ccd 000121 deck_name ccd 000131 caller ccd 000140 caller_auth ccd 000142 pool_path ccd 000214 areap ccd 000216 ecount ccd 000220 eptr ccd 000222 nptr ccd 000224 new_deck_dirname ccd 000276 new_deck_ename ccd 000306 dir ccd 000360 ent ccd 000370 nind ccd 000371 new_ename ccd 000401 suffix ccd 000402 prefix ccd 000412 errsw ccd 000413 i ccd 000414 j ccd THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_cs cat_realloc_cs call_ext_out_desc call_ext_out call_int_this call_int_other return enable shorten_stack ext_entry ext_entry_desc int_entry reverse_cs set_cs_eis free_based THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. check_star_name_$entry com_err_ copy_seg_ cu_$arg_count cu_$arg_ptr expand_pathname_ get_authorization_ get_equal_name_ get_group_id_ get_system_free_area_ get_wdir_ hcs_$star_ ioa_ pool_manager_$find_pool THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$bad_equal_name error_table_$noentry error_table_$nomatch LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 35 000134 37 000135 38 000136 51 000137 52 000141 10 000144 71 000163 72 000174 73 000216 75 000217 76 000222 77 000231 78 000232 79 000234 80 000246 81 000263 82 000265 83 000276 85 000307 86 000337 88 000341 89 000342 90 000343 91 000360 92 000363 93 000404 95 000405 99 000427 100 000443 102 000462 103 000471 104 000521 108 000526 109 000551 111 000552 112 000561 113 000603 114 000655 116 000662 117 000721 120 000723 121 000755 123 000756 124 000757 125 000766 126 000772 127 001000 128 001025 129 001052 130 001076 132 001103 133 001123 136 001124 137 001157 139 001160 140 001165 141 001215 142 001243 144 001246 145 001311 146 001313 147 001316 148 001321 149 001324 151 001325 152 001330 154 001333 155 001366 157 001367 158 001370 159 001372 161 001421 162 001444 163 001450 164 001451 166 001470 167 001477 174 001500 175 001516 176 001522 169 001523 170 001531 171 001540 172 001547 ----------------------------------------------------------- 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