COMPILATION LISTING OF SEGMENT upd_print_err_ Compiled by: Multics PL/I Compiler, Release 27d, of October 11, 1982 Compiled at: Honeywell LISD Phoenix, System M Compiled on: 11/15/82 1724.5 mst Mon 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 11 upd_print_err_: procedure (code, sev); 12 13 14 /* 15* 16* This procedure will format and print an error message, given a 17* status code, severity code, condition name, procedure name, and 18* optional ioa_ string and arguments. Character string arguments 19* which are "" (null string) will result in suppression of the 20* corresponding portions of the message, as will status code and 21* severity code of 0. In addition, the case of severity code only 22* is special-cased to produce the message 23* 24* "An error of severity _n has occurred." 25* 26* and the case of status code/format string and procedure/entry 27* name only is special-cased to produce 28* 29* "proc$entry: Expanded error message." 30* 31* in the format of com_err_. Calling sequence to print_err_ is: 32* 33* call upd_print_err_(code, sev, prefix, condition, 34* proc, entry, string, args ...); 35* 36* (1) code fixed bin(35) status code 37* (2) sev fixed bin severity code 38* (3) prefix char(*) instead of "Error" 39* (4) condition char(*) condition name 40* (5) proc char(*) procedure name 41* (6) entry char(*) entry point name 42* (7) string char(*) format string 43* (8) args ... format args 44* 45* The error message produced will be a subset of: 46* 47* Error (severity _n): condition condition from proc$entry 48* Expanded error message. Optional formatted string. 49* 50* Trailing unwanted arguments may be omitted. 51* 52* P. Bos, May 1972 53* 54**/ 55 56 /* */ 57 58 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 59 60 61 dcl code fixed bin(35), /* status code */ 62 sev fixed bin, /* severity code */ 63 prefix char(xl) based(xp), /* message prefix */ 64 condition char(cl) based(cp), /* condition name */ 65 proc char(pl) based(pp), /* procedure name */ 66 entry char(el) based(ep), /* entry point name */ 67 string char(sl) based(sp); /* ioa_$general_rs control_ string */ 68 69 dcl check_fs_errcode_ entry (fixed bin(35), char(8) aligned, char(300) aligned), 70 convert_binary_integer_$decimal_string entry (fixed bin) returns (char(12) varying), 71 cu_$arg_count entry (fixed bin), 72 cu_$arg_list_ptr entry (ptr), 73 cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35)), 74 ioa_$general_rs entry (ptr, fixed bin, fixed bin, char(*) aligned, fixed bin, bit(1) aligned, 75 bit(1) aligned), 76 ios_$write entry (char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned); 77 78 dcl (addr, null) builtin; 79 80 dcl sws bit(5) aligned; /* control bits for message subfields */ 81 82 dcl (cl, el, i, l, n, pl, sl, xl) fixed bin, 83 ignore fixed bin(35), 84 nelemt fixed bin, 85 status_code bit(72) aligned; 86 87 dcl (argp, cp, ep, p, pp, sp, swp, xp) 88 ptr; 89 90 dcl chars char(i) based(p), /* unaligned char string overlay */ 91 dummy char(8) aligned, /* ignored short format from check_fs_errcode_ */ 92 info char(300) aligned, /* long form message from same */ 93 line char(400) aligned; /* output message */ 94 95 dcl 1 s aligned based(swp), /* bit array overlaid on "sws" */ 96 2 sw (5) bit(1) unal; 97 98 /* */ 99 100 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 101 102 103 sws = "00000"b; /* initialize */ 104 sl, el, pl, cl, xl = 0; /* nobody home yet */ 105 swp = addr (sws); /* for bit array overlay */ 106 call cu_$arg_count (n); /* get number of arguments supplied */ 107 if n > 6 then do; /* user supplied ioa_$general_rs control_ string */ 108 call cu_$arg_ptr (7, sp, sl, ignore); /* get arg pointer and size */ 109 call adjust (sp, sl); /* strip leading & trailing blanks */ 110 if sl ^= 0 then /* anything left? */ 111 s.sw(1) = "1"b; /* error message switch */ 112 go to a; /* skip */ 113 end; 114 if n > 5 then do; /* entry name supplied */ 115 a: call cu_$arg_ptr (6, ep, el, ignore); /* get pointer and length */ 116 call adjust (ep, el); /* get rid of leading and trailing blanks */ 117 if el ^= 0 then /* anything left? */ 118 s.sw(4) = "1"b; /* proc$entry switch */ 119 go to b; /* skip */ 120 end; 121 if n > 4 then do; /* procedure name supplied */ 122 b: call cu_$arg_ptr (5, pp, pl, ignore); /* get pointer and length */ 123 call adjust (pp, pl); /* strip leading & trailing blanks */ 124 if pl ^= 0 then /* all blanks? */ 125 s.sw(4) = "1"b; /* proc$entry switch */ 126 go to c; /* skip */ 127 end; 128 if n > 3 then do; /* condition name supplied */ 129 c: call cu_$arg_ptr (4, cp, cl, ignore); /* get pointer and length */ 130 call adjust (cp, cl); /* strip blanks */ 131 if cl ^= 0 then /* was it really supplied? */ 132 s.sw(3) = "1"b; /* yes */ 133 go to d; /* skip */ 134 end; 135 if n > 2 then do; /* prefix arg supplied? */ 136 d: call cu_$arg_ptr (3, xp, xl, ignore); /* yes, get it */ 137 call adjust (xp, xl); /* get rid of blanks */ 138 if xl ^= 0 then /* was it really supplied ? */ 139 s.sw(5) = "1"b; /* yes */ 140 go to h; /* skip */ 141 end; 142 if n > 1 then do; /* severity code supplied? */ 143 h: if sev ^= 0 then /* omitted if zero */ 144 s.sw(2) = "1"b; /* but it's there */ 145 go to e; /* skip */ 146 end; 147 if n ^= 0 then /* how about status code? */ 148 e: if code ^= 0 then /* zero code implies not there */ 149 s.sw(1) = "1"b; /* error message switch */ 150 151 l = 1; /* output message starts out length one */ 152 line = " 153 "; /* start with a carriage return. */ 154 if sws = "01000"b then /* special case for severity code only */ 155 go to sevmsg; /* skip */ 156 if sws = "10010"b then /* and for status code/procedure name */ 157 go to errmsg; /* skip also */ 158 159 if xl ^= 0 then /* did caller specify prefix string? */ 160 call addchr (prefix); /* yes, use his */ 161 else /* no, */ 162 call addchr ("Error"); /* use canned one */ 163 if sws & "0100"b then /* severity code supplied? */ 164 call addchr (" (severity " || convert_binary_integer_$decimal_string (sev) || ")"); 165 if ((sws & "1001"b) = "1000"b) | (sws & "0011"b) then 166 /* if followed by err msg, cond name, or proc name */ 167 call addchr (":"); /* add colon */ 168 if sws & "0010"b then /* N.B. note red, black shift chars */ 169 call addchr (" " || condition || " condition"); /* around condition name */ 170 if sws & "0001"b then do; /* procedure/entry name supplied? */ 171 call addchr (" from "); /* note red shift after "from" */ 172 if pl ^= 0 then /* if procedure name there, */ 173 call addchr (proc); /* insert it */ 174 if el ^= 0 then /* if entry name there, */ 175 call addchr ("$" || entry); /* add him too */ 176 call addchr (""); /* black shift */ 177 end; 178 if sws & "1000"b then do; /* status code or format string */ 179 if (sws & "0011"b) then /* if condition name or procedure name, */ 180 call addchr (" 181 "); else /* new_line in previous stmt */ 182 call addchr (" "); /* if not, rest goes on same line */ 183 f: if code ^= 0 then do; /* status code? */ 184 call check_fs_errcode_(code, dummy, info); /* expand it into a message */ 185 p = addr (info); /* get pointer, size for adjust */ 186 i = 100; 187 call adjust (p, i); /* strip leading, trailing blanks */ 188 if i ^= 0 then /* anything left? */ 189 call addchr (chars); /* do it to it */ 190 if sl ^= 0 then do; /* if formatted string there also, */ 191 call addchr (" "); /* insert couple of blanks */ 192 go to g; /* skip */ 193 end; 194 end; 195 if sl ^= 0 then do; /* did user supply ioa_$general_rs control_ string? */ 196 g: if n > 7 then do; /* yes, were there args to be formatted? */ 197 sp = addr (info); /* yes, get a place to put them */ 198 sl = 300; /* initialize length */ 199 call cu_$arg_list_ptr (argp); /* get ptr to our argument list. */ 200 call ioa_$general_rs (argp, 7, 8, info, sl, "0"b, "1"b); 201 end; /* otherwise, sp, sl still point to arg 6 */ 202 call addchr (string); /* insert it */ 203 end; 204 end; 205 call addchr (" 206 "); /* add terminal carriage return */ 207 208 write: call ios_$write ("installation_error_", addr (line), 0, l, nelemt, status_code); 209 /* write message onto error stream. */ 210 return; /* done. */ 211 212 213 sevmsg: call addchr ("An error of severity " || convert_binary_integer_$decimal_string (sev) || " has occurred. 214 "); go to write; /* lots of new_line's in strings */ 215 216 217 errmsg: if pl ^= 0 then /* here to form com_err_ style message */ 218 call addchr (proc); /* procedure name */ 219 if el ^= 0 then 220 call addchr ("$" || entry); /* entry name */ 221 call addchr (": "); /* colon, spaces */ 222 go to f; /* join common code to add error message, string */ 223 224 /* */ 225 226 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 227 228 229 addchr: procedure (arg); /* procedure to add arg to line */ 230 231 232 dcl arg char(*); /* char string to insert into line */ 233 234 dcl (length, substr) builtin; 235 236 dcl t fixed bin; /* temp */ 237 238 239 t = length (arg); /* get size of string to add */ 240 if t > 400 - l then /* maximum of 400 chars in message */ 241 t = 400 - l; /* make sure we don't run off end */ 242 if t ^= 0 then do; /* still room, put it in */ 243 substr (line, l+1, t) = arg; /* after what's already there */ 244 l = l + t; /* line got longer */ 245 end; 246 return; /* done */ 247 248 end addchr; 249 250 251 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 252 253 254 adjust: procedure (argp, argl); /* procedure to strip leading, trailing blanks */ 255 256 257 dcl argp ptr, /* pointer to char string */ 258 argl fixed bin; /* length of string */ 259 260 dcl t fixed bin; /* temp */ 261 262 dcl 1 c based (argp), /* char array overlaid on string */ 263 2 char (argl) char(1) unal; /* makes better code than substr */ 264 265 266 do t = 1 to argl; /* scan from front for first non-blank */ 267 if c.char(t) ^= " " then /* non-blank? */ 268 go to first; /* yes, exit loop */ 269 end; 270 first: argp = addr (c.char(t)); /* adjust pointer to point to it */ 271 argl = argl - t + 1; /* adjust length */ 272 if argl ^= 0 then do; /* if string not all blank */ 273 do t = argl to 1 by -1; /* scan from end for last non-blank */ 274 if c.char(t) ^= " " then /* found it? */ 275 go to last; /* yes, skip */ 276 end; 277 last: argl = t; /* set new length */ 278 end; 279 return; /* bye... */ 280 281 end adjust; 282 283 284 end upd_print_err_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/15/82 1514.4 upd_print_err_.pl1 >dumps>old>recomp>upd_print_err_.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 78 ref 105 185 197 208 208 270 arg parameter char unaligned dcl 232 ref 229 239 243 argl parameter fixed bin(17,0) dcl 257 set ref 254 266 271* 271 272 273 277* argp 000116 automatic pointer dcl 87 in procedure "upd_print_err_" set ref 199* 200* argp parameter pointer dcl 257 in procedure "adjust" set ref 254 267 270* 270 274 c based structure level 1 packed unaligned dcl 262 char based char(1) array level 2 packed unaligned dcl 262 set ref 267 270 274 chars based char unaligned dcl 90 set ref 188* check_fs_errcode_ 000010 constant entry external dcl 69 ref 184 cl 000101 automatic fixed bin(17,0) dcl 82 set ref 104* 129* 130* 131 168 code parameter fixed bin(35,0) dcl 61 set ref 11 147 183 184* condition based char unaligned dcl 61 ref 168 convert_binary_integer_$decimal_string 000012 constant entry external dcl 69 ref 163 213 cp 000120 automatic pointer dcl 87 set ref 129* 130* 168 cu_$arg_count 000014 constant entry external dcl 69 ref 106 cu_$arg_list_ptr 000016 constant entry external dcl 69 ref 199 cu_$arg_ptr 000020 constant entry external dcl 69 ref 108 115 122 129 136 dummy 000136 automatic char(8) dcl 90 set ref 184* el 000102 automatic fixed bin(17,0) dcl 82 set ref 104* 115* 116* 117 174 174 219 219 entry based char unaligned dcl 61 ref 174 219 ep 000122 automatic pointer dcl 87 set ref 115* 116* 174 219 i 000103 automatic fixed bin(17,0) dcl 82 set ref 186* 187* 188 188 188 ignore 000111 automatic fixed bin(35,0) dcl 82 set ref 108* 115* 122* 129* 136* info 000140 automatic char(300) dcl 90 set ref 184* 185 197 200* ioa_$general_rs 000022 constant entry external dcl 69 ref 200 ios_$write 000024 constant entry external dcl 69 ref 208 l 000104 automatic fixed bin(17,0) dcl 82 set ref 151* 208* 240 240 243 244* 244 length builtin function dcl 234 ref 239 line 000253 automatic char(400) dcl 90 set ref 152* 208 208 243* n 000105 automatic fixed bin(17,0) dcl 82 set ref 106* 107 114 121 128 135 142 147 196 nelemt 000112 automatic fixed bin(17,0) dcl 82 set ref 208* p 000124 automatic pointer dcl 87 set ref 185* 187* 188 pl 000106 automatic fixed bin(17,0) dcl 82 set ref 104* 122* 123* 124 172 172 172 217 217 217 pp 000126 automatic pointer dcl 87 set ref 122* 123* 172 217 prefix based char unaligned dcl 61 set ref 159* proc based char unaligned dcl 61 set ref 172* 217* s based structure level 1 dcl 95 sev parameter fixed bin(17,0) dcl 61 set ref 11 143 163* 213* sl 000107 automatic fixed bin(17,0) dcl 82 set ref 104* 108* 109* 110 190 195 198* 200* 202 202 sp 000130 automatic pointer dcl 87 set ref 108* 109* 197* 202 status_code 000114 automatic bit(72) dcl 82 set ref 208* string based char unaligned dcl 61 set ref 202* substr builtin function dcl 234 set ref 243* sw based bit(1) array level 2 packed unaligned dcl 95 set ref 110* 117* 124* 131* 138* 143* 147* swp 000132 automatic pointer dcl 87 set ref 105* 110 117 124 131 138 143 147 sws 000100 automatic bit(5) dcl 80 set ref 103* 105 154 156 163 165 165 168 170 178 179 t 000426 automatic fixed bin(17,0) dcl 260 in procedure "adjust" set ref 266* 267* 270 271 273* 274* 277 t 000100 automatic fixed bin(17,0) dcl 236 in procedure "addchr" set ref 239* 240 240* 242 243 244 xl 000110 automatic fixed bin(17,0) dcl 82 set ref 104* 136* 137* 138 159 159 159 xp 000134 automatic pointer dcl 87 set ref 136* 137* 159 NAME DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. null builtin function dcl 78 NAMES DECLARED BY EXPLICIT CONTEXT. a 000133 constant label dcl 115 ref 112 addchr 001224 constant entry internal dcl 229 ref 159 161 163 165 168 171 172 174 176 179 181 188 191 202 205 213 217 219 221 adjust 001263 constant entry internal dcl 254 ref 109 116 123 130 137 187 b 000163 constant label dcl 122 ref 119 c 000213 constant label dcl 129 ref 126 d 000243 constant label dcl 136 ref 133 e 000303 constant label dcl 147 ref 145 errmsg 001144 constant label dcl 217 ref 156 f 000636 constant label dcl 183 ref 222 first 001305 constant label dcl 270 ref 267 g 000715 constant label dcl 196 ref 192 h 000273 constant label dcl 143 ref 140 last 001337 constant label dcl 277 ref 274 sevmsg 001073 constant label dcl 213 ref 154 upd_print_err_ 000055 constant entry external dcl 11 write 001026 constant label dcl 208 ref 214 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1534 1562 1413 1544 Length 1742 1413 26 143 121 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME upd_print_err_ 330 external procedure is an external procedure. addchr 66 internal procedure is called during a stack extension. adjust internal procedure shares stack frame of external procedure upd_print_err_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME addchr 000100 t addchr upd_print_err_ 000100 sws upd_print_err_ 000101 cl upd_print_err_ 000102 el upd_print_err_ 000103 i upd_print_err_ 000104 l upd_print_err_ 000105 n upd_print_err_ 000106 pl upd_print_err_ 000107 sl upd_print_err_ 000110 xl upd_print_err_ 000111 ignore upd_print_err_ 000112 nelemt upd_print_err_ 000114 status_code upd_print_err_ 000116 argp upd_print_err_ 000120 cp upd_print_err_ 000122 ep upd_print_err_ 000124 p upd_print_err_ 000126 pp upd_print_err_ 000130 sp upd_print_err_ 000132 swp upd_print_err_ 000134 xp upd_print_err_ 000136 dummy upd_print_err_ 000140 info upd_print_err_ 000253 line upd_print_err_ 000426 t adjust THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as alloc_cs cat_realloc_cs call_ext_out_desc call_ext_out call_int_this_desc return shorten_stack ext_entry int_entry_desc THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. check_fs_errcode_ convert_binary_integer_$decimal_string cu_$arg_count cu_$arg_list_ptr cu_$arg_ptr ioa_$general_rs ios_$write NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 11 000051 103 000062 104 000063 105 000070 106 000072 107 000100 108 000103 109 000122 110 000124 112 000130 114 000131 115 000133 116 000152 117 000154 119 000160 121 000161 122 000163 123 000202 124 000204 126 000210 128 000211 129 000213 130 000232 131 000234 133 000240 135 000241 136 000243 137 000262 138 000264 140 000270 142 000271 143 000273 145 000300 147 000301 151 000310 152 000312 154 000315 156 000320 159 000322 161 000337 163 000351 165 000423 168 000447 170 000510 171 000514 172 000526 174 000542 176 000571 178 000604 179 000607 181 000624 183 000636 184 000641 185 000654 186 000656 187 000660 188 000662 190 000676 191 000700 192 000712 195 000713 196 000715 197 000720 198 000722 199 000724 200 000733 202 001001 205 001014 208 001026 210 001072 213 001073 214 001142 217 001144 219 001160 221 001207 222 001222 229 001223 239 001237 240 001240 242 001250 243 001252 244 001261 246 001262 254 001263 266 001265 267 001274 269 001303 270 001305 271 001314 272 001320 273 001321 274 001325 276 001334 277 001337 279 001341 ----------------------------------------------------------- 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