format_pl1.pl1 04/09/85 1613.8r w 04/08/85 1128.7 166113 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DESCRIPTION: Program to format a PL/I program according to my own set of conventions. Basically, if-then-else and do-end groups get lined up so that it is easy to find the matching else statement, or the end of a do-end group. This program has its origins in the Multics indent command, but unlike indent, we understand the syntax of PL/I fully, and don't get confused by strange constructs. We also attempt to do more processing, since we have the knowledge. I have wanted to write this program for a long time. I published my first ideas in my S.B. thesis in 1973. I wrote a draft of the parser in 1974. The notes I took for the lexical analyzer for format_pl1 turned into the EIS lex for PL/I itself in 1977. So at long last... (Paul Green) This command is being modified to be the Multics standard PL/I formatting command for MCR 3503. Consequently, it must have options to make it act similar to indent as well as other formatting styles. (Monte Davidoff) Maintenance Instructions: To add another: 1) PL/I statement, see format_pl1_stmt_type_, format_pl1_. 2) Formatting mode, see format_pl1_. 3) Macro, see format_pl1_lex_, format_pl1_stmt_type_, format_pl1_. 4) Declare statement attribute, see format_pl1_. 5) Token type, see format_pl1_lex_, format_pl1_stmt_type_, format_pl1_. 6) Numbered style, see format_pl1_. */ /* HISTORY: Written by Paul Green, 11/06/77. Modified: 11/01/78 by Monte Davidoff: 09/01/82 by Benson I. Margulies: for .X.pmac files. 06/05/84 by R. Michael Tague: to recognize all legal pmac % statements. */ /* format: style5 */ format_pl1: fp: procedure options (variable); /* automatic */ declare arg_count fixed binary; declare arg_length fixed binary (21); declare arg_ptr pointer; declare argument_no fixed binary; declare argx fixed binary; declare bit_count fixed binary (24); declare 1 ca, 2 check_comments bit (1), 2 no_check_comments bit (1), 2 check_strings bit (1), 2 no_check_strings bit (1), 2 force bit (1), 2 no_force bit (1), 2 long bit (1), 2 brief bit (1), 2 modes bit (1), 2 output_file bit (1), 2 record_style bit (1), 2 no_record_style bit (1), 2 require_style_comment bit (1), 2 no_require_style_comment bit (1), 2 version bit (1), 2 no_version bit (1); declare code fixed binary (35); declare in_dname char (168); declare in_ename char (32); declare modes_length fixed binary (21); declare modes_ptr pointer; declare output_ptr pointer; declare source_ptr pointer; declare suffix char (3); declare out_dname char (168); declare out_ename char (32); /* based */ declare arg_string char (arg_length) based (arg_ptr); declare modes_string char (modes_length) based (modes_ptr); /* builtin */ declare (baseno, divide, index, null, reverse, rtrim, size, string, substr) builtin; /* condition */ declare cleanup condition; /* internal static */ declare DEFAULT_STYLE fixed binary internal static options (constant) initial (1); declare VERSION char (3) internal static options (constant) initial ("6.6"); /* external static */ declare error_table_$badopt fixed binary (35) external static; declare error_table_$noentry fixed binary (35) external static; declare format_pl1_severity_ fixed binary (35) external static; /* entry */ declare com_err_ entry options (variable); declare com_err_$suppress_name entry options (variable); declare cu_$arg_count entry (fixed binary, fixed binary (35)); declare cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); declare expand_pathname_ entry (char (*), char (*), char (*), fixed binary (35)); declare get_equal_name_ entry (char (*), char (*), char (32), fixed binary (35)); declare get_temp_segments_ entry (char (*), (*) pointer, fixed binary (35)); declare hcs_$initiate_count entry (char (*), char (*), char (*), fixed binary (24), fixed binary (2), pointer, fixed binary (35)); declare hcs_$make_seg entry (char (*), char (*), char (*), fixed binary (5), pointer, fixed binary (35)); declare ioa_ entry options (variable); declare release_temp_segments_ entry (char (*), (*) pointer, fixed binary (35)); declare suffixed_name_$make entry (char (*), char (*), char (32), fixed binary (35)); declare suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed binary (35)); declare terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); %include format_pl1_dcls; %include terminate_file; %include access_mode_values; /* program */ source_ptr = null; output_ptr = null; temp_segs (*) = null; modes_ptr = null; modes_length = 0; format_pl1_severity_ = 5; string (ca) = ""b; ca.long = "1"b; call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, command); return; end; argument_no = 0; do argx = 1 to arg_count; call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; if arg_string = "-version" | arg_string = "-ver" then do; ca.version = "1"b; ca.no_version = "0"b; end; else if arg_string = "-no_version" | arg_string = "-nver" then do; ca.version = "0"b; ca.no_version = "1"b; end; else if arg_string = "-record_style" | arg_string = "-rcst" then do; ca.record_style = "1"b; ca.no_record_style = "0"b; end; else if arg_string = "-no_record_style" | arg_string = "-nrcst" then do; ca.record_style = "0"b; ca.no_record_style = "1"b; end; else if arg_string = "-check_comments" | arg_string = "-ckcom" then do; ca.check_comments = "1"b; ca.no_check_comments = "0"b; end; else if arg_string = "-no_check_comments" | arg_string = "-nckcom" then do; ca.check_comments = "0"b; ca.no_check_comments = "1"b; end; else if arg_string = "-check_strings" | arg_string = "-ckstr" then do; ca.check_strings = "1"b; ca.no_check_strings = "0"b; end; else if arg_string = "-no_check_strings" | arg_string = "-nckstr" then do; ca.check_strings = "0"b; ca.no_check_strings = "1"b; end; else if arg_string = "-require_style_comment" | arg_string = "-rqst" then do; ca.require_style_comment = "1"b; ca.no_require_style_comment = "0"b; end; else if arg_string = "-no_require_style_comment" | arg_string = "-nrqst" then do; ca.require_style_comment = "0"b; ca.no_require_style_comment = "1"b; end; else if arg_string = "-force" | arg_string = "-fc" then do; ca.force = "1"b; ca.no_force = "0"b; end; else if arg_string = "-no_force" | arg_string = "-nfc" then do; ca.force = "0"b; ca.no_force = "1"b; end; else if arg_string = "-long" | arg_string = "-lg" then do; ca.long = "1"b; ca.brief = "0"b; end; else if arg_string = "-brief" | arg_string = "-bf" then do; ca.long = "0"b; ca.brief = "1"b; end; else if arg_string = "-modes" | arg_string = "-mode" | arg_string = "-md" then do; argx = argx + 1; if argx > arg_count then do; call com_err_ (0, command, "Missing modes string after -modes."); return; end; call cu_$arg_ptr (argx, modes_ptr, modes_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; ca.modes = "1"b; end; else if arg_string = "-output_file" | arg_string = "-of" then do; argx = argx + 1; if argx > arg_count then do; call com_err_ (0, command, "Missing pathname after -output_file."); return; end; call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); return; end; call expand_pathname_ (arg_string, out_dname, out_ename, code); if code ^= 0 then do; call com_err_ (code, command, "^a", arg_string); return; end; ca.output_file = "1"b; end; else if index (arg_string, "-") = 1 then do; call com_err_ (error_table_$badopt, command, "^a", arg_string); return; end; else do; argument_no = argument_no + 1; if argument_no = 1 then do; call expand_pathname_ (arg_string, in_dname, in_ename, code); if code ^= 0 then do; call com_err_ (code, command, "^a", arg_string); return; end; end; end; end; if argument_no ^= 1 then do; call com_err_$suppress_name (0, command, "Usage: ^a in_path {-control_args}", command); return; end; on cleanup call cleanup_procedure; call get_input_segment (code); if code ^= 0 then do; call cleanup_procedure; return; end; if ca.output_file then begin; declare old_ename char (32); old_ename = out_ename; call get_equal_name_ (in_ename, old_ename, out_ename, code); if code ^= 0 then do; call com_err_ (code, command, "Equal name ^a with ^a.", old_ename, in_ename); call cleanup_procedure; return; end; old_ename = out_ename; call suffixed_name_$make (old_ename, suffix, out_ename, code); if code ^= 0 then do; call com_err_ (code, command, "^a with ^a suffix.", old_ename, suffix); call cleanup_procedure; return; end; end; call get_temp_segments_ (command, temp_segs (*), code); if code ^= 0 then do; call com_err_ (code, command, "Getting temporary segments in process directory."); call cleanup_procedure; return; end; global.source_ptr = source_ptr; global.source_length = divide (bit_count + 8, 9, 21); global.max_severity = 0; global.modes_ptr = modes_ptr; global.modes_length = modes_length; global.ca = ca, by name; global.include_file = ends_with (in_ename, ".incl.pl1"); global.rdc_source = ends_with (in_ename, ".rd"); /* Initialize the current style. */ global.current_style = styles (DEFAULT_STYLE); if ca.modes then do; call format_pl1_modes_ (temp_segs (*), modes_string, null, "0"b, "0"b); if global.max_severity > 0 then do; format_pl1_severity_ = global.max_severity; call cleanup_procedure; return; end; end; else global.ca.long = "0"b; global.command_line_style = global.current_style; if ca.force then global.current_style = styles (DEFAULT_STYLE); /* Initialization is complete. Print version if requested. */ if ca.version then call ioa_ ("Format PL/I ^a", VERSION); /* Lex the program. */ call format_pl1_lex_ (temp_segs (*)); if global.max_severity > 2 then do; format_pl1_severity_ = global.max_severity; call com_err_ (0, command, "No formatting will be done."); call cleanup_procedure; return; end; /* Produce a list of statements. */ call format_pl1_stmt_type_ (temp_segs (*)); if global.max_severity > 3 then do; format_pl1_severity_ = global.max_severity; call com_err_ (0, command, "No formatting will be done."); call cleanup_procedure; return; end; /* Do the formatting. */ call format_pl1_ (temp_segs (*)); if global.max_severity > 3 then do; format_pl1_severity_ = global.max_severity; call com_err_ (0, command, "No formatting will be done."); call cleanup_procedure; return; end; /* Copy the formatted program over to the output segment. */ if ^ca.output_file then if global.max_severity <= 1 then do; out_dname = in_dname; out_ename = in_ename; output_ptr = source_ptr; source_ptr = null; end; else do; out_dname = "[pd]"; out_ename = in_ename; call hcs_$make_seg ("", out_ename, "", RW_ACCESS_BIN, output_ptr, code); if output_ptr = null then do; call com_err_ (code, command, "^a^[>^]^a", out_dname, out_dname ^= ">", out_ename); call cleanup_procedure; return; end; if baseno (source_ptr) = baseno (output_ptr) then do; format_pl1_severity_ = global.max_severity; call com_err_ (0, command, "Input segment not replaced."); call cleanup_procedure; return; end; call com_err_ (0, command, "Input segment not replaced. Formatted copy is in ^a^[>^]^a." , out_dname, out_dname ^= ">", out_ename); end; else do; call hcs_$make_seg (out_dname, out_ename, "", RW_ACCESS_BIN, output_ptr, code); if output_ptr = null then do; call com_err_ (code, command, "^a^[>^]^a", out_dname, out_dname ^= ">", out_ename); call cleanup_procedure; return; end; end; substr (output_ptr -> output_string, 1, global.output_length) = substr (output_string, 1, global.output_length); call terminate_file_ (output_ptr, 9 * global.output_length, TERM_FILE_TRUNC_BC_TERM, code); if code ^= 0 then do; global.max_severity = 5; call com_err_ (code, command, "Terminating the file ^a^[>^]^a.", out_dname, out_dname ^= ">", out_ename); end; format_pl1_severity_ = global.max_severity; call cleanup_procedure; return; get_input_segment: procedure (code); declare code fixed binary (35); /* (Output) standard status code */ declare explicit_suffix bit (1) aligned; declare tentative_ename char (32); declare test_ename char (32); /* NOTE: pmac suffices, like rd, must be explicit. */ /* no attempt is made to remember pmac-ness so as to */ /* reject %set etc. in non-pmac segments, since this will */ /* be in the compiler some day. */ code = 0; explicit_suffix = "1"b; if ends_with (in_ename, ".pmac") then test_ename = before (in_ename, ".pmac"); else test_ename = in_ename; if ends_with (test_ename, ".pl1") then suffix = "pl1"; else if ends_with (test_ename, ".cds") then suffix = "cds"; else if ends_with (test_ename, ".rd") then suffix = "rd"; else do; explicit_suffix = "0"b; suffix = "pl1"; tentative_ename = in_ename; call suffixed_name_$make (tentative_ename, suffix, in_ename, code); if code ^= 0 then do; call com_err_ (code, command, "^a with ^a suffix.", tentative_ename, suffix); return; end; end; call hcs_$initiate_count (in_dname, in_ename, "", bit_count, 0, source_ptr, code); if source_ptr ^= null then do; code = 0; return; end; if explicit_suffix | code ^= error_table_$noentry then do; call com_err_ (code, command, "^a^[>^]^a", in_dname, in_dname ^= ">", in_ename); return; end; call suffixed_name_$new_suffix (in_ename, "pl1", "cds", tentative_ename, code); if code ^= 0 then do; call com_err_ (code, command, "^a with ^a suffix.", in_ename, "cds"); return; end; call hcs_$initiate_count (in_dname, tentative_ename, "", bit_count, 0, source_ptr, code); if source_ptr ^= null then do; code = 0; in_ename = tentative_ename; suffix = "cds"; return; end; if code = error_table_$noentry then call com_err_ (code, command, "^a^[>^]^a", in_dname, in_dname ^= ">", in_ename); else call com_err_ (code, command, "^a^[>^]^a", in_dname, in_dname ^= ">", tentative_ename); end get_input_segment; /* Check if one string ends another with trailing blanks ignored. */ ends_with: procedure (string, ending) returns (bit (1) aligned); declare string char (*); /* (Input) string with unknown ending */ declare ending char (*); /* (Input) possible ending */ return (index (reverse (rtrim (string)), reverse (rtrim (ending))) = 1); end ends_with; /* Release temporary storage and terminate segments. */ cleanup_procedure: procedure; call terminate_file_ (source_ptr, 0, TERM_FILE_TERM, code); call terminate_file_ (output_ptr, 0, TERM_FILE_TERM, code); call release_temp_segments_ (command, temp_segs (*), code); end cleanup_procedure; end format_pl1;  format_pl1_.pl1 02/22/85 0829.4rew 02/21/85 0931.2 819099 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DESCRIPTION: Format a PL/I program given a list of tokens and statements. For most statements, as much of the statement is put on a line as possible. If a statement will not fit on one line, parenthesis nesting and the precedence of each token is used to determine where to break the statement across lines. This default formatting is done by format_other. Most of this program handles special cases that format_other would not format correctly. Some token types are changed by format_pl1_stmt_type_ because some tokens require different precedences in different contexts. This procedure assumes the token type needs no further refinement. The steps are: 1) Convert a statement into items. Items are tokens and comments. The item structure has many fields that facilitate formatting. 2) Figure out how to format the statement by modifying the item structure. 3) Copy the items for a statement into the output string using the item structure control information. 4) This procedure keeps track of the syntactic nesting of the program in the unit_stack. The unit_stack is kept current after each statement by adjust_unit_stack. Maintenance Instructions: To add another token type: 1) Add an entry to the precedence array. 2) Add entries to the last_space_class and this_space_class arrays in make_items. If necessary, add entries to the space_table array in make_items. To add another PL/I statement: 1) If the statement needs special formatting, change format_one_statement. To add another macro: 1) If the macro needs special formatting, change format_one_statement. To add another declare statement attribute: 1) If the attribute consists of an identifier or an identifier followed by something in parentheses, and no special formatting is needed, no change is necessary. Otherwise, change attribute_set. To add another formatting mode: 1) Change the style stucture in format_pl1_dcls.incl.pl1 to include space for the new mode. 2) Add a declaration that starts with "mode_" to format_pl1_dcls.incl.pl1 to reference the mode in the current style. This declaration is used only by this procedure. 3) For a switch mode, add entries to the switch_mode_names and switch_antonym_names arrays. For a value mode, add an entry to the value_mode_names array. These arrays are in format_pl1_dcls.incl.pl1. 4) Add a default value for the new mode in each style in the styles array of structures in format_pl1_dcls.incl.pl1. 5) Change this procedure to use the new "mode_" declaration. To add another numbered style: 1) Add new entries to the styles array of structures in format_pl1_dcls.incl.pl1 that defines a default value for each mode in the new style. */ /* HISTORY: Written by Paul Green, 11/01/77. Rewritten by Monte Davidoff, 07/17/78. Modified: 09/03/83 by Jim Lippard: to not go into an infinite loop on "dcl a defined (b;". 06/05/84 by R. Michael Tague: Handle the % macro statments of pmac. Changed pop_unit so that a multiple closure error message will be printed when a labeled end statement is used to close a %if or %else statement instead of the proper closure with a %endif. Added the elsedo formatting option. 11/15/84 by R. Michael Tague: Changed the formatting of "else if" to always place the if statement exactly one space after the else. 02/12/85 by R. Michael Tague: Changed comparisons with percent_statement to use the is_macro_statement. This was a bug, I should have changed it 06/05/84. Fixed so that the trailing comma that comes after a literal will stay on the line with the literal when the literal is the only thing on the line but still the line is too long. */ /* format: style5,^indcomtxt */ format_pl1_: procedure (P_temp_segs); declare P_temp_segs (*) pointer; /* (Input) array of temporary segment pointers */ /* automatic */ declare copy_position fixed binary (21); /* index in output segment of next character to write */ declare item_ptr pointer; /* pointer to base of item array */ declare left_margin fixed binary; /* current indentation level column */ declare line_position fixed binary; /* column next character will be written into */ declare looked_ahead bit (1) aligned;/* on if next statement will fit on the current line */ declare off_region_ptr pointer; /* pointer to first character not to format */ declare text_after_end_msg bit (1) aligned;/* on if printed text after end of program message */ declare unit_stack_index fixed binary; /* number of entries in unit stack */ declare unit_stack_ptr pointer; /* pointer to base of unit_stack */ /* based */ declare 1 item ( divide (sys_info$max_seg_size - binary (rel (item_ptr), 18), 5, 17)) aligned based (item_ptr), 2 string_size fixed binary (21) unaligned, 2 comment_ind_len fixed binary (3) unsigned unaligned, 2 pad1 bit (2) unaligned, 2 type fixed binary (8) unaligned, 2 string_ptr pointer unaligned, 2 paren_depth fixed binary (8) unaligned, 2 precedence fixed binary (9) unsigned unaligned, 2 last_col fixed binary (17) unaligned, 2 next_token fixed binary (17) unaligned, 2 header unaligned, 3 tab bit (1), 3 need_space fixed binary (1) unsigned, 3 tab_blkcom bit (1), 3 insnl bit (1), 3 pad2 bit (5), 3 amount fixed binary (9) unsigned, 2 trailer unaligned, 3 NP bit (1), 3 pad3 bit (8), 3 VTs fixed binary (9) unsigned, 3 NLs fixed binary (9) unsigned, 2 flags unaligned, 3 control_comment bit (1), 3 gave_error_msg bit (1), 3 indcomtxt bit (1), 3 pad4 bit (6); declare 1 unit_stack ( divide (sys_info$max_seg_size - binary (rel (unit_stack_ptr), 18), 4, 17)) aligned based (unit_stack_ptr), 2 type fixed binary (17) unaligned, 2 label_start fixed binary (17) unaligned, 2 label_end fixed binary (17) unaligned, 2 close_left_margin fixed binary (17) unaligned, 2 previous_left_margin fixed binary (17) unaligned, 2 flags unaligned, 3 case bit (1), 3 in_else_clause bit (1), 3 pad bit (16), 2 construct_ptr pointer unaligned; /* builtin */ declare (addr, after, before, binary, copy, divide, hbound, index, length, ltrim, max, min, null, rel, reverse, rtrim, search, size, substr, unspec, verify) builtin; /* internal static */ declare close_comment char (2) internal static options (constant) initial ("*/"); declare open_comment char (2) internal static options (constant) initial ("/*"); declare tab_interval fixed binary (4) internal static options (constant) initial (10); declare ( NO_UNIT initial (0), BEGIN_UNIT initial (1), DO_UNIT initial (2), PROCEDURE_UNIT initial (3), IF_UNIT initial (4), ELSE_UNIT initial (5), ON_UNIT initial (6), PERCENT_IF_UNIT initial (7) ) fixed binary internal static options (constant); declare BS char (1) internal static options (constant) initial (""); declare HT char (1) internal static options (constant) initial (" "); declare HT_BS_NL_VT_NP char (5) internal static options (constant) initial ("  "); declare HT_SP char (2) internal static options (constant) initial (" "); declare precedence (0:53) fixed binary (9) unsigned internal static options (constant) initial (15, /* no_token */ 15, /* invalid_char */ 15, /* identifier */ 3, /* keyword_token */ 15, /* isub */ 10, /* infix + */ 10, /* infix - */ 11, /* * */ 11, /* / */ 12, /* ** */ 12, /* ^ */ 7, /* & */ 6, /* | */ 9, /* || */ 8, /* = */ 8, /* ^= */ 8, /* < */ 8, /* > */ 8, /* <= */ 8, /* >= */ 8, /* ^> */ 8, /* ^< */ 12, /* prefix + */ 12, /* prefix - */ 4, /* assignment */ 15, /* : */ 15, /* ; */ 2, /* , */ 14, /* . */ 13, /* -> */ 17, /* ( */ 1, /* ) */ 15, /* % */ 5, /* target , */ 16, /* comment */ 0, /* nl_vt_np_token */ (18) 15); /* constants */ declare HT_SP_NL_VT_NP char (5) internal static options (constant) initial (" "); declare NL char (1) internal static options (constant) initial (" "); declare NP char (1) internal static options (constant) initial (" "); declare SP char (1) internal static options (constant) initial (""); declare VT char (1) internal static options (constant) initial (" "); /* entry */ declare ioa_ entry options (variable); declare char_offset_ entry (pointer) returns (fixed binary (21)) reducible; /* more internal static */ declare NL_VT_NP char (3) internal static options (constant) initial (" "); %include format_pl1_dcls; /* program */ temp_segs (*) = P_temp_segs (*); global.output_length = 0; copy_position = 1; line_position = 1; looked_ahead = "0"b; text_after_end_msg = "0"b; unit_stack_ptr = addr (token (global.n_tokens + 2)); unspec (unit_stack (1)) = ""b; unit_stack (1).type = NO_UNIT; unit_stack_index = 1; item_ptr = addr (stmt (global.n_stmts + 2)); unspec (item (1)) = ""b; item (1).type = no_token; item (1).string_ptr = null; item (1).trailer.NLs = 1; begin; declare n_items fixed binary; declare prevailing_style_item fixed binary; left_margin = 1; n_items = 1; call make_items (1, 1, "1"b, "0"b, n_items); call set_prevailing_style (n_items, prevailing_style_item); if global.ca.long & unspec (global.prevailing_style) ^= unspec (global.command_line_style) then call format_pl1_long_ (temp_segs (*), (item (prevailing_style_item).string_ptr)); n_items = 1; call make_items (1, 1, "1"b, "1"b, n_items); if prevailing_style_item <= n_items then if global.ca.force then call delete_and_record_new_prevailing_style_comment (prevailing_style_item, n_items); else call copy_items (2, n_items); else do; call copy_items (2, n_items); call record_style; end; end; begin; declare last_stmt_type fixed binary (8); declare stmtx fixed binary; last_stmt_type = unknown_statement; stmtx = 2; do while (stmtx <= global.n_stmts); call format_one_statement (stmtx, last_stmt_type); end; end; if off_region_ptr ^= null then call copy_off_region (global.source_length); do unit_stack_index = unit_stack_index to 2 by -1; if (unit_stack (unit_stack_index).type = BEGIN_UNIT | unit_stack (unit_stack_index).type = DO_UNIT | unit_stack (unit_stack_index).type = PROCEDURE_UNIT) & (^global.rdc_source | unit_stack_index > 2) then call error (3, "Missing end statement.", unit_stack (unit_stack_index).construct_ptr); else if unit_stack (unit_stack_index).type = PERCENT_IF_UNIT then call error (3, "Missing %endif macro.", unit_stack (unit_stack_index).construct_ptr); end; unrecoverable_error: global.output_length = copy_position - 1; return; /* Find the prevailing style comment and set the prevailing style. */ set_prevailing_style: procedure (n_items, prevailing_style_item); declare n_items fixed binary; /* (Input) index of last item before the first token */ declare prevailing_style_item fixed binary; /* (Output) index of prevailing style comment, or n_items + 1 if none */ declare item_string char (item (prevailing_style_item) .string_size) based (item (prevailing_style_item) .string_ptr); do prevailing_style_item = 2 to n_items while (^item (prevailing_style_item).control_comment); end; if prevailing_style_item <= n_items then call format_pl1_modes_ (temp_segs (*), before (after (item_string, control_comment_indicator), close_comment), addr (item_string), "0"b, item (prevailing_style_item).gave_error_msg); else if global.ca.require_style_comment then call error (2, "Program does not already contain a prevailing style control comment.", null); if global.ca.force then begin; declare 1 control_com_style aligned like style; declare command_line_modes char (global.modes_length) based (global.modes_ptr); control_com_style = global.current_style; call format_pl1_modes_ (temp_segs (*), command_line_modes, null, "0"b, "1"b); if unspec (control_com_style) = unspec (global.current_style) then global.ca.force = "0"b; end; global.prevailing_style = global.current_style; left_margin = mode_initcol; if mode_on then off_region_ptr = null; else off_region_ptr = global.source_ptr; end set_prevailing_style; /* Delete an existing prevailing style control comment and optionally record a new one. */ delete_and_record_new_prevailing_style_comment: procedure (prevailing_style_item, n_items); declare prevailing_style_item fixed binary; /* (Input) index of prevailing style comment */ declare n_items fixed binary; /* (Input) index of last item before the first token */ call copy_items (2, prevailing_style_item - 1); if off_region_ptr = null then call record_style; else do; call copy_off_region ( char_offset_ ((item (prevailing_style_item).string_ptr))); call record_style; if prevailing_style_item < n_items then off_region_ptr = item (prevailing_style_item + 1).string_ptr; else if global.n_tokens > 1 then off_region_ptr = token (2).string_ptr; end; call copy_items (prevailing_style_item + 1, n_items); end delete_and_record_new_prevailing_style_comment; /* Record the prevailing style in the output segment. */ record_style: procedure; if ^global.ca.record_style then return; if off_region_ptr = null then call format_pl1_record_style_ (temp_segs (*), copy_position, line_position); else if global.n_tokens <= 1 then do; call copy_off_region (global.source_length); call format_pl1_record_style_ (temp_segs (*), copy_position, line_position); end; else do; call copy_off_region (char_offset_ ((token (2).string_ptr))); call format_pl1_record_style_ (temp_segs (*), copy_position, line_position); off_region_ptr = token (2).string_ptr; end; end record_style; /* Format a statement. */ format_one_statement: procedure (stmtx, last_stmt_type); declare stmtx fixed binary; /* (Updated) statement to format */ declare last_stmt_type fixed binary (8); /* (Updated) type of the last statement */ declare n_items fixed binary; declare label_start fixed binary; declare label_end fixed binary; declare last_stmt_item fixed binary; declare stmt_type fixed binary (8); if stmt (stmtx).type = condition_prefix_list then do; call format_prefix_list (stmtx); if stmtx > global.n_stmts then return; end; if stmt (stmtx).type = label_prefix_list then do; label_start = stmt (stmtx).start; label_end = stmt (stmtx).end; call format_prefix_list (stmtx); if stmtx > global.n_stmts then return; end; else do; label_start = 0; label_end = 0; end; stmt_type = stmt (stmtx).type; call convert_stmt_to_items (stmtx, 1, "0"b, n_items); if stmt_type = assignment_statement then call format_assignment (n_items); else if stmt_type = begin_statement then call format_begin (n_items, last_stmt_type, label_start, label_end); else if stmt_type = declare_statement then call format_declare (n_items); else if stmt_type = do_statement then call format_do (n_items, last_stmt_type, label_start, label_end) ; else if stmt_type = end_statement then call format_end (n_items); else if stmt_type = if_statement then call format_if (last_stmt_type, n_items); else if stmt_type = else_clause then call format_else (n_items); else if stmt_type = on_statement then call format_on (n_items); else if stmt_type = procedure_statement then call format_procedure (n_items, label_start, label_end); else if stmt_type = entry_statement then call format_entry (n_items); else if stmt_type = percent_if_statement then call format_percent_if_macros (n_items, "1"b, "1"b, "1"b); else if stmt_type = percent_elseif_statement then call format_percent_if_macros (n_items, "0"b, "1"b, "1"b); else if stmt_type = percent_else_statement then call format_percent_if_macros (n_items, "0"b, "1"b, "0"b); else if stmt_type = percent_endif_statement then call format_percent_if_macros (n_items, "0"b, "0"b, "0"b); else if is_macro_statement (stmt_type) then call format_other (2, n_items, 1, mode_lineconind, "1"b); else call format_other (2, n_items, left_margin, mode_lineconind, "1"b); do last_stmt_item = n_items by -1 while (item (last_stmt_item).type = comment_token); end; call copy_items (2, last_stmt_item); if ^is_macro_whitespace (stmt_type) then do; call adjust_unit_stack (stmt_type, next_statement (stmtx)); last_stmt_type = stmt_type; end; call copy_items (last_stmt_item + 1, n_items); stmtx = stmtx + 1; return; format_prefix_list: procedure (stmtx); declare stmtx fixed binary; /* (Updated) prefix list to format */ declare first_prefix_item fixed binary; declare itemx fixed binary; declare n_items fixed binary; call convert_stmt_to_items (stmtx, 1, "0"b, n_items); do first_prefix_item = 2 repeat itemx + 1 while (first_prefix_item <= n_items); item (first_prefix_item).header.need_space = 1; do itemx = first_prefix_item to n_items while (item (itemx).type ^= colon); end; do itemx = itemx to n_items while (item (itemx + 1).type = comment_token); call insert_tab (itemx + 1, mode_comcol); end; if stmt (stmtx).type = condition_prefix_list then call format_other (first_prefix_item, itemx, 1, 0, "1"b) ; else call format_other (first_prefix_item, itemx, 1, mode_lineconind, "1"b); end; call copy_items (2, n_items); stmtx = stmtx + 1; end format_prefix_list; /* Convert the tokens in a statement to items. */ convert_stmt_to_items: procedure (P_stmtx, initial_itemx, P_reconverting, P_itemx); declare P_stmtx fixed binary; /* (Input) statement to convert */ declare initial_itemx fixed binary; /* (Input) last used item */ declare P_reconverting bit (1) aligned;/* (Input) on if stmt has already been converted in place */ declare P_itemx fixed binary; /* (Output) last item that was converted */ declare first_in_item_array bit (1) aligned; declare itemx fixed binary; declare reconverting bit (1) aligned; declare stmtx fixed binary; declare tokenx fixed binary; stmtx = P_stmtx; itemx = initial_itemx; first_in_item_array = initial_itemx = 1; reconverting = P_reconverting; do tokenx = stmt (stmtx).start to stmt (stmtx).end; call make_items (stmtx, tokenx, first_in_item_array, reconverting, itemx); end; P_itemx = itemx; item (initial_itemx + 1).header.need_space = 1; item (initial_itemx + 1).header.amount = 1; if itemx >= hbound (item, 1) then call error (4, "Too many tokens and comments in a statement.", item (itemx).string_ptr); unspec (item (itemx + 1)) = ""b; item (itemx + 1).type = no_token; item (itemx + 1).string_ptr = token (stmt (stmtx).end + 1).string_ptr; if first_in_item_array & ^reconverting & stmt (stmtx).type ^= unknown_statement & (token (stmt (stmtx).end).type = semi_colon | ^is_macro_statement (stmt (stmtx + 1).type) | is_macro_whitespace (stmt (stmtx + 1).type)) then if item (itemx).paren_depth > 1 | item (itemx).paren_depth = 1 & item (itemx).type ^= right_parn then call error (2, "Missing right parenthesis.", item (2).string_ptr); else if item (itemx).paren_depth < 0 | item (itemx).paren_depth = 0 & item (itemx).type = right_parn then call error (2, "Missing left parenthesis.", item (2).string_ptr); end convert_stmt_to_items; /* Adjust the unit stack for the next statement. */ adjust_unit_stack: procedure (last_stmt_type, stmtx); declare last_stmt_type fixed binary (8); /* (Input) type of the last statement */ declare stmtx fixed binary; /* (Input) index of the next statement */ if unit_stack (unit_stack_index).type = ON_UNIT & (last_stmt_type ^= on_statement | stmt (stmtx).type = on_statement | stmt (stmtx).type = if_statement) then call pop_unit (0, left_margin, left_margin); if last_stmt_type ^= if_statement & last_stmt_type ^= else_clause then if stmt (stmtx).type = else_clause then begin; /* pop unit stack through matching then */ declare loop bit (1) aligned; loop = "1"b; do while (loop); if unit_stack (unit_stack_index).type = IF_UNIT then do; loop = "0"b; unit_stack (unit_stack_index).type = ELSE_UNIT; left_margin = unit_stack (unit_stack_index) .close_left_margin; if (^unit_stack (unit_stack_index).case | ^unit_stack (unit_stack_index) .in_else_clause & stmt (next_statement (stmtx)).type ^= if_statement) & mode_indthenelse then left_margin = left_margin + mode_ind; end; else if unit_stack (unit_stack_index).type = ELSE_UNIT then call pop_unit (0, 0, left_margin); else do; loop = "0"b; call error (3, "No if statement preceding else clause.", token (stmt (stmtx).start) .string_ptr); end; end; end; else do while (unit_stack (unit_stack_index).type = IF_UNIT | unit_stack (unit_stack_index).type = ELSE_UNIT); call pop_unit (0, 0, left_margin); end; end adjust_unit_stack; format_procedure: procedure (n_items, label_start, label_end); declare n_items fixed binary; /* (Input) number of items in the statement */ declare label_start fixed binary; /* (Input) first label token */ declare label_end fixed binary; /* (Input) last label token */ declare previous_left_margin fixed binary; declare procedure_nest_depth fixed binary; declare unitx fixed binary; previous_left_margin = left_margin; procedure_nest_depth = 0; do unitx = unit_stack_index to 2 by -1; if unit_stack (unit_stack_index).type = PROCEDURE_UNIT then procedure_nest_depth = procedure_nest_depth + 1; end; if procedure_nest_depth < 2 | ^mode_indproc then left_margin = mode_ind + 1; call format_other (2, n_items, left_margin, mode_lineconind, "1"b); call push_unit (PROCEDURE_UNIT, label_start, label_end, left_margin, previous_left_margin); if mode_indprocbody then left_margin = left_margin + mode_ind; end format_procedure; format_assignment: procedure (n_items); declare n_items fixed binary; /* (Input) number of items in the statement */ if mode_equalind = 0 then call format_other (2, n_items, left_margin, mode_lineconind, "1"b); else begin; declare assignment_item fixed binary; do assignment_item = 2 to n_items while (item (assignment_item).type ^= assignment); end; call format_other (2, assignment_item - 1, left_margin, mode_lineconind, "0"b); call format_other (assignment_item, n_items, left_margin + mode_equalind, mode_lineconind, "1"b); end; end format_assignment; format_begin: procedure (n_items, last_stmt_type, label_start, label_end); declare n_items fixed binary; /* (Input) number of items in the statement */ declare last_stmt_type fixed binary (8); /* (Input) type of the last nonwhitespace stmt */ declare label_start fixed binary; /* (Input) first label token */ declare label_end fixed binary; /* (Input) last label token */ declare previous_left_margin fixed binary; call format_other (2, n_items, left_margin, mode_lineconind, "1"b); previous_left_margin = left_margin; if last_stmt_type ^= if_statement & last_stmt_type ^= else_clause & last_stmt_type ^= on_statement then do; if mode_indbegin then do; left_margin = left_margin + mode_ind; call push_unit (BEGIN_UNIT, label_start, label_end, indent_margin (mode_indbeginend, left_margin), previous_left_margin); end; else call push_unit (BEGIN_UNIT, label_start, label_end, left_margin, previous_left_margin); end; else do; if mode_indthenbegin then left_margin = left_margin + mode_ind; call push_unit (BEGIN_UNIT, label_start, label_end, indent_margin (mode_indthenbeginend, left_margin), previous_left_margin); end; end format_begin; format_do: procedure (n_items, last_stmt_type, label_start, label_end); declare n_items fixed binary; /* (Input) number of items in the statement */ declare last_stmt_type fixed binary (8); /* (Input) type of the last non whitespace stmt */ declare label_start fixed binary; /* (Input) first label token */ declare label_end fixed binary; /* (Input) last label token */ declare indent_end bit (1); declare previous_left_margin fixed binary; call format_other (2, n_items, left_margin, mode_lineconind, "1"b); previous_left_margin = left_margin; if last_stmt_type = if_statement | last_stmt_type = else_clause | last_stmt_type = on_statement then if stmt (stmtx).subtype = subtype_noniterative_do then do; if mode_indnoniterdo then left_margin = left_margin + mode_ind; indent_end = mode_indnoniterend; end; else do; if mode_inditerdo then left_margin = left_margin + mode_ind; indent_end = mode_indend; end; else do; left_margin = left_margin + mode_ind; indent_end = mode_indend; end; call push_unit (DO_UNIT, label_start, label_end, indent_margin (indent_end, left_margin), previous_left_margin); end format_do; format_entry: procedure (n_items); declare n_items fixed binary; /* (Input) number of items in the statement */ declare unitx fixed binary; do unitx = unit_stack_index to 2 by -1 while (unit_stack (unitx).type ^= PROCEDURE_UNIT); end; if unit_stack (unitx).type = PROCEDURE_UNIT then call format_other (2, n_items, (unit_stack (unitx).close_left_margin), mode_lineconind, "1"b); else call format_other (2, n_items, mode_ind + 1, mode_lineconind, "1"b); end format_entry; format_end: procedure (n_items); declare n_items fixed binary; /* (Input) number of items in the statement */ declare previous_left_margin fixed binary; if unit_stack_index = 2 & stmtx < global.n_stmts & ^text_after_end_msg then do; call error (3, "Text follows logical end of program.", token (stmt (stmtx + 1).start).string_ptr); text_after_end_msg = "1"b; end; if unit_stack_index > 1 then if token (stmt (stmtx).start + 1).type = identifier then call pop_unit (stmt (stmtx).start + 1, left_margin, previous_left_margin); else call pop_unit (0, left_margin, previous_left_margin); else do; left_margin = 1; previous_left_margin = mode_ind + 1; call error (3, "End statement follows logical end of program.", item (2).string_ptr); end; call format_other (2, n_items, left_margin, mode_lineconind, "1"b); left_margin = previous_left_margin; end format_end; /* ************************************************************************ * format_if - procedure to format an if statement. * * previous_left_margin - left margin when this proc is entered. * * if_statement_left_margin - the column this if statement will begin * * in. This is used to get "else if" statements so that the if * * begins one space after the else regardless of mode_ind. * * if_statement_lineconind - this is an adjustment to the line * * continuation value so that line continuations are placed * * mode_lineconind from the begining of the "else if" instead * * mode_lineconind from the "if". We are treating "else if" as * * if it were one statement. * ************************************************************************ */ format_if: procedure (last_stmt_type, n_items); declare last_stmt_type fixed binary (8); /* (Input) type of the last statement */ declare n_items fixed binary; /* (Input) number of items in the statement */ declare current_mode_case bit (1) aligned; declare then_item fixed binary; declare previous_left_margin fixed binary; declare if_statement_left_margin fixed binary; declare if_statement_lineconind fixed binary; declare third_item_string char (item (3).string_size) based (item (3).string_ptr); current_mode_case = mode_case; if last_stmt_type = if_statement | last_stmt_type = else_clause then current_mode_case = unit_stack (unit_stack_index).case; if item (3).type = comment_token then if third_item_string = case_control_comment then current_mode_case = "1"b; else if third_item_string = tree_control_comment then current_mode_case = "0"b; previous_left_margin = left_margin; if last_stmt_type = else_clause & current_mode_case then do; left_margin = unit_stack (unit_stack_index).close_left_margin; if_statement_left_margin = left_margin + length ("else") + 1; if_statement_lineconind = mode_lineconind - (length ("else") + 1); end; else do; if_statement_left_margin = previous_left_margin; if_statement_lineconind = mode_lineconind; end; call push_unit (IF_UNIT, 0, 0, left_margin, previous_left_margin); unit_stack (unit_stack_index).case = current_mode_case; unit_stack (unit_stack_index).in_else_clause = last_stmt_type = else_clause; if mode_indthenelse then left_margin = left_margin + mode_ind; do then_item = n_items by -1 while (item (then_item).type = comment_token); end; if is_ifthenstmt (stmtx, last_stmt_type, current_mode_case) & mode_ifthenstmt then begin; declare last_item fixed binary; declare may_be_ifthenstmt bit (1) aligned; call convert_stmt_to_items (stmtx + 1, n_items, "0"b, last_item) ; may_be_ifthenstmt = "1"b; if stmt (stmtx + 1).type = on_statement then if may_be_one_line_on_unit (stmtx + 1) then call convert_stmt_to_items (stmtx + 2, (last_item), "0"b, last_item); else may_be_ifthenstmt = "0"b; if may_be_ifthenstmt then do; call format_other (2, last_item, if_statement_left_margin, if_statement_lineconind, "1"b); call look_ahead_if_is_on_one_line (stmtx, 2, last_item, looked_ahead); end; end; else if stmt (stmtx + 1).subtype = subtype_noniterative_do & mode_ifthendo then begin; declare itemx fixed binary; declare last_item fixed binary; declare then_item_NLs fixed binary; call convert_stmt_to_items (stmtx + 1, n_items, "0"b, last_item) ; then_item_NLs = item (then_item).trailer.NLs; call format_other (2, last_item, if_statement_left_margin, if_statement_lineconind, "1"b); do itemx = last_item by -1 while (item (itemx).type = comment_token); end; do itemx = itemx to then_item by -1 while (^item (itemx).header.tab); end; if itemx < then_item & ^mode_thendo then looked_ahead = "1"b; else do; item (then_item).trailer.NLs = then_item_NLs; call convert_stmt_to_items (stmtx + 1, n_items, "0"b, last_item); call format_other (then_item, last_item, left_margin, mode_lineconind, "1"b); call look_ahead_if_is_on_one_line (stmtx, then_item, last_item, looked_ahead); end; end; if ^looked_ahead then if mode_ifthen then begin; declare itemx fixed binary; do itemx = then_item + 1 by 1 while (item (itemx).type = comment_token); call insert_tab (itemx, mode_comcol); end; call format_other (2, n_items, if_statement_left_margin, if_statement_lineconind, "0"b); end; else begin; declare itemx fixed binary; do itemx = then_item - 1 by -1 while (item (itemx).type = comment_token); call insert_tab (itemx, mode_comcol); end; call format_other (2, then_item - 1, if_statement_left_margin, if_statement_lineconind, "1"b); call format_other (then_item, n_items, left_margin, mode_lineconind, "0"b); end; if mode_ifthen then left_margin = left_margin + mode_ind; else left_margin = left_margin + clause_indentation (stmt (stmtx + 1).type); return; is_ifthenstmt: procedure (stmtx, last_stmt_type, case) returns (bit (1) aligned); declare stmtx fixed binary; /* (Input) current if statement */ declare last_stmt_type fixed binary (8); /* (Input) type of last statement */ declare case bit (1) aligned;/* (Input) current mode case */ if ^is_independent_statement (stmt (stmtx + 1).type) | stmt (stmtx + 1).type = if_statement then return ("0"b); if stmt (stmtx + 2).type ^= else_clause then return ("1"b); return (case & (last_stmt_type = else_clause | stmt (next_statement (stmtx + 2)).type = if_statement)); end is_ifthenstmt; end format_if; format_else: procedure (n_items); declare n_items fixed binary; /* (Input) number of items in the statement */ if stmt (stmtx + 1).subtype = subtype_noniterative_do & mode_ifthendo then begin; declare last_item fixed binary; call convert_stmt_to_items (stmtx + 1, n_items, "0"b, last_item) ; call format_other (2, last_item, left_margin, mode_lineconind, "1"b); call look_ahead_if_is_on_one_line (stmtx, 2, last_item, looked_ahead); end; if ^looked_ahead then if mode_elsestmt then call format_other (2, n_items, left_margin, mode_lineconind, "0"b); else do; if stmt (stmtx + 1).type = if_statement & unit_stack (unit_stack_index).case then call format_other (2, n_items, left_margin, mode_lineconind, "0"b); else call format_other (2, n_items, left_margin, mode_lineconind, "1"b); end; if mode_elsestmt then left_margin = left_margin + clause_indentation (stmt (stmtx + 1).type); else left_margin = left_margin + mode_ind; end format_else; clause_indentation: procedure (clause_type) returns (fixed binary); declare clause_type fixed binary (8) unaligned; /* (Input) type of then clause or else clause */ /* length ("then") = length ("else") */ if is_independent_statement (clause_type) then return (max (length ("then") + 1, mode_ind)); else return (mode_ind); end clause_indentation; next_statement: procedure (this_stmtx) returns (fixed binary); declare this_stmtx fixed binary; /* (Input) current statement */ declare stmtx fixed binary; do stmtx = this_stmtx + 1 by 1 while (stmt (stmtx).type = condition_prefix_list | stmt (stmtx).type = label_prefix_list | is_macro_whitespace (stmt (stmtx).type)); end; return (stmtx); end next_statement; format_on: procedure (n_items); declare n_items fixed binary; /* (Input) number of items in the statement */ if may_be_one_line_on_unit (stmtx) then if ^looked_ahead then begin; declare last_item fixed binary; call convert_stmt_to_items (stmtx + 1, n_items, "0"b, last_item); call format_other (2, last_item, left_margin, mode_lineconind, "1"b); call look_ahead_if_is_on_one_line (stmtx, 2, last_item, looked_ahead); end; if ^looked_ahead then call format_other (2, n_items, left_margin, mode_lineconind, "1"b); call push_unit (ON_UNIT, 0, 0, left_margin, left_margin); left_margin = left_margin + mode_ind; end format_on; may_be_one_line_on_unit: procedure (stmtx) returns (bit (1) aligned); declare stmtx fixed binary; /* (Input) on statement index */ return (is_independent_statement (stmt (stmtx + 1).type) & stmt (stmtx + 1).type ^= if_statement & stmt (stmtx + 1).type ^= on_statement & stmt (stmtx + 1).type ^= return_statement & stmt (stmtx + 1).type ^= revert_statement); end may_be_one_line_on_unit; look_ahead_if_is_on_one_line: procedure (stmtx, first_item, last_item, looked_ahead); declare stmtx fixed binary; /* (Input) current statement */ declare first_item fixed binary; /* (Input) first item to check */ declare last_item fixed binary; /* (Input) last item to check */ declare looked_ahead bit (1) aligned;/* (Output) on if next statement fits on the current line */ declare itemx fixed binary; declare last_stmt_item fixed binary; do last_stmt_item = last_item by -1 while (item (last_stmt_item).type = comment_token); end; if item (last_stmt_item).type ^= semi_colon then last_stmt_item = last_item + 1; do itemx = first_item to last_stmt_item - 1 while (item (itemx).trailer.NLs = 0); end; looked_ahead = itemx >= last_stmt_item; if ^looked_ahead then call convert_stmt_to_items (stmtx, 1, "1"b, itemx); end look_ahead_if_is_on_one_line; format_percent_if_macros: procedure (n_items, first_clause, start_clause, has_percent_then); declare n_items fixed binary; /* (Input) number of items in the macro */ declare first_clause bit (1) aligned;/* (Input) on to start new macro: %if */ declare start_clause bit (1) aligned;/* (Input) on to start new clause: %if, %elseif, %else */ declare has_percent_then bit (1) aligned;/* (Input) on if macro has %then: %if, %elseif */ declare itemx fixed binary; if ^first_clause then if start_clause then do; do while (unit_stack (unit_stack_index).type ^= PERCENT_IF_UNIT & unit_stack_index >= 2); call pop_unit (0, 0, left_margin); end; if unit_stack (unit_stack_index).type = PERCENT_IF_UNIT then call pop_unit (0, left_margin, left_margin); else call error (3, "No preceding %if macro.", item (2).string_ptr); end; else begin; declare unitx fixed binary; do unitx = unit_stack_index to 2 by -1 while (unit_stack (unitx).type ^= PERCENT_IF_UNIT); end; if unit_stack (unitx).type = PERCENT_IF_UNIT then do; do unitx = unitx + 1 to unit_stack_index; unit_stack (unitx - 1) = unit_stack (unitx); end; unit_stack_index = unit_stack_index - 1; end; else call error (3, "No %if macro preceding %endif macro.", item (2).string_ptr); end; if start_clause then call push_unit (PERCENT_IF_UNIT, 0, 0, left_margin, left_margin) ; do itemx = n_items by -1 while (item (itemx).type = comment_token); call insert_tab (itemx, mode_comcol); end; call format_other (2, n_items, 1, mode_lineconind, "1"b); if has_percent_then & item (itemx).header.tab then call insert_tab (itemx, 1); end format_percent_if_macros; format_declare: procedure (n_items); declare n_items fixed binary; /* (Input) number of items in the statement */ declare declare_margin fixed binary; declare factored_level_number bit (1) aligned; declare id_start_col fixed binary; declare itemx fixed binary; declare levels_ptr pointer; declare levelx fixed binary; declare tokenx fixed binary; declare levels (0:sys_info$max_seg_size - binary (rel (levels_ptr), 18) - 1) fixed binary based (levels_ptr); tokenx = n_items + 1; do itemx = tokenx to 2 by -1; item (itemx).next_token = tokenx; if item (itemx).type ^= comment_token then tokenx = itemx; end; levels_ptr = addr (item (n_items + 2)); levels (0) = -1; levelx = 0; factored_level_number = "0"b; itemx = 2; if mode_inddcls then declare_margin = left_margin; else declare_margin = 1; if item (itemx).string_size = length ("dcl") then id_start_col = declare_margin + mode_dclind; else id_start_col = declare_margin + mode_declareind; call insert_tab (itemx, declare_margin); itemx = item (itemx).next_token; call declaration_list; itemx = item (itemx).next_token; call insert_NL (itemx - 1, 0); return; declaration_list: procedure; declare declare_stack_index fixed binary; declare declare_stack_ptr pointer; declare 1 declare_stack ( divide (sys_info$max_seg_size - binary (rel (declare_stack_ptr), 18), 2, 17)) aligned based (declare_stack_ptr), 2 state fixed binary (17) unaligned, 2 flags unaligned, 3 has_level_number bit (1), 3 pad bit (17), 2 component_start fixed binary (17); declare item_string char (item (itemx).string_size) based (item (itemx).string_ptr); declare ( START_COMPONENT initial (0), WANT_RIGHT_PAREN initial (1), WANT_ATTRIBUTE_SET initial (2) ) fixed binary internal static options (constant); declare_stack_ptr = addr (unit_stack (unit_stack_index + 1)); declare_stack_index = 0; call push_declare_stack_entry (declare_stack_index); do while (declare_stack_index > 0); if declare_stack (declare_stack_index).state = START_COMPONENT then do; declare_stack (declare_stack_index).state = WANT_ATTRIBUTE_SET; declare_stack (declare_stack_index).has_level_number = "0"b; declare_stack (declare_stack_index).component_start = itemx; if item (itemx).type = dec_integer then begin; declare level fixed binary; level = binary (item_string, 17); do levelx = levelx to 1 by -1 while (levels (levelx) >= level); end; if levelx >= hbound (levels, 1) then call error (4, "Too many levels.", item (itemx).string_ptr); levelx = levelx + 1; levels (levelx) = level; declare_stack (declare_stack_index) .has_level_number = "1"b; if factored_level_number then call error (3, "Level number within the scope of a factored level number.", item (itemx).string_ptr); itemx = item (itemx).next_token; end; else if ^factored_level_number & item (itemx).type ^= left_parn then levelx = 0; call insert_tab (declare_stack (declare_stack_index) .component_start, structure_id_start_col (levelx)); if item (itemx).type = identifier then itemx = item (itemx).next_token; else if item (itemx).type = left_parn then begin; declare ix fixed binary; factored_level_number = declare_stack (declare_stack_index) .has_level_number; call completely_factored_declaration_list ( itemx, ix); if ix > 0 then itemx = ix; else do; itemx = item (itemx).next_token; declare_stack (declare_stack_index) .state = WANT_RIGHT_PAREN; call push_declare_stack_entry ( declare_stack_index); end; end; else if ^is_macro_statement (stmt (stmtx + 1).type) then call error (3, "Syntax error in declaration component.", item (itemx).string_ptr); end; else if declare_stack (declare_stack_index).state = WANT_RIGHT_PAREN then do; declare_stack (declare_stack_index).state = WANT_ATTRIBUTE_SET; if item (itemx).type = right_parn then begin; declare ix fixed binary; do ix = itemx - 1 by -1 while (item (ix).type = comment_token); call insert_tab (ix, mode_comcol); end; call insert_NL (itemx - 1, structure_id_start_col (levelx)); itemx = item (itemx).next_token; end; else if ^is_macro_statement (stmt (stmtx + 1).type) then call error (3, "Missing right parenthesis after declaration list.", item (itemx).string_ptr); if declare_stack (declare_stack_index).has_level_number then factored_level_number = "0"b; end; else do; /* WANT_ATTRIBUTE_SET */ call attribute_set (id_start_col + mode_idind, itemx); if mode_indattr then if declare_stack (declare_stack_index) .has_level_number then call tab_continuation_lines ( declare_stack (declare_stack_index) .component_start + 1, itemx, structure_id_start_col (levelx) + mode_ind); else call tab_continuation_lines ( declare_stack (declare_stack_index) .component_start + 1, itemx, structure_id_start_col (levelx)); else if item (itemx).type = comma | item (itemx).type = semi_colon then call format_other ( declare_stack (declare_stack_index) .component_start, itemx, structure_id_start_col (levelx), mode_lineconind, "0"b); else call format_other ( declare_stack (declare_stack_index) .component_start, itemx - 1, structure_id_start_col (levelx), mode_lineconind, "0"b); if item (itemx).type = comma then do; itemx = item (itemx).next_token; call insert_NL (itemx - 1, 0); declare_stack (declare_stack_index).state = START_COMPONENT; end; else declare_stack_index = declare_stack_index - 1; end; end; return; push_declare_stack_entry: procedure (declare_stack_index); declare declare_stack_index fixed binary; /* (Updated) top of the declare_stack */ if declare_stack_index >= hbound (declare_stack, 1) then call error (4, "Declaration lists nested too deep.", item (itemx).string_ptr); declare_stack_index = declare_stack_index + 1; unspec (declare_stack (declare_stack_index)) = ""b; declare_stack (declare_stack_index).state = START_COMPONENT; end push_declare_stack_entry; /* Format a declaration list if it has all the attributes factored, doesn't contain any comments, and the identifiers don't contain dollar signs. */ completely_factored_declaration_list: procedure (first_item, last_item); declare first_item fixed binary; /* (Input) left paren preceding declaration list */ declare last_item fixed binary; /* (Output) item after right paren of declaration component, or 0 if not a completely factored declaration list */ declare itemx fixed binary; declare item_string char (item (itemx).string_size) based (item (itemx).string_ptr); last_item = 0; itemx = first_item + 1; if item (itemx).type ^= identifier then return; do itemx = itemx + 1 repeat itemx + 1 while (item (itemx).type = comma); itemx = itemx + 1; if item (itemx).type ^= identifier then return; if index (item_string, "$") > 0 then return; end; if item (itemx).type ^= right_parn then return; if ^factored_level_number then levelx = 0; if declare_stack (declare_stack_index).has_level_number then call format_other (declare_stack (declare_stack_index) .component_start, itemx, structure_id_start_col (levelx), mode_lineconind, "0"b); else call format_other (declare_stack (declare_stack_index) .component_start, itemx, structure_id_start_col (levelx), 0, "0"b); if declare_stack (declare_stack_index).has_level_number then factored_level_number = "0"b; last_item = itemx + 1; end completely_factored_declaration_list; attribute_set: procedure (start_col, itemx); declare start_col fixed binary; /* (Input) column the attributes start in */ declare itemx fixed binary; /* (Updated) current item */ declare first_item fixed binary; declare initial_paren_depth fixed binary; declare item_string char (item (itemx).string_size) based (item (itemx).string_ptr); first_item = itemx; do while (item (itemx).type ^= comma & item (itemx).type ^= semi_colon & item (itemx).type ^= right_parn & item (itemx).type ^= no_token); if item (itemx).type = identifier then do; item (itemx).type = keyword_token; item (itemx).precedence = precedence (keyword_token); /* if item_string = "entry" then call entry_attribute; else if item_string = "returns" then call returns_attribute; else if item_string = "generic" then call generic_attribute; else */ if item_string = "like" then do; itemx = item (itemx).next_token; if item (itemx).type = identifier then do; itemx = item (itemx).next_token; do while (item (itemx).type = period); itemx = item (itemx).next_token; if item (itemx).type = identifier then itemx = item (itemx) .next_token; end; end; end; else if item_string = "defined" | item_string = "def" then do; initial_paren_depth = item (itemx).paren_depth; do itemx = item (itemx).next_token repeat item (itemx).next_token while (item (itemx).paren_depth > initial_paren_depth & itemx < n_items | item (itemx).type ^= comma & item (itemx).type ^= semi_colon & item (itemx).type ^= right_parn & (item (itemx).type ^= identifier | ^ could_end_a_reference (item (itemx - 1) .type))); end; end; else itemx = item (itemx).next_token; end; else if item (itemx).type = left_parn then do; initial_paren_depth = item (itemx).paren_depth; do itemx = item (itemx).next_token repeat item (itemx).next_token while (item (itemx).paren_depth >= initial_paren_depth); end; end; else itemx = item (itemx).next_token; end; if first_item < itemx & mode_indattr then if item (itemx).type = comma | item (itemx).type = semi_colon then call format_other (first_item, itemx, start_col, 0, "0"b); else call format_other (first_item, itemx - 1, start_col, 0, "0"b); return; could_end_a_reference: procedure (type) returns (bit (1) aligned); declare type fixed binary (8) unaligned; /* (Input) token type which might end a reference */ return (type = identifier | type = isub | type = right_parn | min_constant_token <= type & type <= max_constant_token); end could_end_a_reference; end attribute_set; structure_id_start_col: procedure (level) returns (fixed binary); declare level fixed binary; /* (Input) current normalized structure level */ return (id_start_col + mode_struclvlind * max (0, level - 1)); end structure_id_start_col; end declaration_list; end format_declare; /* Format items using the precedence rules. */ format_other: procedure (first_item, last_item, start_col, continuation_indent, insert_final_NL_sw); declare first_item fixed binary; /* (Input) first item to format */ declare last_item fixed binary; /* (Input) last item to format */ declare start_col fixed binary; /* (Input) left margin for this statement fragment */ declare continuation_indent fixed binary; /* (Input) number of columns to indent continuation lines */ declare insert_final_NL_sw bit (1) aligned;/* (Input) on to insert a NL after last_item */ declare first_on_line fixed binary; declare ix fixed binary; declare last_line_pos fixed binary; declare ix_item_string char (item (ix).string_size) based (item (ix).string_ptr); declare last_ix_item_string char (item (ix - 1).string_size) based (item (ix - 1).string_ptr); if looked_ahead then do; looked_ahead = "0"b; return; end; call insert_tab (first_item, start_col); call tab_continuation_lines (first_item + 1, last_item, start_col + continuation_indent); if ^mode_insnl then return; first_on_line = first_item; do while (first_on_line <= last_item); do ix = first_on_line to last_item while (item (ix - 1).last_col <= mode_ll | ix = first_on_line); if item (ix).header.tab then do; first_on_line = ix; last_line_pos = -1; end; else if item (ix - 1).type = char_string | item (ix - 1).type = comment_token then if search (last_ix_item_string, NL_VT_NP) = 0 then last_line_pos = item (ix - 1).last_col; else last_line_pos = last_line_position (1, last_ix_item_string); else last_line_pos = item (ix - 1).last_col; if item (ix).type = char_string | item (ix).type = comment_token then item (ix).last_col = next_line_position (last_line_pos + item (ix).header.amount + 1, ix_item_string) - 1; else item (ix).last_col = last_line_pos + item (ix).header.amount + item (ix).string_size; end; if item (ix - 1).last_col <= mode_ll then first_on_line = ix; else begin; declare last_on_line fixed binary; declare low_paren_depth fixed binary; declare low_precedence fixed binary; last_on_line = ix - 1; do first_on_line = first_on_line to last_on_line while (item (first_on_line).last_col < start_col + continuation_indent); end; if item_should_end_line (item (last_on_line).type) then do; low_paren_depth = 1f5; low_precedence = 1f5; end; else do; low_paren_depth = item (last_on_line).paren_depth; low_precedence = item (last_on_line).precedence; end; do ix = first_on_line + 1 to last_on_line - 1; if item (ix).paren_depth < low_paren_depth | item (ix).paren_depth = low_paren_depth & item (ix).precedence <= low_precedence then do; last_on_line = ix; low_paren_depth = item (ix).paren_depth; low_precedence = item (ix).precedence; end; end; if ^item_should_end_line (item (last_on_line).type) then if first_on_line < last_on_line then last_on_line = last_on_line - 1; else if item (last_on_line + 1).type = comma then last_on_line = last_on_line + 1; call insert_NL (last_on_line, start_col + continuation_indent); first_on_line = last_on_line + 1; end; end; if insert_final_NL_sw then call insert_NL (last_item, 0); return; item_should_end_line: procedure (type) returns (bit (1) aligned); declare type fixed binary (8) unaligned; /* (Input) token type */ return (type = comma | type = target_comma | type = right_parn | type = assignment); end item_should_end_line; end format_other; push_unit: procedure (unit_type, label_start, label_end, close_left_margin, previous_left_margin); declare unit_type fixed binary; /* (Input) type of unit to push */ declare label_start fixed binary; /* (Input) first token in the statement's label prefixes */ declare label_end fixed binary; /* (Input) last token in the statement's label prefixes */ declare close_left_margin fixed binary; /* (Input) left margin for corresponding 'end' statement */ declare previous_left_margin fixed binary; /* (Input) left margin for next statement */ if unit_stack_index >= hbound (unit_stack, 1) then call error (4, "Blocks nested too deep.", token (stmt (stmtx).start).string_ptr); unit_stack_index = unit_stack_index + 1; unspec (unit_stack (unit_stack_index)) = ""b; unit_stack (unit_stack_index).type = unit_type; unit_stack (unit_stack_index).label_start = label_start; unit_stack (unit_stack_index).label_end = label_end; unit_stack (unit_stack_index).close_left_margin = close_left_margin; unit_stack (unit_stack_index).previous_left_margin = previous_left_margin; unit_stack (unit_stack_index).construct_ptr = token (stmt (stmtx).start).string_ptr; end push_unit; pop_unit: procedure (label_token, close_left_margin, previous_left_margin); declare label_token fixed binary; /* (Input) end statement label token, 0 if none */ declare close_left_margin fixed binary; /* (Output) left margin for end statement */ declare previous_left_margin fixed binary; /* (Output) left margin for the next statement */ declare matched bit (1) aligned; declare multiple_closure_msg bit (1) aligned; declare tx fixed binary; declare label_string char (token (label_token).string_size) based (token (label_token).string_ptr); declare tx_token_string char (token (tx).string_size) based (token (tx).string_ptr); multiple_closure_msg = "0"b; matched = label_token = 0; do while (^matched & unit_stack_index >= 2); if unit_stack (unit_stack_index).label_start > 0 then do tx = unit_stack (unit_stack_index).label_start to unit_stack (unit_stack_index).label_end while (^matched); if token (tx).type = identifier & token (tx + 1).type = colon then matched = label_string = tx_token_string; end; if ^matched then do; if unit_stack (unit_stack_index).type = BEGIN_UNIT | unit_stack (unit_stack_index).type = DO_UNIT | unit_stack (unit_stack_index).type = PROCEDURE_UNIT | unit_stack (unit_stack_index).type = PERCENT_IF_UNIT then do; if ^multiple_closure_msg then do; call error (1, "Labeled end statement terminates more than one block or group.", token (label_token).string_ptr); multiple_closure_msg = "1"b; end; call error (1, "Block or group terminated by labeled end statement.", unit_stack (unit_stack_index).construct_ptr) ; end; unit_stack_index = unit_stack_index - 1; end; end; if matched then do; close_left_margin = unit_stack (unit_stack_index).close_left_margin; previous_left_margin = unit_stack (unit_stack_index).previous_left_margin; unit_stack_index = unit_stack_index - 1; end; else do; close_left_margin = 1; previous_left_margin = 1; call error (3, "No match for labeled end statement.", token (label_token).string_ptr); end; end pop_unit; /* Ensure starting columns for continuation lines are specified. */ tab_continuation_lines: procedure (first_item, last_item, continuation_col); declare first_item fixed binary; /* (Input) first item to check */ declare last_item fixed binary; /* (Input) last item to check */ declare continuation_col fixed binary; /* (Input) default continuation line starting column */ declare itemx fixed binary; do itemx = first_item to last_item; if item (itemx - 1).trailer.NLs > 0 & ^item (itemx).header.tab then call insert_tab (itemx, continuation_col); end; end tab_continuation_lines; /* Insert a NL in the statement. */ insert_NL: procedure (itemx, start_col); declare itemx fixed binary; /* (Input) index of last item on the line */ declare start_col fixed binary; /* (Input) starting column of first item on the next line, 0 if none */ if item (itemx).trailer.NLs = 0 & mode_insnl then item (itemx).trailer.NLs = 1; if start_col > 0 then call insert_tab (itemx + 1, start_col); end insert_NL; /* Insert a tab to a particular column in the statement. */ insert_tab: procedure (itemx, start_col); declare itemx fixed binary; /* (Input) index of item to be moved over */ declare start_col fixed binary; /* (Input) new starting column */ if item (itemx).type = comment_token & item (itemx).header.tab then return; item (itemx).header.tab = "1"b; item (itemx).header.amount = start_col; end insert_tab; end format_one_statement; /* Convert a token and its trailers to items. Puts white space between two items if necessary. */ make_items: procedure (stmtx, tokenx, scan_control_comments, keep_gave_error_msg, itemx); declare stmtx fixed binary; /* (Input) statement that the token is in */ declare tokenx fixed binary; /* (Input) token to convert */ declare scan_control_comments bit (1) aligned;/* (Input) on to look for control comments */ declare keep_gave_error_msg bit (1) aligned;/* (Input) on to keep old value of item.gave_error_msg in trailer items */ declare itemx fixed binary; /* (Updated) last item */ declare is_after_statement bit (1) aligned; declare last_trailer_type fixed binary (8); declare last_type fixed binary (8); declare loop bit (1) aligned; declare next_comment_in_col_1 bit (1) aligned; declare 1 style_before_trailers aligned like style; declare this_type fixed binary (8); declare trailerx fixed binary; declare trailer_string char (trailer (trailerx).string_size) based (trailer (trailerx).string_ptr); declare last_space_class (0:53) fixed binary (3) internal static options (constant) initial ((10) 1, 2, /* ^ */ (11) 1, 2, /* prefix + */ 2, /* prefix - */ 1, /* assignment */ 2, /* : */ 1, /* ; */ 1, /* , */ 2, /* . */ 1, /* -> */ 3, /* ( */ 4, /* ) */ 2, /* % */ 1, /* target , */ 5, /* comment */ (19) (1)); declare this_space_class (0:53) fixed binary (3) internal static options (constant) initial ((25) 1, 4, /* : */ 2, /* ; */ 2, /* , */ 4, /* . */ 1, /* -> */ 1, /* ( */ 2, /* ) */ 4, /* % */ 2, /* target , */ 5, /* comment */ 1, /* nl_vt_np_token */ 3, /* bit_string */ 3, /* char_string */ (16) (1)); declare space_table (5, 5) fixed binary (1) unsigned internal static options (constant) initial (1, 0, 1, 0, 1, /* last space class 1 */ 0, 0, 0, 0, 1, /* last space class 2 */ 0, 0, 0, 0, 0, /* last space class 3 */ 1, 0, 0, 0, 1, /* last space class 4 */ 1, 0, 1, 1, 1); /* last space class 5 */ this_type = token (tokenx).type; last_type = item (itemx).type; if itemx >= hbound (item, 1) then call error (4, "Too many tokens and comments in a statement.", token (tokenx).string_ptr); itemx = itemx + 1; unspec (item (itemx)) = ""b; item (itemx).type = this_type; item (itemx).string_ptr = token (tokenx).string_ptr; item (itemx).string_size = token (tokenx).string_size; if last_type = right_parn then item (itemx).paren_depth = item (itemx - 1).paren_depth - 1; else item (itemx).paren_depth = item (itemx - 1).paren_depth; if this_type = left_parn then item (itemx).paren_depth = item (itemx).paren_depth + 1; item (itemx).precedence = precedence (this_type); if item (itemx - 1).trailer.NLs = 0 then item (itemx).header.amount, item (itemx).header.need_space = space_table (last_space_class (last_type), this_space_class (this_type)); if token (tokenx).trailer_index = 0 then return; style_before_trailers = global.current_style; is_after_statement = this_type = no_token | this_type = semi_colon | is_macro_statement (stmt (stmtx).type) & tokenx = stmt (stmtx).end; next_comment_in_col_1 = this_type = no_token | this_type = semi_colon & is_macro_statement (stmt (stmtx).type); last_trailer_type = no_token; loop = "1"b; do trailerx = token (tokenx).trailer_index by 1 while (loop); if trailer (trailerx).type = nl_vt_np_token then if is_after_statement | ^mode_delnl then begin; declare i fixed binary (21); next_comment_in_col_1 = trailer_string ^= NL | last_trailer_type = nl_vt_np_token | next_comment_in_col_1; do i = 1 to length (trailer_string); if substr (trailer_string, i, 1) = NL then item (itemx).trailer.NLs = item (itemx).trailer.NLs + 1; else if substr (trailer_string, i, 1) = VT then do; item (itemx).trailer.VTs = item (itemx).trailer.VTs + 1; item (itemx).trailer.NLs = 0; end; else do; /* NP */ item (itemx).trailer.NP = "1"b; item (itemx).trailer.VTs = 0; item (itemx).trailer.NLs = 0; end; end; end; else ; /* ignore vertical white space within stmt in delnl mode */ else begin; /* comment trailer */ declare category fixed binary (2); declare old_gave_error_msg bit (1) aligned; call adjust_vertical_white_space_after_item (itemx); if this_type = semi_colon & trailerx = token (tokenx).trailer_index + 1 & ^item (itemx).trailer.NP & item (itemx).trailer.VTs = 0 & item (itemx).trailer.NLs = 1 & mode_delnl then item (itemx).trailer.NLs = 0; if itemx >= hbound (item, 1) then call error (4, "Too many tokens and comments in a statement.", trailer (trailerx).string_ptr); itemx = itemx + 1; old_gave_error_msg = item (itemx).gave_error_msg; unspec (item (itemx)) = ""b; item (itemx).type = comment_token; item (itemx).string_ptr = trailer (trailerx).string_ptr; item (itemx).string_size = trailer (trailerx).string_size; if item (itemx - 1).type = right_parn then item (itemx).paren_depth = item (itemx - 1).paren_depth - 1; else item (itemx).paren_depth = item (itemx - 1).paren_depth; item (itemx).precedence = precedence (comment_token); item (itemx).header.need_space = space_table ( last_space_class (item (itemx - 1).type), this_space_class (comment_token)); item (itemx).gave_error_msg = old_gave_error_msg & keep_gave_error_msg; do category = length (comment_indicator_extra_chars) to 1 by -1 while ( substr (trailer_string, length (open_comment) + 1, min (length (trailer_string) - length (open_comment) - length (close_comment), category)) ^= substr (comment_indicator_extra_chars, 1, category)) ; end; item (itemx).comment_ind_len = length (open_comment) + category; item (itemx).header.insnl = category > 0; if substr (trailer_string, item (itemx).comment_ind_len + 1, length (comment_indicator_no_indcomtxt)) = comment_indicator_no_indcomtxt then item (itemx).comment_ind_len = item (itemx).comment_ind_len + length (comment_indicator_no_indcomtxt); else item (itemx).indcomtxt = "1"b; if category = 0 then if next_comment_in_col_1 then if mode_indcom & tokenx > 1 then category = 2; else category = 3; else if is_after_statement | this_type = comma | this_type = target_comma then category = 1; if category = 3 then do; item (itemx).header.tab = "1"b; item (itemx).header.amount = 1; end; else if category = 2 then do; item (itemx).header.tab = "1"b; item (itemx).header.amount = indent_margin (mode_indblkcom, left_margin); item (itemx).header.tab_blkcom = tokenx = stmt (stmtx).end; end; else if category = 1 then do; item (itemx).header.tab = "1"b; item (itemx).header.amount = mode_comcol; end; else do; item (itemx).header.amount = item (itemx).header.need_space; if trailer (trailerx).continued & mode_linecom then if trailer (trailerx + 1).type = nl_vt_np_token then do; item (itemx).header.tab = "1"b; item (itemx).header.amount = mode_comcol; if mode_delnl then item (itemx).trailer .NLs = 1; end; end; if scan_control_comments then if is_control_comment (trailer_string, (item (itemx).comment_ind_len), item (itemx).gave_error_msg) then if is_after_statement then do; item (itemx).control_comment = "1"b; call format_pl1_modes_ ( temp_segs (*), before ( after (trailer_string, control_comment_indicator), close_comment), addr (trailer_string), "1"b, item (itemx).gave_error_msg) ; end; else call error (2, "Control comment within statement.", item (itemx).string_ptr); end; last_trailer_type = trailer (trailerx).type; loop = trailer (trailerx).continued; end; call adjust_vertical_white_space_after_item (itemx); global.current_style = style_before_trailers; return; adjust_vertical_white_space_after_item: procedure (itemx); declare itemx fixed binary; /* (Input) item to adjust */ if (item (itemx).trailer.NP | item (itemx).trailer.VTs > 0) & item (itemx).trailer.NLs = 0 then item (itemx).trailer.NLs = 1; if item (itemx).type = comment_token & item (itemx).header.tab & item (itemx).trailer.NLs = 0 & mode_insnl then item (itemx).trailer.NLs = 1; end adjust_vertical_white_space_after_item; is_control_comment: procedure (comment, comment_ind_len, gave_error_msg) returns (bit (1) aligned); declare comment char (*); /* (Input) comment which may be a control comment */ declare comment_ind_len fixed binary (3); /* (Input) comment indicator length */ declare gave_error_msg bit (1); /* (Updated) on if printed it's a bad control comment */ declare control_comment bit (1) aligned; if index (comment, control_comment_indicator) = 0 then return ("0"b); if verify ( before (substr (comment, comment_ind_len + 1), control_comment_indicator), HT_SP) ^= 0 then return ("0"b); control_comment = search ( ltrim ( rtrim ( before (after (comment, control_comment_indicator), close_comment), HT_SP), HT_SP), HT_SP) = 0; if ^control_comment & ^gave_error_msg then do; call error (2, "Invalid syntax in control comment.", addr (comment)); gave_error_msg = "1"b; end; return (control_comment); end is_control_comment; end make_items; /* Copy all items in a statement into the output segment. */ copy_items: procedure (first_item, last_item); declare first_item fixed binary; /* (Input) index of first item to copy */ declare last_item fixed binary; /* (Input) index of last item to copy */ declare itemx fixed binary; declare item_string char (item (itemx).string_size) based (item (itemx).string_ptr); do itemx = first_item to last_item; if item (itemx).header.tab_blkcom then item (itemx).header.amount = indent_margin (mode_indblkcom, left_margin); if item (itemx).control_comment then do; call format_pl1_modes_ (temp_segs (*), before ( after (item_string, control_comment_indicator), close_comment), addr (item_string), "1"b, item (itemx).gave_error_msg); if off_region_ptr = null then if mode_on then call copy_item (itemx, "111"b); else do; call copy_item (itemx, "100"b); off_region_ptr = item (itemx).string_ptr; end; else if mode_on then do; call copy_off_region ( char_offset_ ((item (itemx).string_ptr))); call copy_item (itemx, "011"b); end; end; else if mode_on then call copy_item (itemx, "111"b); end; return; /* Copy one item into the output segment. */ copy_item: procedure (itemx, copy_sws); declare itemx fixed binary; /* (Input) item to copy */ declare copy_sws bit (3) aligned;/* (Input) on to copy header, item, trailer, respectively */ declare item_string char (item (itemx).string_size) based (item (itemx).string_ptr); if substr (copy_sws, 1, 1) & item (itemx).header.amount > 0 then begin; declare col_to_go fixed binary; declare tabs fixed binary; if item (itemx).header.tab then col_to_go = item (itemx).header.amount; else col_to_go = line_position + item (itemx).header.amount; if col_to_go < line_position | col_to_go = line_position & line_position > 1 & item (itemx).type ^= comment_token then if mode_insnl | item (itemx).header.insnl then do; call copy_string (NL); line_position = 1; end; else col_to_go = line_position + item (itemx).header.need_space; tabs = divide (col_to_go - 1, tab_interval, 17) - divide (line_position - 1, tab_interval, 17); if tabs > 0 & col_to_go - line_position > 1 then do; call copy_char (HT, tabs); line_position = tab_interval * divide (col_to_go - 1, tab_interval, 17) + 1; end; if line_position < col_to_go then do; call copy_char (SP, col_to_go - line_position); line_position = col_to_go; end; end; if substr (copy_sws, 2, 1) then if item (itemx).type = comment_token & (^global.rdc_source | index (item_string, "/*++") ^= 1) & item (itemx).indcomtxt & mode_indcomtxt then begin; declare comment_close_ind_len fixed binary (21); declare comment_text_len fixed binary (21); declare scan_index fixed binary (21); comment_text_len = length (item_string) - item (itemx).comment_ind_len - length (close_comment); comment_close_ind_len = length (close_comment); scan_index = verify ( reverse ( substr (item_string, item (itemx).comment_ind_len + 1, comment_text_len)) , comment_indicator_extra_chars) - 1; if scan_index < 0 then scan_index = comment_text_len; scan_index = min (scan_index, length (comment_indicator_extra_chars)); comment_text_len = comment_text_len - scan_index; comment_close_ind_len = comment_close_ind_len + scan_index; if comment_text_len >= length (comment_indicator_no_indcomtxt) then if substr (item_string, item (itemx).comment_ind_len + comment_text_len - length (comment_indicator_no_indcomtxt) + 1, length (comment_indicator_no_indcomtxt)) = comment_indicator_no_indcomtxt then do; comment_text_len = comment_text_len - length ( comment_indicator_no_indcomtxt); comment_close_ind_len = comment_close_ind_len + length ( comment_indicator_no_indcomtxt); end; begin; declare comment_close_ind char ( comment_close_ind_len ) defined ( item_string) position ( item (itemx) .comment_ind_len + comment_text_len + 1); declare comment_indicator char ( item (itemx) . comment_ind_len) defined ( item_string); declare comment_text char ( comment_text_len) defined ( item_string) position ( item (itemx) .comment_ind_len + 1); call indent_comment (comment_indicator, comment_text, comment_close_ind, (item (itemx).header.tab), item (itemx).header.amount - 1, line_position); end; end; else do; call copy_string (item_string); if item (itemx).type = char_string | item (itemx).type = comment_token then line_position = last_line_position (line_position, item_string); else line_position = line_position + length (item_string); end; if substr (copy_sws, 3, 1) & item (itemx).trailer.NLs > 0 then do; if (item (itemx).trailer.NP | item (itemx).trailer.VTs > 0) & line_position > 1 then call copy_string (NL); if item (itemx).trailer.NP then call copy_string (NP); call copy_char (VT, (item (itemx).trailer.VTs)); call copy_char (NL, (item (itemx).trailer.NLs)); line_position = 1; end; return; indent_comment: procedure (comment_indicator, comment_text, comment_close_ind, tab, comment_indentation, line_position); declare comment_indicator char (*); /* (Input) what the comment starts with */ declare comment_text char (*); /* (Input) text of comment to indent */ declare comment_close_ind char (*); /* (Input) what the comment ends with */ declare tab bit (1) aligned;/* (Input) on for block comments */ declare comment_indentation fixed binary; /* (Input) number of columns to indent comment */ declare line_position fixed binary; /* (Output) output segment line position */ declare line_length fixed binary (21); declare n_HT fixed binary; declare n_SP fixed binary; declare scan_index fixed binary (21); declare scan_position fixed binary (21); if tab then begin; declare text_indentation fixed binary; text_indentation = comment_indentation + length (comment_indicator || SP); n_HT = divide (text_indentation, tab_interval, 17); n_SP = text_indentation - tab_interval * n_HT; end; call copy_string (comment_indicator); scan_position = 1; do while (scan_position <= length (comment_text)); scan_index = search (substr (comment_text, scan_position), NL_VT_NP) - 1; if scan_index < 0 then do; scan_index = length (substr (comment_text, scan_position)); line_length = scan_index; end; else line_length = length ( rtrim ( substr (comment_text, scan_position, scan_index), HT_SP)); if scan_position = 1 then begin; declare line char (line_length) defined (comment_text); if verify (line, HT_SP) = 1 then call copy_string (SP); call copy_string (line); end; else if tab then begin; declare trim_length fixed binary (21); trim_length = length ( ltrim ( substr (comment_text, scan_position, line_length), HT_SP)); if trim_length > 0 then begin; declare trimmed_line char ( trim_length) defined ( comment_text) position ( scan_position + line_length - trim_length); call copy_char (HT, n_HT); call copy_char (SP, n_SP); call copy_string (trimmed_line); end; end; else begin; declare line char (line_length) defined (comment_text) position (scan_position) ; call copy_string (line); end; scan_position = scan_position + scan_index; scan_index = verify (substr (comment_text, scan_position), NL_VT_NP) - 1; if scan_index < 0 then scan_index = length (substr (comment_text, scan_position)); begin; declare vertical_white_space char (scan_index) defined (comment_text) position (scan_position) ; call copy_string (vertical_white_space); end; scan_position = scan_position + scan_index; end; if tab & index (NL_VT_NP, substr (output_string, copy_position - 1, 1)) > 0 then do; n_HT = divide (comment_indentation, tab_interval, 17); call copy_char (HT, n_HT); call copy_char (SP, comment_indentation - tab_interval * n_HT); end; else if index (HT_SP_NL_VT_NP, substr (output_string, copy_position - 1, 1)) = 0 then call copy_string (SP); call copy_string (comment_close_ind); begin; declare output char (copy_position - 1) defined (output_string); line_position = last_line_position (1, output); end; end indent_comment; /* Copy one character several times into the output segment. The complicated case statement is just to get better code out of the compiler. */ copy_char: procedure (char, number); declare char char (1); /* (Input) character to place in the output segment */ declare number fixed binary; /* (Input) how many times to copy the character */ if char = SP then substr (output_string, copy_position, number) = ""; else if char = HT then substr (output_string, copy_position, number) = copy (HT, number); else if char = NL then substr (output_string, copy_position, number) = copy (NL, number); else if char = VT then substr (output_string, copy_position, number) = copy (VT, number); else substr (output_string, copy_position, number) = copy (char, number); copy_position = copy_position + number; end copy_char; end copy_item; end copy_items; /* Copy an off region into the output segment. */ copy_off_region: procedure (stop_position); declare stop_position fixed binary (21); /* (Input) last character to copy */ declare off_region_length fixed binary (21); declare off_region_string char (off_region_length) based (off_region_ptr); off_region_length = stop_position - char_offset_ (off_region_ptr); call copy_string (off_region_string); line_position = last_line_position (line_position, off_region_string); off_region_ptr = null; end copy_off_region; /* Copy a string into the output segment. */ copy_string: procedure (string); declare string char (*); /* (Input) string to place in the output segment */ substr (output_string, copy_position, length (string)) = string; copy_position = copy_position + length (string); end copy_string; /* Calculate an indented margin. */ indent_margin: procedure (indent, margin) returns (fixed binary); declare indent bit (1); /* (Input) on to indent to margin */ declare margin fixed binary; /* (Input) margin to indent to */ if indent then return (margin); else return (max (margin - mode_ind, 1)); end indent_margin; /* Calculate the line position after a string. */ last_line_position: procedure (line_position, string) returns (fixed binary); declare line_position fixed binary; /* (Input) line position string starts on */ declare string char (*); /* (Input) string to place at line_position */ declare last_line_length fixed binary (21); last_line_length = search (reverse (string), NL_VT_NP) - 1; if last_line_length < 0 then return (next_line_position (line_position, string)); begin; declare last_line char (last_line_length) defined (string) position (length (string) - last_line_length + 1); return (next_line_position (1, last_line)); end; end last_line_position; /* Calculate the line position after a string on its first line, i.e. before any vertical white space. */ next_line_position: procedure (start_line_position, string) returns (fixed binary); declare start_line_position fixed binary; /* (Input) line position string start on */ declare string char (*); /* (Input) string to place at start_line_position */ declare line_position fixed binary (21); declare scan_index fixed binary (21); declare scan_position fixed binary (21); line_position = start_line_position; scan_position = 1; do while (scan_position <= length (string)); scan_index = search (substr (string, scan_position), HT_BS_NL_VT_NP) - 1; if scan_index < 0 then scan_index = length (substr (string, scan_position)); line_position = line_position + scan_index; scan_position = scan_position + scan_index + 1; if scan_position - 1 <= length (string) then if substr (string, scan_position - 1, 1) = HT then line_position = tab_interval * divide (line_position + tab_interval - 1, tab_interval, 17) + 1; else if substr (string, scan_position - 1, 1) = BS then line_position = line_position - 1; else scan_position = length (string) + 1; end; return (line_position); end next_line_position; /* Print an error message. */ error: procedure (severity, error_string, source_ptr); declare severity fixed binary (35); /* (Input) severity of the error */ declare error_string char (*); /* (Input) error message */ declare source_ptr pointer unaligned; /* (Input) pointer to error in source */ call format_pl1_error_ (temp_segs (*), severity, error_string, (source_ptr)); if severity >= 4 then goto unrecoverable_error; end error; end format_pl1_;  format_pl1_error_.pl1 08/10/84 0951.5re 08/10/84 0947.1 27252 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Centralize format_pl1 error reporting. Written by Paul Green. Modified by Monte Davidoff. */ /* format: style5 */ format_pl1_error_: procedure (P_temp_segs, P_severity, P_error_string, P_source_ptr); declare P_temp_segs (*) pointer; /* (Input) array of temporary segment pointers */ declare P_severity fixed binary (35); /* (Input) severity of the error */ declare P_error_string char (*); /* (Input) error message */ declare P_source_ptr pointer; /* (Input) pointer to where error occured in the source */ /* automatic */ declare line_length fixed binary (21); declare line_number fixed binary (21); declare line_start fixed binary (21); /* based */ declare source_string char (global.source_length) based (global.source_ptr); /* builtin */ declare (divide, index, length, max, null, size, substr) builtin; /* internal static */ declare NL char (1) internal static options (constant) initial (" "); /* entry */ declare char_offset_ entry (pointer) returns (fixed binary (21)) reducible; declare ioa_ entry options (variable); %include format_pl1_dcls; /* program */ temp_segs (*) = P_temp_segs (*); global.max_severity = max (global.max_severity, P_severity); line_number = 0; if P_source_ptr ^= null then begin; declare loop bit (1) aligned; declare source_position fixed binary (21); source_position = char_offset_ (P_source_ptr) - char_offset_ (global.source_ptr) + 1; line_start = 1; line_length = 0; loop = "1"b; do while (loop); line_number = line_number + 1; line_start = line_start + line_length; line_length = index (substr (source_string, line_start), NL); loop = line_start + line_length <= source_position & line_length > 0; end; if line_length = 0 then line_length = length (substr (source_string, line_start)) + 1; end; /* Print the error message. */ call ioa_ ("^/^[WARNING^s^;SEVERITY ^d ERROR^]^[^s^; ON LINE ^d^]", P_severity = 1, P_severity, line_number = 0, line_number); if P_error_string ^= "" then call ioa_ ("^a", P_error_string); if line_number > 0 then call ioa_ ("SOURCE:^-^a", substr (source_string, line_start, line_length - 1)); end format_pl1_error_;  format_pl1_lex_.pl1 08/10/84 0951.5re 08/10/84 0947.2 223803 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DESCRIPTION: This is the lexical analysis program for the format_pl1 command. The primary responsibilities of this program are: 1) Break the source program into tokens. 2) Thread comments off the preceding token. 3) Thread interstatement white space off the preceding token. 4) Diagnose errors in the lexical syntax of programs. This program also performs several miscellaneous chores that assist subsequent phases. They are: 1) Determine the type of arithmetic constants. Maintenance Instructions: To add another token type: 1) Add a token type declaration to format_pl1_dcls.incl.pl1. 2) Adjust the token class limits in format_pl1_dcls.incl.pl1. 3) If necessary, adjust tentative_token_type and action_table. To add another macro: 1) To add another macro statement, see in format_pl1_stmt_type_. 2) To add another macro reference, i.e. a macro construct that gets formatted like a PL/I reference such as %isarg, %isdef, and %target, add an entry to the ignore_percent_token array. */ /* HISTORY: Written by Paul Green, 11/05/77. from "lex" in the PL/I compiler. Modified: 12/26/77 by Paul Green: Save comments and vertical white space as token trailers. 11/01/78 by Monte Davidoff: 06/05/84 by R. Michael Tague: Make format_pl1 handle all % macro statements. Changed %arg to %isarg, and added %isdef to ignore_percent_token. */ /* format: style5 */ format_pl1_lex_: procedure (P_temp_segs); declare P_temp_segs (*) pointer; /* (Input) array of temporary segment pointers */ /* automatic */ declare action_index fixed binary; /* index of action to execute */ declare current_char char (1) aligned; /* character that stopped the scan, char we are checking */ declare loop bit (1) aligned;/* loop control variable */ declare scan_index fixed binary (21); /* index (relative to source_index) of forward scan */ declare source_index fixed binary (21); /* index into current source segment */ declare source_length fixed binary (21); /* length (in characters) of current source segment */ declare source_ptr pointer; /* pointer to base of source segment */ declare string_length fixed binary (21); /* number of characters in dequoted string */ declare token_length fixed binary (21); /* length of token in characters */ declare token_start fixed binary (21); /* index of first character of current token */ declare token_type fixed binary (8); /* type of current token */ declare tokenx fixed binary; /* index into token */ declare trailerx fixed binary; /* index into trailer */ declare tentative_token_type (0:128) fixed binary (8) initial ((9) invalid_char, /* 000-010 ctl chars */ no_token, /* 011 HT */ (3) nl_vt_np_token, /* 012-014 NL VT NP */ (19) invalid_char, /* 015-037 ctl chars */ no_token, /* 040 SP */ invalid_char, /* 041 ! */ char_string, /* 042 " */ (2) invalid_char, /* 043-044 # $ */ percent, /* 045 % */ and, /* 046 & */ invalid_char, /* 047 ' */ left_parn, /* 050 ( */ right_parn, /* 051 ) */ asterisk, /* 052 * */ plus, /* 053 + */ comma, /* 054 , */ minus, /* 055 - */ period, /* 056 . */ slash, /* 057 / */ (10) dec_integer, /* 060-071 0 - 9 */ colon, /* 072 : */ semi_colon, /* 073 ; */ lt, /* 074 < */ assignment, /* 075 = */ gt, /* 076 > */ (2) invalid_char, /* 077-100 ? @ */ (26) identifier,/* 101-132 A - Z */ (3) invalid_char, /* 133-135 [ \ ] */ not, /* 136 ^ */ (2) invalid_char, /* 137-140 _ ` */ (26) identifier,/* 141-172 a - z */ invalid_char, /* 173 { */ or, /* 174 | */ (3) invalid_char, /* 175-177 } ~ PAD */ invalid_char); /* >177 non-ASCII */ /* based */ declare source_string char (source_length) based (source_ptr); declare source_string_array (source_length) char (1) based (source_ptr); declare token_string char (token (tokenx).string_size) based (token (tokenx).string_ptr); /* builtin */ declare (addr, binary, bit, char, divide, hbound, index, lbound, length, min, null, rank, search, size, substr, unspec, verify) builtin; /* internal static */ declare action_table (0:128) fixed binary internal static options (constant) initial ((9) 10,/* 000-010 ctl chars */ 1, /* 011 HT */ (3) 9, /* 012-014 NL VT NP */ (19) 10, /* 015-037 ctl chars */ 1, /* 040 SP */ 10, /* 041 ! */ 2, /* 042 " */ 10, /* 043 # */ 10, /* 044 $ */ 4, /* 045 % */ 5, /* 046 & */ 10, /* 047 ' */ (2) 5, /* 050-051 ( ) */ 11, /* 052 * */ (2) 5, /* 053-054 + , */ 12, /* 055 - */ 7, /* 056 . */ 6, /* 057 / */ (10) 8, /* 060-071 0 - 9 */ (2) 5, /* 072-073 : ; */ 13, /* 074 < */ 5, /* 075 = */ 14, /* 076 > */ (2) 10, /* 077-100 ? @ */ (26) 3, /* 101-132 A - Z */ (3) 10, /* 133-135 [ \ ] */ 15, /* 136 ^ */ (2) 10, /* 137-140 _ ` */ (26) 3, /* 141-172 a - z */ 10, /* 173 { */ 16, /* 174 | */ (3) 10, /* 175-177 } ~ PAD */ 10); /* >177 non-ASCII */ declare bit_string_characters char (23) internal static options (constant) initial ("""0123456789ABCDEFabcdef"); declare digits char (10) internal static options (constant) initial ("0123456789"); declare identifier_characters char (64) internal static options (constant) initial ( "$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz" ); declare ignore_percent_token (3) char (8) internal static options (constant) initial ("%isarg", "%isdef", "%target"); declare HT_SP char (2) internal static options (constant) initial (" "); declare NL_VT_NP char (3) internal static options (constant) initial (" "); %include format_pl1_dcls; /* program */ temp_segs (*) = P_temp_segs (*); global.n_tokens = 0; global.n_trailers = 0; source_ptr = global.source_ptr; source_length = global.source_length; source_index = 1; unspec (token (1)) = ""b; /* build dummy first token */ token (1).type = no_token; token (1).string_ptr = null; tokenx = 1; trailerx = 0; action (1): /* Scan horizontal white space */ scan_index = verify (substr (source_string, source_index), HT_SP); if scan_index = 0 then goto end_of_source_reached_but_no_pending_token; source_index = source_index + scan_index; current_char = substr (source_string, source_index - 1, 1); token_start = source_index - 1; token_type = tentative_token_type ( min (rank (current_char), hbound (tentative_token_type, 1))); action_index = action_table (min (rank (current_char), hbound (action_table, 1))); goto action (action_index); action (2): /* Scan string: current_char = '"' */ string_length = 0; /* count of number of characters in reduced string */ loop = "1"b; do while (loop); scan_index = index (substr (source_string, source_index), """") - 1; if scan_index < 0 then do; call error (3, "Missing double quote after string constant.", token_start); source_index = source_length + 1; string_length = string_length + (source_length - token_start + 1); goto end_of_source_reached; end; source_index = source_index + scan_index + 1; string_length = string_length + scan_index; if source_index > source_length /* not an error */ then goto end_of_source_reached; loop = substr (source_string, source_index, 1) = """"; if loop then do; source_index = source_index + 1; string_length = string_length + 1; end; end; if substr (source_string, source_index, 1) = "b" then do; token_type = bit_string; source_index = source_index + 1; if source_index <= source_length then if index ("1234", substr (source_string, source_index, 1)) > 0 then source_index = source_index + 1; if string_length > max_bit_string_constant then call error (2, "Bit-string constant too long.", token_start); if verify ( substr (source_string, token_start, source_index - token_start), bit_string_characters) ^= 0 then call error (2, "Invalid characters in bit-string constant.", token_start); end; else do; if string_length > max_char_string_constant then call error (2, "Character-string constant too long.", token_start); if global.ca.check_strings & ( search ( substr (source_string, token_start, source_index - token_start), NL_VT_NP) > 0 | index ( substr (source_string, token_start, source_index - token_start), "/*") > 0 | index ( substr (source_string, token_start, source_index - token_start), "*/") > 0) then call error (1, "Character-string constant contains ""/*"", ""*/"", or vertical white space." , token_start); end; call make_token; goto check_syntax_after_constant; action (3): /* Scan identifiers */ call scan_past_identifier_characters; call make_token; /* Now make sure the syntax after the identifier is correct. */ if substr (source_string, source_index, 1) = """" & token_string ^= "p" & token_string ^= "pic" & token_string ^= "picture" then call error (2, "Double quote after identifier.", source_index); goto action (1); action (4): /* % */ if source_index > source_length then goto end_of_source_reached; current_char = substr (source_string, source_index, 1); action_index = action_table (min (rank (current_char), hbound (action_table, 1))); if action_index ^= 3 /* identifier */ then do; call make_token; goto action (1); end; source_index = source_index + 1; call scan_past_identifier_characters; do action_index = lbound (ignore_percent_token, 1) to hbound (ignore_percent_token, 1) while (ignore_percent_token (action_index) ^= substr (source_string, token_start, source_index - token_start)); end; if action_index <= hbound (ignore_percent_token, 1) then token_type = identifier; call make_token; /* Now make sure the syntax after the % is correct. */ if substr (source_string, source_index, 1) = """" then call error (2, "Double quote after %identifier.", source_index); goto action (1); action (5): /* Single character tokens */ call make_token; goto action (1); action (6): /* Separate / and /* */ if source_index > source_length then goto end_of_source_reached; if substr (source_string, source_index, 1) ^= "*" then do; call make_token; goto action (1); end; token_type = comment_token; source_index = source_index + 1; scan_index = index (substr (source_string, source_index), "*/") - 1; if scan_index < 0 then do; call error (3, "Missing ""*/"" at end of comment.", token_start) ; source_index = source_length + 1; call make_trailer; goto end_of_source_reached_but_no_pending_token; end; source_index = source_index + scan_index + length ("*/"); if index ( substr (source_string, token_start + length ("/*"), source_index - token_start - length ("/*") - length ("*/")), "/*") > 0 & global.ca.check_comments then call error (1, "Comment contains ""/*"".", token_start); call make_trailer; goto action (1); action (7): /* Separate . and numbers: current_char = "." */ if source_index > source_length then goto end_of_source_reached; if index (digits, substr (source_string, source_index, 1)) = 0 then do; call make_token; goto action (1); end; token_type = fixed_dec; call scan_past_digits; goto scan_exponent; action (8): /* Scan numbers and isubs: current char = */ if source_index > source_length then goto end_of_source_reached; call scan_past_digits; if substr (source_string, source_index, 1) = "." then do; token_type = fixed_dec; source_index = source_index + 1; call scan_past_digits; end; else if source_index + 2 <= source_length then if substr (source_string, source_index, 3) = "sub" then do; source_index = source_index + 3; token_type = isub; call make_token; goto check_syntax_after_constant; end; scan_exponent: token_length = source_index - token_start; /* remember length of mantissa for later error check */ if substr (source_string, source_index, 1) = "e" | substr (source_string, source_index, 1) = "f" then do; if substr (source_string, source_index, 1) = "e" then token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) | is_float_constant); token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) & ^is_integral_constant); source_index = source_index + 1; if source_index > source_length then do; call error (3, "Missing exponent in arithmetic constant.", token_start); goto end_of_source_reached; end; if substr (source_string, source_index, 1) = "+" | substr (source_string, source_index, 1) = "-" then do; source_index = source_index + 1; if source_index > source_length then do; call error (3, "Missing exponent in arithmetic constant.", token_start); goto end_of_source_reached; end; end; call scan_past_digits; end; if substr (source_string, source_index, 1) = "b"/* binary constant */ then do; token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) & ^is_decimal_constant); source_index = source_index + 1; if verify (substr (source_string, token_start, token_length), ".01") > 0 then call error (2, "Non-binary digit in binary constant.", token_start); end; if source_index <= source_length then if substr (source_string, source_index, 1) = "p" then do; /* default suppression indicator */ token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) & ^is_integral_constant); source_index = source_index + 1; end; if source_index <= source_length then if substr (source_string, source_index, 1) = "i" then do; /* imaginary constant */ token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) | is_imaginary_constant); source_index = source_index + 1; end; call make_token; /* Now make sure the syntax after the constant is correct. */ check_syntax_after_constant: if source_index > source_length then goto end_of_source_reached; current_char = substr (source_string, source_index, 1); action_index = action_table (min (rank (current_char), hbound (action_table, 1))); if action_index = 2 | action_index = 3 | action_index = 8 /* double quote, identifier, or arithmetic constant */ then call error (2, "Invalid syntax after constant or isub.", source_index); goto action (1); action (9): /* Scan NL VT NP */ scan_index = verify (substr (source_string, source_index), NL_VT_NP) - 1; if scan_index < 0 then source_index = source_length + 1; else source_index = source_index + scan_index; call make_trailer; goto action (1); action (10): /* Invalid characters */ if rank (current_char) < 32 | 128 <= rank (current_char) then call error (2, "Invalid character. """ || char (bit (rank (current_char))) || """b", source_index - 1); else if current_char = "_" | current_char = "$" then call error (2, """" || current_char || """ may not start an identifier.", source_index - 1); else call error (2, "Invalid character. """ || current_char || """", source_index - 1); call make_token; goto action (1); action (11): /* Separate * and ** */ if source_index > source_length then goto end_of_source_reached; if substr (source_string, source_index, 1) = "*" then do; source_index = source_index + 1; token_type = expon; end; call make_token; goto action (1); action (12): /* Separate - and -> */ if source_index > source_length then goto end_of_source_reached; if substr (source_string, source_index, 1) = ">" then do; source_index = source_index + 1; token_type = arrow; end; call make_token; goto action (1); action (13): /* Separate < and <= */ if source_index > source_length then goto end_of_source_reached; if substr (source_string, source_index, 1) = "=" then do; source_index = source_index + 1; token_type = le; end; call make_token; goto action (1); action (14): /* Separate > and >= */ if source_index > source_length then goto end_of_source_reached; if substr (source_string, source_index, 1) = "=" then do; source_index = source_index + 1; token_type = ge; end; call make_token; goto action (1); action (15): /* Separate ^ and ^= and ^< and ^> */ if source_index > source_length then goto end_of_source_reached; if substr (source_string, source_index, 1) = "=" then do; source_index = source_index + 1; token_type = ne; end; else if substr (source_string, source_index, 1) = "<" then do; source_index = source_index + 1; token_type = nlt; end; else if substr (source_string, source_index, 1) = ">" then do; source_index = source_index + 1; token_type = ngt; end; call make_token; goto action (1); action (16): /* Separate | and || */ if source_index > source_length then goto end_of_source_reached; if substr (source_string, source_index, 1) = "|" then do; source_index = source_index + 1; token_type = cat; end; call make_token; goto action (1); /* Control transfers here whenever the lex reaches the end of the current source segment. */ end_of_source_reached: call make_token; end_of_source_reached_but_no_pending_token: if tokenx >= hbound (token, 1) then call error (4, "Too many tokens.", source_length); unspec (token (tokenx + 1)) = ""b; /* build dummy last token */ token (tokenx + 1).type = no_token; /* Set string_ptr so error messages will indicate the end of the program. */ if source_length = 0 then token (tokenx + 1).string_ptr = null; else token (tokenx + 1).string_ptr = addr (source_string_array (source_length)); unrecoverable_error: global.n_tokens = tokenx; global.n_trailers = trailerx; return; /* Make a Token. Convention: token_type set to the correct type token_start set to index of first character of token source_index set to index of first character after token */ make_token: procedure; token_length = source_index - token_start; if token_type = identifier & token_length > max_identifier_length then call error (2, "Identifier too long.", token_start); if tokenx >= hbound (token, 1) then call error (4, "Too many tokens.", token_start); tokenx = tokenx + 1; unspec (token (tokenx)) = ""b; token (tokenx).type = token_type; token (tokenx).string_size = token_length; token (tokenx).string_ptr = addr (source_string_array (token_start)); end make_token; /* Make a token trailer and thread it off of the previous token. Convention: token_start set to index of first char of trailer token_type set to trailer type source_index set to first char past trailer */ make_trailer: procedure; if trailerx >= hbound (trailer, 1) then call error (4, "Too many trailers.", token_start); trailerx = trailerx + 1; unspec (trailer (trailerx)) = ""b; trailer (trailerx).type = token_type; trailer (trailerx).string_size = source_index - token_start; trailer (trailerx).string_ptr = addr (source_string_array (token_start)); if token (tokenx).trailer_index = 0 then token (tokenx).trailer_index = trailerx; else trailer (trailerx - 1).continued = "1"b; end make_trailer; /* Convert an arithmetic token type to it's bit string encoding. */ arithmetic_to_bit: procedure (type) returns (bit (4) aligned); declare type fixed binary (8); /* (Input) arithmetic token type */ return (bit (binary (type - min_arithmetic_token, 4), 4)); end arithmetic_to_bit; /* Convert the bit string encoding of an arithmetic token type to it's token type. */ bit_to_arithmetic: procedure (bit_encoding) returns (fixed binary (8)); declare bit_encoding bit (4) aligned;/* (Input) arithmetic token type bit string encoding */ return (binary (bit_encoding, 4) + min_arithmetic_token); end bit_to_arithmetic; /* Scan sequences of identifier characters. Convention: source_index Entry: on character after identifier character Exit: on stopping break */ scan_past_identifier_characters: procedure; scan_index = verify (substr (source_string, source_index), identifier_characters) - 1; if scan_index < 0 then do; source_index = source_length + 1; goto end_of_source_reached; end; source_index = source_index + scan_index; end scan_past_identifier_characters; /* Scan sequences of . Convention: source_index Entry: on character after digit Exit: on stopping break */ scan_past_digits: procedure; scan_index = verify (substr (source_string, source_index), digits) - 1; if scan_index < 0 then do; source_index = source_length + 1; goto end_of_source_reached; end; source_index = source_index + scan_index; end scan_past_digits; /* Print an error message. */ error: procedure (severity, error_string, error_index); declare severity fixed binary (35); /* (Input) severity of error */ declare error_string char (*); /* (Input) error message */ declare error_index fixed binary (21); /* (Input) index into source where error occured */ call format_pl1_error_ (temp_segs (*), severity, error_string, addr (source_string_array (error_index))); if severity >= 4 then goto unrecoverable_error; end error; end format_pl1_lex_;  format_pl1_long_.pl1 08/10/84 0951.5re 08/10/84 0947.2 31311 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Print the -long control argument message. Written 17 March 1981 by M. N. Davidoff. */ /* format: style5 */ format_pl1_long_: procedure (P_temp_segs, P_source_ptr); declare P_temp_segs (*) pointer; /* (Input) array of temporary segment pointers */ declare P_source_ptr pointer; /* (Input) pointer to prevailing style control comment */ /* automatic */ declare mode_differences char (dimension (switch_mode_names, 1) * (length (switch_mode_not_indicator) + max ( maxlength ( switch_mode_names ( lbound (switch_mode_names, 1))), maxlength ( switch_antonym_names ( lbound (switch_antonym_names, 1)))) + length (mode_separator)) + dimension (value_mode_names, 1) * ( maxlength ( value_mode_names ( lbound (value_mode_names, 1))) + length (null -> value_picture) + length (mode_separator))) varying; declare mode_index fixed binary; /* based */ declare value_picture picture "(5)z9" based; /* builtin */ declare (convert, dimension, divide, hbound, lbound, length, ltrim, max, maxlength, null, rtrim, size) builtin; %include format_pl1_dcls; /* program */ temp_segs (*) = P_temp_segs (*); mode_differences = ""; do mode_index = lbound (global.prevailing_style.switches, 1) to hbound (global.prevailing_style.switches, 1); if global.prevailing_style.switches (mode_index) ^= global.command_line_style.switches (mode_index) then do; if mode_differences ^= "" then mode_differences = mode_differences || mode_separator; if ^global.prevailing_style.switches (mode_index) then if switch_antonym_names (mode_index) = "" then mode_differences = mode_differences || switch_mode_not_indicator || rtrim ( switch_mode_names (mode_index)); else mode_differences = mode_differences || rtrim ( switch_antonym_names (mode_index)); else mode_differences = mode_differences || rtrim (switch_mode_names (mode_index)); end; end; do mode_index = lbound (global.prevailing_style.values, 1) to hbound (global.prevailing_style.values, 1); if global.prevailing_style.values (mode_index) ^= global.command_line_style.values (mode_index) then do; if mode_differences ^= "" then mode_differences = mode_differences || mode_separator; mode_differences = mode_differences || rtrim (value_mode_names (mode_index)) || ltrim ( convert (value_picture, global.prevailing_style.values (mode_index))); end; end; call format_pl1_error_ (temp_segs (*), 1, "The following prevailing style modes differ from the command line modes: " || mode_differences, P_source_ptr); end format_pl1_long_;  format_pl1_modes_.pl1 08/10/84 0951.5re 08/10/84 0947.2 58464 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Scan a modes string and apply the modes to the current style. Written 5-Nov-79 by M. N. Davidoff. */ /* format: style5 */ format_pl1_modes_: procedure (P_temp_segs, P_modes_string, P_source_ptr, P_revert_ok_sw, P_printed_error_msg_sw); declare P_temp_segs (*) pointer; /* (Input) array of temporary segment pointers */ declare P_modes_string char (*); /* (Input) modes string to scan */ declare P_source_ptr pointer; /* (Input) pointer to control comment in source segment, or null for a command line modes string */ declare P_revert_ok_sw bit (1); /* (Input) on if there is a prevailing style */ declare P_printed_error_msg_sw bit (1); /* (Input/Output) on if printed it's a bad modes string */ /* automatic */ declare modes_string_length fixed binary (21); declare scan_index fixed binary (21); declare scan_length fixed binary (21); /* based */ declare modes_string char (modes_string_length) based (addr (P_modes_string)); /* builtin */ declare (addr, binary, divide, hbound, index, lbound, length, null, reverse, rtrim, search, size, substr, verify) builtin; /* internal static */ declare HT_SP char (2) internal static options (constant) initial (" "); declare digits char (10) internal static options (constant) initial ("0123456789"); /* entry */ declare com_err_ entry options (variable); %include format_pl1_dcls; /* program */ temp_segs (*) = P_temp_segs (*); modes_string_length = length (rtrim (P_modes_string, HT_SP)); if modes_string_length = 0 then call error (2, ""); scan_index = verify (P_modes_string, HT_SP); do while (scan_index <= length (modes_string)); scan_length = index (substr (modes_string, scan_index), mode_separator) - 1; if scan_length < 0 then scan_length = length (substr (modes_string, scan_index)); begin; declare mode char (scan_length) defined (modes_string) position (scan_index); call apply_mode (mode); end; scan_index = scan_index + scan_length + length (mode_separator); end; if index (reverse (modes_string), reverse (mode_separator)) = 1 then call error (2, ""); return: return; /* Apply one mode to the current style. */ apply_mode: procedure (mode_and_value); declare mode_and_value char (*); /* (Input) mode to apply */ declare mode char (32); declare mode_index fixed binary; declare mode_length fixed binary (21); declare mode_start_pos fixed binary (21); declare not_sw bit (1) aligned; declare value fixed binary; not_sw = index (mode_and_value, switch_mode_not_indicator) = 1; if not_sw then mode_start_pos = length (switch_mode_not_indicator) + 1; else mode_start_pos = 1; mode_length = search (substr (mode_and_value, mode_start_pos), digits) - 1; if mode_length < 0 then mode_length = length (substr (mode_and_value, mode_start_pos)); mode = substr (mode_and_value, mode_start_pos, mode_length); if mode_start_pos + mode_length > length (mode_and_value) then value = -1; else begin; declare conversion condition; declare size condition; if verify ( substr (mode_and_value, mode_start_pos + mode_length), digits) ^= 0 then call error (2, mode_and_value); on conversion, size call error (2, mode_and_value); (conversion, size): value = binary ( substr (mode_and_value, mode_start_pos + mode_length), 17); end; if mode = revert_mode then if not_sw | value >= 0 | ^P_revert_ok_sw then call error (2, mode_and_value); else do; global.current_style = global.prevailing_style; return; end; if mode = style_mode then if value < lbound (styles, 1) | hbound (styles, 1) < value | not_sw then call error (2, mode_and_value); else do; global.current_style = styles (value); return; end; do mode_index = lbound (value_mode_names, 1) to hbound (value_mode_names, 1); if mode = value_mode_names (mode_index) then if not_sw | value < 0 then call error (2, mode_and_value); else do; global.current_style.values (mode_index) = value; return; end; end; if value >= 0 then call error (2, mode_and_value); do mode_index = lbound (switch_mode_names, 1) to hbound (switch_mode_names, 1); if mode = switch_mode_names (mode_index) then do; global.current_style.switches (mode_index) = ^not_sw; return; end; end; do mode_index = lbound (switch_antonym_names, 1) to hbound (switch_antonym_names, 1); if mode = switch_antonym_names (mode_index) then do; global.current_style.switches (mode_index) = not_sw; return; end; end; call error (2, mode_and_value); end apply_mode; /* Print an error message. */ error: procedure (severity, mode); declare severity fixed binary (35); /* (Input) severity of the error */ declare mode char (*); /* (Input) mode that is in error */ if ^P_printed_error_msg_sw then do; if P_source_ptr = null then do; global.max_severity = 5; call com_err_ (0, command, "Invalid mode. ""^a""", mode) ; end; else call format_pl1_error_ (temp_segs (*), severity, "Invalid mode. """ || mode || """", P_source_ptr); P_printed_error_msg_sw = "1"b; end; goto return; end error; end format_pl1_modes_;  format_pl1_record_style_.pl1 08/10/84 0951.5re 08/10/84 0947.2 49437 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Write a prevailing style control comment into the output segment. Written 5-Nov-79 by M. N. Davidoff. */ /* format: style5 */ format_pl1_record_style_: procedure (P_temp_segs, P_copy_position, P_line_position); declare P_temp_segs (*) pointer; /* (Input) array of temporary segment pointers */ declare P_copy_position fixed binary (21); /* (Input/Output) output segment index of next character */ declare P_line_position fixed binary; /* (Input/Output) column next character will be in */ /* builtin */ declare (convert, divide, hbound, lbound, length, ltrim, rtrim, size, substr) builtin; /* internal static */ declare NL char (1) internal static options (constant) initial (" "); declare SP char (1) internal static options (constant) initial (""); %include format_pl1_dcls; /* program */ temp_segs (*) = P_temp_segs (*); call record_style (get_nearest_style ()); return; /* Find the predefined style closest to the prevailing style. */ get_nearest_style: procedure returns (fixed binary); declare differences fixed binary; declare fewest_differences fixed binary; declare nearest_style fixed binary; declare style_index fixed binary; nearest_style = lbound (styles, 1); fewest_differences = count_differences (nearest_style); do style_index = lbound (styles, 1) + 1 to hbound (styles, 1); differences = count_differences (style_index); if differences < fewest_differences then do; fewest_differences = differences; nearest_style = style_index; end; end; return (nearest_style); /* Count how many modes are different between a predefined style and the prevailing style. */ count_differences: procedure (style_index) returns (fixed binary); declare style_index fixed binary; /* (Input) predefined style number */ declare differences fixed binary; declare mode_index fixed binary; differences = 0; do mode_index = lbound (global.prevailing_style.switches, 1) to hbound (global.prevailing_style.switches, 1); if global.prevailing_style.switches (mode_index) ^= styles (style_index).switches (mode_index) then differences = differences + 1; end; do mode_index = lbound (global.prevailing_style.values, 1) to hbound (global.prevailing_style.values, 1); if global.prevailing_style.values (mode_index) ^= styles (style_index).values (mode_index) then differences = differences + 1; end; return (differences); end count_differences; end get_nearest_style; /* Write the prevailing style control comment. */ record_style: procedure (nearest_style); declare nearest_style fixed binary; /* (Input) predefined style closest to the prevailing style */ declare mode_index fixed binary; declare value_picture picture "(5)z9" based; if P_line_position > 1 then do; call copy_string (NL); P_line_position = 1; end; call copy_string ("/*" || SP || control_comment_indicator || SP || style_mode || ltrim (convert (value_picture, nearest_style))); do mode_index = lbound (global.prevailing_style.switches, 1) to hbound (global.prevailing_style.switches, 1); if global.prevailing_style.switches (mode_index) ^= styles (nearest_style).switches (mode_index) then do; call copy_string (mode_separator); if ^global.prevailing_style.switches (mode_index) then if switch_antonym_names (mode_index) = "" then call copy_string ( switch_mode_not_indicator || rtrim ( switch_mode_names (mode_index))); else call copy_string ( rtrim ( switch_antonym_names (mode_index))); else call copy_string ( rtrim (switch_mode_names (mode_index))); end; end; do mode_index = lbound (global.prevailing_style.values, 1) to hbound (global.prevailing_style.values, 1); if global.prevailing_style.values (mode_index) ^= styles (nearest_style).values (mode_index) then call copy_string (mode_separator || rtrim (value_mode_names (mode_index)) || ltrim ( convert (value_picture, global.prevailing_style.values (mode_index)))); end; call copy_string (SP || "*/" || NL); return; /* Copy a string into the output segment. */ copy_string: procedure (string); declare string char (*); /* (Input) string to copy into the output segment */ substr (output_string, P_copy_position, length (string)) = string; P_copy_position = P_copy_position + length (string); end copy_string; end record_style; end format_pl1_record_style_;  format_pl1_stmt_type_.pl1 02/22/85 0829.4rew 02/21/85 0931.2 254817 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DESCRIPTION: Produce a list of statements from a list of tokens. The token type assigned by format_pl1_lex_ is not based upon the context of the token. For example, format_pl1_lex_ assigns "-" the token type minus. This token may be a prefix_minus token depending upon the context. This procedure uses contextual information to make sure the token type is correct. The steps are: 1) Find the end of condition prefix lists, if any. 2) Find the end of label prefix lists, if any, and fix up the token types. 3) Figure out the type of the next statement. 4) Find the end of the statement. 5) Fix up the token types in the statement. Maintenance Instructions: To add another token type: 1) If necesary, change fix_up_tokens to recognize the context in which this token occurs and change an existing token type to the new one. To add another PL/I statement: 1) Add a statement type declaration to format_pl1_dcls.incl.pl1. 2) Add entries to the is_independent_statement, is macro_whitespace, and is_macro_statement arrays in format_pl1_dcls.incl.pl1. 3) Change statement_type to recognize the new statement. This includes adding entries to the keyword, s_type, and paren_not_allowed arrays. 4) If the statement does not end with a semicolon, change find_end_of_statement. 5) If the statement requires certain token types be changed in order to be formatted properly, change fix_up_tokens. To add another macro: 1) Add a statement type declaration that starts with "percent_" to format_pl1_dcls.incl.pl1. 2) Add entries to the is_independent_statement, is_macro_statement, and is_macro_whitespace array in format_pl1_dcls.incl.pl1. 3) Change percent_statement_type to recognize the new macro. 4) If the macro does not end with a semicolon, change find_end_of_statement. 5) If the macro requires certain token types be changed in order to be formatted properly, change fix_up_tokens. */ /* HISTORY: Written by Paul Green, 11/05/77. Modified: 12/10/78 by Monte Davidoff: Removed from format_pl1_. 06/05/84 by R. Michael Tague: To handle all legal pmac % statements. 02/12/85 by R. Michael Tague: Changed test for the "Unknown statement after macro" error message to use is_macro_statement instead of comparing with percent_statment. This should have been changed before. */ /* format: style5,^indcomtxt */ format_pl1_stmt_type_: procedure (P_temp_segs); declare P_temp_segs (*) pointer; /* (Input) array of temporary segment pointers */ /* automatic */ declare stmtx fixed binary; /* index into stmt */ /* builtin */ declare (divide, hbound, index, lbound, length, size, substr, unspec) builtin; %include format_pl1_dcls; /* program */ temp_segs (*) = P_temp_segs (*); global.n_stmts = 0; unspec (stmt (1)) = ""b; /* build dummy first stmt */ stmt (1).type = unknown_statement; stmt (1).subtype = subtype_none; stmt (1).start = 1; stmt (1).end = 1; stmtx = 1; begin; declare tokenx fixed binary; tokenx = 2; do while (tokenx <= global.n_tokens); call type_the_prefix_lists (tokenx); if tokenx <= global.n_tokens then call type_one_statement (tokenx); end; end; if stmtx >= hbound (stmt, 1) then call error (4, "Too many statements.", (stmt (stmtx).start)); unspec (stmt (stmtx + 1)) = ""b; /* build dummy last stmt */ stmt (stmtx + 1).type = unknown_statement; stmt (stmtx + 1).subtype = subtype_none; stmt (stmtx + 1).start = global.n_tokens + 1; stmt (stmtx + 1).end = global.n_tokens + 1; unrecoverable_error: global.n_stmts = stmtx; return; type_the_prefix_lists: procedure (tokenx); declare tokenx fixed binary; /* (Updated) current token */ declare label bit (1) aligned; declare labelx fixed binary; declare prefix_start fixed binary; /* condition prefix list */ prefix_start = tokenx; do while (token (tokenx).type = left_parn); tokenx = tokenx + 1; if token (tokenx).type = identifier then tokenx = tokenx + 1; else if token (tokenx).type ^= percent then call error (3, "Missing identifier in condition prefix list.", tokenx); do while (token (tokenx).type = comma); tokenx = tokenx + 1; if token (tokenx).type = identifier then tokenx = tokenx + 1; else if token (tokenx).type ^= percent then call error (3, "Missing identifier in condition prefix list.", tokenx); end; if token (tokenx).type = right_parn then tokenx = tokenx + 1; else if token (tokenx).type ^= percent then call error (3, "Missing right parenthesis in condition prefix list.", tokenx); if token (tokenx).type = colon then tokenx = tokenx + 1; else if token (tokenx).type ^= percent then call error (3, "Missing colon after condition prefix list.", tokenx); end; if tokenx > prefix_start then call make_stmt (condition_prefix_list, subtype_none, prefix_start, tokenx - 1); /* label prefix list */ prefix_start = tokenx; label = "1"b; do while (token (tokenx).type = identifier & label); labelx = tokenx + 1; if token (labelx).type = left_parn then do; labelx = labelx + 1; if token (labelx).type = plus | token (labelx).type = minus then labelx = labelx + 1; if token (labelx).type = dec_integer | may_be_percent_replace_label_prefix (tokenx, labelx) then do; labelx = labelx + 1; if token (labelx).type = right_parn then labelx = labelx + 1; else label = "0"b; end; else label = "0"b; end; if token (labelx).type = colon & label then do tokenx = tokenx to labelx; if token (tokenx).type = plus then token (tokenx).type = prefix_plus; else if token (tokenx).type = minus then token (tokenx).type = prefix_minus; end; else label = "0"b; end; if tokenx > prefix_start then call make_stmt (label_prefix_list, subtype_none, prefix_start, tokenx - 1); return; /* Label prefixes have the form "id ( [+|-] dec_integer ) :". The %replace macro introduces the possibility that the dec_integer may be an identifier that is replaced by a dec_integer. "id ( id ) :" can't always be formatted as a label prefix since "else ( overflow ) :" is ambiguous. This could be an else clause with a condition prefix, rather than a label array named "else" with a %replace identifier named "overflow". This procedure allows label prefixes of the form "id ( id ) :" unless the label array is "else" and the subscript is a condition prefix list condition name. */ may_be_percent_replace_label_prefix: procedure (label_token, subscript_token) returns (bit (1) aligned); declare label_token fixed binary; /* (Input) index of label name token */ declare subscript_token fixed binary; /* (Input) index of subscript token */ declare cnx fixed binary; declare subscript_start_pos fixed binary (21); declare label_string char (token (label_token).string_size) based (token (label_token).string_ptr); declare subscript_string char (token (subscript_token) .string_size) based (token (subscript_token) .string_ptr); declare condition_name (17) char (16) internal static options (constant) initial ("conversion", "conv", "fixedoverflow", "fofl", "overflow", "ofl", "size", "stringrange", "strg", "stringsize", "strz", "subscriptrange", "subrg", "underflow", "ufl", "zerodivide", "zdiv"); declare disable_prefix char (2) internal static options (constant) initial ("no"); if token (subscript_token).type ^= identifier then return ("0"b); if label_token + 2 ^= subscript_token | label_string ^= "else" then return ("1"b); if index (subscript_string, disable_prefix) = 1 then subscript_start_pos = length (disable_prefix) + 1; else subscript_start_pos = 1; do cnx = lbound (condition_name, 1) to hbound (condition_name, 1) while (condition_name (cnx) ^= substr (subscript_string, subscript_start_pos)); end; return (cnx > hbound (condition_name, 1)); end may_be_percent_replace_label_prefix; end type_the_prefix_lists; /* Get the type of one statement. If the statement contains an embedded statement, e.g. if, else or on, then tokenx is left pointing to the first token of the embedded statement. */ type_one_statement: procedure (tokenx); declare tokenx fixed binary; /* (Updated) index of current token, updated to first token of next statement */ declare start fixed binary; declare type fixed binary (8); start = tokenx; type = statement_type (start); call find_end_of_statement (type, start, tokenx); call fix_up_tokens (type, start, tokenx); call make_stmt (type, statement_subtype (type, start, tokenx), start, tokenx); tokenx = tokenx + 1; return; statement_type: procedure (first_token) returns (fixed binary (8)); declare first_token fixed binary; /* (Input) first token of statement */ declare tokenx fixed binary; declare keywordx fixed binary; declare tokenx_token_string char (token (tokenx).string_size) based (token (tokenx).string_ptr); declare keyword (34) char (12) aligned internal static options (constant) initial ("alloc", "allocate", "begin", "call", "close", "dcl", "declare", "default", "delete", "dft", "do", "else", "end", "entry", "format", "free", "get", "go", "goto", "if", "locate", "on", "open", "proc", "procedure", "put", "read", "return", "revert", "rewrite", "signal", "stop", "system", "write"); declare s_type (34) fixed binary (8) internal static options (constant) initial (1, /* alloc */ 1, /* allocate */ 3, /* begin */ 4, /* call */ 5, /* close */ 6, /* dcl */ 6, /* declare */ 36, /* default */ 8, /* delete */ 36, /* dft */ 10, /* do */ 11, /* else */ 12, /* end */ 13, /* entry */ 15, /* format */ 16, /* free */ 17, /* get */ 18, /* go */ 18, /* goto */ 19, /* if */ 20, /* locate */ 22, /* on */ 23, /* open */ 24, /* proc */ 24, /* procedure */ 25, /* put */ 26, /* read */ 27, /* return */ 28, /* revert */ 29, /* rewrite */ 30, /* signal */ 31, /* stop */ 32, /* system */ 35); /* write */ declare paren_not_allowed (34) bit (1) aligned internal static options (constant) initial ("1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b); /* Figure out what the next statement is. */ tokenx = first_token; if token (tokenx).type = semi_colon then return (null_statement); if token (tokenx).type = percent then return (percent_statement_type (tokenx)); if token (tokenx).type ^= identifier then do; if global.include_file & stmtx = 1 then call error (1, "Unknown statement at beginning of include file.", tokenx); else if is_macro_statement (stmt (stmtx).type) then call error (1, "Unknown statement after macro.", tokenx) ; else call error (3, "Unknown statement.", tokenx); return (unknown_statement); end; /* statement starts with an identifier */ if token (tokenx + 1).type = assignment | token (tokenx + 1).type = arrow | token (tokenx + 1).type = period | token (tokenx + 1).type = comma then return (assignment_statement); do keywordx = lbound (keyword, 1) to hbound (keyword, 1) while (keyword (keywordx) ^= tokenx_token_string); end; if keywordx > hbound (keyword, 1) then return (assignment_statement); if token (tokenx + 1).type = left_parn then if paren_not_allowed (keywordx) then return (assignment_statement); else ; else return (s_type (keywordx)); /* statement starts with "keyword (" */ call skip_parens (tokenx); if token (tokenx).type = arrow | token (tokenx).type = period then return (assignment_statement); if token (tokenx).type = comma then if s_type (keywordx) = declare_statement then do; do while (token (tokenx).type ^= semi_colon & token (tokenx).type ^= assignment); if token (tokenx).type = left_parn then call skip_parens (tokenx); else tokenx = tokenx + 1; end; if token (tokenx).type = assignment then return (assignment_statement); else return (declare_statement); end; else return (assignment_statement); if token (tokenx).type = assignment then if s_type (keywordx) ^= if_statement then return (assignment_statement); else ; else return (s_type (keywordx)); /* statement starts with "if ( ... ) =" */ call find_then (first_token, tokenx); if token (tokenx).type = identifier then return (if_statement); return (assignment_statement); percent_statement_type: procedure (first_token) returns (fixed binary (8)); declare first_token fixed binary; /* (Input) first token of statement */ declare first_token_string char (token (first_token).string_size) based (token (first_token).string_ptr); if first_token_string = "%" then return (percent_statement); else if first_token_string = "%abort" then return (percent_abort_statement); else if first_token_string = "%default" then return (percent_default_statement); else if first_token_string = "%else" then return (percent_else_statement); else if first_token_string = "%elseif" then return (percent_elseif_statement); else if first_token_string = "%endif" then return (percent_endif_statement); else if first_token_string = "%error" then return (percent_error_statement); else if first_token_string = "%if" then return (percent_if_statement); else if first_token_string = "%include" then return (percent_include_statement); else if first_token_string = "%INCLUDE" then return (percent_include_statement); else if first_token_string = "%page" then return (percent_page_statement); else if first_token_string = "%print" then return (percent_print_statement); else if first_token_string = "%replace" then return (percent_replace_statement); else if first_token_string = "%set" then return (percent_set_statement); else if first_token_string = "%skip" then return (percent_skip_statement); else if first_token_string = "%warn" then return (percent_warn_statement); else do; call error (3, "Unknown macro.", first_token); return (percent_statement); end; end percent_statement_type; end statement_type; find_end_of_statement: procedure (stmt_type, first_token, last_token); declare stmt_type fixed binary (8); /* (Input) type of the statement */ declare first_token fixed binary; /* (Input) first token of the statement */ declare last_token fixed binary; /* (Output) last token of the statement */ declare last_token_string char (token (last_token).string_size) based (token (last_token).string_ptr); if stmt_type = on_statement then do; last_token = first_token + 1; call condition_name (last_token); do while (token (last_token).type = comma); last_token = last_token + 1; call condition_name (last_token); end; if token (last_token).type = identifier then if last_token_string = "snap" then if is_snap (last_token) then last_token = last_token + 1; last_token = last_token - 1; end; else if stmt_type = if_statement then do; last_token = first_token; call find_then (first_token, last_token); if token (last_token).type ^= identifier & token (last_token).type ^= percent then call error (3, "Missing ""then"" in if statement.", first_token); if token (last_token).type = percent | token (last_token).type = no_token then last_token = last_token - 1; end; else if stmt_type = percent_if_statement | stmt_type = percent_elseif_statement then begin; declare found_percent_then bit (1) aligned; do last_token = first_token + 1 by 1 while (^is_end_of_statement (token (last_token).type)); end; if token (last_token).type = percent then found_percent_then = last_token_string = "%then"; else found_percent_then = "0"b; if ^found_percent_then then do; call error (3, "Missing ""%then"" in %if or %elseif macro.", first_token); if token (last_token).type ^= semi_colon then last_token = last_token - 1; end; end; else if stmt_type = else_clause | stmt_type = percent_else_statement | stmt_type = percent_endif_statement then last_token = first_token; else do last_token = first_token by 1 while (token (last_token).type ^= semi_colon & token (last_token + 1).type ^= percent & token (last_token + 1).type ^= no_token); end; return; condition_name: procedure (tokenx); declare tokenx fixed binary; /* (Updated) current token position */ if token (tokenx).type = identifier then do; tokenx = tokenx + 1; if token (tokenx).type = left_parn then begin; declare tx fixed binary; tx = tokenx; call skip_parens (tx); if token (tx).type ^= colon then tokenx = tx; end; end; else if token (last_token).type ^= percent then call error (3, "Missing identifier in condition name.", tokenx); end condition_name; is_snap: procedure (snap_token) returns (bit (1) aligned); declare snap_token fixed binary; /* (Input) token containing "snap" */ declare tokenx fixed binary; tokenx = snap_token + 1; if token (tokenx).type = identifier | token (tokenx).type = semi_colon then return ("1"b); if token (tokenx).type ^= left_parn then return ("0"b); call skip_parens (tokenx); return (token (tokenx).type = colon); end is_snap; end find_end_of_statement; fix_up_tokens: procedure (stmt_type, first_token, last_token); declare stmt_type fixed binary (8); /* (Input) type of the current statement */ declare first_token fixed binary; /* (Input) first token of the statement */ declare last_token fixed binary; /* (Input) last token of the statement */ declare tokenx fixed binary; declare paren_depth fixed binary; declare skip_assignment bit (1) aligned; declare tokenx_token_string char (token (tokenx).string_size) based (token (tokenx).string_ptr); if stmt_type = if_statement then do; skip_assignment = "0"b; token (first_token).type = keyword_token; if token (last_token).type = identifier then token (last_token).type = keyword_token; end; else if stmt_type = assignment_statement then skip_assignment = "1"b; else if stmt_type = do_statement then do; tokenx = first_token + 1; if tokenx >= last_token then skip_assignment = "0"b; /* */ else do; skip_assignment = "1"b; if token (tokenx).type = identifier then if tokenx_token_string = "while" & token (tokenx + 1).type = left_parn then do; tokenx = tokenx + 1; call skip_parens (tokenx); if tokenx >= last_token then skip_assignment = "0"b; /* */ end; if skip_assignment /* */ then do tokenx = tokenx + 1 to last_token - 1; if token (tokenx).type = identifier then if tokenx_token_string = "while" | tokenx_token_string = "to" | tokenx_token_string = "by" | tokenx_token_string = "repeat" then if could_end_an_expression (token (tokenx - 1) .type) then token (tokenx) .type = keyword_token ; else ; else ; else if token (tokenx).type = left_parn then do; call skip_parens (tokenx); tokenx = tokenx - 1; end; end; end; end; else if stmt_type = percent_replace_statement then do; tokenx = first_token + 2; if tokenx <= last_token then if token (tokenx).type = identifier then if tokenx_token_string = "by" then token (tokenx).type = keyword_token; end; else if stmt_type = percent_set_statement | stmt_type = percent_default_statement then do; tokenx = first_token + 2; if tokenx <= last_token then if token (tokenx).type = identifier then if tokenx_token_string = "to" then token (tokenx).type = keyword_token; end; else skip_assignment = "0"b; paren_depth = 0; do tokenx = first_token to last_token; if token (tokenx).type = left_parn then paren_depth = paren_depth + 1; else if token (tokenx).type = right_parn then paren_depth = paren_depth - 1; else if token (tokenx).type = assignment then if paren_depth = 0 & skip_assignment then skip_assignment = "0"b; else token (tokenx).type = eq; else if token (tokenx).type = comma & stmt_type = assignment_statement & skip_assignment & paren_depth = 0 then token (tokenx).type = target_comma; else if token (tokenx).type = percent & length (tokenx_token_string) > length ("%") then token (tokenx).type = keyword_token; else if token (tokenx).type = plus | token (tokenx).type = minus then if ^could_end_an_expression (token (tokenx - 1).type) then if token (tokenx).type = minus then token (tokenx).type = prefix_minus; else token (tokenx).type = prefix_plus; end; end fix_up_tokens; find_then: procedure (first_token, tokenx); declare first_token fixed binary; /* (Input) first token of the statement */ declare tokenx fixed binary; /* (Updated) current token on input, then token or end of statement on output */ declare tokenx_token_string char (token (tokenx).string_size) based (token (tokenx).string_ptr); do tokenx = tokenx + 1 by 1 while (^is_end_of_statement (token (tokenx).type)); if token (tokenx).type = identifier then if tokenx_token_string = "then" then if could_end_an_expression (token (tokenx - 1) .type) & first_token < tokenx - 1 then return; else ; else ; else if token (tokenx).type = left_parn then do; call skip_parens (tokenx); tokenx = tokenx - 1; end; end; end find_then; skip_parens: procedure (tokenx); declare tokenx fixed binary; /* (Updated) on input, index of left_parn token, on output, index of end of statement token or token after matching right_parn, whichever comes first */ declare paren_depth fixed binary; paren_depth = 1; do tokenx = tokenx + 1 by 1 while (paren_depth > 0 & ^is_end_of_statement (token (tokenx).type)) ; if token (tokenx).type = left_parn then paren_depth = paren_depth + 1; else if token (tokenx).type = right_parn then paren_depth = paren_depth - 1; end; end skip_parens; could_end_an_expression: procedure (type) returns (bit (1) aligned); declare type fixed binary (8) unaligned; /* (Input) token type which might end an expression */ return (type = identifier | type = isub | type = right_parn | min_constant_token <= type & type <= max_constant_token); end could_end_an_expression; is_end_of_statement: procedure (type) returns (bit (1) aligned); declare type fixed binary (8) unaligned; /* (Input) token type which might end a statement */ return (type = semi_colon | type = percent | type = no_token); end is_end_of_statement; statement_subtype: procedure (stmt_type, first_token, last_token) returns (fixed binary (8)); declare stmt_type fixed binary (8); /* (Input) type of the statement */ declare first_token fixed binary; /* (Input) first token of the statement */ declare last_token fixed binary; /* (Input) last token of the statement */ if stmt_type = do_statement then if token (last_token).type = semi_colon & last_token = first_token + 1 then return (subtype_noniterative_do); return (subtype_none); end statement_subtype; end type_one_statement; /* Make a stmt entry. */ make_stmt: procedure (type, subtype, start, end); declare type fixed binary (8); /* (Input) statement type */ declare subtype fixed binary (8); /* (Input) statement subtype */ declare start fixed binary; /* (Input) first token of statement */ declare end fixed binary; /* (Input) last token of statement */ if stmtx >= hbound (stmt, 1) then call error (4, "Too many statements.", start); stmtx = stmtx + 1; unspec (stmt (stmtx)) = ""b; stmt (stmtx).type = type; stmt (stmtx).subtype = subtype; stmt (stmtx).start = start; stmt (stmtx).end = end; end make_stmt; /* Print an error message. */ error: procedure (severity, error_string, tokenx); declare severity fixed binary (35); /* (Input) severity of the error */ declare error_string char (*); /* (Input) error message */ declare tokenx fixed binary; /* (Input) token on which error occurred */ call format_pl1_error_ (temp_segs (*), severity, error_string, (token (tokenx).string_ptr)); if severity >= 4 then goto unrecoverable_error; end error; end format_pl1_stmt_type_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- 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