COMPILATION LISTING OF SEGMENT cobol_FILE_ Compiled by: Multics PL/I Compiler, Release 31b, of April 24, 1989 Compiled at: Bull HN, Phoenix AZ, System-M Compiled on: 05/24/89 1028.7 mst Wed Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1989 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* *********************************************************** */ 11 12 13 14 15 /****^ HISTORY COMMENTS: 16* 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), 17* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 18* MCR8060 cobol_FILE_.pl1 Reformatted code to new Cobol standard. 19* END HISTORY COMMENTS */ 20 21 22 /* format: style3 */ 23 cobol_FILE_: 24 proc; 25 call com_err_ (0, "cobol_FILE_", "For documentation execute:^/ec >udd>LIS>Wardd>pr_doc cobol_FILE_ MPM"); 26 return; 27 IN: 28 entry (cn, n1, n2, opn, p, l, k) returns (bit (1)); 29 p = null (); 30 l = 0; /* Initiate. */ 31 if length (opn) > 0 32 then if ^gn (n1, n2, opn) 33 then call hcs_$initiate (dn, en, "", 0b, 00b, p, e); 34 if p = null () 35 then do; 36 if gn (n1, n2, "") 37 then return ("1"b); 38 call hcs_$initiate (dn, en, "", 0b, 00b, p, e); 39 end; 40 if p = null () 41 then do; /* Attempt to use names as an initiated segment. */ 42 call hcs_$make_ptr (null (), n1 || n2 || opn, "", p, e); 43 if length (opn) > 0 44 then if p = null () 45 then call hcs_$make_ptr (null (), n1 || n2, "", p, e); 46 if p ^= null () 47 then call hcs_$fs_get_path_name (p, dn, l1, wen, e); 48 end; 49 if p = null () 50 then do; 51 call com_err_ (e, cn, NAMES ()); 52 return ("1"b); 53 end; 54 call hcs_$status_mins (p, tp, bc, e); 55 if e > 0 56 then do; 57 call com_err_ (e, cn, (NAMES ())); 58 return ("1"b); 59 end; 60 if k = 0 61 then do; 62 call com_err_ (0, cn, "Warning,zero divide factor " || NAMES ()); 63 l = -bc; 64 return ("1"b); 65 end; 66 if k < 0 67 then call com_err_ (0, cn, "Warning, divide factor (^d) negative " || NAMES (), k); 68 if bc < 1 69 then call com_err_ (0, cn, "Warning, bit-count zero " || NAMES ()); 70 l = divide ((bc + (k - 1)), k, 35, 0); 71 return ("0"b); 72 73 LEN: 74 entry (cn, n1, n2, l) returns (bit (1)); 75 if gn (n1, n2, "") 76 then return ("1"b); 77 if l < 0 78 then call hcs_$delentry_file (dn, en, e); 79 else do; 80 call hcs_$set_bc (dn, en, fixed (l, 24), e); 81 if e = 0 82 then call hcs_$truncate_file (dn, en, divide ((l + 35), 36, 24, 0), e); 83 end; 84 if e > 0 85 then do; 86 call com_err_ (e, cn, "Attempted bit-count ^d " || NAMES (), l); 87 return ("1"b); 88 end; 89 return ("0"b); 90 91 SBC: 92 entry (cn, segp, l) returns (bit (1)); 93 if l < 0 94 then call hcs_$delentry_seg (segp, e); 95 else call hcs_$set_bc_seg (segp, fixed (l, 24), e); 96 if e > 0 97 then do; /* Obtain the segment's pathname. */ 98 call hcs_$fs_get_path_name (segp, dn, l1, en, e); 99 call com_err_ (e, cn, "Attempted to set bi ^d " || NAMES (), l); 100 return ("1"b); 101 end; 102 return ("0"b); 103 104 105 OUT: 106 entry (cn, n1, n2, opn, p) returns (bit (1)); 107 p = null (); 108 if gn (n1, n2, "") 109 then return ("1"b); 110 do l1 = 1 to length (opn); /* Verify that access is acceptable characters. */ 111 l2 = index ("rewa", substr (opn, l1, 1)); 112 if l2 < 1 113 then do; 114 call com_err_ (0, cn, "Parameter 4, access must be letters from ""rewa"", (""^a"").", opn); 115 return ("1"b); 116 end; 117 substr (mode, (l2 + 1), 1) = "1"b; 118 end; 119 call hcs_$make_seg (dn, en, "", fixed (mode, 5), p, e); 120 if p ^= null () 121 then do; 122 call hcs_$truncate_file (dn, en, 0, e); 123 call hcs_$set_bc (dn, en, 0, e); 124 end; 125 if p = null () 126 then do; 127 call com_err_ (e, cn, (NAMES ())); 128 return ("1"b); 129 end; 130 call hcs_$acl_add1 (dn, en, "*.*.*", 01100b, rbc, e); 131 return ("0"b); 132 133 PROC: 134 entry (cn, n1, n2, p) returns (bit (1)); 135 p = null (); 136 SN = n1 || n2; 137 EN = ""; 138 DN = ""; 139 i = index (SN, "$"); 140 if i > 0 141 then do; /* Specific entry name. */ 142 EN = substr (SN, (i + 1), (length (SN) - i)); 143 SN = substr (SN, 1, (i - 1)); 144 end; /* Isolate segment name from directory. */ 145 do i = length (SN) to 1 by -1 while ((substr (SN, i, 1) ^= ">") & (substr (SN, i, 1) ^= "<")); 146 end; 147 if i > 0 148 then do; /* More than a segment name input. */ 149 DN = substr (SN, 1, i); 150 SN = substr (SN, (i + 1), (length (SN) - i)); 151 end; 152 if length (EN) < 1 153 then EN = SN; /* Entry name, if not specific. */ 154 /* Establish calling directory. */ 155 dp = null (); 156 if length (DN) > 0 157 then if ^gn ((DN), (SN), "") 158 then call hcs_$initiate (dn, en, "", 0b, 00b, dp, e); 159 call hcs_$make_ptr (dp, (SN), (EN), p, e); 160 if e > 0 161 then do; 162 call com_err_ (e, cn, "Could not obtain pointer to an entry from name ""^a^a""", n1, n2); 163 return ("1"b); 164 end; 165 return ("0"b); 166 167 168 /* Internal procedures. */ 169 gn: 170 proc (n1, n2, opn) returns (bit (1)); /* Obtain directory name in dn and entry name in en. */ 171 if length (n1) > 0 172 then N = n1 || n2 || opn; 173 else do; 174 call cobol_set_pdir (N); 175 N = N || ">" || n2 || opn; 176 end; 177 call expand_path_ (addrel (addr (N), 1), length (N), addr (dn), addr (en), e); 178 if e > 0 179 then do; 180 if length (opn) > 0 181 then call com_err_ (e, cn, "for (""^a"",""^a"",[""^a""]).", n1, n2, opn); 182 else call com_err_ (e, cn, "for (""^a"",""^a"").", n1, n2); 183 return ("1"b); 184 end; 185 return ("0"b); 186 dcl (n1, n2, opn) char (*) parm; 187 dcl N char (256) var; 188 end gn; 189 190 NAMES: 191 proc returns (char (256) var); 192 l1 = index (en, " "); 193 if l1 < 1 194 then l1 = 33; 195 else l1 = l1 - 1; 196 l2 = index (dn, " "); 197 if l2 < 1 198 then l2 = 169; 199 else l2 = l2 - 1; 200 r = "Segment """ || substr (en, 1, l1) || """ in directory """ || substr (dn, 1, l2) || """."; 201 return (r); 202 203 dcl r char (256) var; 204 end NAMES; /* Declarations for variables. */ 205 dcl ( 206 cn, /* Caller's name. */ 207 n1, /* Name left part. */ 208 n2, /* Name right part. */ 209 opn /* Name right optional part (| access mode. */ 210 ) char (*) parm, 211 segp ptr parm, /* Input pointer. */ 212 p ptr parm, /* Output pointer. */ 213 l fixed bin (35) parm, /* Output length. */ 214 k fixed bin (35) parm, /* Bit-count divide constant. */ 215 (l1, l2) fixed bin (35), 216 bc fixed bin (24), 217 tp bin (2), 218 e fixed bin (35), /* Error code. */ 219 com_err_ entry options (variable) ext, 220 mode bit (5) aligned init ("00000"b), 221 dn char (169), 222 (en, wen) char (33); 223 dcl (addr, addrel, null, substr, index, length) 224 builtin; 225 dcl expand_path_ entry (ptr, fixed bin (35), ptr, ptr, fixed bin (35)) ext, 226 hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)) ext, 227 hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)) ext, 228 hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)) ext, 229 hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)) ext, 230 hcs_$delentry_file entry (char (*), char (*), fixed bin (35)) ext, 231 hcs_$delentry_seg entry (ptr, fixed bin (35)) ext, 232 hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)) ext, 233 hcs_$truncate_seg entry (ptr, fixed bin (35), fixed bin (35)) ext, 234 hcs_$truncate_file entry (char (*), char (*), fixed bin (35), fixed bin (35)) ext, 235 hcs_$fs_get_path_name 236 entry (ptr, char (*), fixed bin (35), char (*), fixed bin (35)) ext, 237 hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)) ext; 238 239 dcl hcs_$acl_add1 entry (char (*), char (*), char (*), fixed bin (5), (3) fixed bin (6), fixed bin (35)) ext; 240 dcl rbc (3) fixed bin (6) init (4, 4, 4) static internal; 241 dcl cobol_set_pdir entry (char (*) var) ext; 242 dcl SN char (256) var; 243 dcl EN char (32) var; 244 dcl DN char (168) var; 245 dcl i fixed bin (35); 246 dcl dp ptr; 247 end cobol_FILE_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/24/89 0837.3 cobol_FILE_.pl1 >spec>install>MR12.3-1048>cobol_FILE_.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. DN 000315 automatic varying char(168) dcl 244 set ref 138* 149* 156 156 EN 000304 automatic varying char(32) dcl 243 set ref 137* 142* 152 152* 159 N 000100 automatic varying char(256) dcl 187 set ref 171* 174* 175* 175 177 177 177 177 SN 000203 automatic varying char(256) dcl 242 set ref 136* 139 142 142 143* 143 145 145 145 149 150* 150 150 152 156 159 addr builtin function dcl 223 ref 177 177 177 177 177 177 addrel builtin function dcl 223 ref 177 177 bc 000102 automatic fixed bin(24,0) dcl 205 set ref 54* 63 68 70 cn parameter char packed unaligned dcl 205 set ref 27 51* 57* 62* 66* 68* 73 86* 91 99* 105 114* 127* 133 162* 180* 182* cobol_set_pdir 000046 constant entry external dcl 241 ref 174 com_err_ 000014 constant entry external dcl 205 ref 25 51 57 62 66 68 86 99 114 127 162 180 182 dn 000106 automatic char(169) packed unaligned dcl 205 set ref 31* 38* 46* 77* 80* 81* 98* 119* 122* 123* 130* 156* 177 177 196 200 dp 000372 automatic pointer dcl 246 set ref 155* 156* 159* e 000104 automatic fixed bin(35,0) dcl 205 set ref 31* 38* 42* 43* 46* 51* 54* 55 57* 77* 80* 81 81* 84 86* 93* 95* 96 98* 99* 119* 122* 123* 127* 130* 156* 159* 160 162* 177* 178 180* 182* en 000161 automatic char(33) packed unaligned dcl 205 set ref 31* 38* 77* 80* 81* 98* 119* 122* 123* 130* 156* 177 177 192 200 expand_path_ 000016 constant entry external dcl 225 ref 177 hcs_$acl_add1 000044 constant entry external dcl 239 ref 130 hcs_$delentry_file 000030 constant entry external dcl 225 ref 77 hcs_$delentry_seg 000032 constant entry external dcl 225 ref 93 hcs_$fs_get_path_name 000040 constant entry external dcl 225 ref 46 98 hcs_$initiate 000020 constant entry external dcl 225 ref 31 38 156 hcs_$make_ptr 000042 constant entry external dcl 225 ref 42 43 159 hcs_$make_seg 000034 constant entry external dcl 225 ref 119 hcs_$set_bc 000024 constant entry external dcl 225 ref 80 123 hcs_$set_bc_seg 000026 constant entry external dcl 225 ref 95 hcs_$status_mins 000022 constant entry external dcl 225 ref 54 hcs_$truncate_file 000036 constant entry external dcl 225 ref 81 122 i 000370 automatic fixed bin(35,0) dcl 245 set ref 139* 140 142 142 143 145* 145 145* 147 149 150 150 index builtin function dcl 223 ref 111 139 192 196 k parameter fixed bin(35,0) dcl 205 set ref 27 60 66 66* 70 70 l parameter fixed bin(35,0) dcl 205 set ref 27 30* 63* 70* 73 77 80 80 81 81 86* 91 93 95 95 99* l1 000100 automatic fixed bin(35,0) dcl 205 set ref 46* 98* 110* 111* 192* 193 193* 195* 195 200 l2 000101 automatic fixed bin(35,0) dcl 205 set ref 111* 112 117 196* 197 197* 199* 199 200 length builtin function dcl 223 ref 31 43 110 142 145 150 152 156 171 177 177 180 mode 000105 automatic bit(5) initial dcl 205 set ref 117* 119 119 205* n1 parameter char packed unaligned dcl 205 in procedure "cobol_FILE_" set ref 27 31* 36* 42 43 73 75* 105 108* 133 136 162* n1 parameter char packed unaligned dcl 186 in procedure "gn" set ref 169 171 171 180* 182* n2 parameter char packed unaligned dcl 186 in procedure "gn" set ref 169 171 175 180* 182* n2 parameter char packed unaligned dcl 205 in procedure "cobol_FILE_" set ref 27 31* 36* 42 43 73 75* 105 108* 133 136 162* null builtin function dcl 223 ref 29 34 40 42 42 43 43 43 46 49 107 120 125 135 155 opn parameter char packed unaligned dcl 205 in procedure "cobol_FILE_" set ref 27 31 31* 42 43 105 110 111 114* opn parameter char packed unaligned dcl 186 in procedure "gn" set ref 169 171 175 180 180* p parameter pointer dcl 205 set ref 27 29* 31* 34 38* 40 42* 43 43* 46 46* 49 54* 105 107* 119* 120 125 133 135* 159* r 000414 automatic varying char(256) dcl 203 set ref 200* 201 rbc 000010 internal static fixed bin(6,0) initial array dcl 240 set ref 130* segp parameter pointer dcl 205 set ref 91 93* 95* 98* substr builtin function dcl 223 set ref 111 117* 142 143 145 145 149 150 200 200 tp 000103 automatic fixed bin(2,0) dcl 205 set ref 54* wen 000172 automatic char(33) packed unaligned dcl 205 set ref 46* NAME DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. hcs_$truncate_seg 000000 constant entry external dcl 225 NAMES DECLARED BY EXPLICIT CONTEXT. IN 000275 constant entry external dcl 27 LEN 001355 constant entry external dcl 73 NAMES 003615 constant entry internal dcl 190 ref 51 57 62 66 68 86 99 127 OUT 002100 constant entry external dcl 105 PROC 002572 constant entry external dcl 133 SBC 001667 constant entry external dcl 91 cobol_FILE_ 000215 constant entry external dcl 23 gn 003254 constant entry internal dcl 169 ref 31 36 75 108 156 NAMES DECLARED BY CONTEXT OR IMPLICATION. divide builtin function ref 70 81 81 fixed builtin function ref 80 80 95 95 119 119 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 4176 4246 3764 4206 Length 4466 3764 50 203 211 4 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME cobol_FILE_ 498 external procedure is an external procedure. gn 186 internal procedure is called during a stack extension. NAMES internal procedure shares stack frame of external procedure cobol_FILE_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 rbc cobol_FILE_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME cobol_FILE_ 000100 l1 cobol_FILE_ 000101 l2 cobol_FILE_ 000102 bc cobol_FILE_ 000103 tp cobol_FILE_ 000104 e cobol_FILE_ 000105 mode cobol_FILE_ 000106 dn cobol_FILE_ 000161 en cobol_FILE_ 000172 wen cobol_FILE_ 000203 SN cobol_FILE_ 000304 EN cobol_FILE_ 000315 DN cobol_FILE_ 000370 i cobol_FILE_ 000372 dp cobol_FILE_ 000414 r NAMES gn 000100 N gn THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_char_temp cat_realloc_chars call_ext_out_desc call_ext_out call_int_this_desc return_mac signal_op shorten_stack ext_entry ext_entry_desc int_entry_desc divide_fx3 THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. cobol_set_pdir com_err_ expand_path_ hcs_$acl_add1 hcs_$delentry_file hcs_$delentry_seg hcs_$fs_get_path_name hcs_$initiate hcs_$make_ptr hcs_$make_seg hcs_$set_bc hcs_$set_bc_seg hcs_$status_mins hcs_$truncate_file NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 205 000211 23 000214 25 000225 26 000257 27 000266 29 000340 30 000342 31 000343 34 000441 36 000445 38 000511 40 000554 42 000560 43 000645 46 000725 49 000762 51 000766 52 001013 54 001026 55 001043 57 001045 58 001102 60 001116 62 001121 63 001164 64 001167 66 001202 68 001252 70 001321 71 001335 73 001350 75 001411 77 001455 80 001501 81 001527 84 001564 86 001566 87 001633 89 001647 91 001662 93 001711 95 001726 96 001743 98 001745 99 001776 100 002043 102 002057 105 002072 107 002141 108 002143 110 002207 111 002223 112 002236 114 002240 115 002272 117 002305 118 002310 119 002315 120 002355 122 002361 123 002406 125 002434 127 002440 128 002475 130 002511 131 002552 133 002565 135 002626 136 002630 137 002657 138 002661 139 002662 140 002674 142 002675 143 002707 145 002715 146 002733 147 002740 149 002742 150 002751 152 002763 155 002776 156 003000 159 003113 160 003164 162 003167 163 003225 165 003240 169 003253 171 003301 173 003344 174 003345 175 003355 176 003425 177 003426 178 003463 180 003466 182 003540 183 003601 185 003607 190 003615 192 003617 193 003630 195 003635 196 003643 197 003654 199 003661 200 003667 201 003742 ----------------------------------------------------------- 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