COMPILATION LISTING OF SEGMENT pl1_macro_lex_ Compiled by: Multics PL/I Compiler, Release 32f, of October 9, 1989 Compiled at: Bull HN, Phoenix AZ, System-M Compiled on: 10/09/89 0903.3 mst Mon Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Bull Inc., 1987 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* *********************************************************** */ 11 12 13 14 15 /****^ HISTORY COMMENTS: 16* 1) change(87-05-06,Huen), approve(87-05-06,MCR7675), audit(87-05-11,RWaters), 17* install(87-12-01,MR12.2-1005): 18* Fix PL/1 bug 2163 : Speeding up the macro processing. 19* END HISTORY COMMENTS */ 20 21 22 /* format: style2 */ 23 /* This is the lexical analysis program for the pl1_macro command. 24* The primary responsibilities of this program are: 25* 1. Break the source program into tokens. 26* 2. Perform whatever substitution need be done at stand_alone time. 27* 3. Create the output segment. 28* 29* Written 771105 by PG; from "lex" in the Multics PL/I compiler. 30* Modified 771226 by PG to save comments and vertical white space as token trailers. 31* Modified November 1978 by Monte Davidoff. 32* Stolen and modified Nov 21 80 by Marshall Presser 33* Modified May 1987 by Susanna Huen. 34**/ 35 pl1_macro_lex_: 36 procedure (P_temp_segs, code); 37 38 declare P_temp_segs (*) pointer; /* INPUT: temporary segment pointers */ 39 declare code fixed binary (35); /* OUTPUT: status code */ 40 41 /* automatic */ 42 43 declare FALSE_token fixed binary; /* index of a "0"b token */ 44 declare TRUE_token fixed binary; /* index of a "1"b token */ 45 declare action_index fixed binary; /* index of action to execute */ 46 declare alias_id fixed binary; /* for replacement tokens, the token to which it resolves */ 47 declare current_char char (1); /* character that stopped the scan, char we are checking */ 48 declare error_message char (256) varying;/* used as a temp to avoid stack extension in call */ 49 declare file_number fixed binary (8); /* file number of seg were lexing */ 50 declare first_result fixed binary; /* first replacement token in expansion */ 51 declare i fixed binary; 52 declare last_result fixed binary; /* last token in expansion of macro */ 53 declare last_token fixed binary; /* last token in macro consturct being interpreted */ 54 declare line_number fixed binary (14); /* line in source from which were lexing */ 55 declare loop bit (1) aligned; /* loop control variable */ 56 declare macro_depth fixed binary; /* depth of macro stack */ 57 declare macro_ptr pointer; /* -> macro_stack for current source_segment */ 58 declare nested_if_level fixed binary; /* number of %if's on the stack */ 59 declare next_char_to_print fixed binary (21); /* next char to print from current source */ 60 declare next_free_token fixed binary; /* when finishing macro, where to plunk results */ 61 declare number_of_clargs fixed binary; /* number of command line args */ 62 declare number_of_params fixed binary; /* number of command line parameters */ 63 declare output_index fixed binary (21); /* current length (and index) of computed output */ 64 declare output_length fixed binary (21); /* length of output segment */ 65 declare pct_type fixed binary (5) unsigned; 66 declare reinterpret bit (1); /* macro needs reintretreting of result */ 67 declare replacement_token_index 68 fixed binary; /* next free token for replacment identifiers */ 69 declare result_first fixed binary; /* first token of result of parsing macros */ 70 declare scan_index fixed binary (21); /* index (relative to source_index) of forward scan */ 71 declare source_index fixed binary (21); /* index into current source segment */ 72 declare source_length fixed binary (21); /* length (in characters) of current source segment */ 73 declare source_number fixed binary; /* number of source segments scanned */ 74 declare source_ptr pointer; /* pointer to base of source segment */ 75 declare source_type fixed binary (35); /* type of input being scanned */ 76 declare string_length fixed binary (21); /* number of characters in dequoted string */ 77 declare target_error bit (1); /* "1"b iff %target used without -target control arg */ 78 declare target_value fixed binary (17); /* value of %target to use */ 79 declare temp_token char (256) var; /* used as a temp to avoid stack extension in call */ 80 declare terminator_type fixed binary; /* how macro construct is terminated */ 81 declare token_index fixed binary; /* index into current macro_construct */ 82 declare token_length fixed binary (21); /* length of token in characters */ 83 declare token_ptr pointer; /* pointer to char string of token */ 84 declare token_start fixed binary (21); /* index of first character of current token */ 85 declare token_type fixed binary (8) unsigned; 86 /* type of current token */ 87 declare tokenx fixed binary; /* index into token */ 88 declare var_id pointer; /* id of variable, used in altering properties */ 89 declare var_name char (256) varying;/* name of variable */ 90 declare var_type fixed binary; /* type of statement in which variable declared */ 91 92 /*format: off */ 93 declare tentative_token_type (0:128) fixed binary (8) unsigned 94 initial ( 95 (9) invalid_char, /* 000-010 ctl chars */ 96 no_token, /* 011 HT */ 97 (3) nl_vt_np_token,/* 012-014 NL VT NP */ 98 (19) invalid_char, /* 015-037 ctl chars */ 99 no_token, /* 040 SP */ 100 invalid_char, /* 041 ! */ 101 char_string, /* 042 " */ 102 (2) invalid_char, /* 043-044 # $ */ 103 percent, /* 045 % */ 104 and, /* 046 & */ 105 invalid_char, /* 047 ' */ 106 left_parn, /* 050 ( */ 107 right_parn, /* 051 ) */ 108 asterisk, /* 052 * */ 109 plus, /* 053 + */ 110 comma, /* 054 , */ 111 minus, /* 055 - */ 112 period, /* 056 . */ 113 slash, /* 057 / */ 114 (10) dec_integer, /* 060-071 0 - 9 */ 115 colon, /* 072 : */ 116 semi_colon, /* 073 ; */ 117 lt, /* 074 < */ 118 assignment, /* 075 = */ 119 gt, /* 076 > */ 120 (2) invalid_char, /* 077-100 ? @ */ 121 (26) identifier, /* 101-132 A - Z */ 122 (3) invalid_char, /* 133-135 [ \ ] */ 123 not, /* 136 ^ */ 124 (2) invalid_char, /* 137-140 _ ` */ 125 (26) identifier, /* 141-172 a - z */ 126 invalid_char, /* 173 { */ 127 or, /* 174 | */ 128 (3) invalid_char, /* 175-177 } ~ PAD */ 129 invalid_char); /* >177 non-ASCII */ 130 /* format: on */ 131 /* Pushdown stack for nested include files and macros */ 132 133 declare 1 file_macro_stack (0:64) aligned based (temp_seg_3.file_stack_ptr), 134 2 source_type fixed binary (35), /* either macro or source */ 135 2 file aligned, 136 3 source_ptr ptr, /* ptr to base of source segment */ 137 3 source_index fixed bin (21), /* index (in chars) of lexical scan */ 138 3 source_length fixed bin (21), /* length (in chars) of source segment */ 139 3 line_number fixed bin (14), /* line number in source segment */ 140 3 file_number fixed bin (8), /* file number of source segment */ 141 3 macro_ptr pointer, /* -> macro_stack for this source seg */ 142 3 macro_depth fixed binary, /* depth of macro_stack */ 143 3 nested_if_level fixed binary, /* nesting level of %if's */ 144 3 next_char_to_print 145 fixed binary (21), /* index of next character to print */ 146 2 macro aligned, 147 3 token_index fixed binary, /* index (by token number) of in scan */ 148 3 last_token fixed binary, /* position (in tokens) of last token */ 149 3 first_result fixed binary, /* first token in result string */ 150 3 last_result fixed binary, /* last token in result */ 151 3 last_printed fixed binary; /* when applicable, last char printed */ 152 153 declare 1 macro_stack (64) aligned based (macro_ptr), 154 /* per source seg stack */ 155 2 type fixed binary, /* kind of token string */ 156 2 token_index fixed binary, /* first token in string */ 157 2 last_token fixed binary, /* last token in string */ 158 2 first_result fixed binary, /* first token in result string */ 159 2 last_result fixed binary, /* last token in result */ 160 2 else_seen bit (1); /* for if-types, if an %else has been seen */ 161 162 dcl pl1_macro_hash_table_ptr ptr; 163 164 declare 1 hash_table_structure aligned based (pl1_macro_hash_table_ptr), 165 2 hash_table (0:630) ptr unaligned; 166 167 /* based */ 168 169 declare based_chars char (256) based; 170 declare source_string char (source_length) based (source_ptr); 171 declare source_string_array (source_length) char (1) based (source_ptr); 172 declare token_string char (token (token_index).string_size) based (token (token_index).string_ptr); 173 174 /* builtin */ 175 176 declare (addr, bin, binary, bit, char, fixed, divide, hbound, index, lbound, length, ltrim, max, min, null, 177 rank, rtrim, substr, unspec, verify) 178 builtin; 179 180 /* entry */ 181 declare char_offset_ entry (pointer) returns (fixed binary (21)); 182 declare find_include_file_$initiate_count 183 entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35)); 184 declare com_err_ entry () options (variable); 185 declare hcs_$terminate_noname entry (ptr, fixed bin (35)); 186 declare ioa_ entry () options (variable); 187 /* external static */ 188 declare error_table_$translation_failed 189 fixed bin (35) ext static; 190 191 /* internal static */ 192 /* format: off */ 193 declare action_table (0:128) fixed binary internal static options (constant) 194 initial ( 195 (9) 9, /* 000-010 ctl chars */ 196 1, /* 011 HT */ 197 18, /* 012 NL */ 198 (2) 8, /* 013-014 VT NP */ 199 (19) 9, /* 015-037 ctl chars */ 200 1, /* 040 SP */ 201 9, /* 041 ! */ 202 2, /* 042 " */ 203 9, /* 043 # */ 204 9, /* 044 $ */ 205 16, /* 045 % */ 206 4, /* 046 & */ 207 9, /* 047 ' */ 208 (2) 4, /* 050-051 ( ) */ 209 10, /* 052 * */ 210 (2) 4, /* 053-054 + , */ 211 11, /* 055 - */ 212 6, /* 056 . */ 213 5, /* 057 / */ 214 (10) 7, /* 060-071 0 - 9 */ 215 4, /* 072 : */ 216 17, /* 073 ; */ 217 12, /* 074 < */ 218 4, /* 075 = */ 219 13, /* 076 > */ 220 (2) 9, /* 077-100 ? @ */ 221 (26) 3, /* 101-132 A - Z */ 222 (3) 9, /* 133-135 [ \ ] */ 223 14, /* 136 ^ */ 224 (2) 9, /* 137-140 _ ` */ 225 (26) 3, /* 141-172 a - z */ 226 9, /* 173 { */ 227 15, /* 174 | */ 228 (3) 9, /* 175-177 } ~ PAD */ 229 9); /* >177 non-ASCII */ 230 /* format: on */ 231 232 declare digits char (10) internal static options (constant) initial ("0123456789"); 233 declare identifier_characters char (64) internal static options (constant) 234 initial ("$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"); 235 236 declare source_list_length fixed binary internal static options (constant) initial (255); 237 declare ASCII_SEGMENT fixed binary internal static options (constant) initial (1); 238 declare MACRO_CONSTRUCT fixed binary internal static options (constant) initial (2); 239 declare FALSE bit (1) aligned internal static options (constant) initial ("0"b); 240 declare TRUE bit (1) aligned internal static options (constant) initial ("1"b); 241 declare HT_SP char (2) internal static options (constant) initial (" "); 242 declare VT_NP char (3) internal static options (constant) initial (" "); 243 1 1 /* Begin include file pl1_macro_lex_dcls.incl.pl1 */ 1 2 1 3 1 4 /****^ HISTORY COMMENTS: 1 5* 1) change(87-05-11,Huen), approve(87-05-11,MCR7675), 1 6* audit(87-05-11,RWaters), install(87-12-01,MR12.2-1005): 1 7* Fix PL/1 bug2163 : Speeding up the macro processing. 1 8* END HISTORY COMMENTS */ 1 9 1 10 /* format: style2 */ 1 11 1 12 /* Created Dec 80 M E Presser 1 13* Modified 1 14* 11 May 87 - SH, speeding up the macro processing 1 15* 3 August 81 - MEP redefined token 1 16* 18 May 81 - MEP, redefined token, temp_seg_3, and token types 1 17**/ 1 18 1 19 /* automatic */ 1 20 1 21 declare temp_segs (5) pointer; 1 22 1 23 /* use of temp_segs: 1 24* 1. tokens in pl1_macro_lex_ 1 25* 2. output_string 1 26* 3. job information 1 27* 4. listing and cross_ref 1 28* 5. Unused just now 1 29**/ 1 30 /* area */ 1 31 1 32 declare area area based (temp_seg_3.area_ptr); 1 33 1 34 /* based */ 1 35 1 36 declare 1 atoken aligned based, 1 37 2 string_size fixed binary (21) unaligned, 1 38 /* length of token string */ 1 39 2 created bit (1) unaligned, /* "1" iff created by pl1_macro */ 1 40 2 pct_type fixed binary (5) unsigned unaligned, 1 41 2 type fixed binary (8) unsigned unaligned, 1 42 /* token_type */ 1 43 2 replace_by fixed binary, /* index of replacement value, if any */ 1 44 2 string_ptr unaligned pointer; /* pointer to start of token */ 1 45 1 46 declare 1 token (divide (sys_info$max_seg_size, size (atoken), 19)) aligned based (temp_segs (1)) 1 47 like atoken; 1 48 1 49 /* builtin */ 1 50 1 51 declare size builtin; 1 52 1 53 /* structure for command line args */ 1 54 1 55 declare 1 args aligned based, 1 56 2 string_size fixed binary (21), 1 57 2 string_ptr unaligned pointer; 1 58 1 59 /* structure for command line parameter control arg arguments */ 1 60 1 61 declare 1 params aligned based, 1 62 2 name aligned like args, 1 63 2 value aligned like token; 1 64 1 65 /* temp_seg_3 is used for general storage of system wide information */ 1 66 1 67 declare 1 temp_seg_3 aligned based (temp_segs (3)), 1 68 2 area_ptr pointer, /* base of area */ 1 69 2 source_ptr pointer, /* ptr to source seg */ 1 70 2 source_length fixed binary (21), /* lenght (chars) of source */ 1 71 2 output_length fixed binary (21), /* length (chars) of output */ 1 72 2 constant_base pointer, /* start of chain of constant nodes */ 1 73 2 variable_base pointer, /* start of chain of variable nodes */ 1 74 2 source_depth fixed binary, /* depth of file_macro_stack */ 1 75 2 file_stack_ptr pointer, /* ptr -> file_macro_stack */ 1 76 2 flags unaligned, 1 77 3 list bit (1), /* if .maclist to be made */ 1 78 3 pad1 bit (35), 1 79 2 target_value fixed binary (17), /* as returned by system_type_ */ 1 80 2 number_of_clargs fixed binary, 1 81 2 number_of_params fixed binary, 1 82 2 cl_args (64) aligned like args, 1 83 2 cl_params (64) aligned like params; 1 84 1 85 1 86 declare output_string char (4 * sys_info$max_seg_size) based (temp_segs (2)); 1 87 1 88 /* variable node */ 1 89 1 90 declare 1 variable aligned based, 1 91 2 next pointer unaligned, /* next alloc in chain */ 1 92 2 nextv pointer unaligned, /* next var in hash chain */ 1 93 2 alias_id fixed binary (17) unaligned, 1 94 /* index into token chain */ 1 95 2 variable_type fixed binary unaligned, /* default, replace or set type */ 1 96 2 name_length fixed binary (17) unaligned, 1 97 2 name character (variable_name_length refer (variable.name_length)); 1 98 1 99 declare variable_name_length fixed binary; 1 100 1 101 /* constant node */ 1 102 1 103 declare 1 constant aligned based, 1 104 2 next pointer, /* next in chain */ 1 105 2 string_length fixed binary (21), 1 106 2 string_value character (constant_length refer (constant.string_length)); 1 107 1 108 declare constant_length fixed binary (21); 1 109 1 110 /* token types */ 1 111 1 112 declare ( 1 113 no_token initial (0), 1 114 invalid_char initial (1), 1 115 identifier initial (2), 1 116 keyword_token initial (3), 1 117 isub initial (4), 1 118 plus initial (5), 1 119 minus initial (6), 1 120 asterisk initial (7), 1 121 slash initial (8), 1 122 expon initial (9), 1 123 not initial (10), 1 124 and initial (11), 1 125 or initial (12), 1 126 cat initial (13), 1 127 eq initial (14), 1 128 ne initial (15), 1 129 lt initial (16), 1 130 gt initial (17), 1 131 le initial (18), 1 132 ge initial (19), 1 133 ngt initial (20), 1 134 nlt initial (21), 1 135 prefix_plus initial (22), 1 136 prefix_minus initial (23), 1 137 assignment initial (24), 1 138 colon initial (25), 1 139 semi_colon initial (26), 1 140 comma initial (27), 1 141 period initial (28), 1 142 arrow initial (29), 1 143 left_parn initial (30), 1 144 right_parn initial (31), 1 145 percent initial (32), 1 146 target_comma initial (33), 1 147 comment_token initial (34), 1 148 nl_vt_np_token initial (35), 1 149 bit_string initial (36), 1 150 char_string initial (37), 1 151 fixed_bin initial (38), 1 152 bin_integer initial (39), 1 153 fixed_dec initial (40), 1 154 dec_integer initial (41), 1 155 float_bin initial (42), 1 156 token_hole_1 initial (43), 1 157 float_dec initial (44), 1 158 token_hole_2 initial (45), 1 159 i_fixed_bin initial (46), 1 160 i_bin_integer initial (47), 1 161 i_fixed_dec initial (48), 1 162 i_dec_integer initial (49), 1 163 i_float_bin initial (50), 1 164 token_hole_3 initial (51), 1 165 i_float_dec initial (52), 1 166 token_hole_4 initial (53), 1 167 white_space_token initial (54) 1 168 ) fixed binary (8) unsigned internal static options (constant); 1 169 1 170 /* token class limits */ 1 171 1 172 declare ( 1 173 min_delimiter_token initial (5), 1 174 max_delimiter_token initial (35), 1 175 min_constant_token initial (36), 1 176 max_constant_token initial (53), 1 177 min_arithmetic_token initial (38), 1 178 max_arithmetic_token initial (53) 1 179 ) fixed binary (8) unsigned internal static options (constant); 1 180 1 181 /* arithmetic token type masks */ 1 182 1 183 declare ( 1 184 is_imaginary_constant initial ("1000"b), 1 185 is_float_constant initial ("0100"b), 1 186 is_decimal_constant initial ("0010"b), 1 187 is_integral_constant initial ("0001"b) 1 188 ) bit (4) aligned internal static options (constant); 1 189 1 190 /* valid keyword following a percent_sign and their attributes */ 1 191 1 192 /* format: off */ 1 193 1 194 declare 1 pct_keywords (19) aligned structure internal static options (constant), 1 195 2 name character (8) varying 1 196 initial( 1 197 "page", "skip", "replace", "default", "target", "isarg", "isdef", 1 198 "include","if", "then", "else", "elseif", "endif", "print", 1 199 "error", "warn", "abort", "INCLUDE", "set"), 1 200 1 201 2 terminator fixed binary (17) unaligned /* refer to macro stack types */ 1 202 initial( 1 203 3, 3, 3, 3, 1, 1, 1, 1 204 3, 2, 2, 2, 2, 2, 3, 1 205 3, 3, 3, 3, 3), 1 206 1 207 2 needs_reinterpreation bit (1) unaligned 1 208 initial( 1 209 "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, 1 210 "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, 1 211 "1"b, "1"b, "1"b, "1"b, "1"b), 1 212 1 213 2 m_index fixed binary (17) unaligned 1 214 initial( 1 215 2, 3, 4, 1, 7, 8, 6, 1 216 15, 9, 10, 11, 12, 13, 16, 1 217 5, 17, 18, 14, 19); 1 218 1 219 /* format: on */ 1 220 1 221 /* pct_types */ 1 222 1 223 declare ( 1 224 pct_default initial (1), 1 225 pct_page initial (2), 1 226 pct_skip initial (3), 1 227 pct_replace initial (4), 1 228 pct_error initial (5), 1 229 pct_isdef initial (6), 1 230 pct_target initial (7), 1 231 pct_isarg initial (8), 1 232 pct_if initial (9), 1 233 pct_then initial (10), 1 234 pct_else initial (11), 1 235 pct_elseif initial (12), 1 236 pct_endif initial (13), 1 237 pct_INCLUDE initial (14), 1 238 pct_include initial (15), 1 239 pct_print initial (16), 1 240 pct_warn initial (17), 1 241 pct_abort initial (18), 1 242 pct_set initial (19) 1 243 ) fixed binary internal static options (constant); 1 244 1 245 /* variable types - in which statement type they were first declared */ 1 246 1 247 declare ( 1 248 replace_var initial (1), 1 249 default_var initial (2), 1 250 set_var initial (3), 1 251 parameter_var initial (4) 1 252 ) fixed binary internal static options (constant); 1 253 1 254 /* macro stack types */ 1 255 1 256 declare ( 1 257 paren_macro initial (1), 1 258 if_macro initial (2), 1 259 semicolon_macro initial (3), 1 260 reinterpret_macro initial (4) 1 261 ) fixed binary internal static options (constant); 1 262 1 263 /* lexical limits */ 1 264 1 265 declare ( 1 266 max_bit_string_constant 1 267 initial (253), 1 268 max_char_string_constant 1 269 initial (254), 1 270 max_identifier_length initial (256) 1 271 ) fixed binary internal static options (constant); 1 272 1 273 1 274 /* external static */ 1 275 1 276 declare pl1_macro_severity_ fixed binary (35) external static; 1 277 declare sys_info$max_seg_size fixed binary (19) external static; 1 278 1 279 /* entry */ 1 280 1 281 declare pl1_macro_error_ entry (fixed binary (35), char (*), pointer, fixed binary (21), fixed binary (21)); 1 282 declare pl1_macro_lex_ entry ((*) pointer, fixed binary (35)); 1 283 declare pl1_macro_lex_$cleanup entry ((*) pointer); 1 284 declare system_type_ entry (char (*), char (*), fixed binary (17), fixed binary (35)); 1 285 1 286 /* constants mostly used by lex */ 1 287 1 288 declare arithchar char (28) internal static options (constant) 1 289 initial ("0123456789(=^=<=>=+-*/) ."" 1 290 "); 1 291 declare alphabetics char (52) internal static options (constant) 1 292 initial ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"); 1 293 1 294 declare numerals char (10) internal static options (constant) initial ("0123456789"); 1 295 1 296 declare identifier_chars char (64) internal static options (constant) 1 297 initial ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$"); 1 298 1 299 declare lower_case_letters char (26) internal static options (constant) initial ("abcdefghijklmnopqrstuvwxyz"); 1 300 declare upper_case_letters char (26) internal static options (constant) initial ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); 1 301 1 302 declare zero_one char (2) internal static options (constant) initial ("01"); 1 303 declare QUOTE char (1) internal static options (constant) initial (""""); 1 304 declare QUOTEQUOTE char (2) internal static options (constant) initial (""""""); 1 305 1 306 /* miscellaneous constants */ 1 307 1 308 declare none fixed binary internal static options (constant) initial (0); 1 309 1 310 declare macro_version character (5) internal static options (constant) initial (" 2.0 "); 1 311 declare command character (9) internal static options (constant) initial ("pl1_macro"); 1 312 1 313 /* error codes */ 1 314 1 315 declare NO_RESULT fixed binary (35) internal static options (constant) initial (1); 1 316 declare COMPILER_ERROR fixed binary (35) internal static options (constant) initial (2); 1 317 declare SYNTAX_ERROR fixed binary (35) internal static options (constant) initial (3); 1 318 declare SEMANTIC_ERROR fixed binary (35) internal static options (constant) initial (4); 1 319 declare STORAGE_SYSTEM_ERROR fixed binary (35) internal static options (constant) initial (5); 1 320 declare IMPLEMENTATION_RESTRICTION 1 321 fixed binary (35) internal static options (constant) initial (6); 1 322 declare TARGET_STRING_ERROR fixed binary (35) internal static options (constant) initial (7); 1 323 2 1 /* BEGIN INCLUDE FILE ... system_types.incl.pl1 ... 03/23/81 ... W. Olin Sibert */ 2 2 2 3 dcl L68_SYSTEM fixed bin (17) internal static options (constant) init (1); 2 4 dcl ADP_SYSTEM fixed bin (17) internal static options (constant) init (2); 2 5 2 6 dcl SYSTEM_TYPE_NAME (2) char (8) internal static options (constant) init 2 7 ("Level68", "ADP"); 2 8 2 9 /* END INCLUDE FILE ... system_types.incl.pl1 */ 1 324 1 325 1 326 /* END INCLUDE FILE . . . pl1_macro_lex_dcls.incl. */ 244 245 246 /* program */ 247 248 code = 0; 249 temp_segs (*) = P_temp_segs (*); 250 output_index = 0; 251 tokenx = 0; 252 replacement_token_index = hbound (token, 1); 253 source_number = 0; 254 temp_seg_3.source_depth = -1; 255 file_number = 0; 256 line_number = 1; 257 target_error = FALSE; 258 target_value = temp_seg_3.target_value; 259 output_length = temp_seg_3.output_length; 260 261 /* Entry to initialize the hash table used by create_token. Note that the 262* length of the hash table must be a prime number */ 263 264 pl1_macro_hash_table_ptr = allocate (temp_seg_3.area_ptr, size (hash_table_structure)); 265 hash_table (*) = null; 266 267 temp_seg_3.file_stack_ptr = allocate (temp_seg_3.area_ptr, size (file_macro_stack)); 268 number_of_params = temp_seg_3.number_of_params; 269 number_of_clargs = temp_seg_3.number_of_clargs; 270 271 /* set up replacment tokens for the command line parameters */ 272 273 do i = 1 to number_of_params; 274 var_name = 275 substr (temp_seg_3.cl_params.name (i).string_ptr -> based_chars, 1, 276 temp_seg_3.cl_params.name (i).string_size); 277 278 call lookup (var_name, alias_id, var_type, var_id); 279 280 token_type = temp_seg_3.cl_params.value (i).type; 281 temp_token = 282 substr (temp_seg_3.cl_params.value (i).string_ptr -> based_chars, 1, 283 temp_seg_3.cl_params (i).value.string_size); 284 285 if token_type = identifier 286 then token_index = create_identifier_token (rtrim (temp_token)); 287 288 else if token_type = char_string 289 then token_index = create_char_token (rtrim (temp_token)); 290 291 else if token_type = bit_string 292 then token_index = 293 create_bit_token ( 294 bit ( 295 dequote_string_ ( 296 substr (temp_seg_3.cl_args (i).string_ptr -> based_chars, 1, 297 temp_seg_3.cl_args (i).string_size - 1)))); 298 299 else if token_type = dec_integer 300 then token_index = create_arith_token (bin (temp_token, 71)); 301 302 else call print_error$null (2, "Undefined token type for argument " || ltrim (char (i))); 303 304 if alias_id = none 305 then call create_variable (var_name, token_index, parameter_var); 306 else call reset_variable_alias (var_id, token_index); 307 end /* do loop */; 308 309 /* set up the two logical tokens useful in if's */ 310 311 TRUE_token = create_bit_token ("1"b); 312 FALSE_token = create_bit_token ("0"b); 313 314 /* set up is finished - enter the source segment */ 315 316 call enter_source_segment (temp_seg_3.source_ptr, temp_seg_3.source_length, (file_number)); 317 318 do while (temp_seg_3.source_depth >= 0); /* for source, include files and macros */ 319 goto source_start (source_type); 320 321 source_start (1): /* ASCII segments */ 322 do while (source_index <= source_length); 323 324 /* determine from 1st char, what sort of token this can be and go there */ 325 326 current_char = substr (source_string, source_index, 1); 327 token_start = source_index; 328 source_index = source_index + 1; 329 token_type = tentative_token_type (min (rank (current_char), hbound (tentative_token_type, 1))); 330 pct_type = none; 331 action_index = action_table (min (rank (current_char), hbound (action_table, 1))); 332 goto action (action_index); 333 334 action (1): /* Scan white space */ 335 scan_index = verify (substr (source_string, source_index), HT_SP) - 1; 336 if scan_index < 0 337 then source_index = source_length + 1; 338 else source_index = source_index + scan_index; 339 340 token_type = white_space_token; 341 call make_token; 342 goto END_ACTION; 343 344 action (2): /* Scan string: current_char = '"' */ 345 string_length = 0; /* count of number of characters in reduced string */ 346 347 loop = TRUE; 348 do while (loop); 349 scan_index = index (substr (source_string, source_index), """"); 350 if scan_index = 0 351 then do; 352 call print_error (3, "Missing double quote after string constant.", token_start); 353 354 source_index = source_length + 1; 355 string_length = string_length + (source_length - token_start + 1); 356 goto end_of_source_reached; 357 end; 358 359 source_index = source_index + scan_index; 360 string_length = string_length + scan_index - 1; 361 362 if source_index > source_length /* not an error */ 363 then goto end_of_source_reached; 364 365 loop = substr (source_string, source_index, 1) = """"; 366 if loop 367 then do; 368 source_index = source_index + 1; 369 string_length = string_length + 1; 370 end; 371 end; 372 373 if substr (source_string, source_index, 1) = "b" 374 then do; 375 token_type = bit_string; 376 source_index = source_index + 1; 377 378 if source_index <= source_length 379 then if index ("1234", substr (source_string, source_index, 1)) > 0 380 then source_index = source_index + 1; 381 end; 382 383 if token_type = char_string 384 then do; 385 if string_length > max_char_string_constant 386 then call print_error (2, "Character-string constant too long.", token_start); 387 388 /* here we will insert code to count new_lines in the char_string */ 389 390 end; 391 392 else if string_length > max_bit_string_constant 393 then call print_error (2, "Bit-string constant too long.", token_start); 394 395 call make_token; 396 goto check_syntax_after_constant; 397 398 action (3): /* Scan identifers */ 399 scan_index = verify (substr (source_string, source_index), identifier_characters); 400 if scan_index = 0 401 then scan_index = source_length - source_index + 2; 402 source_index = source_index + scan_index - 1; 403 404 /* look up this token - and make a token setting replace_by by its alias or none. 405* if within a macro construct, make a replacment-token, else simply put 406* out the replacement- chars */ 407 408 temp_token = substr (source_string, token_start, source_index - token_start); 409 call lookup (temp_token, alias_id, var_type, var_id); 410 411 call make_token; 412 token (tokenx).replace_by = alias_id; 413 414 /* if we're not in the middle of a macro construct and there has been replacement activity 415* then it's a convenient time to update the output */ 416 417 if alias_id ^= none & macro_depth = 0 418 then do; 419 call output_chars$from_source (next_char_to_print, source_index - scan_index - 1); 420 call output_chars$token (alias_id); 421 next_char_to_print = source_index; 422 end; 423 424 goto END_ACTION; 425 426 action (4): /* Single character tokens */ 427 call make_token; 428 if macro_depth > 0 /* check if in a macro construct */ 429 then if token_type = right_parn & macro_stack (macro_depth).type = paren_macro 430 then do; 431 macro_stack (macro_depth).last_token = tokenx; 432 call save_environment; 433 call enter_macro_source; 434 goto source_start (MACRO_CONSTRUCT); 435 end; 436 437 goto END_ACTION; 438 439 action (5): /* Separate / and /* */ 440 if source_index > source_length 441 then goto end_of_source_reached; 442 443 if substr (source_string, source_index, 1) ^= "*" 444 then do; 445 call make_token; 446 goto END_ACTION; 447 end; 448 449 token_type = comment_token; 450 source_index = source_index + 1; 451 452 scan_index = index (substr (source_string, source_index), "*/"); 453 if scan_index = 0 454 then do; 455 call print_error (3, "Missing ""*/"" at end of comment.", token_start); 456 457 source_index = source_length + 1; 458 goto end_of_source_reached_but_no_pending_token; 459 end; 460 461 /* here we will insert code to count the number of new_lines in a comment */ 462 463 source_index = source_index + scan_index + 1; 464 465 /* we only need to make comment tokens within a macro cosntruct- outside we get them for nothing as loose text */ 466 467 if macro_depth > 0 468 then call make_token; 469 goto END_ACTION; 470 471 action (6): /* Separate . and numbers: current_char = "." */ 472 if source_index > source_length 473 then goto end_of_source_reached; 474 475 if index (digits, substr (source_string, source_index, 1)) = 0 476 then do; 477 call make_token; 478 goto END_ACTION; 479 end; 480 481 token_type = fixed_dec; 482 call scan_past_digits; 483 goto scan_exponent; 484 485 action (7): /* Scan numbers and isubs: current char = */ 486 if source_index > source_length 487 then goto end_of_source_reached; 488 489 call scan_past_digits; 490 491 if substr (source_string, source_index, 1) = "." 492 then do; 493 token_type = fixed_dec; 494 source_index = source_index + 1; 495 call scan_past_digits; 496 end; 497 else if source_index + 2 <= source_length 498 then if substr (source_string, source_index, 3) = "sub" 499 then do; 500 source_index = source_index + 3; 501 token_type = isub; 502 call make_token; 503 goto END_ACTION; 504 end; 505 506 scan_exponent: 507 token_length = source_index - token_start; 508 /* remember length of mantissa for later error check */ 509 510 if substr (source_string, source_index, 1) = "e" | substr (source_string, source_index, 1) = "f" 511 then do; 512 if substr (source_string, source_index, 1) = "e" 513 then token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) & is_float_constant); 514 515 token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) & ^is_integral_constant); 516 source_index = source_index + 1; 517 518 if source_index > source_length 519 then do; 520 call print_error (3, "Missing exponent in arithmetic constant.", token_start); 521 goto end_of_source_reached; 522 end; 523 524 if substr (source_string, source_index, 1) = "+" 525 | substr (source_string, source_index, 1) = "-" 526 then do; 527 source_index = source_index + 1; 528 529 if source_index > source_length 530 then do; 531 call print_error (3, "Missing exponent in arithmetic constant.", 532 token_start); 533 goto end_of_source_reached; 534 end; 535 end; 536 537 call scan_past_digits; 538 end; 539 540 if substr (source_string, source_index, 1) = "b" 541 /* binary constant */ 542 then do; 543 token_type = bit_to_arithmetic (arithmetic_to_bit (token_type) & ^is_decimal_constant); 544 source_index = source_index + 1; 545 546 if verify (substr (source_string, token_start, token_length), ".01") > 0 547 then call print_error (2, "Non-binary digit in binary constant.", token_start); 548 end; 549 550 if source_index <= source_length 551 then if substr (source_string, source_index, 1) = "p" 552 then do; /* default suppression indicator */ 553 token_type = 554 bit_to_arithmetic (arithmetic_to_bit (token_type) & ^is_integral_constant); 555 source_index = source_index + 1; 556 end; 557 558 if source_index <= source_length 559 then if substr (source_string, source_index, 1) = "i" 560 then do; /* imaginary constant */ 561 token_type = 562 bit_to_arithmetic (arithmetic_to_bit (token_type) | is_imaginary_constant); 563 source_index = source_index + 1; 564 end; 565 566 call make_token; 567 568 /* Now make sure the syntax after the constant is correct. */ 569 570 check_syntax_after_constant: 571 if source_index > source_length 572 then goto end_of_source_reached; 573 574 current_char = substr (source_string, source_index, 1); 575 action_index = action_table (min (rank (current_char), hbound (action_table, 1))); 576 577 if action_index = 2 | action_index = 3 | action_index = 7 578 /* double quote, identifier or arithmetic constant */ 579 then call print_error (2, "Invalid syntax after constant.", source_index); 580 581 goto END_ACTION; 582 583 action (8): /* Scan VT NP */ 584 scan_index = verify (substr (source_string, source_index), VT_NP) - 1; 585 if scan_index < 0 586 then source_index = source_length + 1; 587 else source_index = source_index + scan_index; 588 token_type = white_space_token; 589 call make_token; 590 591 goto END_ACTION; 592 593 action (9): /* Invalid characters */ 594 if rank (current_char) < 32 | 128 <= rank (current_char) 595 then call print_error (2, "Invalid character. """ || char (bit (rank (current_char))) || """b", 596 source_index - 1); 597 598 else if current_char = "_" | current_char = "$" 599 then call print_error (2, """" || current_char || """ may not start an identifier.", source_index - 1) 600 ; 601 602 else call print_error (2, "Invalid character. """ || current_char || """", source_index - 1); 603 604 call make_token; 605 goto END_ACTION; 606 607 action (10): /* Separate * and ** */ 608 if source_index > source_length 609 then goto end_of_source_reached; 610 611 if substr (source_string, source_index, 1) = "*" 612 then do; 613 source_index = source_index + 1; 614 token_type = expon; 615 end; 616 617 call make_token; 618 goto END_ACTION; 619 620 action (11): /* Separate - and -> */ 621 if source_index > source_length 622 then goto end_of_source_reached; 623 624 if substr (source_string, source_index, 1) = ">" 625 then do; 626 source_index = source_index + 1; 627 token_type = arrow; 628 end; 629 630 call make_token; 631 goto END_ACTION; 632 633 action (12): /* Separate < and <= */ 634 if source_index > source_length 635 then goto end_of_source_reached; 636 637 if substr (source_string, source_index, 1) = "=" 638 then do; 639 source_index = source_index + 1; 640 token_type = le; 641 end; 642 643 call make_token; 644 goto END_ACTION; 645 646 action (13): /* Separate > and >= */ 647 if source_index > source_length 648 then goto end_of_source_reached; 649 650 if substr (source_string, source_index, 1) = "=" 651 then do; 652 source_index = source_index + 1; 653 token_type = ge; 654 end; 655 656 call make_token; 657 goto END_ACTION; 658 659 action (14): /* Separate ^ and ^= and ^< and ^> */ 660 if source_index > source_length 661 then goto end_of_source_reached; 662 663 if substr (source_string, source_index, 1) = "=" 664 then do; 665 source_index = source_index + 1; 666 token_type = ne; 667 end; 668 669 else if substr (source_string, source_index, 1) = "<" 670 then do; 671 source_index = source_index + 1; 672 token_type = nlt; 673 end; 674 675 else if substr (source_string, source_index, 1) = ">" 676 then do; 677 source_index = source_index + 1; 678 token_type = ngt; 679 end; 680 681 call make_token; 682 goto END_ACTION; 683 684 action (15): /* Separate | and || */ 685 if source_index > source_length 686 then goto end_of_source_reached; 687 688 if substr (source_string, source_index, 1) = "|" 689 then do; 690 source_index = source_index + 1; 691 token_type = cat; 692 end; 693 694 call make_token; 695 goto END_ACTION; 696 697 action (16): /* percent seen */ 698 /* if not in the middle of a % statement, print out all the stuff to here */ 699 if macro_depth = 0 700 then do; 701 call output_chars$from_source (next_char_to_print, source_index - 2); 702 next_char_to_print = source_index - 1; 703 end; 704 705 /* % is not really a token, see what follows is correct keyword */ 706 707 if index (alphabetics, substr (source_string, source_index, 1)) = 0 708 then do; 709 call print_error (3, "Illegal character following ""%"".", token_start); 710 source_index = source_index + 1; 711 goto END_ACTION; 712 end; 713 714 /* for this identifier, see it is legitimate */ 715 716 scan_index = verify (substr (source_string, source_index), identifier_characters); 717 if scan_index = 0 718 then scan_index = source_length - source_index + 1; 719 temp_token = substr (source_string, source_index, scan_index - 1); 720 call validate_pct_token (temp_token, pct_type, terminator_type); 721 722 source_index = source_index + scan_index - 1; 723 724 goto percent_action (pct_type); 725 726 percent_action (0): /* invalid identifier */ 727 call print_error (3, "Invalid keyword: " || temp_token || " following ""%"".", token_start); 728 goto END_ACTION; 729 730 percent_action (1): /* default */ 731 percent_action (2): /* page */ 732 percent_action (3): /* skip */ 733 percent_action (4): /* replace */ 734 percent_action (5): /* error */ 735 percent_action (6): /* isdef */ 736 percent_action (7): /* target */ 737 percent_action (8): /* isarg */ 738 percent_action (14): /* INCLUDE */ 739 percent_action (15): /* include */ 740 percent_action (16): /* print */ 741 percent_action (17): /* warn */ 742 percent_action (18): /* abort */ 743 percent_action (19): /* set */ 744 call make_token; 745 call bump_macro_stack (tokenx, terminator_type); 746 goto END_ACTION; 747 748 percent_action (9): /* if */ 749 call make_token; 750 call bump_macro_stack (tokenx, if_macro); 751 nested_if_level = nested_if_level + 1; 752 goto END_ACTION; 753 754 percent_action (10): /* then */ 755 percent_action (11): /* else */ 756 percent_action (12): /* elseif */ 757 /* this is valid iff we are within an if statement - exact syntax later */ 758 if macro_depth > 0 759 then do; 760 if macro_stack (macro_depth).type ^= if_macro 761 then call print_error (3, "Unexpected keyword: " || temp_token || " following %.", 762 token_start); 763 else do; 764 call make_token; 765 if macro_stack (macro_depth).else_seen 766 then do; 767 call print_error (3, 768 "A %" || temp_token || " has followed an %else at the same level.", 769 token_start); 770 call clear_macro_frame; 771 end; 772 macro_stack (macro_depth).else_seen = (token_type = pct_else); 773 end; 774 end; 775 else call print_error (3, "Unexpected keyword: " || temp_token || " following %.", token_start); 776 goto END_ACTION; 777 778 percent_action (13): /* endif */ 779 if macro_depth > 0 780 then do; 781 if macro_stack (macro_depth).type ^= if_macro 782 then call print_error (3, "Unexpected keyword: " || temp_token || " following %.", 783 token_start); 784 else do; 785 call make_token; 786 macro_stack (macro_depth).last_token = tokenx; 787 nested_if_level = nested_if_level - 1; 788 if nested_if_level = 0 789 then do; 790 call save_environment; 791 call enter_macro_source; 792 goto source_start (MACRO_CONSTRUCT); 793 end; 794 else macro_depth = macro_depth - 1; 795 end; 796 end; 797 else call print_error (3, "Unexpected keyword: " || temp_token || " following %.", token_start); 798 799 goto END_ACTION; 800 801 action (17): /* semicolon */ 802 call make_token; 803 if macro_depth > 0 /* check if this terminates a macro construct */ 804 then if macro_stack (macro_depth).type = semicolon_macro 805 then do; 806 if nested_if_level = 0 /* a semicolon macro not embedded */ 807 then do; 808 macro_stack (macro_depth).last_token = tokenx; 809 call save_environment; 810 call enter_macro_source; 811 goto source_start (MACRO_CONSTRUCT); 812 end; 813 else macro_depth = macro_depth - 1; 814 /* terminate it -parsed in %if later */ 815 end; 816 817 goto END_ACTION; 818 819 action (18): /* NL */ 820 line_number = line_number + 1; 821 token_type = white_space_token; 822 call make_token; 823 824 goto END_ACTION; 825 826 END_ACTION: /* with case statements, we wouldn't need this */ 827 end /* source segment while loop */; 828 829 /* control transfers here whenever the lex reaches the end of the current source segment. */ 830 831 end_of_source_reached: 832 call make_token; 833 834 end_of_source_reached_but_no_pending_token: 835 if tokenx >= hbound (token, 1) 836 then call print_error (4, "Too many tokens.", source_length); 837 838 /* output all the remaining characters in the segment */ 839 840 call output_chars$from_source (next_char_to_print, source_length); 841 goto check_depth; 842 843 source_start (2): /* tokens, not chars are being interpreted */ 844 token_index = token_index - 1; /* decrement so get_next_token works */ 845 do while (token_index < last_token); 846 847 call get_next_token$retain_white_space; 848 849 if pct_type = none /* not a pct token */ 850 then do; 851 call make_replacement_token (token_index); 852 goto END_CASE; 853 end; 854 else goto parser (pct_type); 855 856 parser (1): /* default */ 857 call parse_default; 858 goto END_CASE; 859 parser (2): /* page */ 860 call parse_page; 861 goto END_CASE; 862 parser (3): /* skip */ 863 call parse_skip; 864 goto END_CASE; 865 parser (4): /* replace */ 866 call parse_replace; 867 goto END_CASE; 868 parser (5): /* error */ 869 call parse_error; 870 goto END_CASE; 871 parser (6): /* isdef */ 872 call parse_isdef; 873 goto END_CASE; 874 parser (7): /* target */ 875 call parse_target; 876 goto END_CASE; 877 parser (8): /* isarg */ 878 call parse_isarg; 879 goto END_CASE; 880 parser (9): /* if */ 881 call parse_if; 882 goto END_CASE; 883 parser (10): /* then */ 884 parser (11): /* else */ 885 parser (12): /* elseif */ 886 parser (13): /* endif */ 887 call print_error (3, "Unexpected keyword.", token_start); 888 code = SYNTAX_ERROR; 889 goto PARSE_ERROR; 890 parser (14): /* INCLUDE */ 891 call parse_INCLUDE; 892 goto END_CASE; 893 parser (15): /* include */ 894 call parse_include; 895 goto END_CASE; 896 parser (16): /* print */ 897 call parse_print; 898 goto END_CASE; 899 parser (17): /* warn */ 900 call parse_warn; 901 goto END_CASE; 902 parser (18): /* abort */ 903 call parse_abort; 904 goto END_CASE; 905 parser (19): 906 call parse_set; 907 goto END_CASE; 908 909 END_CASE: 910 end /* while loop */; 911 912 last_result = tokenx; 913 call finish_up_macro; 914 goto check_depth; 915 916 PARSE_ERROR: 917 call clear_macro_frame; 918 goto check_depth; 919 920 /* having finished a source or macro, anything left on stack ? */ 921 922 check_depth: 923 call enter_previous_source; 924 925 end /* source_depth loop */; 926 927 /* having finished all sources or error of severity 4 */ 928 929 unrecoverable_error: 930 temp_seg_3.output_length = max (output_index, 0); 931 call check_defaults; 932 call macro_lex_cleanup; 933 if code ^= 0 | target_error 934 then code = error_table_$translation_failed; 935 936 return; 937 938 pl1_macro_lex_$cleanup: 939 entry (P_temp_segs); 940 941 temp_segs (*) = P_temp_segs (*); 942 call macro_lex_cleanup; 943 return; 944 945 macro_lex_cleanup: 946 procedure; 947 948 /* terminate all include files. All other storage cleanup is now done by 949* throwing away the allocation segments in pl1_macro by 950* translator_temp_$release_all_segments */ 951 952 declare i fixed binary; 953 954 do i = 1 to temp_seg_3.source_depth; 955 if file_macro_stack (i).source_type = ASCII_SEGMENT 956 then do; 957 call hcs_$terminate_noname (file_macro_stack (i).file.source_ptr, code); 958 end; 959 end; 960 return; 961 end macro_lex_cleanup; 962 3 1 /* BEGIN INCLUDE FILE ... pl1_macro_token_procs.incl.pl1 */ 3 2 make_token: 3 3 procedure; 3 4 3 5 /* Make a Token. Conventions: 3 6* token_type set to the correct type 3 7* token_start set to index of first character of token 3 8* source_index set to index of first character after token */ 3 9 3 10 token_length = source_index - token_start; 3 11 3 12 if token_type = identifier & token_length > max_identifier_length 3 13 then call print_error (2, "Identifier too long.", token_start); 3 14 3 15 tokenx = tokenx + 1; 3 16 if tokenx >= replacement_token_index 3 17 then call print_error (4, "Too many tokens.", token_start); 3 18 3 19 token (tokenx).type = token_type; 3 20 token (tokenx).string_size = token_length; 3 21 token (tokenx).string_ptr, token_ptr = addr (source_string_array (token_start)); 3 22 token (tokenx).created = "0"b; 3 23 token (tokenx).pct_type = pct_type; 3 24 token (tokenx).replace_by = none; 3 25 3 26 end make_token; 3 27 3 28 make_replacement_token: 3 29 procedure (alias_index); 3 30 3 31 declare alias_index fixed binary; /* INPUT: index of token to be copied */ 3 32 3 33 tokenx = tokenx + 1; 3 34 if tokenx >= replacement_token_index 3 35 then call print_error (4, "Too many tokens.", token_start); 3 36 3 37 token (tokenx) = token (alias_index); 3 38 if token (tokenx).replace_by = alias_index 3 39 then token (tokenx).replace_by = none; 3 40 3 41 end make_replacement_token; 3 42 /* END INCLUDE FILE pl1_macro_token_procs.incl.pl1 */ 964 965 /* Scan sequences of 966* 967* Convention: 968* source_index Entry: on character after digit 969* Exit: on stopping break 970**/ 971 scan_past_digits: 972 procedure; 973 974 scan_index = verify (substr (source_string, source_index), digits); 975 if scan_index = 0 976 then do; 977 source_index = source_length + 1; 978 goto end_of_source_reached; 979 end; 980 981 source_index = source_index + scan_index - 1; 982 end scan_past_digits; 983 984 arithmetic_to_bit: 985 procedure (type) returns (bit (4) aligned); 986 declare type fixed binary (8) unsigned; 987 /* INPUT: arithmetic token type */ 988 return (bit (binary (type - min_arithmetic_token, 4), 4)); 989 end arithmetic_to_bit; 990 991 bit_to_arithmetic: 992 procedure (bit_encoding) returns (fixed binary (8) unsigned); 993 declare bit_encoding bit (4) aligned; /* INPUT: arithmetic toke type bit string encoding */ 994 return (binary (bit_encoding, 4) + min_arithmetic_token); 995 end bit_to_arithmetic; 996 997 validate_pct_token: 998 procedure (identifier, pct_type, term_type); 999 1000 /* a procedure to determine if the identifier following the % is valid and which token it represents */ 1001 1002 declare identifier char (*) var; /* INPUT: char string following the % */ 1003 declare pct_type fixed binary (5) unsigned; 1004 /* OUTPUT: index of valid keyword */ 1005 declare term_type fixed binary; /* OUTPUT: terminator of this macro construct */ 1006 1007 declare indx fixed binary; 1008 1009 pct_type = none; 1010 term_type = none; 1011 1012 do indx = lbound (pct_keywords, 1) to hbound (pct_keywords, 1) while (pct_type = none); 1013 if identifier = pct_keywords (indx).name 1014 then do; 1015 pct_type = pct_keywords (indx).m_index; 1016 term_type = pct_keywords (indx).terminator; 1017 end; 1018 end /* do loop */; 1019 1020 /* if the identifier is not recognized, pct_type is set to none */ 1021 1022 end validate_pct_token; 1023 1024 check_defaults: 1025 procedure; 1026 1027 /* a procedure to insure that all params have been declared in a %default statement */ 1028 1029 declare a_ptr pointer; 1030 1031 a_ptr = temp_seg_3.variable_base; 1032 do while (a_ptr ^= null); 1033 if a_ptr -> variable.variable_type = parameter_var 1034 then call print_error$null (2, "The parameter " || a_ptr -> variable.name || " has no default value."); 1035 a_ptr = a_ptr -> variable.next; 1036 end; 1037 1038 end check_defaults; 1039 1040 set_default_flag: 1041 procedure (var_id); 1042 1043 declare var_id pointer; /* INPUT: id of variable returned by lookup */ 1044 1045 var_id -> variable.variable_type = default_var; 1046 1047 end set_default_flag; 1048 1049 reset_variable_alias: 1050 procedure (var_id, alias_id); 1051 1052 declare var_id pointer; /* INPUT: id of var as returned by lookup */ 1053 declare alias_id fixed binary; /* INPUT: index of token with new replacement value */ 1054 1055 var_id -> variable.alias_id = alias_id; 1056 1057 end reset_variable_alias; 1058 1059 output_chars: 1060 procedure (charsz); 1061 1062 declare charsz character (*) /* INPUT: chars to be output */; 1063 declare bump fixed binary (21); 1064 1065 bump = length (charsz); 1066 call test_length; 1067 substr (output_string, output_index + 1, bump) = charsz; 1068 goto bump_length; 1069 1070 output_chars$token: 1071 entry (token_id); 1072 1073 declare token_id fixed binary; /*INPUT: index of token in its array */ 1074 declare based_token_string char (token (real_token).string_size) based (token (real_token).string_ptr); 1075 declare real_token fixed binary; 1076 1077 if token (token_id).replace_by = none 1078 then real_token = token_id; 1079 else real_token = token (token_id).replace_by; 1080 1081 bump = token (real_token).string_size; 1082 call test_length; 1083 substr (output_string, output_index + 1, bump) = based_token_string; 1084 goto bump_length; 1085 1086 output_chars$based: 1087 entry (ch_ptr, num_of_chars); 1088 1089 declare ch_ptr pointer /* INPUT: pointer to a based string */; 1090 declare num_of_chars fixed binary (21) /* INPUT: lenght of above */; 1091 declare based_output_string character (num_of_chars) based (ch_ptr); 1092 bump = num_of_chars; 1093 call test_length; 1094 substr (output_string, output_index + 1, bump) = based_output_string; 1095 goto bump_length; 1096 1097 1098 output_chars$from_source: 1099 entry (from_char, to_char); 1100 1101 declare from_char fixed binary (21) /* INPUT: index in source indicating start */; 1102 declare to_char fixed binary (21); /*INPUT: indicating end */ 1103 bump = to_char - from_char + 1; 1104 call test_length; 1105 substr (output_string, output_index + 1, bump) = substr (source_string, from_char, bump); 1106 goto bump_length; 1107 1108 bump_length: 1109 output_index = output_index + bump; 1110 return; 1111 1112 test_length: 1113 procedure; 1114 1115 if output_index + bump > output_length 1116 then call print_error (4, "Output segment overflow", source_index); 1117 1118 end test_length; 1119 1120 end output_chars; 1121 1122 enter_source_segment: 1123 procedure (bv_source_ptr, bv_source_length, bv_file_number); 1124 1125 /* Internal procedure to set some global variables each time a new source segment is entered */ 1126 1127 /* parameters */ 1128 1129 declare ( 1130 bv_source_ptr ptr, /* ptr to base of source segment */ 1131 bv_source_length fixed bin (21), /* length in chars of source segment */ 1132 bv_file_number fixed bin (8) /* number of new source file */ 1133 ) parameter; 1134 1135 source_type = ASCII_SEGMENT; 1136 source_ptr = bv_source_ptr; 1137 source_length = bv_source_length; 1138 source_index = 1; 1139 token_start = 1; 1140 line_number = 1; 1141 next_char_to_print = 1; 1142 temp_seg_3.source_depth = temp_seg_3.source_depth + 1; 1143 source_number = source_number + 1; 1144 macro_ptr = allocate (temp_seg_3.area_ptr, size (macro_stack)); 1145 macro_depth = 0; 1146 nested_if_level = 0; 1147 1148 end enter_source_segment; 1149 1150 enter_macro_source: 1151 procedure; 1152 1153 /* by analogy to enter_source_segment, to set global variables when entering a macro string for the 1st time */ 1154 1155 source_type = MACRO_CONSTRUCT; 1156 token_index = macro_stack (macro_depth).token_index; 1157 last_token = macro_stack (macro_depth).last_token; 1158 next_free_token = token_index - 1; 1159 first_result = tokenx + 1; 1160 last_result = tokenx; 1161 reinterpret = FALSE; 1162 temp_seg_3.source_depth = temp_seg_3.source_depth + 1; 1163 1164 end enter_macro_source; 1165 1166 save_environment: 1167 procedure; 1168 1169 /* when we are about to leave an environment prematurely, i.e. before the last character or token is seen, 1170* save our location so we can pop back in */ 1171 1172 if temp_seg_3.source_depth > hbound (file_macro_stack, 1) 1173 then call print_error (4, "Include files and macros nested too deeply.", token_start); 1174 1175 if source_type = ASCII_SEGMENT 1176 then do; 1177 file_macro_stack (temp_seg_3.source_depth).source_type = ASCII_SEGMENT; 1178 file_macro_stack (temp_seg_3.source_depth).file.source_ptr = source_ptr; 1179 file_macro_stack (temp_seg_3.source_depth).file.source_index = source_index; 1180 file_macro_stack (temp_seg_3.source_depth).file.source_length = source_length; 1181 file_macro_stack (temp_seg_3.source_depth).file.line_number = line_number; 1182 file_macro_stack (temp_seg_3.source_depth).file.file_number = file_number; 1183 file_macro_stack (temp_seg_3.source_depth).file.next_char_to_print = source_index; 1184 file_macro_stack (temp_seg_3.source_depth).file.macro_depth = macro_depth - 1; 1185 file_macro_stack (temp_seg_3.source_depth).file.macro_ptr = macro_ptr; 1186 file_macro_stack (temp_seg_3.source_depth).file.nested_if_level = nested_if_level; 1187 unspec (file_macro_stack (temp_seg_3.source_depth).macro) = ""b; 1188 end; 1189 else do; 1190 file_macro_stack (temp_seg_3.source_depth).source_type = MACRO_CONSTRUCT; 1191 file_macro_stack (temp_seg_3.source_depth).macro.token_index = token_index; 1192 file_macro_stack (temp_seg_3.source_depth).macro.last_token = last_token; 1193 file_macro_stack (temp_seg_3.source_depth).macro.first_result = first_result; 1194 file_macro_stack (temp_seg_3.source_depth).macro.last_result = last_result; 1195 unspec (file_macro_stack (temp_seg_3.source_depth).file) = ""b; 1196 end; 1197 return; 1198 end save_environment; 1199 1200 enter_previous_source: 1201 procedure; 1202 1203 /* when we have finished processing an include file or macro, this pops us back */ 1204 if source_type ^= ASCII_SEGMENT 1205 then if reinterpret 1206 then goto reinterpret_this_macro; 1207 1208 temp_seg_3.source_depth = temp_seg_3.source_depth - 1; 1209 if temp_seg_3.source_depth < 0 1210 then return; 1211 1212 source_type = file_macro_stack (temp_seg_3.source_depth).source_type; 1213 if source_type = ASCII_SEGMENT /* popping to primary or include file */ 1214 then do; 1215 source_ptr = file_macro_stack (temp_seg_3.source_depth).file.source_ptr; 1216 source_index = file_macro_stack (temp_seg_3.source_depth).file.source_index; 1217 source_length = file_macro_stack (temp_seg_3.source_depth).file.source_length; 1218 line_number = file_macro_stack (temp_seg_3.source_depth).file.line_number; 1219 file_number = file_macro_stack (temp_seg_3.source_depth).file.file_number; 1220 next_char_to_print = file_macro_stack (temp_seg_3.source_depth).file.next_char_to_print; 1221 macro_ptr = file_macro_stack (temp_seg_3.source_depth).file.macro_ptr; 1222 macro_depth = file_macro_stack (temp_seg_3.source_depth).file.macro_depth; 1223 nested_if_level = file_macro_stack (temp_seg_3.source_depth).file.nested_if_level; 1224 end; 1225 1226 else do; /* previous was a macro */ 1227 reinterpret_this_macro: 1228 token_index = file_macro_stack (temp_seg_3.source_depth).macro.token_index; 1229 last_token = file_macro_stack (temp_seg_3.source_depth).macro.last_token; 1230 first_result = file_macro_stack (temp_seg_3.source_depth).macro.first_result; 1231 last_result = file_macro_stack (temp_seg_3.source_depth).macro.last_result; 1232 reinterpret = FALSE; 1233 end; 1234 return; 1235 1236 end enter_previous_source; 1237 1238 /* Centralize lex error reporting. */ 1239 1240 print_error: 1241 procedure (severity, error_string, error_index); 1242 1243 declare severity fixed binary (35); /* (Input) severity of error */ 1244 declare error_string char (*); /* (Input) error message */ 1245 declare error_index fixed binary (21); /* (Input) index into source where error occured */ 1246 1247 call pl1_macro_error_ (severity, error_string, source_ptr, source_index, source_length); 1248 goto print_error_common; 1249 1250 print_error$null: 1251 entry (severity, error_string); 1252 call pl1_macro_error_ (severity, error_string, null, 0, 0); 1253 goto print_error_common; 1254 1255 print_error_common: 1256 if severity >= 4 1257 then goto unrecoverable_error; 1258 end print_error; 1259 1260 parse_if: 1261 procedure; 1262 1263 declare logical_expected bit (1); 1264 declare conditional_true bit (1); 1265 1266 /* syntax: %if %then 1267* [%elseif %then ]... 1268* [%else ] %endif */ 1269 1270 call get_next_token; 1271 logical_expected = TRUE; 1272 do while (logical_expected & token_index < last_token); 1273 1274 /* first evaluate the conditional after the %if or %elseif */ 1275 1276 call parse_expression (result_first, code); 1277 1278 if code ^= 0 1279 then goto PARSE_ERROR; 1280 1281 /* the expression must resolve to a bit_string constant */ 1282 1283 if token (result_first).type ^= bit_string 1284 then do; 1285 call print_error (2, "Wrong data type in %if", token_start); 1286 code = SEMANTIC_ERROR; 1287 goto PARSE_ERROR; 1288 end; 1289 1290 conditional_true = (bit_value (result_first) ^= ""b); 1291 1292 /* next token had better be a %then */ 1293 1294 if token_type = white_space_token 1295 then call get_next_token; 1296 if token (token_index).pct_type ^= pct_then 1297 then do; 1298 call print_error (3, "Missing keyword: %then", token_start); 1299 code = SYNTAX_ERROR; 1300 goto PARSE_ERROR; 1301 end; 1302 1303 if conditional_true 1304 then do; 1305 1306 /* get the tokens till the %elseif, %else, or %endif at the same level 1307* skip the rest of the %if construct */ 1308 1309 call get_this_clause; 1310 logical_expected = FALSE; 1311 end; 1312 1313 else do; 1314 1315 /* conditional is false - skip then-clause 1316* if terminating keyword an %else, get the tokens - elseif it is %elseif, goto top of loop 1317* elseif it is an %endif, stop - else an error */ 1318 1319 call skip_this_clause; 1320 if pct_type = pct_endif 1321 then logical_expected = FALSE; 1322 1323 else if pct_type = pct_else 1324 then do; 1325 call get_this_clause; 1326 logical_expected = FALSE; 1327 end; 1328 1329 else if pct_type ^= pct_elseif 1330 then do; 1331 call print_error (3, "Illegal syntax in a %if.", token_start); 1332 code = SYNTAX_ERROR; 1333 goto PARSE_ERROR; 1334 end; 1335 1336 else call get_next_token; 1337 end /* conditional false */; 1338 end /* while loop */; 1339 1340 /* if loop terminated without and %endif, an error has ooccurred */ 1341 1342 if pct_type ^= pct_endif 1343 then do; 1344 call print_error (3, "Missing %endif.", token_start); 1345 code = SYNTAX_ERROR; 1346 goto PARSE_ERROR; 1347 end; 1348 return; 1349 1350 skip_this_clause: 1351 procedure; 1352 1353 declare action_type fixed binary; 1354 declare if_level fixed binary; 1355 declare terminating_keyword bit (1) aligned; 1356 declare GET_THIS_CLAUSE fixed binary internal static options (constant) initial (1); 1357 declare SKIP_THIS_CLAUSE fixed binary internal static options (constant) initial (2); 1358 declare SKIP_THE_REST fixed binary internal static options (constant) initial (3); 1359 1360 action_type = SKIP_THIS_CLAUSE; 1361 goto common_skip; 1362 1363 get_this_clause: 1364 entry; 1365 action_type = GET_THIS_CLAUSE; 1366 goto common_skip; 1367 1368 common_skip: /* quit when at the same if_level after finding a relevant keyword and 1369* 1370* if skipping then clauses, stop on else at same level */ 1371 if_level = 1; 1372 do while (if_level > 0 & token_index <= last_token); 1373 1374 call get_next_token$retain_white_space; 1375 1376 terminating_keyword = if_level = 1 & (pct_type = pct_elseif | pct_type = pct_else | pct_type = pct_endif); 1377 if pct_type = pct_if 1378 then if_level = if_level + 1; 1379 1380 else if pct_type = pct_endif 1381 then if_level = if_level - 1; 1382 1383 goto what_next (action_type); 1384 1385 what_next (1): /* GET_THIS_CLAUSE: when getting a THEN or ELSE clause, we've reached the end when we find a terminating keyword 1386* at the inital if level. if not at the end, make a replacement token. */ 1387 if terminating_keyword 1388 then action_type = SKIP_THE_REST; 1389 else call make_replacement_token (token_index); 1390 goto end_of_loop; 1391 1392 what_next (2): /* SKIP THIS CLAUSE: skip over all the tokens until we come to a terminating_keyword at the initial if-level */ 1393 if terminating_keyword 1394 then return; 1395 else goto end_of_loop; 1396 1397 what_next (3): /* SKIP_THE_REST: skip over all tokens till the if-level is back to ZERO */ 1398 goto end_of_loop; 1399 1400 end_of_loop: 1401 end /* while loop */; 1402 1403 end skip_this_clause; 1404 1405 end parse_if; 1406 1407 parse_target: 1408 procedure; 1409 1410 declare alias fixed binary; 1411 declare cannon_name char (32); 1412 declare entry_type fixed binary; 1413 declare error_seen bit (1); 1414 declare not_found bit (1) aligned; 1415 declare result_token fixed binary; 1416 declare saved_token_start fixed binary (21); 1417 declare t_code fixed binary (35); 1418 declare t_value fixed binary (17); 1419 declare target_string char (256); 1420 declare var_id pointer; 1421 1422 entry_type = pct_target; 1423 1424 /* if %target used and no -target control arg, set the default and set as error */ 1425 1426 if target_value = none 1427 then do; 1428 target_error = TRUE; 1429 target_value = L68_SYSTEM; 1430 call print_error (2, "%target used without use of -target control arg. L68 assumed.", token_start); 1431 end; 1432 1433 goto common_parse; 1434 1435 parse_isarg: 1436 entry; 1437 1438 entry_type = pct_isarg; 1439 goto common_parse; 1440 1441 parse_isdef: 1442 entry; 1443 1444 entry_type = pct_isdef; 1445 goto common_parse; 1446 1447 common_parse: 1448 error_seen = FALSE; 1449 saved_token_start = token_start; 1450 1451 if token_index < last_token 1452 then call get_next_token; 1453 else do; 1454 call print_error (3, "Incomplete macro statement", saved_token_start); 1455 goto TARGET_ERROR; 1456 end; 1457 1458 if token_type ^= left_parn 1459 then do; 1460 call print_error (3, "Missing left_parentheis in macro-builtin", saved_token_start); 1461 error_seen = TRUE; 1462 end; 1463 1464 if token_index < last_token 1465 then call get_next_token; 1466 else do; 1467 call print_error (3, "Incomplete macro statement", saved_token_start); 1468 goto TARGET_ERROR; 1469 end; 1470 1471 target_string = substr (token_ptr -> based_chars, 1, token_length); 1472 1473 if entry_type = pct_target 1474 then do; 1475 call system_type_ (target_string, cannon_name, t_value, t_code); 1476 if t_value = target_value 1477 then result_token = TRUE_token; 1478 else result_token = FALSE_token; 1479 end; 1480 else if entry_type = pct_isarg 1481 then do; 1482 1483 /* because the command line processor passes any char string as an arg, and the macro only looks at pl1 tokens, for 1484* "wierd" arguments, i.e. non-pl1 tokens, users must quote them to get recognized by the lexer, otherwise, the 1485* raw character string itself suffices, IF it is a SINGLE pl1 token. 1486* The curious code below occurs because dequote_string_ and system_type_ want char (*), but we would much rather 1487* use varying character strings, to kill the terminal blanks. 1488**/ 1489 1490 if token_type = char_string 1491 then target_string = dequote_string_ (rtrim (target_string)); 1492 1493 not_found = TRUE; 1494 do i = 1 to number_of_clargs while (not_found); 1495 not_found = 1496 (target_string 1497 ^= 1498 substr (temp_seg_3.cl_args (i).string_ptr -> based_chars, 1, 1499 temp_seg_3.cl_args (i).string_size)); 1500 end; 1501 1502 if not_found 1503 then result_token = FALSE_token; 1504 else result_token = TRUE_token; 1505 end; 1506 else do; /* isdef */ 1507 call lookup ((target_string), alias, var_type, var_id); 1508 if alias = none 1509 then result_token = FALSE_token; 1510 else result_token = TRUE_token; 1511 end; 1512 1513 if token_index < last_token 1514 then call get_next_token; 1515 else do; 1516 call print_error (3, "Incomplete macro statement", saved_token_start); 1517 goto TARGET_ERROR; 1518 end; 1519 1520 if token_type ^= right_parn 1521 then do; 1522 error_seen = TRUE; 1523 call print_error (3, "Incomplete macro statement", saved_token_start); 1524 end; 1525 1526 if error_seen 1527 then do; 1528 TARGET_ERROR: 1529 code = SYNTAX_ERROR; 1530 goto PARSE_ERROR; 1531 end; 1532 else call make_replacement_token (result_token); 1533 1534 end parse_target; 1535 1536 parse_replace: 1537 procedure; 1538 1539 declare alias fixed binary; 1540 declare entry_name char (8) varying; 1541 declare equals fixed binary; 1542 declare previous_var_type fixed binary; 1543 declare t_type fixed binary; 1544 declare var_id pointer; 1545 declare var_name character (256) varying; 1546 declare var_type fixed binary; 1547 1548 /* format: off */ 1549 declare 1 magic_words (4) aligned structure internal static options (constant), 1550 2 statement_type character (9) varying 1551 initial ( 1552 "replace", "default", "set", "parameter"), 1553 1554 2 preposition character (2) 1555 initial ( 1556 "by", "to", "to", ".."); 1557 /* format: on */ 1558 1559 /* syntax : %replace by ; 1560* %default to ; 1561* %set to ; 1562**/ 1563 1564 var_type = replace_var; 1565 goto common_parse; 1566 1567 parse_default: 1568 entry; 1569 1570 var_type = default_var; 1571 goto common_parse; 1572 1573 parse_set: 1574 entry; 1575 1576 var_type = set_var; 1577 goto common_parse; 1578 1579 common_parse: 1580 entry_name = magic_words (var_type).statement_type; 1581 1582 call get_next_token; 1583 1584 if token_type ^= identifier 1585 then do; 1586 call print_error (3, "The subject of a %" || entry_name || " must be an identifier.", token_start); 1587 code = SYNTAX_ERROR; 1588 goto PARSE_ERROR; 1589 end; 1590 1591 var_name = token_string; 1592 call lookup (var_name, alias, previous_var_type, var_id); 1593 1594 call get_next_token; 1595 if token_string ^= magic_words (var_type).preposition 1596 then do; 1597 call print_error (3, "Illegal syntax in a %" || entry_name, token_start); 1598 code = SYNTAX_ERROR; 1599 goto PARSE_ERROR; 1600 end; 1601 1602 call get_next_token; 1603 call parse_expression (result_first, code); 1604 if code ^= 0 1605 then goto PARSE_ERROR; 1606 1607 /* this token must be copied, for in deeply nested macros, its token number is reusaed */ 1608 1609 result_first = copy_token (result_first); 1610 1611 if token_type = white_space_token 1612 then call get_next_token; 1613 if token_type ^= semi_colon 1614 then do; 1615 call print_error (3, "A %" || entry_name || " statement must end with a semicolon.", token_start); 1616 code = SYNTAX_ERROR; 1617 goto PARSE_ERROR; 1618 end; 1619 1620 if alias = none /* not previously defined */ 1621 then call create_variable (var_name, result_first, var_type); 1622 1623 else if var_type ^= previous_var_type /* already declared in a different mode */ 1624 then do; 1625 1626 /* OKAY to appear in a different mode if previous was a parameter and this is its default statement */ 1627 1628 if previous_var_type = parameter_var & var_type = default_var 1629 then call set_default_flag (var_id); 1630 else call print_error (3, 1631 "The variable " || var_name || " may not appear in a %" || entry_name 1632 || " after appearing in a %" || magic_words (previous_var_type).statement_type, token_start) 1633 ; 1634 end; 1635 1636 else do; /* previously declared in the same mode */ 1637 t_type = op_mix (alias, result_first) /* check for same data type and equal value */; 1638 1639 /* the old and new values must alwasy have the same data type, and if default or replace, the same value */ 1640 1641 if t_type = 0 /* different types */ 1642 then do; 1643 1644 test_redefine (0): /* different types */ 1645 call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); 1646 code = SEMANTIC_ERROR; 1647 goto PARSE_ERROR; 1648 end; 1649 1650 equals = fixed (eq); 1651 1652 if var_type = set_var 1653 then do; 1654 call reset_variable_alias (var_id, result_first); 1655 return; 1656 end; 1657 else goto test_redefine (t_type); 1658 1659 test_redefine (1): /* dec_integer */ 1660 if ^compare_numbers (equals, alias, result_first) 1661 /* redefined to a different integer */ 1662 then do; 1663 call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); 1664 code = SEMANTIC_ERROR; 1665 goto PARSE_ERROR; 1666 end; 1667 return; 1668 1669 test_redefine (2): /* bit_string */ 1670 if ^compare_bit_strings (equals, alias, result_first) 1671 then do; 1672 call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); 1673 code = SEMANTIC_ERROR; 1674 goto PARSE_ERROR; 1675 end; 1676 return; 1677 1678 test_redefine (3): /* char_string */ 1679 if ^compare_chars (equals, alias, result_first) 1680 then do; 1681 call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); 1682 code = SEMANTIC_ERROR; 1683 goto PARSE_ERROR; 1684 end; 1685 return; 1686 1687 test_redefine (4): /* identifier */ 1688 if ^same_identifier (alias, result_first) 1689 then do; 1690 call print_error (3, "Illegal redefinition of identifier: " || var_name, token_start); 1691 code = SEMANTIC_ERROR; 1692 goto PARSE_ERROR; 1693 end; 1694 return; 1695 end; 1696 1697 1698 copy_token: 1699 procedure (original_token) returns (fixed binary); 1700 declare original_token fixed binary /* token to be copied */; 1701 1702 if replacement_token_index <= tokenx 1703 then call print_error$null (4, "Too many tokens."); 1704 1705 token (replacement_token_index) = token (original_token); 1706 token (replacement_token_index).created = TRUE; 1707 replacement_token_index = replacement_token_index - 1; 1708 return (replacement_token_index + 1); 1709 1710 end copy_token; 1711 4 1 /* BEGIN INCLUDE FILE pl1_macro_compare_procs.incl.pl1 */ 4 2 compare_numbers: 4 3 procedure (operation, operand1, operand2) returns (bit (1)); 4 4 declare operation fixed binary; /* INPUT: logical operation */ 4 5 declare (operand1, operand2) fixed binary; /* INPUT: operands */ 4 6 4 7 goto compare (operation); 4 8 4 9 compare (14): 4 10 compare (24): 4 11 return (arith_value (operand1) = arith_value (operand2)); 4 12 compare (15): 4 13 return (arith_value (operand1) ^= arith_value (operand2)); 4 14 compare (16): 4 15 return (arith_value (operand1) < arith_value (operand2)); 4 16 compare (17): 4 17 return (arith_value (operand1) > arith_value (operand2)); 4 18 compare (18): 4 19 return (arith_value (operand1) <= arith_value (operand2)); 4 20 compare (19): 4 21 return (arith_value (operand1) >= arith_value (operand2)); 4 22 compare (20): 4 23 return (arith_value (operand1) ^> arith_value (operand2)); 4 24 compare (21): 4 25 return (arith_value (operand1) ^< arith_value (operand2)); 4 26 4 27 end compare_numbers; 4 28 4 29 compare_chars: 4 30 procedure (operation, operand1, operand2) returns (bit (1)); 4 31 declare operation fixed binary; /* INPUT: logical operation */ 4 32 declare (operand1, operand2) fixed binary; /* INPUT: operands */ 4 33 4 34 goto compare (operation); 4 35 4 36 compare (14): 4 37 compare (24): 4 38 return (char_value (operand1) = char_value (operand2)); 4 39 compare (15): 4 40 return (char_value (operand1) ^= char_value (operand2)); 4 41 compare (16): 4 42 return (char_value (operand1) < char_value (operand2)); 4 43 compare (17): 4 44 return (char_value (operand1) > char_value (operand2)); 4 45 compare (18): 4 46 return (char_value (operand1) <= char_value (operand2)); 4 47 compare (19): 4 48 return (char_value (operand1) >= char_value (operand2)); 4 49 compare (20): 4 50 return (char_value (operand1) ^> char_value (operand2)); 4 51 compare (21): 4 52 return (char_value (operand1) ^< char_value (operand2)); 4 53 4 54 end compare_chars; 4 55 4 56 compare_bit_strings: 4 57 procedure (operation, operand1, operand2) returns (bit (1)); 4 58 declare operation fixed binary; /* INPUT: logical operation */ 4 59 declare (operand1, operand2) fixed binary; /* INPUT: operands */ 4 60 4 61 goto compare (operation); 4 62 4 63 compare (14): 4 64 compare (24): 4 65 return (bit_value (operand1) = bit_value (operand2)); 4 66 compare (15): 4 67 return (bit_value (operand1) ^= bit_value (operand2)); 4 68 compare (16): 4 69 return (bit_value (operand1) < bit_value (operand2)); 4 70 compare (17): 4 71 return (bit_value (operand1) > bit_value (operand2)); 4 72 compare (18): 4 73 return (bit_value (operand1) <= bit_value (operand2)); 4 74 compare (19): 4 75 return (bit_value (operand1) >= bit_value (operand2)); 4 76 compare (20): 4 77 return (bit_value (operand1) ^> bit_value (operand2)); 4 78 compare (21): 4 79 return (bit_value (operand1) ^< bit_value (operand2)); 4 80 4 81 end compare_bit_strings; 4 82 4 83 same_identifier: 4 84 procedure (id1, id2) returns (bit (1)); 4 85 declare (id1, id2) fixed binary; 4 86 4 87 /* long winded way of saying that both tokens are represented by the same char_string */ 4 88 4 89 return (substr (token (id1).string_ptr -> based_chars, 1, token (id1).string_size) = substr (token (id2).string_ptr -> based_chars, 1, token (id2).string_size)); 4 90 4 91 end same_identifier; 4 92 /* END INCLUDE FILE ... pl1_macro_compare_procs.incl.pl1 */ 1712 5 1 /* BEGIN INCLUDE FILE ... pl1_macro_dtype_procs.incl.pl1 */ 5 2 both_arithmetic: 5 3 procedure (opr1, opr2) returns (bit (1)); 5 4 declare (opr1, opr2) fixed binary; /* INPUT - indixes of tokens */ 5 5 5 6 if token (opr1).type = dec_integer & token (opr2).type = dec_integer 5 7 then return ("1"b); 5 8 else return ("0"b); 5 9 end both_arithmetic; 5 10 5 11 both_bit_string: 5 12 procedure (oprx1, oprx2) returns (bit (1)); 5 13 declare (oprx1, oprx2) fixed binary; 5 14 5 15 if token (oprx1).type = bit_string & token (oprx2).type = bit_string 5 16 then return ("1"b); 5 17 else return ("0"b); 5 18 5 19 end both_bit_string; 5 20 5 21 5 22 both_char_string: 5 23 procedure (z1, z2) returns (bit (1)); 5 24 declare (z1, z2) fixed binary; 5 25 5 26 if token (z1).type = char_string & token (z2).type = char_string 5 27 then return ("1"b); 5 28 else return ("0"b); 5 29 end both_char_string; 5 30 5 31 both_identifier: 5 32 procedure (z1, z2) returns (bit (1)); 5 33 declare (z1, z2) fixed binary; 5 34 5 35 if token (z1).type = identifier & token (z2).type = identifier 5 36 then return ("1"b); 5 37 else return ("0"b); 5 38 end both_identifier; 5 39 5 40 op_mix: 5 41 procedure (x1, x2) returns (fixed binary); 5 42 declare (x1, x2) fixed binary; 5 43 5 44 if both_arithmetic (x1, x2) 5 45 then return (1); 5 46 else if both_bit_string (x1, x2) 5 47 then return (2); 5 48 else if both_char_string (x1, x2) 5 49 then return (3); 5 50 else if both_identifier (x1,x2) 5 51 then return (4); 5 52 else return (none); 5 53 end op_mix; 5 54 /* END INCLUDE FILE ... pl1_macro_dtype_procs.incl.pl1 */ 1713 1714 1715 end parse_replace; 1716 1717 parse_page: 1718 procedure; 1719 1720 /* syntax: %page [()]; also for skip 1721* handled by compiler, just diagnose and parrot back in stand alone */ 1722 1723 declare entry_type character (4); 1724 declare saved_token_index fixed binary; 1725 1726 entry_type = "page"; 1727 goto page_skip; 1728 1729 parse_skip: 1730 entry; 1731 1732 entry_type = "skip"; 1733 goto page_skip; 1734 1735 page_skip: 1736 saved_token_index = token_index; 1737 code = 0; 1738 1739 call get_next_token; 1740 1741 if token_type ^= semi_colon 1742 then do; 1743 if token_type ^= left_parn 1744 then code = SYNTAX_ERROR; 1745 1746 call get_next_token; 1747 if token_type ^= dec_integer 1748 then code = SYNTAX_ERROR; 1749 1750 call get_next_token; 1751 if token_type ^= right_parn 1752 then code = SYNTAX_ERROR; 1753 1754 call get_next_token; 1755 if token_type ^= semi_colon 1756 then code = SYNTAX_ERROR; 1757 end; 1758 1759 if code ^= 0 1760 then do; 1761 call print_error (3, "Illegal syntax in %" || entry_type, token_start); 1762 goto PARSE_ERROR; 1763 end; 1764 else do i = saved_token_index to token_index; 1765 call make_replacement_token (i); 1766 end; 1767 1768 return; 1769 end parse_page; 1770 1771 parse_include: 1772 procedure; 1773 1774 declare saved_token_index fixed binary; 1775 declare saved_token_start fixed binary (21); 1776 declare entry_name char (7); 1777 declare include_file_name char (32) varying; 1778 declare include_file_length fixed binary (21); 1779 declare include_file_ptr pointer; 1780 declare i fixed binary; 1781 declare bitcount fixed binary (24); 1782 1783 entry_name = "include"; 1784 goto INCLUDE_COMMON; 1785 1786 parse_INCLUDE: 1787 entry; 1788 1789 entry_name = "INCLUDE"; 1790 goto INCLUDE_COMMON; 1791 1792 INCLUDE_COMMON: 1793 saved_token_index = token_index; 1794 saved_token_start = token_start; 1795 code = 0; 1796 1797 call get_next_token; 1798 1799 if token_type = identifier 1800 then include_file_name = token_string; 1801 else if token_type = char_string 1802 then include_file_name = dequote_string_ (token_string); 1803 else code = SYNTAX_ERROR; 1804 1805 call get_next_token; 1806 if token_type ^= semi_colon 1807 then code = SYNTAX_ERROR; 1808 1809 if code ^= 0 1810 then do; 1811 error_message = "Invalid syntax in %" || entry_name; 1812 call print_error (3, (error_message), saved_token_start); 1813 goto PARSE_ERROR; 1814 end; 1815 else if entry_name = "include" 1816 then do i = saved_token_index to token_index; 1817 call make_replacement_token (i); 1818 end; 1819 1820 else do; /* INCLUDE */ 1821 if length (include_file_name) > 24 1822 then do; 1823 call print_error (3, "Include file name too long.", saved_token_start); 1824 code = STORAGE_SYSTEM_ERROR; 1825 goto PARSE_ERROR; 1826 end; 1827 1828 if file_number > source_list_length 1829 then do; 1830 call print_error (3, "Too many include files.", saved_token_start); 1831 code = IMPLEMENTATION_RESTRICTION; 1832 goto PARSE_ERROR; 1833 end; 1834 1835 if temp_seg_3.source_depth > hbound (file_macro_stack, 1) 1836 then do; 1837 call print_error (3, "Include files and macros nested too deeply.", saved_token_start); 1838 code = IMPLEMENTATION_RESTRICTION; 1839 goto PARSE_ERROR; 1840 end; 1841 1842 include_file_name = include_file_name || ".incl.pl1"; 1843 call find_include_file_$initiate_count (command, source_ptr, (include_file_name), bitcount, 1844 include_file_ptr, code); 1845 1846 if include_file_ptr = null () 1847 then do; 1848 error_message = "Include file: " || include_file_name || " not found."; 1849 call print_error (3, (error_message), saved_token_start); 1850 code = STORAGE_SYSTEM_ERROR; 1851 goto PARSE_ERROR; 1852 end; 1853 else if code ^= 0 1854 then call com_err_ (code, command, "^a", include_file_name); 1855 call save_environment; 1856 file_number = file_number + 1; 1857 include_file_length = divide (bitcount + 8, 9, 24, 0); 1858 call enter_source_segment (include_file_ptr, include_file_length, file_number); 1859 goto source_start (ASCII_SEGMENT); 1860 1861 end; 1862 1863 return; 1864 end parse_include; 1865 1866 parse_error: 1867 procedure; 1868 1869 declare entry_type fixed binary (5) unsigned; 1870 declare error_level fixed binary (35); 1871 declare error_seen bit (1) aligned; 1872 declare error_message_token fixed binary; 1873 declare saved_token_start fixed binary (21); 1874 1875 entry_type = pct_error; 1876 error_level = 3; 1877 goto message_common; 1878 1879 parse_warn: 1880 entry; 1881 entry_type = pct_warn; 1882 error_level = 1; 1883 goto message_common; 1884 1885 parse_abort: 1886 entry; 1887 entry_type = pct_abort; 1888 error_level = 4; 1889 goto message_common; 1890 1891 parse_print: 1892 entry; 1893 entry_type = pct_print; 1894 error_level = 0; 1895 goto message_common; 1896 1897 message_common: 1898 error_seen = FALSE; 1899 saved_token_start = token_start; 1900 1901 if token_index < last_token 1902 then call get_next_token; 1903 else do; 1904 call print_error (3, "Incomplete macro statement", saved_token_start); 1905 goto message_error; 1906 end; 1907 1908 call parse_expression (error_message_token, code); 1909 if code ^= 0 1910 then goto message_error; 1911 1912 if token (error_message_token).type ^= char_string 1913 then do; 1914 call print_error (3, "Macro user messages must be character strings", saved_token_start); 1915 goto message_error; 1916 end; 1917 1918 if token_type = white_space_token 1919 then call get_next_token; 1920 1921 if token_type ^= semi_colon 1922 then do; 1923 call print_error (3, "Macro user messages must end in a semicolon", saved_token_start); 1924 goto message_error; 1925 end; 1926 1927 if entry_type = pct_print 1928 then call ioa_ (char_value (error_message_token)); 1929 else call print_error$null (error_level, char_value (error_message_token)); 1930 return; 1931 1932 message_error: 1933 code = SYNTAX_ERROR; 1934 goto PARSE_ERROR; 1935 1936 end parse_error; 1937 6 1 /* BEGIN INCLUDE FILE ... pl1_macro_next_token.incl.pl1 */ 6 2 6 3 get_next_token: 6 4 procedure; 6 5 6 6 /* In the standard entry, find the next non-white-space or comment token. 6 7* Otherwise, return after the next token */ 6 8 6 9 declare standard_entry bit (1); 6 10 6 11 standard_entry = TRUE; 6 12 goto common_code; 6 13 6 14 get_next_token$retain_white_space: 6 15 entry; 6 16 6 17 standard_entry = FALSE; 6 18 goto common_code; 6 19 6 20 common_code: 6 21 do while (TRUE); 6 22 token_index = token_index + 1; 6 23 if token_index < lbound (token, 1) | token_index > last_token 6 24 then do; 6 25 token_type = no_token; 6 26 pct_type = none; 6 27 token_length = 0; 6 28 token_start = 0; 6 29 token_ptr = null (); 6 30 end; 6 31 else do; 6 32 token_type = token (token_index).type; 6 33 pct_type = token (token_index).pct_type; 6 34 token_length = token (token_index).string_size; 6 35 token_ptr = token (token_index).string_ptr; 6 36 token_start = char_offset_ (token_ptr); 6 37 end; 6 38 6 39 if (standard_entry & (token_type ^= white_space_token & token_type ^= comment_token)) | ^standard_entry 6 40 then return; 6 41 6 42 end; 6 43 6 44 end get_next_token; 6 45 6 46 /* END INCLUDE FILE ... pl1_macro_next_token.incl.pl1 */ 1939 1940 create_char_token: 1941 procedure (char_value) returns (fixed binary); 1942 declare char_value char (*); /* INPUT: the name of the identifier */ 1943 declare t_ptr pointer; 1944 declare t_type fixed binary (8) unsigned; 1945 declare chars char (256) varying; 1946 1947 t_type = char_string; 1948 chars = char_value; 1949 goto create_common; 1950 1951 create_identifier_token: 1952 entry (char_value) returns (fixed binary); 1953 t_type = identifier; 1954 chars = requote_string_ (char_value); 1955 goto create_common; 1956 1957 create_bit_token: 1958 entry (b_value) returns (fixed binary); 1959 declare b_value bit (*); 1960 t_type = bit_string; 1961 chars = QUOTE || char (b_value) || QUOTE || "b" /* give it pl1 representation */; 1962 goto create_common; 1963 1964 create_arith_token: 1965 entry (a_value) returns (fixed binary); 1966 declare a_value fixed binary (71); 1967 t_type = dec_integer; 1968 chars = ltrim (char (a_value)); 1969 goto create_common; 1970 1971 create_common: 1972 constant_length = length (chars); 1973 if t_type = char_string & constant_length > max_char_string_constant 1974 then do; 1975 call print_error$null (2, "Character-string constant too long."); 1976 return (none); 1977 end; 1978 else if t_type = bit_string & constant_length > max_bit_string_constant 1979 then do; 1980 call print_error$null (2, "Bit-string constant too long."); 1981 return (none); 1982 end; 1983 else if t_type = identifier & constant_length > max_identifier_length 1984 then do; 1985 call print_error$null (2, "Identifier too long."); 1986 return (none); 1987 end; 1988 if replacement_token_index <= tokenx 1989 then do; 1990 call print_error$null (4, "Too many tokens."); 1991 return (none); 1992 end; 1993 1994 t_ptr = allocate (temp_seg_3.area_ptr, size (constant)); 1995 t_ptr -> constant.next = temp_seg_3.constant_base; 1996 token (replacement_token_index).string_size, t_ptr -> constant.string_length = constant_length; 1997 token (replacement_token_index).type = t_type; 1998 t_ptr -> string_value = chars; 1999 token (replacement_token_index).string_ptr = addr (t_ptr -> constant.string_value); 2000 token (replacement_token_index).created = TRUE; 2001 token (replacement_token_index).pct_type = none; 2002 token (replacement_token_index).replace_by = none; 2003 replacement_token_index = replacement_token_index - 1; 2004 temp_seg_3.constant_base = t_ptr; 2005 return (replacement_token_index + 1); 2006 2007 end create_char_token; 2008 7 1 /* BEGIN INCLUDE FILE ... pl1_macro_value_procs.incl.pl1 */ 7 2 bit_value: 7 3 procedure (token_num) returns (bit (253) varying ); 7 4 declare token_num fixed binary; 7 5 declare b_length fixed binary; 7 6 7 7 /* this assumes that the caller has checked that the token_type bit_string 7 8* and we remove the trailing b and dequote to gewt all 1's and 0's */ 7 9 7 10 b_length = token (token_num).string_size - 3; 7 11 return (bit (dequote_string_ (substr (token (token_num).string_ptr -> 7 12 based_chars, 1, b_length + 2)), b_length)); 7 13 7 14 end bit_value; 7 15 7 16 arith_value: 7 17 procedure (token_num) returns (fixed binary (35)); 7 18 declare token_num fixed binary; 7 19 7 20 /* assumes caller has checked type of token */ 7 21 7 22 return (fixed (substr (token (token_num).string_ptr -> based_chars, 1, token (token_num).string_size), 35)); 7 23 end arith_value; 7 24 7 25 char_value: 7 26 procedure (token_num) returns (char (256) varying); 7 27 declare token_num fixed binary; 7 28 7 29 return (dequote_string_ (substr (token (token_num).string_ptr -> based_chars, 1, token (token_num).string_size))); 7 30 7 31 end char_value; 7 32 7 33 requote_string_: 7 34 procedure (instring) returns (char (256) varying); 7 35 declare instring char (*); /* INPUT: string to be requoted */ 7 36 declare outstring char (256); 7 37 declare (inlength, outlength, indx, scan) 7 38 fixed binary (21); 7 39 declare (index, length, substr) 7 40 builtin; 7 41 7 42 inlength = length (instring); 7 43 outlength = 1; 7 44 indx = 1; 7 45 substr (outstring, 1, 1) = QUOTE; 7 46 7 47 do while (indx <= inlength); 7 48 scan = index (substr (instring, indx), QUOTE); 7 49 /* how many chars till the QUOTE */ 7 50 if scan = 0 /* no more QUOTES, just rest of string */ 7 51 then do; /* copy the remainder */ 7 52 substr (outstring, outlength + 1, inlength - indx + 1) = substr (instring, indx); 7 53 outlength = outlength + inlength - indx + 1; 7 54 indx = inlength + 1; 7 55 end; 7 56 else do; /* tack on till the QUOTE and a QUOTEQUOTE */ 7 57 substr (outstring, outlength + 1, scan - 1) = substr (instring, indx, scan - 1); 7 58 outlength = outlength + scan; 7 59 substr (outstring, outlength, 2) = QUOTEQUOTE; 7 60 outlength = outlength + 1; 7 61 indx = indx + scan; 7 62 end /* else clause */; 7 63 end /* while loop */; 7 64 7 65 /* take on the final QUOTE and return */ 7 66 7 67 outlength = outlength + 1; 7 68 substr (outstring, outlength, 1) = QUOTE; 7 69 return (substr (outstring, 1, outlength)); 7 70 7 71 end requote_string_; 7 72 7 73 dequote_string_: 7 74 procedure (instring) returns (char (256) varying); 7 75 declare instring char (*); /* INPUT: string to be requoted */ 7 76 declare outstring char (256); 7 77 declare NULLSTRING char (0) internal static options (constant) initial (""); 7 78 declare (inlength, outlength, indx, scan) 7 79 fixed binary (21); 7 80 declare (index, length, substr) 7 81 builtin; 7 82 7 83 inlength = length (instring); 7 84 7 85 if inlength < 2 then return (NULLSTRING); 7 86 if substr (instring,1,1) ^= QUOTE | substr (instring, inlength,1) ^= QUOTE 7 87 then return (NULLSTRING); 7 88 7 89 outlength = 0; 7 90 indx = 2; 7 91 7 92 7 93 do while (indx <= inlength - 1); 7 94 scan = index (substr (instring, indx, inlength - indx), QUOTE) -1 ; 7 95 /* how many chars till the QUOTE */ 7 96 if scan = -1 /* no more QUOTES, just rest of string */ 7 97 then do; /* copy the remainder */ 7 98 substr (outstring, outlength + 1, inlength - indx) = substr (instring, indx, inlength -indx); 7 99 outlength = outlength + inlength - indx; 7 100 indx = inlength + 1; 7 101 end; 7 102 else do; /* tack on till the QUOTE and replace QUOTE with QUOTEQUOTE */ 7 103 substr (outstring, outlength + 1, scan ) = substr (instring, indx, scan ); 7 104 outlength = outlength + scan; 7 105 indx = indx + scan; 7 106 if substr (instring,indx, 2) ^= QUOTEQUOTE 7 107 then return (NULLSTRING); 7 108 substr (outstring, outlength+1, 1 )= QUOTE;indx = indx + 2; 7 109 outlength = outlength + 1; 7 110 end /* else clause */; 7 111 end /* while loop */; 7 112 7 113 return (substr (outstring, 1, outlength)); 7 114 7 115 end dequote_string_; 7 116 7 117 /* END INCLUDE FILE ... pl1_macro_value_procs.incl.pl1 */ 2009 2010 2011 parse_expression: 2012 procedure (result_token, code); 2013 2014 declare result_token fixed binary; /* OUTPUT: index of token in which result is placed */ 2015 declare code fixed binary (35); /* OUTPUT: status code */ 2016 2017 declare stack_index fixed binary; /* top of stack */ 2018 declare opindex fixed binary; /* location of operator in op_table */ 2019 declare (operand1, operand2) fixed binary; /* token offsets of the two operands */ 2020 declare result fixed binary; /* token offset of result */ 2021 declare stack (0:64) fixed binary; 2022 2023 /* format: off */ 2024 declare precedence (0:24) fixed binary (15) internal static options (constant) 2025 initial ( 2026 (5) 0, /* illegal */ 2027 5, /* +, plus */ 2028 5, /* -, minus */ 2029 6, /* *, asterisk */ 2030 6, /* /, slash */ 2031 7, /* **, expon */ 2032 7, /* ^, not */ 2033 2, /* &, and */ 2034 1, /* |, or */ 2035 4, /* ||, cat */ 2036 3, /* =, eq */ 2037 3, /* ^=, ne */ 2038 3, /* <, lt */ 2039 3, /* >, gt */ 2040 3, /* <=, le */ 2041 3, /* >=, ge */ 2042 3, /* ^>, ngt */ 2043 3, /* ^<, nlt */ 2044 7, /* +, unary plus */ 2045 7, /* -, unary minus */ 2046 3); /* =, assignment */ 2047 /* format: on */ 2048 2049 stack_index = 0; 2050 stack (0) = primitive (); 2051 2052 FETCHOP: 2053 CHECKOP: 2054 if token_type = white_space_token 2055 then call get_next_token; 2056 if (token_type <= max_delimiter_token) & (token_type >= min_delimiter_token) & (token_type <= assignment) 2057 then do; /* i.e. relational and arith operator */ 2058 2059 if token_type = not /* unary operators handled by primitive */ 2060 then do; 2061 call print_error (3, "Invalid syntax in expression", source_index); 2062 goto EXP_PARSE_FAIL; 2063 end; 2064 2065 if stack_index ^= 0 /* check precedence is not first operator */ 2066 then do; 2067 opindex = token (stack (stack_index - 1)).type; 2068 if precedence (opindex) >= precedence (token_type) 2069 then goto UNSTACK; 2070 end; 2071 2072 STACKOP: 2073 stack_index = stack_index + 1; 2074 stack (stack_index) = token_index; 2075 stack_index = stack_index + 1; 2076 call get_next_token; 2077 if token_index > last_token 2078 then do; 2079 call print_error (3, "Invalid syntax in expression.", source_index); 2080 goto EXP_PARSE_FAIL; 2081 end; 2082 stack (stack_index) = primitive (); 2083 goto FETCHOP; 2084 2085 end; 2086 2087 if stack_index = 0 2088 then goto SUCCESS; 2089 opindex = token (stack (stack_index - 1)).type; 2090 2091 UNSTACK: 2092 operand1 = stack (stack_index - 2); 2093 operand2 = stack (stack_index); 2094 2095 result = evaluate (opindex, operand1, operand2); 2096 2097 if result = none 2098 then do; 2099 call print_error (3, "Semantically incorrect expression.", source_index); 2100 goto EXP_PARSE_FAIL; 2101 end; 2102 2103 POP: 2104 stack_index = stack_index - 2; 2105 stack (stack_index) = result; 2106 2107 goto CHECKOP; 2108 2109 EXP_PARSE_FAIL: 2110 result_token = none; 2111 code = -1; 2112 return; 2113 2114 SUCCESS: 2115 result_token = stack (0); 2116 code = 0; 2117 return; 2118 2119 primitive: 2120 procedure returns (fixed binary); 2121 2122 /* calling conventions: token_index points to the current token, token_type been set properly. 2123* on return token_index will point the the next token (possibly white space) in the input sequence */ 2124 2125 2126 declare next_tk fixed binary; /* value of token returned by recursive calls */ 2127 declare saved_token_index fixed binary; /* index of token at entry */ 2128 2129 saved_token_index = token_index; 2130 2131 if token_type = plus /* unary plus */ 2132 then do; 2133 call get_next_token; 2134 next_tk = primitive (); 2135 2136 if token (next_tk).type = dec_integer 2137 then return (next_tk); 2138 else do; 2139 call print_error (3, "Invalid syntax in expression.", source_index); 2140 goto PRIMITIVE_FAIL; 2141 end; 2142 end; 2143 2144 else if token_type = minus /*unary minus */ 2145 then do; 2146 call get_next_token; 2147 next_tk = primitive (); 2148 2149 if token (next_tk).type = dec_integer 2150 then return (create_arith_token (-arith_value (next_tk))); 2151 else do; 2152 call print_error (3, "Invalid syntax in expression.", source_index); 2153 goto PRIMITIVE_FAIL; 2154 end; 2155 end; 2156 2157 else if token_type = not 2158 then do; 2159 call get_next_token; 2160 next_tk = primitive (); 2161 2162 if token (next_tk).type = bit_string 2163 then return (create_bit_token (^bit_value (next_tk))); 2164 else do; 2165 call print_error (3, "Invalid syntax in expression.", source_index); 2166 goto PRIMITIVE_FAIL; 2167 end; 2168 end; 2169 2170 else if token_type = left_parn 2171 then do; 2172 call get_next_token; 2173 call parse_expression (result, code); 2174 2175 if code ^= 0 2176 then goto PRIMITIVE_FAIL; 2177 if token_type = white_space_token 2178 then call get_next_token; 2179 if token_type ^= right_parn 2180 then do; 2181 call print_error (3, "Invalid syntax in expression.", source_index); 2182 goto PRIMITIVE_FAIL; 2183 end; 2184 else do; 2185 call get_next_token$retain_white_space; 2186 return (result); 2187 end; 2188 end; 2189 2190 else if (token_type <= max_constant_token & token_type >= min_constant_token) | (token_type = identifier) 2191 then do; 2192 if token_type = identifier & token (saved_token_index).replace_by ^= none 2193 then saved_token_index = token (saved_token_index).replace_by; 2194 call get_next_token$retain_white_space; 2195 return (saved_token_index); 2196 end; 2197 2198 else do; 2199 code = -1; 2200 call print_error (3, "Invalid syntax in expression.", source_index); 2201 return (none); 2202 end; 2203 2204 PRIMITIVE_FAIL: 2205 goto EXP_PARSE_FAIL; 2206 end primitive; 2207 8 1 /* BEGIN INCLUDE FILE ... pl1_macro_next_token.incl.pl1 */ 8 2 8 3 get_next_token: 8 4 procedure; 8 5 8 6 /* In the standard entry, find the next non-white-space or comment token. 8 7* Otherwise, return after the next token */ 8 8 8 9 declare standard_entry bit (1); 8 10 8 11 standard_entry = TRUE; 8 12 goto common_code; 8 13 8 14 get_next_token$retain_white_space: 8 15 entry; 8 16 8 17 standard_entry = FALSE; 8 18 goto common_code; 8 19 8 20 common_code: 8 21 do while (TRUE); 8 22 token_index = token_index + 1; 8 23 if token_index < lbound (token, 1) | token_index > last_token 8 24 then do; 8 25 token_type = no_token; 8 26 pct_type = none; 8 27 token_length = 0; 8 28 token_start = 0; 8 29 token_ptr = null (); 8 30 end; 8 31 else do; 8 32 token_type = token (token_index).type; 8 33 pct_type = token (token_index).pct_type; 8 34 token_length = token (token_index).string_size; 8 35 token_ptr = token (token_index).string_ptr; 8 36 token_start = char_offset_ (token_ptr); 8 37 end; 8 38 8 39 if (standard_entry & (token_type ^= white_space_token & token_type ^= comment_token)) | ^standard_entry 8 40 then return; 8 41 8 42 end; 8 43 8 44 end get_next_token; 8 45 8 46 /* END INCLUDE FILE ... pl1_macro_next_token.incl.pl1 */ 2209 2210 evaluate: 2211 procedure (P_operation, P_op1, P_op2) returns (fixed binary); 2212 2213 declare P_operation fixed binary; /* INPUT: arithemtic or logicl op */ 2214 declare (P_op1, P_op2) fixed binary; /* INPUT: the operands */ 2215 2216 /* given an op_code and two operands, return the index of the token 2217*node created with the result stored there */ 2218 2219 declare (fixedoverflow, overflow, zerodivide, underflow, error, stringrange) 2220 condition; 2221 declare (op1, op2, operation) fixed binary; 2222 declare temp_chars character (256); 2223 2224 op1 = P_op1; 2225 op2 = P_op2; 2226 operation = P_operation; 2227 2228 on fixedoverflow goto FIXEDOVERFLOW; 2229 on overflow goto OVERFLOW; 2230 on zerodivide goto ZERODIVIDE; 2231 on underflow goto UNDERFLOW; 2232 on error goto ERROR; 2233 on stringrange goto STRINGRANGE; 2234 2235 if operation < lbound (eval_action, 1) | operation > hbound (eval_action, 1) 2236 then do; 2237 call print_error (3, "Illegal operator in expression.", source_index); 2238 return (none); 2239 end; 2240 goto eval_action (operation); 2241 2242 eval_action (0): /* illegal op */ 2243 eval_action (1): 2244 eval_action (2): 2245 eval_action (3): 2246 eval_action (4): 2247 eval_action (10): /* unary not */ 2248 eval_action (22): /* unary plus */ 2249 eval_action (23): /* unary minus */ 2250 call print_error (3, "Illegal operator in expression.", source_index); 2251 return (none); 2252 2253 eval_action (5): /* plus */ 2254 if both_arithmetic (op1, op2) 2255 then return (create_arith_token (arith_value (op1) + arith_value (op2))); 2256 else do; 2257 call eval_err ("+"); 2258 return (none); 2259 end; 2260 eval_action (6): /* minus */ 2261 if both_arithmetic (op1, op2) 2262 then return (create_arith_token (arith_value (op1) - arith_value (op2))); 2263 else do; 2264 call eval_err ("-"); 2265 return (none); 2266 end; 2267 eval_action (7): /* times */ 2268 if both_arithmetic (op1, op2) 2269 then return (create_arith_token (arith_value (op1) * arith_value (op2))); 2270 else do; 2271 call eval_err ("*"); 2272 return (none); 2273 end; 2274 2275 eval_action (8): /* divide */ 2276 if both_arithmetic (op1, op2) 2277 then return (create_arith_token (arith_value (op1) / arith_value (op2))); 2278 else do; 2279 call eval_err ("/"); 2280 return (none); 2281 end; 2282 eval_action (9): /* expon */ 2283 if both_arithmetic (op1, op2) 2284 then return (create_arith_token (arith_value (op1) ** arith_value (op2))); 2285 else do; 2286 call eval_err ("**"); 2287 return (none); 2288 end; 2289 2290 eval_action (11): /* & (and) */ 2291 if both_bit_string (op1, op2) 2292 then return (create_bit_token (bit_value (op1) & bit_value (op2))); 2293 else do; 2294 call eval_err ("&"); 2295 return (none); 2296 end; 2297 2298 eval_action (12): /* | (or) */ 2299 if both_bit_string (op1, op2) 2300 then return (create_bit_token (bit_value (op1) | bit_value (op2))); 2301 else do; 2302 call eval_err ("|"); 2303 return (none); 2304 end; 2305 eval_action (13): /* || (concat)*/ 2306 if both_char_string (op1, op2) 2307 then do; 2308 temp_chars = requote_string_ (char_value (op1) || char_value (op2)); 2309 return (create_char_token (rtrim (temp_chars))); 2310 end; 2311 else do; 2312 call eval_err ("||"); 2313 return (none); 2314 end; 2315 2316 eval_action (14): /* = (equals relation ) */ 2317 eval_action (15): /* ^= (not_equal) */ 2318 eval_action (16): /* < (less than) */ 2319 eval_action (17): /* > (greater than) */ 2320 eval_action (18): /* <= (lessthan or equal to ) */ 2321 eval_action (19): /* >= (greater than or equal to */ 2322 eval_action (20): /* ^> (ngt) */ 2323 eval_action (21): /* ^< (nlt) */ 2324 eval_action (24): /* assignment = */ 2325 goto operand_types (op_mix (op1, op2)); 2326 2327 operand_types (0): /* operands of different types */ 2328 call print_error (3, "Different data types in a relational expression.", source_index); 2329 return (none); 2330 operand_types (1): /* both arithmetic */ 2331 if compare_numbers (operation, op1, op2) 2332 then return (TRUE_token); 2333 else return (FALSE_token); 2334 2335 operand_types (2): /* both bit_string */ 2336 if compare_bit_strings (operation, op1, op2) 2337 then return (TRUE_token); 2338 else return (FALSE_token); 2339 2340 operand_types (3): /* both character */ 2341 if compare_chars (operation, op1, op2) 2342 then return (TRUE_token); 2343 else return (FALSE_token); 2344 2345 operand_types (4): /* both identifier */ 2346 if operation = eq | operation = assignment 2347 then do; 2348 if same_identifier (op1, op2) 2349 then return (TRUE_token); 2350 else return (FALSE_token); 2351 end; 2352 else if operation = ne 2353 then do; 2354 if same_identifier (op1, op2) 2355 then return (FALSE_token); 2356 else return (TRUE_token); 2357 end; 2358 else do; 2359 call eval_err ("current"); 2360 return (none); 2361 end; 2362 2363 FIXEDOVERFLOW: 2364 call print_error$null (2, "Fixedoverflow condition: result undefined"); 2365 return (none); 2366 2367 OVERFLOW: 2368 call print_error$null (2, "Overflow condition: result undefined"); 2369 return (none); 2370 2371 ZERODIVIDE: 2372 call print_error$null (2, "Zerodivide condition: result undefined"); 2373 return (none); 2374 2375 UNDERFLOW: 2376 call print_error$null (2, "Underflow condition: result undefined"); 2377 return (none); 2378 2379 ERROR: 2380 call print_error$null (2, "Error condition: result undefined"); 2381 return (none); 2382 2383 STRINGRANGE: 2384 call print_error$null (2, "Stringrange condition: result undefined"); 2385 return (none); 2386 2387 eval_err: 2388 procedure (message_chars); 2389 declare message_chars char (*); 2390 error_message = "Illegal data types for the " || message_chars || " operation."; 2391 call print_error (3, (error_message), source_index); 2392 end eval_err; 2393 9 1 /* BEGIN INCLUDE FILE ... pl1_macro_dtype_procs.incl.pl1 */ 9 2 both_arithmetic: 9 3 procedure (opr1, opr2) returns (bit (1)); 9 4 declare (opr1, opr2) fixed binary; /* INPUT - indixes of tokens */ 9 5 9 6 if token (opr1).type = dec_integer & token (opr2).type = dec_integer 9 7 then return ("1"b); 9 8 else return ("0"b); 9 9 end both_arithmetic; 9 10 9 11 both_bit_string: 9 12 procedure (oprx1, oprx2) returns (bit (1)); 9 13 declare (oprx1, oprx2) fixed binary; 9 14 9 15 if token (oprx1).type = bit_string & token (oprx2).type = bit_string 9 16 then return ("1"b); 9 17 else return ("0"b); 9 18 9 19 end both_bit_string; 9 20 9 21 9 22 both_char_string: 9 23 procedure (z1, z2) returns (bit (1)); 9 24 declare (z1, z2) fixed binary; 9 25 9 26 if token (z1).type = char_string & token (z2).type = char_string 9 27 then return ("1"b); 9 28 else return ("0"b); 9 29 end both_char_string; 9 30 9 31 both_identifier: 9 32 procedure (z1, z2) returns (bit (1)); 9 33 declare (z1, z2) fixed binary; 9 34 9 35 if token (z1).type = identifier & token (z2).type = identifier 9 36 then return ("1"b); 9 37 else return ("0"b); 9 38 end both_identifier; 9 39 9 40 op_mix: 9 41 procedure (x1, x2) returns (fixed binary); 9 42 declare (x1, x2) fixed binary; 9 43 9 44 if both_arithmetic (x1, x2) 9 45 then return (1); 9 46 else if both_bit_string (x1, x2) 9 47 then return (2); 9 48 else if both_char_string (x1, x2) 9 49 then return (3); 9 50 else if both_identifier (x1,x2) 9 51 then return (4); 9 52 else return (none); 9 53 end op_mix; 9 54 /* END INCLUDE FILE ... pl1_macro_dtype_procs.incl.pl1 */ 2394 2395 10 1 /* BEGIN INCLUDE FILE pl1_macro_compare_procs.incl.pl1 */ 10 2 compare_numbers: 10 3 procedure (operation, operand1, operand2) returns (bit (1)); 10 4 declare operation fixed binary; /* INPUT: logical operation */ 10 5 declare (operand1, operand2) fixed binary; /* INPUT: operands */ 10 6 10 7 goto compare (operation); 10 8 10 9 compare (14): 10 10 compare (24): 10 11 return (arith_value (operand1) = arith_value (operand2)); 10 12 compare (15): 10 13 return (arith_value (operand1) ^= arith_value (operand2)); 10 14 compare (16): 10 15 return (arith_value (operand1) < arith_value (operand2)); 10 16 compare (17): 10 17 return (arith_value (operand1) > arith_value (operand2)); 10 18 compare (18): 10 19 return (arith_value (operand1) <= arith_value (operand2)); 10 20 compare (19): 10 21 return (arith_value (operand1) >= arith_value (operand2)); 10 22 compare (20): 10 23 return (arith_value (operand1) ^> arith_value (operand2)); 10 24 compare (21): 10 25 return (arith_value (operand1) ^< arith_value (operand2)); 10 26 10 27 end compare_numbers; 10 28 10 29 compare_chars: 10 30 procedure (operation, operand1, operand2) returns (bit (1)); 10 31 declare operation fixed binary; /* INPUT: logical operation */ 10 32 declare (operand1, operand2) fixed binary; /* INPUT: operands */ 10 33 10 34 goto compare (operation); 10 35 10 36 compare (14): 10 37 compare (24): 10 38 return (char_value (operand1) = char_value (operand2)); 10 39 compare (15): 10 40 return (char_value (operand1) ^= char_value (operand2)); 10 41 compare (16): 10 42 return (char_value (operand1) < char_value (operand2)); 10 43 compare (17): 10 44 return (char_value (operand1) > char_value (operand2)); 10 45 compare (18): 10 46 return (char_value (operand1) <= char_value (operand2)); 10 47 compare (19): 10 48 return (char_value (operand1) >= char_value (operand2)); 10 49 compare (20): 10 50 return (char_value (operand1) ^> char_value (operand2)); 10 51 compare (21): 10 52 return (char_value (operand1) ^< char_value (operand2)); 10 53 10 54 end compare_chars; 10 55 10 56 compare_bit_strings: 10 57 procedure (operation, operand1, operand2) returns (bit (1)); 10 58 declare operation fixed binary; /* INPUT: logical operation */ 10 59 declare (operand1, operand2) fixed binary; /* INPUT: operands */ 10 60 10 61 goto compare (operation); 10 62 10 63 compare (14): 10 64 compare (24): 10 65 return (bit_value (operand1) = bit_value (operand2)); 10 66 compare (15): 10 67 return (bit_value (operand1) ^= bit_value (operand2)); 10 68 compare (16): 10 69 return (bit_value (operand1) < bit_value (operand2)); 10 70 compare (17): 10 71 return (bit_value (operand1) > bit_value (operand2)); 10 72 compare (18): 10 73 return (bit_value (operand1) <= bit_value (operand2)); 10 74 compare (19): 10 75 return (bit_value (operand1) >= bit_value (operand2)); 10 76 compare (20): 10 77 return (bit_value (operand1) ^> bit_value (operand2)); 10 78 compare (21): 10 79 return (bit_value (operand1) ^< bit_value (operand2)); 10 80 10 81 end compare_bit_strings; 10 82 10 83 same_identifier: 10 84 procedure (id1, id2) returns (bit (1)); 10 85 declare (id1, id2) fixed binary; 10 86 10 87 /* long winded way of saying that both tokens are represented by the same char_string */ 10 88 10 89 return (substr (token (id1).string_ptr -> based_chars, 1, token (id1).string_size) = substr (token (id2).string_ptr -> based_chars, 1, token (id2).string_size)); 10 90 10 91 end same_identifier; 10 92 /* END INCLUDE FILE ... pl1_macro_compare_procs.incl.pl1 */ 2396 2397 2398 end evaluate; 2399 2400 end parse_expression; 2401 2402 bump_macro_stack: 2403 procedure (start_tk, variety); 2404 declare start_tk fixed binary /* INPUT: first token in macro */; 2405 declare variety fixed binary /* INPUT: macro_type */; 2406 2407 if macro_depth > hbound (macro_stack, 1) 2408 then call print_error (4, "Macros nested too deeply.", char_offset_ ((token (start_tk).string_ptr))); 2409 2410 macro_depth = macro_depth + 1; 2411 macro_stack (macro_depth).type = variety; 2412 macro_stack (macro_depth).token_index = start_tk; 2413 macro_stack (macro_depth).last_token = 0; 2414 macro_stack (macro_depth).first_result = none; 2415 macro_stack (macro_depth).last_result = none; 2416 macro_stack (macro_depth).else_seen = FALSE; 2417 2418 end bump_macro_stack; 2419 2420 clear_macro_frame: 2421 procedure; 2422 2423 tokenx = macro_stack (macro_depth).token_index; 2424 macro_depth = 0; 2425 2426 end clear_macro_frame; 2427 2428 finish_up_macro: 2429 procedure; 2430 2431 declare tokn fixed binary; 2432 2433 /* thread in replacement strings fro this macro - i.e. replace the tokens for the macro by the tokens it generates */ 2434 2435 tokenx = next_free_token; 2436 reinterpret = FALSE; 2437 2438 do tokn = first_result to last_result while (tokn ^= none); 2439 call make_replacement_token (tokn); 2440 reinterpret = reinterpret | needs_reinterpretation (tokn); 2441 end; 2442 2443 if reinterpret 2444 then do; 2445 2446 /* what is now the first-result becomes the first_token in the string to reinterpret, similarly for last_token and last_result. 2447* so, set first_result above the minimal value of last result. */ 2448 2449 file_macro_stack (temp_seg_3.source_depth).token_index = first_result; 2450 file_macro_stack (temp_seg_3.source_depth).last_token = last_result; 2451 file_macro_stack (temp_seg_3.source_depth).first_result = tokenx + 1; 2452 file_macro_stack (temp_seg_3.source_depth).last_result = tokenx; 2453 return; 2454 end; 2455 2456 else if macro_depth = 1 /* not imbedded */ 2457 then do; 2458 call print_token_string (first_result, last_result); 2459 end; 2460 macro_depth = macro_depth - 1; 2461 return; 2462 2463 end finish_up_macro; 2464 2465 print_token_string: 2466 procedure (first, last); 2467 2468 declare (first, last) fixed binary /* first and last token to print */; 2469 declare ix fixed binary; 2470 2471 do ix = first to last while (ix ^= none); 2472 call output_chars$token (ix); 2473 end; 2474 2475 end print_token_string; 2476 2477 needs_reinterpretation: 2478 procedure (tknx) returns (bit (1)); 2479 2480 declare tknx fixed binary /* INPUT: index of token */; 2481 declare t_type fixed binary (5) unsigned; 2482 2483 /* may need reinterpretation if a pct token but not skip page and include in stand alone mode */ 2484 2485 t_type = token (tknx).pct_type; 2486 if t_type = none 2487 then return (FALSE); 2488 else if t_type = pct_skip | t_type = pct_page | t_type = pct_include 2489 then return (FALSE); 2490 else return (TRUE); 2491 2492 end needs_reinterpretation; 2493 2494 create_variable: 2495 procedure (var_name, alias_token, var_type); 2496 declare var_name char (*) var; /* INPUT: name of var to be created */ 2497 declare alias_token fixed binary; /* INPUT: index of token of variable's alias */ 2498 declare var_type fixed binary; /* INPUT: mode of declaration */ 2499 /* OUTPUT: type of statement in which variable declared */ 2500 2501 declare v_ptr pointer; 2502 2503 /* assumed that the caller has checked that this variable name is not duplicated - use lookup for this. 2504* create a variable node for this var_name and stuff in the node the name, 2505* the token to which it refers and then chain it on the list */ 2506 2507 /* automatic */ 2508 2509 declare (hash_index, i, n, n_chars, n_words) fixed bin, 2510 mod_2_sum bit (36) aligned, 2511 four_chars char (4) aligned, 2512 protected bit (18) aligned, 2513 (old_q, q, p, variable_string_ptr) ptr; 2514 2515 /* based */ 2516 2517 declare variable_array_overlay (64) char (4) based (variable_string_ptr), 2518 variable_overlay char (n) based (variable_string_ptr); 2519 2520 /* builtins */ 2521 2522 declare (addr, binary, bool, dim, divide, length, mod, null, substr, unspec) builtin; 2523 2524 /* program */ 2525 2526 variable_string_ptr = addr (substr (var_name, 1)); 2527 2528 n = length (var_name); 2529 n_words = divide (n, 4, 21, 0); 2530 n_chars = n - n_words * 4; 2531 mod_2_sum = ""b; 2532 2533 do i = 1 to n_words; 2534 four_chars = variable_array_overlay (i); 2535 mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); 2536 end; 2537 2538 if n_chars ^= 0 2539 then do; 2540 four_chars = substr (variable_array_overlay (i), 1, n_chars); 2541 mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); 2542 end; 2543 2544 hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1)); 2545 old_q = null; 2546 2547 do q = hash_table (hash_index) repeat (q -> variable.nextv) while (q ^= null); 2548 if n < q -> variable.name_length 2549 then go to insert_variable; 2550 2551 if variable_overlay = q -> variable.name 2552 then do; 2553 return; 2554 end; 2555 old_q = q; 2556 end; 2557 2558 insert_variable: 2559 variable_name_length = length (var_name); 2560 v_ptr = allocate (temp_seg_3.area_ptr, size (variable)); 2561 2562 v_ptr -> variable.name_length = variable_name_length; 2563 v_ptr -> variable.name = var_name; 2564 v_ptr -> variable.alias_id = alias_token; 2565 v_ptr -> variable.variable_type = var_type; 2566 v_ptr -> variable.nextv = q; 2567 v_ptr -> variable.next = temp_seg_3.variable_base; 2568 temp_seg_3.variable_base = v_ptr; 2569 2570 if old_q = null 2571 then hash_table (hash_index) = v_ptr; 2572 else old_q -> variable.nextv = v_ptr; 2573 return; 2574 2575 lookup: 2576 entry (var_name, alias, var_type, var_id); 2577 2578 declare alias fixed binary; /* OUTPUT: index of alias token, if any */ 2579 declare var_id pointer; /* OUTPUT: id of var, used in altering properties of variable */ 2580 2581 /* given an identifier name, determine if it has been defined - 2582* if so, return as its alias, the index of token to which it evaluates 2583* else return none 2584* 2585* var_id and var_type are only meaningful if alias ^= none. 2586* possible values for var_type are: 2587* default_var, replace_var, parameter_var, and set_var. 2588**/ 2589 2590 alias, var_type = none; 2591 var_id = null; 2592 2593 variable_string_ptr = addr (substr (var_name, 1)); 2594 2595 n = length (var_name); 2596 n_words = divide (n, 4, 21, 0); 2597 n_chars = n - n_words * 4; 2598 mod_2_sum = ""b; 2599 2600 do i = 1 to n_words; 2601 four_chars = variable_array_overlay (i); 2602 mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); 2603 end; 2604 2605 if n_chars ^= 0 2606 then do; 2607 four_chars = substr (variable_array_overlay (i), 1, n_chars); 2608 mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); 2609 end; 2610 2611 hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1)); 2612 old_q = null; 2613 2614 do q = hash_table (hash_index) repeat (q -> variable.nextv) while (q ^= null); 2615 if variable_overlay = q -> variable.name 2616 then do; 2617 alias = q -> variable.alias_id; 2618 var_type = q -> variable.variable_type; 2619 var_id = q; 2620 end; 2621 end; 2622 if var_name = "set_opt" | var_name = "symbol_update_at" then do; 2623 return; 2624 end; 2625 return; 2626 end create_variable; 11 1 /* BEGINNING OF: translator_temp_alloc.incl.pl1 * * * * * * * * * * * * * * * * */ 11 2 11 3 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 11 4 /* */ 11 5 /* N__a_m_e: translator_temp_alloc.incl.pl1 */ 11 6 /* */ 11 7 /* This include segment allocates space in a translator's temporary segment. It */ 11 8 /* contains a complete space allocation function 'allocate' which can be a quick PL/I */ 11 9 /* internal procedure in the program which includes this include segment. The temporary */ 11 10 /* segment should be one obtained by using the translator_temp_ subroutine. */ 11 11 /* */ 11 12 /* S__t_a_t_u_s */ 11 13 /* */ 11 14 /* 0) Created by: G. C. Dixon in January, 1975. */ 11 15 /* 1) Modified by: G. C. Dixon in February, 1981 - use limit area structure. */ 11 16 /* */ 11 17 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 11 18 11 19 11 20 11 21 allocate: procedure (Parea, ANwords) returns (ptr); 11 22 11 23 dcl Parea ptr, /* ptr to the temporary segment. (In) */ 11 24 ANwords fixed bin; /* number of words to be allocated. (In) */ 11 25 11 26 dcl Nwords fixed bin, /* number of words to be allocated, rounded up */ 11 27 /* to a 0 mod 2 quantity. */ 11 28 P ptr, /* a temporary pointer. */ 11 29 code fixed bin(35), /* a status code. */ 11 30 (mod, null, ptr) builtin; 11 31 11 32 dcl 1 area based (Parea), 11 33 2 Pfirst_temp_seg ptr unal, /* ptr to first temp seg of a group. */ 11 34 2 Ofree fixed bin(35), /* offset of next free word in temp seg. */ 11 35 2 Lfree fixed bin(35); /* length of remaining free space in temp seg. */ 11 36 11 37 dcl translator_temp_$get_next_segment 11 38 entry (ptr, ptr, fixed bin(35)); 11 39 11 40 Nwords = ANwords + mod (ANwords, 2); /* round up word count to 0 + mod 2 quantity. */ 11 41 if Nwords > Lfree then do; /* handle area overflow. */ 11 42 call translator_temp_$get_next_segment (Parea, P, code); 11 43 if P = null then return (null); 11 44 Parea = P; 11 45 if Nwords > area.Lfree then return (null); 11 46 end; 11 47 P = ptr (Parea, area.Ofree); /* get pointer to next free word of area. */ 11 48 area.Ofree = area.Ofree + Nwords; /* increase offset of remaining free space. */ 11 49 area.Lfree = area.Lfree - Nwords; /* decrease length of remaining free space. */ 11 50 return (P); 11 51 11 52 end allocate; 11 53 11 54 /* END OF: translator_temp_alloc.incl.pl1 * * * * * * * * * * * * * * * * */ 2627 2628 end pl1_macro_lex_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/09/89 0900.0 pl1_macro_lex_.pl1 >spec>install>1087>pl1_macro_lex_.pl1 244 1 12/03/87 1248.1 pl1_macro_lex_dcls.incl.pl1 >ldd>include>pl1_macro_lex_dcls.incl.pl1 1-324 2 06/19/81 2115.0 system_types.incl.pl1 >ldd>include>system_types.incl.pl1 963 3 03/27/82 0429.7 pl1_macro_token_procs.incl.pl1 >ldd>include>pl1_macro_token_procs.incl.pl1 1712 4 03/27/82 0429.8 pl1_macro_compare_procs.incl.pl1 >ldd>include>pl1_macro_compare_procs.incl.pl1 1713 5 03/27/82 0429.8 pl1_macro_dtype_procs.incl.pl1 >ldd>include>pl1_macro_dtype_procs.incl.pl1 1938 6 03/27/82 0429.7 pl1_macro_next_token.incl.pl1 >ldd>include>pl1_macro_next_token.incl.pl1 2009 7 03/27/82 0429.7 pl1_macro_value_procs.incl.pl1 >ldd>include>pl1_macro_value_procs.incl.pl1 2208 8 03/27/82 0429.7 pl1_macro_next_token.incl.pl1 >ldd>include>pl1_macro_next_token.incl.pl1 2394 9 03/27/82 0429.8 pl1_macro_dtype_procs.incl.pl1 >ldd>include>pl1_macro_dtype_procs.incl.pl1 2396 10 03/27/82 0429.8 pl1_macro_compare_procs.incl.pl1 >ldd>include>pl1_macro_compare_procs.incl.pl1 2627 11 07/22/81 2045.0 translator_temp_alloc.incl.pl1 >ldd>include>translator_temp_alloc.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. ANwords parameter fixed bin(17,0) dcl 11-23 ref 11-21 11-40 11-40 ASCII_SEGMENT constant fixed bin(17,0) initial dcl 237 ref 955 1135 1175 1177 1204 1213 1859 FALSE constant bit(1) initial dcl 239 ref 257 1161 1232 1310 1320 1326 1447 1897 6-17 8-17 2416 2436 2486 2488 FALSE_token 000100 automatic fixed bin(17,0) dcl 43 set ref 312* 1478 1502 1508 2333 2338 2343 2350 2354 GET_THIS_CLAUSE constant fixed bin(17,0) initial dcl 1356 ref 1365 HT_SP constant char(2) initial packed unaligned dcl 241 ref 334 IMPLEMENTATION_RESTRICTION constant fixed bin(35,0) initial dcl 1-320 ref 1831 1838 L68_SYSTEM constant fixed bin(17,0) initial dcl 2-3 ref 1429 Lfree 2 based fixed bin(35,0) level 2 dcl 11-32 set ref 11-41 11-45 11-49* 11-49 MACRO_CONSTRUCT constant fixed bin(17,0) initial dcl 238 ref 434 792 811 1155 1190 NULLSTRING constant char initial packed unaligned dcl 7-77 ref 7-85 7-86 7-106 Nwords 000100 automatic fixed bin(17,0) dcl 11-26 set ref 11-40* 11-41 11-45 11-48 11-49 Ofree 1 based fixed bin(35,0) level 2 dcl 11-32 set ref 11-47 11-48* 11-48 P 000102 automatic pointer dcl 11-26 set ref 11-42* 11-43 11-44 11-47* 11-50 P_op1 parameter fixed bin(17,0) dcl 2214 ref 2210 2224 P_op2 parameter fixed bin(17,0) dcl 2214 ref 2210 2225 P_operation parameter fixed bin(17,0) dcl 2213 ref 2210 2226 P_temp_segs parameter pointer array dcl 38 ref 35 249 938 941 Parea parameter pointer dcl 11-23 set ref 11-21 11-41 11-42* 11-44* 11-45 11-47 11-47 11-48 11-48 11-49 11-49 QUOTE 025622 constant char(1) initial packed unaligned dcl 1-303 ref 1961 1961 7-45 7-48 7-68 7-86 7-86 7-94 7-108 QUOTEQUOTE 025621 constant char(2) initial packed unaligned dcl 1-304 ref 7-59 7-106 SEMANTIC_ERROR constant fixed bin(35,0) initial dcl 1-318 ref 1286 1646 1664 1673 1682 1691 SKIP_THE_REST constant fixed bin(17,0) initial dcl 1358 ref 1385 SKIP_THIS_CLAUSE constant fixed bin(17,0) initial dcl 1357 ref 1360 STORAGE_SYSTEM_ERROR constant fixed bin(35,0) initial dcl 1-319 ref 1824 1850 SYNTAX_ERROR constant fixed bin(35,0) initial dcl 1-317 ref 888 1299 1332 1345 1528 1587 1598 1616 1743 1747 1751 1755 1803 1806 1932 TRUE constant bit(1) initial dcl 240 ref 347 1271 1428 1461 1493 1522 1706 6-11 6-20 2000 8-11 8-20 2490 TRUE_token 000101 automatic fixed bin(17,0) dcl 44 set ref 311* 1476 1504 1510 2330 2335 2340 2348 2356 VT_NP 000477 constant char(3) initial packed unaligned dcl 242 ref 583 a_ptr 001000 automatic pointer dcl 1029 set ref 1031* 1032 1033 1033 1035* 1035 a_value parameter fixed bin(71,0) dcl 1966 ref 1964 1968 action_index 000102 automatic fixed bin(17,0) dcl 45 set ref 331* 332 575* 577 577 577 action_table 000523 constant fixed bin(17,0) initial array dcl 193 ref 331 331 575 575 action_type 001102 automatic fixed bin(17,0) dcl 1353 set ref 1360* 1365* 1383 1385* addr builtin function dcl 176 in procedure "pl1_macro_lex_" ref 3-21 1999 addr builtin function dcl 2522 in procedure "create_variable" ref 2526 2593 alias 001114 automatic fixed bin(17,0) dcl 1410 in procedure "parse_target" set ref 1507* 1508 alias parameter fixed bin(17,0) dcl 2578 in procedure "create_variable" set ref 2575 2590* 2617* alias 001246 automatic fixed bin(17,0) dcl 1539 in procedure "parse_replace" set ref 1592* 1620 1637* 1659* 1669* 1678* 1687* alias_id 000103 automatic fixed bin(17,0) dcl 46 in procedure "pl1_macro_lex_" set ref 278* 304 409* 412 417 420* alias_id 2 based fixed bin(17,0) level 2 in structure "variable" packed packed unaligned dcl 1-90 in procedure "pl1_macro_lex_" set ref 1055* 2564* 2617 alias_id parameter fixed bin(17,0) dcl 1053 in procedure "reset_variable_alias" ref 1049 1055 alias_index parameter fixed bin(17,0) dcl 3-31 ref 3-28 3-37 3-38 alias_token parameter fixed bin(17,0) dcl 2497 ref 2494 2564 alphabetics 000462 constant char(52) initial packed unaligned dcl 1-291 ref 707 and constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 area based structure level 1 unaligned dcl 11-32 area_ptr based pointer level 2 dcl 1-67 set ref 264* 267* 1144* 1994* 2560* args based structure level 1 dcl 1-55 arrow constant fixed bin(8,0) initial unsigned dcl 1-112 ref 627 assignment constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 2056 2345 asterisk constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 atoken based structure level 1 dcl 1-36 ref 252 834 b_length 000100 automatic fixed bin(17,0) dcl 7-5 set ref 7-10* 7-11 7-11 7-11 b_value parameter bit packed unaligned dcl 1959 ref 1957 1961 based_chars based char(256) packed unaligned dcl 169 ref 274 281 291 291 291 291 1471 1495 4-89 4-89 7-11 7-11 7-22 7-29 7-29 10-89 10-89 based_output_string based char packed unaligned dcl 1091 ref 1094 based_token_string based char packed unaligned dcl 1074 ref 1083 bin builtin function dcl 176 ref 299 299 binary builtin function dcl 176 in procedure "pl1_macro_lex_" ref 988 994 binary builtin function dcl 2522 in procedure "create_variable" ref 2544 2611 bit builtin function dcl 176 ref 291 291 593 988 7-11 bit_encoding parameter bit(4) dcl 993 ref 991 994 bit_string constant fixed bin(8,0) initial unsigned dcl 1-112 ref 291 375 1283 5-15 5-15 1960 1978 2162 9-15 9-15 bitcount 001517 automatic fixed bin(24,0) dcl 1781 set ref 1843* 1857 bool builtin function dcl 2522 ref 2535 2541 2602 2608 bump 001024 automatic fixed bin(21,0) dcl 1063 set ref 1065* 1067 1081* 1083 1092* 1094 1103* 1105 1105 1108 1115 bv_file_number parameter fixed bin(8,0) dcl 1129 ref 1122 bv_source_length parameter fixed bin(21,0) dcl 1129 ref 1122 1137 bv_source_ptr parameter pointer dcl 1129 ref 1122 1136 cannon_name 001115 automatic char(32) packed unaligned dcl 1411 set ref 1475* cat constant fixed bin(8,0) initial unsigned dcl 1-112 ref 691 ch_ptr parameter pointer dcl 1089 ref 1086 1094 char builtin function dcl 176 ref 302 593 1961 1968 char_offset_ 000010 constant entry external dcl 181 ref 6-36 8-36 2407 2407 char_string constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 288 383 1490 5-26 5-26 1801 1912 1947 1973 9-26 9-26 char_value parameter char packed unaligned dcl 1942 set ref 1940 1948 1951 1954* chars 000103 automatic varying char(256) dcl 1945 set ref 1948* 1954* 1961* 1968* 1971 1998 charsz parameter char packed unaligned dcl 1062 ref 1059 1065 1067 cl_args 22 based structure array level 2 dcl 1-67 cl_params 222 based structure array level 2 dcl 1-67 code 000104 automatic fixed bin(35,0) dcl 11-26 in procedure "allocate" set ref 11-42* code parameter fixed bin(35,0) dcl 39 in procedure "pl1_macro_lex_" set ref 35 248* 888* 933 933* 957* 1276* 1278 1286* 1299* 1332* 1345* 1528* 1587* 1598* 1603* 1604 1616* 1646* 1664* 1673* 1682* 1691* 1737* 1743* 1747* 1751* 1755* 1759 1795* 1803* 1806* 1809 1824* 1831* 1838* 1843* 1850* 1853 1853* 1908* 1909 1932* code parameter fixed bin(35,0) dcl 2015 in procedure "parse_expression" set ref 2011 2111* 2116* 2173* 2175 2199* colon constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 com_err_ 000014 constant entry external dcl 184 ref 1853 comma constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 command 000457 constant char(9) initial packed unaligned dcl 1-311 set ref 1843* 1853* comment_token constant fixed bin(8,0) initial unsigned dcl 1-112 ref 449 6-39 8-39 conditional_true 001073 automatic bit(1) packed unaligned dcl 1264 set ref 1290* 1303 constant based structure level 1 dcl 1-103 set ref 1994 1994 constant_base 6 based pointer level 2 dcl 1-67 set ref 1995 2004* constant_length 000703 automatic fixed bin(21,0) dcl 1-108 set ref 1971* 1973 1978 1983 1994 1994 1996 created 0(22) based bit(1) array level 2 packed packed unaligned dcl 1-46 set ref 3-22* 1706* 2000* current_char 000104 automatic char(1) packed unaligned dcl 47 set ref 326* 329 331 574* 575 593 593 593 598 598 598 602 dec_integer constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 299 5-6 5-6 1747 1967 2136 2149 9-6 9-6 default_var constant fixed bin(17,0) initial dcl 1-247 ref 1045 1570 1628 digits 000520 constant char(10) initial packed unaligned dcl 232 ref 475 974 dim builtin function dcl 2522 ref 2544 2611 divide builtin function dcl 2522 in procedure "create_variable" ref 2529 2596 divide builtin function dcl 176 in procedure "pl1_macro_lex_" ref 252 834 1857 else_seen 5 based bit(1) array level 2 dcl 153 set ref 765 772* 2416* entry_name 001247 automatic varying char(8) dcl 1540 in procedure "parse_replace" set ref 1579* 1586 1597 1615 1630 entry_name 001500 automatic char(7) packed unaligned dcl 1776 in procedure "parse_include" set ref 1783* 1789* 1811 1815 entry_type 001530 automatic fixed bin(5,0) unsigned dcl 1869 in procedure "parse_error" set ref 1875* 1881* 1887* 1893* 1927 entry_type 001125 automatic fixed bin(17,0) dcl 1412 in procedure "parse_target" set ref 1422* 1438* 1444* 1473 1480 entry_type 001464 automatic char(4) packed unaligned dcl 1723 in procedure "parse_page" set ref 1726* 1732* 1761 eq constant fixed bin(8,0) initial unsigned dcl 1-112 ref 1650 2345 equals 001252 automatic fixed bin(17,0) dcl 1541 set ref 1650* 1659* 1669* 1678* error 000130 stack reference condition dcl 2219 ref 2232 error_index parameter fixed bin(21,0) dcl 1245 ref 1240 error_level 001531 automatic fixed bin(35,0) dcl 1870 set ref 1876* 1882* 1888* 1894* 1929* error_message 000105 automatic varying char(256) dcl 48 set ref 1811* 1812 1848* 1849 2390* 2391 error_message_token 001533 automatic fixed bin(17,0) dcl 1872 set ref 1908* 1912 1927* 1929* error_seen 001126 automatic bit(1) packed unaligned dcl 1413 in procedure "parse_target" set ref 1447* 1461* 1522* 1526 error_seen 001532 automatic bit(1) dcl 1871 in procedure "parse_error" set ref 1897* error_string parameter char packed unaligned dcl 1244 set ref 1240 1247* 1250 1252* error_table_$translation_failed 000022 external static fixed bin(35,0) dcl 188 ref 933 expon constant fixed bin(8,0) initial unsigned dcl 1-112 ref 614 file 2 based structure array level 2 dcl 133 set ref 1195* file_macro_stack based structure array level 1 dcl 133 set ref 267 267 1172 1835 file_number 000206 automatic fixed bin(8,0) dcl 49 in procedure "pl1_macro_lex_" set ref 255* 316 1182 1219* 1828 1856* 1856 1858* file_number 7 based fixed bin(8,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1182* 1219 file_stack_ptr 14 based pointer level 2 dcl 1-67 set ref 267* 267 267 955 957 1172 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1190 1191 1192 1193 1194 1195 1212 1215 1216 1217 1218 1219 1220 1221 1222 1223 1227 1229 1230 1231 1835 2449 2450 2451 2452 find_include_file_$initiate_count 000012 constant entry external dcl 182 ref 1843 first parameter fixed bin(17,0) dcl 2468 ref 2465 2471 first_result 000207 automatic fixed bin(17,0) dcl 50 in procedure "pl1_macro_lex_" set ref 1159* 1193 1230* 2438 2449 2458* first_result 17 based fixed bin(17,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1193* 1230 2451* first_result 3 based fixed bin(17,0) array level 2 in structure "macro_stack" dcl 153 in procedure "pl1_macro_lex_" set ref 2414* fixed builtin function dcl 176 ref 1650 7-22 fixed_dec constant fixed bin(8,0) initial unsigned dcl 1-112 ref 481 493 fixedoverflow 000100 stack reference condition dcl 2219 ref 2228 four_chars 001630 automatic char(4) dcl 2509 set ref 2534* 2535 2540* 2541 2601* 2602 2607* 2608 from_char parameter fixed bin(21,0) dcl 1101 ref 1098 1103 1105 ge constant fixed bin(8,0) initial unsigned dcl 1-112 ref 653 gt constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 hash_index 001622 automatic fixed bin(17,0) dcl 2509 set ref 2544* 2547 2570 2611* 2614 hash_table based pointer array level 2 packed packed unaligned dcl 164 set ref 265* 2544 2547 2570* 2611 2614 hash_table_structure based structure level 1 dcl 164 set ref 264 264 hbound builtin function dcl 176 ref 252 329 331 575 834 1012 1172 1835 2235 2407 hcs_$terminate_noname 000016 constant entry external dcl 185 ref 957 i 000722 automatic fixed bin(17,0) dcl 952 in procedure "macro_lex_cleanup" set ref 954* 955 957* i 001516 automatic fixed bin(17,0) dcl 1780 in procedure "parse_include" set ref 1815* 1817* i 001623 automatic fixed bin(17,0) dcl 2509 in procedure "create_variable" set ref 2533* 2534* 2540 2600* 2601* 2607 i 000210 automatic fixed bin(17,0) dcl 51 in procedure "pl1_macro_lex_" set ref 273* 274 274 280 281 281 291 291 291 291 291 291 291 291 302* 1494* 1495 1495* 1764* 1765* id1 parameter fixed bin(17,0) dcl 10-85 in procedure "same_identifier" ref 10-83 10-89 10-89 id1 parameter fixed bin(17,0) dcl 4-85 in procedure "same_identifier" ref 4-83 4-89 4-89 id2 parameter fixed bin(17,0) dcl 10-85 in procedure "same_identifier" ref 10-83 10-89 10-89 id2 parameter fixed bin(17,0) dcl 4-85 in procedure "same_identifier" ref 4-83 4-89 4-89 identifier parameter varying char dcl 1002 in procedure "validate_pct_token" ref 997 1013 identifier constant fixed bin(8,0) initial unsigned dcl 1-112 in procedure "pl1_macro_lex_" ref 93 93 285 997 3-12 1584 5-35 5-35 1799 1953 1983 2190 2192 9-35 9-35 identifier_characters 000500 constant char(64) initial packed unaligned dcl 233 ref 398 716 if_level 001103 automatic fixed bin(17,0) dcl 1354 set ref 1368* 1372 1376 1377* 1377 1380* 1380 if_macro constant fixed bin(17,0) initial dcl 1-256 set ref 750* 760 781 include_file_length 001513 automatic fixed bin(21,0) dcl 1778 set ref 1857* 1858* include_file_name 001502 automatic varying char(32) dcl 1777 set ref 1799* 1801* 1821 1842* 1842 1843 1848 1853* include_file_ptr 001514 automatic pointer dcl 1779 set ref 1843* 1846 1858* index builtin function dcl 7-39 in procedure "requote_string_" ref 7-48 index builtin function dcl 7-80 in procedure "dequote_string_" ref 7-94 index builtin function dcl 176 in procedure "pl1_macro_lex_" ref 349 378 452 475 707 indx 000202 automatic fixed bin(21,0) dcl 7-78 in procedure "dequote_string_" set ref 7-90* 7-93 7-94 7-94 7-98 7-98 7-98 7-99 7-100* 7-103 7-105* 7-105 7-106 7-108* 7-108 indx 000202 automatic fixed bin(21,0) dcl 7-37 in procedure "requote_string_" set ref 7-44* 7-47 7-48 7-52 7-52 7-53 7-54* 7-57 7-61* 7-61 indx 000770 automatic fixed bin(17,0) dcl 1007 in procedure "validate_pct_token" set ref 1012* 1013 1015 1016* inlength 000200 automatic fixed bin(21,0) dcl 7-37 in procedure "requote_string_" set ref 7-42* 7-47 7-52 7-53 7-54 inlength 000200 automatic fixed bin(21,0) dcl 7-78 in procedure "dequote_string_" set ref 7-83* 7-85 7-86 7-93 7-94 7-98 7-98 7-99 7-100 instring parameter char packed unaligned dcl 7-35 in procedure "requote_string_" ref 7-33 7-42 7-48 7-52 7-57 instring parameter char packed unaligned dcl 7-75 in procedure "dequote_string_" ref 7-73 7-83 7-86 7-86 7-94 7-98 7-103 7-106 invalid_char constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 93 93 93 93 93 93 93 93 93 93 93 93 93 93 93 93 93 ioa_ 000020 constant entry external dcl 186 ref 1927 is_decimal_constant constant bit(4) initial dcl 1-183 ref 543 is_float_constant constant bit(4) initial dcl 1-183 ref 512 is_imaginary_constant constant bit(4) initial dcl 1-183 ref 561 is_integral_constant constant bit(4) initial dcl 1-183 ref 515 553 isub constant fixed bin(8,0) initial unsigned dcl 1-112 ref 501 ix 001600 automatic fixed bin(17,0) dcl 2469 set ref 2471* 2471* 2472* last parameter fixed bin(17,0) dcl 2468 ref 2465 2471 last_result 20 based fixed bin(17,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1194* 1231 2452* last_result 000211 automatic fixed bin(17,0) dcl 52 in procedure "pl1_macro_lex_" set ref 912* 1160* 1194 1231* 2438 2450 2458* last_result 4 based fixed bin(17,0) array level 2 in structure "macro_stack" dcl 153 in procedure "pl1_macro_lex_" set ref 2415* last_token 16 based fixed bin(17,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1192* 1229 2450* last_token 2 based fixed bin(17,0) array level 2 in structure "macro_stack" dcl 153 in procedure "pl1_macro_lex_" set ref 431* 786* 808* 1157 2413* last_token 000212 automatic fixed bin(17,0) dcl 53 in procedure "pl1_macro_lex_" set ref 845 1157* 1192 1229* 1272 1372 1451 1464 1513 1901 6-23 2077 8-23 lbound builtin function dcl 176 ref 1012 6-23 8-23 2235 le constant fixed bin(8,0) initial unsigned dcl 1-112 ref 640 left_parn constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 1458 1743 2170 length builtin function dcl 176 in procedure "pl1_macro_lex_" ref 1065 1821 1971 length builtin function dcl 7-39 in procedure "requote_string_" ref 7-42 length builtin function dcl 2522 in procedure "create_variable" ref 2528 2558 2595 length builtin function dcl 7-80 in procedure "dequote_string_" ref 7-83 line_number 000213 automatic fixed bin(14,0) dcl 54 in procedure "pl1_macro_lex_" set ref 256* 819* 819 1140* 1181 1218* line_number 6 based fixed bin(14,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1181* 1218 logical_expected 001072 automatic bit(1) packed unaligned dcl 1263 set ref 1271* 1272 1310* 1320* 1326* loop 000214 automatic bit(1) dcl 55 set ref 347* 348 365* 366 lt constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 ltrim builtin function dcl 176 ref 302 1968 m_index 3(19) 000000 constant fixed bin(17,0) initial array level 2 packed packed unaligned dcl 1-194 ref 1015 macro 15 based structure array level 2 dcl 133 set ref 1187* macro_depth 000215 automatic fixed bin(17,0) dcl 56 in procedure "pl1_macro_lex_" set ref 417 428 428 431 467 697 754 760 765 772 778 781 786 794* 794 803 803 808 813* 813 1145* 1156 1157 1184 1222* 2407 2410* 2410 2411 2412 2413 2414 2415 2416 2423 2424* 2456 2460* 2460 macro_depth 12 based fixed bin(17,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1184* 1222 macro_ptr 000216 automatic pointer dcl 57 in procedure "pl1_macro_lex_" set ref 428 431 760 765 772 781 786 803 808 1144* 1144 1144 1156 1157 1185 1221* 2407 2411 2412 2413 2414 2415 2416 2423 macro_ptr 10 based pointer array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1185* 1221 macro_stack based structure array level 1 dcl 153 set ref 1144 1144 2407 magic_words 000235 constant structure array level 1 dcl 1549 max builtin function dcl 176 ref 929 max_bit_string_constant constant fixed bin(17,0) initial dcl 1-265 ref 392 1978 max_char_string_constant constant fixed bin(17,0) initial dcl 1-265 ref 385 1973 max_constant_token constant fixed bin(8,0) initial unsigned dcl 1-172 ref 2190 max_delimiter_token constant fixed bin(8,0) initial unsigned dcl 1-172 ref 2056 max_identifier_length constant fixed bin(17,0) initial dcl 1-265 ref 3-12 1983 message_chars parameter char packed unaligned dcl 2389 ref 2387 2390 min builtin function dcl 176 ref 329 331 575 min_arithmetic_token constant fixed bin(8,0) initial unsigned dcl 1-172 ref 988 994 min_constant_token constant fixed bin(8,0) initial unsigned dcl 1-172 ref 2190 min_delimiter_token constant fixed bin(8,0) initial unsigned dcl 1-172 ref 2056 minus constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 2144 mod builtin function dcl 2522 in procedure "create_variable" ref 2544 2611 mod builtin function dcl 11-26 in procedure "allocate" ref 11-40 mod_2_sum 001627 automatic bit(36) dcl 2509 set ref 2531* 2535* 2535 2541* 2541 2544 2598* 2602* 2602 2608* 2608 2611 n 001624 automatic fixed bin(17,0) dcl 2509 set ref 2528* 2529 2530 2548 2551 2595* 2596 2597 2615 n_chars 001625 automatic fixed bin(17,0) dcl 2509 set ref 2530* 2538 2540 2597* 2605 2607 n_words 001626 automatic fixed bin(17,0) dcl 2509 set ref 2529* 2530 2533 2596* 2597 2600 name 222 based structure array level 3 in structure "temp_seg_3" dcl 1-67 in procedure "pl1_macro_lex_" name 000000 constant varying char(8) initial array level 2 in structure "pct_keywords" dcl 1-194 in procedure "pl1_macro_lex_" ref 1013 name 4 based char level 2 in structure "variable" dcl 1-90 in procedure "pl1_macro_lex_" set ref 1033 2551 2563* 2615 name_length 3 based fixed bin(17,0) level 2 packed packed unaligned dcl 1-90 set ref 1033 2548 2551 2562* 2563 2615 ne constant fixed bin(8,0) initial unsigned dcl 1-112 ref 666 2352 nested_if_level 13 based fixed bin(17,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1186* 1223 nested_if_level 000220 automatic fixed bin(17,0) dcl 58 in procedure "pl1_macro_lex_" set ref 751* 751 787* 787 788 806 1146* 1186 1223* next based pointer level 2 in structure "variable" packed packed unaligned dcl 1-90 in procedure "pl1_macro_lex_" set ref 1035 2567* next based pointer level 2 in structure "constant" dcl 1-103 in procedure "pl1_macro_lex_" set ref 1995* next_char_to_print 000221 automatic fixed bin(21,0) dcl 59 in procedure "pl1_macro_lex_" set ref 419* 421* 701* 702* 840* 1141* 1220* next_char_to_print 14 based fixed bin(21,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1183* 1220 next_free_token 000222 automatic fixed bin(17,0) dcl 60 set ref 1158* 2435 next_tk 000100 automatic fixed bin(17,0) dcl 2126 set ref 2134* 2136 2136 2147* 2149 2149* 2160* 2162 2162* nextv 1 based pointer level 2 packed packed unaligned dcl 1-90 set ref 2556 2566* 2572* 2621 ngt constant fixed bin(8,0) initial unsigned dcl 1-112 ref 678 nl_vt_np_token constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 93 93 nlt constant fixed bin(8,0) initial unsigned dcl 1-112 ref 672 no_token constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 93 6-25 8-25 none constant fixed bin(17,0) initial dcl 1-308 ref 304 330 417 849 3-24 3-38 1009 1010 1012 1077 1426 1508 1620 5-52 6-26 1976 1981 1986 1991 2001 2002 2097 2109 2192 2201 8-26 2238 2251 2258 2265 2272 2280 2287 2295 2303 2313 2329 2360 2365 2369 2373 2377 2381 2385 9-52 2414 2415 2438 2471 2486 2590 not constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 2059 2157 not_found 001127 automatic bit(1) dcl 1414 set ref 1493* 1494 1495* 1502 null builtin function dcl 176 in procedure "pl1_macro_lex_" ref 265 1032 1252 1252 1846 6-29 8-29 null builtin function dcl 11-26 in procedure "allocate" ref 11-43 11-43 11-45 null builtin function dcl 2522 in procedure "create_variable" ref 2545 2547 2570 2591 2612 2614 num_of_chars parameter fixed bin(21,0) dcl 1090 ref 1086 1092 1094 number_of_clargs 000223 automatic fixed bin(17,0) dcl 61 in procedure "pl1_macro_lex_" set ref 269* 1494 number_of_clargs 20 based fixed bin(17,0) level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pl1_macro_lex_" ref 269 number_of_params 21 based fixed bin(17,0) level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pl1_macro_lex_" ref 268 number_of_params 000224 automatic fixed bin(17,0) dcl 62 in procedure "pl1_macro_lex_" set ref 268* 273 old_q 001632 automatic pointer dcl 2509 set ref 2545* 2555* 2570 2572 2612* op1 000144 automatic fixed bin(17,0) dcl 2221 set ref 2224* 2253* 2253* 2260* 2260* 2267* 2267* 2275* 2275* 2282* 2282* 2290* 2290* 2298* 2298* 2305* 2308* 2316* 2330* 2335* 2340* 2348* 2354* op2 000145 automatic fixed bin(17,0) dcl 2221 set ref 2225* 2253* 2253* 2260* 2260* 2267* 2267* 2275* 2275* 2282* 2282* 2290* 2290* 2298* 2298* 2305* 2308* 2316* 2330* 2335* 2340* 2348* 2354* operand1 parameter fixed bin(17,0) dcl 4-5 in procedure "compare_numbers" set ref 4-2 4-9* 4-12* 4-14* 4-16* 4-18* 4-20* 4-22* 4-24* operand1 parameter fixed bin(17,0) dcl 10-32 in procedure "compare_chars" set ref 10-29 10-36* 10-39* 10-41* 10-43* 10-45* 10-47* 10-49* 10-51* operand1 000102 automatic fixed bin(17,0) dcl 2019 in procedure "parse_expression" set ref 2091* 2095* operand1 parameter fixed bin(17,0) dcl 10-5 in procedure "compare_numbers" set ref 10-2 10-9* 10-12* 10-14* 10-16* 10-18* 10-20* 10-22* 10-24* operand1 parameter fixed bin(17,0) dcl 4-32 in procedure "compare_chars" set ref 4-29 4-36* 4-39* 4-41* 4-43* 4-45* 4-47* 4-49* 4-51* operand1 parameter fixed bin(17,0) dcl 4-59 in procedure "compare_bit_strings" set ref 4-56 4-63* 4-66* 4-68* 4-70* 4-72* 4-74* 4-76* 4-78* operand1 parameter fixed bin(17,0) dcl 10-59 in procedure "compare_bit_strings" set ref 10-56 10-63* 10-66* 10-68* 10-70* 10-72* 10-74* 10-76* 10-78* operand2 000103 automatic fixed bin(17,0) dcl 2019 in procedure "parse_expression" set ref 2093* 2095* operand2 parameter fixed bin(17,0) dcl 10-32 in procedure "compare_chars" set ref 10-29 10-36* 10-39* 10-41* 10-43* 10-45* 10-47* 10-49* 10-51* operand2 parameter fixed bin(17,0) dcl 4-5 in procedure "compare_numbers" set ref 4-2 4-9* 4-12* 4-14* 4-16* 4-18* 4-20* 4-22* 4-24* operand2 parameter fixed bin(17,0) dcl 4-32 in procedure "compare_chars" set ref 4-29 4-36* 4-39* 4-41* 4-43* 4-45* 4-47* 4-49* 4-51* operand2 parameter fixed bin(17,0) dcl 10-59 in procedure "compare_bit_strings" set ref 10-56 10-63* 10-66* 10-68* 10-70* 10-72* 10-74* 10-76* 10-78* operand2 parameter fixed bin(17,0) dcl 4-59 in procedure "compare_bit_strings" set ref 4-56 4-63* 4-66* 4-68* 4-70* 4-72* 4-74* 4-76* 4-78* operand2 parameter fixed bin(17,0) dcl 10-5 in procedure "compare_numbers" set ref 10-2 10-9* 10-12* 10-14* 10-16* 10-18* 10-20* 10-22* 10-24* operation parameter fixed bin(17,0) dcl 4-58 in procedure "compare_bit_strings" ref 4-56 4-61 operation 000146 automatic fixed bin(17,0) dcl 2221 in procedure "evaluate" set ref 2226* 2235 2235 2240 2330* 2335* 2340* 2345 2345 2352 operation parameter fixed bin(17,0) dcl 10-4 in procedure "compare_numbers" ref 10-2 10-7 operation parameter fixed bin(17,0) dcl 4-4 in procedure "compare_numbers" ref 4-2 4-7 operation parameter fixed bin(17,0) dcl 4-31 in procedure "compare_chars" ref 4-29 4-34 operation parameter fixed bin(17,0) dcl 10-58 in procedure "compare_bit_strings" ref 10-56 10-61 operation parameter fixed bin(17,0) dcl 10-31 in procedure "compare_chars" ref 10-29 10-34 opindex 000101 automatic fixed bin(17,0) dcl 2018 set ref 2067* 2068 2089* 2095* opr1 parameter fixed bin(17,0) dcl 5-4 in procedure "both_arithmetic" ref 5-2 5-6 opr1 parameter fixed bin(17,0) dcl 9-4 in procedure "both_arithmetic" ref 9-2 9-6 opr2 parameter fixed bin(17,0) dcl 5-4 in procedure "both_arithmetic" ref 5-2 5-6 opr2 parameter fixed bin(17,0) dcl 9-4 in procedure "both_arithmetic" ref 9-2 9-6 oprx1 parameter fixed bin(17,0) dcl 5-13 in procedure "both_bit_string" ref 5-11 5-15 oprx1 parameter fixed bin(17,0) dcl 9-13 in procedure "both_bit_string" ref 9-11 9-15 oprx2 parameter fixed bin(17,0) dcl 5-13 in procedure "both_bit_string" ref 5-11 5-15 oprx2 parameter fixed bin(17,0) dcl 9-13 in procedure "both_bit_string" ref 9-11 9-15 or constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 original_token parameter fixed bin(17,0) dcl 1700 ref 1698 1705 outlength 000201 automatic fixed bin(21,0) dcl 7-37 in procedure "requote_string_" set ref 7-43* 7-52 7-53* 7-53 7-57 7-58* 7-58 7-59 7-60* 7-60 7-67* 7-67 7-68 7-69 outlength 000201 automatic fixed bin(21,0) dcl 7-78 in procedure "dequote_string_" set ref 7-89* 7-98 7-99* 7-99 7-103 7-104* 7-104 7-108 7-109* 7-109 7-113 output_index 000225 automatic fixed bin(21,0) dcl 63 set ref 250* 929 1067 1083 1094 1105 1108* 1108 1115 output_length 000226 automatic fixed bin(21,0) dcl 64 in procedure "pl1_macro_lex_" set ref 259* 1115 output_length 5 based fixed bin(21,0) level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pl1_macro_lex_" set ref 259 929* output_string based char packed unaligned dcl 1-86 set ref 1067* 1083* 1094* 1105* outstring 000100 automatic char(256) packed unaligned dcl 7-36 in procedure "requote_string_" set ref 7-45* 7-52* 7-57* 7-59* 7-68* 7-69 outstring 000100 automatic char(256) packed unaligned dcl 7-76 in procedure "dequote_string_" set ref 7-98* 7-103* 7-108* 7-113 overflow 000106 stack reference condition dcl 2219 ref 2229 parameter_var constant fixed bin(17,0) initial dcl 1-247 set ref 304* 1033 1628 params based structure level 1 dcl 1-61 paren_macro constant fixed bin(17,0) initial dcl 1-256 ref 428 pct_abort constant fixed bin(17,0) initial dcl 1-223 ref 1887 pct_else constant fixed bin(17,0) initial dcl 1-223 ref 772 1323 1376 pct_elseif constant fixed bin(17,0) initial dcl 1-223 ref 1329 1376 pct_endif constant fixed bin(17,0) initial dcl 1-223 ref 1320 1342 1376 1380 pct_error constant fixed bin(17,0) initial dcl 1-223 ref 1875 pct_if constant fixed bin(17,0) initial dcl 1-223 ref 1377 pct_include constant fixed bin(17,0) initial dcl 1-223 ref 2488 pct_isarg constant fixed bin(17,0) initial dcl 1-223 ref 1438 1480 pct_isdef constant fixed bin(17,0) initial dcl 1-223 ref 1444 pct_keywords 000000 constant structure array level 1 dcl 1-194 ref 1012 1012 pct_page constant fixed bin(17,0) initial dcl 1-223 ref 2488 pct_print constant fixed bin(17,0) initial dcl 1-223 ref 1893 1927 pct_skip constant fixed bin(17,0) initial dcl 1-223 ref 2488 pct_target constant fixed bin(17,0) initial dcl 1-223 ref 1422 1473 pct_then constant fixed bin(17,0) initial dcl 1-223 ref 1296 pct_type 000227 automatic fixed bin(5,0) unsigned dcl 65 in procedure "pl1_macro_lex_" set ref 330* 720* 724 849 849 3-23 1320 1323 1329 1342 1376 1376 1376 1377 1380 6-26* 6-33* 8-26* 8-33* pct_type 0(23) based fixed bin(5,0) array level 2 in structure "token" packed packed unsigned unaligned dcl 1-46 in procedure "pl1_macro_lex_" set ref 3-23* 1296 6-33 2001* 8-33 2485 pct_type parameter fixed bin(5,0) unsigned dcl 1003 in procedure "validate_pct_token" set ref 997 1009* 1012 1015* pct_warn constant fixed bin(17,0) initial dcl 1-223 ref 1881 percent constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 period constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 pl1_macro_error_ 000026 constant entry external dcl 1-281 ref 1247 1252 pl1_macro_hash_table_ptr 000666 automatic pointer dcl 162 set ref 264* 264 264 265 2544 2547 2570 2611 2614 plus constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 2131 precedence 000426 constant fixed bin(15,0) initial array dcl 2024 ref 2068 2068 preposition 4 000235 constant char(2) initial array level 2 dcl 1549 ref 1595 previous_var_type 001253 automatic fixed bin(17,0) dcl 1542 set ref 1592* 1623 1628 1630 ptr builtin function dcl 11-26 ref 11-47 q 001634 automatic pointer dcl 2509 set ref 2547* 2547* 2548 2551 2555* 2556 2566 2614* 2614* 2615 2617 2618 2619* 2621 rank builtin function dcl 176 ref 329 331 575 593 593 593 real_token 001025 automatic fixed bin(17,0) dcl 1075 set ref 1077* 1079* 1081 1083 1083 reinterpret 000230 automatic bit(1) packed unaligned dcl 66 set ref 1161* 1204 1232* 2436* 2440* 2440 2443 replace_by 1 based fixed bin(17,0) array level 2 dcl 1-46 set ref 412* 3-24* 3-38 3-38* 1077 1079 2002* 2192 2192 replace_var constant fixed bin(17,0) initial dcl 1-247 ref 1564 replacement_token_index 000231 automatic fixed bin(17,0) dcl 67 set ref 252* 3-16 3-34 1702 1705 1706 1707* 1707 1708 1988 1996 1997 1999 2000 2001 2002 2003* 2003 2005 result 000104 automatic fixed bin(17,0) dcl 2020 set ref 2095* 2097 2105 2173* 2186 result_first 000232 automatic fixed bin(17,0) dcl 69 set ref 1276* 1283 1290* 1603* 1609* 1609* 1620* 1637* 1654* 1659* 1669* 1678* 1687* result_token parameter fixed bin(17,0) dcl 2014 in procedure "parse_expression" set ref 2011 2109* 2114* result_token 001130 automatic fixed bin(17,0) dcl 1415 in procedure "parse_target" set ref 1476* 1478* 1502* 1504* 1508* 1510* 1532* right_parn constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 428 1520 1751 2179 rtrim builtin function dcl 176 ref 285 285 288 288 1490 1490 2309 2309 saved_token_index 001465 automatic fixed bin(17,0) dcl 1724 in procedure "parse_page" set ref 1735* 1764 saved_token_index 001476 automatic fixed bin(17,0) dcl 1774 in procedure "parse_include" set ref 1792* 1815 saved_token_index 000101 automatic fixed bin(17,0) dcl 2127 in procedure "primitive" set ref 2129* 2192 2192* 2192 2195 saved_token_start 001477 automatic fixed bin(21,0) dcl 1775 in procedure "parse_include" set ref 1794* 1812* 1823* 1830* 1837* 1849* saved_token_start 001131 automatic fixed bin(21,0) dcl 1416 in procedure "parse_target" set ref 1449* 1454* 1460* 1467* 1516* 1523* saved_token_start 001534 automatic fixed bin(21,0) dcl 1873 in procedure "parse_error" set ref 1899* 1904* 1914* 1923* scan 000203 automatic fixed bin(21,0) dcl 7-37 in procedure "requote_string_" set ref 7-48* 7-50 7-57 7-57 7-58 7-61 scan 000203 automatic fixed bin(21,0) dcl 7-78 in procedure "dequote_string_" set ref 7-94* 7-96 7-103 7-103 7-104 7-105 scan_index 000233 automatic fixed bin(21,0) dcl 70 set ref 334* 336 338 349* 350 359 360 398* 400 400* 402 419 452* 453 463 583* 585 587 716* 717 717* 719 722 974* 975 981 semi_colon constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 1613 1741 1755 1806 1921 semicolon_macro constant fixed bin(17,0) initial dcl 1-256 ref 803 set_var constant fixed bin(17,0) initial dcl 1-247 ref 1576 1652 severity parameter fixed bin(35,0) dcl 1243 set ref 1240 1247* 1250 1252* 1255 size builtin function dcl 1-51 ref 252 264 264 267 267 834 1144 1144 1994 1994 2560 2560 slash constant fixed bin(8,0) initial unsigned dcl 1-112 ref 93 source_depth 12 based fixed bin(17,0) level 2 dcl 1-67 set ref 254* 318 954 1142* 1142 1162* 1162 1172 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1190 1191 1192 1193 1194 1195 1208* 1208 1209 1212 1215 1216 1217 1218 1219 1220 1221 1222 1223 1227 1229 1230 1231 1835 2449 2450 2451 2452 source_index 4 based fixed bin(21,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1179* 1216 source_index 000234 automatic fixed bin(21,0) dcl 71 in procedure "pl1_macro_lex_" set ref 321 326 327 328* 328 334 336* 338* 338 349 354* 359* 359 362 365 368* 368 373 376* 376 378 378 378* 378 398 400 402* 402 408 419 421 439 443 450* 450 452 457* 463* 463 471 475 485 491 494* 494 497 497 500* 500 506 510 510 512 516* 516 518 524 524 527* 527 529 540 544* 544 550 550 555* 555 558 558 563* 563 570 574 577* 583 585* 587* 587 593 598 602 607 611 613* 613 620 624 626* 626 633 637 639* 639 646 650 652* 652 659 663 665* 665 669 671* 671 675 677* 677 684 688 690* 690 701 702 707 710* 710 716 717 719 722* 722 3-10 974 977* 981* 981 1115* 1138* 1179 1183 1216* 1247* 2061* 2079* 2099* 2139* 2152* 2165* 2181* 2200* 2237* 2242* 2327* 2391* source_length 4 based fixed bin(21,0) level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pl1_macro_lex_" set ref 316* source_length 000235 automatic fixed bin(21,0) dcl 72 in procedure "pl1_macro_lex_" set ref 321 326 334 336 349 354 355 362 365 373 378 378 398 400 408 439 443 452 457 471 475 485 491 497 497 510 510 512 518 524 524 529 540 546 550 550 558 558 570 574 583 585 607 611 620 624 633 637 646 650 659 663 669 675 684 688 707 716 717 719 834* 840* 974 977 1105 1137* 1180 1217* 1247* source_length 5 based fixed bin(21,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1180* 1217 source_list_length constant fixed bin(17,0) initial dcl 236 ref 1828 source_number 000236 automatic fixed bin(17,0) dcl 73 set ref 253* 1143* 1143 source_ptr 2 based pointer array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 957* 1178* 1215 source_ptr 2 based pointer level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pl1_macro_lex_" set ref 316* source_ptr 000240 automatic pointer dcl 74 in procedure "pl1_macro_lex_" set ref 326 334 349 365 373 378 398 408 443 452 475 491 497 510 510 512 524 524 540 546 550 558 574 583 611 624 637 650 663 669 675 688 707 716 719 3-21 974 1105 1136* 1178 1215* 1247* 1843* source_string based char packed unaligned dcl 170 ref 326 334 349 365 373 378 398 408 443 452 475 491 497 510 510 512 524 524 540 546 550 558 574 583 611 624 637 650 663 669 675 688 707 716 719 974 1105 source_string_array based char(1) array packed unaligned dcl 171 set ref 3-21 source_type 000242 automatic fixed bin(35,0) dcl 75 in procedure "pl1_macro_lex_" set ref 319 1135* 1155* 1175 1204 1212* 1213 source_type based fixed bin(35,0) array level 2 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 955 1177* 1190* 1212 stack 000105 automatic fixed bin(17,0) array dcl 2021 set ref 2050* 2067 2074* 2082* 2089 2091 2093 2105* 2114 stack_index 000100 automatic fixed bin(17,0) dcl 2017 set ref 2049* 2065 2067 2072* 2072 2074 2075* 2075 2082 2087 2089 2091 2093 2103* 2103 2105 standard_entry 001544 automatic bit(1) packed unaligned dcl 6-9 in procedure "get_next_token" set ref 6-11* 6-17* 6-39 6-39 standard_entry 000100 automatic bit(1) packed unaligned dcl 8-9 in procedure "get_next_token" set ref 8-11* 8-17* 8-39 8-39 start_tk parameter fixed bin(17,0) dcl 2404 ref 2402 2407 2407 2412 statement_type 000235 constant varying char(9) initial array level 2 dcl 1549 ref 1579 1630 string_length 000243 automatic fixed bin(21,0) dcl 76 in procedure "pl1_macro_lex_" set ref 344* 355* 355 360* 360 369* 369 385 392 string_length 2 based fixed bin(21,0) level 2 in structure "constant" dcl 1-103 in procedure "pl1_macro_lex_" set ref 1996* 1998 1999 string_ptr 226 based pointer array level 4 in structure "temp_seg_3" packed packed unaligned dcl 1-67 in procedure "pl1_macro_lex_" ref 281 string_ptr 2 based pointer array level 2 in structure "token" packed packed unaligned dcl 1-46 in procedure "pl1_macro_lex_" set ref 3-21* 1083 1591 1595 4-89 4-89 1799 1801 6-35 1999* 7-11 7-11 7-22 7-29 7-29 8-35 10-89 10-89 2407 2407 string_ptr 23 based pointer array level 3 in structure "temp_seg_3" packed packed unaligned dcl 1-67 in procedure "pl1_macro_lex_" ref 291 291 291 291 1495 string_ptr 223 based pointer array level 4 in structure "temp_seg_3" packed packed unaligned dcl 1-67 in procedure "pl1_macro_lex_" ref 274 string_size based fixed bin(21,0) array level 2 in structure "token" packed packed unaligned dcl 1-46 in procedure "pl1_macro_lex_" set ref 3-20* 1081 1083 1591 1595 4-89 4-89 1799 1801 1801 6-34 1996* 7-10 7-22 7-29 7-29 8-34 10-89 10-89 string_size 224 based fixed bin(21,0) array level 4 in structure "temp_seg_3" packed packed unaligned dcl 1-67 in procedure "pl1_macro_lex_" ref 281 string_size 222 based fixed bin(21,0) array level 4 in structure "temp_seg_3" dcl 1-67 in procedure "pl1_macro_lex_" ref 274 string_size 22 based fixed bin(21,0) array level 3 in structure "temp_seg_3" dcl 1-67 in procedure "pl1_macro_lex_" ref 291 291 291 291 1495 string_value 3 based char level 2 dcl 1-103 set ref 1998* 1999 stringrange 000136 stack reference condition dcl 2219 ref 2233 substr builtin function dcl 2522 in procedure "create_variable" ref 2526 2540 2593 2607 substr builtin function dcl 7-39 in procedure "requote_string_" set ref 7-45* 7-48 7-52* 7-52 7-57* 7-57 7-59* 7-68* 7-69 substr builtin function dcl 176 in procedure "pl1_macro_lex_" set ref 274 281 291 291 291 291 326 334 349 365 373 378 398 408 443 452 475 491 497 510 510 512 524 524 540 546 550 558 574 583 611 624 637 650 663 669 675 688 707 716 719 974 1067* 1083* 1094* 1105* 1105 1471 1495 4-89 4-89 7-11 7-11 7-22 7-29 7-29 10-89 10-89 substr builtin function dcl 7-80 in procedure "dequote_string_" set ref 7-86 7-86 7-94 7-98* 7-98 7-103* 7-103 7-106 7-108* 7-113 sys_info$max_seg_size 000024 external static fixed bin(19,0) dcl 1-277 ref 252 834 1067 1083 1094 1105 system_type_ 000030 constant entry external dcl 1-284 ref 1475 t_code 001132 automatic fixed bin(35,0) dcl 1417 set ref 1475* t_ptr 000100 automatic pointer dcl 1943 set ref 1994* 1995 1996 1998 1999 2004 t_type 000102 automatic fixed bin(8,0) unsigned dcl 1944 in procedure "create_char_token" set ref 1947* 1953* 1960* 1967* 1973 1978 1983 1997 t_type 001254 automatic fixed bin(17,0) dcl 1543 in procedure "parse_replace" set ref 1637* 1641 1652 t_type 001610 automatic fixed bin(5,0) unsigned dcl 2481 in procedure "needs_reinterpretation" set ref 2485* 2486 2488 2488 2488 t_value 001133 automatic fixed bin(17,0) dcl 1418 set ref 1475* 1476 target_error 000244 automatic bit(1) packed unaligned dcl 77 set ref 257* 933 1428* target_string 001134 automatic char(256) packed unaligned dcl 1419 set ref 1471* 1475* 1490* 1490 1490 1495 1507 target_value 17 based fixed bin(17,0) level 2 in structure "temp_seg_3" dcl 1-67 in procedure "pl1_macro_lex_" ref 258 target_value 000245 automatic fixed bin(17,0) dcl 78 in procedure "pl1_macro_lex_" set ref 258* 1426 1429* 1476 temp_chars 000147 automatic char(256) packed unaligned dcl 2222 set ref 2308* 2309 2309 temp_seg_3 based structure level 1 dcl 1-67 temp_segs 000670 automatic pointer array dcl 1-21 set ref 249* 252 254 258 259 264 267 267 267 267 268 269 274 274 280 281 281 291 291 291 291 291 291 291 291 316 316 318 412 834 929 941* 954 955 957 3-19 3-20 3-21 3-22 3-23 3-24 3-37 3-37 3-38 3-38 1031 1067 1077 1079 1081 1083 1083 1083 1094 1105 1142 1142 1144 1162 1162 1172 1172 1177 1177 1178 1178 1179 1179 1180 1180 1181 1181 1182 1182 1183 1183 1184 1184 1185 1185 1186 1186 1187 1187 1190 1190 1191 1191 1192 1192 1193 1193 1194 1194 1195 1195 1208 1208 1209 1212 1212 1215 1215 1216 1216 1217 1217 1218 1218 1219 1219 1220 1220 1221 1221 1222 1222 1223 1223 1227 1227 1229 1229 1230 1230 1231 1231 1283 1296 1495 1495 1591 1591 1595 1595 1705 1705 1706 4-89 4-89 4-89 4-89 5-6 5-6 5-15 5-15 5-26 5-26 5-35 5-35 1799 1799 1801 1801 1801 1835 1835 1912 6-23 6-32 6-33 6-34 6-35 1994 1995 1996 1997 1999 2000 2001 2002 2004 7-10 7-11 7-11 7-22 7-22 7-29 7-29 7-29 7-29 2067 2089 2136 2149 2162 2192 2192 8-23 8-32 8-33 8-34 8-35 9-6 9-6 9-15 9-15 9-26 9-26 9-35 9-35 10-89 10-89 10-89 10-89 2407 2407 2449 2449 2450 2450 2451 2451 2452 2452 2485 2560 2567 2568 temp_token 000246 automatic varying char(256) dcl 79 set ref 281* 285 285 288 288 299 299 408* 409* 719* 720* 726 760 767 775 781 797 tentative_token_type 000464 automatic fixed bin(8,0) initial array unsigned dcl 93 set ref 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 93* 329 329 term_type parameter fixed bin(17,0) dcl 1005 set ref 997 1010* 1016* terminating_keyword 001104 automatic bit(1) dcl 1355 set ref 1376* 1385 1392 terminator 3 000000 constant fixed bin(17,0) initial array level 2 packed packed unaligned dcl 1-194 ref 1016 terminator_type 000347 automatic fixed bin(17,0) dcl 80 set ref 720* 745* tknx parameter fixed bin(17,0) dcl 2480 ref 2477 2485 to_char parameter fixed bin(21,0) dcl 1102 ref 1098 1103 token based structure array level 1 dcl 1-46 set ref 252 834 3-37* 3-37 1705* 1705 6-23 8-23 token_id parameter fixed bin(17,0) dcl 1073 ref 1070 1077 1077 1079 token_index 15 based fixed bin(17,0) array level 3 in structure "file_macro_stack" dcl 133 in procedure "pl1_macro_lex_" set ref 1191* 1227 2449* token_index 000350 automatic fixed bin(17,0) dcl 81 in procedure "pl1_macro_lex_" set ref 285* 288* 291* 299* 304* 306* 843* 843 845 851* 1156* 1158 1191 1227* 1272 1296 1372 1389* 1451 1464 1513 1591 1591 1595 1595 1735 1764 1792 1799 1799 1801 1801 1801 1815 1901 6-22* 6-22 6-23 6-23 6-32 6-33 6-34 6-35 2074 2077 2129 8-22* 8-22 8-23 8-23 8-32 8-33 8-34 8-35 token_index 1 based fixed bin(17,0) array level 2 in structure "macro_stack" dcl 153 in procedure "pl1_macro_lex_" set ref 1156 2412* 2423 token_length 000351 automatic fixed bin(21,0) dcl 82 set ref 506* 546 3-10* 3-12 3-20 1471 6-27* 6-34* 8-27* 8-34* token_num parameter fixed bin(17,0) dcl 7-18 in procedure "arith_value" ref 7-16 7-22 7-22 token_num parameter fixed bin(17,0) dcl 7-27 in procedure "char_value" ref 7-25 7-29 7-29 7-29 7-29 token_num parameter fixed bin(17,0) dcl 7-4 in procedure "bit_value" ref 7-2 7-10 7-11 7-11 token_ptr 000352 automatic pointer dcl 83 set ref 3-21* 1471 6-29* 6-35* 6-36* 8-29* 8-35* 8-36* token_start 000354 automatic fixed bin(21,0) dcl 84 set ref 327* 352* 355 385* 392* 408 408 455* 506 520* 531* 546 546* 709* 726* 760* 767* 775* 781* 797* 883* 3-10 3-12* 3-16* 3-21 3-34* 1139* 1172* 1285* 1298* 1331* 1344* 1430* 1449 1586* 1597* 1615* 1630* 1644* 1663* 1672* 1681* 1690* 1761* 1794 1899 6-28* 6-36* 8-28* 8-36* token_string based char packed unaligned dcl 172 set ref 1591 1595 1799 1801* token_type 000355 automatic fixed bin(8,0) unsigned dcl 85 set ref 280* 285 288 291 299 329* 340* 375* 383 428 449* 481* 493* 501* 512* 512* 515* 515* 543* 543* 553* 553* 561* 561* 588* 614* 627* 640* 653* 666* 672* 678* 691* 772 821* 3-12 3-19 1294 1458 1490 1520 1584 1611 1613 1741 1743 1747 1751 1755 1799 1801 1806 1918 1921 6-25* 6-32* 6-39 6-39 2052 2056 2056 2056 2059 2068 2131 2144 2157 2170 2177 2179 2190 2190 2190 2192 8-25* 8-32* 8-39 8-39 tokenx 000356 automatic fixed bin(17,0) dcl 87 set ref 251* 412 431 745* 750* 786 808 834 912 3-15* 3-15 3-16 3-19 3-20 3-21 3-22 3-23 3-24 3-33* 3-33 3-34 3-37 3-38 3-38 1159 1160 1702 1988 2423* 2435* 2451 2452 tokn 001570 automatic fixed bin(17,0) dcl 2431 set ref 2438* 2438* 2439* 2440* translator_temp_$get_next_segment 000032 constant entry external dcl 11-37 ref 11-42 type 0(28) based fixed bin(8,0) array level 2 in structure "token" packed packed unsigned unaligned dcl 1-46 in procedure "pl1_macro_lex_" set ref 3-19* 1283 5-6 5-6 5-15 5-15 5-26 5-26 5-35 5-35 1912 6-32 1997* 2067 2089 2136 2149 2162 8-32 9-6 9-6 9-15 9-15 9-26 9-26 9-35 9-35 type based fixed bin(17,0) array level 2 in structure "macro_stack" dcl 153 in procedure "pl1_macro_lex_" set ref 428 760 781 803 2411* type parameter fixed bin(8,0) unsigned dcl 986 in procedure "arithmetic_to_bit" ref 984 988 type 224(28) based fixed bin(8,0) array level 4 in structure "temp_seg_3" packed packed unsigned unaligned dcl 1-67 in procedure "pl1_macro_lex_" ref 280 underflow 000122 stack reference condition dcl 2219 ref 2231 unspec builtin function dcl 2522 in procedure "create_variable" ref 2535 2541 2602 2608 unspec builtin function dcl 176 in procedure "pl1_macro_lex_" set ref 1187* 1195* v_ptr 001620 automatic pointer dcl 2501 set ref 2560* 2562 2563 2564 2565 2566 2567 2568 2570 2572 value 224 based structure array level 3 dcl 1-67 var_id parameter pointer dcl 1052 in procedure "reset_variable_alias" ref 1049 1055 var_id 001234 automatic pointer dcl 1420 in procedure "parse_target" set ref 1507* var_id parameter pointer dcl 1043 in procedure "set_default_flag" ref 1040 1045 var_id parameter pointer dcl 2579 in procedure "create_variable" set ref 2575 2591* 2619* var_id 000360 automatic pointer dcl 88 in procedure "pl1_macro_lex_" set ref 278* 306* 409* var_id 001256 automatic pointer dcl 1544 in procedure "parse_replace" set ref 1592* 1628* 1654* var_name parameter varying char dcl 2496 in procedure "create_variable" set ref 2494 2526 2528 2558 2563 2575 2593 2595 2622 2622 var_name 000362 automatic varying char(256) dcl 89 in procedure "pl1_macro_lex_" set ref 274* 278* 304* var_name 001260 automatic varying char(256) dcl 1545 in procedure "parse_replace" set ref 1591* 1592* 1620* 1630 1644 1663 1672 1681 1690 var_type 001361 automatic fixed bin(17,0) dcl 1546 in procedure "parse_replace" set ref 1564* 1570* 1576* 1579 1595 1620* 1623 1628 1652 var_type parameter fixed bin(17,0) dcl 2498 in procedure "create_variable" set ref 2494 2565 2575 2590* 2618* var_type 000463 automatic fixed bin(17,0) dcl 90 in procedure "pl1_macro_lex_" set ref 278* 409* 1507* variable based structure level 1 dcl 1-90 set ref 2560 2560 variable_array_overlay based char(4) array packed unaligned dcl 2517 ref 2534 2540 2601 2607 variable_base 10 based pointer level 2 dcl 1-67 set ref 1031 2567 2568* variable_name_length 000702 automatic fixed bin(17,0) dcl 1-99 set ref 2558* 2560 2560 2562 variable_overlay based char packed unaligned dcl 2517 ref 2551 2615 variable_string_ptr 001636 automatic pointer dcl 2509 set ref 2526* 2534 2540 2551 2593* 2601 2607 2615 variable_type 2(18) based fixed bin(17,0) level 2 packed packed unaligned dcl 1-90 set ref 1033 1045* 2565* 2618 variety parameter fixed bin(17,0) dcl 2405 ref 2402 2411 verify builtin function dcl 176 ref 334 398 546 583 716 974 white_space_token constant fixed bin(8,0) initial unsigned dcl 1-112 ref 340 588 821 1294 1611 1918 6-39 2052 2177 8-39 x1 parameter fixed bin(17,0) dcl 9-42 in procedure "op_mix" set ref 9-40 9-44* 9-46* 9-48* 9-50* x1 parameter fixed bin(17,0) dcl 5-42 in procedure "op_mix" set ref 5-40 5-44* 5-46* 5-48* 5-50* x2 parameter fixed bin(17,0) dcl 9-42 in procedure "op_mix" set ref 9-40 9-44* 9-46* 9-48* 9-50* x2 parameter fixed bin(17,0) dcl 5-42 in procedure "op_mix" set ref 5-40 5-44* 5-46* 5-48* 5-50* z1 parameter fixed bin(17,0) dcl 9-24 in procedure "both_char_string" ref 9-22 9-26 z1 parameter fixed bin(17,0) dcl 5-24 in procedure "both_char_string" ref 5-22 5-26 z1 parameter fixed bin(17,0) dcl 5-33 in procedure "both_identifier" ref 5-31 5-35 z1 parameter fixed bin(17,0) dcl 9-33 in procedure "both_identifier" ref 9-31 9-35 z2 parameter fixed bin(17,0) dcl 9-33 in procedure "both_identifier" ref 9-31 9-35 z2 parameter fixed bin(17,0) dcl 5-33 in procedure "both_identifier" ref 5-31 5-35 z2 parameter fixed bin(17,0) dcl 9-24 in procedure "both_char_string" ref 9-22 9-26 z2 parameter fixed bin(17,0) dcl 5-24 in procedure "both_char_string" ref 5-22 5-26 zerodivide 000114 stack reference condition dcl 2219 ref 2230 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. ADP_SYSTEM internal static fixed bin(17,0) initial dcl 2-4 COMPILER_ERROR internal static fixed bin(35,0) initial dcl 1-316 NO_RESULT internal static fixed bin(35,0) initial dcl 1-315 SYSTEM_TYPE_NAME internal static char(8) initial array packed unaligned dcl 2-6 TARGET_STRING_ERROR internal static fixed bin(35,0) initial dcl 1-322 area based area(1024) dcl 1-32 arithchar internal static char(28) initial packed unaligned dcl 1-288 bin_integer internal static fixed bin(8,0) initial unsigned dcl 1-112 fixed_bin internal static fixed bin(8,0) initial unsigned dcl 1-112 float_bin internal static fixed bin(8,0) initial unsigned dcl 1-112 float_dec internal static fixed bin(8,0) initial unsigned dcl 1-112 i_bin_integer internal static fixed bin(8,0) initial unsigned dcl 1-112 i_dec_integer internal static fixed bin(8,0) initial unsigned dcl 1-112 i_fixed_bin internal static fixed bin(8,0) initial unsigned dcl 1-112 i_fixed_dec internal static fixed bin(8,0) initial unsigned dcl 1-112 i_float_bin internal static fixed bin(8,0) initial unsigned dcl 1-112 i_float_dec internal static fixed bin(8,0) initial unsigned dcl 1-112 identifier_chars internal static char(64) initial packed unaligned dcl 1-296 keyword_token internal static fixed bin(8,0) initial unsigned dcl 1-112 lower_case_letters internal static char(26) initial packed unaligned dcl 1-299 macro_version internal static char(5) initial packed unaligned dcl 1-310 max_arithmetic_token internal static fixed bin(8,0) initial unsigned dcl 1-172 numerals internal static char(10) initial packed unaligned dcl 1-294 p automatic pointer dcl 2509 pct_INCLUDE internal static fixed bin(17,0) initial dcl 1-223 pct_default internal static fixed bin(17,0) initial dcl 1-223 pct_replace internal static fixed bin(17,0) initial dcl 1-223 pct_set internal static fixed bin(17,0) initial dcl 1-223 pl1_macro_lex_ 000000 constant entry external dcl 1-282 pl1_macro_lex_$cleanup 000000 constant entry external dcl 1-283 pl1_macro_severity_ external static fixed bin(35,0) dcl 1-276 prefix_minus internal static fixed bin(8,0) initial unsigned dcl 1-112 prefix_plus internal static fixed bin(8,0) initial unsigned dcl 1-112 protected automatic bit(18) dcl 2509 reinterpret_macro internal static fixed bin(17,0) initial dcl 1-256 target_comma internal static fixed bin(8,0) initial unsigned dcl 1-112 token_hole_1 internal static fixed bin(8,0) initial unsigned dcl 1-112 token_hole_2 internal static fixed bin(8,0) initial unsigned dcl 1-112 token_hole_3 internal static fixed bin(8,0) initial unsigned dcl 1-112 token_hole_4 internal static fixed bin(8,0) initial unsigned dcl 1-112 upper_case_letters internal static char(26) initial packed unaligned dcl 1-300 zero_one internal static char(2) initial packed unaligned dcl 1-302 NAMES DECLARED BY EXPLICIT CONTEXT. CHECKOP 016044 constant label dcl 2052 ref 2107 END_ACTION 005463 constant label dcl 826 ref 342 424 437 446 469 478 503 581 591 605 618 631 644 657 682 695 711 728 746 752 776 799 817 824 END_CASE 005630 constant label dcl 909 ref 852 858 861 864 867 870 873 876 879 882 892 895 898 901 904 907 ERROR 020712 constant label dcl 2379 ref 2232 EXP_PARSE_FAIL 016276 constant label dcl 2109 ref 2062 2080 2100 2204 FETCHOP 016044 constant label dcl 2052 ref 2083 FIXEDOVERFLOW 020562 constant label dcl 2363 ref 2228 INCLUDE_COMMON 013444 constant label dcl 1792 ref 1784 1790 OVERFLOW 020610 constant label dcl 2367 ref 2229 PARSE_ERROR 005634 constant label dcl 916 ref 889 1278 1287 1300 1333 1346 1530 1588 1599 1604 1617 1647 1665 1674 1683 1692 1762 1813 1825 1832 1839 1851 1934 POP 016270 constant label dcl 2103 PRIMITIVE_FAIL 017036 constant label dcl 2204 set ref 2140 2153 2166 2175 2182 STACKOP 016131 constant label dcl 2072 STRINGRANGE 020740 constant label dcl 2383 ref 2233 SUCCESS 016304 constant label dcl 2114 ref 2087 TARGET_ERROR 010374 constant label dcl 1528 ref 1455 1468 1517 UNDERFLOW 020664 constant label dcl 2375 ref 2231 UNSTACK 016215 constant label dcl 2091 ref 2068 ZERODIVIDE 020636 constant label dcl 2371 ref 2230 action 000141 constant label array(18) dcl 334 ref 332 allocate 023644 constant entry internal dcl 11-21 ref 264 267 1144 1994 2560 arith_value 015377 constant entry internal dcl 7-16 ref 4-9 4-9 4-12 4-12 4-14 4-14 4-16 4-16 4-18 4-18 4-20 4-20 4-22 4-22 4-24 4-24 2149 2253 2253 2260 2260 2267 2267 2275 2275 2282 2282 10-9 10-9 10-12 10-12 10-14 10-14 10-16 10-16 10-18 10-18 10-20 10-20 10-22 10-22 10-24 10-24 arithmetic_to_bit 006243 constant entry internal dcl 984 ref 512 515 543 553 561 bit_to_arithmetic 006255 constant entry internal dcl 991 ref 512 515 543 553 561 bit_value 015302 constant entry internal dcl 7-2 ref 1290 4-63 4-63 4-66 4-66 4-68 4-68 4-70 4-70 4-72 4-72 4-74 4-74 4-76 4-76 4-78 4-78 2162 2290 2290 2298 2298 10-63 10-63 10-66 10-66 10-68 10-68 10-70 10-70 10-72 10-72 10-74 10-74 10-76 10-76 10-78 10-78 both_arithmetic 013020 constant entry internal dcl 5-2 in procedure "parse_replace" ref 5-44 both_arithmetic 021072 constant entry internal dcl 9-2 in procedure "evaluate" ref 2253 2260 2267 2275 2282 9-44 both_bit_string 013053 constant entry internal dcl 5-11 in procedure "parse_replace" ref 5-46 both_bit_string 021127 constant entry internal dcl 9-11 in procedure "evaluate" ref 2290 2298 9-46 both_char_string 013106 constant entry internal dcl 5-22 in procedure "parse_replace" ref 5-48 both_char_string 021164 constant entry internal dcl 9-22 in procedure "evaluate" ref 2305 9-48 both_identifier 021221 constant entry internal dcl 9-31 in procedure "evaluate" ref 9-50 both_identifier 013141 constant entry internal dcl 5-31 in procedure "parse_replace" ref 5-50 bump_length 006611 constant label dcl 1108 ref 1068 1084 1095 1106 bump_macro_stack 023013 constant entry internal dcl 2402 ref 745 750 char_value 015432 constant entry internal dcl 7-25 ref 4-36 4-36 4-39 4-39 4-41 4-41 4-43 4-43 4-45 4-45 4-47 4-47 4-49 4-49 4-51 4-51 1927 1929 2308 2308 10-36 10-36 10-39 10-39 10-41 10-41 10-43 10-43 10-45 10-45 10-47 10-47 10-49 10-49 10-51 10-51 check_defaults 006341 constant entry internal dcl 1024 ref 931 check_depth 005636 constant label dcl 922 ref 841 914 918 check_syntax_after_constant 004175 constant label dcl 570 ref 396 clear_macro_frame 023103 constant entry internal dcl 2420 ref 770 916 common_code 014506 constant label dcl 6-20 in procedure "get_next_token" ref 6-12 6-18 common_code 017062 constant label dcl 8-20 in procedure "get_next_token" ref 8-12 8-18 common_parse 007770 constant label dcl 1447 in procedure "parse_target" ref 1433 1439 1445 common_parse 010417 constant label dcl 1579 in procedure "parse_replace" ref 1565 1571 1577 common_skip 007640 constant label dcl 1368 ref 1361 1366 compare 000314 constant label array(14:24) dcl 4-63 in procedure "compare_bit_strings" ref 4-61 compare 000413 constant label array(14:24) dcl 10-63 in procedure "compare_bit_strings" ref 10-61 compare 000400 constant label array(14:24) dcl 10-36 in procedure "compare_chars" ref 10-34 compare 000365 constant label array(14:24) dcl 10-9 in procedure "compare_numbers" ref 10-7 compare 000266 constant label array(14:24) dcl 4-9 in procedure "compare_numbers" ref 4-7 compare 000301 constant label array(14:24) dcl 4-36 in procedure "compare_chars" ref 4-34 compare_bit_strings 012403 constant entry internal dcl 4-56 in procedure "parse_replace" ref 1669 compare_bit_strings 022354 constant entry internal dcl 10-56 in procedure "evaluate" ref 2335 compare_chars 021750 constant entry internal dcl 10-29 in procedure "evaluate" ref 2340 compare_chars 012017 constant entry internal dcl 4-29 in procedure "parse_replace" ref 1678 compare_numbers 021374 constant entry internal dcl 10-2 in procedure "evaluate" ref 2330 compare_numbers 011463 constant entry internal dcl 4-2 in procedure "parse_replace" ref 1659 copy_token 011406 constant entry internal dcl 1698 ref 1609 create_arith_token 014760 constant entry internal dcl 1964 ref 299 2149 2253 2260 2267 2275 2282 create_bit_token 014662 constant entry internal dcl 1957 ref 291 311 312 2162 2290 2298 create_char_token 014573 constant entry internal dcl 1940 ref 288 2309 create_common 015022 constant label dcl 1971 ref 1949 1955 1962 1969 create_identifier_token 014624 constant entry internal dcl 1951 ref 285 create_variable 023263 constant entry internal dcl 2494 ref 304 1620 dequote_string_ 015647 constant entry internal dcl 7-73 ref 291 291 1490 1801 7-11 7-29 end_of_loop 007720 constant label dcl 1400 ref 1390 1392 1397 end_of_source_reached 005463 constant label dcl 831 ref 356 362 439 471 485 521 533 570 607 620 633 646 659 684 978 end_of_source_reached_but_no_pending_token 005464 constant label dcl 834 ref 458 enter_macro_source 006714 constant entry internal dcl 1150 ref 433 791 810 enter_previous_source 007105 constant entry internal dcl 1200 ref 922 enter_source_segment 006652 constant entry internal dcl 1122 ref 316 1858 eval_action 000327 constant label array(0:24) dcl 2242 ref 2235 2235 2240 eval_err 020766 constant entry internal dcl 2387 ref 2257 2264 2271 2279 2286 2294 2302 2312 2359 evaluate 017152 constant entry internal dcl 2210 ref 2095 finish_up_macro 023113 constant entry internal dcl 2428 ref 913 get_next_token 017042 constant entry internal dcl 8-3 in procedure "parse_expression" ref 2052 2076 2133 2146 2159 2172 2177 get_next_token 014477 constant entry internal dcl 6-3 in procedure "pl1_macro_lex_" ref 1270 1294 1336 1451 1464 1513 1582 1594 1602 1611 1739 1746 1750 1754 1797 1805 1901 1918 get_next_token$retain_white_space 014503 constant entry internal dcl 6-14 in procedure "pl1_macro_lex_" ref 847 1374 get_next_token$retain_white_space 017053 constant entry internal dcl 8-14 in procedure "parse_expression" ref 2185 2194 get_this_clause 007634 constant entry internal dcl 1363 ref 1309 1325 insert_variable 023406 constant label dcl 2558 ref 2548 lookup 023471 constant entry internal dcl 2575 ref 278 409 1507 1592 macro_lex_cleanup 005741 constant entry internal dcl 945 ref 932 942 make_replacement_token 006130 constant entry internal dcl 3-28 ref 851 1389 1532 1765 1817 2439 make_token 006000 constant entry internal dcl 3-2 ref 341 395 411 426 445 467 477 502 566 589 604 617 630 643 656 681 694 730 748 764 785 801 822 831 message_common 014243 constant label dcl 1897 ref 1877 1883 1889 1895 message_error 014473 constant label dcl 1932 set ref 1905 1909 1915 1924 needs_reinterpretation 023224 constant entry internal dcl 2477 ref 2440 op_mix 021256 constant entry internal dcl 9-40 in procedure "evaluate" ref 2316 op_mix 013174 constant entry internal dcl 5-40 in procedure "parse_replace" ref 1637 operand_types 000360 constant label array(0:4) dcl 2327 ref 2316 output_chars 006450 constant entry internal dcl 1059 output_chars$based 006542 constant entry internal dcl 1086 output_chars$from_source 006565 constant entry internal dcl 1098 ref 419 701 840 output_chars$token 006477 constant entry internal dcl 1070 ref 420 2472 page_skip 013322 constant label dcl 1735 ref 1727 1733 parse_INCLUDE 013440 constant entry internal dcl 1786 ref 890 parse_abort 014230 constant entry internal dcl 1885 ref 902 parse_default 010407 constant entry internal dcl 1567 ref 856 parse_error 014214 constant entry internal dcl 1866 ref 868 parse_expression 016030 constant entry internal dcl 2011 ref 1276 1603 1908 2173 parse_if 007332 constant entry internal dcl 1260 ref 880 parse_include 013434 constant entry internal dcl 1771 ref 893 parse_isarg 007760 constant entry internal dcl 1435 ref 877 parse_isdef 007764 constant entry internal dcl 1441 ref 871 parse_page 013312 constant entry internal dcl 1717 ref 859 parse_print 014236 constant entry internal dcl 1891 ref 896 parse_replace 010403 constant entry internal dcl 1536 ref 865 parse_set 010413 constant entry internal dcl 1573 ref 905 parse_skip 013316 constant entry internal dcl 1729 ref 862 parse_target 007721 constant entry internal dcl 1407 ref 874 parse_warn 014222 constant entry internal dcl 1879 ref 899 parser 000207 constant label array(19) dcl 856 ref 849 percent_action 000163 constant label array(0:19) dcl 726 ref 724 pl1_macro_lex_ 002305 constant entry external dcl 35 pl1_macro_lex_$cleanup 005664 constant entry external dcl 938 primitive 016312 constant entry internal dcl 2119 ref 2050 2082 2134 2147 2160 print_error 007202 constant entry internal dcl 1240 ref 352 385 392 455 520 531 546 577 593 598 602 709 726 760 767 775 781 797 834 883 3-12 3-16 3-34 1115 1172 1285 1298 1331 1344 1430 1454 1460 1467 1516 1523 1586 1597 1615 1630 1644 1663 1672 1681 1690 1761 1812 1823 1830 1837 1849 1904 1914 1923 2061 2079 2099 2139 2152 2165 2181 2200 2237 2242 2327 2391 2407 print_error$null 007250 constant entry internal dcl 1250 ref 302 1033 1702 1929 1975 1980 1985 1990 2363 2367 2371 2375 2379 2383 print_error_common 007322 constant label dcl 1255 ref 1248 1253 print_token_string 023204 constant entry internal dcl 2465 ref 2458 reinterpret_this_macro 007156 constant label dcl 1227 ref 1204 requote_string_ 015505 constant entry internal dcl 7-33 ref 1954 2308 reset_variable_alias 006440 constant entry internal dcl 1049 ref 306 1654 same_identifier 012767 constant entry internal dcl 4-83 in procedure "parse_replace" ref 1687 same_identifier 022760 constant entry internal dcl 10-83 in procedure "evaluate" ref 2348 2354 save_environment 006743 constant entry internal dcl 1166 ref 432 790 809 1855 scan_exponent 003703 constant label dcl 506 set ref 483 scan_past_digits 006210 constant entry internal dcl 971 ref 482 489 495 537 set_default_flag 006431 constant entry internal dcl 1040 ref 1628 skip_this_clause 007630 constant entry internal dcl 1350 ref 1319 source_start 000137 constant label array(2) dcl 321 ref 319 434 792 811 1859 test_length 006614 constant entry internal dcl 1112 ref 1066 1082 1093 1104 test_redefine 000261 constant label array(0:4) dcl 1644 ref 1652 unrecoverable_error 005640 constant label dcl 929 ref 1255 validate_pct_token 006264 constant entry internal dcl 997 ref 720 what_next 000232 constant label array(3) dcl 1385 ref 1383 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 26276 26332 25636 26306 Length 27062 25636 34 514 437 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME pl1_macro_lex_ 1988 external procedure is an external procedure. macro_lex_cleanup internal procedure shares stack frame of external procedure pl1_macro_lex_. make_token internal procedure shares stack frame of external procedure pl1_macro_lex_. make_replacement_token internal procedure shares stack frame of external procedure pl1_macro_lex_. scan_past_digits internal procedure shares stack frame of external procedure pl1_macro_lex_. arithmetic_to_bit internal procedure shares stack frame of external procedure pl1_macro_lex_. bit_to_arithmetic internal procedure shares stack frame of external procedure pl1_macro_lex_. validate_pct_token internal procedure shares stack frame of external procedure pl1_macro_lex_. check_defaults internal procedure shares stack frame of external procedure pl1_macro_lex_. set_default_flag internal procedure shares stack frame of external procedure pl1_macro_lex_. reset_variable_alias internal procedure shares stack frame of external procedure pl1_macro_lex_. output_chars internal procedure shares stack frame of external procedure pl1_macro_lex_. test_length internal procedure shares stack frame of external procedure pl1_macro_lex_. enter_source_segment internal procedure shares stack frame of external procedure pl1_macro_lex_. enter_macro_source internal procedure shares stack frame of external procedure pl1_macro_lex_. save_environment internal procedure shares stack frame of external procedure pl1_macro_lex_. enter_previous_source internal procedure shares stack frame of external procedure pl1_macro_lex_. print_error 91 internal procedure is called during a stack extension. parse_if internal procedure shares stack frame of external procedure pl1_macro_lex_. skip_this_clause internal procedure shares stack frame of external procedure pl1_macro_lex_. parse_target internal procedure shares stack frame of external procedure pl1_macro_lex_. parse_replace internal procedure shares stack frame of external procedure pl1_macro_lex_. copy_token internal procedure shares stack frame of external procedure pl1_macro_lex_. compare_numbers internal procedure shares stack frame of external procedure pl1_macro_lex_. compare_chars internal procedure shares stack frame of external procedure pl1_macro_lex_. compare_bit_strings internal procedure shares stack frame of external procedure pl1_macro_lex_. same_identifier internal procedure shares stack frame of external procedure pl1_macro_lex_. both_arithmetic internal procedure shares stack frame of external procedure pl1_macro_lex_. both_bit_string internal procedure shares stack frame of external procedure pl1_macro_lex_. both_char_string internal procedure shares stack frame of external procedure pl1_macro_lex_. both_identifier internal procedure shares stack frame of external procedure pl1_macro_lex_. op_mix internal procedure shares stack frame of external procedure pl1_macro_lex_. parse_page internal procedure shares stack frame of external procedure pl1_macro_lex_. parse_include internal procedure shares stack frame of external procedure pl1_macro_lex_. parse_error internal procedure shares stack frame of external procedure pl1_macro_lex_. get_next_token internal procedure shares stack frame of external procedure pl1_macro_lex_. create_char_token 307 internal procedure is called during a stack extension. bit_value 306 internal procedure is called by several nonquick procedures. arith_value 234 internal procedure is called by several nonquick procedures. char_value 148 internal procedure is called by several nonquick procedures. requote_string_ 135 internal procedure is called during a stack extension. dequote_string_ 135 internal procedure is called during a stack extension. parse_expression 182 internal procedure is called by several nonquick procedures. primitive 112 internal procedure calls itself recursively. get_next_token 72 internal procedure is called by several nonquick procedures. evaluate 637 internal procedure enables or reverts conditions. on unit on line 2228 64 on unit on unit on line 2229 64 on unit on unit on line 2230 64 on unit on unit on line 2231 64 on unit on unit on line 2232 64 on unit on unit on line 2233 64 on unit eval_err internal procedure shares stack frame of internal procedure evaluate. both_arithmetic internal procedure shares stack frame of internal procedure evaluate. both_bit_string internal procedure shares stack frame of internal procedure evaluate. both_char_string internal procedure shares stack frame of internal procedure evaluate. both_identifier internal procedure shares stack frame of internal procedure evaluate. op_mix internal procedure shares stack frame of internal procedure evaluate. compare_numbers internal procedure shares stack frame of internal procedure evaluate. compare_chars internal procedure shares stack frame of internal procedure evaluate. compare_bit_strings internal procedure shares stack frame of internal procedure evaluate. same_identifier internal procedure shares stack frame of internal procedure evaluate. bump_macro_stack internal procedure shares stack frame of external procedure pl1_macro_lex_. clear_macro_frame internal procedure shares stack frame of external procedure pl1_macro_lex_. finish_up_macro internal procedure shares stack frame of external procedure pl1_macro_lex_. print_token_string internal procedure shares stack frame of external procedure pl1_macro_lex_. needs_reinterpretation internal procedure shares stack frame of external procedure pl1_macro_lex_. create_variable internal procedure shares stack frame of external procedure pl1_macro_lex_. allocate 78 internal procedure is called by several nonquick procedures. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME allocate 000100 Nwords allocate 000102 P allocate 000104 code allocate bit_value 000100 b_length bit_value create_char_token 000100 t_ptr create_char_token 000102 t_type create_char_token 000103 chars create_char_token dequote_string_ 000100 outstring dequote_string_ 000200 inlength dequote_string_ 000201 outlength dequote_string_ 000202 indx dequote_string_ 000203 scan dequote_string_ evaluate 000144 op1 evaluate 000145 op2 evaluate 000146 operation evaluate 000147 temp_chars evaluate get_next_token 000100 standard_entry get_next_token parse_expression 000100 stack_index parse_expression 000101 opindex parse_expression 000102 operand1 parse_expression 000103 operand2 parse_expression 000104 result parse_expression 000105 stack parse_expression pl1_macro_lex_ 000100 FALSE_token pl1_macro_lex_ 000101 TRUE_token pl1_macro_lex_ 000102 action_index pl1_macro_lex_ 000103 alias_id pl1_macro_lex_ 000104 current_char pl1_macro_lex_ 000105 error_message pl1_macro_lex_ 000206 file_number pl1_macro_lex_ 000207 first_result pl1_macro_lex_ 000210 i pl1_macro_lex_ 000211 last_result pl1_macro_lex_ 000212 last_token pl1_macro_lex_ 000213 line_number pl1_macro_lex_ 000214 loop pl1_macro_lex_ 000215 macro_depth pl1_macro_lex_ 000216 macro_ptr pl1_macro_lex_ 000220 nested_if_level pl1_macro_lex_ 000221 next_char_to_print pl1_macro_lex_ 000222 next_free_token pl1_macro_lex_ 000223 number_of_clargs pl1_macro_lex_ 000224 number_of_params pl1_macro_lex_ 000225 output_index pl1_macro_lex_ 000226 output_length pl1_macro_lex_ 000227 pct_type pl1_macro_lex_ 000230 reinterpret pl1_macro_lex_ 000231 replacement_token_index pl1_macro_lex_ 000232 result_first pl1_macro_lex_ 000233 scan_index pl1_macro_lex_ 000234 source_index pl1_macro_lex_ 000235 source_length pl1_macro_lex_ 000236 source_number pl1_macro_lex_ 000240 source_ptr pl1_macro_lex_ 000242 source_type pl1_macro_lex_ 000243 string_length pl1_macro_lex_ 000244 target_error pl1_macro_lex_ 000245 target_value pl1_macro_lex_ 000246 temp_token pl1_macro_lex_ 000347 terminator_type pl1_macro_lex_ 000350 token_index pl1_macro_lex_ 000351 token_length pl1_macro_lex_ 000352 token_ptr pl1_macro_lex_ 000354 token_start pl1_macro_lex_ 000355 token_type pl1_macro_lex_ 000356 tokenx pl1_macro_lex_ 000360 var_id pl1_macro_lex_ 000362 var_name pl1_macro_lex_ 000463 var_type pl1_macro_lex_ 000464 tentative_token_type pl1_macro_lex_ 000666 pl1_macro_hash_table_ptr pl1_macro_lex_ 000670 temp_segs pl1_macro_lex_ 000702 variable_name_length pl1_macro_lex_ 000703 constant_length pl1_macro_lex_ 000722 i macro_lex_cleanup 000770 indx validate_pct_token 001000 a_ptr check_defaults 001024 bump output_chars 001025 real_token output_chars 001072 logical_expected parse_if 001073 conditional_true parse_if 001102 action_type skip_this_clause 001103 if_level skip_this_clause 001104 terminating_keyword skip_this_clause 001114 alias parse_target 001115 cannon_name parse_target 001125 entry_type parse_target 001126 error_seen parse_target 001127 not_found parse_target 001130 result_token parse_target 001131 saved_token_start parse_target 001132 t_code parse_target 001133 t_value parse_target 001134 target_string parse_target 001234 var_id parse_target 001246 alias parse_replace 001247 entry_name parse_replace 001252 equals parse_replace 001253 previous_var_type parse_replace 001254 t_type parse_replace 001256 var_id parse_replace 001260 var_name parse_replace 001361 var_type parse_replace 001464 entry_type parse_page 001465 saved_token_index parse_page 001476 saved_token_index parse_include 001477 saved_token_start parse_include 001500 entry_name parse_include 001502 include_file_name parse_include 001513 include_file_length parse_include 001514 include_file_ptr parse_include 001516 i parse_include 001517 bitcount parse_include 001530 entry_type parse_error 001531 error_level parse_error 001532 error_seen parse_error 001533 error_message_token parse_error 001534 saved_token_start parse_error 001544 standard_entry get_next_token 001570 tokn finish_up_macro 001600 ix print_token_string 001610 t_type needs_reinterpretation 001620 v_ptr create_variable 001622 hash_index create_variable 001623 i create_variable 001624 n create_variable 001625 n_chars create_variable 001626 n_words create_variable 001627 mod_2_sum create_variable 001630 four_chars create_variable 001632 old_q create_variable 001634 q create_variable 001636 variable_string_ptr create_variable primitive 000100 next_tk primitive 000101 saved_token_index primitive requote_string_ 000100 outstring requote_string_ 000200 inlength requote_string_ 000201 outlength requote_string_ 000202 indx requote_string_ 000203 scan requote_string_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 r_l_a r_g_s r_g_a r_l_s r_e_as r_ne_as r_le_a r_ge_s r_ge_a r_le_s alloc_char_temp alloc_bit_temp cat_realloc_chars call_ext_out_desc call_ext_out call_int_this_desc call_int_this call_int_other_desc call_int_other return_mac fl2_to_fx2 tra_ext_1 bound_ck_signal mdfx1 enable_op shorten_stack ext_entry_desc int_entry int_entry_desc trunc_fx2 any_to_any_truncate_divide_fx1 double_power_integer_ THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. char_offset_ com_err_ find_include_file_$initiate_count hcs_$terminate_noname ioa_ pl1_macro_error_ system_type_ translator_temp_$get_next_segment THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$translation_failed sys_info$max_seg_size LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 93 001766 35 002301 248 002313 249 002315 250 002363 251 002364 252 002365 253 002371 254 002372 255 002375 256 002376 257 002400 258 002401 259 002403 264 002405 265 002421 267 002434 268 002451 269 002454 273 002456 274 002465 278 002501 280 002504 281 002514 285 002526 288 002567 291 002630 299 002717 302 002743 304 003017 306 003026 307 003030 311 003032 312 003050 316 003066 318 003103 319 003107 321 003111 326 003115 327 003122 328 003123 329 003124 330 003135 331 003137 332 003142 334 003143 336 003162 338 003167 340 003170 341 003172 342 003173 344 003174 347 003175 348 003177 349 003202 350 003222 352 003223 354 003250 355 003253 356 003257 359 003260 360 003261 362 003264 365 003267 366 003274 368 003275 369 003276 371 003277 373 003300 375 003306 376 003310 378 003311 383 003326 385 003331 390 003361 392 003362 395 003412 396 003413 398 003414 400 003434 402 003441 408 003444 409 003455 411 003460 412 003461 417 003467 419 003472 420 003500 421 003502 424 003504 426 003505 428 003506 431 003521 432 003523 433 003524 434 003525 437 003527 439 003530 443 003533 445 003537 446 003540 449 003541 450 003543 452 003544 453 003563 455 003564 457 003611 458 003614 463 003615 467 003620 469 003623 471 003624 475 003627 477 003640 478 003641 481 003642 482 003644 483 003645 485 003646 489 003651 491 003652 493 003660 494 003662 495 003663 496 003664 497 003665 500 003675 501 003677 502 003701 503 003702 506 003703 510 003706 512 003720 515 003732 516 003745 518 003746 520 003751 521 003776 524 003777 527 004010 529 004011 531 004014 533 004041 537 004042 540 004043 543 004051 544 004064 546 004065 550 004127 553 004137 555 004152 558 004153 561 004163 563 004173 566 004174 570 004175 574 004200 575 004205 577 004214 581 004247 583 004250 585 004267 587 004274 588 004275 589 004277 591 004300 593 004301 598 004367 602 004434 604 004477 605 004501 607 004502 611 004505 613 004511 614 004512 617 004514 618 004515 620 004516 624 004521 626 004525 627 004526 630 004530 631 004531 633 004532 637 004535 639 004541 640 004542 643 004544 644 004545 646 004546 650 004551 652 004555 653 004556 656 004560 657 004561 659 004562 663 004565 665 004573 666 004574 667 004576 669 004577 671 004601 672 004602 673 004604 675 004605 677 004607 678 004610 681 004612 682 004613 684 004614 688 004617 690 004623 691 004624 694 004626 695 004627 697 004630 701 004632 702 004637 707 004642 709 004655 710 004702 711 004703 716 004704 717 004723 719 004730 720 004740 722 004743 724 004747 726 004751 728 005020 730 005022 745 005023 746 005025 748 005026 750 005027 751 005031 752 005032 754 005033 760 005035 763 005113 764 005114 765 005115 767 005122 770 005171 772 005173 774 005203 775 005204 776 005253 778 005255 781 005257 784 005335 785 005336 786 005337 787 005345 788 005347 790 005351 791 005352 792 005353 794 005355 796 005357 797 005360 799 005427 801 005431 803 005432 806 005442 808 005444 809 005447 810 005450 811 005451 813 005453 817 005455 819 005456 821 005457 822 005461 824 005462 831 005463 834 005464 840 005517 841 005521 843 005522 845 005524 847 005527 849 005530 851 005533 852 005535 856 005536 858 005537 859 005540 861 005541 862 005542 864 005543 865 005544 867 005545 868 005546 870 005547 871 005550 873 005551 874 005552 876 005553 877 005554 879 005555 880 005556 882 005557 883 005560 888 005610 889 005613 890 005614 892 005615 893 005616 895 005617 896 005620 898 005621 899 005622 901 005623 902 005624 904 005625 905 005626 907 005627 912 005630 913 005632 914 005633 916 005634 918 005635 922 005636 925 005637 929 005640 931 005646 932 005647 933 005650 936 005660 938 005661 941 005672 942 005737 943 005740 945 005741 954 005742 955 005753 957 005761 959 005775 960 005777 3 2 006000 3 10 006001 3 12 006004 3 15 006037 3 16 006040 3 19 006071 3 20 006101 3 21 006106 3 22 006116 3 23 006120 3 24 006125 3 26 006127 3 28 006130 3 33 006132 3 34 006133 3 37 006164 3 38 006202 3 41 006207 971 006210 974 006211 975 006232 977 006233 978 006236 981 006237 982 006242 984 006243 988 006245 991 006255 994 006257 997 006264 1009 006275 1010 006300 1012 006301 1013 006312 1015 006325 1016 006332 1018 006336 1022 006340 1024 006341 1031 006342 1032 006345 1033 006352 1035 006424 1036 006427 1038 006430 1040 006431 1045 006433 1047 006437 1049 006440 1055 006442 1057 006447 1059 006450 1065 006461 1066 006462 1067 006463 1068 006476 1070 006477 1077 006501 1079 006513 1081 006514 1082 006520 1083 006521 1084 006541 1086 006542 1092 006544 1093 006547 1094 006550 1095 006564 1098 006565 1103 006567 1104 006574 1105 006575 1106 006610 1108 006611 1110 006613 1112 006614 1115 006615 1118 006651 1122 006652 1135 006654 1136 006656 1137 006661 1138 006663 1139 006665 1140 006666 1141 006670 1142 006672 1143 006674 1144 006675 1145 006711 1146 006712 1148 006713 1150 006714 1155 006715 1156 006717 1157 006725 1158 006727 1159 006732 1160 006735 1161 006737 1162 006740 1164 006742 1166 006743 1172 006744 1175 006775 1177 007000 1178 007006 1179 007011 1180 007014 1181 007016 1182 007020 1183 007022 1184 007024 1185 007027 1186 007033 1187 007037 1188 007045 1190 007046 1191 007054 1192 007057 1193 007064 1194 007071 1195 007076 1197 007104 1200 007105 1204 007106 1208 007113 1209 007116 1212 007121 1213 007125 1215 007127 1216 007133 1217 007136 1218 007140 1219 007142 1220 007144 1221 007146 1222 007150 1223 007153 1224 007155 1227 007156 1229 007164 1230 007171 1231 007173 1232 007177 1234 007200 1240 007201 1247 007215 1248 007246 1250 007247 1252 007263 1253 007321 1255 007322 1258 007331 1260 007332 1270 007333 1271 007334 1272 007336 1276 007343 1278 007354 1283 007357 1285 007367 1286 007417 1287 007422 1290 007423 1294 007441 1296 007445 1298 007456 1299 007506 1300 007511 1303 007512 1309 007514 1310 007515 1311 007516 1319 007517 1320 007520 1323 007525 1325 007527 1326 007530 1327 007531 1329 007532 1331 007534 1332 007564 1333 007567 1336 007570 1338 007571 1342 007572 1344 007575 1345 007623 1346 007626 1348 007627 1350 007630 1360 007631 1361 007633 1363 007634 1365 007635 1366 007637 1368 007640 1372 007642 1374 007647 1376 007650 1377 007671 1380 007676 1383 007702 1385 007704 1389 007711 1390 007713 1392 007714 1397 007717 1403 007720 1407 007721 1422 007722 1426 007724 1428 007726 1429 007730 1430 007732 1433 007757 1435 007760 1438 007761 1439 007763 1441 007764 1444 007765 1445 007767 1447 007770 1449 007771 1451 007773 1454 010000 1455 010025 1458 010026 1460 010031 1461 010056 1464 010060 1467 010065 1468 010112 1471 010113 1473 010120 1475 010123 1476 010150 1478 010156 1479 010160 1480 010161 1490 010163 1493 010226 1494 010231 1495 010243 1500 010254 1502 010256 1504 010263 1505 010265 1507 010266 1508 010276 1510 010303 1513 010305 1516 010312 1517 010337 1520 010340 1522 010343 1523 010345 1526 010372 1528 010374 1530 010377 1532 010400 1534 010402 1536 010403 1564 010404 1565 010406 1567 010407 1570 010410 1571 010412 1573 010413 1576 010414 1577 010416 1579 010417 1582 010432 1584 010433 1586 010436 1587 010505 1588 010511 1591 010512 1592 010527 1594 010532 1595 010533 1597 010554 1598 010613 1599 010617 1602 010620 1603 010621 1604 010632 1609 010635 1611 010637 1613 010643 1615 010646 1616 010715 1617 010721 1620 010722 1623 010730 1628 010733 1630 010744 1634 011051 1637 011053 1641 011055 1644 011057 1646 011116 1647 011122 1650 011123 1652 011125 1654 011132 1655 011134 1659 011135 1663 011142 1664 011201 1665 011205 1667 011206 1669 011207 1672 011214 1673 011253 1674 011257 1676 011260 1678 011261 1681 011266 1682 011325 1683 011331 1685 011332 1687 011333 1690 011340 1691 011377 1692 011403 1694 011404 1715 011405 1698 011406 1702 011410 1705 011435 1706 011453 1707 011455 1708 011457 4 2 011463 4 7 011465 4 9 011467 4 12 011522 4 14 011555 4 16 011610 4 18 011643 4 20 011676 4 22 011731 4 24 011764 4 29 012017 4 34 012021 4 36 012023 4 39 012061 4 41 012117 4 43 012155 4 45 012213 4 47 012251 4 49 012307 4 51 012345 4 56 012403 4 61 012405 4 63 012407 4 66 012445 4 68 012503 4 70 012541 4 72 012577 4 74 012635 4 76 012673 4 78 012731 4 83 012767 4 89 012771 5 2 013020 5 6 013022 5 8 013046 5 11 013053 5 15 013055 5 17 013101 5 22 013106 5 26 013110 5 28 013134 5 31 013141 5 35 013143 5 37 013167 5 40 013174 5 44 013176 5 46 013220 5 48 013242 5 50 013264 5 52 013306 1717 013312 1726 013313 1727 013315 1729 013316 1732 013317 1733 013321 1735 013322 1737 013324 1739 013326 1741 013327 1743 013332 1746 013337 1747 013340 1750 013346 1751 013347 1754 013355 1755 013356 1759 013364 1761 013367 1762 013417 1764 013420 1765 013427 1766 013431 1768 013433 1771 013434 1783 013435 1784 013437 1786 013440 1789 013441 1790 013443 1792 013444 1794 013446 1795 013450 1797 013452 1799 013453 1801 013474 1803 013535 1805 013540 1806 013541 1809 013547 1811 013552 1812 013566 1813 013621 1815 013623 1817 013635 1818 013637 1821 013642 1823 013645 1824 013672 1825 013675 1828 013676 1830 013701 1831 013731 1832 013734 1835 013735 1837 013741 1838 013766 1839 013771 1842 013772 1843 014004 1846 014050 1848 014055 1849 014107 1850 014142 1851 014146 1853 014147 1855 014201 1856 014202 1857 014203 1858 014207 1859 014211 1863 014213 1866 014214 1875 014215 1876 014217 1877 014221 1879 014222 1881 014223 1882 014225 1883 014227 1885 014230 1887 014231 1888 014233 1889 014235 1891 014236 1893 014237 1894 014241 1895 014242 1897 014243 1899 014244 1901 014246 1904 014253 1905 014300 1908 014301 1909 014312 1912 014315 1914 014325 1915 014352 1918 014353 1921 014357 1923 014362 1924 014407 1927 014410 1929 014435 1930 014471 1932 014473 1934 014476 6 3 014477 6 11 014500 6 12 014502 6 14 014503 6 17 014504 6 18 014505 6 22 014506 6 23 014507 6 25 014514 6 26 014516 6 27 014520 6 28 014521 6 29 014522 6 30 014524 6 32 014525 6 33 014534 6 34 014540 6 35 014543 6 36 014545 6 39 014556 6 42 014570 6 44 014571 1940 014572 1947 014606 1948 014610 1949 014622 1951 014623 1953 014637 1954 014641 1955 014660 1957 014661 1960 014675 1961 014677 1962 014755 1964 014757 1967 014765 1968 014767 1969 015021 1971 015022 1973 015025 1975 015033 1976 015055 1978 015061 1980 015067 1981 015111 1983 015115 1985 015123 1986 015145 1988 015151 1990 015154 1991 015177 1994 015203 1995 015223 1996 015227 1997 015245 1998 015251 1999 015256 2000 015260 2001 015262 2002 015266 2003 015270 2004 015272 2005 015274 7 2 015301 7 10 015307 7 11 015321 7 16 015376 7 22 015404 7 25 015431 7 29 015437 7 33 015504 7 42 015520 7 43 015521 7 44 015523 7 45 015524 7 47 015526 7 48 015531 7 50 015552 7 52 015553 7 53 015567 7 54 015574 7 55 015577 7 57 015600 7 58 015615 7 59 015617 7 60 015623 7 61 015624 7 63 015625 7 67 015626 7 68 015627 7 69 015633 7 73 015646 7 83 015662 7 85 015663 7 86 015671 7 89 015706 7 90 015707 7 93 015711 7 94 015716 7 96 015734 7 98 015736 7 99 015751 7 100 015755 7 101 015760 7 103 015761 7 104 015771 7 105 015773 7 106 015774 7 108 016004 7 108 016010 7 109 016012 7 111 016013 7 113 016014 2011 016027 2049 016035 2050 016036 2052 016044 2056 016054 2059 016064 2061 016066 2062 016114 2065 016115 2067 016117 2068 016125 2072 016131 2074 016132 2075 016135 2076 016136 2077 016142 2079 016146 2080 016174 2082 016175 2083 016204 2087 016205 2089 016207 2091 016215 2093 016220 2095 016222 2097 016236 2099 016240 2100 016267 2103 016270 2105 016272 2107 016275 2109 016276 2111 016301 2112 016303 2114 016304 2116 016307 2117 016310 2119 016311 2129 016317 2131 016323 2133 016326 2134 016333 2136 016342 2139 016360 2140 016406 2144 016407 2146 016411 2147 016416 2149 016425 2152 016471 2153 016517 2157 016520 2159 016522 2160 016527 2162 016536 2165 016612 2166 016640 2170 016641 2172 016643 2173 016650 2175 016663 2177 016667 2179 016700 2181 016705 2182 016733 2185 016734 2186 016741 2190 016746 2192 016756 2194 016767 2195 016774 2199 017000 2200 017004 2201 017032 2204 017036 8 3 017041 8 11 017047 8 12 017051 8 14 017052 8 17 017060 8 18 017061 8 22 017062 8 23 017065 8 25 017072 8 26 017074 8 27 017076 8 28 017077 8 29 017100 8 30 017102 8 32 017103 8 33 017112 8 34 017116 8 35 017121 8 36 017123 8 39 017134 8 42 017147 8 44 017150 2210 017151 2224 017157 2225 017162 2226 017164 2228 017166 2229 017205 2230 017224 2231 017243 2232 017262 2233 017301 2235 017320 2237 017324 2238 017354 2240 017360 2242 017361 2251 017411 2253 017415 2257 017465 2258 017472 2260 017476 2264 017550 2265 017555 2267 017561 2271 017630 2272 017635 2275 017641 2279 017714 2280 017721 2282 017725 2286 020000 2287 020005 2290 020011 2294 020101 2295 020106 2298 020112 2302 020202 2303 020207 2305 020213 2308 020220 2309 020302 2312 020344 2313 020351 2316 020355 2327 020361 2329 020411 2330 020415 2333 020430 2335 020436 2338 020451 2340 020457 2343 020472 2345 020500 2348 020505 2350 020520 2352 020526 2354 020530 2356 020543 2359 020551 2360 020556 2363 020562 2365 020604 2367 020610 2369 020632 2371 020636 2373 020660 2375 020664 2377 020706 2379 020712 2381 020734 2383 020740 2385 020762 2387 020766 2390 020777 2391 021034 2392 021070 9 2 021072 9 6 021074 9 8 021122 9 11 021127 9 15 021131 9 17 021157 9 22 021164 9 26 021166 9 28 021214 9 31 021221 9 35 021223 9 37 021251 9 40 021256 9 44 021260 9 46 021302 9 48 021324 9 50 021346 9 52 021370 10 2 021374 10 7 021376 10 9 021400 10 12 021435 10 14 021472 10 16 021527 10 18 021564 10 20 021621 10 22 021656 10 24 021713 10 29 021750 10 34 021752 10 36 021754 10 39 022014 10 41 022054 10 43 022114 10 45 022154 10 47 022214 10 49 022254 10 51 022314 10 56 022354 10 61 022356 10 63 022360 10 66 022420 10 68 022460 10 70 022520 10 72 022560 10 74 022620 10 76 022660 10 78 022720 10 83 022760 10 89 022762 2402 023013 2407 023015 2410 023063 2411 023064 2412 023073 2413 023075 2414 023076 2415 023100 2416 023101 2418 023102 2420 023103 2423 023104 2424 023111 2426 023112 2428 023113 2435 023114 2436 023116 2438 023117 2439 023131 2440 023133 2441 023140 2443 023142 2449 023144 2450 023153 2451 023160 2452 023166 2453 023173 2456 023174 2458 023177 2460 023201 2461 023203 2465 023204 2471 023206 2472 023217 2473 023221 2475 023223 2477 023224 2485 023226 2486 023235 2488 023243 2490 023256 2494 023263 2526 023274 2528 023277 2529 023302 2530 023304 2531 023311 2533 023312 2534 023321 2535 023326 2536 023330 2538 023332 2540 023334 2541 023343 2544 023345 2545 023352 2547 023354 2548 023364 2551 023371 2553 023401 2555 023402 2556 023403 2558 023406 2560 023412 2562 023430 2563 023434 2564 023443 2565 023446 2566 023450 2567 023452 2568 023455 2570 023457 2572 023466 2573 023470 2575 023471 2590 023502 2591 023506 2593 023510 2595 023512 2596 023515 2597 023517 2598 023524 2600 023525 2601 023535 2602 023542 2603 023544 2605 023546 2607 023550 2608 023557 2611 023561 2612 023566 2614 023570 2615 023600 2617 023611 2618 023615 2619 023621 2621 023622 2622 023625 2623 023641 2625 023642 11 21 023643 11 40 023651 11 41 023657 11 42 023663 11 43 023675 11 44 023705 11 45 023710 11 47 023720 11 48 023727 11 49 023733 11 50 023741 ----------------------------------------------------------- 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