COMPILATION LISTING OF SEGMENT format_cobol_source 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 1024.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 format_cobol_source.pl1 Reformatted code to new Cobol standard. 19* END HISTORY COMMENTS */ 20 21 22 /* Last modified on 02/01/77 by ORN to support the -lmargin control argument */ 23 /* Last modified on 11/24/76 by ORN to fix bug in which input seg is truncated if same as output seg */ 24 /* Last modified on 08/16/76 by ORN to support -uc and -lc control arguments */ 25 26 /* format: style3 */ 27 format_cobol_source: 28 fcs: 29 proc; 30 31 dcl dir_ptr ptr; 32 dcl ename_ptr (2) ptr; 33 dcl final_ptr ptr; 34 dcl argptr ptr; 35 dcl segptr (2) ptr; 36 dcl 1 i_o based (addr (segptr (1))), 37 2 inptr ptr, 38 2 outptr ptr; 39 dcl nargs fixed bin; 40 dcl arglen fixed bin; 41 dcl arg char (arglen) based (argptr); 42 dcl code fixed bin (35); 43 dcl bc fixed bin (24); 44 dcl (i, j) fixed bin; 45 dcl (ctype, mtype) fixed bin; 46 dcl shift bit (1); 47 dcl dir char (168); 48 dcl ename (2) char (32); 49 dcl equalname char (32); 50 51 dcl error_table_$sameseg 52 fixed bin (35) ext; 53 dcl error_table_$noarg fixed bin (35) ext; 54 dcl error_table_$badopt fixed bin (35) ext; 55 dcl error_table_$arg_ignored 56 fixed bin (35) ext; 57 dcl error_table_$too_many_args 58 fixed bin (35) ext; 59 60 dcl cobol_source_formatter_ 61 entry (ptr, ptr, fixed bin (24), fixed bin, fixed bin); 62 dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); 63 dcl cobol_source_formatter_$no_shift 64 entry (ptr, ptr, fixed bin (24), fixed bin); 65 dcl com_err_ entry options (variable); 66 dcl equal_ entry (ptr, ptr, ptr, fixed bin (35)); 67 dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); 68 dcl cu_$arg_count entry (fixed bin); 69 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); 70 dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); 71 dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); 72 dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); 73 74 dcl addr builtin; 75 dcl index builtin; 76 dcl null builtin; 77 dcl substr builtin; 78 79 80 /*************************************/ 81 start: 82 shift = "1"b; 83 go to join; 84 85 no_shift: 86 entry; 87 shift = "0"b; 88 89 join: 90 dir_ptr = addr (dir); 91 ename_ptr (1) = addr (ename (1)); 92 ename_ptr (2) = addr (equalname); 93 call cu_$arg_count (nargs); 94 if nargs > 4 95 then go to too_many_args_error; 96 if nargs < 2 97 then go to noarg_error; 98 99 /* Process arguments */ 100 do i = 1 to 2; 101 call cu_$arg_ptr (i, argptr, arglen, code); 102 if code ^= 0 103 then go to multics_error; 104 call expand_path_ (argptr, arglen, dir_ptr, ename_ptr (i), code); 105 if code ^= 0 106 then go to multics_error; 107 if i = 2 108 then do; 109 final_ptr = addr (ename (2)); 110 call equal_ (ename_ptr (1), ename_ptr (2), final_ptr, code); 111 if code ^= 0 112 then go to multics_error; 113 ename_ptr (2) = final_ptr; 114 end; 115 j = index (ename (i), " "); 116 if j = 0 117 then j = 33; 118 if substr (ename (i), j - 6, 6) ^= ".cobol" 119 then substr (ename (i), j, 6) = ".cobol"; 120 call hcs_$initiate (dir, ename (i), "", 0, 1, segptr (i), code); 121 if i = 2 122 then do; 123 if inptr = outptr 124 then go to sameseg_error; 125 if segptr (2) = null () 126 then do; /* output segment doesn't exist; create it */ 127 call hcs_$make_seg (dir, ename (2), "", 10, segptr (2), code); 128 if code ^= 0 129 then go to multics_arg_error; 130 end; 131 else do; 132 call hcs_$truncate_seg (segptr (2), 0, code); 133 if code ^= 0 134 then go to multics_arg_error; 135 end; 136 end; 137 else if segptr (1) = null () 138 then go to multics_arg_error; 139 end; 140 141 ctype, mtype = 0; 142 if nargs > 2 143 then do i = 3 to nargs; 144 call cu_$arg_ptr (i, argptr, arglen, code); 145 if code ^= 0 146 then go to multics_error; 147 if arg = "-upper_case" | arg = "-uc" 148 then do; 149 if ctype = 0 150 then ctype = 1; 151 else call com_err_ (error_table_$arg_ignored, "format_cobol_source", arg); 152 end; 153 else if arg = "-lower_case" | arg = "-lc" 154 then do; 155 if ctype = 0 156 then ctype = -1; 157 else call com_err_ (error_table_$arg_ignored, "format_cobol_source", arg); 158 end; 159 else if arg = "-lmargin" | arg = "-lm" 160 then mtype = 1; 161 else go to badopt_error; 162 end; 163 164 165 /* Call routine which actually does reformatting. */ 166 167 if ^shift 168 then call cobol_source_formatter_$no_shift ((inptr), (outptr), bc, ctype); 169 else call cobol_source_formatter_ ((inptr), (outptr), bc, ctype, mtype); 170 /* pass by value so offsets remain 0 */ 171 172 call hcs_$set_bc_seg (outptr, bc, code); 173 if code ^= 0 174 then go to multics_error; 175 176 return; 177 178 /* Error Handling */ 179 180 noarg_error: 181 code = error_table_$noarg; 182 go to multics_error; 183 184 badopt_error: 185 call com_err_ (error_table_$badopt, "format_cobol_source", arg); 186 return; 187 188 too_many_args_error: 189 code = error_table_$too_many_args; 190 go to multics_error; 191 192 sameseg_error: 193 code = error_table_$sameseg; 194 go to multics_error; 195 196 multics_error: 197 call com_err_ (code, "format_cobol_source"); 198 return; 199 200 multics_arg_error: 201 call com_err_ (code, "format_cobol_source", "^a", ename (i)); 202 return; 203 204 end format_cobol_source; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/24/89 0836.8 format_cobol_source.pl1 >spec>install>MR12.3-1048>format_cobol_source.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. addr builtin function dcl 74 ref 89 91 92 109 123 123 167 167 169 169 172 arg based char packed unaligned dcl 41 set ref 147 147 151* 153 153 157* 159 159 184* arglen 000117 automatic fixed bin(17,0) dcl 40 set ref 101* 104* 144* 147 147 151 151 153 153 157 157 159 159 184 184 argptr 000110 automatic pointer dcl 34 set ref 101* 104* 144* 147 147 151 153 153 157 159 159 184 bc 000121 automatic fixed bin(24,0) dcl 43 set ref 167* 169* 172* cobol_source_formatter_ 000022 constant entry external dcl 60 ref 169 cobol_source_formatter_$no_shift 000026 constant entry external dcl 63 ref 167 code 000120 automatic fixed bin(35,0) dcl 42 set ref 101* 102 104* 105 110* 111 120* 127* 128 132* 133 144* 145 172* 173 180* 188* 192* 196* 200* com_err_ 000030 constant entry external dcl 65 ref 151 157 184 196 200 ctype 000124 automatic fixed bin(17,0) dcl 45 set ref 141* 149 149* 155 155* 167* 169* cu_$arg_count 000036 constant entry external dcl 68 ref 93 cu_$arg_ptr 000040 constant entry external dcl 69 ref 101 144 dir 000127 automatic char(168) packed unaligned dcl 47 set ref 89 120* 127* dir_ptr 000100 automatic pointer dcl 31 set ref 89* 104* ename 000201 automatic char(32) array packed unaligned dcl 48 set ref 91 109 115 118 118* 120* 127* 200* ename_ptr 000102 automatic pointer array dcl 32 set ref 91* 92* 104* 110* 110* 113* equal_ 000032 constant entry external dcl 66 ref 110 equalname 000221 automatic char(32) packed unaligned dcl 49 set ref 92 error_table_$arg_ignored 000016 external static fixed bin(35,0) dcl 55 set ref 151* 157* error_table_$badopt 000014 external static fixed bin(35,0) dcl 54 set ref 184* error_table_$noarg 000012 external static fixed bin(35,0) dcl 53 ref 180 error_table_$sameseg 000010 external static fixed bin(35,0) dcl 51 ref 192 error_table_$too_many_args 000020 external static fixed bin(35,0) dcl 57 ref 188 expand_path_ 000034 constant entry external dcl 67 ref 104 final_ptr 000106 automatic pointer dcl 33 set ref 109* 110* 113 hcs_$initiate 000042 constant entry external dcl 70 ref 120 hcs_$make_seg 000044 constant entry external dcl 71 ref 127 hcs_$set_bc_seg 000046 constant entry external dcl 72 ref 172 hcs_$truncate_seg 000024 constant entry external dcl 62 ref 132 i 000122 automatic fixed bin(17,0) dcl 44 set ref 100* 101* 104 107 115 118 118 120 120 121* 142* 144* 200 i_o based structure level 1 unaligned dcl 36 index builtin function dcl 75 ref 115 inptr based pointer level 2 dcl 36 ref 123 167 169 j 000123 automatic fixed bin(17,0) dcl 44 set ref 115* 116 116* 118 118 mtype 000125 automatic fixed bin(17,0) dcl 45 set ref 141* 159* 169* nargs 000116 automatic fixed bin(17,0) dcl 39 set ref 93* 94 96 142 142 null builtin function dcl 76 ref 125 137 outptr 2 based pointer level 2 dcl 36 set ref 123 167 169 172* segptr 000112 automatic pointer array dcl 35 set ref 120* 123 123 125 127* 132* 137 167 167 169 169 172 shift 000126 automatic bit(1) packed unaligned dcl 46 set ref 81* 87* 167 substr builtin function dcl 77 set ref 118 118* NAMES DECLARED BY EXPLICIT CONTEXT. badopt_error 000701 constant label dcl 184 ref 159 fcs 000040 constant entry external dcl 27 format_cobol_source 000047 constant entry external dcl 27 join 000066 constant label dcl 89 ref 83 multics_arg_error 000770 constant label dcl 200 ref 128 133 137 multics_error 000744 constant label dcl 196 ref 102 105 111 145 173 182 190 194 no_shift 000060 constant entry external dcl 85 noarg_error 000675 constant label dcl 180 ref 96 sameseg_error 000740 constant label dcl 192 ref 123 start 000054 constant label dcl 81 too_many_args_error 000734 constant label dcl 188 ref 94 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1234 1304 1027 1244 Length 1510 1027 50 167 205 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME fcs 220 external procedure is an external procedure. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME fcs 000100 dir_ptr fcs 000102 ename_ptr fcs 000106 final_ptr fcs 000110 argptr fcs 000112 segptr fcs 000116 nargs fcs 000117 arglen fcs 000120 code fcs 000121 bc fcs 000122 i fcs 000123 j fcs 000124 ctype fcs 000125 mtype fcs 000126 shift fcs 000127 dir fcs 000201 ename fcs 000221 equalname fcs THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out_desc call_ext_out return_mac ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. cobol_source_formatter_ cobol_source_formatter_$no_shift com_err_ cu_$arg_count cu_$arg_ptr equal_ expand_path_ hcs_$initiate hcs_$make_seg hcs_$set_bc_seg hcs_$truncate_seg THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$arg_ignored error_table_$badopt error_table_$noarg error_table_$sameseg error_table_$too_many_args LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 27 000037 81 000054 83 000056 85 000057 87 000065 89 000066 91 000070 92 000072 93 000074 94 000103 96 000106 100 000110 101 000115 102 000132 104 000134 105 000156 107 000160 109 000163 110 000165 111 000202 113 000204 115 000206 116 000223 118 000226 120 000246 121 000314 123 000317 125 000325 127 000331 128 000370 130 000372 132 000373 133 000407 136 000411 137 000412 139 000416 141 000420 142 000422 144 000433 145 000450 147 000452 149 000464 151 000471 152 000523 153 000524 155 000534 157 000541 158 000573 159 000574 162 000606 167 000610 169 000634 172 000657 173 000672 176 000674 180 000675 182 000700 184 000701 186 000733 188 000734 190 000737 192 000740 194 000743 196 000744 198 000767 200 000770 202 001026 ----------------------------------------------------------- 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