COMPILATION LISTING OF SEGMENT format_pl1_modes_ Compiled by: Multics PL/I Compiler, Release 28d, of October 4, 1983 Compiled at: Honeywell Multics Op. - System M Compiled on: 08/10/84 0947.6 mst Fri 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 /* Scan a modes string and apply the modes to the current style. 12* 13* Written 5-Nov-79 by M. N. Davidoff. 14**/ 15 /* format: style5 */ 16 format_pl1_modes_: 17 procedure (P_temp_segs, P_modes_string, P_source_ptr, P_revert_ok_sw, 18 P_printed_error_msg_sw); 19 20 declare P_temp_segs (*) pointer; /* (Input) array of temporary segment pointers */ 21 declare P_modes_string char (*); /* (Input) modes string to scan */ 22 declare P_source_ptr pointer; /* (Input) pointer to control comment in source segment, or 23* null for a command line modes string */ 24 declare P_revert_ok_sw bit (1); /* (Input) on if there is a prevailing style */ 25 declare P_printed_error_msg_sw bit (1); /* (Input/Output) on if printed it's a bad modes string */ 26 27 /* automatic */ 28 29 declare modes_string_length fixed binary (21); 30 declare scan_index fixed binary (21); 31 declare scan_length fixed binary (21); 32 33 /* based */ 34 35 declare modes_string char (modes_string_length) 36 based (addr (P_modes_string)); 37 38 /* builtin */ 39 40 declare (addr, binary, divide, hbound, index, lbound, length, null, 41 reverse, rtrim, search, size, substr, verify) 42 builtin; 43 44 /* internal static */ 45 46 declare HT_SP char (2) internal static 47 options (constant) initial (" "); 48 declare digits char (10) internal static 49 options (constant) 50 initial ("0123456789"); 51 52 /* entry */ 53 54 declare com_err_ entry options (variable); 55 1 1 /* BEGIN INCLUDE FILE . . . format_pl1_dcls.incl.pl1 */ 1 2 1 3 /* DESCRIPTION: 1 4* This include file contains common definitions used by the format_pl1 1 5* programs. It defines tokens, statement types, mode types, etc. 1 6**/ 1 7 1 8 /* HISTORY: 1 9*Written by somebody, sometime. 1 10*Modified: 1 11*07/15/84 by R. Michael Tague: Added the statement types: 1 12* percent_abort_statement through percent_warn_statement. Added 1 13* the condition is_macro_whitespace. Added the modes: mode_indbegin, 1 14* mode_indbeginend, mode_indthenbegin, mode_indthenbeginend, 1 15* mode_indprocbody, mode_elsestmt, mode_equalind, and mode_linconind. 1 16* Added style5. 1 17**/ 1 18 1 19 /* format: style5 */ 1 20 1 21 /* automatic */ 1 22 1 23 declare temp_segs (4) pointer; 1 24 1 25 /* based */ 1 26 1 27 /* format_pl1_ places the unit_stack and the declare_stack after the token array */ 1 28 1 29 declare 1 token (divide (sys_info$max_seg_size, 3, 19)) 1 30 aligned based (temp_segs (1)), 1 31 2 string_size fixed binary (21) unaligned, 1 32 2 pad bit (5) unaligned, 1 33 2 type fixed binary (8) unaligned, 1 34 2 string_ptr pointer unaligned, 1 35 2 trailer_index fixed binary (17); 1 36 1 37 declare 1 trailer (divide (sys_info$max_seg_size, 2, 19)) 1 38 aligned based (temp_segs (2)), 1 39 2 string_size fixed binary (21) unaligned, 1 40 2 continued bit (1) unaligned, 1 41 2 pad bit (4) unaligned, 1 42 2 type fixed binary (8) unaligned, 1 43 2 string_ptr pointer unaligned; 1 44 1 45 /* format_pl1_ places the item array and the levels array after the stmt array */ 1 46 1 47 declare 1 global_header aligned based, 1 48 2 source_ptr pointer, 1 49 2 source_length fixed binary (21), 1 50 2 n_tokens fixed binary (17), 1 51 2 n_trailers fixed binary (17), 1 52 2 n_stmts fixed binary (17), 1 53 2 output_length fixed binary (21), 1 54 2 max_severity fixed binary (35), 1 55 2 modes_ptr pointer, 1 56 2 modes_length fixed binary (21), 1 57 2 ca unaligned, 1 58 3 check_comments bit (1), 1 59 3 check_strings bit (1), 1 60 3 force bit (1), 1 61 3 long bit (1), 1 62 3 record_style bit (1), 1 63 3 require_style_comment 1 64 bit (1), 1 65 2 flags unaligned, 1 66 3 include_file bit (1), 1 67 3 rdc_source bit (1), 1 68 3 pad bit (28), 1 69 2 command_line_style aligned like style, 1 70 2 prevailing_style aligned like style, 1 71 2 current_style aligned like style; 1 72 1 73 declare 1 global aligned based (temp_segs (3)), 1 74 2 header aligned like global_header, 1 75 2 stmt ( 1 76 divide (sys_info$max_seg_size 1 77 - size (global_header), 2, 19)), 1 78 3 type fixed binary (8) unaligned, 1 79 3 subtype fixed binary (8) unaligned, 1 80 3 start fixed binary (17) unaligned, 1 81 3 end fixed binary (17) unaligned, 1 82 3 pad bit (18) unaligned; 1 83 1 84 declare output_string char (4 * sys_info$max_seg_size) 1 85 based (temp_segs (4)); 1 86 1 87 /* internal static */ 1 88 1 89 declare command char (10) internal static 1 90 options (constant) initial ("format_pl1"); 1 91 1 92 /* token types */ 1 93 1 94 declare ( 1 95 no_token initial (0), 1 96 invalid_char initial (1), 1 97 identifier initial (2), 1 98 keyword_token initial (3), 1 99 isub initial (4), 1 100 plus initial (5), 1 101 minus initial (6), 1 102 asterisk initial (7), 1 103 slash initial (8), 1 104 expon initial (9), 1 105 not initial (10), 1 106 and initial (11), 1 107 or initial (12), 1 108 cat initial (13), 1 109 eq initial (14), 1 110 ne initial (15), 1 111 lt initial (16), 1 112 gt initial (17), 1 113 le initial (18), 1 114 ge initial (19), 1 115 ngt initial (20), 1 116 nlt initial (21), 1 117 prefix_plus initial (22), 1 118 prefix_minus initial (23), 1 119 assignment initial (24), 1 120 colon initial (25), 1 121 semi_colon initial (26), 1 122 comma initial (27), 1 123 period initial (28), 1 124 arrow initial (29), 1 125 left_parn initial (30), 1 126 right_parn initial (31), 1 127 percent initial (32), 1 128 target_comma initial (33), 1 129 comment_token initial (34), 1 130 nl_vt_np_token initial (35), 1 131 bit_string initial (36), 1 132 char_string initial (37), 1 133 fixed_bin initial (38), 1 134 bin_integer initial (39), 1 135 fixed_dec initial (40), 1 136 dec_integer initial (41), 1 137 float_bin initial (42), 1 138 token_hole_1 initial (43), 1 139 float_dec initial (44), 1 140 token_hole_2 initial (45), 1 141 i_fixed_bin initial (46), 1 142 i_bin_integer initial (47), 1 143 i_fixed_dec initial (48), 1 144 i_dec_integer initial (49), 1 145 i_float_bin initial (50), 1 146 token_hole_3 initial (51), 1 147 i_float_dec initial (52), 1 148 token_hole_4 initial (53) 1 149 ) fixed binary (8) internal static 1 150 options (constant); 1 151 1 152 /* token class limits */ 1 153 1 154 declare ( 1 155 min_delimiter_token initial (5), 1 156 max_delimiter_token initial (35), 1 157 min_constant_token initial (36), 1 158 max_constant_token initial (53), 1 159 min_arithmetic_token initial (38), 1 160 max_arithmetic_token initial (53) 1 161 ) fixed binary (8) internal static 1 162 options (constant); 1 163 1 164 /* arithmetic token type masks */ 1 165 1 166 declare ( 1 167 is_imaginary_constant initial ("1000"b), 1 168 is_float_constant initial ("0100"b), 1 169 is_decimal_constant initial ("0010"b), 1 170 is_integral_constant initial ("0001"b) 1 171 ) bit (4) aligned internal static 1 172 options (constant); 1 173 1 174 /* lexical limits */ 1 175 1 176 declare ( 1 177 max_bit_string_constant initial (253), 1 178 max_char_string_constant 1 179 initial (254), 1 180 max_identifier_length initial (256) 1 181 ) fixed binary internal static options (constant); 1 182 1 183 /* statement types */ 1 184 1 185 declare ( 1 186 unknown_statement initial (0), 1 187 allocate_statement initial (1), 1 188 assignment_statement initial (2), 1 189 begin_statement initial (3), 1 190 call_statement initial (4), 1 191 close_statement initial (5), 1 192 declare_statement initial (6), 1 193 lock_statement initial (7), 1 194 delete_statement initial (8), 1 195 display_statement initial (9), 1 196 do_statement initial (10), 1 197 else_clause initial (11), 1 198 end_statement initial (12), 1 199 entry_statement initial (13), 1 200 exit_statement initial (14), 1 201 format_statement initial (15), 1 202 free_statement initial (16), 1 203 get_statement initial (17), 1 204 goto_statement initial (18), 1 205 if_statement initial (19), 1 206 locate_statement initial (20), 1 207 null_statement initial (21), 1 208 on_statement initial (22), 1 209 open_statement initial (23), 1 210 procedure_statement initial (24), 1 211 put_statement initial (25), 1 212 read_statement initial (26), 1 213 return_statement initial (27), 1 214 revert_statement initial (28), 1 215 rewrite_statement initial (29), 1 216 signal_statement initial (30), 1 217 stop_statement initial (31), 1 218 system_on_unit initial (32), 1 219 unlock_statement initial (33), 1 220 wait_statement initial (34), 1 221 write_statement initial (35), 1 222 default_statement initial (36), 1 223 condition_prefix_list initial (37), 1 224 label_prefix_list initial (38), 1 225 percent_statement initial (39), 1 226 percent_abort_statement initial (40), 1 227 percent_default_statement 1 228 initial (41), 1 229 percent_else_statement initial (42), 1 230 percent_elseif_statement 1 231 initial (43), 1 232 percent_endif_statement initial (44), 1 233 percent_error_statement initial (45), 1 234 percent_if_statement initial (46), 1 235 percent_include_statement 1 236 initial (47), 1 237 percent_page_statement initial (48), 1 238 percent_print_statement initial (49), 1 239 percent_replace_statement 1 240 initial (50), 1 241 percent_set_statement initial (51), 1 242 percent_skip_statement initial (52), 1 243 percent_warn_statement initial (53) 1 244 ) fixed binary (8) internal static 1 245 options (constant); 1 246 1 247 declare is_independent_statement 1 248 (0:53) bit (1) aligned internal static 1 249 options (constant) 1 250 initial ("0"b, (2) (1)"1"b, "0"b, (2) (1)"1"b, 1 251 "0"b, (3) (1)"1"b, (4) (1)"0"b, "1"b, "0"b, 1 252 (8) (1)"1"b, "0"b, (11) (1)"1"b, (18) (1)"0"b); 1 253 1 254 declare is_macro_statement (0:53) bit (1) aligned internal static 1 255 options (constant) 1 256 initial ((39) (1)"0"b, (15) (1)"1"b); 1 257 1 258 declare is_macro_whitespace (0:53) bit (1) aligned internal static 1 259 options (constant) 1 260 initial ((39) (1)"0"b, (3) (1)"1"b, (3) (1)"0"b, 1 261 "1"b, "0"b, (7) (1)"1"b); 1 262 1 263 /* statement subtypes */ 1 264 1 265 declare ( 1 266 subtype_none initial (0), 1 267 subtype_noniterative_do initial (1) 1 268 ) fixed binary (8) internal static 1 269 options (constant); 1 270 1 271 /* style structures and constants */ 1 272 1 273 declare 1 style aligned based, 1 274 2 switches (26) bit (1) unaligned, 1 275 2 pad bit (10) unaligned, 1 276 2 values (10) fixed binary; 1 277 1 278 /* named modes for format_pl1_ */ 1 279 1 280 declare ( 1 281 mode_on defined (global.current_style.switches (1)), 1 282 mode_inddcls defined (global.current_style.switches (2)), 1 283 mode_delnl defined (global.current_style.switches (3)), 1 284 mode_insnl defined (global.current_style.switches (4)), 1 285 mode_indattr defined (global.current_style.switches (5)), 1 286 mode_linecom defined (global.current_style.switches (6)), 1 287 mode_case defined (global.current_style.switches (7)), 1 288 mode_ifthenstmt defined (global.current_style.switches (8)), 1 289 mode_ifthendo defined (global.current_style.switches (9)), 1 290 mode_ifthen defined (global.current_style.switches (10)), 1 291 mode_indthenelse defined (global.current_style.switches (11)), 1 292 mode_indnoniterdo defined (global.current_style.switches (12)), 1 293 mode_indnoniterend defined (global.current_style.switches (13)), 1 294 mode_indcomtxt defined (global.current_style.switches (14)), 1 295 mode_thendo defined (global.current_style.switches (15)), 1 296 mode_inditerdo defined (global.current_style.switches (16)), 1 297 mode_indend defined (global.current_style.switches (17)), 1 298 mode_indproc defined (global.current_style.switches (18)), 1 299 mode_indcom defined (global.current_style.switches (19)), 1 300 mode_indblkcom defined (global.current_style.switches (20)), 1 301 mode_indbegin defined (global.current_style.switches (21)), 1 302 mode_indbeginend defined (global.current_style.switches (22)), 1 303 mode_indthenbegin defined (global.current_style.switches (23)), 1 304 mode_indthenbeginend defined (global.current_style.switches (24)), 1 305 mode_indprocbody defined (global.current_style.switches (25)), 1 306 mode_elsestmt defined (global.current_style.switches (26)) 1 307 ) bit (1); 1 308 1 309 declare ( 1 310 mode_ind defined (global.current_style.values (1)), 1 311 mode_ll defined (global.current_style.values (2)), 1 312 mode_initcol defined (global.current_style.values (3)), 1 313 mode_declareind defined (global.current_style.values (4)), 1 314 mode_dclind defined (global.current_style.values (5)), 1 315 mode_idind defined (global.current_style.values (6)), 1 316 mode_struclvlind defined (global.current_style.values (7)), 1 317 mode_comcol defined (global.current_style.values (8)), 1 318 mode_equalind defined (global.current_style.values (9)), 1 319 mode_lineconind defined (global.current_style.values (10)) 1 320 ) fixed binary; 1 321 1 322 /* mode names */ 1 323 1 324 declare switch_mode_names (26) char (15) internal static 1 325 options (constant) 1 326 initial ("on", "inddcls", "delnl", "insnl", 1 327 "indattr", "linecom", "case", "ifthenstmt", 1 328 "ifthendo", "ifthen", "indthenelse", 1 329 "indnoniterdo", "indnoniterend", "indcomtxt", 1 330 "thendo", "inditerdo", "indend", "indproc", 1 331 "indcom", "indblkcom", "indbegin", 1 332 "indbeginend", "indthenbegin", 1 333 "indthenbeginend", "indprocbody", "elsestmt"); 1 334 1 335 declare switch_antonym_names (26) char (4) internal static 1 336 options (constant) 1 337 initial ("off", (5) (1)"", "tree", (19) (1)""); 1 338 1 339 declare value_mode_names (10) char (12) internal static 1 340 options (constant) 1 341 initial ("ind", "ll", "initcol", "declareind", 1 342 "dclind", "idind", "struclvlind", "comcol", 1 343 "equalind", "lineconind"); 1 344 1 345 /* predefined styles */ 1 346 1 347 /* style1: on,inddcls,^delnl,^insnl,indattr,^linecom,case,^ifthenstmt,^ifthendo,^ifthen,^indthenelse,indnoniterdo, 1 348* ^indnoniterend,^indcomtxt,^thendo,inditerdo,^indend,^indproc,^indcom,indblkcom,indbegin,^indbeginend,indthenbegin,^indthenbeginend,indprocbody,elsestmt,ind5,ll122,initcol6,declareind8, 1 349* dclind8,idind23,struclvlind2,comcol61,equalind0,lineconind5 1 350* style2: style1,delnl,insnl 1 351* style3: style2,^inddcls,declareind10,dclind10,idind20 1 352* style4: style1,^inddcls,^indattr,linecom,ifthendo,^indnoniterdo,indcomtxt,^inditerdo,indproc,^indthenbegin,declareind9,dclind5 1 353* style5: style2,linecom,ifthen,^indnoniterdo,indnoniterend,indcomtxt,^indthenbegin,indthenbeginend,^indprocbody,^elsestmt,ind8,ll80,initcol0,idind24,comcol57,lineconind4 1 354* 1 355* 1 356**/ 1 357 1 358 declare 1 styles (5) aligned internal static options (constant), 1 359 2 switches (26) bit (1) unaligned 1 360 initial ("1"b, "1"b, "0"b, "0"b, "1"b, "0"b, 1 361 "1"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, 1 362 "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, 1 363 "1"b, "0"b, "1"b, "1"b, /* style1 */ 1 364 "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "0"b, 1 365 "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, 1 366 "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "1"b, "0"b, 1 367 "1"b, "1"b, /* style2 */ 1 368 "1"b, "0"b, "1"b, "1"b, "1"b, "0"b, "1"b, "0"b, 1 369 "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "1"b, 1 370 "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "1"b, "0"b, 1 371 "1"b, "1"b, /* style3 */ 1 372 "1"b, "0"b, "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, 1 373 "1"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, 1 374 "0"b, "1"b, "0"b, "1"b, "1"b, "0"b, "0"b, "0"b, 1 375 "1"b, "1"b, /* style4 */ 1 376 "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, 1 377 "0"b, "1"b, "0"b, "0"b, "1"b, "1"b, "0"b, "1"b, 1 378 "0"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "1"b, 1 379 "0"b, "0"b), /* style5 */ 1 380 2 pad bit (10) unaligned initial ((5) (1)""b), 1 381 2 values (10) fixed binary 1 382 initial (5, 122, 6, 8, 8, 23, 2, 61, 0, 5, 1 383 /* style1 */ 1 384 5, 122, 6, 8, 8, 23, 2, 61, 0, 5, 1 385 /* style2 */ 1 386 5, 122, 6, 10, 10, 20, 2, 61, 0, 5, 1 387 /* style3 */ 1 388 5, 122, 6, 9, 5, 23, 2, 61, 0, 5, 1 389 /* style4 */ 1 390 8, 80, 1, 8, 8, 24, 2, 57, 0, 4); 1 391 /* style5 */ 1 392 1 393 /* control comment constants */ 1 394 1 395 declare control_comment_indicator 1 396 char (7) internal static 1 397 options (constant) initial ("format:"); 1 398 declare mode_separator char (1) internal static 1 399 options (constant) initial (","); 1 400 declare revert_mode char (6) internal static 1 401 options (constant) initial ("revert"); 1 402 declare style_mode char (5) internal static 1 403 options (constant) initial ("style"); 1 404 declare switch_mode_not_indicator 1 405 char (1) internal static 1 406 options (constant) initial ("^"); 1 407 1 408 /* if statement control comments */ 1 409 1 410 declare case_control_comment char (10) internal static 1 411 options (constant) initial ("/* case */"); 1 412 declare tree_control_comment char (10) internal static 1 413 options (constant) initial ("/* tree */"); 1 414 1 415 /* comment indicator constants */ 1 416 1 417 declare comment_indicator_extra_chars 1 418 char (3) internal static 1 419 options (constant) initial ((3)"*"); 1 420 declare comment_indicator_no_indcomtxt 1 421 char (1) internal static 1 422 options (constant) initial ("^"); 1 423 1 424 /* external static */ 1 425 1 426 declare sys_info$max_seg_size fixed binary (19) external static; 1 427 1 428 /* entry */ 1 429 1 430 declare format_pl1_lex_ entry ((*) pointer); 1 431 declare format_pl1_stmt_type_ entry ((*) pointer); 1 432 declare format_pl1_ entry ((*) pointer); 1 433 declare format_pl1_modes_ entry ((*) pointer, char (*), pointer, bit (1), 1 434 bit (1)); 1 435 declare format_pl1_record_style_ 1 436 entry ((*) pointer, fixed binary (21), 1 437 fixed binary); 1 438 declare format_pl1_long_ entry ((*) pointer, pointer); 1 439 declare format_pl1_error_ entry ((*) pointer, fixed binary (35), char (*), 1 440 pointer); 1 441 1 442 /* END INCLUDE FILE . . . format_pl1_dcls.incl.pl1 */ 56 57 58 /* program */ 59 60 temp_segs (*) = P_temp_segs (*); 61 62 modes_string_length = length (rtrim (P_modes_string, HT_SP)); 63 if modes_string_length = 0 then 64 call error (2, ""); 65 66 scan_index = verify (P_modes_string, HT_SP); 67 do while (scan_index <= length (modes_string)); 68 scan_length = 69 index (substr (modes_string, scan_index), mode_separator) 70 - 1; 71 if scan_length < 0 then 72 scan_length = 73 length (substr (modes_string, scan_index)); 74 75 begin; 76 declare mode char (scan_length) 77 defined (modes_string) 78 position (scan_index); 79 80 call apply_mode (mode); 81 end; 82 83 scan_index = scan_index + scan_length + length (mode_separator); 84 end; 85 86 if index (reverse (modes_string), reverse (mode_separator)) = 1 then 87 call error (2, ""); 88 89 return: 90 return; 91 92 /* Apply one mode to the current style. */ 93 94 apply_mode: 95 procedure (mode_and_value); 96 97 declare mode_and_value char (*); /* (Input) mode to apply */ 98 99 declare mode char (32); 100 declare mode_index fixed binary; 101 declare mode_length fixed binary (21); 102 declare mode_start_pos fixed binary (21); 103 declare not_sw bit (1) aligned; 104 declare value fixed binary; 105 106 not_sw = index (mode_and_value, switch_mode_not_indicator) = 1; 107 if not_sw then 108 mode_start_pos = length (switch_mode_not_indicator) + 1; 109 else 110 mode_start_pos = 1; 111 112 mode_length = 113 search (substr (mode_and_value, mode_start_pos), digits) - 1; 114 if mode_length < 0 then 115 mode_length = length (substr (mode_and_value, mode_start_pos)); 116 117 mode = substr (mode_and_value, mode_start_pos, mode_length); 118 119 if mode_start_pos + mode_length > length (mode_and_value) then 120 value = -1; 121 else 122 begin; 123 declare conversion condition; 124 declare size condition; 125 126 if verify ( 127 substr (mode_and_value, mode_start_pos + mode_length), 128 digits) ^= 0 then 129 call error (2, mode_and_value); 130 131 on conversion, size call error (2, mode_and_value); 132 133 (conversion, size): 134 value = 135 binary ( 136 substr (mode_and_value, mode_start_pos + mode_length), 17); 137 end; 138 139 if mode = revert_mode then 140 if not_sw | value >= 0 | ^P_revert_ok_sw then 141 call error (2, mode_and_value); 142 else 143 do; 144 global.current_style = global.prevailing_style; 145 return; 146 end; 147 148 if mode = style_mode then 149 if value < lbound (styles, 1) | hbound (styles, 1) < value 150 | not_sw then 151 call error (2, mode_and_value); 152 else 153 do; 154 global.current_style = styles (value); 155 return; 156 end; 157 158 do mode_index = lbound (value_mode_names, 1) 159 to hbound (value_mode_names, 1); 160 if mode = value_mode_names (mode_index) then 161 if not_sw | value < 0 then 162 call error (2, mode_and_value); 163 else 164 do; 165 global.current_style.values (mode_index) = 166 value; 167 return; 168 end; 169 end; 170 171 if value >= 0 then 172 call error (2, mode_and_value); 173 174 do mode_index = lbound (switch_mode_names, 1) 175 to hbound (switch_mode_names, 1); 176 if mode = switch_mode_names (mode_index) then 177 do; 178 global.current_style.switches (mode_index) = ^not_sw; 179 return; 180 end; 181 end; 182 183 do mode_index = lbound (switch_antonym_names, 1) 184 to hbound (switch_antonym_names, 1); 185 if mode = switch_antonym_names (mode_index) then 186 do; 187 global.current_style.switches (mode_index) = not_sw; 188 return; 189 end; 190 end; 191 192 call error (2, mode_and_value); 193 end apply_mode; 194 195 /* Print an error message. */ 196 197 error: 198 procedure (severity, mode); 199 200 declare severity fixed binary (35); 201 /* (Input) severity of the error */ 202 declare mode char (*); /* (Input) mode that is in error */ 203 204 if ^P_printed_error_msg_sw then 205 do; 206 if P_source_ptr = null then 207 do; 208 global.max_severity = 5; 209 call com_err_ (0, command, "Invalid mode. ""^a""", mode) 210 ; 211 end; 212 213 else 214 call format_pl1_error_ (temp_segs (*), severity, 215 "Invalid mode. """ || mode || """", P_source_ptr); 216 217 P_printed_error_msg_sw = "1"b; 218 end; 219 220 goto return; 221 end error; 222 223 end format_pl1_modes_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 08/10/84 0947.2 format_pl1_modes_.pl1 >special_ldd>on>6896>format_pl1_modes_.pl1 56 1 08/09/84 1141.5 format_pl1_dcls.incl.pl1 >special_ldd>on>6896>format_pl1_dcls.incl.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. HT_SP constant char(2) initial unaligned dcl 46 ref 62 66 P_modes_string parameter char unaligned dcl 21 set ref 16 62 66 67 68 71 80 86 P_printed_error_msg_sw parameter bit(1) unaligned dcl 25 set ref 16 204 217* P_revert_ok_sw parameter bit(1) unaligned dcl 24 ref 16 139 P_source_ptr parameter pointer dcl 22 set ref 16 206 213* P_temp_segs parameter pointer array dcl 20 ref 16 60 addr builtin function dcl 40 ref 67 68 71 80 86 binary builtin function dcl 40 ref 133 com_err_ 000010 constant entry external dcl 54 ref 209 command 000326 constant char(10) initial unaligned dcl 1-89 set ref 209* conversion 000100 stack reference condition dcl 123 ref 131 current_style 42 based structure level 3 dcl 1-73 set ref 144* 154* digits 000331 constant char(10) initial unaligned dcl 48 ref 112 126 format_pl1_error_ 000012 constant entry external dcl 1-439 ref 213 global based structure level 1 dcl 1-73 global_header based structure level 1 dcl 1-47 hbound builtin function dcl 40 ref 148 158 174 183 header based structure level 2 dcl 1-73 index builtin function dcl 40 ref 68 86 106 lbound builtin function dcl 40 ref 148 158 174 183 length builtin function dcl 40 ref 62 67 71 83 107 114 119 max_severity 7 based fixed bin(35,0) level 3 dcl 1-73 set ref 208* mode 000126 automatic char(32) unaligned dcl 99 in procedure "apply_mode" set ref 117* 139 148 160 176 185 mode defined char unaligned dcl 76 in begin block on line 75 set ref 80* mode parameter char unaligned dcl 202 in procedure "error" set ref 197 209* 213 mode_and_value parameter char unaligned dcl 97 set ref 94 106 112 114 117 119 126 126* 131* 133 139* 148* 160* 171* 192* mode_index 000136 automatic fixed bin(17,0) dcl 100 set ref 158* 160 165* 174* 176 178* 183* 185 187* mode_length 000137 automatic fixed bin(21,0) dcl 101 set ref 112* 114 114* 117 119 126 133 mode_separator constant char(1) initial unaligned dcl 1-398 ref 68 83 86 mode_start_pos 000140 automatic fixed bin(21,0) dcl 102 set ref 107* 109* 112 114 117 119 126 133 modes_string based char unaligned dcl 35 ref 67 68 71 80 80 86 modes_string_length 000100 automatic fixed bin(21,0) dcl 29 set ref 62* 63 67 68 71 80 86 not_sw 000141 automatic bit(1) dcl 103 set ref 106* 107 139 148 160 178 187 null builtin function dcl 40 ref 206 prevailing_style 27 based structure level 3 dcl 1-73 ref 144 reverse builtin function dcl 40 ref 86 86 revert_mode 000072 constant char(6) initial unaligned dcl 1-400 ref 139 rtrim builtin function dcl 40 ref 62 scan_index 000101 automatic fixed bin(21,0) dcl 30 set ref 66* 67 68 71 80 83* 83 scan_length 000102 automatic fixed bin(21,0) dcl 31 set ref 68* 71 71* 76 83 search builtin function dcl 40 ref 112 severity parameter fixed bin(35,0) dcl 200 set ref 197 213* size 000106 stack reference condition dcl 124 ref 131 style based structure level 1 dcl 1-273 style_mode 000070 constant char(5) initial unaligned dcl 1-402 ref 148 styles 000000 constant structure array level 1 dcl 1-358 ref 148 148 154 substr builtin function dcl 40 ref 68 71 112 114 117 126 133 switch_antonym_names 000132 constant char(4) initial array unaligned dcl 1-335 ref 183 183 185 switch_mode_names 000164 constant char(15) initial array unaligned dcl 1-324 ref 174 174 176 switch_mode_not_indicator constant char(1) initial unaligned dcl 1-404 ref 106 107 switches 42 based bit(1) array level 4 packed unaligned dcl 1-73 set ref 178* 187* temp_segs 000104 automatic pointer array dcl 1-23 set ref 60* 144 144 154 165 178 187 208 213* value 000142 automatic fixed bin(17,0) dcl 104 set ref 119* 133* 139 148 148 154 160 165 171 value_mode_names 000074 constant char(12) initial array unaligned dcl 1-339 ref 158 158 160 values 43 based fixed bin(17,0) array level 4 dcl 1-73 set ref 165* verify builtin function dcl 40 ref 66 126 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. allocate_statement internal static fixed bin(8,0) initial dcl 1-185 and internal static fixed bin(8,0) initial dcl 1-94 arrow internal static fixed bin(8,0) initial dcl 1-94 assignment internal static fixed bin(8,0) initial dcl 1-94 assignment_statement internal static fixed bin(8,0) initial dcl 1-185 asterisk internal static fixed bin(8,0) initial dcl 1-94 begin_statement internal static fixed bin(8,0) initial dcl 1-185 bin_integer internal static fixed bin(8,0) initial dcl 1-94 bit_string internal static fixed bin(8,0) initial dcl 1-94 call_statement internal static fixed bin(8,0) initial dcl 1-185 case_control_comment internal static char(10) initial unaligned dcl 1-410 cat internal static fixed bin(8,0) initial dcl 1-94 char_string internal static fixed bin(8,0) initial dcl 1-94 close_statement internal static fixed bin(8,0) initial dcl 1-185 colon internal static fixed bin(8,0) initial dcl 1-94 comma internal static fixed bin(8,0) initial dcl 1-94 comment_indicator_extra_chars internal static char(3) initial unaligned dcl 1-417 comment_indicator_no_indcomtxt internal static char(1) initial unaligned dcl 1-420 comment_token internal static fixed bin(8,0) initial dcl 1-94 condition_prefix_list internal static fixed bin(8,0) initial dcl 1-185 control_comment_indicator internal static char(7) initial unaligned dcl 1-395 dec_integer internal static fixed bin(8,0) initial dcl 1-94 declare_statement internal static fixed bin(8,0) initial dcl 1-185 default_statement internal static fixed bin(8,0) initial dcl 1-185 delete_statement internal static fixed bin(8,0) initial dcl 1-185 display_statement internal static fixed bin(8,0) initial dcl 1-185 divide builtin function dcl 40 do_statement internal static fixed bin(8,0) initial dcl 1-185 else_clause internal static fixed bin(8,0) initial dcl 1-185 end_statement internal static fixed bin(8,0) initial dcl 1-185 entry_statement internal static fixed bin(8,0) initial dcl 1-185 eq internal static fixed bin(8,0) initial dcl 1-94 exit_statement internal static fixed bin(8,0) initial dcl 1-185 expon internal static fixed bin(8,0) initial dcl 1-94 fixed_bin internal static fixed bin(8,0) initial dcl 1-94 fixed_dec internal static fixed bin(8,0) initial dcl 1-94 float_bin internal static fixed bin(8,0) initial dcl 1-94 float_dec internal static fixed bin(8,0) initial dcl 1-94 format_pl1_ 000000 constant entry external dcl 1-432 format_pl1_lex_ 000000 constant entry external dcl 1-430 format_pl1_long_ 000000 constant entry external dcl 1-438 format_pl1_modes_ 000000 constant entry external dcl 1-433 format_pl1_record_style_ 000000 constant entry external dcl 1-435 format_pl1_stmt_type_ 000000 constant entry external dcl 1-431 format_statement internal static fixed bin(8,0) initial dcl 1-185 free_statement internal static fixed bin(8,0) initial dcl 1-185 ge internal static fixed bin(8,0) initial dcl 1-94 get_statement internal static fixed bin(8,0) initial dcl 1-185 goto_statement internal static fixed bin(8,0) initial dcl 1-185 gt internal static fixed bin(8,0) initial dcl 1-94 i_bin_integer internal static fixed bin(8,0) initial dcl 1-94 i_dec_integer internal static fixed bin(8,0) initial dcl 1-94 i_fixed_bin internal static fixed bin(8,0) initial dcl 1-94 i_fixed_dec internal static fixed bin(8,0) initial dcl 1-94 i_float_bin internal static fixed bin(8,0) initial dcl 1-94 i_float_dec internal static fixed bin(8,0) initial dcl 1-94 identifier internal static fixed bin(8,0) initial dcl 1-94 if_statement internal static fixed bin(8,0) initial dcl 1-185 invalid_char internal static fixed bin(8,0) initial dcl 1-94 is_decimal_constant internal static bit(4) initial dcl 1-166 is_float_constant internal static bit(4) initial dcl 1-166 is_imaginary_constant internal static bit(4) initial dcl 1-166 is_independent_statement internal static bit(1) initial array dcl 1-247 is_integral_constant internal static bit(4) initial dcl 1-166 is_macro_statement internal static bit(1) initial array dcl 1-254 is_macro_whitespace internal static bit(1) initial array dcl 1-258 isub internal static fixed bin(8,0) initial dcl 1-94 keyword_token internal static fixed bin(8,0) initial dcl 1-94 label_prefix_list internal static fixed bin(8,0) initial dcl 1-185 le internal static fixed bin(8,0) initial dcl 1-94 left_parn internal static fixed bin(8,0) initial dcl 1-94 locate_statement internal static fixed bin(8,0) initial dcl 1-185 lock_statement internal static fixed bin(8,0) initial dcl 1-185 lt internal static fixed bin(8,0) initial dcl 1-94 max_arithmetic_token internal static fixed bin(8,0) initial dcl 1-154 max_bit_string_constant internal static fixed bin(17,0) initial dcl 1-176 max_char_string_constant internal static fixed bin(17,0) initial dcl 1-176 max_constant_token internal static fixed bin(8,0) initial dcl 1-154 max_delimiter_token internal static fixed bin(8,0) initial dcl 1-154 max_identifier_length internal static fixed bin(17,0) initial dcl 1-176 min_arithmetic_token internal static fixed bin(8,0) initial dcl 1-154 min_constant_token internal static fixed bin(8,0) initial dcl 1-154 min_delimiter_token internal static fixed bin(8,0) initial dcl 1-154 minus internal static fixed bin(8,0) initial dcl 1-94 mode_case defined bit(1) unaligned dcl 1-280 mode_comcol defined fixed bin(17,0) dcl 1-309 mode_dclind defined fixed bin(17,0) dcl 1-309 mode_declareind defined fixed bin(17,0) dcl 1-309 mode_delnl defined bit(1) unaligned dcl 1-280 mode_elsestmt defined bit(1) unaligned dcl 1-280 mode_equalind defined fixed bin(17,0) dcl 1-309 mode_idind defined fixed bin(17,0) dcl 1-309 mode_ifthen defined bit(1) unaligned dcl 1-280 mode_ifthendo defined bit(1) unaligned dcl 1-280 mode_ifthenstmt defined bit(1) unaligned dcl 1-280 mode_ind defined fixed bin(17,0) dcl 1-309 mode_indattr defined bit(1) unaligned dcl 1-280 mode_indbegin defined bit(1) unaligned dcl 1-280 mode_indbeginend defined bit(1) unaligned dcl 1-280 mode_indblkcom defined bit(1) unaligned dcl 1-280 mode_indcom defined bit(1) unaligned dcl 1-280 mode_indcomtxt defined bit(1) unaligned dcl 1-280 mode_inddcls defined bit(1) unaligned dcl 1-280 mode_indend defined bit(1) unaligned dcl 1-280 mode_inditerdo defined bit(1) unaligned dcl 1-280 mode_indnoniterdo defined bit(1) unaligned dcl 1-280 mode_indnoniterend defined bit(1) unaligned dcl 1-280 mode_indproc defined bit(1) unaligned dcl 1-280 mode_indprocbody defined bit(1) unaligned dcl 1-280 mode_indthenbegin defined bit(1) unaligned dcl 1-280 mode_indthenbeginend defined bit(1) unaligned dcl 1-280 mode_indthenelse defined bit(1) unaligned dcl 1-280 mode_initcol defined fixed bin(17,0) dcl 1-309 mode_insnl defined bit(1) unaligned dcl 1-280 mode_linecom defined bit(1) unaligned dcl 1-280 mode_lineconind defined fixed bin(17,0) dcl 1-309 mode_ll defined fixed bin(17,0) dcl 1-309 mode_on defined bit(1) unaligned dcl 1-280 mode_struclvlind defined fixed bin(17,0) dcl 1-309 mode_thendo defined bit(1) unaligned dcl 1-280 ne internal static fixed bin(8,0) initial dcl 1-94 ngt internal static fixed bin(8,0) initial dcl 1-94 nl_vt_np_token internal static fixed bin(8,0) initial dcl 1-94 nlt internal static fixed bin(8,0) initial dcl 1-94 no_token internal static fixed bin(8,0) initial dcl 1-94 not internal static fixed bin(8,0) initial dcl 1-94 null_statement internal static fixed bin(8,0) initial dcl 1-185 on_statement internal static fixed bin(8,0) initial dcl 1-185 open_statement internal static fixed bin(8,0) initial dcl 1-185 or internal static fixed bin(8,0) initial dcl 1-94 output_string based char unaligned dcl 1-84 percent internal static fixed bin(8,0) initial dcl 1-94 percent_abort_statement internal static fixed bin(8,0) initial dcl 1-185 percent_default_statement internal static fixed bin(8,0) initial dcl 1-185 percent_else_statement internal static fixed bin(8,0) initial dcl 1-185 percent_elseif_statement internal static fixed bin(8,0) initial dcl 1-185 percent_endif_statement internal static fixed bin(8,0) initial dcl 1-185 percent_error_statement internal static fixed bin(8,0) initial dcl 1-185 percent_if_statement internal static fixed bin(8,0) initial dcl 1-185 percent_include_statement internal static fixed bin(8,0) initial dcl 1-185 percent_page_statement internal static fixed bin(8,0) initial dcl 1-185 percent_print_statement internal static fixed bin(8,0) initial dcl 1-185 percent_replace_statement internal static fixed bin(8,0) initial dcl 1-185 percent_set_statement internal static fixed bin(8,0) initial dcl 1-185 percent_skip_statement internal static fixed bin(8,0) initial dcl 1-185 percent_statement internal static fixed bin(8,0) initial dcl 1-185 percent_warn_statement internal static fixed bin(8,0) initial dcl 1-185 period internal static fixed bin(8,0) initial dcl 1-94 plus internal static fixed bin(8,0) initial dcl 1-94 prefix_minus internal static fixed bin(8,0) initial dcl 1-94 prefix_plus internal static fixed bin(8,0) initial dcl 1-94 procedure_statement internal static fixed bin(8,0) initial dcl 1-185 put_statement internal static fixed bin(8,0) initial dcl 1-185 read_statement internal static fixed bin(8,0) initial dcl 1-185 return_statement internal static fixed bin(8,0) initial dcl 1-185 revert_statement internal static fixed bin(8,0) initial dcl 1-185 rewrite_statement internal static fixed bin(8,0) initial dcl 1-185 right_parn internal static fixed bin(8,0) initial dcl 1-94 semi_colon internal static fixed bin(8,0) initial dcl 1-94 signal_statement internal static fixed bin(8,0) initial dcl 1-185 size builtin function dcl 40 slash internal static fixed bin(8,0) initial dcl 1-94 stop_statement internal static fixed bin(8,0) initial dcl 1-185 subtype_none internal static fixed bin(8,0) initial dcl 1-265 subtype_noniterative_do internal static fixed bin(8,0) initial dcl 1-265 sys_info$max_seg_size external static fixed bin(19,0) dcl 1-426 system_on_unit internal static fixed bin(8,0) initial dcl 1-185 target_comma internal static fixed bin(8,0) initial dcl 1-94 token based structure array level 1 dcl 1-29 token_hole_1 internal static fixed bin(8,0) initial dcl 1-94 token_hole_2 internal static fixed bin(8,0) initial dcl 1-94 token_hole_3 internal static fixed bin(8,0) initial dcl 1-94 token_hole_4 internal static fixed bin(8,0) initial dcl 1-94 trailer based structure array level 1 dcl 1-37 tree_control_comment internal static char(10) initial unaligned dcl 1-412 unknown_statement internal static fixed bin(8,0) initial dcl 1-185 unlock_statement internal static fixed bin(8,0) initial dcl 1-185 wait_statement internal static fixed bin(8,0) initial dcl 1-185 write_statement internal static fixed bin(8,0) initial dcl 1-185 NAMES DECLARED BY EXPLICIT CONTEXT. apply_mode 000642 constant entry internal dcl 94 ref 80 error 001371 constant entry internal dcl 197 ref 63 86 126 131 139 148 160 171 192 format_pl1_modes_ 000401 constant entry external dcl 16 return 000641 constant label dcl 89 ref 220 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 2422 2436 2343 2432 Length 2634 2343 14 161 56 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME format_pl1_modes_ 138 external procedure is an external procedure. begin block on line 75 begin block shares stack frame of external procedure format_pl1_modes_. apply_mode internal procedure shares stack frame of external procedure format_pl1_modes_. begin block on line 121 248 begin block enables or reverts conditions. on unit on line 131 78 on unit error 94 internal procedure is called by several nonquick procedures. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME format_pl1_modes_ 000100 modes_string_length format_pl1_modes_ 000101 scan_index format_pl1_modes_ 000102 scan_length format_pl1_modes_ 000104 temp_segs format_pl1_modes_ 000126 mode apply_mode 000136 mode_index apply_mode 000137 mode_length apply_mode 000140 mode_start_pos apply_mode 000141 not_sw apply_mode 000142 value apply_mode THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as alloc_cs cat_realloc_cs enter_begin leave_begin call_ext_out_desc call_int_this_desc call_int_other_desc return tra_ext bound_check_signal enable shorten_stack ext_entry_desc int_entry int_entry_desc size_check_fx1 any_to_any_tr THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. com_err_ format_pl1_error_ NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 16 000374 60 000414 62 000461 63 000475 66 000514 67 000531 68 000535 71 000554 76 000560 80 000562 83 000601 84 000605 86 000606 89 000641 94 000642 106 000653 107 000670 109 000674 112 000676 114 000714 117 000720 119 000723 121 000731 126 000734 131 001001 133 001046 137 001077 139 001100 144 001137 145 001143 148 001144 154 001200 155 001206 158 001207 160 001215 165 001250 167 001253 169 001254 171 001256 174 001300 176 001305 178 001312 179 001322 181 001323 183 001325 185 001333 187 001340 188 001344 190 001345 192 001347 193 001367 197 001370 204 001404 206 001413 208 001417 209 001422 211 001454 213 001455 217 001530 220 001537 ----------------------------------------------------------- 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