pl1_macro.pl1 10/09/89 0906.2rew 10/09/89 0900.0 181485 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-10-02,Blackmore), approve(89-10-02,MCR8138), audit(89-10-03,Vu), install(89-10-09,MR12.3-1087): Make consistent with 'pl1_macro_lex_' in use of 'translator_temp_' for area management. END HISTORY COMMENTS */ /* format: style2 */ pl1_macro: pmac: procedure; /* Free standing command to macro_process a pl1 segment: 1. Usual command line scan. 2. set up temp_seg_3 for call to pl1_lex_ 3. ... 4. Produce an XREF listing, if requested. 5. Clean-up pl1_macro. 6. Produce the output segment. 7. Usual cleanup. Written 30 Nov 79 by Marshall Presser Modified: The first half of 1981, ending July 28, to make it work and for auditing, MEP */ /* 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 list bit (1), 2 pd bit (1), 2 print bit (1), 2 target bit (1), 2 version bit (1); declare call_length fixed binary (21); declare call_ptr pointer; declare cannon_name char (32); declare clargx fixed binary; declare code fixed binary (35); declare data_type fixed binary (8) unsigned; declare in_dname char (168); declare in_ename char (32); declare in_seg_ptr pointer; declare in_seg_length fixed binary (21); declare language_suffix char (16) varying; declare n_chars_left fixed binary (2); declare n_words fixed binary (19); declare needs_cleanup bit (1); declare num_of_clargs fixed binary (17); declare num_of_params fixed binary (17); declare out_dname char (168); declare out_ename char (32); declare out_seg_ptr pointer; declare out_seg_length fixed binary (21); declare output_length fixed binary (21); declare output_ptr pointer; declare real_seg_name character (32) varying; declare source_length fixed binary (21); declare source_ptr pointer; declare target_length fixed binary (21); declare target_ptr pointer; declare target_value fixed binary (17); declare temp_target char (32); declare trans_temp_ptr pointer; /* based */ declare arg_string char (arg_length) based (arg_ptr); declare call_string char (call_length) based (call_ptr); declare in_seg char (in_seg_length) based (in_seg_ptr); declare out_seg char (out_seg_length) based (out_seg_ptr); declare result_string char (output_length) based (output_ptr); declare target_string char (target_length) based (target_ptr); /* builtin */ declare (addr, baseno, divide, index, low, length, mod, null, reverse, rtrim, search, string, substr, verify) builtin; /* condition */ declare cleanup condition; /* internal static */ declare MINUS_SIGN char (1) internal static options (constant) initial ("-"); declare suffix char (4) internal static options (constant) initial ("pmac"); /* external static */ declare ( error_table_$badopt, error_table_$inconsistent, error_table_$noarg ) fixed binary (35) external static; declare iox_$user_output pointer external static; /* entry */ declare com_err_ entry options (variable); declare com_err_$suppress_name entry options (variable); declare cu_$arg_count entry (fixed bin, fixed bin (35)); declare cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35)); declare cu_$cp entry (pointer, fixed binary (21), fixed binary (35)); declare expand_pathname_ entry (char (*), char (*), char (*), fixed binary (35)); declare expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); declare get_pdir_ entry returns (char (168)); declare get_system_free_area_ entry () returns (pointer); 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 hcs_$set_bc_seg entry (pointer, fixed binary (24), fixed binary (35)); declare hcs_$terminate_noname entry (pointer, fixed binary (35)); declare hcs_$truncate_seg entry (pointer, fixed binary (19), fixed binary (35)); declare ioa_ entry options (variable); declare iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35)); declare pathname_ entry (char (*), char (*)) returns (char (168)); declare release_temp_segments_ entry (char (*), (*) pointer, fixed binary (35)); declare translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)); declare translator_temp_$release_all_segments entry (ptr, fixed bin (35)); %include pl1_macro_lex_dcls; /* program */ source_ptr = null; output_ptr = null; temp_segs (*) = null; trans_temp_ptr = null; call_ptr = null; call_length = 0; pl1_macro_severity_ = 5; string (ca) = ""b; ca.version = "1"b; needs_cleanup = "0"b; num_of_clargs = 0; num_of_params = 0; on cleanup call macro_cleanup; call translator_temp_$get_segment (command, trans_temp_ptr, code); if code ^= 0 then do; call com_err_ (code, command, "Getting area segment in process directory."); call macro_cleanup; return; 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 macro_cleanup; return; end; output_ptr = temp_segs (2); 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); call macro_cleanup; return; end; if arg_string = "" then ; else if arg_string = "-print" | arg_string = "-pr" then ca.print = "1"b; else if arg_string = "-process_dir" | arg_string = "-pd" then ca.pd = "1"b; else if arg_string = "-version" | arg_string = "-ver" then ca.version = "1"b; else if arg_string = "-no_version" | arg_string = "-nver" then ca.version = "0"b; else if arg_string = "-list" | arg_string = "-ls" then ca.list = "1"b; else if arg_string = "-target" | arg_string = "-tgt" then do; ca.target = "1"b; argx = argx + 1; if argx > arg_count then do; call com_err_ (error_table_$noarg, command, "Missing target string after -target."); call macro_cleanup; return; end; call cu_$arg_ptr (argx, target_ptr, target_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); call macro_cleanup; return; end; else do; temp_target = target_string; call system_type_ (temp_target, cannon_name, target_value, code); if code ^= 0 then do; call com_err_ (code, command, "Invalid target string: ^a", target_string); call macro_cleanup; return; end; else do; temp_seg_3.target_value = target_value; end; end; end; else if arg_string = "-call" then do; argx = argx + 1; if argx > arg_count then do; call com_err_ (error_table_$noarg, command, "Missing call string after -call."); call macro_cleanup; return; end; call cu_$arg_ptr (argx, call_ptr, call_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); call macro_cleanup; return; end; end; else if arg_string = "-parameter" | arg_string = "-pm" then do; argx = argx + 1; num_of_params = num_of_params + 1; if num_of_params >= 65 then do; call com_err_ (0, command, "No more than 64 parameters permitted."); call macro_cleanup; return; end; if argx + 1 > arg_count then do; call com_err_ (error_table_$noarg, command, "Missing arguments after -pm."); call macro_cleanup; 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); call macro_cleanup; return; end; else do; data_type = get_data_type (arg_string); if data_type ^= identifier then do; call com_err_ (0, command, "The first arg in a parameter pair must be an identifier: ^a", arg_string); call macro_cleanup; return; end; else do; temp_seg_3.cl_params (num_of_params).name.string_size = arg_length; temp_seg_3.cl_params (num_of_params).name.string_ptr = arg_ptr; end; argx = argx + 1; call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "argument ^d.", argx); call macro_cleanup; return; end; data_type = get_data_type (arg_string); if data_type = no_token then do; call com_err_ (0, command, "Wrong data type in command line arg: ^a", arg_string); call macro_cleanup; return; end; else do; temp_seg_3.cl_params (num_of_params).value.string_ptr = arg_ptr; temp_seg_3.cl_params (num_of_params).value.string_size = arg_length; temp_seg_3.cl_params (num_of_params).value.type = data_type; temp_seg_3.cl_params (num_of_params).value.created = "0"b; end; end; end; else if arg_string = "-arguments" | arg_string = "-ag" then do; argx = argx + 1; if argx > arg_count then do; call com_err_ (error_table_$noarg, command, "Missing arguments after -ag."); call macro_cleanup; return; end; num_of_clargs = arg_count - argx + 1; do clargx = 1 to num_of_clargs; call cu_$arg_ptr (argx, arg_ptr, arg_length, code); if code ^= 0 then do; call com_err_ (code, command, "Argument ^d.", argx); call macro_cleanup; return; end; else do; temp_seg_3.cl_args (clargx).string_ptr = arg_ptr; temp_seg_3.cl_args (clargx).string_size = arg_length; end; argx = argx + 1; if argx >= 65 then do; call com_err_ (0, command, "No more than 64 cl_args permitted."); call macro_cleanup; return; end; end; end; else if index (arg_string, "-") = 1 then do; call com_err_ (error_table_$badopt, command, "^a", arg_string); call macro_cleanup; return; end; else do; argument_no = argument_no + 1; if argument_no = 1 then do; in_seg_ptr = arg_ptr; in_seg_length = arg_length; end; else if argument_no = 2 then do; out_seg_ptr = arg_ptr; out_seg_length = arg_length; end; end; end; if argument_no = 0 | argument_no > 2 then do; call com_err_$suppress_name (0, command, "Usage: ^a in_path {out_path} {-control_args}", command); call macro_cleanup; return; end; if ca.pd & argument_no > 1 then do; call com_err_ (error_table_$inconsistent, command, "The -pd control argument is incompatible with an output path name."); call macro_cleanup; return; end; if ca.print & argument_no > 1 then do; call com_err_ (error_table_$inconsistent, command, "The -pr control argument is incompatible with an output path name."); call macro_cleanup; return; end; if ca.print & ca.pd then do; call com_err_ (error_table_$inconsistent, command, "The -pr and -pd control arguments are incompatible."); call macro_cleanup; return; end; call get_input_segment (code); if code ^= 0 then do; call macro_cleanup; return; end; if ca.list then call ioa_ ("List not yet implemented."); if ^ca.print then do; if argument_no = 1 /* Should we use default output ? */ then do; if ca.pd then out_dname = get_pdir_ (); else out_dname = in_dname; out_ename = real_seg_name; end; else do; /* second pathname given */ call expand_pathname_ (out_seg, out_dname, out_ename, code); if code ^= 0 then do; call com_err_ (code, command, "^a", out_seg); call macro_cleanup; return; end; end; call hcs_$make_seg (out_dname, out_ename, "", 1010b, output_ptr, code); if output_ptr = null then do; call com_err_ (code, command, "^a", pathname_ (out_dname, out_ename)); call macro_cleanup; return; end; if baseno (output_ptr) = baseno (source_ptr) /* same source as output not on */ then do; call com_err_ (0, command, "The source segment and the output segment are the same. No output produced."); call macro_cleanup; return; end; end; temp_seg_3.source_ptr = source_ptr; temp_seg_3.source_length = source_length; temp_seg_3.output_length = 4 * sys_info$max_seg_size; temp_seg_3.flags.list = ca.list; temp_seg_3.area_ptr = trans_temp_ptr; temp_seg_3.number_of_clargs = num_of_clargs; temp_seg_3.number_of_params = num_of_params; temp_seg_3.constant_base = null (); temp_seg_3.variable_base = null (); if ^ca.target then temp_seg_3.target_value = none; if ^valid_penultimate_suffix (language_suffix) then call com_err_ (0, command, "Warning: ^a an unrecognized penultimate suffix. PL/I lex rules used.", language_suffix); if ca.version then call ioa_ ("^a ^a", command, macro_version); pl1_macro_severity_ = 0; needs_cleanup = "1"b; call pl1_macro_lex_ (temp_segs, code); needs_cleanup = "0"b; if code ^= 0 then call com_err_ (0, command, "Errors in macro processing; output segment may be suspect."); /* Copy the macro processed program over to the output segment */ output_length = temp_seg_3.output_length; if ca.print then do; call iox_$put_chars (iox_$user_output, temp_segs (2), output_length, code); if code ^= 0 then do; call com_err_ (code, command); call macro_cleanup; return; end; end; else do; substr (result_string, 1, output_length) = substr (temp_segs (2) -> output_string, 1, output_length); n_chars_left = mod (4 - output_length, 4); substr (result_string, output_length + 1, n_chars_left) = low (n_chars_left); n_words = divide (output_length + 3, 4, 19); call hcs_$truncate_seg (output_ptr, n_words, code); if code ^= 0 then do; pl1_macro_severity_ = 5; call com_err_ (code, command, "Unable to truncate ^a to ^d words.", pathname_ (out_dname, out_ename), n_words); end; bit_count = 9 * output_length; call hcs_$set_bc_seg (output_ptr, bit_count, code); if code ^= 0 then do; pl1_macro_severity_ = 5; call com_err_ (code, command, "Unable to set bit count of ^a to ^d.", pathname_ (out_dname, out_ename), bit_count); end; end; if call_ptr ^= null & pl1_macro_severity_ <= 1 then begin; declare command_line character (call_length + 169); command_line = call_string || " " || pathname_ (out_dname, out_ename); call cu_$cp (addr (command_line), length (command_line), code); end; call macro_cleanup; return; get_data_type: procedure (chars) returns (fixed binary (8) unsigned); declare chars character (*); declare ch_len fixed binary (24); /* scan the character string: if all digits , then data_type = dec_integer else if begins and end with a QUOTE, then char_string else if begins with a QUOTE and ends with QUOTE b and everythin inbetween is 1 or o then bit_string else if begins with an alphabertic and others are identifier chars, then identifier else invalid data type */ ch_len = length (chars); if ch_len = 0 then return (no_token); if verify (chars, numerals) = 0 then return (dec_integer); else if substr (chars, 1, 1) = QUOTE then do; if ch_len = 1 then return (no_token); else if substr (chars, ch_len, 1) = QUOTE then return (char_string); else if substr (chars, ch_len, 1) = "b" & ch_len > 2 & substr (chars, ch_len - 1, 1) = QUOTE & verify (substr (chars, 2, ch_len - 3), zero_one) = 0 then return (bit_string); else return (no_token); end; else if search (chars, alphabetics) = 1 & verify (chars, identifier_chars) = 0 then return (identifier); else if substr (chars, 1, 1) = MINUS_SIGN then do; if ch_len = 1 then return (no_token); else if verify (substr (chars, 2), numerals) = 0 then return (dec_integer); else return (no_token); end; else return (no_token); end get_data_type; get_input_segment: procedure (code); declare code fixed binary (35); /* (Output) standard status code */ call expand_pathname_$add_suffix (in_seg, suffix, in_dname, in_ename, code); if code ^= 0 then do; call com_err_ (code, command, "^a", in_seg); return; end; /* trim off the ".macro" to get the segments REAL name. */ real_seg_name = substr (in_ename, 1, length (rtrim (in_ename)) - length (suffix) - 1); if number_of_components (real_seg_name) > 1 then language_suffix = get_last_component (real_seg_name); else language_suffix = ""; call hcs_$initiate_count (in_dname, in_ename, "", bit_count, 0, source_ptr, code); if source_ptr ^= null then do; code = 0; source_length = divide (bit_count + 8, 9, 21); return; end; else do; call com_err_ (code, command, "^a", pathname_ (in_dname, in_ename)); return; end; return; end get_input_segment; number_of_components: procedure (seg_name) returns (fixed binary); declare seg_name character (*) varying; declare (indx, count, nex) fixed binary; count = 0; indx = 1; do while (indx < length (seg_name)); nex = search (substr (seg_name, indx), "."); if nex = 0 then nex = length (seg_name); indx = indx + nex; count = count + 1; end; return (count); end number_of_components; get_last_component: procedure (seg_name) returns (character (*) varying); declare seg_name char (*) varying; declare indx fixed binary; indx = search (reverse (seg_name), "."); return (substr (seg_name, length (seg_name) - indx + 2)); end get_last_component; valid_penultimate_suffix: procedure (suffix_chars) returns (bit (1) aligned); declare suffix_chars char (*) varying; return (suffix_chars = "pl1" | suffix_chars = "cds" | suffix_chars = "rd"); end valid_penultimate_suffix; /* Release temporary storage and terminate segments. */ macro_cleanup: procedure; if source_ptr ^= null then do; call hcs_$terminate_noname (source_ptr, code); source_ptr = null; end; if (output_ptr ^= temp_segs (2) & output_ptr ^= null) then do; call hcs_$terminate_noname (output_ptr, code); output_ptr = null; end; if needs_cleanup then call pl1_macro_lex_$cleanup (temp_segs); if temp_segs (1) ^= null then call release_temp_segments_ (command, temp_segs (*), code); temp_segs (*) = null; call translator_temp_$release_all_segments (trans_temp_ptr, code); trans_temp_ptr = null; end macro_cleanup; end pl1_macro;  pl1_macro_error_.pl1 12/01/87 1559.5r w 12/01/87 1554.3 23616 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ pl1_macro_error_: procedure (P_error_severity, P_error_string, P_source_ptr, P_source_index, P_source_length); declare P_error_severity fixed binary (35); /* (Input) error_severity of the error */ declare P_error_string char (*); /* (Input) error message */ declare P_source_ptr pointer; /* (Input) pointer to the source */ declare P_source_index fixed binary (21); /* INPUT: char index where error occured */ declare P_source_length fixed binary (21); /* INPUT: length in chars of source segment */ /* automatic */ declare line_length fixed binary (21); declare line_number fixed binary (21); declare line_start fixed binary (21); declare loop bit (1); /* based */ declare source_string char (P_source_length) based (P_source_ptr); /* builtin */ declare index builtin; declare length builtin; declare max builtin; declare null builtin; declare substr builtin; /* internal static */ declare NL char (1) internal static options (constant) initial (" "); /* entry */ declare ioa_ entry options (variable); %include pl1_macro_lex_dcls; /* program */ pl1_macro_severity_ = max (P_error_severity, pl1_macro_severity_); line_number = 0; /* find the line in the source, if there is one */ if P_source_ptr ^= null () then do; 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 <= P_source_index & line_length > 0; if line_length = 0 then line_length = length (substr (source_string, line_start)) + 1; end; end; /* Print the error message. */ call ioa_ ("^/^[WARNING^s^;SEVERITY ^d ERROR^]^[^s^; ON LINE ^d^]", P_error_severity = 1, P_error_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 pl1_macro_error_;  pl1_macro_lex_.pl1 10/09/89 0906.2rew 10/09/89 0900.0 717282 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-05-06,Huen), approve(87-05-06,MCR7675), audit(87-05-11,RWaters), install(87-12-01,MR12.2-1005): Fix PL/1 bug 2163 : Speeding up the macro processing. END HISTORY COMMENTS */ /* format: style2 */ /* This is the lexical analysis program for the pl1_macro command. The primary responsibilities of this program are: 1. Break the source program into tokens. 2. Perform whatever substitution need be done at stand_alone time. 3. Create the output segment. Written 771105 by PG; from "lex" in the Multics PL/I compiler. Modified 771226 by PG to save comments and vertical white space as token trailers. Modified November 1978 by Monte Davidoff. Stolen and modified Nov 21 80 by Marshall Presser Modified May 1987 by Susanna Huen. */ pl1_macro_lex_: procedure (P_temp_segs, code); declare P_temp_segs (*) pointer; /* INPUT: temporary segment pointers */ declare code fixed binary (35); /* OUTPUT: status code */ /* automatic */ declare FALSE_token fixed binary; /* index of a "0"b token */ declare TRUE_token fixed binary; /* index of a "1"b token */ declare action_index fixed binary; /* index of action to execute */ declare alias_id fixed binary; /* for replacement tokens, the token to which it resolves */ declare current_char char (1); /* character that stopped the scan, char we are checking */ declare error_message char (256) varying;/* used as a temp to avoid stack extension in call */ declare file_number fixed binary (8); /* file number of seg were lexing */ declare first_result fixed binary; /* first replacement token in expansion */ declare i fixed binary; declare last_result fixed binary; /* last token in expansion of macro */ declare last_token fixed binary; /* last token in macro consturct being interpreted */ declare line_number fixed binary (14); /* line in source from which were lexing */ declare loop bit (1) aligned; /* loop control variable */ declare macro_depth fixed binary; /* depth of macro stack */ declare macro_ptr pointer; /* -> macro_stack for current source_segment */ declare nested_if_level fixed binary; /* number of %if's on the stack */ declare next_char_to_print fixed binary (21); /* next char to print from current source */ declare next_free_token fixed binary; /* when finishing macro, where to plunk results */ declare number_of_clargs fixed binary; /* number of command line args */ declare number_of_params fixed binary; /* number of command line parameters */ declare output_index fixed binary (21); /* current length (and index) of computed output */ declare output_length fixed binary (21); /* length of output segment */ declare pct_type fixed binary (5) unsigned; declare reinterpret bit (1); /* macro needs reintretreting of result */ declare replacement_token_index fixed binary; /* next free token for replacment identifiers */ declare result_first fixed binary; /* first token of result of parsing macros */ 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_number fixed binary; /* number of source segments scanned */ declare source_ptr pointer; /* pointer to base of source segment */ declare source_type fixed binary (35); /* type of input being scanned */ declare string_length fixed binary (21); /* number of characters in dequoted string */ declare target_error bit (1); /* "1"b iff %target used without -target control arg */ declare target_value fixed binary (17); /* value of %target to use */ declare temp_token char (256) var; /* used as a temp to avoid stack extension in call */ declare terminator_type fixed binary; /* how macro construct is terminated */ declare token_index fixed binary; /* index into current macro_construct */ declare token_length fixed binary (21); /* length of token in characters */ declare token_ptr pointer; /* pointer to char string of token */ declare token_start fixed binary (21); /* index of first character of current token */ declare token_type fixed binary (8) unsigned; /* type of current token */ declare tokenx fixed binary; /* index into token */ declare var_id pointer; /* id of variable, used in altering properties */ declare var_name char (256) varying;/* name of variable */ declare var_type fixed binary; /* type of statement in which variable declared */ /*format: off */ declare tentative_token_type (0:128) fixed binary (8) unsigned 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 */ /* format: on */ /* Pushdown stack for nested include files and macros */ declare 1 file_macro_stack (0:64) aligned based (temp_seg_3.file_stack_ptr), 2 source_type fixed binary (35), /* either macro or source */ 2 file aligned, 3 source_ptr ptr, /* ptr to base of source segment */ 3 source_index fixed bin (21), /* index (in chars) of lexical scan */ 3 source_length fixed bin (21), /* length (in chars) of source segment */ 3 line_number fixed bin (14), /* line number in source segment */ 3 file_number fixed bin (8), /* file number of source segment */ 3 macro_ptr pointer, /* -> macro_stack for this source seg */ 3 macro_depth fixed binary, /* depth of macro_stack */ 3 nested_if_level fixed binary, /* nesting level of %if's */ 3 next_char_to_print fixed binary (21), /* index of next character to print */ 2 macro aligned, 3 token_index fixed binary, /* index (by token number) of in scan */ 3 last_token fixed binary, /* position (in tokens) of last token */ 3 first_result fixed binary, /* first token in result string */ 3 last_result fixed binary, /* last token in result */ 3 last_printed fixed binary; /* when applicable, last char printed */ declare 1 macro_stack (64) aligned based (macro_ptr), /* per source seg stack */ 2 type fixed binary, /* kind of token string */ 2 token_index fixed binary, /* first token in string */ 2 last_token fixed binary, /* last token in string */ 2 first_result fixed binary, /* first token in result string */ 2 last_result fixed binary, /* last token in result */ 2 else_seen bit (1); /* for if-types, if an %else has been seen */ dcl pl1_macro_hash_table_ptr ptr; declare 1 hash_table_structure aligned based (pl1_macro_hash_table_ptr), 2 hash_table (0:630) ptr unaligned; /* based */ declare based_chars char (256) 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 (token_index).string_size) based (token (token_index).string_ptr); /* builtin */ declare (addr, bin, binary, bit, char, fixed, divide, hbound, index, lbound, length, ltrim, max, min, null, rank, rtrim, substr, unspec, verify) builtin; /* entry */ declare char_offset_ entry (pointer) returns (fixed binary (21)); declare find_include_file_$initiate_count entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35)); declare com_err_ entry () options (variable); declare hcs_$terminate_noname entry (ptr, fixed bin (35)); declare ioa_ entry () options (variable); /* external static */ declare error_table_$translation_failed fixed bin (35) ext static; /* internal static */ /* format: off */ declare action_table (0:128) fixed binary internal static options (constant) initial ( (9) 9, /* 000-010 ctl chars */ 1, /* 011 HT */ 18, /* 012 NL */ (2) 8, /* 013-014 VT NP */ (19) 9, /* 015-037 ctl chars */ 1, /* 040 SP */ 9, /* 041 ! */ 2, /* 042 " */ 9, /* 043 # */ 9, /* 044 $ */ 16, /* 045 % */ 4, /* 046 & */ 9, /* 047 ' */ (2) 4, /* 050-051 ( ) */ 10, /* 052 * */ (2) 4, /* 053-054 + , */ 11, /* 055 - */ 6, /* 056 . */ 5, /* 057 / */ (10) 7, /* 060-071 0 - 9 */ 4, /* 072 : */ 17, /* 073 ; */ 12, /* 074 < */ 4, /* 075 = */ 13, /* 076 > */ (2) 9, /* 077-100 ? @ */ (26) 3, /* 101-132 A - Z */ (3) 9, /* 133-135 [ \ ] */ 14, /* 136 ^ */ (2) 9, /* 137-140 _ ` */ (26) 3, /* 141-172 a - z */ 9, /* 173 { */ 15, /* 174 | */ (3) 9, /* 175-177 } ~ PAD */ 9); /* >177 non-ASCII */ /* format: on */ declare digits char (10) internal static options (constant) initial ("0123456789"); declare identifier_characters char (64) internal static options (constant) initial ("$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"); declare source_list_length fixed binary internal static options (constant) initial (255); declare ASCII_SEGMENT fixed binary internal static options (constant) initial (1); declare MACRO_CONSTRUCT fixed binary internal static options (constant) initial (2); declare FALSE bit (1) aligned internal static options (constant) initial ("0"b); declare TRUE bit (1) aligned internal static options (constant) initial ("1"b); declare HT_SP char (2) internal static options (constant) initial (" "); declare VT_NP char (3) internal static options (constant) initial (" "); %include pl1_macro_lex_dcls; /* program */ code = 0; temp_segs (*) = P_temp_segs (*); output_index = 0; tokenx = 0; replacement_token_index = hbound (token, 1); source_number = 0; temp_seg_3.source_depth = -1; file_number = 0; line_number = 1; target_error = FALSE; target_value = temp_seg_3.target_value; output_length = temp_seg_3.output_length; /* Entry to initialize the hash table used by create_token. Note that the length of the hash table must be a prime number */ pl1_macro_hash_table_ptr = allocate (temp_seg_3.area_ptr, size (hash_table_structure)); hash_table (*) = null; temp_seg_3.file_stack_ptr = allocate (temp_seg_3.area_ptr, size (file_macro_stack)); number_of_params = temp_seg_3.number_of_params; number_of_clargs = temp_seg_3.number_of_clargs; /* set up replacment tokens for the command line parameters */ do i = 1 to number_of_params; var_name = substr (temp_seg_3.cl_params.name (i).string_ptr -> based_chars, 1, temp_seg_3.cl_params.name (i).string_size); call lookup (var_name, alias_id, var_type, var_id); token_type = temp_seg_3.cl_params.value (i).type; temp_token = substr (temp_seg_3.cl_params.value (i).string_ptr -> based_chars, 1, temp_seg_3.cl_params (i).value.string_size); if token_type = identifier then token_index = create_identifier_token (rtrim (temp_token)); else if token_type = char_string then token_index = create_char_token (rtrim (temp_token)); else if token_type = bit_string then token_index = create_bit_token ( bit ( dequote_string_ ( substr (temp_seg_3.cl_args (i).string_ptr -> based_chars, 1, temp_seg_3.cl_args (i).string_size - 1)))); else if token_type = dec_integer then token_index = create_arith_token (bin (temp_token, 71)); else call print_error$null (2, "Undefined token type for argument " || ltrim (char (i))); if alias_id = none then call create_variable (var_name, token_index, parameter_var); else call reset_variable_alias (var_id, token_index); end /* do loop */; /* set up the two logical tokens useful in if's */ TRUE_token = create_bit_token ("1"b); FALSE_token = create_bit_token ("0"b); /* set up is finished - enter the source segment */ call enter_source_segment (temp_seg_3.source_ptr, temp_seg_3.source_length, (file_number)); do while (temp_seg_3.source_depth >= 0); /* for source, include files and macros */ goto source_start (source_type); source_start (1): /* ASCII segments */ do while (source_index <= source_length); /* determine from 1st char, what sort of token this can be and go there */ current_char = substr (source_string, source_index, 1); token_start = source_index; source_index = source_index + 1; token_type = tentative_token_type (min (rank (current_char), hbound (tentative_token_type, 1))); pct_type = none; action_index = action_table (min (rank (current_char), hbound (action_table, 1))); goto action (action_index); action (1): /* Scan white space */ scan_index = verify (substr (source_string, source_index), HT_SP) - 1; if scan_index < 0 then source_index = source_length + 1; else source_index = source_index + scan_index; token_type = white_space_token; call make_token; goto END_ACTION; action (2): /* Scan string: current_char = '"' */ string_length = 0; /* count of number of characters in reduced string */ loop = TRUE; do while (loop); scan_index = index (substr (source_string, source_index), """"); if scan_index = 0 then do; call print_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; string_length = string_length + scan_index - 1; 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; end; if token_type = char_string then do; if string_length > max_char_string_constant then call print_error (2, "Character-string constant too long.", token_start); /* here we will insert code to count new_lines in the char_string */ end; else if string_length > max_bit_string_constant then call print_error (2, "Bit-string constant too long.", token_start); call make_token; goto check_syntax_after_constant; action (3): /* Scan identifers */ scan_index = verify (substr (source_string, source_index), identifier_characters); if scan_index = 0 then scan_index = source_length - source_index + 2; source_index = source_index + scan_index - 1; /* look up this token - and make a token setting replace_by by its alias or none. if within a macro construct, make a replacment-token, else simply put out the replacement- chars */ temp_token = substr (source_string, token_start, source_index - token_start); call lookup (temp_token, alias_id, var_type, var_id); call make_token; token (tokenx).replace_by = alias_id; /* if we're not in the middle of a macro construct and there has been replacement activity then it's a convenient time to update the output */ if alias_id ^= none & macro_depth = 0 then do; call output_chars$from_source (next_char_to_print, source_index - scan_index - 1); call output_chars$token (alias_id); next_char_to_print = source_index; end; goto END_ACTION; action (4): /* Single character tokens */ call make_token; if macro_depth > 0 /* check if in a macro construct */ then if token_type = right_parn & macro_stack (macro_depth).type = paren_macro then do; macro_stack (macro_depth).last_token = tokenx; call save_environment; call enter_macro_source; goto source_start (MACRO_CONSTRUCT); end; goto END_ACTION; action (5): /* 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 END_ACTION; end; token_type = comment_token; source_index = source_index + 1; scan_index = index (substr (source_string, source_index), "*/"); if scan_index = 0 then do; call print_error (3, "Missing ""*/"" at end of comment.", token_start); source_index = source_length + 1; goto end_of_source_reached_but_no_pending_token; end; /* here we will insert code to count the number of new_lines in a comment */ source_index = source_index + scan_index + 1; /* we only need to make comment tokens within a macro cosntruct- outside we get them for nothing as loose text */ if macro_depth > 0 then call make_token; goto END_ACTION; action (6): /* 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 END_ACTION; end; token_type = fixed_dec; call scan_past_digits; goto scan_exponent; action (7): /* 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 END_ACTION; 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 print_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 print_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 print_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 = 7 /* double quote, identifier or arithmetic constant */ then call print_error (2, "Invalid syntax after constant.", source_index); goto END_ACTION; action (8): /* Scan VT NP */ scan_index = verify (substr (source_string, source_index), VT_NP) - 1; if scan_index < 0 then source_index = source_length + 1; else source_index = source_index + scan_index; token_type = white_space_token; call make_token; goto END_ACTION; action (9): /* Invalid characters */ if rank (current_char) < 32 | 128 <= rank (current_char) then call print_error (2, "Invalid character. """ || char (bit (rank (current_char))) || """b", source_index - 1); else if current_char = "_" | current_char = "$" then call print_error (2, """" || current_char || """ may not start an identifier.", source_index - 1) ; else call print_error (2, "Invalid character. """ || current_char || """", source_index - 1); call make_token; goto END_ACTION; action (10): /* 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 END_ACTION; 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 = arrow; end; call make_token; goto END_ACTION; 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 = le; end; call make_token; goto END_ACTION; 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 = ge; end; call make_token; goto END_ACTION; action (14): /* 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 END_ACTION; action (15): /* 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 END_ACTION; action (16): /* percent seen */ /* if not in the middle of a % statement, print out all the stuff to here */ if macro_depth = 0 then do; call output_chars$from_source (next_char_to_print, source_index - 2); next_char_to_print = source_index - 1; end; /* % is not really a token, see what follows is correct keyword */ if index (alphabetics, substr (source_string, source_index, 1)) = 0 then do; call print_error (3, "Illegal character following ""%"".", token_start); source_index = source_index + 1; goto END_ACTION; end; /* for this identifier, see it is legitimate */ scan_index = verify (substr (source_string, source_index), identifier_characters); if scan_index = 0 then scan_index = source_length - source_index + 1; temp_token = substr (source_string, source_index, scan_index - 1); call validate_pct_token (temp_token, pct_type, terminator_type); source_index = source_index + scan_index - 1; goto percent_action (pct_type); percent_action (0): /* invalid identifier */ call print_error (3, "Invalid keyword: " || temp_token || " following ""%"".", token_start); goto END_ACTION; percent_action (1): /* default */ percent_action (2): /* page */ percent_action (3): /* skip */ percent_action (4): /* replace */ percent_action (5): /* error */ percent_action (6): /* isdef */ percent_action (7): /* target */ percent_action (8): /* isarg */ percent_action (14): /* INCLUDE */ percent_action (15): /* include */ percent_action (16): /* print */ percent_action (17): /* warn */ percent_action (18): /* abort */ percent_action (19): /* set */ call make_token; call bump_macro_stack (tokenx, terminator_type); goto END_ACTION; percent_action (9): /* if */ call make_token; call bump_macro_stack (tokenx, if_macro); nested_if_level = nested_if_level + 1; goto END_ACTION; percent_action (10): /* then */ percent_action (11): /* else */ percent_action (12): /* elseif */ /* this is valid iff we are within an if statement - exact syntax later */ if macro_depth > 0 then do; if macro_stack (macro_depth).type ^= if_macro then call print_error (3, "Unexpected keyword: " || temp_token || " following %.", token_start); else do; call make_token; if macro_stack (macro_depth).else_seen then do; call print_error (3, "A %" || temp_token || " has followed an %else at the same level.", token_start); call clear_macro_frame; end; macro_stack (macro_depth).else_seen = (token_type = pct_else); end; end; else call print_error (3, "Unexpected keyword: " || temp_token || " following %.", token_start); goto END_ACTION; percent_action (13): /* endif */ if macro_depth > 0 then do; if macro_stack (macro_depth).type ^= if_macro then call print_error (3, "Unexpected keyword: " || temp_token || " following %.", token_start); else do; call make_token; macro_stack (macro_depth).last_token = tokenx; nested_if_level = nested_if_level - 1; if nested_if_level = 0 then do; call save_environment; call enter_macro_source; goto source_start (MACRO_CONSTRUCT); end; else macro_depth = macro_depth - 1; end; end; else call print_error (3, "Unexpected keyword: " || temp_token || " following %.", token_start); goto END_ACTION; action (17): /* semicolon */ call make_token; if macro_depth > 0 /* check if this terminates a macro construct */ then if macro_stack (macro_depth).type = semicolon_macro then do; if nested_if_level = 0 /* a semicolon macro not embedded */ then do; macro_stack (macro_depth).last_token = tokenx; call save_environment; call enter_macro_source; goto source_start (MACRO_CONSTRUCT); end; else macro_depth = macro_depth - 1; /* terminate it -parsed in %if later */ end; goto END_ACTION; action (18): /* NL */ line_number = line_number + 1; token_type = white_space_token; call make_token; goto END_ACTION; END_ACTION: /* with case statements, we wouldn't need this */ end /* source segment while loop */; /* 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 print_error (4, "Too many tokens.", source_length); /* output all the remaining characters in the segment */ call output_chars$from_source (next_char_to_print, source_length); goto check_depth; source_start (2): /* tokens, not chars are being interpreted */ token_index = token_index - 1; /* decrement so get_next_token works */ do while (token_index < last_token); call get_next_token$retain_white_space; if pct_type = none /* not a pct token */ then do; call make_replacement_token (token_index); goto END_CASE; end; else goto parser (pct_type); parser (1): /* default */ call parse_default; goto END_CASE; parser (2): /* page */ call parse_page; goto END_CASE; parser (3): /* skip */ call parse_skip; goto END_CASE; parser (4): /* replace */ call parse_replace; goto END_CASE; parser (5): /* error */ call parse_error; goto END_CASE; parser (6): /* isdef */ call parse_isdef; goto END_CASE; parser (7): /* target */ call parse_target; goto END_CASE; parser (8): /* isarg */ call parse_isarg; goto END_CASE; parser (9): /* if */ call parse_if; goto END_CASE; parser (10): /* then */ parser (11): /* else */ parser (12): /* elseif */ parser (13): /* endif */ call print_error (3, "Unexpected keyword.", token_start); code = SYNTAX_ERROR; goto PARSE_ERROR; parser (14): /* INCLUDE */ call parse_INCLUDE; goto END_CASE; parser (15): /* include */ call parse_include; goto END_CASE; parser (16): /* print */ call parse_print; goto END_CASE; parser (17): /* warn */ call parse_warn; goto END_CASE; parser (18): /* abort */ call parse_abort; goto END_CASE; parser (19): call parse_set; goto END_CASE; END_CASE: end /* while loop */; last_result = tokenx; call finish_up_macro; goto check_depth; PARSE_ERROR: call clear_macro_frame; goto check_depth; /* having finished a source or macro, anything left on stack ? */ check_depth: call enter_previous_source; end /* source_depth loop */; /* having finished all sources or error of severity 4 */ unrecoverable_error: temp_seg_3.output_length = max (output_index, 0); call check_defaults; call macro_lex_cleanup; if code ^= 0 | target_error then code = error_table_$translation_failed; return; pl1_macro_lex_$cleanup: entry (P_temp_segs); temp_segs (*) = P_temp_segs (*); call macro_lex_cleanup; return; macro_lex_cleanup: procedure; /* terminate all include files. All other storage cleanup is now done by throwing away the allocation segments in pl1_macro by translator_temp_$release_all_segments */ declare i fixed binary; do i = 1 to temp_seg_3.source_depth; if file_macro_stack (i).source_type = ASCII_SEGMENT then do; call hcs_$terminate_noname (file_macro_stack (i).file.source_ptr, code); end; end; return; end macro_lex_cleanup; %include pl1_macro_token_procs; /* 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); if scan_index = 0 then do; source_index = source_length + 1; goto end_of_source_reached; end; source_index = source_index + scan_index - 1; end scan_past_digits; arithmetic_to_bit: procedure (type) returns (bit (4) aligned); declare type fixed binary (8) unsigned; /* INPUT: arithmetic token type */ return (bit (binary (type - min_arithmetic_token, 4), 4)); end arithmetic_to_bit; bit_to_arithmetic: procedure (bit_encoding) returns (fixed binary (8) unsigned); declare bit_encoding bit (4) aligned; /* INPUT: arithmetic toke type bit string encoding */ return (binary (bit_encoding, 4) + min_arithmetic_token); end bit_to_arithmetic; validate_pct_token: procedure (identifier, pct_type, term_type); /* a procedure to determine if the identifier following the % is valid and which token it represents */ declare identifier char (*) var; /* INPUT: char string following the % */ declare pct_type fixed binary (5) unsigned; /* OUTPUT: index of valid keyword */ declare term_type fixed binary; /* OUTPUT: terminator of this macro construct */ declare indx fixed binary; pct_type = none; term_type = none; do indx = lbound (pct_keywords, 1) to hbound (pct_keywords, 1) while (pct_type = none); if identifier = pct_keywords (indx).name then do; pct_type = pct_keywords (indx).m_index; term_type = pct_keywords (indx).terminator; end; end /* do loop */; /* if the identifier is not recognized, pct_type is set to none */ end validate_pct_token; check_defaults: procedure; /* a procedure to insure that all params have been declared in a %default statement */ declare a_ptr pointer; a_ptr = temp_seg_3.variable_base; do while (a_ptr ^= null); if a_ptr -> variable.variable_type = parameter_var then call print_error$null (2, "The parameter " || a_ptr -> variable.name || " has no default value."); a_ptr = a_ptr -> variable.next; end; end check_defaults; set_default_flag: procedure (var_id); declare var_id pointer; /* INPUT: id of variable returned by lookup */ var_id -> variable.variable_type = default_var; end set_default_flag; reset_variable_alias: procedure (var_id, alias_id); declare var_id pointer; /* INPUT: id of var as returned by lookup */ declare alias_id fixed binary; /* INPUT: index of token with new replacement value */ var_id -> variable.alias_id = alias_id; end reset_variable_alias; output_chars: procedure (charsz); declare charsz character (*) /* INPUT: chars to be output */; declare bump fixed binary (21); bump = length (charsz); call test_length; substr (output_string, output_index + 1, bump) = charsz; goto bump_length; output_chars$token: entry (token_id); declare token_id fixed binary; /*INPUT: index of token in its array */ declare based_token_string char (token (real_token).string_size) based (token (real_token).string_ptr); declare real_token fixed binary; if token (token_id).replace_by = none then real_token = token_id; else real_token = token (token_id).replace_by; bump = token (real_token).string_size; call test_length; substr (output_string, output_index + 1, bump) = based_token_string; goto bump_length; output_chars$based: entry (ch_ptr, num_of_chars); declare ch_ptr pointer /* INPUT: pointer to a based string */; declare num_of_chars fixed binary (21) /* INPUT: lenght of above */; declare based_output_string character (num_of_chars) based (ch_ptr); bump = num_of_chars; call test_length; substr (output_string, output_index + 1, bump) = based_output_string; goto bump_length; output_chars$from_source: entry (from_char, to_char); declare from_char fixed binary (21) /* INPUT: index in source indicating start */; declare to_char fixed binary (21); /*INPUT: indicating end */ bump = to_char - from_char + 1; call test_length; substr (output_string, output_index + 1, bump) = substr (source_string, from_char, bump); goto bump_length; bump_length: output_index = output_index + bump; return; test_length: procedure; if output_index + bump > output_length then call print_error (4, "Output segment overflow", source_index); end test_length; end output_chars; enter_source_segment: procedure (bv_source_ptr, bv_source_length, bv_file_number); /* Internal procedure to set some global variables each time a new source segment is entered */ /* parameters */ declare ( bv_source_ptr ptr, /* ptr to base of source segment */ bv_source_length fixed bin (21), /* length in chars of source segment */ bv_file_number fixed bin (8) /* number of new source file */ ) parameter; source_type = ASCII_SEGMENT; source_ptr = bv_source_ptr; source_length = bv_source_length; source_index = 1; token_start = 1; line_number = 1; next_char_to_print = 1; temp_seg_3.source_depth = temp_seg_3.source_depth + 1; source_number = source_number + 1; macro_ptr = allocate (temp_seg_3.area_ptr, size (macro_stack)); macro_depth = 0; nested_if_level = 0; end enter_source_segment; enter_macro_source: procedure; /* by analogy to enter_source_segment, to set global variables when entering a macro string for the 1st time */ source_type = MACRO_CONSTRUCT; token_index = macro_stack (macro_depth).token_index; last_token = macro_stack (macro_depth).last_token; next_free_token = token_index - 1; first_result = tokenx + 1; last_result = tokenx; reinterpret = FALSE; temp_seg_3.source_depth = temp_seg_3.source_depth + 1; end enter_macro_source; save_environment: procedure; /* when we are about to leave an environment prematurely, i.e. before the last character or token is seen, save our location so we can pop back in */ if temp_seg_3.source_depth > hbound (file_macro_stack, 1) then call print_error (4, "Include files and macros nested too deeply.", token_start); if source_type = ASCII_SEGMENT then do; file_macro_stack (temp_seg_3.source_depth).source_type = ASCII_SEGMENT; file_macro_stack (temp_seg_3.source_depth).file.source_ptr = source_ptr; file_macro_stack (temp_seg_3.source_depth).file.source_index = source_index; file_macro_stack (temp_seg_3.source_depth).file.source_length = source_length; file_macro_stack (temp_seg_3.source_depth).file.line_number = line_number; file_macro_stack (temp_seg_3.source_depth).file.file_number = file_number; file_macro_stack (temp_seg_3.source_depth).file.next_char_to_print = source_index; file_macro_stack (temp_seg_3.source_depth).file.macro_depth = macro_depth - 1; file_macro_stack (temp_seg_3.source_depth).file.macro_ptr = macro_ptr; file_macro_stack (temp_seg_3.source_depth).file.nested_if_level = nested_if_level; unspec (file_macro_stack (temp_seg_3.source_depth).macro) = ""b; end; else do; file_macro_stack (temp_seg_3.source_depth).source_type = MACRO_CONSTRUCT; file_macro_stack (temp_seg_3.source_depth).macro.token_index = token_index; file_macro_stack (temp_seg_3.source_depth).macro.last_token = last_token; file_macro_stack (temp_seg_3.source_depth).macro.first_result = first_result; file_macro_stack (temp_seg_3.source_depth).macro.last_result = last_result; unspec (file_macro_stack (temp_seg_3.source_depth).file) = ""b; end; return; end save_environment; enter_previous_source: procedure; /* when we have finished processing an include file or macro, this pops us back */ if source_type ^= ASCII_SEGMENT then if reinterpret then goto reinterpret_this_macro; temp_seg_3.source_depth = temp_seg_3.source_depth - 1; if temp_seg_3.source_depth < 0 then return; source_type = file_macro_stack (temp_seg_3.source_depth).source_type; if source_type = ASCII_SEGMENT /* popping to primary or include file */ then do; source_ptr = file_macro_stack (temp_seg_3.source_depth).file.source_ptr; source_index = file_macro_stack (temp_seg_3.source_depth).file.source_index; source_length = file_macro_stack (temp_seg_3.source_depth).file.source_length; line_number = file_macro_stack (temp_seg_3.source_depth).file.line_number; file_number = file_macro_stack (temp_seg_3.source_depth).file.file_number; next_char_to_print = file_macro_stack (temp_seg_3.source_depth).file.next_char_to_print; macro_ptr = file_macro_stack (temp_seg_3.source_depth).file.macro_ptr; macro_depth = file_macro_stack (temp_seg_3.source_depth).file.macro_depth; nested_if_level = file_macro_stack (temp_seg_3.source_depth).file.nested_if_level; end; else do; /* previous was a macro */ reinterpret_this_macro: token_index = file_macro_stack (temp_seg_3.source_depth).macro.token_index; last_token = file_macro_stack (temp_seg_3.source_depth).macro.last_token; first_result = file_macro_stack (temp_seg_3.source_depth).macro.first_result; last_result = file_macro_stack (temp_seg_3.source_depth).macro.last_result; reinterpret = FALSE; end; return; end enter_previous_source; /* Centralize lex error reporting. */ print_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 pl1_macro_error_ (severity, error_string, source_ptr, source_index, source_length); goto print_error_common; print_error$null: entry (severity, error_string); call pl1_macro_error_ (severity, error_string, null, 0, 0); goto print_error_common; print_error_common: if severity >= 4 then goto unrecoverable_error; end print_error; parse_if: procedure; declare logical_expected bit (1); declare conditional_true bit (1); /* syntax: %if %then [%elseif %then ]... [%else ] %endif */ call get_next_token; logical_expected = TRUE; do while (logical_expected & token_index < last_token); /* first evaluate the conditional after the %if or %elseif */ call parse_expression (result_first, code); if code ^= 0 then goto PARSE_ERROR; /* the expression must resolve to a bit_string constant */ if token (result_first).type ^= bit_string then do; call print_error (2, "Wrong data type in %if", token_start); code = SEMANTIC_ERROR; goto PARSE_ERROR; end; conditional_true = (bit_value (result_first) ^= ""b); /* next token had better be a %then */ if token_type = white_space_token then call get_next_token; if token (token_index).pct_type ^= pct_then then do; call print_error (3, "Missing keyword: %then", token_start); code = SYNTAX_ERROR; goto PARSE_ERROR; end; if conditional_true then do; /* get the tokens till the %elseif, %else, or %endif at the same level skip the rest of the %if construct */ call get_this_clause; logical_expected = FALSE; end; else do; /* conditional is false - skip then-clause if terminating keyword an %else, get the tokens - elseif it is %elseif, goto top of loop elseif it is an %endif, stop - else an error */ call skip_this_clause; if pct_type = pct_endif then logical_expected = FALSE; else if pct_type = pct_else then do; call get_this_clause; logical_expected = FALSE; end; else if pct_type ^= pct_elseif then do; call print_error (3, "Illegal syntax in a %if.", token_start); code = SYNTAX_ERROR; goto PARSE_ERROR; end; else call get_next_token; end /* conditional false */; end /* while loop */; /* if loop terminated without and %endif, an error has ooccurred */ if pct_type ^= pct_endif then do; call print_error (3, "Missing %endif.", token_start); code = SYNTAX_ERROR; goto PARSE_ERROR; end; return; skip_this_clause: procedure; declare action_type fixed binary; declare if_level fixed binary; declare terminating_keyword bit (1) aligned; declare GET_THIS_CLAUSE fixed binary internal static options (constant) initial (1); declare SKIP_THIS_CLAUSE fixed binary internal static options (constant) initial (2); declare SKIP_THE_REST fixed binary internal static options (constant) initial (3); action_type = SKIP_THIS_CLAUSE; goto common_skip; get_this_clause: entry; action_type = GET_THIS_CLAUSE; goto common_skip; common_skip: /* quit when at the same if_level after finding a relevant keyword and if skipping then clauses, stop on else at same level */ if_level = 1; do while (if_level > 0 & token_index <= last_token); call get_next_token$retain_white_space; terminating_keyword = if_level = 1 & (pct_type = pct_elseif | pct_type = pct_else | pct_type = pct_endif); if pct_type = pct_if then if_level = if_level + 1; else if pct_type = pct_endif then if_level = if_level - 1; goto what_next (action_type); what_next (1): /* GET_THIS_CLAUSE: when getting a THEN or ELSE clause, we've reached the end when we find a terminating keyword at the inital if level. if not at the end, make a replacement token. */ if terminating_keyword then action_type = SKIP_THE_REST; else call make_replacement_token (token_index); goto end_of_loop; what_next (2): /* SKIP THIS CLAUSE: skip over all the tokens until we come to a terminating_keyword at the initial if-level */ if terminating_keyword then return; else goto end_of_loop; what_next (3): /* SKIP_THE_REST: skip over all tokens till the if-level is back to ZERO */ goto end_of_loop; end_of_loop: end /* while loop */; end skip_this_clause; end parse_if; parse_target: procedure; declare alias fixed binary; declare cannon_name char (32); declare entry_type fixed binary; declare error_seen bit (1); declare not_found bit (1) aligned; declare result_token fixed binary; declare saved_token_start fixed binary (21); declare t_code fixed binary (35); declare t_value fixed binary (17); declare target_string char (256); declare var_id pointer; entry_type = pct_target; /* if %target used and no -target control arg, set the default and set as error */ if target_value = none then do; target_error = TRUE; target_value = L68_SYSTEM; call print_error (2, "%target used without use of -target control arg. L68 assumed.", token_start); end; goto common_parse; parse_isarg: entry; entry_type = pct_isarg; goto common_parse; parse_isdef: entry; entry_type = pct_isdef; goto common_parse; common_parse: error_seen = FALSE; saved_token_start = token_start; if token_index < last_token then call get_next_token; else do; call print_error (3, "Incomplete macro statement", saved_token_start); goto TARGET_ERROR; end; if token_type ^= left_parn then do; call print_error (3, "Missing left_parentheis in macro-builtin", saved_token_start); error_seen = TRUE; end; if token_index < last_token then call get_next_token; else do; call print_error (3, "Incomplete macro statement", saved_token_start); goto TARGET_ERROR; end; target_string = substr (token_ptr -> based_chars, 1, token_length); if entry_type = pct_target then do; call system_type_ (target_string, cannon_name, t_value, t_code); if t_value = target_value then result_token = TRUE_token; else result_token = FALSE_token; end; else if entry_type = pct_isarg then do; /* because the command line processor passes any char string as an arg, and the macro only looks at pl1 tokens, for "wierd" arguments, i.e. non-pl1 tokens, users must quote them to get recognized by the lexer, otherwise, the raw character string itself suffices, IF it is a SINGLE pl1 token. The curious code below occurs because dequote_string_ and system_type_ want char (*), but we would much rather use varying character strings, to kill the terminal blanks. */ if token_type = char_string then target_string = dequote_string_ (rtrim (target_string)); not_found = TRUE; do i = 1 to number_of_clargs while (not_found); not_found = (target_string ^= substr (temp_seg_3.cl_args (i).string_ptr -> based_chars, 1, temp_seg_3.cl_args (i).string_size)); end; if not_found then result_token = FALSE_token; else result_token = TRUE_token; end; else do; /* isdef */ call lookup ((target_string), alias, var_type, var_id); if alias = none then result_token = FALSE_token; else result_token = TRUE_token; end; if token_index < last_token then call get_next_token; else do; call print_error (3, "Incomplete macro statement", saved_token_start); goto TARGET_ERROR; end; if token_type ^= right_parn then do; error_seen = TRUE; call print_error (3, "Incomplete macro statement", saved_token_start); end; if error_seen then do; TARGET_ERROR: code = SYNTAX_ERROR; goto PARSE_ERROR; end; else call make_replacement_token (result_token); end parse_target; parse_replace: procedure; declare alias fixed binary; declare entry_name char (8) varying; declare equals fixed binary; declare previous_var_type fixed binary; declare t_type fixed binary; declare var_id pointer; declare var_name character (256) varying; declare var_type fixed binary; /* format: off */ declare 1 magic_words (4) aligned structure internal static options (constant), 2 statement_type character (9) varying initial ( "replace", "default", "set", "parameter"), 2 preposition character (2) initial ( "by", "to", "to", ".."); /* format: on */ /* syntax : %replace by ; %default to ; %set to ; */ var_type = replace_var; goto common_parse; parse_default: entry; var_type = default_var; goto common_parse; parse_set: entry; var_type = set_var; goto common_parse; common_parse: entry_name = magic_words (var_type).statement_type; call get_next_token; if token_type ^= identifier then do; call print_error (3, "The subject of a %" || entry_name || " must be an identifier.", token_start); code = SYNTAX_ERROR; goto PARSE_ERROR; end; var_name = token_string; call lookup (var_name, alias, previous_var_type, var_id); call get_next_token; if token_string ^= magic_words (var_type).preposition then do; call print_error (3, "Illegal syntax in a %" || entry_name, token_start); code = SYNTAX_ERROR; goto PARSE_ERROR; end; call get_next_token; call parse_expression (result_first, code); if code ^= 0 then goto PARSE_ERROR; /* this token must be copied, for in deeply nested macros, its token number is reusaed */ result_first = copy_token (result_first); if token_type = white_space_token then call get_next_token; if token_type ^= semi_colon then do; call print_error (3, "A %" || entry_name || " statement must end with a semicolon.", token_start); code = SYNTAX_ERROR; goto PARSE_ERROR; end; if alias = none /* not previously defined */ then call create_variable (var_name, result_first, var_type); else if var_type ^= previous_var_type /* already declared in a different mode */ then do; /* OKAY to appear in a different mode if previous was a parameter and this is its default statement */ if previous_var_type = parameter_var & var_type = default_var then call set_default_flag (var_id); else call print_error (3, "The variable " || var_name || " may not appear in a %" || entry_name || " after appearing in a %" || magic_words (previous_var_type).statement_type, token_start) ; end; else do; /* previously declared in the same mode */ t_type = op_mix (alias, result_first) /* check for same data type and equal value */; /* the old and new values must alwasy have the same data type, and if default or replace, the same value */ if t_type = 0 /* different types */ then do; test_redefine (0): /* different types */ call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); code = SEMANTIC_ERROR; goto PARSE_ERROR; end; equals = fixed (eq); if var_type = set_var then do; call reset_variable_alias (var_id, result_first); return; end; else goto test_redefine (t_type); test_redefine (1): /* dec_integer */ if ^compare_numbers (equals, alias, result_first) /* redefined to a different integer */ then do; call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); code = SEMANTIC_ERROR; goto PARSE_ERROR; end; return; test_redefine (2): /* bit_string */ if ^compare_bit_strings (equals, alias, result_first) then do; call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); code = SEMANTIC_ERROR; goto PARSE_ERROR; end; return; test_redefine (3): /* char_string */ if ^compare_chars (equals, alias, result_first) then do; call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); code = SEMANTIC_ERROR; goto PARSE_ERROR; end; return; test_redefine (4): /* identifier */ if ^same_identifier (alias, result_first) then do; call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); code = SEMANTIC_ERROR; goto PARSE_ERROR; end; return; end; copy_token: procedure (original_token) returns (fixed binary); declare original_token fixed binary /* token to be copied */; if replacement_token_index <= tokenx then call print_error$null (4, "Too many tokens."); token (replacement_token_index) = token (original_token); token (replacement_token_index).created = TRUE; replacement_token_index = replacement_token_index - 1; return (replacement_token_index + 1); end copy_token; %include pl1_macro_compare_procs; %include pl1_macro_dtype_procs; end parse_replace; parse_page: procedure; /* syntax: %page [()]; also for skip handled by compiler, just diagnose and parrot back in stand alone */ declare entry_type character (4); declare saved_token_index fixed binary; entry_type = "page"; goto page_skip; parse_skip: entry; entry_type = "skip"; goto page_skip; page_skip: saved_token_index = token_index; code = 0; call get_next_token; if token_type ^= semi_colon then do; if token_type ^= left_parn then code = SYNTAX_ERROR; call get_next_token; if token_type ^= dec_integer then code = SYNTAX_ERROR; call get_next_token; if token_type ^= right_parn then code = SYNTAX_ERROR; call get_next_token; if token_type ^= semi_colon then code = SYNTAX_ERROR; end; if code ^= 0 then do; call print_error (3, "Illegal syntax in %" || entry_type, token_start); goto PARSE_ERROR; end; else do i = saved_token_index to token_index; call make_replacement_token (i); end; return; end parse_page; parse_include: procedure; declare saved_token_index fixed binary; declare saved_token_start fixed binary (21); declare entry_name char (7); declare include_file_name char (32) varying; declare include_file_length fixed binary (21); declare include_file_ptr pointer; declare i fixed binary; declare bitcount fixed binary (24); entry_name = "include"; goto INCLUDE_COMMON; parse_INCLUDE: entry; entry_name = "INCLUDE"; goto INCLUDE_COMMON; INCLUDE_COMMON: saved_token_index = token_index; saved_token_start = token_start; code = 0; call get_next_token; if token_type = identifier then include_file_name = token_string; else if token_type = char_string then include_file_name = dequote_string_ (token_string); else code = SYNTAX_ERROR; call get_next_token; if token_type ^= semi_colon then code = SYNTAX_ERROR; if code ^= 0 then do; error_message = "Invalid syntax in %" || entry_name; call print_error (3, (error_message), saved_token_start); goto PARSE_ERROR; end; else if entry_name = "include" then do i = saved_token_index to token_index; call make_replacement_token (i); end; else do; /* INCLUDE */ if length (include_file_name) > 24 then do; call print_error (3, "Include file name too long.", saved_token_start); code = STORAGE_SYSTEM_ERROR; goto PARSE_ERROR; end; if file_number > source_list_length then do; call print_error (3, "Too many include files.", saved_token_start); code = IMPLEMENTATION_RESTRICTION; goto PARSE_ERROR; end; if temp_seg_3.source_depth > hbound (file_macro_stack, 1) then do; call print_error (3, "Include files and macros nested too deeply.", saved_token_start); code = IMPLEMENTATION_RESTRICTION; goto PARSE_ERROR; end; include_file_name = include_file_name || ".incl.pl1"; call find_include_file_$initiate_count (command, source_ptr, (include_file_name), bitcount, include_file_ptr, code); if include_file_ptr = null () then do; error_message = "Include file: " || include_file_name || " not found."; call print_error (3, (error_message), saved_token_start); code = STORAGE_SYSTEM_ERROR; goto PARSE_ERROR; end; else if code ^= 0 then call com_err_ (code, command, "^a", include_file_name); call save_environment; file_number = file_number + 1; include_file_length = divide (bitcount + 8, 9, 24, 0); call enter_source_segment (include_file_ptr, include_file_length, file_number); goto source_start (ASCII_SEGMENT); end; return; end parse_include; parse_error: procedure; declare entry_type fixed binary (5) unsigned; declare error_level fixed binary (35); declare error_seen bit (1) aligned; declare error_message_token fixed binary; declare saved_token_start fixed binary (21); entry_type = pct_error; error_level = 3; goto message_common; parse_warn: entry; entry_type = pct_warn; error_level = 1; goto message_common; parse_abort: entry; entry_type = pct_abort; error_level = 4; goto message_common; parse_print: entry; entry_type = pct_print; error_level = 0; goto message_common; message_common: error_seen = FALSE; saved_token_start = token_start; if token_index < last_token then call get_next_token; else do; call print_error (3, "Incomplete macro statement", saved_token_start); goto message_error; end; call parse_expression (error_message_token, code); if code ^= 0 then goto message_error; if token (error_message_token).type ^= char_string then do; call print_error (3, "Macro user messages must be character strings", saved_token_start); goto message_error; end; if token_type = white_space_token then call get_next_token; if token_type ^= semi_colon then do; call print_error (3, "Macro user messages must end in a semicolon", saved_token_start); goto message_error; end; if entry_type = pct_print then call ioa_ (char_value (error_message_token)); else call print_error$null (error_level, char_value (error_message_token)); return; message_error: code = SYNTAX_ERROR; goto PARSE_ERROR; end parse_error; %include pl1_macro_next_token; create_char_token: procedure (char_value) returns (fixed binary); declare char_value char (*); /* INPUT: the name of the identifier */ declare t_ptr pointer; declare t_type fixed binary (8) unsigned; declare chars char (256) varying; t_type = char_string; chars = char_value; goto create_common; create_identifier_token: entry (char_value) returns (fixed binary); t_type = identifier; chars = requote_string_ (char_value); goto create_common; create_bit_token: entry (b_value) returns (fixed binary); declare b_value bit (*); t_type = bit_string; chars = QUOTE || char (b_value) || QUOTE || "b" /* give it pl1 representation */; goto create_common; create_arith_token: entry (a_value) returns (fixed binary); declare a_value fixed binary (71); t_type = dec_integer; chars = ltrim (char (a_value)); goto create_common; create_common: constant_length = length (chars); if t_type = char_string & constant_length > max_char_string_constant then do; call print_error$null (2, "Character-string constant too long."); return (none); end; else if t_type = bit_string & constant_length > max_bit_string_constant then do; call print_error$null (2, "Bit-string constant too long."); return (none); end; else if t_type = identifier & constant_length > max_identifier_length then do; call print_error$null (2, "Identifier too long."); return (none); end; if replacement_token_index <= tokenx then do; call print_error$null (4, "Too many tokens."); return (none); end; t_ptr = allocate (temp_seg_3.area_ptr, size (constant)); t_ptr -> constant.next = temp_seg_3.constant_base; token (replacement_token_index).string_size, t_ptr -> constant.string_length = constant_length; token (replacement_token_index).type = t_type; t_ptr -> string_value = chars; token (replacement_token_index).string_ptr = addr (t_ptr -> constant.string_value); token (replacement_token_index).created = TRUE; token (replacement_token_index).pct_type = none; token (replacement_token_index).replace_by = none; replacement_token_index = replacement_token_index - 1; temp_seg_3.constant_base = t_ptr; return (replacement_token_index + 1); end create_char_token; %include pl1_macro_value_procs; parse_expression: procedure (result_token, code); declare result_token fixed binary; /* OUTPUT: index of token in which result is placed */ declare code fixed binary (35); /* OUTPUT: status code */ declare stack_index fixed binary; /* top of stack */ declare opindex fixed binary; /* location of operator in op_table */ declare (operand1, operand2) fixed binary; /* token offsets of the two operands */ declare result fixed binary; /* token offset of result */ declare stack (0:64) fixed binary; /* format: off */ declare precedence (0:24) fixed binary (15) internal static options (constant) initial ( (5) 0, /* illegal */ 5, /* +, plus */ 5, /* -, minus */ 6, /* *, asterisk */ 6, /* /, slash */ 7, /* **, expon */ 7, /* ^, not */ 2, /* &, and */ 1, /* |, or */ 4, /* ||, cat */ 3, /* =, eq */ 3, /* ^=, ne */ 3, /* <, lt */ 3, /* >, gt */ 3, /* <=, le */ 3, /* >=, ge */ 3, /* ^>, ngt */ 3, /* ^<, nlt */ 7, /* +, unary plus */ 7, /* -, unary minus */ 3); /* =, assignment */ /* format: on */ stack_index = 0; stack (0) = primitive (); FETCHOP: CHECKOP: if token_type = white_space_token then call get_next_token; if (token_type <= max_delimiter_token) & (token_type >= min_delimiter_token) & (token_type <= assignment) then do; /* i.e. relational and arith operator */ if token_type = not /* unary operators handled by primitive */ then do; call print_error (3, "Invalid syntax in expression", source_index); goto EXP_PARSE_FAIL; end; if stack_index ^= 0 /* check precedence is not first operator */ then do; opindex = token (stack (stack_index - 1)).type; if precedence (opindex) >= precedence (token_type) then goto UNSTACK; end; STACKOP: stack_index = stack_index + 1; stack (stack_index) = token_index; stack_index = stack_index + 1; call get_next_token; if token_index > last_token then do; call print_error (3, "Invalid syntax in expression.", source_index); goto EXP_PARSE_FAIL; end; stack (stack_index) = primitive (); goto FETCHOP; end; if stack_index = 0 then goto SUCCESS; opindex = token (stack (stack_index - 1)).type; UNSTACK: operand1 = stack (stack_index - 2); operand2 = stack (stack_index); result = evaluate (opindex, operand1, operand2); if result = none then do; call print_error (3, "Semantically incorrect expression.", source_index); goto EXP_PARSE_FAIL; end; POP: stack_index = stack_index - 2; stack (stack_index) = result; goto CHECKOP; EXP_PARSE_FAIL: result_token = none; code = -1; return; SUCCESS: result_token = stack (0); code = 0; return; primitive: procedure returns (fixed binary); /* calling conventions: token_index points to the current token, token_type been set properly. on return token_index will point the the next token (possibly white space) in the input sequence */ declare next_tk fixed binary; /* value of token returned by recursive calls */ declare saved_token_index fixed binary; /* index of token at entry */ saved_token_index = token_index; if token_type = plus /* unary plus */ then do; call get_next_token; next_tk = primitive (); if token (next_tk).type = dec_integer then return (next_tk); else do; call print_error (3, "Invalid syntax in expression.", source_index); goto PRIMITIVE_FAIL; end; end; else if token_type = minus /*unary minus */ then do; call get_next_token; next_tk = primitive (); if token (next_tk).type = dec_integer then return (create_arith_token (-arith_value (next_tk))); else do; call print_error (3, "Invalid syntax in expression.", source_index); goto PRIMITIVE_FAIL; end; end; else if token_type = not then do; call get_next_token; next_tk = primitive (); if token (next_tk).type = bit_string then return (create_bit_token (^bit_value (next_tk))); else do; call print_error (3, "Invalid syntax in expression.", source_index); goto PRIMITIVE_FAIL; end; end; else if token_type = left_parn then do; call get_next_token; call parse_expression (result, code); if code ^= 0 then goto PRIMITIVE_FAIL; if token_type = white_space_token then call get_next_token; if token_type ^= right_parn then do; call print_error (3, "Invalid syntax in expression.", source_index); goto PRIMITIVE_FAIL; end; else do; call get_next_token$retain_white_space; return (result); end; end; else if (token_type <= max_constant_token & token_type >= min_constant_token) | (token_type = identifier) then do; if token_type = identifier & token (saved_token_index).replace_by ^= none then saved_token_index = token (saved_token_index).replace_by; call get_next_token$retain_white_space; return (saved_token_index); end; else do; code = -1; call print_error (3, "Invalid syntax in expression.", source_index); return (none); end; PRIMITIVE_FAIL: goto EXP_PARSE_FAIL; end primitive; %include pl1_macro_next_token; evaluate: procedure (P_operation, P_op1, P_op2) returns (fixed binary); declare P_operation fixed binary; /* INPUT: arithemtic or logicl op */ declare (P_op1, P_op2) fixed binary; /* INPUT: the operands */ /* given an op_code and two operands, return the index of the token node created with the result stored there */ declare (fixedoverflow, overflow, zerodivide, underflow, error, stringrange) condition; declare (op1, op2, operation) fixed binary; declare temp_chars character (256); op1 = P_op1; op2 = P_op2; operation = P_operation; on fixedoverflow goto FIXEDOVERFLOW; on overflow goto OVERFLOW; on zerodivide goto ZERODIVIDE; on underflow goto UNDERFLOW; on error goto ERROR; on stringrange goto STRINGRANGE; if operation < lbound (eval_action, 1) | operation > hbound (eval_action, 1) then do; call print_error (3, "Illegal operator in expression.", source_index); return (none); end; goto eval_action (operation); eval_action (0): /* illegal op */ eval_action (1): eval_action (2): eval_action (3): eval_action (4): eval_action (10): /* unary not */ eval_action (22): /* unary plus */ eval_action (23): /* unary minus */ call print_error (3, "Illegal operator in expression.", source_index); return (none); eval_action (5): /* plus */ if both_arithmetic (op1, op2) then return (create_arith_token (arith_value (op1) + arith_value (op2))); else do; call eval_err ("+"); return (none); end; eval_action (6): /* minus */ if both_arithmetic (op1, op2) then return (create_arith_token (arith_value (op1) - arith_value (op2))); else do; call eval_err ("-"); return (none); end; eval_action (7): /* times */ if both_arithmetic (op1, op2) then return (create_arith_token (arith_value (op1) * arith_value (op2))); else do; call eval_err ("*"); return (none); end; eval_action (8): /* divide */ if both_arithmetic (op1, op2) then return (create_arith_token (arith_value (op1) / arith_value (op2))); else do; call eval_err ("/"); return (none); end; eval_action (9): /* expon */ if both_arithmetic (op1, op2) then return (create_arith_token (arith_value (op1) ** arith_value (op2))); else do; call eval_err ("**"); return (none); end; eval_action (11): /* & (and) */ if both_bit_string (op1, op2) then return (create_bit_token (bit_value (op1) & bit_value (op2))); else do; call eval_err ("&"); return (none); end; eval_action (12): /* | (or) */ if both_bit_string (op1, op2) then return (create_bit_token (bit_value (op1) | bit_value (op2))); else do; call eval_err ("|"); return (none); end; eval_action (13): /* || (concat)*/ if both_char_string (op1, op2) then do; temp_chars = requote_string_ (char_value (op1) || char_value (op2)); return (create_char_token (rtrim (temp_chars))); end; else do; call eval_err ("||"); return (none); end; eval_action (14): /* = (equals relation ) */ eval_action (15): /* ^= (not_equal) */ eval_action (16): /* < (less than) */ eval_action (17): /* > (greater than) */ eval_action (18): /* <= (lessthan or equal to ) */ eval_action (19): /* >= (greater than or equal to */ eval_action (20): /* ^> (ngt) */ eval_action (21): /* ^< (nlt) */ eval_action (24): /* assignment = */ goto operand_types (op_mix (op1, op2)); operand_types (0): /* operands of different types */ call print_error (3, "Different data types in a relational expression.", source_index); return (none); operand_types (1): /* both arithmetic */ if compare_numbers (operation, op1, op2) then return (TRUE_token); else return (FALSE_token); operand_types (2): /* both bit_string */ if compare_bit_strings (operation, op1, op2) then return (TRUE_token); else return (FALSE_token); operand_types (3): /* both character */ if compare_chars (operation, op1, op2) then return (TRUE_token); else return (FALSE_token); operand_types (4): /* both identifier */ if operation = eq | operation = assignment then do; if same_identifier (op1, op2) then return (TRUE_token); else return (FALSE_token); end; else if operation = ne then do; if same_identifier (op1, op2) then return (FALSE_token); else return (TRUE_token); end; else do; call eval_err ("current"); return (none); end; FIXEDOVERFLOW: call print_error$null (2, "Fixedoverflow condition: result undefined"); return (none); OVERFLOW: call print_error$null (2, "Overflow condition: result undefined"); return (none); ZERODIVIDE: call print_error$null (2, "Zerodivide condition: result undefined"); return (none); UNDERFLOW: call print_error$null (2, "Underflow condition: result undefined"); return (none); ERROR: call print_error$null (2, "Error condition: result undefined"); return (none); STRINGRANGE: call print_error$null (2, "Stringrange condition: result undefined"); return (none); eval_err: procedure (message_chars); declare message_chars char (*); error_message = "Illegal data types for the " || message_chars || " operation."; call print_error (3, (error_message), source_index); end eval_err; %include pl1_macro_dtype_procs; %include pl1_macro_compare_procs; end evaluate; end parse_expression; bump_macro_stack: procedure (start_tk, variety); declare start_tk fixed binary /* INPUT: first token in macro */; declare variety fixed binary /* INPUT: macro_type */; if macro_depth > hbound (macro_stack, 1) then call print_error (4, "Macros nested too deeply.", char_offset_ ((token (start_tk).string_ptr))); macro_depth = macro_depth + 1; macro_stack (macro_depth).type = variety; macro_stack (macro_depth).token_index = start_tk; macro_stack (macro_depth).last_token = 0; macro_stack (macro_depth).first_result = none; macro_stack (macro_depth).last_result = none; macro_stack (macro_depth).else_seen = FALSE; end bump_macro_stack; clear_macro_frame: procedure; tokenx = macro_stack (macro_depth).token_index; macro_depth = 0; end clear_macro_frame; finish_up_macro: procedure; declare tokn fixed binary; /* thread in replacement strings fro this macro - i.e. replace the tokens for the macro by the tokens it generates */ tokenx = next_free_token; reinterpret = FALSE; do tokn = first_result to last_result while (tokn ^= none); call make_replacement_token (tokn); reinterpret = reinterpret | needs_reinterpretation (tokn); end; if reinterpret then do; /* what is now the first-result becomes the first_token in the string to reinterpret, similarly for last_token and last_result. so, set first_result above the minimal value of last result. */ file_macro_stack (temp_seg_3.source_depth).token_index = first_result; file_macro_stack (temp_seg_3.source_depth).last_token = last_result; file_macro_stack (temp_seg_3.source_depth).first_result = tokenx + 1; file_macro_stack (temp_seg_3.source_depth).last_result = tokenx; return; end; else if macro_depth = 1 /* not imbedded */ then do; call print_token_string (first_result, last_result); end; macro_depth = macro_depth - 1; return; end finish_up_macro; print_token_string: procedure (first, last); declare (first, last) fixed binary /* first and last token to print */; declare ix fixed binary; do ix = first to last while (ix ^= none); call output_chars$token (ix); end; end print_token_string; needs_reinterpretation: procedure (tknx) returns (bit (1)); declare tknx fixed binary /* INPUT: index of token */; declare t_type fixed binary (5) unsigned; /* may need reinterpretation if a pct token but not skip page and include in stand alone mode */ t_type = token (tknx).pct_type; if t_type = none then return (FALSE); else if t_type = pct_skip | t_type = pct_page | t_type = pct_include then return (FALSE); else return (TRUE); end needs_reinterpretation; %page; create_variable: procedure (var_name, alias_token, var_type); declare var_name char (*) var; /* INPUT: name of var to be created */ declare alias_token fixed binary; /* INPUT: index of token of variable's alias */ declare var_type fixed binary; /* INPUT: mode of declaration */ /* OUTPUT: type of statement in which variable declared */ declare v_ptr pointer; /* assumed that the caller has checked that this variable name is not duplicated - use lookup for this. create a variable node for this var_name and stuff in the node the name, the token to which it refers and then chain it on the list */ /* automatic */ declare (hash_index, i, n, n_chars, n_words) fixed bin, mod_2_sum bit (36) aligned, four_chars char (4) aligned, protected bit (18) aligned, (old_q, q, p, variable_string_ptr) ptr; /* based */ declare variable_array_overlay (64) char (4) based (variable_string_ptr), variable_overlay char (n) based (variable_string_ptr); /* builtins */ declare (addr, binary, bool, dim, divide, length, mod, null, substr, unspec) builtin; /* program */ variable_string_ptr = addr (substr (var_name, 1)); n = length (var_name); n_words = divide (n, 4, 21, 0); n_chars = n - n_words * 4; mod_2_sum = ""b; do i = 1 to n_words; four_chars = variable_array_overlay (i); mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); end; if n_chars ^= 0 then do; four_chars = substr (variable_array_overlay (i), 1, n_chars); mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); end; hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1)); old_q = null; do q = hash_table (hash_index) repeat (q -> variable.nextv) while (q ^= null); if n < q -> variable.name_length then go to insert_variable; if variable_overlay = q -> variable.name then do; return; end; old_q = q; end; insert_variable: variable_name_length = length (var_name); v_ptr = allocate (temp_seg_3.area_ptr, size (variable)); v_ptr -> variable.name_length = variable_name_length; v_ptr -> variable.name = var_name; v_ptr -> variable.alias_id = alias_token; v_ptr -> variable.variable_type = var_type; v_ptr -> variable.nextv = q; v_ptr -> variable.next = temp_seg_3.variable_base; temp_seg_3.variable_base = v_ptr; if old_q = null then hash_table (hash_index) = v_ptr; else old_q -> variable.nextv = v_ptr; return; %page; lookup: entry (var_name, alias, var_type, var_id); declare alias fixed binary; /* OUTPUT: index of alias token, if any */ declare var_id pointer; /* OUTPUT: id of var, used in altering properties of variable */ /* given an identifier name, determine if it has been defined - if so, return as its alias, the index of token to which it evaluates else return none var_id and var_type are only meaningful if alias ^= none. possible values for var_type are: default_var, replace_var, parameter_var, and set_var. */ alias, var_type = none; var_id = null; variable_string_ptr = addr (substr (var_name, 1)); n = length (var_name); n_words = divide (n, 4, 21, 0); n_chars = n - n_words * 4; mod_2_sum = ""b; do i = 1 to n_words; four_chars = variable_array_overlay (i); mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); end; if n_chars ^= 0 then do; four_chars = substr (variable_array_overlay (i), 1, n_chars); mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); end; hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1)); old_q = null; do q = hash_table (hash_index) repeat (q -> variable.nextv) while (q ^= null); if variable_overlay = q -> variable.name then do; alias = q -> variable.alias_id; var_type = q -> variable.variable_type; var_id = q; end; end; if var_name = "set_opt" | var_name = "symbol_update_at" then do; return; end; return; end create_variable; %include translator_temp_alloc; end pl1_macro_lex_; 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