COMPILATION LISTING OF SEGMENT cobol_error_ 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 1026.9 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_error_.pl1 Reformatted code to new Cobol standard. 19* END HISTORY COMMENTS */ 20 21 22 /* Modified on 06/08/79 by PRP, [4.0-1], print_cobol_error_ made to use error_output */ 23 /* Modified since Version 4.0 */ 24 /*{*/ 25 /* format: style3 */ 26 cobol_error_: 27 proc (cobol_code, multics_code, line_no1, line_no2, progname, error_ptr); 28 29 /* This is a run-time routine for reporting object errors 30*which occur in cobol programs or are discovered by cobol 31*run-time support routines. It reports the error to the 32*error_output stream and signals the "error" condition. 33*The sub-generators cobol_process_error and cobol_gen_error are used by 34*code generators to set up a call to this routine. */ 35 36 dcl cobol_code fixed bin parameter; 37 dcl multics_code fixed bin (35) parameter; 38 dcl line_no1 fixed bin parameter; 39 dcl line_no2 fixed bin parameter; 40 dcl progname char (65) varying parameter; 41 dcl error_ptr ptr parameter; 42 43 44 /* 45*cobol_code indicates the cobol error number (input). 46* 47*multics_code indicates the multics status code (input). 48* 49*line_no1 the line number on which the error occurred. 50* If 0, no line number is applicable 51* and no such indication will be given in the 52* error message (input). 53* 54*line_no2 the additional line number. If 0, then only 55* a one-part line number is given (input). 56* 57*progname a character string containing the name of the 58* program which produced the error. The 59* cobol_process_error sub-generator will always 60* set is to the name of the program for which 61* code is being generated. Run-time support 62* routines may identify the program which 63* called them of themselves, depending on the 64* nature of the error. If this is a null 65* string, then no program name is applicable 66* and none will be attached to the error 67* message (input). 68* 69*error_ptr a pointer to the location at which the error 70* was discovered or to the location at which 71* cobol_error_ is called from. The 72* cobol_process_error sub-generator will always 73* set it to the latter (input). 74* 75* 76*The following message(s) will be output to the "error_output" stream: 77* 78* ["progname": Multics message (from com_err_)] 79* ["progname": COBOL error message] 80* Error occurred at "segno|offset" 81* [in "progname" [on line ["line_no2"] "line_no1"]] 82* 83*The first line is printed only if multics_code is non-zero. The second line is printed 84*only if cobol_code is non-zero. 85*The third line is always printed. The progname portion of it is not present 86*if progname is null; the line_no2 portion of it is not present is line_no2 is zero; 87*the line_no1 portion of it is not present if line_no1 is zero. 88*}*/ 89 90 /* COBOL ERROR TABLE */ 91 dcl cet_ptr ptr static init (null ()); 92 dcl cet char (100000) based (cet_ptr); 93 dcl 1 cobol_error_table based (cet_ptr), 94 2 max fixed bin aligned, 95 2 error (0 refer (cobol_error_table.max)) aligned, 96 3 start fixed bin unal, 97 3 len fixed bin unal; /* DECLARATIONS */ 98 dcl len fixed bin; 99 dcl code fixed bin (35); 100 101 dcl dname char (168); 102 dcl ename char (32); 103 dcl inprog char (168); 104 dcl online char (24); 105 dcl shortinfo char (8) aligned; 106 dcl longinfo char (100) aligned; 107 108 dcl evar entry auto; 109 dcl bptr ptr based (addr (evar)); 110 111 dcl cobol_error_$use entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (65) varying, ptr); 112 dcl convert_status_code_ 113 entry (fixed bin (35), char (8) aligned, char (100) aligned); 114 dcl com_err_ entry options (variable); 115 dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); 116 dcl ioa_$ioa_stream entry options (variable); 117 dcl ioa_$ioa_stream_nnl entry options (variable); 118 dcl ioa_$rs entry options (variable); 119 dcl ioa_$rsnnl entry options (variable); 120 dcl hcs_$fs_get_path_name 121 entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); 122 dcl signal_ entry (char (*)); 123 124 125 /*************************************/ 126 start: 127 if cet_ptr = null () 128 then call set_cet_ptr; 129 if multics_code ^= 0 130 then do; 131 call convert_status_code_ (multics_code, shortinfo, longinfo); 132 if progname ^= "" 133 then call ioa_$ioa_stream_nnl ("error_output", "^a: ", progname); 134 call ioa_$ioa_stream ("error_output", longinfo); 135 end; 136 137 if cobol_code > 0 138 then do; 139 if progname ^= "" 140 then call ioa_$ioa_stream_nnl ("error_output", "^a: ", progname); 141 if cobol_code > cobol_error_table.max 142 then call ioa_$ioa_stream ("error_output", "Invalid cobol error code ^d", cobol_code); 143 else call ioa_$ioa_stream ("error_output", 144 substr (cet, error.start (cobol_code), error.len (cobol_code))); 145 /*-06/02/76-*/ 146 end; 147 148 call hcs_$fs_get_path_name (error_ptr, dname, len, ename, code); 149 if code ^= 0 150 then inprog = ""; 151 else inprog = " in " || substr (dname, 1, len) || ">" || ename; 152 if line_no1 > 0 | line_no2 > 0 153 then if line_no1 > 0 & line_no2 > 0 154 then call ioa_$rsnnl (" on line ^d-^d", online, len, line_no2, line_no1); 155 else call ioa_$rsnnl (" on line ^d", online, len, line_no1); 156 else online = ""; 157 call ioa_$ioa_stream ("error_output", "Error occurred at ^p^a^a", error_ptr, inprog, online); 158 call cobol_error_$use (cobol_code, multics_code, line_no1, line_no2, progname, error_ptr); 159 /*-05/10/76-*/ 160 call signal_ ("error"); 161 return; 162 163 164 /*************************************/ 165 use: 166 entry (cobol_code, multics_code, line_no1, line_no2, progname, error_ptr); 167 dcl errline char (300) static; 168 dcl tline char (120); 169 dcl erroff fixed bin; 170 dcl errlen fixed bin static init (0); 171 172 start_use: 173 if cet_ptr = null () 174 then call set_cet_ptr; 175 erroff = 1; 176 if multics_code ^= 0 177 then do; 178 call convert_status_code_ (multics_code, shortinfo, longinfo); 179 if progname ^= "" 180 then do; 181 call ioa_$rsnnl ("^a: ", tline, len, progname); 182 substr (errline, erroff, len) = tline; 183 erroff = erroff + len; 184 end; 185 call ioa_$rs (longinfo, tline, len); 186 substr (errline, erroff, len) = tline; 187 erroff = erroff + len; 188 end; 189 190 if cobol_code > 0 191 then do; 192 if progname ^= "" 193 then do; 194 call ioa_$rsnnl ("^a: ", tline, len, progname); 195 substr (errline, erroff, len) = tline; 196 erroff = erroff + len; 197 end; 198 if cobol_code > cobol_error_table.max 199 then call ioa_$rs ("Invalid cobol error code ^d", tline, len, cobol_code); 200 /*-06/02/76-*/ 201 else do; 202 call ioa_$rs (substr (cet, error.start (cobol_code), error.len (cobol_code)), tline, len); 203 /*-06/02/76-*/ 204 substr (errline, erroff, len) = tline; 205 erroff = erroff + len; 206 end; 207 end; 208 209 call hcs_$fs_get_path_name (error_ptr, dname, len, ename, code); 210 if code ^= 0 211 then inprog = ""; 212 else inprog = " in " || substr (dname, 1, len) || ">" || ename; 213 if line_no1 > 0 | line_no2 > 0 214 then if line_no1 > 0 & line_no2 > 0 215 then call ioa_$rsnnl (" on line ^d-^d", online, len, line_no2, line_no1); 216 else call ioa_$rsnnl (" on line ^d", online, len, line_no1); 217 else online = ""; 218 call ioa_$rs ("Error occurred at ^p^a^a", tline, len, error_ptr, inprog, online); 219 substr (errline, erroff, len) = tline; 220 errlen = erroff + len - 1; 221 return; 222 223 224 /*************************************/ 225 print_cobol_error_: 226 entry; 227 dcl stream char (32); /*[4.0-1]*/ 228 stream = "error_output"; 229 go to join; 230 231 switch: 232 entry (in_stream); 233 dcl in_stream char (*) parameter; 234 stream = in_stream; 235 236 join: 237 if errlen = 0 238 then call ioa_$ioa_stream (stream, "Improper call to print_cobol_error_ - no pending error recorded"); 239 else call ioa_$ioa_stream (stream, substr (errline, 1, errlen)); 240 return; 241 242 /*************************************/ 243 abort: 244 call signal_ ("error"); 245 246 set_cet_ptr: 247 proc; 248 evar = cobol_error_; 249 call hcs_$make_ptr (bptr, "cobol_error_table_", "cobol_error_table_", cet_ptr, code); 250 if cet_ptr = null () 251 then do; 252 call com_err_ (code, "cobol rts", "cobol_error_table_$cobol_error_table_"); 253 go to abort; 254 end; 255 return; 256 end set_cet_ptr; 257 258 /***** Declaration for builtin function *****/ 259 260 dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) 261 builtin; 262 263 /***** End of declaration for builtin function *****/ 264 265 end cobol_error_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/24/89 0836.9 cobol_error_.pl1 >spec>install>MR12.3-1048>cobol_error_.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 260 ref 249 bptr based pointer dcl 109 set ref 249* cet based char(100000) packed unaligned dcl 92 ref 143 143 202 202 cet_ptr 000010 internal static pointer initial dcl 91 set ref 126 141 143 143 143 143 143 143 172 198 202 202 202 202 202 202 249* 250 cobol_code parameter fixed bin(17,0) dcl 36 set ref 26 137 141 141* 143 143 143 143 158* 165 190 198 198* 202 202 202 202 cobol_error_$use 000126 constant entry external dcl 111 ref 158 cobol_error_table based structure level 1 unaligned dcl 93 code 000101 automatic fixed bin(35,0) dcl 99 set ref 148* 149 209* 210 249* 252* com_err_ 000132 constant entry external dcl 114 ref 252 convert_status_code_ 000130 constant entry external dcl 112 ref 131 178 dname 000102 automatic char(168) packed unaligned dcl 101 set ref 148* 151 209* 212 ename 000154 automatic char(32) packed unaligned dcl 102 set ref 148* 151 209* 212 errlen 000125 internal static fixed bin(17,0) initial dcl 170 set ref 220* 236 239 239 errline 000012 internal static char(300) packed unaligned dcl 167 set ref 182* 186* 195* 204* 219* 239 239 erroff 000342 automatic fixed bin(17,0) dcl 169 set ref 175* 182 183* 183 186 187* 187 195 196* 196 204 205* 205 219 220 error 1 based structure array level 2 dcl 93 error_ptr parameter pointer dcl 41 set ref 26 148* 157* 158* 165 209* 218* evar 000300 automatic entry variable dcl 108 set ref 248* 249 hcs_$fs_get_path_name 000146 constant entry external dcl 120 ref 148 209 hcs_$make_ptr 000134 constant entry external dcl 115 ref 249 in_stream parameter char packed unaligned dcl 233 ref 231 234 inprog 000164 automatic char(168) packed unaligned dcl 103 set ref 149* 151* 157* 210* 212* 218* ioa_$ioa_stream 000136 constant entry external dcl 116 ref 134 141 143 157 236 239 ioa_$ioa_stream_nnl 000140 constant entry external dcl 117 ref 132 139 ioa_$rs 000142 constant entry external dcl 118 ref 185 198 202 218 ioa_$rsnnl 000144 constant entry external dcl 119 ref 152 155 181 194 213 216 len 000100 automatic fixed bin(17,0) dcl 98 in procedure "cobol_error_" set ref 148* 151 152* 155* 181* 182 183 185* 186 187 194* 195 196 198* 202* 204 205 209* 212 213* 216* 218* 219 220 len 1(18) based fixed bin(17,0) array level 3 in structure "cobol_error_table" packed packed unaligned dcl 93 in procedure "cobol_error_" ref 143 143 202 202 line_no1 parameter fixed bin(17,0) dcl 38 set ref 26 152 152 152* 155* 158* 165 213 213 213* 216* line_no2 parameter fixed bin(17,0) dcl 39 set ref 26 152 152 152* 158* 165 213 213 213* longinfo 000246 automatic char(100) dcl 106 set ref 131* 134* 178* 185* max based fixed bin(17,0) level 2 dcl 93 ref 141 198 multics_code parameter fixed bin(35,0) dcl 37 set ref 26 129 131* 158* 165 176 178* null builtin function dcl 260 ref 126 172 250 online 000236 automatic char(24) packed unaligned dcl 104 set ref 152* 155* 156* 157* 213* 216* 217* 218* progname parameter varying char(65) dcl 40 set ref 26 132 132* 139 139* 158* 165 179 181* 192 194* shortinfo 000244 automatic char(8) dcl 105 set ref 131* 178* signal_ 000150 constant entry external dcl 122 ref 160 243 start 1 based fixed bin(17,0) array level 3 packed packed unaligned dcl 93 ref 143 143 202 202 stream 000343 automatic char(32) packed unaligned dcl 227 set ref 228* 234* 236* 239* substr builtin function dcl 260 set ref 143 143 151 182* 186* 195* 202 202 204* 212 219* 239 239 tline 000304 automatic char(120) packed unaligned dcl 168 set ref 181* 182 185* 186 194* 195 198* 202* 204 218* 219 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. addrel builtin function dcl 260 binary builtin function dcl 260 fixed builtin function dcl 260 index builtin function dcl 260 length builtin function dcl 260 mod builtin function dcl 260 rel builtin function dcl 260 string builtin function dcl 260 unspec builtin function dcl 260 NAMES DECLARED BY EXPLICIT CONTEXT. abort 001611 constant label dcl 243 ref 253 cobol_error_ 000133 constant entry external dcl 26 ref 248 join 001542 constant label dcl 236 ref 229 print_cobol_error_ 001505 constant entry external dcl 225 set_cet_ptr 001625 constant entry internal dcl 246 ref 126 172 start 000140 constant label dcl 126 start_use 000716 constant label dcl 172 switch 001521 constant entry external dcl 231 use 000711 constant entry external dcl 165 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 2076 2250 1731 2106 Length 2460 1731 152 174 145 116 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME cobol_error_ 380 external procedure is an external procedure. set_cet_ptr internal procedure shares stack frame of external procedure cobol_error_. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 cet_ptr cobol_error_ 000012 errline cobol_error_ 000125 errlen cobol_error_ STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME cobol_error_ 000100 len cobol_error_ 000101 code cobol_error_ 000102 dname cobol_error_ 000154 ename cobol_error_ 000164 inprog cobol_error_ 000236 online cobol_error_ 000244 shortinfo cobol_error_ 000246 longinfo cobol_error_ 000300 evar cobol_error_ 000304 tline cobol_error_ 000342 erroff cobol_error_ 000343 stream cobol_error_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_g_a alloc_char_temp cat_realloc_chars call_ext_out_desc call_ext_out return_mac shorten_stack ext_entry ext_entry_desc THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. cobol_error_$use com_err_ convert_status_code_ hcs_$fs_get_path_name hcs_$make_ptr ioa_$ioa_stream ioa_$ioa_stream_nnl ioa_$rs ioa_$rsnnl signal_ NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 26 000125 126 000140 129 000145 131 000150 132 000163 134 000221 137 000242 139 000245 141 000302 143 000337 146 000374 148 000375 149 000427 151 000435 152 000473 155 000550 156 000602 157 000605 158 000651 160 000673 161 000706 165 000707 172 000716 175 000724 176 000726 178 000731 179 000744 181 000753 182 001002 183 001010 185 001012 186 001033 187 001041 190 001043 192 001046 194 001054 195 001103 196 001111 198 001113 202 001147 204 001204 205 001213 209 001215 210 001247 212 001255 213 001313 216 001370 217 001422 218 001425 219 001471 220 001477 221 001503 225 001504 228 001512 229 001515 231 001516 234 001534 236 001542 239 001565 240 001607 243 001611 265 001624 246 001625 248 001626 249 001632 250 001667 252 001674 253 001723 255 001724 ----------------------------------------------------------- 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