COMPILATION LISTING OF SEGMENT build_message_segment Compiled by: Multics PL/I Compiler, Release 27d, of October 11, 1982 Compiled at: Honeywell LISD Phoenix, System M Compiled on: 11/15/82 1705.1 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 build_message_segment: proc(xsource_ptr,xobj_ptr, bitcnt); 12 13 /* Modified: 17 Dec 1979 to make all return statements in another_string return value */ 14 /* This program is in sad shape and should be rewritten. */ 15 16 dcl (xsource_ptr, xobj_ptr, source_ptr, obj_ptr) ptr, bitcnt fixed bin(24); 17 18 dcl 1 object_segment based(obj_ptr), 19 2 index_block(0:500), 20 3 message_pointer fixed bin(17), /*Pointer to start of message.*/ 21 3 severity fixed bin(17), /*Severity level for this message*/ 22 3 len fixed bin(17), /*Number of characters for this message.*/ 23 2 message_block char(248000) aligned; /*Text for all messages.*/ 24 25 dcl (old_seq_number init(0), new_seq_number,i, 26 severity_code) fixed bin(17); 27 28 dcl xstring char(64) varying aligned, garbage bit(1) aligned; 29 30 dcl ll fixed bin(15); 31 32 dcl ioa_ entry options(variable); 33 34 dcl ( s_first,s_last,o_current ) fixed bin(17) init (1); 35 36 dcl source_string char(256000) aligned based(source_ptr); 37 38 dcl old_first fixed bin(17); /*Beginning of string; to facilitate backing up. */ 39 40 dcl cur_char char(1) aligned; 41 42 dcl white_space char(3) static init(" 43 "); /* new_lline, space, tab */ 44 45 46 dcl NLNL init(" 47 48 ") char(2) int static; 49 50 dcl (index,length,search,substr) builtin; 51 52 53 54 55 56 obj_ptr = xobj_ptr; 57 source_ptr=xsource_ptr; 58 59 60 do while(another_message()); 61 /*Process sequence number.*/ 62 garbage=another_string(xstring); /*Get first string*/ 63 new_seq_number=0; 64 do ll=1 to length(xstring); 65 new_seq_number=new_seq_number*10+index("123456789",substr(xstring,ll,1)); 66 end; 67 if new_seq_number > 500 68 then do; 69 call ioa_("Sequence number > 500--fatal error"); 70 return; 71 end; 72 if new_seq_number <= old_seq_number 73 then do; 74 call ioa_("Message number ^d is out of sequence--fatal error",new_seq_number); 75 return; 76 end; 77 else do i=old_seq_number+1 to new_seq_number-1; 78 /*Set index block entries for missing messages.*/ 79 index_block(i).message_pointer = -1; 80 index_block(i).len = 0; 81 index_block(i).severity = 0; 82 end; 83 84 old_seq_number = new_seq_number; /*Advance old_seq_number.*/ 85 86 87 88 89 /*Process Severity Level Code.*/ 90 91 old_first = s_first; /*To permit backing up if no Severity Code.*/ 92 93 if another_string(xstring) 94 then do; /*Determine and insert severity level code*/ 95 if substr(xstring,1,1) = "(" /*Assume "(" adequate*/ 96 then do; 97 do i = 2 by 1 while(substr(xstring,i,1) ^= ")" ); end; 98 /*Extract severity code from enclosing parentheses*/ 99 severity_code = index("1234",substr(xstring,2,1)); 100 if severity_code > 4 101 then do; 102 call ioa_("Invalid severity for message ^d--fatal error",new_seq_number); 103 return; 104 end; 105 else index_block(new_seq_number).severity 106 = severity_code; 107 end; 108 else do; 109 index_block(new_seq_number).severity 110 = 2; /*Default value of two.*/ 111 s_first = old_first; /*Back up.*/ 112 end; 113 end; 114 else do; /*No more strings after sequence number*/ 115 call ioa_("Message number ^d is null--fatal error."); 116 return; 117 end; 118 /*End of Severity Level Code Processing.*/ 119 120 121 122 123 /* Move message text to object segment. */ 124 125 dcl cum_length fixed bin(17), delim_count fixed bin(17) init(0); 126 cum_length=0; 127 128 do s_first = s_first by 1 while 129 (substr(source_string,s_first,2)^=NLNL); 130 /*Copy message.*/ 131 132 133 cur_char=substr(source_string,s_first,1); 134 if search(cur_char,white_space) = 1 135 then do; 136 delim_count=delim_count+1;/*Count redundant delimeters.*/ 137 if delim_count = 1 138 then do; 139 substr(message_block,o_current,1)=" "; 140 o_current=o_current+1; 141 cum_length=cum_length+1; 142 end; 143 end; 144 else do; 145 delim_count=0; 146 substr(message_block,o_current,1)=cur_char; 147 o_current=o_current+1; 148 cum_length=cum_length+1; 149 end; 150 151 end; 152 153 index_block(new_seq_number).len = cum_length; 154 index_block(new_seq_number).message_pointer 155 =o_current-cum_length; 156 s_first=s_first+2; /*Bypass two trailing nl's.*/ 157 158 159 end; /*End of the major "do while(another_message)" block.*/ 160 161 162 /*Close out object segment by filling in remaining 163* index block entries with "null" values. */ 164 165 166 do i=old_seq_number+1 to 500; 167 index_block(i).message_pointer = -1; 168 index_block(i).len = 0; 169 index_block(i).severity = 0; 170 end; 171 172 /*Compute bit count for return to command.*/ 173 174 bitcnt = 3*501*36+9*o_current; 175 176 return; /*Processing done.*/ 177 178 179 180 /*Internal procedure to locate next string in text.*/ 181 182 another_string: proc(xstring) returns(bit(1)); 183 184 /*another_string locates and returns the next string, 185* if there is one, in a message, returning with its function 186* value set to "1". If no more strings exist in the message, 187* the value is "0". another_string is entered with s_first 188* pointing to the first character following the previous 189* string in the message.*/ 190 191 dcl xstring char(64) varying aligned; 192 193 dcl k fixed bin, skip_comments bit(1); 194 195 if substr(source_string,s_first,2)^=NLNL 196 then do; 197 198 skip_comments = "1"b; 199 do while(skip_comments); 200 201 /* skip over white space */ 202 203 do while(search(substr(source_string,s_first,1),white_space) ^= 0); 204 s_first = s_first + 1; 205 end; 206 207 if substr(source_string,s_first,2) = "/*" 208 then do; 209 k = index(substr(source_string,s_first+2),"*/"); 210 211 if k = 0 212 then do; 213 call ioa_("Unbalanced comment--fatal error"); 214 return("0"b); 215 end; 216 217 s_first = s_first + k + 4; 218 end; 219 else skip_comments = "0"b; 220 end; 221 222 /* scan until we hit white space */ 223 224 s_last = s_first + 1; 225 do while(search(substr(source_string,s_last,1),white_space) = 0); 226 s_last = s_last + 1; 227 end; 228 229 xstring = substr(source_string,s_first,s_last-s_first); 230 s_first = s_last; 231 232 return("1"b); 233 end; 234 235 return("0"b); /*End of message.*/ 236 237 end another_string; 238 239 240 241 /*Internal procedure to determine existance of 242* another message in the text.*/ 243 244 another_message: proc returns(bit(1)); 245 246 /*another_message returns with a function value of 247* "1" if there is another message in the text; else 248* it returns with a value of "0".*/ 249 250 251 dcl xstring char(64) varying aligned; 252 253 254 old_first=s_first; /*To permit backing up, if necessary.*/ 255 garbage=another_string(xstring); 256 if xstring="(end)" then return("0"b); 257 else do; 258 s_first=old_first; /*Back up.*/ 259 return("1"b); 260 end; 261 262 end another_message; 263 264 265 266 end build_message_segment; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/15/82 1508.8 build_message_segment.pl1 >dumps>old>recomp>build_message_segment.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. NLNL 000756 constant char(2) initial unaligned dcl 46 ref 128 195 bitcnt parameter fixed bin(24,0) dcl 16 set ref 11 174* cum_length 000140 automatic fixed bin(17,0) dcl 125 set ref 126* 141* 141 148* 148 153 154 cur_char 000137 automatic char(1) dcl 40 set ref 133* 134 146 delim_count 000141 automatic fixed bin(17,0) initial dcl 125 set ref 125* 136* 136 137 145* garbage 000131 automatic bit(1) dcl 28 set ref 62* 255* i 000106 automatic fixed bin(17,0) dcl 25 set ref 77* 79 80 81* 97* 97* 166* 167 168 169* index builtin function dcl 50 ref 65 99 209 index_block based structure array level 2 unaligned dcl 18 ioa_ 000010 constant entry external dcl 32 ref 69 74 102 115 213 k 000152 automatic fixed bin(17,0) dcl 193 set ref 209* 211 217 len 2 based fixed bin(17,0) array level 3 dcl 18 set ref 80* 153* 168* length builtin function dcl 50 ref 64 ll 000132 automatic fixed bin(15,0) dcl 30 set ref 64* 65* message_block 2737 based char(248000) level 2 dcl 18 set ref 139* 146* message_pointer based fixed bin(17,0) array level 3 dcl 18 set ref 79* 154* 167* new_seq_number 000105 automatic fixed bin(17,0) dcl 25 set ref 63* 65* 65 67 72 74* 77 84 102* 105 109 153 154 o_current 000135 automatic fixed bin(17,0) initial dcl 34 set ref 34* 139 140* 140 146 147* 147 154 174 obj_ptr 000102 automatic pointer dcl 16 set ref 56* 79 80 81 105 109 139 146 153 154 167 168 169 object_segment based structure level 1 unaligned dcl 18 old_first 000136 automatic fixed bin(17,0) dcl 38 set ref 91* 111 254* 258 old_seq_number 000104 automatic fixed bin(17,0) initial dcl 25 set ref 25* 72 77 84* 166 s_first 000133 automatic fixed bin(17,0) initial dcl 34 set ref 34* 91 111* 128* 128 128* 133* 156* 156 195 203 204* 204 207 209 217* 217 224 229 229 230* 254 258* s_last 000134 automatic fixed bin(17,0) initial dcl 34 set ref 34* 224* 225 226* 226 229 230 search builtin function dcl 50 ref 134 203 225 severity 1 based fixed bin(17,0) array level 3 dcl 18 set ref 81* 105* 109* 169* severity_code 000107 automatic fixed bin(17,0) dcl 25 set ref 99* 100 105 skip_comments 000153 automatic bit(1) unaligned dcl 193 set ref 198* 199 219* source_ptr 000100 automatic pointer dcl 16 set ref 57* 128 133 195 203 207 209 225 229 source_string based char(256000) dcl 36 ref 128 133 195 203 207 209 225 229 substr builtin function dcl 50 set ref 65 95 97 99 128 133 139* 146* 195 203 207 209 225 229 white_space 000000 constant char(3) initial unaligned dcl 42 ref 134 203 225 xobj_ptr parameter pointer dcl 16 ref 11 56 xsource_ptr parameter pointer dcl 16 ref 11 57 xstring parameter varying char(64) dcl 191 in procedure "another_string" set ref 182 229* xstring 000110 automatic varying char(64) dcl 28 in procedure "build_message_segment" set ref 62* 64 65 93* 95 97 99 xstring 000162 automatic varying char(64) dcl 251 in procedure "another_message" set ref 255* 256 NAMES DECLARED BY EXPLICIT CONTEXT. another_message 000674 constant entry internal dcl 244 ref 60 another_string 000521 constant entry internal dcl 182 ref 62 93 255 build_message_segment 000116 constant entry external dcl 11 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1016 1030 761 1026 Length 1200 761 12 134 34 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME build_message_segment 189 external procedure is an external procedure. another_string internal procedure shares stack frame of external procedure build_message_segment. another_message internal procedure shares stack frame of external procedure build_message_segment. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME build_message_segment 000100 source_ptr build_message_segment 000102 obj_ptr build_message_segment 000104 old_seq_number build_message_segment 000105 new_seq_number build_message_segment 000106 i build_message_segment 000107 severity_code build_message_segment 000110 xstring build_message_segment 000131 garbage build_message_segment 000132 ll build_message_segment 000133 s_first build_message_segment 000134 s_last build_message_segment 000135 o_current build_message_segment 000136 old_first build_message_segment 000137 cur_char build_message_segment 000140 cum_length build_message_segment 000141 delim_count build_message_segment 000152 k another_string 000153 skip_comments another_string 000162 xstring another_message THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. call_ext_out_desc return ext_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. ioa_ NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 11 000112 25 000123 34 000124 125 000130 56 000131 57 000135 60 000140 62 000145 63 000152 64 000153 65 000162 66 000177 67 000201 69 000204 70 000220 72 000221 74 000223 75 000243 77 000244 79 000254 80 000260 81 000262 82 000263 84 000265 91 000267 93 000271 95 000276 97 000302 97 000311 99 000313 100 000324 102 000326 103 000346 105 000347 107 000355 109 000356 111 000364 113 000366 115 000367 116 000403 126 000404 128 000405 133 000415 134 000421 136 000432 137 000433 139 000436 140 000443 141 000444 143 000445 145 000446 146 000447 147 000454 148 000455 151 000456 153 000460 154 000466 156 000471 159 000473 166 000474 167 000502 168 000506 169 000510 170 000511 174 000513 176 000520 182 000521 195 000523 198 000531 199 000533 203 000535 204 000547 205 000550 207 000551 209 000555 211 000574 213 000575 214 000611 217 000617 218 000622 219 000623 220 000624 224 000625 225 000630 226 000642 227 000643 229 000644 230 000660 232 000662 235 000667 244 000674 254 000676 255 000700 256 000705 258 000720 259 000722 ----------------------------------------------------------- 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