COMPILATION LISTING OF SEGMENT lex Compiled by: Multics PL/I Compiler, Release 33e, of October 6, 1992 Compiled at: CGI Compiled on: 2000-04-18_1149.67_Tue_mdt Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1989 * 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(89-04-17,JRGray), approve(89-04-17,MCR8078), audit(89-04-18,Huen), 17* install(89-06-09,MR12.3-1055): 18* Modified to allow for archive component source programs. 19* 2) change(89-07-10,RWaters), approve(89-07-10,MCR8118), audit(89-07-19,Vu), 20* install(89-07-31,MR12.3-1066): 21* Removed the obsolete parameter source_line from the call to error_(). 22* 3) change(89-08-01,RWaters), approve(89-08-01,MCR8069), audit(89-09-07,Vu), 23* install(89-09-19,MR12.3-1068): 24* Fix bug 1748. 25* 4) change(89-10-03,Vu), approve(89-10-03,MCR8139), audit(89-10-04,Blackmore), 26* install(89-10-09,MR12.3-1086): 27* Allow the use of named constants as replication factors. 28* 5) change(91-01-18,Blackmore), approve(91-01-18,MCR8234), 29* audit(91-12-05,Huen), install(92-04-24,MR12.5-1011): 30* Change entry pts. and dcl of 'constant_token' entry to allow passing a ptr 31* to the current block, for the constant reference resolution fix. 32* END HISTORY COMMENTS */ 33 34 35 /* lex is the lexical analysis program for the Multics PL/I compiler. Its primary responsibilities are: 36* 1. Break the source program into tokens. 37* 2. Process %include statements. 38* 3. Generate a line-numbered source listing. 39* 4. Diagnose errors in lexical syntax of programs. 40* 41* lex also performs several other chores during its operation that eliminate a few of the 42* vagaries of the PL/I language, thus making the job of subsequent phases simpler. They are: 43* 1. Apply string repetition factors. 44* 2. Apply bit-string radix factors. 45* 3. Determine the type of numeric constants. 46* 4. Notice equal signs at level 0 of parenthesis. 47* 5. Notice colons at level 0 of parenthesis. 48* 49* The original version of lex was written by J.D.Mills, 26 March 1968. 50* Totally rewritten to use EIS in April, 1977 by P. Green. 51* Modified 770713 by PG to put back in checks for errors 157 and 158. 52* Modified 771020 by PG to fix 1677 (compiler faults if no status permission to main source program), 53* and 1668 (lex can fault if a stmt has > 3000 tokens) 54* Modified 780607 by PG to fix 1738 (print one more character of source line for errors 157 and 158) 55* Modified 780804 by PG to fix 1759 (not supplying substitutable argument for errors 109 and 110). 56* Modified 790730 by PG to use rank builtin, to create enter_token facility, reducing number of calls 57* to create_token, and to implement %page and %skip. 58* Modified 7 October 1980 by M. N. Davidoff to fix 1989 (uninitialized variable can cause lex to fault 59* on null statements) and to implement 1914 (call com_err_ with find_include_file_ code). 60* Modified 25 April 1983 by R Gray to allow archive component source files 61* Modified 7 Feb 1989 by RW deleted obsolete parameter to error_ 62* Modified 1 Jan 1989 by RW print new message disallowing pathnames in 63* the %include macro 64**/ 65 /* format: style3,^indattr,ifthendo,ifthen,^indnoniterdo,indproc,^elsestmt,dclind9 */ 66 lex: 67 procedure (cblock); 68 69 /* parameter */ 70 71 declare cblock pointer parameter; /* pointer to current block */ 72 73 /* automatic */ 74 75 declare action_index fixed bin, /* index of action to execute */ 76 bitcount fixed bin (24), /* bitcount of include segment */ 77 char_value fixed bin (9), /* numeric value of current character */ 78 code fixed bin (35), /* standard status code */ 79 current_char char (1) aligned, /* character that stopped the scan, char we are checking */ 80 depthx fixed bin, /* do-loop temporary */ 81 decimal_value bit (9) aligned, /* flag meaning constant is decimal, not binary */ 82 dx fixed bin, /* temporary used in radix expansion */ 83 error_number fixed bin (15), /* temp to hold error number for call to lex_error */ 84 error_token ptr, /* temp to hold token ptr for call to lex_error */ 85 first_bit fixed bin, /* temporary used in radix expansion */ 86 float_value bit (9) aligned, /* flag meaning constant is float, not fixed */ 87 imaginary_value bit (9) aligned, /* flag meaning constant is imaginary, not real */ 88 include_file_length fixed bin (21), /* length, in chars, of new include file */ 89 include_file_name char (32) varying, /* name of include file */ 90 include_file_ptr ptr, /* ptr to base of include file */ 91 integral_value bit (9) aligned, /* flag meaning constant is integral, not fractional */ 92 k fixed bin, /* index into t_table */ 93 line_length fixed bin (21), /* number of chars to be printed in listing */ 94 listing_on bit (1) aligned, /* flag meaning to generate a source listing */ 95 max_in_chars fixed bin, /* max string length before radix expansion */ 96 n fixed bin (21), /* temp used when allocating a source node */ 97 new_file_number fixed bin (8), /* number of new source file */ 98 new_file_token_ptr ptr, /* ptr to token node for new include file name */ 99 page_macro bit (1) aligned, /* "1"b iff macro was %page, not %skip */ 100 parenthesis_level fixed bin (21), /* nesting depth of parenthesis in current statement */ 101 percent_sign_seen bit (1) aligned, /* a %-sign was seen during scan...ck for %include later */ 102 protected bit (18) aligned, /* "1"b iff current (constant) token is protected from default */ 103 radix fixed bin, /* radix of bit string begin expanded */ 104 rep_factor fixed bin, /* string replication factor */ 105 saved_token_index fixed bin, /* token_index at time % was seen */ 106 scan_index fixed bin (21), /* index (relative to source_index) of forward scan */ 107 string_max fixed bin (21), /* temporary used in rep_factor checking */ 108 string_token_start fixed bin (21), /* if token_start = 0, string_token_start holds offset 109* of first char of token in source seg */ 110 strx fixed bin, /* temporary used in radix expansion */ 111 temp_token_string char (256) varying, /* copy of token used by replication and radix code */ 112 token_index fixed bin, /* index of current token being created */ 113 token_length fixed bin (21), /* length of token in characters */ 114 token_ptr ptr unal, /* ptr to current delimiter token */ 115 token_start fixed bin (21), /* index of first character of current token */ 116 token_string char (256) varying, /* current token in some hairy cases */ 117 token_string_ptr ptr, /* ptr to token string, wherever it is */ 118 token_type bit (9) aligned; /* type of current token */ 119 120 /* based */ 121 122 declare source_string char (source_length) based (source_ptr), 123 /* overlay of current source segment */ 124 token_overlay char (token_length) based (token_string_ptr); 125 /* overlay of current token */ 126 127 /* builtins */ 128 129 declare (addr, addrel, binary, bit, char, copy, divide, hbound, index, lbound, length, ltrim, null, rank, rtrim, search, 130 string, substr, verify) builtin; 131 132 /* entries */ 133 134 declare com_err_ entry options (variable); 135 declare constant_token entry (ptr, ptr, bit(9) aligned, bit(9) aligned) returns (bit(9)); 136 declare date_time_ entry (fixed bin (71), char (*)); 137 declare find_include_file_$initiate_count entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35)); 138 declare hcs_$terminate_noname entry (ptr, fixed bin (35)); 139 140 /* external static */ 141 142 declare error_table_$noentry fixed bin (35) external static; 143 declare ( 144 pl1_stat_$cur_statement ptr, /* ptr to tree for current statement...cleared by lex */ 145 pl1_stat_$level_0_colon bit (1) aligned, /* "1"b iff colon seen at level 0 of parens */ 146 pl1_stat_$level_0_equal bit (1) aligned, /* "1"b iff equal sign seen at level 0 of parens */ 147 pl1_stat_$line_count fixed bin, /* grand total of number of source lines processed */ 148 pl1_stat_$listing_on bit (1) aligned, /* "1"b iff line-numbered source listing being created */ 149 pl1_stat_$seg_name char (32) varying, /* name of main source program, w/o .pl1 suffix */ 150 pl1_stat_$st_length fixed bin (21), /* length of current statement */ 151 pl1_stat_$st_start fixed bin (21) /* 0-origin char offset of begining of current statement; 152* value -1 means it has never been set */ 153 ) external static; 154 155 /* internal static */ 156 157 declare ( 158 file_token_ptr ptr, /* ptr to token node for current file name */ 159 lexing_after_end_stmt bit (1) aligned, /* "1"b iff main procedure has been lexed and we are 160* just scanning comments and white space */ 161 line_begins_in_comment bit (1) aligned, /* "1"b iff source line begins inside a comment */ 162 line_number fixed bin (14), /* line number of current line in source segment */ 163 line_start fixed bin (21), /* offset of first char to be printed in listing */ 164 source_depth fixed bin, /* 0-origin nesting depth of include files */ 165 source_index fixed bin (21), /* index into current source segment */ 166 source_length fixed bin (21), /* length (in characters) of current source segment */ 167 source_ptr ptr, /* pointer to base of current source segment */ 168 statement_number fixed bin (5), /* number of statement on current line */ 169 suppress_line_numbers bit (1) aligned /* next listing line should not have source numbers */ 170 ) internal static; 171 172 declare (and_token_ptr, arrow_token_ptr, assignment_token_ptr, asterisk_token_ptr, cat_token_ptr, colon_token_ptr, 173 comma_token_ptr, expon_token_ptr, ge_token_ptr, gt_token_ptr, le_token_ptr, left_parn_token_ptr, lt_token_ptr, 174 minus_token_ptr, ne_token_ptr, ngt_token_ptr, nlt_token_ptr, not_token_ptr, or_token_ptr, percent_token_ptr, 175 period_token_ptr, plus_token_ptr, right_parn_token_ptr, semi_colon_token_ptr, slash_token_ptr) ptr 176 unaligned internal static; /* ptrs to like-named tokens */ 177 178 declare 1 file_stack (0:32) aligned internal static, /* Pushdown stack used to process nested include files */ 179 2 source_ptr ptr, /* ptr to base of source segment */ 180 2 file_token_ptr ptr, /* ptr to token node for file name */ 181 2 source_index fixed bin (21), /* index (in chars) of lexical scan */ 182 2 source_length fixed bin (21), /* length (in chars) of source segment */ 183 2 line_number fixed bin (14), /* line number in source segment */ 184 2 file_number fixed bin (8); /* file number of source segment */ 185 186 declare action_table (0:128) fixed bin internal static initial (/* what action label to take given ASCII char */ (9) 9, 187 /* 000-010 ctl chars */ 188 1, /* 011 tab */ 189 8, /* 012 newline */ 190 (2) 1, /* 013-014 vt, np */ 191 (19) 9, /* 015-037 ctl chars */ 192 1, /* 040 sp */ 193 9, /* 041 ! */ 194 2, /* 042 " */ 195 9, /* 043 # */ 196 9, /* 044 $ */ 197 4, /* 045 % */ 198 17, /* 046 & */ 199 9, /* 047 ' */ 200 18, /* 050 ( */ 201 19, /* 051 ) */ 202 10, /* 052 * */ 203 20, /* 053 + */ 204 21, /* 054 , */ 205 11, /* 055 - */ 206 7, /* 056 . */ 207 5, /* 057 / */ 208 (10) 6, /* 060-071 0 - 9 */ 209 22, /* 072 : */ 210 16, /* 073 ; */ 211 12, /* 074 < */ 212 23, /* 075 = */ 213 13, /* 076 > */ 214 (2) 9, /* 077-100 ? @ */ 215 (26) 3, /* 101-132 A - Z */ 216 (3) 9, /* 133-135 [ \ ] */ 217 14, /* 136 ^ */ 218 (2) 9, /* 137-140 _ ` */ 219 (26) 3, /* 141-172 a - z */ 220 9, /* 173 { */ 221 15, /* 174 | */ 222 (3) 9, /* 175-177 { ~ PAD */ 223 9); /* >177 non-ASCII */ 224 225 declare command char (3) internal static options (constant) initial ("pl1"); 226 declare ( 227 asterisk_or_newline char (2) initial ("* 228 "), 229 double_quote char (1) initial (""""), 230 double_quote_or_newline char (2) initial (""" 231 "), 232 HT_VT_NP_SP char (4) initial (" "), 233 identifier_characters char (64) initial ("$0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"), 234 newline char (1) initial (" 235 "), 236 newpage char (1) initial (" ") 237 ) internal static; 238 239 /* include files */ 240 1 1 /****^ ********************************************************* 1 2* * * 1 3* * Copyright, (C) BULL HN Information Systems Inc., 1989 * 1 4* * * 1 5* ********************************************************* */ 1 6 1 7 /* BEGIN INCLUDE FILE ... language_utility.incl.pl1 */ 1 8 1 9 1 10 /****^ HISTORY COMMENTS: 1 11* 1) change(89-07-10,RWaters), approve(89-07-10,MCR8118), audit(89-07-19,Vu), 1 12* install(89-07-31,MR12.3-1066): 1 13* Removed the obsolete parameter source_line from the dcl of error_(). 1 14* END HISTORY COMMENTS */ 1 15 1 16 /* Modified: 6 Jun 1979 by PG to add rank and byte 1 17* * Modified: 9 Jul 1989 by RW updated the declaration of error_ 1 18* */ 1 19 1 20 declare adjust_count entry(pointer); 1 21 /* parameter 1: (input) any node pointer */ 1 22 1 23 declare bindec entry(fixed bin(31)) reducible 1 24 returns(character(12) aligned); 1 25 /* parameter 1: (input) bin value */ 1 26 /* return: (output) character value with blanks */ 1 27 1 28 declare bindec$vs entry(fixed bin(31)) reducible 1 29 returns(character(12) aligned varying); 1 30 /* parameter 1: (input) binary value */ 1 31 /* return: (output) char value without blanks */ 1 32 1 33 declare binoct entry(fixed bin(31)) reducible 1 34 returns(char(12) aligned); 1 35 /* parameter 1: (input) binary value */ 1 36 /* return: (output) char value with blanks */ 1 37 1 38 declare binary_to_octal_string entry(fixed bin(31)) reducible 1 39 returns(char(12) aligned); 1 40 /* parameter 1: (input) binary value */ 1 41 /* return: (output) right-aligned char value */ 1 42 1 43 declare binary_to_octal_var_string entry(fixed bin(31)) reducible 1 44 returns(char(12) varying aligned); 1 45 /* parameter 1: (input) binary value */ 1 46 /* returns: (output) char value without blanks */ 1 47 1 48 declare compare_expression entry(pointer,pointer) reducible 1 49 returns(bit(1) aligned); 1 50 /* parameter 1: (input) any node pointer */ 1 51 /* parameter 2: (input) any node pointer */ 1 52 /* return: (output) compare bit */ 1 53 1 54 declare constant_length entry (pointer, fixed bin (71)) 1 55 returns (bit (1) aligned); 1 56 /* parameter 1: (input) reference node pointer */ 1 57 /* parameter 2: (input) value of constant length */ 1 58 /* return: (output) "1"b if constant length */ 1 59 1 60 declare convert entry(pointer,bit(36) aligned) 1 61 returns(pointer); 1 62 /* parameter 1: (input) any node pointer */ 1 63 /* parameter 2: (input) target type */ 1 64 /* return: (output) target value tree pointer */ 1 65 1 66 declare convert$to_integer entry(pointer,bit(36)aligned) 1 67 returns(pointer); 1 68 /* parameter 1: (input) any node pointer */ 1 69 /* parameter 2: (input) target type */ 1 70 /* return: (output) target value tree pointer */ 1 71 1 72 declare convert$from_builtin entry(pointer,bit(36) aligned) 1 73 returns(pointer); 1 74 /* parameter 1: (input) any node pointer */ 1 75 /* parameter 2: (input) target type */ 1 76 /* return: (output) target value tree pointer */ 1 77 1 78 declare convert$validate entry(pointer,pointer); 1 79 /* parameter 1: (input) source value tree pointer */ 1 80 /* parameter 2: (input) target reference node pointer */ 1 81 1 82 declare convert$to_target_fb entry(pointer,pointer) 1 83 returns(pointer); 1 84 /* parameter 1: (input) source value tree pointer */ 1 85 /* parameter 2: (input) target reference node pointer */ 1 86 /* return: (output) target value tree pointer */ 1 87 1 88 declare convert$to_target entry(pointer,pointer) 1 89 returns(pointer); 1 90 /* parameter 1: (input) source value tree pointer */ 1 91 /* parameter 2: (input) target reference node pointer */ 1 92 /* return: (output) target value tree pointer */ 1 93 1 94 declare copy_expression entry(pointer unaligned) 1 95 returns(pointer); 1 96 /* parameter 1: (input) any node pointer */ 1 97 /* return: (output) any node pointer */ 1 98 1 99 declare copy_expression$copy_sons entry(pointer,pointer); 1 100 /* parameter 1: (input) father symbol node pointer */ 1 101 /* parameter 2: (input) stepfather symbol node ptr */ 1 102 1 103 declare copy_unique_expression entry(pointer) 1 104 returns(pointer); 1 105 /* parameter 1: (input) any node pointer */ 1 106 /* return: (output) any node pointer */ 1 107 1 108 declare create_array entry() 1 109 returns(pointer); 1 110 /* return: (output) array node pointer */ 1 111 1 112 declare create_block entry(bit(9) aligned,pointer) 1 113 returns(pointer); 1 114 /* parameter 1: (input) block type */ 1 115 /* parameter 2: (input) father block node pointer */ 1 116 /* return: (output) block node pointer */ 1 117 1 118 declare create_bound entry() 1 119 returns(pointer); 1 120 /* return: (output) bound node pointer */ 1 121 1 122 declare create_context entry(pointer,pointer) 1 123 returns(pointer); 1 124 /* parameter 1: (input) block node pointer */ 1 125 /* parameter 2: (input) token pointer */ 1 126 /* return: (output) context node pointer */ 1 127 1 128 declare create_cross_reference entry() 1 129 returns(pointer); 1 130 /* return: (output) cross reference node pointer */ 1 131 1 132 declare create_default entry 1 133 returns(pointer); 1 134 /* return: (output) default node pointer */ 1 135 1 136 declare create_identifier entry() 1 137 returns(pointer); 1 138 /* return: (output) token node pointer */ 1 139 1 140 declare create_label entry(pointer,pointer,bit(3) aligned) 1 141 returns(pointer); 1 142 /* parameter 1: (input) block node pointer */ 1 143 /* parameter 2: (input) token node pointer */ 1 144 /* parameter 3: (input) declare type */ 1 145 /* return: (output) label node pointer */ 1 146 1 147 declare create_list entry(fixed bin(15)) 1 148 returns(pointer); 1 149 /* parameter 1: (input) number of list elements */ 1 150 /* return: (output) list node pointer */ 1 151 1 152 declare create_operator entry(bit(9) aligned,fixed bin(15)) 1 153 returns(pointer); 1 154 /* parameter 1: (input) operator type */ 1 155 /* parameter 2: (input) number of operands */ 1 156 /* return: (output) operator node pointer */ 1 157 1 158 declare create_reference entry(pointer) 1 159 returns(pointer); 1 160 /* parameter 1: (input) symbol node pointer */ 1 161 /* return: (output) reference node pointer */ 1 162 1 163 declare create_statement entry(bit(9) aligned,pointer,pointer,bit(12) aligned) 1 164 returns(pointer); 1 165 /* parameter 1: (input) statement type */ 1 166 /* parameter 2: (input) block node pointer */ 1 167 /* parameter 3: (input) label node pointer */ 1 168 /* parameter 4: (input) conditions */ 1 169 /* return: (output) statement node pointer */ 1 170 1 171 declare create_statement$prologue entry(bit(9) aligned,pointer,pointer,bit(12) aligned) 1 172 returns(pointer); 1 173 /* parameter 1: (input) statement type */ 1 174 /* parameter 2: (input) block node pointer */ 1 175 /* parameter 3: (input) label node pointer */ 1 176 /* parameter 4: (input) conditions */ 1 177 /* return: (output) statement node pointer */ 1 178 1 179 declare create_storage entry(fixed bin(15)) 1 180 returns(pointer); 1 181 /* parameter 1: (input) number of words */ 1 182 /* return: (output) storage block pointer */ 1 183 1 184 declare create_symbol entry(pointer,pointer,bit(3) aligned) 1 185 returns(pointer); 1 186 /* parameter 1: (input) block node pointer */ 1 187 /* parameter 2: (input) token node pointer */ 1 188 /* parameter 3: (input) declare type */ 1 189 /* return: (output) symbol node pointer */ 1 190 1 191 declare create_token entry (character (*), bit (9) aligned) 1 192 returns (ptr); 1 193 /* parameter 1: (input) token string */ 1 194 /* parameter 2: (input) token type */ 1 195 /* return: (output) token node ptr */ 1 196 1 197 declare create_token$init_hash_table entry (); 1 198 1 199 declare create_token$protected entry (char (*), bit (9) aligned, bit (18) aligned) 1 200 returns (ptr); 1 201 /* parameter 1: (input) token string */ 1 202 /* parameter 2: (input) token type */ 1 203 /* parameter 3: (input) protected flag */ 1 204 /* return: (output) token node ptr */ 1 205 1 206 declare decbin entry(character(*) aligned) reducible 1 207 returns(fixed bin(31)); 1 208 /* parameter 1: (input) decimal character string */ 1 209 /* return: (output) binary value */ 1 210 1 211 declare declare_constant entry(bit(*) aligned,bit(36) aligned,fixed bin(31),fixed bin(15)) 1 212 returns(pointer); 1 213 /* parameter 1: (input) value */ 1 214 /* parameter 2: (input) type */ 1 215 /* parameter 3: (input) size */ 1 216 /* parameter 4: (input) scale */ 1 217 /* return: (output) reference node pointer */ 1 218 1 219 declare declare_constant$bit entry(bit(*) aligned) 1 220 returns(pointer); 1 221 /* parameter 1: (input) bit */ 1 222 /* return: (output) reference node pointer */ 1 223 1 224 declare declare_constant$char entry(character(*) aligned) 1 225 returns(pointer); 1 226 /* parameter 1: (input) character */ 1 227 /* return: (output) reference node pointer */ 1 228 1 229 declare declare_constant$desc entry(bit(*) aligned) 1 230 returns(pointer); 1 231 /* parameter 1: (input) descriptor bit value */ 1 232 /* return: (output) reference node pointer */ 1 233 1 234 declare declare_constant$integer entry(fixed bin(31)) /* note...should really be fixed bin(24) */ 1 235 returns(pointer); 1 236 /* parameter 1: (input) integer */ 1 237 /* return: (output) reference node pointer */ 1 238 1 239 declare declare_descriptor entry(pointer,pointer,pointer,pointer,bit(2) aligned) 1 240 returns(pointer); 1 241 /* parameter 1: (input) block node pointer */ 1 242 /* parameter 2: (input) statement node pointer */ 1 243 /* parameter 3: (input) symbol node pointer */ 1 244 /* parameter 4: (input) loc pointer */ 1 245 /* parameter 5: (input) array descriptor bit 1 246* cross_section bit */ 1 247 /* return: (output) reference node pointer */ 1 248 1 249 declare declare_descriptor$ctl entry(pointer,pointer,pointer,pointer,bit(2) aligned) 1 250 returns(pointer); 1 251 /* parameter 1: (input) block node pointer */ 1 252 /* parameter 2: (input) statement node pointer */ 1 253 /* parameter 3: (input) symbol node pointer */ 1 254 /* parameter 4: (input) loc pointer */ 1 255 /* parameter 5: (input) array descriptor bit 1 256* cross_section bit */ 1 257 /* return: (output) reference node pointer */ 1 258 1 259 declare declare_descriptor$param entry(pointer,pointer,pointer,pointer,bit(2) aligned) 1 260 returns(pointer); 1 261 /* parameter 1: (input) block node pointer */ 1 262 /* parameter 2: (input) statement node pointer */ 1 263 /* parameter 3: (input) symbol node pointer */ 1 264 /* parameter 4: (input) loc pointer */ 1 265 /* parameter 5: (input) array descriptor bit 1 266* cross_section bit */ 1 267 /* return: (output) reference node pointer */ 1 268 1 269 declare declare_integer entry(pointer) 1 270 returns(pointer); 1 271 /* parameter 1: (input) block node pointer */ 1 272 /* return: (output) reference node pointer */ 1 273 1 274 declare declare_picture entry(char(*)aligned,pointer,fixed bin(15)); 1 275 /* parameter 1: (input) picture string */ 1 276 /* parameter 2: (input) symbol node pointer */ 1 277 /* parameter 3: (output) error code, if any */ 1 278 1 279 declare declare_picture_temp entry(char(*) aligned,fixed bin(31),bit(1) aligned,bit(1) aligned) 1 280 returns(pointer); 1 281 /* parameter 1: (input) picture string */ 1 282 /* parameter 2: (input) scalefactor of picture */ 1 283 /* parameter 3: (input) ="1"b => complex picture */ 1 284 /* parameter 4: (input) ="1"b => unaligned temp */ 1 285 /* return: (output) reference node pointer */ 1 286 1 287 declare declare_pointer entry(pointer) 1 288 returns(pointer); 1 289 /* parameter 1: (input) block node pointer */ 1 290 /* return: (output) reference node pointer */ 1 291 1 292 declare declare_temporary entry(bit(36) aligned,fixed bin(31),fixed bin(15),pointer) 1 293 returns(pointer); 1 294 /* parameter 1: (input) type */ 1 295 /* parameter 2: (input) precision */ 1 296 /* parameter 3: (input) scale */ 1 297 /* parameter 4: (input) length */ 1 298 /* return: (output) reference node pointer */ 1 299 1 300 declare decode_node_id entry(pointer,bit(1) aligned) 1 301 returns(char(120) varying); 1 302 /* parameter 1: (input) node pointer */ 1 303 /* parameter 2: (input) ="1"b => capitals */ 1 304 /* return: (output) source line id */ 1 305 1 306 declare decode_source_id entry( 2 1 1 structure unaligned, 2 2 2 /* file_number */ bit(8), 2 3 2 /* line_number */ bit(14), 2 4 2 /* stmt_number */ bit(5), 1 307 1 308 bit(1) aligned) 1 309 returns(char(120) varying); 1 310 /* parameter 1: (input) source id */ 1 311 /* parameter 2: (input) ="1"b => capitals */ 1 312 /* return: (output) source line id */ 1 313 1 314 declare error entry(fixed bin(15),pointer,pointer); 1 315 /* parameter 1: (input) error number */ 1 316 /* parameter 2: (input) statement node pointer or null*/ 1 317 /* parameter 3: (input) token node pointer */ 1 318 1 319 declare error$omit_text entry(fixed bin(15),pointer,pointer); 1 320 /* parameter 1: (input) error number */ 1 321 /* parameter 2: (input) statement node pointer or null*/ 1 322 /* parameter 3: (input) token node pointer */ 1 323 1 324 declare error_ entry(fixed bin(15), 3 1 1 structure unaligned, 3 2 2 /* file_number */ bit(8), 3 3 2 /* line_number */ bit(14), 3 4 2 /* stmt_number */ bit(5), 1 325 1 326 pointer,fixed bin(8),fixed bin(23),fixed bin(11)); 1 327 /* parameter 1: (input) error number */ 1 328 /* parameter 2: (input) statement id */ 1 329 /* parameter 3: (input) any node pointer */ 1 330 /* parameter 4: (input) source segment */ 1 331 /* parameter 5: (input) source starting character */ 1 332 /* parameter 6: (input) source length */ 1 333 1 334 declare error_$no_text entry(fixed bin(15), 4 1 1 structure unaligned, 4 2 2 /* file_number */ bit(8), 4 3 2 /* line_number */ bit(14), 4 4 2 /* stmt_number */ bit(5), 1 335 1 336 pointer); 1 337 /* parameter 1: (input) error number */ 1 338 /* parameter 2: (input) statement id */ 1 339 /* parameter 3: (input) any node pointer */ 1 340 1 341 declare error_$initialize_error entry(); 1 342 1 343 declare error_$finish entry(); 1 344 1 345 declare free_node entry(pointer); 1 346 /* parameter 1: any node pointer */ 1 347 1 348 declare get_array_size entry(pointer,fixed bin(3)); 1 349 /* parameter 1: (input) symbol node pointer */ 1 350 /* parameter 2: (input) units */ 1 351 1 352 declare get_size entry(pointer); 1 353 /* parameter 1: (input) symbol node pointer */ 1 354 1 355 declare merge_attributes external entry(pointer,pointer) 1 356 returns(bit(1) aligned); 1 357 /* parameter 1: (input) target symbol node pointer */ 1 358 /* parameter 2: (input) source symbol node pointer */ 1 359 /* return: (output) "1"b if merge was unsuccessful */ 1 360 1 361 declare optimizer entry(pointer); 1 362 /* parameter 1: (input) root pointer */ 1 363 1 364 declare parse_error entry(fixed bin(15),pointer); 1 365 /* parameter 1: (input) error number */ 1 366 /* parameter 2: (input) any node pointer */ 1 367 1 368 declare parse_error$no_text entry(fixed bin(15),pointer); 1 369 /* parameter 1: (input) error number */ 1 370 /* parameter 2: (input) any node pointer */ 1 371 1 372 declare pl1_error_print$write_out 1 373 entry(fixed bin(15), 5 1 1 structure unaligned, 5 2 2 /* file_number */ bit(8), 5 3 2 /* line_number */ bit(14), 5 4 2 /* stmt_number */ bit(5), 1 374 1 375 pointer,fixed bin(11),fixed bin(31),fixed bin(31),fixed bin(15)); 1 376 /* parameter 1: (input) error number */ 1 377 /* parameter 2: (input) statement identification */ 1 378 /* parameter 3: (input) any node pointer */ 1 379 /* parameter 4: (input) source segment */ 1 380 /* parameter 5: (input) source character index */ 1 381 /* parameter 6: (input) source length */ 1 382 /* parameter 7: (input) source line */ 1 383 1 384 declare pl1_error_print$listing_segment 1 385 entry(fixed bin(15), 6 1 1 structure unaligned, 6 2 2 /* file_number */ bit(8), 6 3 2 /* line_number */ bit(14), 6 4 2 /* stmt_number */ bit(5), 1 386 1 387 pointer); 1 388 /* parameter 1: (input) error number */ 1 389 /* parameter 2: (input) statement identification */ 1 390 /* parameter 3: (input) token node pointer */ 1 391 1 392 declare pl1_print$varying entry(character(*) aligned varying); 1 393 /* parameter 1: (input) string */ 1 394 1 395 declare pl1_print$varying_nl entry(character(*) aligned varying); 1 396 /* parameter 1: (input) string */ 1 397 1 398 declare pl1_print$non_varying entry(character(*) aligned,fixed bin(31)); 1 399 /* parameter 1: (input) string */ 1 400 /* parameter 2: (input) string length or 0 */ 1 401 1 402 declare pl1_print$non_varying_nl entry(character(*) aligned,fixed bin(31)); 1 403 /* parameter 1: (input) string */ 1 404 /* parameter 2: (input) string length or 0 */ 1 405 1 406 declare pl1_print$string_pointer entry(pointer,fixed bin(31)); 1 407 /* parameter 1: (input) string pointer */ 1 408 /* parameter 2: (input) string size */ 1 409 1 410 declare pl1_print$string_pointer_nl entry(pointer,fixed bin(31)); 1 411 /* parameter 1: (input) string pointer */ 1 412 /* parameter 2: (input) string length or 0 */ 1 413 1 414 declare pl1_print$unaligned_nl entry(character(*) unaligned,fixed bin(31)); 1 415 /* parameter 1: (input) string */ 1 416 /* parameter 2: (input) length */ 1 417 1 418 declare pl1_print$for_lex entry (ptr, fixed bin (14), fixed bin (21), fixed bin (21), bit (1) aligned, bit (1) aligned); 1 419 /* parameter 1: (input) ptr to base of source segment */ 1 420 /* parameter 2: (input) line number */ 1 421 /* parameter 3: (input) starting offset in source seg */ 1 422 /* parameter 4: (input) number of chars to copy */ 1 423 /* parameter 5: (input) ON iff shd print line number */ 1 424 /* parameter 6: (input) ON iff line begins in comment */ 1 425 1 426 declare refer_extent entry(pointer,pointer); 1 427 /* parameter 1: (input/output) null,ref node,op node pointer */ 1 428 /* parameter 2: (input) null,ref node,op node pointer */ 1 429 1 430 declare reserve$clear entry() 1 431 returns(pointer); 1 432 /* return: (output) pointer */ 1 433 1 434 declare reserve$declare_lib entry(fixed bin(15)) 1 435 returns(pointer); 1 436 /* parameter 1: (input) builtin function number */ 1 437 /* return: (output) pointer */ 1 438 1 439 declare reserve$read_lib entry(fixed bin(15)) 1 440 returns(pointer); 1 441 /* parameter 1: (input) builtin function number */ 1 442 /* return: (output) pointer */ 1 443 1 444 declare semantic_translator entry(); 1 445 1 446 declare semantic_translator$abort entry(fixed bin(15),pointer); 1 447 /* parameter 1: (input) error number */ 1 448 /* parameter 2: (input) any node pointer */ 1 449 1 450 declare semantic_translator$error entry(fixed bin(15),pointer); 1 451 /* parameter 1: (input) error number */ 1 452 /* parameter 2: (input) any node pointer */ 1 453 1 454 declare share_expression entry(ptr) 1 455 returns(ptr); 1 456 /* parameter 1: (input) usually operator node pointer */ 1 457 /* return: (output) tree pointer or null */ 1 458 1 459 declare token_to_binary entry(ptr) reducible 1 460 returns(fixed bin(31)); 1 461 /* parameter 1: (input) token node pointer */ 1 462 /* return: (output) converted binary value */ 1 463 1 464 /* END INCLUDE FILE ... language_utility.incl.pl1 */ 241 7 1 /* BEGIN INCLUDE FILE ... nodes.incl.pl1 */ 7 2 7 3 /* Modified: 26 Dec 1979 by PCK to implement by name assignment */ 7 4 7 5 dcl ( block_node initial("000000001"b), 7 6 statement_node initial("000000010"b), 7 7 operator_node initial("000000011"b), 7 8 reference_node initial("000000100"b), 7 9 token_node initial("000000101"b), 7 10 symbol_node initial("000000110"b), 7 11 context_node initial("000000111"b), 7 12 array_node initial("000001000"b), 7 13 bound_node initial("000001001"b), 7 14 format_value_node initial("000001010"b), 7 15 list_node initial("000001011"b), 7 16 default_node initial("000001100"b), 7 17 machine_state_node initial("000001101"b), 7 18 source_node initial("000001110"b), 7 19 label_node initial("000001111"b), 7 20 cross_reference_node initial("000010000"b), 7 21 sf_par_node initial("000010001"b), 7 22 temporary_node initial("000010010"b), 7 23 label_array_element_node initial("000010011"b), 7 24 by_name_agg_node initial("000010100"b)) 7 25 bit(9) internal static aligned options(constant); 7 26 7 27 dcl 1 node based aligned, 7 28 2 type unal bit(9), 7 29 2 source_id unal structure, 7 30 3 file_number bit(8), 7 31 3 line_number bit(14), 7 32 3 statement_number bit(5); 7 33 7 34 /* END INCLUDE FILE ... nodes.incl.pl1 */ 242 8 1 /* BEGIN INCLUDE FILE ... pl1_tree_areas.incl.pl1 */ 8 2 8 3 /* format: style3 */ 8 4 dcl tree_area area based (pl1_stat_$tree_area_ptr); 8 5 dcl xeq_tree_area area based (pl1_stat_$xeq_tree_area_ptr); 8 6 8 7 dcl pl1_stat_$tree_area_ptr 8 8 ptr ext static, 8 9 pl1_stat_$xeq_tree_area_ptr 8 10 ptr ext static; 8 11 8 12 /* END INCLUDE FILE ... op_codes.incl.pl1 */ 243 9 1 /* BEGIN INCLUDE FILE ... radix_factor_constants.incl.pl1 */ 9 2 9 3 /* The following array, "digits", although static, IS assigned to in some cases */ 9 4 /* so could never be "options(constant)!! */ 9 5 9 6 dcl digits(0:5) char(16) int static init( "0101010101010101", /* only 1st two digits are meaningful */ 9 7 "0101010101010101", /* only 1st 2 digits meaningful */ 9 8 "0123012301230123", /* only 1st 4 digits meaningful */ 9 9 "0123456701234567", /* only 1st 8 digits meaningful */ 9 10 "0123456789abcdef", /* all 16 digits meaningful */ 9 11 "0123456789ABCDEF"); /* all 16 digits meaningful */ 9 12 9 13 dcl capital_hex char(6) init("ABCDEF") int static options(constant); 9 14 9 15 dcl lower_case_hex char(6) init("abcdef") int static options(constant); 9 16 9 17 dcl expand_bit_chars(2:4) char(64) int static init( "00011011", 9 18 "000001010011100101110111", 9 19 "0000000100100011010001010110011110001001101010111100110111101111"); 9 20 9 21 dcl expand_bits(2:4) bit(64) int static init( "00011011"b, 9 22 "000001010011100101110111"b, 9 23 "0000000100100011010001010110011110001001101010111100110111101111"b); 9 24 9 25 /* END INCLUDE FILE ... radix_factor_constants.incl.pl1 */ 244 10 1 dcl m fixed bin(15); 10 2 dcl pl1_stat_$source_seg fixed bin(8) ext static; 10 3 dcl pl1_stat_$last_source fixed bin(15) ext static; 10 4 dcl pl1_stat_$source_list_ptr ptr ext static; 10 5 dcl source_list(0:source_list_length) ptr based(pl1_stat_$source_list_ptr); 10 6 dcl source_list_length fixed bin(15) internal static initial(255) options(constant); 10 7 10 8 dcl 1 source based(source_list(m)) aligned, 10 9 2 node_type unal bit(9), 10 10 2 source_id unal structure, 10 11 3 file_number bit(8), 10 12 3 line_number bit(14), 10 13 3 statement_number bit(5), 10 14 2 standard_object_info aligned structure, 10 15 3 uid bit(36), 10 16 3 dtm fixed bin(71), 10 17 2 seg_ptr unal ptr, 10 18 2 name unal ptr, 10 19 2 source_length unal fixed bin(24), 10 20 2 pathlen unal fixed bin(10), 10 21 2 pathname char(n refer(source.pathlen)); 245 11 1 /* BEGIN INCLUDE FILE ... system.incl.pl1 */ 11 2 11 3 /* Modified: 25 Apr 1979 by PCK to implemnt 4-bit decimal */ 11 4 11 5 dcl ( max_p_flt_bin_1 initial(27), 11 6 max_p_flt_bin_2 initial(63), 11 7 max_p_fix_bin_1 initial(35), 11 8 max_p_fix_bin_2 initial(71), 11 9 11 10 max_p_dec initial(59), 11 11 max_p_bin_or_dec initial (71), /* max (max_p_fix_bin_2, max_p_dec) */ 11 12 11 13 min_scale initial(-128), 11 14 max_scale initial(+127), 11 15 max_bit_string initial(9437184), 11 16 max_char_string initial(1048576), 11 17 max_area_size initial(262144), 11 18 min_area_size initial(28), 11 19 11 20 max_bit_string_constant initial (253), /* max length of bit literals */ 11 21 max_char_string_constant initial (254), /* max length of character literals */ 11 22 max_identifier_length initial (256), 11 23 max_number_of_dimensions initial (127), 11 24 11 25 max_length_precision initial(24), 11 26 max_offset_precision initial(24), /* 18 bits for word offset + 6 bits for bit offset */ 11 27 11 28 max_words_per_variable initial (262144), 11 29 11 30 bits_per_word initial(36), 11 31 bits_per_double initial(72), 11 32 packed_digits_per_character initial(2), 11 33 characters_per_half initial(2), 11 34 characters_per_word initial(4), 11 35 characters_per_double initial(8), 11 36 11 37 bits_per_character initial(9), 11 38 bits_per_half initial(18), 11 39 bits_per_decimal_digit initial(9), 11 40 bits_per_binary_exponent initial(8), 11 41 bits_per_packed_ptr initial(36), 11 42 words_per_packed_pointer initial(1), 11 43 11 44 words_per_fix_bin_1 initial(1), 11 45 words_per_fix_bin_2 initial(2), 11 46 words_per_flt_bin_1 initial(1), 11 47 words_per_flt_bin_2 initial(2), 11 48 words_per_varying_string_header initial(1), 11 49 words_per_offset initial(1), 11 50 words_per_pointer initial(2), 11 51 words_per_label_var initial(4), 11 52 words_per_entry_var initial(4), 11 53 words_per_file_var initial(4), 11 54 words_per_format initial(4), 11 55 words_per_condition_var initial(6), 11 56 11 57 max_index_register_value initial(262143), 11 58 max_signed_index_register_value initial(131071), 11 59 11 60 max_signed_xreg_precision initial(17), 11 61 max_uns_xreg_precision initial(18), 11 62 11 63 default_area_size initial(1024), 11 64 default_flt_bin_p initial(27), 11 65 default_fix_bin_p initial(17), 11 66 default_flt_dec_p initial(10), 11 67 default_fix_dec_p initial(7)) fixed bin(31) internal static options(constant); 11 68 11 69 dcl bits_per_digit initial(4.5) fixed bin(31,1) internal static options(constant); 11 70 11 71 dcl ( integer_type initial("010000000000000000000100000001100000"b), 11 72 dec_integer_type initial("010000000000000000000100000010100000"b), 11 73 pointer_type initial("000001000000000000000100000000000000"b), 11 74 real_type initial("001000000000000000000100000001100000"b), 11 75 complex_type initial("001000000000000000000100000001010000"b), 11 76 builtin_type initial("000000000000000010000000000000000000"b), 11 77 storage_block_type initial("000000000000100000000000000000000000"b), 11 78 arg_desc_type initial("000000000001000000000000000000000000"b), 11 79 local_label_var_type initial("000000001000000000000100000100001000"b), 11 80 entry_var_type initial("000000000100000000000000000000001000"b), 11 81 bit_type initial("000100000000000000000000000000000000"b), 11 82 char_type initial("000010000000000000000000000000000000"b)) bit(36) aligned int static 11 83 options(constant); 11 84 11 85 /* END INCLUDE FILE ... system.incl.pl1 */ 246 12 1 /* BEGIN INCLUDE FILE ... token.incl.pl1 */ 12 2 12 3 dcl 1 token based aligned, 12 4 2 node_type bit(9) unaligned, 12 5 2 type bit(9) unaligned, 12 6 2 loc bit(18) unaligned, /* symtab offset for identifiers, "p" flag for constants */ 12 7 2 declaration ptr unaligned, 12 8 2 next ptr unaligned, 12 9 2 size fixed(9), 12 10 2 string char(n refer(token.size)); 12 11 12 12 /* END INCLUDE FILE ... token.incl.pl1 */ 247 13 1 dcl pl1_stat_$token_list_ptr ptr external static; /* pointer to token list */ 13 2 dcl token_list(token_list_length) ptr based(token_list_pointer); 13 3 dcl token_list_pointer ptr initial(pl1_stat_$token_list_ptr); /* for efficiency only */ 13 4 dcl token_list_length fixed(15) internal static initial(3000) options(constant); 13 5 13 6 dcl 1 pl1_stat_$statement_id external static, 13 7 2 file_number bit(8), 13 8 2 line_number bit(14), 13 9 2 statement_number bit(5); 13 10 13 11 dcl 1 t_table based(token_list(k)) aligned, 13 12 2 node_type bit(9) unaligned, 13 13 2 type bit(9) unaligned, 13 14 2 loc bit(18) unaligned, 13 15 2 declaration ptr unaligned, 13 16 2 next ptr unaligned, 13 17 2 size fixed(9), 13 18 2 string char(n refer(t_table.size)); 248 14 1 /* BEGIN INCLUDE FILE ... token_types.incl.pl1 */ 14 2 14 3 dcl ( no_token initial("000000000"b), /* token types */ 14 4 identifier initial("100000000"b), 14 5 isub initial("010000000"b), 14 6 plus initial("001000001"b), 14 7 minus initial("001000010"b), 14 8 asterisk initial("001000011"b), 14 9 slash initial("001000100"b), 14 10 expon initial("001000101"b), 14 11 not initial("001000110"b), 14 12 and initial("001000111"b), 14 13 or initial("001001000"b), 14 14 cat initial("001001001"b), 14 15 eq initial("001001010"b), 14 16 ne initial("001001011"b), 14 17 lt initial("001001100"b), 14 18 gt initial("001001101"b), 14 19 le initial("001001110"b), 14 20 ge initial("001001111"b), 14 21 ngt initial("001010000"b), 14 22 nlt initial("001010001"b), 14 23 assignment initial("001010010"b), 14 24 colon initial("001010011"b), 14 25 semi_colon initial("001010100"b), 14 26 comma initial("001010101"b), 14 27 period initial("001010110"b), 14 28 arrow initial("001010111"b), 14 29 left_parn initial("001011000"b), 14 30 right_parn initial("001011001"b), 14 31 percent initial("001011100"b), 14 32 bit_string initial("000100001"b), 14 33 char_string initial("000100010"b), 14 34 bin_integer initial("000110001"b), 14 35 dec_integer initial("000110011"b), 14 36 fixed_bin initial("000110000"b), 14 37 fixed_dec initial("000110010"b), 14 38 float_bin initial("000110100"b), 14 39 float_dec initial("000110110"b), 14 40 i_bin_integer initial("000111001"b), 14 41 i_dec_integer initial("000111011"b), 14 42 i_fixed_bin initial("000111000"b), 14 43 i_fixed_dec initial("000111010"b), 14 44 i_float_bin initial("000111100"b), 14 45 i_float_dec initial("000111110"b)) bit (9) aligned internal static options (constant); 14 46 14 47 dcl ( is_identifier initial ("100000000"b), /* token type masks */ 14 48 is_isub initial ("010000000"b), 14 49 is_delimiter initial ("001000000"b), 14 50 is_constant initial ("000100000"b), 14 51 is_arith_constant initial ("000010000"b), /* N.B. not really a mask...s/b "000110000"b */ 14 52 is_arithmetic_constant initial ("000110000"b), 14 53 is_imaginary_constant initial ("000111000"b), 14 54 is_float_constant initial ("000110100"b), 14 55 is_decimal_constant initial ("000110010"b), 14 56 is_integral_constant initial ("000110001"b) 14 57 ) bit(9) internal static aligned options(constant); 14 58 14 59 /* END INCLUDE FILE ... token_types.incl.pl1 */ 249 250 251 /* program */ 252 253 /* Main entry to lex. Convert the next source statement into tokens and return. */ 254 255 token_index = 0; 256 protected = ""b; 257 listing_on = pl1_stat_$listing_on; 258 parenthesis_level = 0; 259 pl1_stat_$level_0_colon = "0"b; 260 pl1_stat_$level_0_equal = "0"b; 261 percent_sign_seen = "0"b; 262 263 action (1): /* SCAN WHITE SPACE */ 264 scan_index = verify (substr (source_string, source_index), HT_VT_NP_SP); 265 266 if scan_index = 0 then 267 go to end_of_source_reached_but_no_pending_token; 268 269 source_index = source_index + scan_index; 270 current_char = substr (source_string, source_index - 1, 1); 271 char_value = rank (current_char); 272 273 if char_value >= hbound (action_table, 1) then 274 action_index = action_table (hbound (action_table, 1)); 275 else 276 action_index = action_table (char_value); 277 278 go to action (action_index); 279 280 action (2): /* SCAN STRING. current_char = double_quote */ 281 if source_index > source_length then do; 282 call lex_error (362, file_token_ptr); /* eof in string */ 283 go to end_of_source_reached_but_no_pending_token; 284 end; 285 286 token_start = source_index; /* skip over double_quote */ 287 string_token_start = source_index - 1; /* save offset of double_quote for make_token */ 288 token_length = 0; 289 token_type = char_string; /* tentative */ 290 291 rescan: 292 scan_index = search (substr (source_string, source_index), double_quote_or_newline); 293 294 if scan_index = 0 then do; 295 call lex_error (362, file_token_ptr); /* eof in string */ 296 297 if token_start = 0 /* filling copy of token */ then 298 token_string = token_string || substr (source_string, source_index); 299 else 300 token_length = source_length - token_start + 1; 301 302 go to end_of_source_reached; 303 end; 304 305 if substr (source_string, source_index + scan_index - 1, 1) = newline then do; 306 if token_start = 0 then 307 token_string = token_string || substr (source_string, source_index, scan_index); 308 else 309 token_length = token_length + scan_index; 310 311 source_index = source_index + scan_index; 312 call print_line; 313 go to rescan; 314 end; 315 316 /* Found a matching quote. Ignore it. */ 317 318 if token_start = 0 then 319 token_string = token_string || substr (source_string, source_index, scan_index - 1); 320 else 321 token_length = token_length + scan_index - 1; 322 323 source_index = source_index + scan_index; 324 325 if source_index > source_length /* not an error */ then 326 go to end_of_source_reached; 327 328 if substr (source_string, source_index, 1) = double_quote then do; 329 if token_start > 0 then do; /* begin using copy, if we haven't already */ 330 token_string = substr (source_string, token_start, token_length); 331 token_start = 0; 332 end; 333 334 token_string = token_string || double_quote; 335 source_index = source_index + 1; 336 go to rescan; 337 end; 338 else if substr (source_string, source_index, 1) = "b" then do; 339 token_type = bit_string; 340 source_index = source_index + 1; 341 342 if source_index <= source_length then do; 343 radix = index ("1234", substr (source_string, source_index, 1)); 344 345 if radix > 0 then 346 source_index = source_index + 1; 347 else 348 radix = 1; 349 end; 350 else 351 radix = 1; 352 353 if token_start > 0 then do; 354 temp_token_string = substr (source_string, token_start, token_length); 355 token_start = 0; 356 end; 357 else 358 temp_token_string = token_string; 359 360 /* We will now expand temp_token_string according to the specified 361* radix factor, and put the result into token_string */ 362 363 if radix = 4 then 364 if search (temp_token_string, capital_hex) ^= 0 then 365 dx = 5; 366 else 367 dx = 4; 368 else 369 dx = radix; 370 371 if verify (temp_token_string, digits (dx)) ^= 0 then do; 372 /* non-binary digit in bit string */ 373 error_token = create_token (temp_token_string || "b", bit_string); 374 call lex_error (152, error_token); 375 token_type = char_string; 376 token_string = temp_token_string; 377 end; 378 else if radix > 1 then do; 379 max_in_chars = divide (max_bit_string_constant, radix, 21, 0); 380 token_string = ""; 381 382 if length (temp_token_string) > max_in_chars then do; 383 /* radix factor makes bit string too long */ 384 temp_token_string = substr (temp_token_string, 1, max_in_chars); 385 error_token = 386 create_token ("""" || temp_token_string || """b" || substr ("1234", radix, 1), 387 no_token /* fake type - suppress quoting */); 388 call lex_error (154, error_token); /* radix factor makes bit string too long */ 389 end; 390 391 do strx = 1 to length (temp_token_string); 392 first_bit = radix * (index (digits (dx), substr (temp_token_string, strx, 1)) - 1) + 1; 393 token_string = token_string || substr (expand_bit_chars (radix), first_bit, radix); 394 end; 395 end; 396 else 397 token_string = temp_token_string; 398 end; 399 400 if token_index >= 3 /* is there room for a replication factor? */ then 401 if token_list (token_index - 2) -> token.type = left_parn 402 & token_list (token_index) -> token.type = right_parn then do; 403 token_index = token_index - 3; /* wipe out rep factor and parens */ 404 405 if constant_token (cblock, token_list (token_index + 2), "777"b3, dec_integer) ^= dec_integer then 406 call lex_error (110, token_list (token_index + 2)); 407 /* rep factor is not a decimal integer */ 408 else do; 409 rep_factor = token_to_binary (token_list (token_index + 2)); 410 411 if token_start > 0 then do; 412 temp_token_string = substr (source_string, token_start, token_length); 413 token_start = 0; 414 end; 415 else 416 temp_token_string = token_string; 417 418 if token_type = bit_string then 419 string_max = max_bit_string_constant; 420 else 421 string_max = max_char_string_constant; 422 423 if length (temp_token_string) * rep_factor > string_max then do; 424 error_token = create_token (temp_token_string || "b", bit_string); 425 call lex_error (109, error_token); 426 /* replicated string too long */ 427 rep_factor = divide (string_max, length (temp_token_string), 21, 0); 428 end; 429 430 token_string = ""; 431 do strx = 1 to rep_factor; 432 token_string = token_string || temp_token_string; 433 end; 434 end; 435 end; 436 437 if token_type = bit_string then do; 438 if length (token_string) > max_bit_string_constant then do; 439 /* bit string too long */ 440 token_string = substr (token_string, 1, max_bit_string_constant); 441 error_token = create_token (token_string || "b", bit_string); 442 call lex_error (100, error_token); 443 end; 444 445 token_string = token_string || "b"; 446 end; 447 else if token_start > 0 then 448 if token_length > max_char_string_constant then do; 449 token_length = max_char_string_constant; 450 error_token = create_token (substr (source_string, token_start, token_length), char_string); 451 call lex_error (100, error_token); /* char string too long */ 452 end; 453 else 454 ; 455 else if length (token_string) > max_char_string_constant then do; 456 /* char string too long */ 457 token_string = substr (token_string, 1, max_char_string_constant); 458 call lex_error (100, create_token ((token_string), char_string)); 459 end; 460 461 if source_index > source_length then 462 go to end_of_source_reached; 463 464 call make_token; 465 go to check_syntax_after_constant; 466 467 action (3): /* SCAN IDENTIFIERS */ 468 token_type = identifier; 469 token_start = source_index - 1; 470 471 scan_index = verify (substr (source_string, source_index), identifier_characters); 472 473 if scan_index = 0 then do; 474 source_index = source_length + 1; 475 go to end_of_source_reached; 476 end; 477 478 source_index = source_index + scan_index - 1; 479 call make_token; 480 481 /* Now make sure the syntax after the identifier is correct. */ 482 483 current_char = substr (source_string, source_index, 1); 484 char_value = rank (current_char); 485 source_index = source_index + 1; 486 487 if char_value >= hbound (action_table, 1) then 488 action_index = action_table (hbound (action_table, 1)); 489 else 490 action_index = action_table (char_value); 491 492 if action_index = 2 /* double quote */ then do; 493 error_token = token_list (token_index); 494 495 if error_token -> token.string ^= "p" & error_token -> token.string ^= "pic" 496 & error_token -> token.string ^= "picture" then 497 call lex_error (158, error_token); /* double quote after identifier */ 498 end; 499 500 go to action (action_index); 501 502 /* SINGLE CHARACTER TOKENS */ 503 504 action (4): /* % */ 505 token_start = source_index - 1; 506 if percent_sign_seen then 507 call lex_error (125, null); /* %sign while parsing macro */ 508 509 percent_sign_seen = "1"b; 510 saved_token_index = token_index; 511 call print_line_before_include; 512 call enter_token (percent_token_ptr); 513 go to action (1); 514 515 action (17): /* & */ 516 token_start = source_index - 1; 517 call enter_token (and_token_ptr); 518 go to action (1); 519 520 action (18): /* ( */ 521 token_start = source_index - 1; 522 parenthesis_level = parenthesis_level + 1; 523 call enter_token (left_parn_token_ptr); 524 go to action (1); 525 526 action (19): /* ) */ 527 token_start = source_index - 1; 528 parenthesis_level = parenthesis_level - 1; 529 call enter_token (right_parn_token_ptr); 530 go to action (1); 531 532 action (20): /* + */ 533 token_start = source_index - 1; 534 call enter_token (plus_token_ptr); 535 go to action (1); 536 537 action (21): /* , */ 538 token_start = source_index - 1; 539 call enter_token (comma_token_ptr); 540 go to action (1); 541 542 action (22): /* : */ 543 token_start = source_index - 1; 544 if parenthesis_level = 0 then 545 pl1_stat_$level_0_colon = "1"b; 546 547 call enter_token (colon_token_ptr); 548 go to action (1); 549 550 action (23): /* = */ 551 token_start = source_index - 1; 552 if parenthesis_level = 0 then 553 pl1_stat_$level_0_equal = "1"b; 554 555 call enter_token (assignment_token_ptr); 556 go to action (1); 557 558 action (5): /* SEPARATE / AND /* */ 559 token_start = source_index - 1; /* tentative */ 560 token_type = slash; 561 562 if source_index > source_length then 563 go to end_of_source_reached; 564 565 if substr (source_string, source_index, 1) ^= "*" then do; 566 call enter_token (slash_token_ptr); 567 go to action (1); 568 end; 569 570 /* Now lexing a comment */ 571 572 source_index = source_index + 1; 573 574 rescan_comment: 575 scan_index = search (substr (source_string, source_index), asterisk_or_newline); 576 if scan_index = 0 then do; 577 call lex_error (360, file_token_ptr); /* eof in comment */ 578 go to end_of_source_reached_but_no_pending_token; 579 end; 580 581 source_index = source_index + scan_index; 582 583 if substr (source_string, source_index - 1, 1) = newline then do; 584 call print_line; 585 line_begins_in_comment = "1"b; 586 go to rescan_comment; 587 end; 588 589 /* at this point substr (source_string, source_index - 1, 1) is an asterisk */ 590 591 if substr (source_string, source_index, 1) = "/" then do; 592 source_index = source_index + 1; 593 go to action (1); 594 end; 595 596 go to rescan_comment; 597 598 action (6): /* SCAN NUMBERS AND ISUBS. current char = */ 599 token_start = source_index - 1; 600 token_type = fixed_bin; /* set initial token_type & flags */ 601 decimal_value = is_decimal_constant; /* .. */ 602 imaginary_value = "0"b; /* .. */ 603 float_value = "0"b; /* .. */ 604 integral_value = is_integral_constant; /* .. */ 605 606 if source_index > source_length then 607 go to end_of_source_reached; 608 609 call scan_past_digits; 610 611 if substr (source_string, source_index, 1) = "." then do; 612 integral_value = "0"b; 613 614 scan_fraction: 615 source_index = source_index + 1; 616 617 if source_index > source_length then 618 go to end_of_source_reached; 619 620 call scan_past_digits; 621 end; 622 else if source_index + 2 <= source_length then 623 if substr (source_string, source_index, 3) = "sub" then do; 624 source_index = source_index + 3; 625 token_type = isub; 626 call make_token; 627 go to action (1); 628 end; 629 630 token_length = source_index - token_start; /* remember length of mantissa for later error check */ 631 632 if (substr (source_string, source_index, 1) = "e") | (substr (source_string, source_index, 1) = "f") then do; 633 if substr (source_string, source_index, 1) = "e" then 634 float_value = is_float_constant; 635 636 integral_value = "0"b; 637 source_index = source_index + 1; 638 639 if source_index > source_length then do; 640 call missing_exponent; 641 go to end_of_source_reached; 642 end; 643 644 if (substr (source_string, source_index, 1) = "+") | (substr (source_string, source_index, 1) = "-") 645 then do; 646 source_index = source_index + 1; 647 648 if source_index > source_length then do; 649 call missing_exponent; 650 go to end_of_source_reached; 651 end; 652 end; 653 654 call scan_past_digits; 655 end; 656 657 if substr (source_string, source_index, 1) = "b" /* binary constant */ then do; 658 decimal_value = "0"b; 659 scan_index = source_index; /* remember position of "b" */ 660 source_index = source_index + 1; 661 end; 662 663 if source_index <= source_length then 664 if substr (source_string, source_index, 1) = "p" /* default suppression indicator */ then do; 665 source_index = source_index + 1; 666 protected = "1"b; 667 end; 668 669 if source_index <= source_length then 670 if substr (source_string, source_index, 1) = "i" /* imaginary constant */ then do; 671 imaginary_value = is_imaginary_constant; 672 source_index = source_index + 1; 673 end; 674 675 if decimal_value = ""b /* is this a binary constant ? */ then 676 if verify (substr (source_string, token_start, token_length), ".01") > 0 then do; 677 error_token = 678 create_token (substr (source_string, token_start, source_index - token_start), i_float_dec); 679 /* don't care about real token_type...guess safely */ 680 call lex_error (153, error_token); /* non-binary digit in apparent binary constant */ 681 682 /* Fix up the constant...restore the decimal attribute, and eliminate the "b" from 683* the token_string */ 684 685 decimal_value = is_decimal_constant; 686 token_string = substr (source_string, token_start, scan_index - token_start); 687 688 if imaginary_value ^= ""b then 689 token_string = token_string || "i"; 690 691 string_token_start = token_start; /* save for make_token */ 692 token_start = 0; 693 end; 694 695 /* If the constant is protected (and wasn't copied by the error recovery 696* code above), then we have to copy it now in order to avoid getting 697* the "p" into the token. */ 698 699 if (protected ^= ""b) & token_start > 0 then do; 700 if imaginary_value ^= ""b then 701 token_length = source_index - token_start - 2; 702 else 703 token_length = source_index - token_start - 1; 704 705 token_string = substr (source_string, token_start, token_length); 706 token_start = 0; 707 708 if imaginary_value ^= ""b then 709 token_string = token_string || "i"; 710 end; 711 712 if source_index > source_length then 713 go to end_of_source_reached; 714 715 call make_token; 716 717 /* Now make sure the syntax after the constant is correct. */ 718 719 check_syntax_after_constant: 720 current_char = substr (source_string, source_index, 1); 721 char_value = rank (current_char); 722 source_index = source_index + 1; 723 724 if char_value >= hbound (action_table, 1) then 725 action_index = action_table (hbound (action_table, 1)); 726 else 727 action_index = action_table (char_value); 728 729 if action_index = 3 | action_index = 6 | action_index = 2 /* alphabetics, numbers, double quote */ then 730 call lex_error (157, token_list (token_index)); 731 /* text after string */ 732 733 go to action (action_index); 734 735 action (7): /* SEPARATE . AND NUMBERS. current_char = "." */ 736 token_start = source_index - 1; 737 token_type = period; /* assume for now */ 738 739 if source_index > source_length then 740 go to end_of_source_reached; 741 742 current_char = substr (source_string, source_index, 1); 743 /* grab next character */ 744 char_value = rank (current_char); 745 746 if char_value <= hbound (action_table, 1) then 747 if action_table (char_value) = 6 /* next char is a */ then do; 748 token_type = fixed_bin; /* set initial token_type & flags */ 749 decimal_value = is_decimal_constant; /* .. */ 750 imaginary_value = "0"b; /* .. */ 751 float_value = "0"b; /* .. */ 752 integral_value = "0"b; /* .. */ 753 go to scan_fraction; 754 end; 755 756 call enter_token (period_token_ptr); 757 go to action (1); 758 759 action (8): /* SCAN NEWLINE */ 760 call print_line; 761 go to action (1); 762 763 action (9): /* MISC ERRORS */ 764 if char_value < 32 | char_value >= 128 then do; 765 error_number = 159; /* control chars & non-ASCII not allowed */ 766 error_token = create_token (char (bit (char_value, 9)) || "b", bit_string); 767 end; 768 else if (current_char = "_") | (current_char = "$") then do; 769 error_number = 151; /* $ and _ may not start identifier */ 770 error_token = null; 771 end; 772 else do; 773 error_number = 363; /* printing char ^a not allowed */ 774 error_token = create_token ((current_char), char_string); 775 end; 776 777 call lex_error (error_number, error_token); 778 go to action (1); 779 780 action (10): /* SEPARATE * AND ** */ 781 token_start = source_index - 1; 782 token_type = asterisk; 783 token_ptr = asterisk_token_ptr; 784 785 if source_index > source_length then 786 go to end_of_source_reached; 787 788 if substr (source_string, source_index, 1) = "*" then do; 789 source_index = source_index + 1; 790 token_ptr = expon_token_ptr; 791 end; 792 793 call enter_token (token_ptr); 794 go to action (1); 795 796 action (11): /* SEPARATE - AND -> */ 797 token_start = source_index - 1; 798 token_type = minus; 799 token_ptr = minus_token_ptr; 800 801 if source_index > source_length then 802 go to end_of_source_reached; 803 804 if substr (source_string, source_index, 1) = ">" then do; 805 source_index = source_index + 1; 806 token_ptr = arrow_token_ptr; 807 end; 808 809 call enter_token (token_ptr); 810 go to action (1); 811 812 action (12): /* SEPARATE < AND <= */ 813 token_start = source_index - 1; 814 token_type = lt; 815 token_ptr = lt_token_ptr; 816 817 if source_index > source_length then 818 go to end_of_source_reached; 819 820 if substr (source_string, source_index, 1) = "=" then do; 821 source_index = source_index + 1; 822 token_ptr = le_token_ptr; 823 end; 824 825 call enter_token (token_ptr); 826 go to action (1); 827 828 action (13): /* SEPARATE > AND >= */ 829 token_start = source_index - 1; 830 token_type = gt; 831 token_ptr = gt_token_ptr; 832 833 if source_index > source_length then 834 go to end_of_source_reached; 835 836 if substr (source_string, source_index, 1) = "=" then do; 837 source_index = source_index + 1; 838 token_ptr = ge_token_ptr; 839 end; 840 841 call enter_token (token_ptr); 842 go to action (1); 843 844 action (14): /* SEPARATE ^ AND ^= AND ^< AND ^> */ 845 token_start = source_index - 1; 846 token_type = not; 847 token_ptr = not_token_ptr; 848 849 if source_index > source_length then 850 go to end_of_source_reached; 851 852 if substr (source_string, source_index, 1) = "=" then do; 853 source_index = source_index + 1; 854 token_ptr = ne_token_ptr; 855 end; 856 else if substr (source_string, source_index, 1) = "<" then do; 857 source_index = source_index + 1; 858 token_ptr = nlt_token_ptr; 859 end; 860 else if substr (source_string, source_index, 1) = ">" then do; 861 source_index = source_index + 1; 862 token_ptr = ngt_token_ptr; 863 end; 864 865 call enter_token (token_ptr); 866 go to action (1); 867 868 action (15): /* SEPARATE | AND || */ 869 token_start = source_index - 1; 870 token_type = or; 871 token_ptr = or_token_ptr; 872 873 if source_index > source_length then 874 go to end_of_source_reached; 875 876 if substr (source_string, source_index, 1) = "|" then do; 877 source_index = source_index + 1; 878 token_ptr = cat_token_ptr; 879 end; 880 881 call enter_token (token_ptr); 882 go to action (1); 883 884 action (16): /* SCAN SEMICOLON. current_char = ";" */ 885 token_start = source_index - 1; 886 887 if percent_sign_seen then do; 888 percent_sign_seen = "0"b; 889 listing_on = pl1_stat_$listing_on; 890 line_start = source_index; 891 k = saved_token_index + 1; 892 893 if token_list (token_index) -> token.type = percent /* %; */ then do; 894 token_index = saved_token_index; 895 go to action (1); /* ignore it */ 896 end; 897 898 k = k + 1; 899 900 if t_table.string = "page" | t_table.string = "skip" then do; 901 if t_table.string = "page" then 902 page_macro = "1"b; 903 else 904 page_macro = "0"b; 905 906 if k = token_index /* no argument */ then 907 n = 1; 908 else do; 909 k = k + 1; /* step over keyword */ 910 911 if token_index - k + 1 < 3 /* must be at least 3 more tokens */ then 912 go to error_376; /* a good programming lang wouldn't need this goto */ 913 914 if t_table.type ^= left_parn | token_list (k + 1) -> token.type ^= dec_integer 915 | token_list (k + 2) -> token.type ^= right_parn then do; 916 error_376: 917 call lex_error (376, null); /* syntax error in %page macro */ 918 k = token_index; /* suppress possible error 375, below */ 919 n = 1; 920 end; 921 else do; 922 n = token_to_binary (token_list (k + 1)); 923 k = k + 2; 924 end; 925 end; 926 927 if listing_on then 928 if page_macro then 929 call pl1_print$non_varying (copy (newpage, n), 0); 930 else 931 call pl1_print$non_varying (copy (newline, n), 0); 932 933 if k ^= token_index then 934 call lex_error (375, null); /* excess arguments ignored */ 935 936 token_index = saved_token_index; 937 go to action (1); 938 end; 939 940 if t_table.string ^= "include" then do; 941 token_index = saved_token_index; 942 call lex_error (103, null); /* not include or page */ 943 go to action (1); 944 end; 945 946 k = k + 1; 947 948 if (t_table.type = identifier) | (t_table.type = char_string) then 949 include_file_name = t_table.string; 950 else do; 951 token_index = saved_token_index; 952 call lex_error (104, null); /* filename not identifier or string */ 953 go to action (1); 954 end; 955 956 if k ^= token_index then do; 957 token_index = saved_token_index; 958 call lex_error (441, null); /* no semicolon */ 959 go to action (1); 960 end; 961 962 token_index = saved_token_index; 963 964 if length (include_file_name) >= 24 then do; 965 call lex_error (106, token_list (k)); /* filename too long */ 966 go to action (1); 967 end; 968 969 include_file_name = include_file_name || ".incl.pl1"; 970 new_file_token_ptr = create_token ((include_file_name), identifier); 971 972 call find_include_file_$initiate_count (command, source_ptr, (include_file_name), bitcount, 973 include_file_ptr, code); 974 975 if include_file_ptr = null () then do; 976 if index (include_file_name, ">") ^= 0 | index (include_file_name, "<") ^= 0 then 977 call lex_error (392, new_file_token_ptr); 978 /* ">" and "<" not accepted in include macro */ 979 else 980 call lex_error (107, new_file_token_ptr); 981 /* include file not found */ 982 983 end; 984 else if code ^= 0 then 985 call com_err_ (code, command, "^a", include_file_name); 986 987 if pl1_stat_$last_source = source_list_length then do; 988 call hcs_$terminate_noname (include_file_ptr, code); 989 call lex_error (129, new_file_token_ptr); 990 /* too many include files */ 991 go to action (1); 992 end; 993 994 if source_depth > hbound (file_stack, 1) then do; 995 call hcs_$terminate_noname (include_file_ptr, code); 996 call lex_error (112, new_file_token_ptr); 997 /* nested too deep */ 998 go to action (1); 999 end; 1000 1001 file_stack (source_depth).source_ptr = source_ptr; 1002 file_stack (source_depth).file_token_ptr = file_token_ptr; 1003 file_stack (source_depth).source_index = source_index; 1004 file_stack (source_depth).source_length = source_length; 1005 file_stack (source_depth).line_number = line_number; 1006 file_stack (source_depth).file_number = pl1_stat_$source_seg; 1007 1008 do depthx = lbound (file_stack, 1) to source_depth; 1009 if file_stack (depthx).source_ptr = include_file_ptr then do; 1010 call hcs_$terminate_noname (include_file_ptr, code); 1011 call lex_error (108, new_file_token_ptr); 1012 /* infinite recursion */ 1013 go to action (1); 1014 end; 1015 end; 1016 1017 /* At this point it is OK to enter the include file */ 1018 1019 source_depth = source_depth + 1; 1020 include_file_length = divide (bitcount + 8, 9, 24, 0); 1021 new_file_number = 1022 create_source (include_file_ptr, include_file_length, new_file_token_ptr, pl1_stat_$source_seg, 1023 line_number); 1024 1025 call enter_source_segment (include_file_ptr, include_file_length, new_file_token_ptr, new_file_number); 1026 go to action (1); 1027 end; 1028 1029 call emit_semicolon; 1030 1031 if lexing_after_end_stmt then 1032 call lex_error (99, null); /* text after end of program */ 1033 1034 return; 1035 1036 /* Control transfers here whenever the lex reaches the end of the current source segment. */ 1037 1038 end_of_source_reached: 1039 call make_token; 1040 1041 end_of_source_reached_but_no_pending_token: 1042 if percent_sign_seen then do; 1043 call lex_error (71, null); /* eof in macro */ 1044 percent_sign_seen = "0"b; /* ignore %include */ 1045 token_index = saved_token_index; 1046 end; 1047 1048 call print_line_at_eof; 1049 1050 pl1_stat_$line_count = pl1_stat_$line_count + line_number; 1051 1052 if source_depth = 0 /* we are now in the outermost file */ then do; 1053 if lexing_after_end_stmt then do; 1054 if token_index > 0 /* any tokens generated? */ then 1055 call lex_error (99, null); /* text after eof */ 1056 1057 return; 1058 end; 1059 1060 if token_index > 0 then do; 1061 call lex_error (361, null); /* last stmt has no semicolon */ 1062 call emit_semicolon; 1063 return; 1064 end; 1065 1066 call lex_error (101, null); /* not enough end stmts */ 1067 1068 if token_index < token_list_length then 1069 token_index = token_index + 1; 1070 token_list (token_index) = create_token ("end", identifier); 1071 /* generate "end" */ 1072 call emit_semicolon; /* generate ";" */ 1073 pl1_stat_$st_length = 0; /* no source for this phony stmt */ 1074 return; 1075 end; 1076 1077 source_depth = source_depth - 1; /* we were in incl file...pop out */ 1078 call enter_source_segment (file_stack (source_depth).source_ptr, file_stack (source_depth).source_length, 1079 file_stack (source_depth).file_token_ptr, file_stack (source_depth).file_number); 1080 1081 source_index = file_stack (source_depth).source_index; 1082 line_start = source_index; 1083 line_number = file_stack (source_depth).line_number; 1084 go to action (1); 1085 1086 /* Entry to initialize all of the static variables used by the lex and create_token. 1087* This entry must be called before the first call to lex itself. */ 1088 1089 initialize_lex: 1090 entry (bv_source_ptr, bv_source_length); 1091 1092 /* parameters */ 1093 1094 declare ( 1095 bv_source_ptr ptr, 1096 bv_source_length fixed bin (21) 1097 ) parameter; 1098 1099 /* program */ 1100 1101 /* Initialize create_token, first */ 1102 1103 call create_token$init_hash_table; 1104 1105 /* Initialize static variables */ 1106 1107 statement_number = 1; 1108 1109 suppress_line_numbers = "0"b; 1110 line_begins_in_comment = "0"b; 1111 lexing_after_end_stmt = "0"b; 1112 1113 /* Get static pointers to all the delimiter tokens */ 1114 1115 plus_token_ptr = create_token ("+", plus); 1116 minus_token_ptr = create_token ("-", minus); 1117 asterisk_token_ptr = create_token ("*", asterisk); 1118 slash_token_ptr = create_token ("/", slash); 1119 expon_token_ptr = create_token ("**", expon); 1120 not_token_ptr = create_token ("^", not); 1121 and_token_ptr = create_token ("&", and); 1122 or_token_ptr = create_token ("|", or); 1123 cat_token_ptr = create_token ("||", cat); 1124 ne_token_ptr = create_token ("^=", ne); 1125 lt_token_ptr = create_token ("<", lt); 1126 gt_token_ptr = create_token (">", gt); 1127 le_token_ptr = create_token ("<=", le); 1128 ge_token_ptr = create_token (">=", ge); 1129 ngt_token_ptr = create_token ("^>", ngt); 1130 nlt_token_ptr = create_token ("^<", nlt); 1131 assignment_token_ptr = create_token ("=", assignment); 1132 colon_token_ptr = create_token (":", colon); 1133 semi_colon_token_ptr = create_token (";", semi_colon); 1134 comma_token_ptr = create_token (",", comma); 1135 period_token_ptr = create_token (".", period); 1136 arrow_token_ptr = create_token ("->", arrow); 1137 left_parn_token_ptr = create_token ("(", left_parn); 1138 right_parn_token_ptr = create_token (")", right_parn); 1139 percent_token_ptr = create_token ("%", percent); 1140 1141 source_depth = 0; 1142 pl1_stat_$source_seg = -1; 1143 pl1_stat_$last_source = -1; 1144 pl1_stat_$line_count = 0; 1145 1146 new_file_token_ptr = create_token (pl1_stat_$seg_name || ".pl1", identifier); 1147 1148 /* Create a source node for the main file */ 1149 1150 new_file_number = create_source (bv_source_ptr, bv_source_length, new_file_token_ptr, 0, 0); 1151 1152 /* Enter the main source segment */ 1153 1154 call enter_source_segment (bv_source_ptr, bv_source_length, new_file_token_ptr, new_file_number); 1155 return; 1156 1157 /* Entry to terminate source segments. */ 1158 1159 terminate_source: 1160 entry; 1161 1162 do pl1_stat_$last_source = pl1_stat_$last_source to 0 by -1; 1163 m = pl1_stat_$last_source; 1164 call hcs_$terminate_noname ((source.seg_ptr), code); 1165 end; 1166 return; 1167 1168 /* Entry to write the last line and check for text after the end statement. */ 1169 1170 write_last_line: 1171 entry (cblock); 1172 1173 declare 1 source_info aligned, 1174 2 line_id char (9) unal, 1175 2 sp1 char (2) unal, 1176 2 file_id char (3) unal, 1177 2 sp2 char (4) unal, 1178 2 dtm char (16) unal, 1179 2 sp3 char (2) unal, 1180 2 include_name char (32) unal, 1181 2 sp4 char (2) unal, 1182 2 pathname char (168) unal; 1183 1184 declare line_id char (9) varying aligned; 1185 declare five_digits picture "zzzzz"; 1186 declare three_digits picture "zz9"; 1187 1188 /* internal static */ 1189 1190 declare header char (93) varying aligned int static options (constant) init (" SOURCE FILES USED IN THIS COMPILATION. 1191 1192 LINE NUMBER DATE MODIFIED NAME PATHNAME"); 1193 1194 /* program */ 1195 1196 lexing_after_end_stmt = "1"b; 1197 call lex (cblock); /* see if anything there besides white space & comments */ 1198 1199 listing_on = pl1_stat_$listing_on; 1200 1201 if ^listing_on then 1202 return; 1203 1204 call pl1_print$varying_nl (header); 1205 1206 do m = 0 to pl1_stat_$last_source; 1207 string (source_info) = ""; 1208 1209 if source.file_number = ""b then 1210 line_id = ""; 1211 else do; 1212 three_digits = binary (source.file_number, 8); 1213 /* known to take three digits at most */ 1214 line_id = ltrim (three_digits) || "-"; 1215 end; 1216 1217 five_digits = binary (source.line_number, 14); 1218 /* known to take five digits at most */ 1219 source_info.line_id = line_id || ltrim (five_digits); 1220 1221 three_digits = m; /* known to take three digits at most */ 1222 source_info.file_id = three_digits; 1223 1224 call date_time_ (source.dtm, source_info.dtm); 1225 source_info.include_name = source.name -> token.string; 1226 source_info.pathname = source.pathname; 1227 n = length (string (source_info)) - length (source_info.pathname) + source.pathlen; 1228 call pl1_print$non_varying_nl (string (source_info), (n)); 1229 end; 1230 return; 1231 1232 /* Internal procedures */ 1233 1234 /* Internal procedure to create a source node for the main file and each include file */ 1235 /* Modified by Gray to allow archive component source */ 1236 1237 create_source: 1238 procedure (bv_source_ptr, bv_source_length, bv_file_token_ptr, bv_file_number, bv_line_number) 1239 returns (fixed bin (8)); 1240 1241 /* parameters */ 1242 1243 declare ( 1244 bv_source_ptr ptr, /* ptr to base of source segment */ 1245 bv_source_length fixed bin (21), /* length in chars of source segment */ 1246 bv_file_token_ptr ptr, /* ptr to token node of file name */ 1247 bv_file_number fixed bin (8), /* number of file that contains %include stmt */ 1248 bv_line_number fixed bin (14) /* number of line that contains %include stmt */ 1249 ) parameter; 1250 1251 /* automatic */ 1252 1253 declare cname char (32), /* archive component name */ 1254 dname char (256), /* directory name of source segment */ 1255 dtm fixed bin (71), /* date-time modified of source segment */ 1256 ename char (32), /* real entry name of source segment */ 1257 include_path char (256) varying, /* temporary */ 1258 uid bit (36) aligned; /* file system unique id of segment */ 1259 1260 /* entries */ 1261 1262 declare translator_info_$component_get_source_info 1263 entry (ptr, char (*), char (*), char (*), fixed bin (71), bit (36) aligned, fixed bin (35)); 1264 1265 /* external static */ 1266 1267 declare pl1_stat_$node_uses (18) fixed bin external static; 1268 /* number of nodes allocated, indexed by type */ 1269 1270 /* program */ 1271 1272 call translator_info_$component_get_source_info (bv_source_ptr, dname, ename, cname, dtm, uid, code); 1273 if code ^= 0 then do; 1274 call lex_error (344, bv_file_token_ptr); 1275 include_path = "UNKNOWN DIRECTORY NAME" || bv_file_token_ptr -> token.string; 1276 /* give 'em something. */ 1277 uid = ""b; 1278 dtm = 0; 1279 end; 1280 else if cname = "" then 1281 include_path = rtrim (dname, "> ") || ">" || rtrim (ename); 1282 else 1283 include_path = rtrim (dname, "> ") || ">" || before (ename || " ", ".archive ") || "::" || rtrim (cname); 1284 1285 n = length (include_path); 1286 1287 pl1_stat_$node_uses (14) = pl1_stat_$node_uses (14) + 1; 1288 1289 m, pl1_stat_$last_source = pl1_stat_$last_source + 1; 1290 allocate source in (tree_area) set (source_list (m)); 1291 source.node_type = source_node; 1292 source.seg_ptr = bv_source_ptr; 1293 source.name = bv_file_token_ptr; 1294 source.source_length = bv_source_length; 1295 source.pathname = include_path; 1296 source.file_number = bit (bv_file_number, 8); 1297 source.line_number = bit (bv_line_number, 14); 1298 source.uid = uid; 1299 source.dtm = dtm; 1300 return (m); 1301 1302 end create_source; 1303 1304 /* Procedure to centralize the processing performed when the semicolon is reached. */ 1305 1306 emit_semicolon: 1307 procedure; 1308 1309 if token_index = token_list_length then 1310 call lex_error (105, null); /* too many tokens */ 1311 else 1312 token_index = token_index + 1; 1313 1314 token_list (token_index) = semi_colon_token_ptr; 1315 1316 if token_index = 1 /* we have just lexed a null statement */ then do; 1317 pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8); 1318 pl1_stat_$statement_id.line_number = bit (line_number, 14); 1319 pl1_stat_$statement_id.statement_number = bit (statement_number, 5); 1320 pl1_stat_$st_start = token_start - 1; 1321 end; 1322 1323 statement_number = statement_number + 1; 1324 1325 if statement_number >= 1f5b /* check range of statement number */ then do; 1326 call lex_error (111, null); /* too many statements */ 1327 statement_number = 1; 1328 end; 1329 1330 if pl1_stat_$st_start ^= -1 /* if st_start has been set, set st_length */ then 1331 pl1_stat_$st_length = (source_index - 1) - pl1_stat_$st_start; 1332 pl1_stat_$cur_statement = null; 1333 return; 1334 1335 end emit_semicolon; 1336 1337 /* Internal procedure to set some global variables each time a new source segment is entered */ 1338 1339 enter_source_segment: 1340 procedure (bv_source_ptr, bv_source_length, bv_file_token_ptr, bv_file_number); 1341 1342 /* parameters */ 1343 1344 declare ( 1345 bv_source_ptr ptr, /* ptr to base of source segment */ 1346 bv_source_length fixed bin (21), /* length in chars of source segment */ 1347 bv_file_token_ptr ptr, /* ptr to token node of file name */ 1348 bv_file_number fixed bin (8) /* number of new source file */ 1349 ) parameter; 1350 1351 /* program */ 1352 1353 source_ptr = bv_source_ptr; 1354 source_length = bv_source_length; 1355 source_index = 1; 1356 file_token_ptr = bv_file_token_ptr; 1357 pl1_stat_$source_seg = bv_file_number; 1358 line_number = 1; 1359 line_start = 1; 1360 pl1_stat_$st_start = -1; 1361 pl1_stat_$st_length = 0; 1362 return; 1363 1364 end enter_source_segment; 1365 1366 /* Internal procedure to centralize error reporting by the lex. */ 1367 1368 lex_error: 1369 procedure (bv_error_number, bv_token_ptr); 1370 1371 /* parameters */ 1372 1373 declare ( 1374 bv_error_number fixed bin (15), 1375 bv_token_ptr ptr 1376 ) parameter; 1377 1378 /* automatic */ 1379 1380 declare statement_length fixed bin (21); /* length (in chars) of current statement */ 1381 1382 /* program */ 1383 1384 pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8); 1385 pl1_stat_$statement_id.line_number = bit (line_number, 14); 1386 pl1_stat_$statement_id.statement_number = bit (statement_number, 5); 1387 1388 if pl1_stat_$st_start = -1 /* if st_start hasn't been set, do it now */ then do; 1389 pl1_stat_$st_start = line_start - 1; /* print one source line... */ 1390 1391 if source_index > source_length /* if beyond eof, cancel stmt */ then 1392 statement_length = 0; 1393 else 1394 statement_length = (source_index - 1) - pl1_stat_$st_start; 1395 end; 1396 else 1397 statement_length = (source_index - 1) - pl1_stat_$st_start; 1398 1399 call error_ (bv_error_number, pl1_stat_$statement_id, bv_token_ptr, pl1_stat_$source_seg, (pl1_stat_$st_start), 1400 (statement_length)); 1401 return; 1402 1403 end lex_error; 1404 1405 /* This procedure is called to enter a pointer to a token into the token 1406* list. */ 1407 1408 enter_token: 1409 procedure (P_token_ptr); 1410 1411 /* parameters */ 1412 1413 declare P_token_ptr ptr unal parameter; 1414 1415 /* program */ 1416 1417 if token_index < token_list_length then 1418 token_index = token_index + 1; 1419 1420 token_list (token_index) = P_token_ptr; 1421 1422 if token_index = 1 /* Now emitting first token of a stmt... */ then do; 1423 pl1_stat_$statement_id.file_number = bit (pl1_stat_$source_seg, 8); 1424 pl1_stat_$statement_id.line_number = bit (line_number, 14); 1425 pl1_stat_$statement_id.statement_number = bit (statement_number, 5); 1426 1427 if token_start = 0 then 1428 pl1_stat_$st_start = string_token_start - 1; 1429 /* char_strings & bit_strings */ 1430 else 1431 pl1_stat_$st_start = token_start - 1; /* everything else */ 1432 end; 1433 1434 return; 1435 1436 end enter_token; 1437 1438 /* This procedure is called to make a token. */ 1439 /* Convention: 1440* token_type is set to the correct type, OR is set to fixed_bin, in which case 1441* the variables imaginary_value, float_value, decimal_value, and integral_value are all set. 1442* token_start is either set to the index of the first character of the token, 1443* OR is zero and token_string contains the token. If token_start is nonzero and token_type is char_string, 1444* token_length is also set, otherwise it isn't. 1445* source_index is set to the index of the first character after the token. */ 1446 1447 make_token: 1448 procedure; 1449 1450 /* automatic */ 1451 1452 declare token_ptr ptr unal; 1453 1454 /* program */ 1455 1456 if token_type = fixed_bin then 1457 token_type = token_type | imaginary_value | float_value | decimal_value | integral_value; 1458 1459 if token_start > 0 then do; 1460 token_string_ptr = addr (substr (source_string, token_start, 1)); 1461 /* UGH */ 1462 1463 if token_type ^= char_string /* token_length is OK for char_strings */ then 1464 token_length = source_index - token_start; 1465 1466 if token_length > max_identifier_length then do; 1467 token_length = max_identifier_length; 1468 call lex_error (100, create_token (token_overlay, (token_type))); 1469 end; 1470 end; 1471 else do; 1472 token_string_ptr = addrel (addr (token_string), 1); 1473 /* UGH */ 1474 token_length = length (token_string); 1475 end; 1476 1477 token_ptr = create_token$protected (token_overlay, (token_type), protected); 1478 /* we pass token_type by value to get sta's, not stba's. */ 1479 1480 protected = ""b; 1481 1482 call enter_token (token_ptr); 1483 return; 1484 1485 /* Internal procedure (quick block) version of create_token */ 1486 15 1 /* BEGIN INCLUDE FILE ... create_token.incl.pl1 */ 15 2 15 3 create_token: 15 4 procedure (bv_token_string, bv_token_type) returns (ptr); 15 5 15 6 /* Modified on: April 1977 by RHS for new allocation methods */ 15 7 /* Modified 770509 by PG to put hash_table in tree and make it bigger */ 15 8 15 9 /* parameters */ 15 10 15 11 declare ( bv_token_string char (*), 15 12 bv_token_type bit (9) aligned, 15 13 bv_protected bit (18) aligned 15 14 ) parameter; 15 15 15 16 /* automatic */ 15 17 15 18 declare (hash_index, i, n, n_chars, n_words) fixed bin, 15 19 mod_2_sum bit (36) aligned, 15 20 four_chars char (4) aligned, 15 21 protected bit (18) aligned, 15 22 (old_q, q, p, token_string_ptr) ptr; 15 23 15 24 /* based */ 15 25 15 26 declare token_array_overlay (64) char (4) based (token_string_ptr), 15 27 token_overlay char (n) based (token_string_ptr); 15 28 15 29 /* builtins */ 15 30 15 31 declare (addr, binary, bool, dim, divide, length, mod, null, substr, unspec) builtin; 15 32 15 33 /* external static */ 15 34 15 35 declare pl1_stat_$node_uses (18) external fixed bin; 15 36 15 37 /* include files */ 15 38 16 1 /* BEGIN INCLUDE FILE ... pl1_token_hash_table.incl.pl1 */ 16 2 16 3 declare 1 hash_table_structure aligned based (pl1_stat_$hash_table_ptr), 16 4 2 hash_table (0:630) ptr unaligned; 16 5 16 6 declare pl1_stat_$hash_table_ptr ptr external static; 16 7 16 8 /* END INCLUDE FILE ... pl1_token_hash_table.incl.pl1 */ 15 39 17 1 /* BEGIN INCLUDE FILE ... pl1_tree_areas.incl.pl1 */ 17 2 17 3 /* format: style3 */ 17 4 dcl tree_area area based (pl1_stat_$tree_area_ptr); 17 5 dcl xeq_tree_area area based (pl1_stat_$xeq_tree_area_ptr); 17 6 17 7 dcl pl1_stat_$tree_area_ptr 17 8 ptr ext static, 17 9 pl1_stat_$xeq_tree_area_ptr 17 10 ptr ext static; 17 11 17 12 /* END INCLUDE FILE ... op_codes.incl.pl1 */ 15 40 18 1 /* BEGIN INCLUDE FILE ... nodes.incl.pl1 */ 18 2 18 3 /* Modified: 26 Dec 1979 by PCK to implement by name assignment */ 18 4 18 5 dcl ( block_node initial("000000001"b), 18 6 statement_node initial("000000010"b), 18 7 operator_node initial("000000011"b), 18 8 reference_node initial("000000100"b), 18 9 token_node initial("000000101"b), 18 10 symbol_node initial("000000110"b), 18 11 context_node initial("000000111"b), 18 12 array_node initial("000001000"b), 18 13 bound_node initial("000001001"b), 18 14 format_value_node initial("000001010"b), 18 15 list_node initial("000001011"b), 18 16 default_node initial("000001100"b), 18 17 machine_state_node initial("000001101"b), 18 18 source_node initial("000001110"b), 18 19 label_node initial("000001111"b), 18 20 cross_reference_node initial("000010000"b), 18 21 sf_par_node initial("000010001"b), 18 22 temporary_node initial("000010010"b), 18 23 label_array_element_node initial("000010011"b), 18 24 by_name_agg_node initial("000010100"b)) 18 25 bit(9) internal static aligned options(constant); 18 26 18 27 dcl 1 node based aligned, 18 28 2 type unal bit(9), 18 29 2 source_id unal structure, 18 30 3 file_number bit(8), 18 31 3 line_number bit(14), 18 32 3 statement_number bit(5); 18 33 18 34 /* END INCLUDE FILE ... nodes.incl.pl1 */ 15 41 19 1 /* BEGIN INCLUDE FILE ... token.incl.pl1 */ 19 2 19 3 dcl 1 token based aligned, 19 4 2 node_type bit(9) unaligned, 19 5 2 type bit(9) unaligned, 19 6 2 loc bit(18) unaligned, /* symtab offset for identifiers, "p" flag for constants */ 19 7 2 declaration ptr unaligned, 19 8 2 next ptr unaligned, 19 9 2 size fixed(9), 19 10 2 string char(n refer(token.size)); 19 11 19 12 /* END INCLUDE FILE ... token.incl.pl1 */ 15 42 15 43 15 44 /* program */ 15 45 15 46 protected = ""b; 15 47 15 48 join: 15 49 token_string_ptr = addr (bv_token_string); 15 50 15 51 n = length (bv_token_string); 15 52 n_words = divide (n, 4, 21, 0); 15 53 n_chars = n - n_words * 4; 15 54 mod_2_sum = ""b; 15 55 15 56 do i = 1 to n_words; 15 57 four_chars = token_array_overlay (i); 15 58 mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); 15 59 end; 15 60 15 61 if n_chars ^= 0 15 62 then do; 15 63 four_chars = substr (token_array_overlay (i), 1, n_chars); 15 64 mod_2_sum = bool (mod_2_sum, unspec (four_chars), "0110"b); 15 65 end; 15 66 15 67 hash_index = mod (binary (mod_2_sum, 35), dim (hash_table, 1)); 15 68 old_q = null; 15 69 15 70 do q = hash_table (hash_index) repeat (q -> token.next) while (q ^= null); 15 71 if n < q -> token.size 15 72 then go to insert_token; 15 73 15 74 if n = q -> token.size 15 75 then if bv_token_type = q -> token.type 15 76 then if token_overlay = q -> token.string 15 77 then if protected = q -> token.loc 15 78 then return (q); 15 79 15 80 old_q = q; 15 81 end; 15 82 15 83 insert_token: 15 84 pl1_stat_$node_uses (5) = pl1_stat_$node_uses (5) + 1; 15 85 15 86 allocate token in (tree_area) set (p); 15 87 p -> token.node_type = token_node; 15 88 p -> token.type = bv_token_type; 15 89 p -> token.declaration = null; 15 90 p -> token.loc = protected; 15 91 p -> token.string = token_overlay; 15 92 p -> token.next = q; 15 93 15 94 if old_q = null 15 95 then hash_table (hash_index) = p; 15 96 else old_q -> token.next = p; 15 97 return (p); 15 98 15 99 create_token$protected: 15 100 entry (bv_token_string, bv_token_type, bv_protected) returns (ptr); 15 101 15 102 protected = bv_protected; 15 103 go to join; 15 104 15 105 /* END INCLUDE FILE ... create_token.incl.pl1 */ 1487 1488 end create_token; 1489 1490 end make_token; 1491 1492 /* Internal procedure to centralize error recovery from eof in numeric tokens */ 1493 1494 missing_exponent: 1495 procedure; 1496 1497 token_string = substr (source_string, token_start, source_index - token_start); 1498 token_string = token_string || "0"; /* provide an exponent */ 1499 token_start = 0; 1500 call lex_error (155, create_token ((token_string), char_string)); 1501 /* missing exponent */ 1502 return; 1503 1504 end missing_exponent; 1505 1506 /* This procedure handles everything that needs to be done when a newline is seen */ 1507 /* Convention: source_index must be set to the index of the character after the newline. */ 1508 1509 print_line: 1510 procedure; 1511 1512 line_length = source_index - line_start; 1513 1514 if listing_on then 1515 call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers), 1516 (line_begins_in_comment)); 1517 1518 line_start = source_index; 1519 line_number = line_number + 1; 1520 1521 if line_number >= 1f14b /* check range of line number */ then 1522 if ^lexing_after_end_stmt /* doesn't matter if past program portion of segment */ then do; 1523 call lex_error (46, null); /* too many source lines */ 1524 line_number = 1; /* no use counting higher...node fields aren't big enough */ 1525 end; 1526 1527 statement_number = 1; 1528 suppress_line_numbers = "0"b; 1529 line_begins_in_comment = "0"b; 1530 return; 1531 1532 end print_line; 1533 1534 /* procedure to flush listing buffer of everything on last line of a segment. There are two special cases 1535* to worry about: (1) the last line is empty, and (2) the last line doesn't end in a newline. */ 1536 1537 print_line_at_eof: 1538 procedure; 1539 1540 line_length = source_index - line_start; 1541 1542 if line_length = 0 then 1543 return; /* nothing on last line. */ 1544 1545 if listing_on then 1546 call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers), 1547 (line_begins_in_comment)); 1548 1549 line_begins_in_comment = "0"b; 1550 1551 if substr (source_string, source_index - 1, 1) = newline then do; 1552 suppress_line_numbers = "0"b; 1553 statement_number = 1; 1554 end; 1555 else 1556 suppress_line_numbers = "1"b; 1557 1558 return; 1559 1560 end print_line_at_eof; 1561 1562 /* procedure to flush listing buffer of everything on the line before the percent sign. */ 1563 1564 print_line_before_include: 1565 procedure; 1566 1567 line_length = source_index - line_start - 1; /* do not print percent sign */ 1568 1569 if line_length > 0 then do; /* if ll=0, percent sign is in column 1...nothing to print */ 1570 if listing_on then 1571 call pl1_print$for_lex (source_ptr, line_number, line_start, line_length, (suppress_line_numbers), 1572 (line_begins_in_comment)); 1573 1574 suppress_line_numbers = "1"b; /* we are no longer at the left margin */ 1575 line_begins_in_comment = "0"b; 1576 end; 1577 1578 listing_on = "0"b; /* in case %include is > 1 line long */ 1579 return; 1580 1581 end print_line_before_include; 1582 1583 /* Internal procedure to scan sequences of . */ 1584 /* Convention: source_index is on character after digit upon entry, and is on 1585* stopping break upon exit. */ 1586 1587 scan_past_digits: 1588 procedure; 1589 1590 scan_index = verify (substr (source_string, source_index), "0123456789"); 1591 1592 if scan_index = 0 then do; /* eof reached */ 1593 source_index = source_length + 1; /* set to pseudo-char after eof */ 1594 go to end_of_source_reached; 1595 end; 1596 else 1597 source_index = source_index + scan_index - 1; 1598 return; 1599 1600 end scan_past_digits; 1601 1602 end lex; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 04/18/00 1149.6 lex.pl1 >udd>sm>ds>w>ml>lex.pl1 241 1 08/01/89 1339.9 language_utility.incl.pl1 >ldd>incl>language_utility.incl.pl1 1-307 2 05/06/74 1846.9 source_id_descriptor.incl.pl1 >ldd>incl>source_id_descriptor.incl.pl1 1-325 3 05/06/74 1846.9 source_id_descriptor.incl.pl1 >ldd>incl>source_id_descriptor.incl.pl1 1-335 4 05/06/74 1846.9 source_id_descriptor.incl.pl1 >ldd>incl>source_id_descriptor.incl.pl1 1-374 5 05/06/74 1846.9 source_id_descriptor.incl.pl1 >ldd>incl>source_id_descriptor.incl.pl1 1-386 6 05/06/74 1846.9 source_id_descriptor.incl.pl1 >ldd>incl>source_id_descriptor.incl.pl1 242 7 07/21/80 1646.3 nodes.incl.pl1 >ldd>incl>nodes.incl.pl1 243 8 07/21/80 1646.3 pl1_tree_areas.incl.pl1 >ldd>incl>pl1_tree_areas.incl.pl1 244 9 09/14/77 1805.7 radix_factor_constants.incl.pl1 >ldd>incl>radix_factor_constants.incl.pl1 245 10 05/03/76 1420.4 source_list.incl.pl1 >ldd>incl>source_list.incl.pl1 246 11 12/07/83 1801.7 system.incl.pl1 >ldd>incl>system.incl.pl1 247 12 09/14/77 1805.7 token.incl.pl1 >ldd>incl>token.incl.pl1 248 13 09/14/77 1805.7 token_list.incl.pl1 >ldd>incl>token_list.incl.pl1 249 14 11/30/78 1327.4 token_types.incl.pl1 >ldd>incl>token_types.incl.pl1 1487 15 09/14/77 1806.1 create_token.incl.pl1 >ldd>incl>create_token.incl.pl1 15-39 16 09/14/77 1805.7 pl1_token_hash_table.incl.pl1 >ldd>incl>pl1_token_hash_table.incl.pl1 15-40 17 07/21/80 1646.3 pl1_tree_areas.incl.pl1 >ldd>incl>pl1_tree_areas.incl.pl1 15-41 18 07/21/80 1646.3 nodes.incl.pl1 >ldd>incl>nodes.incl.pl1 15-42 19 09/14/77 1805.7 token.incl.pl1 >ldd>incl>token.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. HT_VT_NP_SP 000246 constant char(4) initial packed unaligned dcl 226 ref 263 P_token_ptr parameter pointer packed unaligned dcl 1413 ref 1408 1420 action_index 000100 automatic fixed bin(17,0) dcl 75 set ref 273* 275* 278 487* 489* 492 500 724* 726* 729 729 729 733 action_table 000250 constant fixed bin(17,0) initial array dcl 186 ref 273 273 273 275 487 487 487 489 724 724 724 726 746 746 addr builtin function dcl 15-31 in procedure "create_token" ref 15-48 addr builtin function dcl 129 in procedure "lex" ref 1460 1472 addrel builtin function dcl 129 ref 1472 and 000104 constant bit(9) initial dcl 14-3 set ref 1121* and_token_ptr 000026 internal static pointer packed unaligned dcl 172 set ref 517* 1121* arrow 000065 constant bit(9) initial dcl 14-3 set ref 1136* arrow_token_ptr 000027 internal static pointer packed unaligned dcl 172 set ref 806 1136* assignment 000072 constant bit(9) initial dcl 14-3 set ref 1131* assignment_token_ptr 000030 internal static pointer packed unaligned dcl 172 set ref 555* 1131* asterisk 000110 constant bit(9) initial dcl 14-3 set ref 782 1117* asterisk_or_newline constant char(2) initial packed unaligned dcl 226 ref 574 asterisk_token_ptr 000031 internal static pointer packed unaligned dcl 172 set ref 783 1117* binary builtin function dcl 129 in procedure "lex" ref 1212 1217 binary builtin function dcl 15-31 in procedure "create_token" ref 15-67 bit builtin function dcl 129 ref 766 1296 1297 1317 1318 1319 1384 1385 1386 1423 1424 1425 bit_string 000061 constant bit(9) initial dcl 14-3 set ref 339 373* 418 424* 437 441* 766* bitcount 000101 automatic fixed bin(24,0) dcl 75 set ref 972* 1020 bool builtin function dcl 15-31 ref 15-58 15-64 bv_error_number parameter fixed bin(15,0) dcl 1373 set ref 1368 1399* bv_file_number parameter fixed bin(8,0) dcl 1243 in procedure "create_source" ref 1237 1296 bv_file_number parameter fixed bin(8,0) dcl 1344 in procedure "enter_source_segment" ref 1339 1357 bv_file_token_ptr parameter pointer dcl 1243 in procedure "create_source" set ref 1237 1274* 1275 1293 bv_file_token_ptr parameter pointer dcl 1344 in procedure "enter_source_segment" ref 1339 1356 bv_line_number parameter fixed bin(14,0) dcl 1243 ref 1237 1297 bv_protected parameter bit(18) dcl 15-11 ref 15-99 15-102 bv_source_length parameter fixed bin(21,0) dcl 1094 in procedure "lex" set ref 1089 1150* 1154* bv_source_length parameter fixed bin(21,0) dcl 1344 in procedure "enter_source_segment" ref 1339 1354 bv_source_length parameter fixed bin(21,0) dcl 1243 in procedure "create_source" ref 1237 1294 bv_source_ptr parameter pointer dcl 1243 in procedure "create_source" set ref 1237 1272* 1292 bv_source_ptr parameter pointer dcl 1344 in procedure "enter_source_segment" ref 1339 1353 bv_source_ptr parameter pointer dcl 1094 in procedure "lex" set ref 1089 1150* 1154* bv_token_ptr parameter pointer dcl 1373 set ref 1368 1399* bv_token_string parameter char packed unaligned dcl 15-11 set ref 15-3 15-48 15-51 15-99 bv_token_type parameter bit(9) dcl 15-11 ref 15-3 15-74 15-88 15-99 capital_hex 000174 constant char(6) initial packed unaligned dcl 9-13 ref 363 cat 000102 constant bit(9) initial dcl 14-3 set ref 1123* cat_token_ptr 000032 internal static pointer packed unaligned dcl 172 set ref 878 1123* cblock parameter pointer dcl 71 set ref 66 405* 1170 1197* char builtin function dcl 129 ref 766 char_string 000507 constant bit(9) initial dcl 14-3 set ref 289 375 450* 458* 458* 774* 948 1463 1500* 1500* char_value 000102 automatic fixed bin(9,0) dcl 75 set ref 271* 273 275 484* 487 489 721* 724 726 744* 746 746 763 763 766 cname 000514 automatic char(32) packed unaligned dcl 1253 set ref 1272* 1280 1282 code 000103 automatic fixed bin(35,0) dcl 75 set ref 972* 984 984* 988* 995* 1010* 1164* 1272* 1273 colon 000071 constant bit(9) initial dcl 14-3 set ref 1132* colon_token_ptr 000033 internal static pointer packed unaligned dcl 172 set ref 547* 1132* com_err_ 000470 constant entry external dcl 134 ref 984 comma 000067 constant bit(9) initial dcl 14-3 set ref 1134* comma_token_ptr 000034 internal static pointer packed unaligned dcl 172 set ref 539* 1134* command 000247 constant char(3) initial packed unaligned dcl 225 set ref 972* 984* constant_token 000472 constant entry external dcl 135 ref 405 copy builtin function dcl 129 ref 927 927 930 930 create_token 000522 constant entry external dcl 1-191 ref 373 385 424 441 450 458 458 677 766 774 970 1070 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1146 1500 1500 create_token$init_hash_table 000524 constant entry external dcl 1-197 ref 1103 current_char 000104 automatic char(1) dcl 75 set ref 270* 271 483* 484 719* 721 742* 744 768 768 774 date_time_ 000474 constant entry external dcl 136 ref 1224 dec_integer 000060 constant bit(9) initial dcl 14-3 set ref 405* 405 914 decimal_value 000106 automatic bit(9) dcl 75 set ref 601* 658* 675 685* 749* 1456 declaration 1 based pointer level 2 packed packed unaligned dcl 19-3 set ref 15-89* depthx 000105 automatic fixed bin(17,0) dcl 75 set ref 1008* 1009* digits 000176 constant char(16) initial array packed unaligned dcl 9-6 ref 371 392 dim builtin function dcl 15-31 ref 15-67 divide builtin function dcl 15-31 in procedure "create_token" ref 15-52 divide builtin function dcl 129 in procedure "lex" ref 379 427 1020 dname 000524 automatic char(256) packed unaligned dcl 1253 set ref 1272* 1280 1282 double_quote 000507 constant char(1) initial packed unaligned dcl 226 ref 328 334 double_quote_or_newline constant char(2) initial packed unaligned dcl 226 ref 291 dtm 4 based fixed bin(71,0) level 3 in structure "source" dcl 10-8 in procedure "lex" set ref 1224* 1299* dtm 4(18) 000376 automatic char(16) level 2 in structure "source_info" packed packed unaligned dcl 1173 in procedure "lex" set ref 1224* dtm 000624 automatic fixed bin(71,0) dcl 1253 in procedure "create_source" set ref 1272* 1278* 1299 dx 000107 automatic fixed bin(17,0) dcl 75 set ref 363* 366* 368* 371 392 ename 000626 automatic char(32) packed unaligned dcl 1253 set ref 1272* 1280 1282 error_ 000526 constant entry external dcl 1-324 ref 1399 error_number 000110 automatic fixed bin(15,0) dcl 75 set ref 765* 769* 773* 777* error_token 000112 automatic pointer dcl 75 set ref 373* 374* 385* 388* 424* 425* 441* 442* 450* 451* 493* 495 495 495 495* 677* 680* 766* 770* 774* 777* expand_bit_chars 000113 constant char(64) initial array packed unaligned dcl 9-17 ref 393 expon 000106 constant bit(9) initial dcl 14-3 set ref 1119* expon_token_ptr 000035 internal static pointer packed unaligned dcl 172 set ref 790 1119* file_id 2(27) 000376 automatic char(3) level 2 packed packed unaligned dcl 1173 set ref 1222* file_number 7 000060 internal static fixed bin(8,0) array level 2 in structure "file_stack" dcl 178 in procedure "lex" set ref 1006* 1078* file_number 000554 external static bit(8) level 2 in structure "pl1_stat_$statement_id" packed packed unaligned dcl 13-6 in procedure "lex" set ref 1317* 1384* 1423* file_number 0(09) based bit(8) level 3 in structure "source" packed packed unaligned dcl 10-8 in procedure "lex" set ref 1209 1212 1296* file_stack 000060 internal static structure array level 1 dcl 178 set ref 994 1008 file_token_ptr 000010 internal static pointer dcl 157 in procedure "lex" set ref 282* 295* 577* 1002 1356* file_token_ptr 2 000060 internal static pointer array level 2 in structure "file_stack" dcl 178 in procedure "lex" set ref 1002* 1078* find_include_file_$initiate_count 000476 constant entry external dcl 137 ref 972 first_bit 000114 automatic fixed bin(17,0) dcl 75 set ref 392* 393 five_digits 000476 automatic picture(5) packed unaligned dcl 1185 set ref 1217* 1219 fixed_bin constant bit(9) initial dcl 14-3 ref 600 748 1456 float_value 000115 automatic bit(9) dcl 75 set ref 603* 633* 751* 1456 four_chars 001016 automatic char(4) dcl 15-18 set ref 15-57* 15-58 15-63* 15-64 ge 000075 constant bit(9) initial dcl 14-3 set ref 1128* ge_token_ptr 000036 internal static pointer packed unaligned dcl 172 set ref 838 1128* gt 000077 constant bit(9) initial dcl 14-3 set ref 830 1126* gt_token_ptr 000037 internal static pointer packed unaligned dcl 172 set ref 831 1126* hash_index 001010 automatic fixed bin(17,0) dcl 15-18 set ref 15-67* 15-70 15-94 hash_table based pointer array level 2 packed packed unaligned dcl 16-3 set ref 15-67 15-70 15-94* hash_table_structure based structure level 1 dcl 16-3 hbound builtin function dcl 129 ref 273 273 487 487 724 724 746 994 hcs_$terminate_noname 000500 constant entry external dcl 138 ref 988 995 1010 1164 header 000027 constant varying char(93) initial dcl 1190 set ref 1204* i 001011 automatic fixed bin(17,0) dcl 15-18 set ref 15-56* 15-57* 15-63 i_float_dec 000500 constant bit(9) initial dcl 14-3 set ref 677* identifier 000505 constant bit(9) initial dcl 14-3 set ref 467 948 970* 1070* 1146* identifier_characters 000226 constant char(64) initial packed unaligned dcl 226 ref 471 imaginary_value 000116 automatic bit(9) dcl 75 set ref 602* 671* 688 700 708 750* 1456 include_file_length 000117 automatic fixed bin(21,0) dcl 75 set ref 1020* 1021* 1025* include_file_name 000120 automatic varying char(32) dcl 75 set ref 948* 964 969* 969 970 972 976 976 984* include_file_ptr 000132 automatic pointer dcl 75 set ref 972* 975 988* 995* 1009 1010* 1021* 1025* include_name 11 000376 automatic char(32) level 2 packed packed unaligned dcl 1173 set ref 1225* include_path 000636 automatic varying char(256) dcl 1253 set ref 1275* 1280* 1282* 1285 1295 index builtin function dcl 129 ref 343 392 976 976 integral_value 000134 automatic bit(9) dcl 75 set ref 604* 612* 636* 752* 1456 is_decimal_constant constant bit(9) initial dcl 14-47 ref 601 685 749 is_float_constant constant bit(9) initial dcl 14-47 ref 633 is_imaginary_constant constant bit(9) initial dcl 14-47 ref 671 is_integral_constant constant bit(9) initial dcl 14-47 ref 604 isub constant bit(9) initial dcl 14-3 ref 625 k 000135 automatic fixed bin(17,0) dcl 75 set ref 891* 898* 898 900 900 901 906 909* 909 911 914 914 914 918* 922 923* 923 933 940 946* 946 948 948 948 956 965 lbound builtin function dcl 129 ref 1008 le 000076 constant bit(9) initial dcl 14-3 set ref 1127* le_token_ptr 000040 internal static pointer packed unaligned dcl 172 set ref 822 1127* left_parn 000064 constant bit(9) initial dcl 14-3 set ref 400 914 1137* left_parn_token_ptr 000041 internal static pointer packed unaligned dcl 172 set ref 523* 1137* length builtin function dcl 129 in procedure "lex" ref 382 391 423 427 438 455 964 1227 1227 1285 1474 length builtin function dcl 15-31 in procedure "create_token" ref 15-51 lexing_after_end_stmt 000012 internal static bit(1) dcl 157 set ref 1031 1053 1111* 1196* 1521 line_begins_in_comment 000013 internal static bit(1) dcl 157 set ref 585* 1110* 1514 1529* 1545 1549* 1570 1575* line_id 000472 automatic varying char(9) dcl 1184 in procedure "lex" set ref 1209* 1214* 1219 line_id 000376 automatic char(9) level 2 in structure "source_info" packed packed unaligned dcl 1173 in procedure "lex" set ref 1219* line_length 000136 automatic fixed bin(21,0) dcl 75 set ref 1512* 1514* 1540* 1542 1545* 1567* 1569 1570* line_number 0(08) 000554 external static bit(14) level 2 in structure "pl1_stat_$statement_id" packed packed unaligned dcl 13-6 in procedure "lex" set ref 1318* 1385* 1424* line_number 000014 internal static fixed bin(14,0) dcl 157 in procedure "lex" set ref 1005 1021* 1050 1083* 1318 1358* 1385 1424 1514* 1519* 1519 1521 1524* 1545* 1570* line_number 0(17) based bit(14) level 3 in structure "source" packed packed unaligned dcl 10-8 in procedure "lex" set ref 1217 1297* line_number 6 000060 internal static fixed bin(14,0) array level 2 in structure "file_stack" dcl 178 in procedure "lex" set ref 1005* 1083 line_start 000015 internal static fixed bin(21,0) dcl 157 set ref 890* 1082* 1359* 1389 1512 1514* 1518* 1540 1545* 1567 1570* listing_on 000137 automatic bit(1) dcl 75 set ref 257* 889* 927 1199* 1201 1514 1545 1570 1578* loc 0(18) based bit(18) level 2 packed packed unaligned dcl 19-3 set ref 15-74 15-90* lt 000100 constant bit(9) initial dcl 14-3 set ref 814 1125* lt_token_ptr 000042 internal static pointer packed unaligned dcl 172 set ref 815 1125* ltrim builtin function dcl 129 ref 1214 1219 m 000373 automatic fixed bin(15,0) dcl 10-1 set ref 1163* 1164 1206* 1209 1212 1217 1221 1224 1225 1226 1227* 1289* 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 max_bit_string_constant constant fixed bin(31,0) initial dcl 11-5 ref 379 418 438 440 max_char_string_constant constant fixed bin(31,0) initial dcl 11-5 ref 420 447 449 455 457 max_identifier_length constant fixed bin(31,0) initial dcl 11-5 ref 1466 1467 max_in_chars 000140 automatic fixed bin(17,0) dcl 75 set ref 379* 382 384 minus 000111 constant bit(9) initial dcl 14-3 set ref 798 1116* minus_token_ptr 000043 internal static pointer packed unaligned dcl 172 set ref 799 1116* mod builtin function dcl 15-31 ref 15-67 mod_2_sum 001015 automatic bit(36) dcl 15-18 set ref 15-54* 15-58* 15-58 15-64* 15-64 15-67 n 001012 automatic fixed bin(17,0) dcl 15-18 in procedure "create_token" set ref 15-51* 15-52 15-53 15-71 15-74 15-74 15-86 15-86 15-91 n 000141 automatic fixed bin(21,0) dcl 75 in procedure "lex" set ref 906* 919* 922* 927 927 930 930 1227* 1228 1285* 1290 1290 n_chars 001013 automatic fixed bin(17,0) dcl 15-18 set ref 15-53* 15-61 15-63 n_words 001014 automatic fixed bin(17,0) dcl 15-18 set ref 15-52* 15-53 15-56 name 7 based pointer level 2 packed packed unaligned dcl 10-8 set ref 1225 1293* ne 000101 constant bit(9) initial dcl 14-3 set ref 1124* ne_token_ptr 000044 internal static pointer packed unaligned dcl 172 set ref 854 1124* new_file_number 000142 automatic fixed bin(8,0) dcl 75 set ref 1021* 1025* 1150* 1154* new_file_token_ptr 000144 automatic pointer dcl 75 set ref 970* 976* 979* 989* 996* 1011* 1021* 1025* 1146* 1150* 1154* newline 012402 constant char(1) initial packed unaligned dcl 226 ref 305 583 930 930 1551 newpage constant char(1) initial packed unaligned dcl 226 ref 927 927 next 2 based pointer level 2 packed packed unaligned dcl 19-3 set ref 15-81 15-92* 15-96* ngt 000074 constant bit(9) initial dcl 14-3 set ref 1129* ngt_token_ptr 000045 internal static pointer packed unaligned dcl 172 set ref 862 1129* nlt 000073 constant bit(9) initial dcl 14-3 set ref 1130* nlt_token_ptr 000046 internal static pointer packed unaligned dcl 172 set ref 858 1130* no_token 000513 constant bit(9) initial dcl 14-3 set ref 385* node_type based bit(9) level 2 in structure "source" packed packed unaligned dcl 10-8 in procedure "lex" set ref 1291* node_type based bit(9) level 2 in structure "token" packed packed unaligned dcl 19-3 in procedure "create_token" set ref 15-87* not 000105 constant bit(9) initial dcl 14-3 set ref 846 1120* not_token_ptr 000047 internal static pointer packed unaligned dcl 172 set ref 847 1120* null builtin function dcl 15-31 in procedure "create_token" ref 15-68 15-70 15-89 15-94 null builtin function dcl 129 in procedure "lex" ref 506 506 770 916 916 933 933 942 942 952 952 958 958 975 1031 1031 1043 1043 1054 1054 1061 1061 1066 1066 1309 1309 1326 1326 1332 1523 1523 old_q 001020 automatic pointer dcl 15-18 set ref 15-68* 15-80* 15-94 15-96 or 000103 constant bit(9) initial dcl 14-3 set ref 870 1122* or_token_ptr 000050 internal static pointer packed unaligned dcl 172 set ref 871 1122* p 001024 automatic pointer dcl 15-18 set ref 15-86* 15-87 15-88 15-89 15-90 15-91 15-92 15-94 15-96 15-97 page_macro 000146 automatic bit(1) dcl 75 set ref 901* 903* 927 parenthesis_level 000147 automatic fixed bin(21,0) dcl 75 set ref 258* 522* 522 528* 528 544 552 pathlen 10(25) based fixed bin(10,0) level 2 packed packed unaligned dcl 10-8 set ref 1226 1227 1290* 1295 pathname 21(18) 000376 automatic char(168) level 2 in structure "source_info" packed packed unaligned dcl 1173 in procedure "lex" set ref 1226* 1227 pathname 11 based char level 2 in structure "source" dcl 10-8 in procedure "lex" set ref 1226 1295* percent 000062 constant bit(9) initial dcl 14-3 set ref 893 1139* percent_sign_seen 000150 automatic bit(1) dcl 75 set ref 261* 506 509* 887 888* 1041 1044* percent_token_ptr 000051 internal static pointer packed unaligned dcl 172 set ref 512* 1139* period 000066 constant bit(9) initial dcl 14-3 set ref 737 1135* period_token_ptr 000052 internal static pointer packed unaligned dcl 172 set ref 756* 1135* pl1_print$for_lex 000536 constant entry external dcl 1-418 ref 1514 1545 1570 pl1_print$non_varying 000532 constant entry external dcl 1-398 ref 927 930 pl1_print$non_varying_nl 000534 constant entry external dcl 1-402 ref 1228 pl1_print$varying_nl 000530 constant entry external dcl 1-395 ref 1204 pl1_stat_$cur_statement 000502 external static pointer dcl 143 set ref 1332* pl1_stat_$hash_table_ptr 000564 external static pointer dcl 16-6 ref 15-67 15-70 15-94 pl1_stat_$last_source 000546 external static fixed bin(15,0) dcl 10-3 set ref 987 1143* 1162* 1162* 1163* 1206 1289 1289* pl1_stat_$level_0_colon 000504 external static bit(1) dcl 143 set ref 259* 544* pl1_stat_$level_0_equal 000506 external static bit(1) dcl 143 set ref 260* 552* pl1_stat_$line_count 000510 external static fixed bin(17,0) dcl 143 set ref 1050* 1050 1144* pl1_stat_$listing_on 000512 external static bit(1) dcl 143 ref 257 889 1199 pl1_stat_$node_uses 000560 external static fixed bin(17,0) array dcl 1267 in procedure "create_source" set ref 1287* 1287 pl1_stat_$node_uses 000562 external static fixed bin(17,0) array dcl 15-35 in procedure "create_token" set ref 15-83* 15-83 pl1_stat_$seg_name 000514 external static varying char(32) dcl 143 ref 1146 pl1_stat_$source_list_ptr 000550 external static pointer dcl 10-4 ref 1164 1209 1212 1217 1224 1225 1226 1227 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 pl1_stat_$source_seg 000544 external static fixed bin(8,0) dcl 10-2 set ref 1006 1021* 1142* 1317 1357* 1384 1399* 1423 pl1_stat_$st_length 000516 external static fixed bin(21,0) dcl 143 set ref 1073* 1330* 1361* pl1_stat_$st_start 000520 external static fixed bin(21,0) dcl 143 set ref 1320* 1330 1330 1360* 1388 1389* 1393 1396 1399 1427* 1430* pl1_stat_$statement_id 000554 external static structure level 1 packed packed unaligned dcl 13-6 set ref 1399* pl1_stat_$token_list_ptr 000552 external static pointer dcl 13-1 ref 13-3 pl1_stat_$tree_area_ptr 000542 external static pointer dcl 8-7 in procedure "lex" ref 1290 pl1_stat_$tree_area_ptr 000566 external static pointer dcl 17-7 in procedure "create_token" ref 15-86 plus 000112 constant bit(9) initial dcl 14-3 set ref 1115* plus_token_ptr 000053 internal static pointer packed unaligned dcl 172 set ref 534* 1115* protected 001017 automatic bit(18) dcl 15-18 in procedure "create_token" set ref 15-46* 15-74 15-90 15-102* protected 000151 automatic bit(18) dcl 75 in procedure "lex" set ref 256* 666* 699 1477* 1480* q 001022 automatic pointer dcl 15-18 set ref 15-70* 15-70* 15-71 15-74 15-74 15-74 15-74 15-74 15-80* 15-81 15-92 radix 000152 automatic fixed bin(17,0) dcl 75 set ref 343* 345 347* 350* 363 368 378 379 385 392 393 393 rank builtin function dcl 129 ref 271 484 721 744 rep_factor 000153 automatic fixed bin(17,0) dcl 75 set ref 409* 423 427* 431 right_parn 000063 constant bit(9) initial dcl 14-3 set ref 400 914 1138* right_parn_token_ptr 000054 internal static pointer packed unaligned dcl 172 set ref 529* 1138* rtrim builtin function dcl 129 ref 1280 1280 1282 1282 saved_token_index 000154 automatic fixed bin(17,0) dcl 75 set ref 510* 891 894 936 941 951 957 962 1045 scan_index 000155 automatic fixed bin(21,0) dcl 75 set ref 263* 266 269 291* 294 305 306 308 311 318 320 323 471* 473 478 574* 576 581 659* 686 1590* 1592 1596 search builtin function dcl 129 ref 291 363 574 seg_ptr 6 based pointer level 2 packed packed unaligned dcl 10-8 set ref 1164 1292* semi_colon 000070 constant bit(9) initial dcl 14-3 set ref 1133* semi_colon_token_ptr 000055 internal static pointer packed unaligned dcl 172 set ref 1133* 1314 size 3 based fixed bin(9,0) level 2 in structure "token" dcl 12-3 in procedure "lex" ref 495 495 495 1225 1275 size 3 based fixed bin(9,0) level 2 in structure "token" dcl 19-3 in procedure "create_token" set ref 15-71 15-74 15-74 15-86* 15-91 size 3 based fixed bin(9,0) level 2 in structure "t_table" dcl 13-11 in procedure "lex" ref 900 900 901 940 948 slash 000107 constant bit(9) initial dcl 14-3 set ref 560 1118* slash_token_ptr 000056 internal static pointer packed unaligned dcl 172 set ref 566* 1118* source based structure level 1 dcl 10-8 set ref 1290 source_depth 000016 internal static fixed bin(17,0) dcl 157 set ref 994 1001 1002 1003 1004 1005 1006 1008 1019* 1019 1052 1077* 1077 1078 1078 1078 1078 1081 1083 1141* source_id 0(09) based structure level 2 packed packed unaligned dcl 10-8 source_index 4 000060 internal static fixed bin(21,0) array level 2 in structure "file_stack" dcl 178 in procedure "lex" set ref 1003* 1081 source_index 000017 internal static fixed bin(21,0) dcl 157 in procedure "lex" set ref 263 269* 269 270 280 286 287 291 297 305 306 311* 311 318 323* 323 325 328 335* 335 338 340* 340 342 343 345* 345 461 469 471 474* 478* 478 483 485* 485 504 515 520 526 532 537 542 550 558 562 565 572* 572 574 581* 581 583 591 592* 592 598 606 611 614* 614 617 622 622 624* 624 630 632 632 633 637* 637 639 644 644 646* 646 648 657 659 660* 660 663 663 665* 665 669 669 672* 672 677 677 700 702 712 719 722* 722 735 739 742 780 785 788 789* 789 796 801 804 805* 805 812 817 820 821* 821 828 833 836 837* 837 844 849 852 853* 853 856 857* 857 860 861* 861 868 873 876 877* 877 884 890 1003 1081* 1082 1330 1355* 1391 1393 1396 1463 1497 1512 1518 1540 1551 1567 1590 1593* 1596* 1596 source_info 000376 automatic structure level 1 dcl 1173 set ref 1207* 1227 1228 1228 source_length 000020 internal static fixed bin(21,0) dcl 157 in procedure "lex" set ref 263 270 280 291 297 299 305 306 318 325 328 330 338 342 343 354 412 450 450 461 471 474 483 562 565 574 583 591 606 611 617 622 622 632 632 633 639 644 644 648 657 663 663 669 669 675 677 677 686 705 712 719 739 742 785 788 801 804 817 820 833 836 849 852 856 860 873 876 1004 1354* 1391 1460 1497 1551 1590 1593 source_length 5 000060 internal static fixed bin(21,0) array level 2 in structure "file_stack" dcl 178 in procedure "lex" set ref 1004* 1078* source_length 10 based fixed bin(24,0) level 2 in structure "source" packed packed unaligned dcl 10-8 in procedure "lex" set ref 1294* source_list based pointer array dcl 10-5 set ref 1164 1209 1212 1217 1224 1225 1226 1227 1290* 1291 1292 1293 1294 1295 1296 1297 1298 1299 source_list_length constant fixed bin(15,0) initial dcl 10-6 ref 987 source_node constant bit(9) initial dcl 7-5 ref 1291 source_ptr 000022 internal static pointer dcl 157 in procedure "lex" set ref 263 270 291 297 305 306 318 328 330 338 343 354 412 450 450 471 483 565 574 583 591 611 622 632 632 633 644 644 657 663 669 675 677 677 686 705 719 742 788 804 820 836 852 856 860 876 972* 1001 1353* 1460 1497 1514* 1545* 1551 1570* 1590 source_ptr 000060 internal static pointer array level 2 in structure "file_stack" dcl 178 in procedure "lex" set ref 1001* 1009 1078* source_string based char packed unaligned dcl 122 set ref 263 270 291 297 305 306 318 328 330 338 343 354 412 450 450 471 483 565 574 583 591 611 622 632 632 633 644 644 657 663 669 675 677 677 686 705 719 742 788 804 820 836 852 856 860 876 1460 1497 1551 1590 standard_object_info 2 based structure level 2 dcl 10-8 statement_length 000762 automatic fixed bin(21,0) dcl 1380 set ref 1391* 1393* 1396* 1399 statement_number 0(22) 000554 external static bit(5) level 2 in structure "pl1_stat_$statement_id" packed packed unaligned dcl 13-6 in procedure "lex" set ref 1319* 1386* 1425* statement_number 000024 internal static fixed bin(5,0) dcl 157 in procedure "lex" set ref 1107* 1319 1323* 1323 1325 1327* 1386 1425 1527* 1553* string 4 based char level 2 in structure "t_table" dcl 13-11 in procedure "lex" ref 900 900 901 940 948 string builtin function dcl 129 in procedure "lex" set ref 1207* 1227 1228 1228 string 4 based char level 2 in structure "token" dcl 19-3 in procedure "create_token" set ref 15-74 15-91* string 4 based char level 2 in structure "token" dcl 12-3 in procedure "lex" ref 495 495 495 1225 1275 string_max 000156 automatic fixed bin(21,0) dcl 75 set ref 418* 420* 423 427 string_token_start 000157 automatic fixed bin(21,0) dcl 75 set ref 287* 691* 1427 strx 000160 automatic fixed bin(17,0) dcl 75 set ref 391* 392* 431* substr builtin function dcl 129 in procedure "lex" ref 263 270 291 297 305 306 318 328 330 338 343 354 384 385 392 393 412 440 450 450 457 471 483 565 574 583 591 611 622 632 632 633 644 644 657 663 669 675 677 677 686 705 719 742 788 804 820 836 852 856 860 876 1460 1497 1551 1590 substr builtin function dcl 15-31 in procedure "create_token" ref 15-63 suppress_line_numbers 000025 internal static bit(1) dcl 157 set ref 1109* 1514 1528* 1545 1552* 1555* 1570 1574* t_table based structure level 1 dcl 13-11 temp_token_string 000161 automatic varying char(256) dcl 75 set ref 354* 357* 363 371 373 376 382 384* 384 385 391 392 396 412* 415* 423 424 427 432 three_digits 000500 automatic picture(3) packed unaligned dcl 1186 set ref 1212* 1214 1221* 1222 token based structure level 1 dcl 12-3 in procedure "lex" token based structure level 1 dcl 19-3 in procedure "create_token" set ref 15-86 token_array_overlay based char(4) array packed unaligned dcl 15-26 ref 15-57 15-63 token_index 000262 automatic fixed bin(17,0) dcl 75 set ref 255* 400 400 400 403* 403 405 405 409 493 510 729 893 894* 906 911 918 933 936* 941* 951* 956 957* 962* 1045* 1054 1060 1068 1068* 1068 1070 1309 1311* 1311 1314 1316 1417 1417* 1417 1420 1422 token_length 000263 automatic fixed bin(21,0) dcl 75 set ref 288* 299* 308* 308 320* 320 330 354 412 447 449* 450 450 630* 675 700* 702* 705 1463* 1466 1467* 1468 1468 1468 1468 1474* 1477 1477 token_list based pointer array dcl 13-2 set ref 400 400 405* 405* 409* 493 729* 893 900 900 901 914 914 914 922* 940 948 948 948 965* 1070* 1314* 1420* token_list_length constant fixed bin(15,0) initial dcl 13-4 ref 1068 1309 1417 token_list_pointer 000374 automatic pointer initial dcl 13-3 set ref 400 400 405 405 409 493 729 893 900 900 901 914 914 914 922 940 948 948 948 965 1070 13-3* 1314 1420 token_node constant bit(9) initial dcl 18-5 ref 15-87 token_overlay based char packed unaligned dcl 15-26 in procedure "create_token" ref 15-74 15-91 token_overlay based char packed unaligned dcl 122 in procedure "lex" set ref 1468* 1468* 1477* token_ptr 001000 automatic pointer packed unaligned dcl 1452 in procedure "make_token" set ref 1477* 1482* token_ptr 000264 automatic pointer packed unaligned dcl 75 in procedure "lex" set ref 783* 790* 793* 799* 806* 809* 815* 822* 825* 831* 838* 841* 847* 854* 858* 862* 865* 871* 878* 881* token_start 000265 automatic fixed bin(21,0) dcl 75 set ref 286* 297 299 306 318 329 330 331* 353 354 355* 411 412 413* 447 450 450 469* 504* 515* 520* 526* 532* 537* 542* 550* 558* 598* 630 675 677 677 677 677 686 686 691 692* 699 700 702 705 706* 735* 780* 796* 812* 828* 844* 868* 884* 1320 1427 1430 1459 1460 1463 1497 1497 1499* token_string 000266 automatic varying char(256) dcl 75 set ref 297* 297 306* 306 318* 318 330* 334* 334 357 376* 380* 393* 393 396* 415 430* 432* 432 438 440* 440 441 445* 445 455 457* 457 458 458 686* 688* 688 705* 708* 708 1472 1474 1497* 1498* 1498 1500 1500 token_string_ptr 001026 automatic pointer dcl 15-18 in procedure "create_token" set ref 15-48* 15-57 15-63 15-74 15-91 token_string_ptr 000370 automatic pointer dcl 75 in procedure "lex" set ref 1460* 1468 1468 1472* 1477 token_to_binary 000540 constant entry external dcl 1-459 ref 409 922 token_type 000372 automatic bit(9) dcl 75 set ref 289* 339* 375* 418 437 467* 560* 600* 625* 737* 748* 782* 798* 814* 830* 846* 870* 1456 1456* 1456 1463 1468 1468 1477 translator_info_$component_get_source_info 000556 constant entry external dcl 1262 ref 1272 tree_area based area(1024) dcl 8-4 in procedure "lex" ref 1290 tree_area based area(1024) dcl 17-4 in procedure "create_token" ref 15-86 type 0(09) based bit(9) level 2 in structure "token" packed packed unaligned dcl 12-3 in procedure "lex" ref 400 400 893 914 914 type 0(09) based bit(9) level 2 in structure "t_table" packed packed unaligned dcl 13-11 in procedure "lex" ref 914 948 948 type 0(09) based bit(9) level 2 in structure "token" packed packed unaligned dcl 19-3 in procedure "create_token" set ref 15-74 15-88* uid 000737 automatic bit(36) dcl 1253 in procedure "create_source" set ref 1272* 1277* 1298 uid 2 based bit(36) level 3 in structure "source" dcl 10-8 in procedure "lex" set ref 1298* unspec builtin function dcl 15-31 ref 15-58 15-64 verify builtin function dcl 129 ref 263 371 471 675 1590 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. adjust_count 000000 constant entry external dcl 1-20 arg_desc_type internal static bit(36) initial dcl 11-71 array_node internal static bit(9) initial dcl 7-5 in procedure "lex" array_node internal static bit(9) initial dcl 18-5 in procedure "create_token" bin_integer internal static bit(9) initial dcl 14-3 binary_to_octal_string 000000 constant entry external dcl 1-38 binary_to_octal_var_string 000000 constant entry external dcl 1-43 bindec 000000 constant entry external dcl 1-23 bindec$vs 000000 constant entry external dcl 1-28 binoct 000000 constant entry external dcl 1-33 bit_type internal static bit(36) initial dcl 11-71 bits_per_binary_exponent internal static fixed bin(31,0) initial dcl 11-5 bits_per_character internal static fixed bin(31,0) initial dcl 11-5 bits_per_decimal_digit internal static fixed bin(31,0) initial dcl 11-5 bits_per_digit internal static fixed bin(31,1) initial dcl 11-69 bits_per_double internal static fixed bin(31,0) initial dcl 11-5 bits_per_half internal static fixed bin(31,0) initial dcl 11-5 bits_per_packed_ptr internal static fixed bin(31,0) initial dcl 11-5 bits_per_word internal static fixed bin(31,0) initial dcl 11-5 block_node internal static bit(9) initial dcl 7-5 in procedure "lex" block_node internal static bit(9) initial dcl 18-5 in procedure "create_token" bound_node internal static bit(9) initial dcl 18-5 in procedure "create_token" bound_node internal static bit(9) initial dcl 7-5 in procedure "lex" builtin_type internal static bit(36) initial dcl 11-71 by_name_agg_node internal static bit(9) initial dcl 7-5 in procedure "lex" by_name_agg_node internal static bit(9) initial dcl 18-5 in procedure "create_token" char_type internal static bit(36) initial dcl 11-71 characters_per_double internal static fixed bin(31,0) initial dcl 11-5 characters_per_half internal static fixed bin(31,0) initial dcl 11-5 characters_per_word internal static fixed bin(31,0) initial dcl 11-5 compare_expression 000000 constant entry external dcl 1-48 complex_type internal static bit(36) initial dcl 11-71 constant_length 000000 constant entry external dcl 1-54 context_node internal static bit(9) initial dcl 18-5 in procedure "create_token" context_node internal static bit(9) initial dcl 7-5 in procedure "lex" convert 000000 constant entry external dcl 1-60 convert$from_builtin 000000 constant entry external dcl 1-72 convert$to_integer 000000 constant entry external dcl 1-66 convert$to_target 000000 constant entry external dcl 1-88 convert$to_target_fb 000000 constant entry external dcl 1-82 convert$validate 000000 constant entry external dcl 1-78 copy_expression 000000 constant entry external dcl 1-94 copy_expression$copy_sons 000000 constant entry external dcl 1-99 copy_unique_expression 000000 constant entry external dcl 1-103 create_array 000000 constant entry external dcl 1-108 create_block 000000 constant entry external dcl 1-112 create_bound 000000 constant entry external dcl 1-118 create_context 000000 constant entry external dcl 1-122 create_cross_reference 000000 constant entry external dcl 1-128 create_default 000000 constant entry external dcl 1-132 create_identifier 000000 constant entry external dcl 1-136 create_label 000000 constant entry external dcl 1-140 create_list 000000 constant entry external dcl 1-147 create_operator 000000 constant entry external dcl 1-152 create_reference 000000 constant entry external dcl 1-158 create_statement 000000 constant entry external dcl 1-163 create_statement$prologue 000000 constant entry external dcl 1-171 create_storage 000000 constant entry external dcl 1-179 create_symbol 000000 constant entry external dcl 1-184 create_token$protected 000000 constant entry external dcl 1-199 cross_reference_node internal static bit(9) initial dcl 18-5 in procedure "create_token" cross_reference_node internal static bit(9) initial dcl 7-5 in procedure "lex" dec_integer_type internal static bit(36) initial dcl 11-71 decbin 000000 constant entry external dcl 1-206 declare_constant 000000 constant entry external dcl 1-211 declare_constant$bit 000000 constant entry external dcl 1-219 declare_constant$char 000000 constant entry external dcl 1-224 declare_constant$desc 000000 constant entry external dcl 1-229 declare_constant$integer 000000 constant entry external dcl 1-234 declare_descriptor 000000 constant entry external dcl 1-239 declare_descriptor$ctl 000000 constant entry external dcl 1-249 declare_descriptor$param 000000 constant entry external dcl 1-259 declare_integer 000000 constant entry external dcl 1-269 declare_picture 000000 constant entry external dcl 1-274 declare_picture_temp 000000 constant entry external dcl 1-279 declare_pointer 000000 constant entry external dcl 1-287 declare_temporary 000000 constant entry external dcl 1-292 decode_node_id 000000 constant entry external dcl 1-300 decode_source_id 000000 constant entry external dcl 1-306 default_area_size internal static fixed bin(31,0) initial dcl 11-5 default_fix_bin_p internal static fixed bin(31,0) initial dcl 11-5 default_fix_dec_p internal static fixed bin(31,0) initial dcl 11-5 default_flt_bin_p internal static fixed bin(31,0) initial dcl 11-5 default_flt_dec_p internal static fixed bin(31,0) initial dcl 11-5 default_node internal static bit(9) initial dcl 7-5 in procedure "lex" default_node internal static bit(9) initial dcl 18-5 in procedure "create_token" entry_var_type internal static bit(36) initial dcl 11-71 eq internal static bit(9) initial dcl 14-3 error 000000 constant entry external dcl 1-314 error$omit_text 000000 constant entry external dcl 1-319 error_$finish 000000 constant entry external dcl 1-343 error_$initialize_error 000000 constant entry external dcl 1-341 error_$no_text 000000 constant entry external dcl 1-334 error_table_$noentry external static fixed bin(35,0) dcl 142 expand_bits internal static bit(64) initial array packed unaligned dcl 9-21 fixed_dec internal static bit(9) initial dcl 14-3 float_bin internal static bit(9) initial dcl 14-3 float_dec internal static bit(9) initial dcl 14-3 format_value_node internal static bit(9) initial dcl 7-5 in procedure "lex" format_value_node internal static bit(9) initial dcl 18-5 in procedure "create_token" free_node 000000 constant entry external dcl 1-345 get_array_size 000000 constant entry external dcl 1-348 get_size 000000 constant entry external dcl 1-352 i_bin_integer internal static bit(9) initial dcl 14-3 i_dec_integer internal static bit(9) initial dcl 14-3 i_fixed_bin internal static bit(9) initial dcl 14-3 i_fixed_dec internal static bit(9) initial dcl 14-3 i_float_bin internal static bit(9) initial dcl 14-3 integer_type internal static bit(36) initial dcl 11-71 is_arith_constant internal static bit(9) initial dcl 14-47 is_arithmetic_constant internal static bit(9) initial dcl 14-47 is_constant internal static bit(9) initial dcl 14-47 is_delimiter internal static bit(9) initial dcl 14-47 is_identifier internal static bit(9) initial dcl 14-47 is_isub internal static bit(9) initial dcl 14-47 label_array_element_node internal static bit(9) initial dcl 7-5 in procedure "lex" label_array_element_node internal static bit(9) initial dcl 18-5 in procedure "create_token" label_node internal static bit(9) initial dcl 18-5 in procedure "create_token" label_node internal static bit(9) initial dcl 7-5 in procedure "lex" list_node internal static bit(9) initial dcl 7-5 in procedure "lex" list_node internal static bit(9) initial dcl 18-5 in procedure "create_token" local_label_var_type internal static bit(36) initial dcl 11-71 lower_case_hex internal static char(6) initial packed unaligned dcl 9-15 machine_state_node internal static bit(9) initial dcl 7-5 in procedure "lex" machine_state_node internal static bit(9) initial dcl 18-5 in procedure "create_token" max_area_size internal static fixed bin(31,0) initial dcl 11-5 max_bit_string internal static fixed bin(31,0) initial dcl 11-5 max_char_string internal static fixed bin(31,0) initial dcl 11-5 max_index_register_value internal static fixed bin(31,0) initial dcl 11-5 max_length_precision internal static fixed bin(31,0) initial dcl 11-5 max_number_of_dimensions internal static fixed bin(31,0) initial dcl 11-5 max_offset_precision internal static fixed bin(31,0) initial dcl 11-5 max_p_bin_or_dec internal static fixed bin(31,0) initial dcl 11-5 max_p_dec internal static fixed bin(31,0) initial dcl 11-5 max_p_fix_bin_1 internal static fixed bin(31,0) initial dcl 11-5 max_p_fix_bin_2 internal static fixed bin(31,0) initial dcl 11-5 max_p_flt_bin_1 internal static fixed bin(31,0) initial dcl 11-5 max_p_flt_bin_2 internal static fixed bin(31,0) initial dcl 11-5 max_scale internal static fixed bin(31,0) initial dcl 11-5 max_signed_index_register_value internal static fixed bin(31,0) initial dcl 11-5 max_signed_xreg_precision internal static fixed bin(31,0) initial dcl 11-5 max_uns_xreg_precision internal static fixed bin(31,0) initial dcl 11-5 max_words_per_variable internal static fixed bin(31,0) initial dcl 11-5 merge_attributes 000000 constant entry external dcl 1-355 min_area_size internal static fixed bin(31,0) initial dcl 11-5 min_scale internal static fixed bin(31,0) initial dcl 11-5 node based structure level 1 dcl 7-27 in procedure "lex" node based structure level 1 dcl 18-27 in procedure "create_token" operator_node internal static bit(9) initial dcl 18-5 in procedure "create_token" operator_node internal static bit(9) initial dcl 7-5 in procedure "lex" optimizer 000000 constant entry external dcl 1-361 packed_digits_per_character internal static fixed bin(31,0) initial dcl 11-5 parse_error 000000 constant entry external dcl 1-364 parse_error$no_text 000000 constant entry external dcl 1-368 pl1_error_print$listing_segment 000000 constant entry external dcl 1-384 pl1_error_print$write_out 000000 constant entry external dcl 1-372 pl1_print$string_pointer 000000 constant entry external dcl 1-406 pl1_print$string_pointer_nl 000000 constant entry external dcl 1-410 pl1_print$unaligned_nl 000000 constant entry external dcl 1-414 pl1_print$varying 000000 constant entry external dcl 1-392 pl1_stat_$xeq_tree_area_ptr external static pointer dcl 17-7 in procedure "create_token" pl1_stat_$xeq_tree_area_ptr external static pointer dcl 8-7 in procedure "lex" pointer_type internal static bit(36) initial dcl 11-71 real_type internal static bit(36) initial dcl 11-71 refer_extent 000000 constant entry external dcl 1-426 reference_node internal static bit(9) initial dcl 7-5 in procedure "lex" reference_node internal static bit(9) initial dcl 18-5 in procedure "create_token" reserve$clear 000000 constant entry external dcl 1-430 reserve$declare_lib 000000 constant entry external dcl 1-434 reserve$read_lib 000000 constant entry external dcl 1-439 semantic_translator 000000 constant entry external dcl 1-444 semantic_translator$abort 000000 constant entry external dcl 1-446 semantic_translator$error 000000 constant entry external dcl 1-450 sf_par_node internal static bit(9) initial dcl 7-5 in procedure "lex" sf_par_node internal static bit(9) initial dcl 18-5 in procedure "create_token" share_expression 000000 constant entry external dcl 1-454 source_node internal static bit(9) initial dcl 18-5 statement_node internal static bit(9) initial dcl 18-5 in procedure "create_token" statement_node internal static bit(9) initial dcl 7-5 in procedure "lex" storage_block_type internal static bit(36) initial dcl 11-71 symbol_node internal static bit(9) initial dcl 18-5 in procedure "create_token" symbol_node internal static bit(9) initial dcl 7-5 in procedure "lex" temporary_node internal static bit(9) initial dcl 7-5 in procedure "lex" temporary_node internal static bit(9) initial dcl 18-5 in procedure "create_token" token_node internal static bit(9) initial dcl 7-5 words_per_condition_var internal static fixed bin(31,0) initial dcl 11-5 words_per_entry_var internal static fixed bin(31,0) initial dcl 11-5 words_per_file_var internal static fixed bin(31,0) initial dcl 11-5 words_per_fix_bin_1 internal static fixed bin(31,0) initial dcl 11-5 words_per_fix_bin_2 internal static fixed bin(31,0) initial dcl 11-5 words_per_flt_bin_1 internal static fixed bin(31,0) initial dcl 11-5 words_per_flt_bin_2 internal static fixed bin(31,0) initial dcl 11-5 words_per_format internal static fixed bin(31,0) initial dcl 11-5 words_per_label_var internal static fixed bin(31,0) initial dcl 11-5 words_per_offset internal static fixed bin(31,0) initial dcl 11-5 words_per_packed_pointer internal static fixed bin(31,0) initial dcl 11-5 words_per_pointer internal static fixed bin(31,0) initial dcl 11-5 words_per_varying_string_header internal static fixed bin(31,0) initial dcl 11-5 xeq_tree_area based area(1024) dcl 17-5 in procedure "create_token" xeq_tree_area based area(1024) dcl 8-5 in procedure "lex" NAMES DECLARED BY EXPLICIT CONTEXT. action 000000 constant label array(23) dcl 263 ref 278 500 513 518 524 530 535 540 548 556 567 593 627 733 757 761 778 794 810 826 842 866 882 895 937 943 953 959 966 991 998 1013 1026 1084 check_syntax_after_constant 003060 constant label dcl 719 ref 465 create_source 006362 constant entry internal dcl 1237 ref 1021 1150 create_token 007457 constant entry internal dcl 15-3 ref 1468 1468 create_token$protected 007704 constant entry internal dcl 15-99 ref 1477 emit_semicolon 007003 constant entry internal dcl 1306 ref 1029 1062 1072 end_of_source_reached 004473 constant label dcl 1038 ref 302 325 461 475 562 606 617 641 650 712 739 785 801 817 833 849 873 1594 end_of_source_reached_but_no_pending_token 004474 constant label dcl 1041 ref 266 283 578 enter_source_segment 007112 constant entry internal dcl 1339 ref 1025 1078 1154 enter_token 007244 constant entry internal dcl 1408 ref 512 517 523 529 534 539 547 555 566 756 793 809 825 841 865 881 1482 error_376 003654 constant label dcl 916 ref 911 initialize_lex 004644 constant entry external dcl 1089 insert_token 007625 constant label dcl 15-83 ref 15-71 join 007474 constant label dcl 15-48 ref 15-103 lex 000567 constant entry external dcl 66 ref 1197 lex_error 007141 constant entry internal dcl 1368 ref 282 295 374 388 405 425 442 451 458 495 506 577 680 729 777 916 933 942 952 958 965 976 979 989 996 1011 1031 1043 1054 1061 1066 1274 1309 1326 1468 1500 1523 make_token 007327 constant entry internal dcl 1447 ref 464 479 626 715 1038 missing_exponent 007725 constant entry internal dcl 1494 ref 640 649 print_line 010010 constant entry internal dcl 1509 ref 312 584 759 print_line_at_eof 010073 constant entry internal dcl 1537 ref 1048 print_line_before_include 010147 constant entry internal dcl 1564 ref 511 rescan 000677 constant label dcl 291 ref 313 336 rescan_comment 002437 constant label dcl 574 ref 586 596 scan_fraction 002547 constant label dcl 614 ref 753 scan_past_digits 010212 constant entry internal dcl 1587 ref 609 620 654 terminate_source 006012 constant entry external dcl 1159 write_last_line 006055 constant entry external dcl 1170 NAME DECLARED BY CONTEXT OR IMPLICATION. before builtin function ref 1282 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 13030 13620 12422 13040 Length 14634 12422 570 777 406 460 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME lex 979 external procedure is an external procedure. create_source internal procedure shares stack frame of external procedure lex. emit_semicolon internal procedure shares stack frame of external procedure lex. enter_source_segment internal procedure shares stack frame of external procedure lex. lex_error internal procedure shares stack frame of external procedure lex. enter_token internal procedure shares stack frame of external procedure lex. make_token internal procedure shares stack frame of external procedure lex. create_token internal procedure shares stack frame of external procedure lex. missing_exponent internal procedure shares stack frame of external procedure lex. print_line internal procedure shares stack frame of external procedure lex. print_line_at_eof internal procedure shares stack frame of external procedure lex. print_line_before_include internal procedure shares stack frame of external procedure lex. scan_past_digits internal procedure shares stack frame of external procedure lex. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 file_token_ptr lex 000012 lexing_after_end_stmt lex 000013 line_begins_in_comment lex 000014 line_number lex 000015 line_start lex 000016 source_depth lex 000017 source_index lex 000020 source_length lex 000022 source_ptr lex 000024 statement_number lex 000025 suppress_line_numbers lex 000026 and_token_ptr lex 000027 arrow_token_ptr lex 000030 assignment_token_ptr lex 000031 asterisk_token_ptr lex 000032 cat_token_ptr lex 000033 colon_token_ptr lex 000034 comma_token_ptr lex 000035 expon_token_ptr lex 000036 ge_token_ptr lex 000037 gt_token_ptr lex 000040 le_token_ptr lex 000041 left_parn_token_ptr lex 000042 lt_token_ptr lex 000043 minus_token_ptr lex 000044 ne_token_ptr lex 000045 ngt_token_ptr lex 000046 nlt_token_ptr lex 000047 not_token_ptr lex 000050 or_token_ptr lex 000051 percent_token_ptr lex 000052 period_token_ptr lex 000053 plus_token_ptr lex 000054 right_parn_token_ptr lex 000055 semi_colon_token_ptr lex 000056 slash_token_ptr lex 000060 file_stack lex STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME lex 000100 action_index lex 000101 bitcount lex 000102 char_value lex 000103 code lex 000104 current_char lex 000105 depthx lex 000106 decimal_value lex 000107 dx lex 000110 error_number lex 000112 error_token lex 000114 first_bit lex 000115 float_value lex 000116 imaginary_value lex 000117 include_file_length lex 000120 include_file_name lex 000132 include_file_ptr lex 000134 integral_value lex 000135 k lex 000136 line_length lex 000137 listing_on lex 000140 max_in_chars lex 000141 n lex 000142 new_file_number lex 000144 new_file_token_ptr lex 000146 page_macro lex 000147 parenthesis_level lex 000150 percent_sign_seen lex 000151 protected lex 000152 radix lex 000153 rep_factor lex 000154 saved_token_index lex 000155 scan_index lex 000156 string_max lex 000157 string_token_start lex 000160 strx lex 000161 temp_token_string lex 000262 token_index lex 000263 token_length lex 000264 token_ptr lex 000265 token_start lex 000266 token_string lex 000370 token_string_ptr lex 000372 token_type lex 000373 m lex 000374 token_list_pointer lex 000376 source_info lex 000472 line_id lex 000476 five_digits lex 000500 three_digits lex 000514 cname create_source 000524 dname create_source 000624 dtm create_source 000626 ename create_source 000636 include_path create_source 000737 uid create_source 000762 statement_length lex_error 001000 token_ptr make_token 001010 hash_index create_token 001011 i create_token 001012 n create_token 001013 n_chars create_token 001014 n_words create_token 001015 mod_2_sum create_token 001016 four_chars create_token 001017 protected create_token 001020 old_q create_token 001022 q create_token 001024 p create_token 001026 token_string_ptr create_token THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_char_temp cat_realloc_chars call_ext_in call_ext_out_desc call_ext_out return_mac mdfx1 shorten_stack ext_entry set_chars_eis verify_eis any_to_any_truncate_ op_alloc_ index_before_cs THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. com_err_ constant_token create_token create_token$init_hash_table date_time_ error_ find_include_file_$initiate_count hcs_$terminate_noname pl1_print$for_lex pl1_print$non_varying pl1_print$non_varying_nl pl1_print$varying_nl token_to_binary translator_info_$component_get_source_info THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. pl1_stat_$cur_statement pl1_stat_$hash_table_ptr pl1_stat_$last_source pl1_stat_$level_0_colon pl1_stat_$level_0_equal pl1_stat_$line_count pl1_stat_$listing_on pl1_stat_$node_uses pl1_stat_$node_uses pl1_stat_$seg_name pl1_stat_$source_list_ptr pl1_stat_$source_seg pl1_stat_$st_length pl1_stat_$st_start pl1_stat_$statement_id pl1_stat_$token_list_ptr pl1_stat_$tree_area_ptr pl1_stat_$tree_area_ptr LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 13 3 000556 66 000564 255 000575 256 000576 257 000577 258 000602 259 000603 260 000604 261 000605 263 000606 266 000630 269 000631 270 000632 271 000637 273 000642 275 000647 278 000651 280 000652 282 000656 283 000670 286 000671 287 000672 288 000674 289 000675 291 000677 294 000721 295 000722 297 000734 299 000762 302 000767 305 000770 306 000776 308 001013 311 001015 312 001017 313 001020 318 001021 320 001041 323 001045 325 001047 328 001052 329 001060 330 001062 331 001073 334 001074 335 001103 336 001104 338 001105 339 001107 340 001111 342 001112 343 001115 345 001126 347 001131 349 001133 350 001134 353 001136 354 001140 355 001151 356 001152 357 001153 363 001160 366 001201 368 001204 371 001205 373 001215 374 001253 375 001260 376 001262 377 001267 378 001270 379 001273 380 001276 382 001277 384 001301 385 001305 388 001363 391 001370 392 001377 393 001415 394 001435 395 001437 396 001440 400 001445 403 001466 405 001470 409 001536 411 001553 412 001555 413 001570 414 001571 415 001572 418 001577 420 001605 423 001607 424 001616 425 001655 427 001662 430 001665 431 001666 432 001675 433 001707 437 001711 438 001714 440 001717 441 001721 442 001760 445 001765 446 001774 447 001775 449 002002 450 002004 451 002035 453 002042 455 002043 457 002046 458 002050 459 002105 461 002106 464 002112 465 002113 467 002114 469 002116 471 002122 473 002143 474 002144 475 002147 478 002150 479 002153 483 002154 484 002163 485 002166 487 002167 489 002174 492 002176 493 002200 495 002205 500 002226 504 002230 506 002234 509 002244 510 002246 511 002250 512 002251 513 002260 515 002261 517 002265 518 002273 520 002274 522 002300 523 002301 524 002307 526 002310 528 002314 529 002316 530 002324 532 002325 534 002331 535 002337 537 002340 539 002344 540 002352 542 002353 544 002357 547 002363 548 002371 550 002372 552 002376 555 002402 556 002410 558 002411 560 002415 562 002417 565 002422 566 002427 567 002435 572 002436 574 002437 576 002461 577 002462 578 002474 581 002475 583 002476 584 002503 585 002504 586 002507 591 002510 592 002514 593 002515 596 002516 598 002517 600 002523 601 002525 602 002527 603 002530 604 002531 606 002533 609 002536 611 002537 612 002546 614 002547 617 002551 620 002554 621 002555 622 002556 624 002566 625 002570 626 002572 627 002573 630 002574 632 002600 633 002612 636 002616 637 002617 639 002620 640 002623 641 002624 644 002625 646 002635 648 002636 649 002641 650 002642 654 002643 657 002644 658 002653 659 002654 660 002656 663 002657 665 002666 666 002667 669 002671 671 002700 672 002702 675 002703 677 002721 680 002753 685 002760 686 002762 688 002776 691 003007 692 003011 699 003012 700 003017 702 003026 705 003032 706 003042 708 003043 712 003054 715 003057 719 003060 721 003067 722 003072 724 003073 726 003100 729 003102 733 003125 735 003127 737 003133 739 003135 742 003140 744 003145 746 003150 748 003155 749 003157 750 003161 751 003162 752 003163 753 003164 756 003165 757 003173 759 003174 761 003175 763 003176 765 003203 766 003205 767 003251 768 003252 769 003257 770 003261 771 003263 773 003264 774 003266 777 003310 778 003312 780 003313 782 003317 783 003321 785 003323 788 003326 789 003333 790 003334 793 003336 794 003340 796 003341 798 003345 799 003347 801 003351 804 003354 805 003361 806 003362 809 003364 810 003366 812 003367 814 003373 815 003375 817 003377 820 003402 821 003407 822 003410 825 003412 826 003414 828 003415 830 003421 831 003423 833 003425 836 003430 837 003435 838 003436 841 003440 842 003442 844 003443 846 003447 847 003451 849 003453 852 003456 853 003465 854 003466 855 003470 856 003471 857 003473 858 003474 859 003476 860 003477 861 003501 862 003502 865 003504 866 003506 868 003507 870 003513 871 003515 873 003517 876 003522 877 003527 878 003530 881 003532 882 003534 884 003535 887 003541 888 003543 889 003544 890 003546 891 003550 893 003553 894 003564 895 003566 898 003567 900 003570 901 003605 903 003614 906 003615 909 003623 911 003624 914 003631 916 003654 918 003662 919 003664 920 003666 922 003667 923 003701 927 003703 930 003735 933 003763 936 003775 937 003777 940 004000 941 004004 942 004006 943 004014 946 004015 948 004016 951 004044 952 004046 953 004054 956 004055 957 004060 958 004062 959 004070 962 004071 964 004073 965 004076 966 004110 969 004111 970 004123 972 004153 975 004220 976 004225 979 004256 983 004262 984 004263 987 004314 988 004320 989 004330 991 004334 994 004335 995 004340 996 004350 998 004354 1001 004355 1002 004360 1003 004362 1004 004365 1005 004367 1006 004371 1008 004373 1009 004401 1010 004410 1011 004420 1013 004424 1015 004425 1019 004427 1020 004431 1021 004435 1025 004455 1026 004457 1029 004460 1031 004461 1034 004472 1038 004473 1041 004474 1043 004476 1044 004504 1045 004505 1048 004507 1050 004510 1052 004513 1053 004515 1054 004517 1057 004527 1060 004530 1061 004532 1062 004540 1063 004541 1066 004542 1068 004550 1070 004554 1072 004602 1073 004603 1074 004605 1077 004606 1078 004610 1081 004626 1082 004634 1083 004635 1084 004637 1089 004640 1103 004652 1107 004657 1109 004662 1110 004663 1111 004664 1115 004665 1116 004712 1117 004737 1118 004764 1119 005011 1120 005036 1121 005063 1122 005110 1123 005135 1124 005162 1125 005207 1126 005234 1127 005261 1128 005306 1129 005333 1130 005360 1131 005405 1132 005432 1133 005457 1134 005504 1135 005531 1136 005556 1137 005603 1138 005630 1139 005655 1141 005702 1142 005703 1143 005705 1144 005707 1146 005710 1150 005747 1154 005773 1155 006010 1159 006011 1162 006020 1163 006027 1164 006030 1165 006046 1166 006052 1170 006053 1196 006063 1197 006066 1199 006075 1201 006100 1204 006101 1206 006111 1207 006121 1209 006124 1212 006140 1214 006152 1215 006207 1217 006210 1219 006224 1221 006257 1222 006270 1224 006274 1225 006313 1226 006325 1227 006333 1228 006337 1229 006357 1230 006361 1237 006362 1272 006364 1273 006424 1274 006426 1275 006441 1277 006465 1278 006467 1279 006471 1280 006472 1282 006555 1285 006672 1287 006675 1289 006700 1290 006704 1291 006727 1292 006731 1293 006735 1294 006740 1295 006745 1296 006754 1297 006764 1298 006774 1299 006776 1300 007000 1306 007003 1309 007004 1311 007016 1314 007017 1316 007025 1317 007030 1318 007037 1319 007047 1320 007057 1323 007062 1325 007063 1326 007067 1327 007075 1330 007100 1332 007107 1333 007111 1339 007112 1353 007114 1354 007120 1355 007122 1356 007124 1357 007127 1358 007131 1359 007133 1360 007135 1361 007137 1362 007140 1368 007141 1384 007143 1385 007153 1386 007163 1388 007173 1389 007176 1391 007201 1393 007206 1395 007211 1396 007212 1399 007216 1401 007243 1408 007244 1417 007246 1420 007252 1422 007263 1423 007266 1424 007276 1425 007306 1427 007316 1430 007324 1434 007326 1447 007327 1456 007330 1459 007340 1460 007342 1463 007350 1466 007355 1467 007360 1468 007362 1470 007410 1472 007411 1474 007415 1475 007417 1477 007420 1480 007453 1482 007454 1483 007456 15 3 007457 15 46 007473 15 48 007474 15 51 007477 15 52 007501 15 53 007503 15 54 007510 15 56 007511 15 57 007521 15 58 007526 15 59 007530 15 61 007532 15 63 007534 15 64 007543 15 67 007545 15 68 007552 15 70 007554 15 71 007566 15 74 007572 15 80 007621 15 81 007622 15 83 007625 15 86 007630 15 87 007644 15 88 007646 15 89 007652 15 90 007654 15 91 007657 15 92 007665 15 94 007667 15 96 007700 15 97 007702 15 99 007704 15 102 007720 15 103 007724 1494 007725 1497 007726 1498 007742 1499 007751 1500 007752 1502 010006 1509 010010 1512 010011 1514 010015 1518 010043 1519 010046 1521 010047 1523 010055 1524 010063 1527 010066 1528 010070 1529 010071 1530 010072 1537 010073 1540 010074 1542 010100 1545 010102 1549 010130 1551 010132 1552 010140 1553 010141 1554 010143 1555 010144 1558 010146 1564 010147 1567 010150 1569 010155 1570 010156 1574 010204 1575 010207 1578 010210 1579 010211 1587 010212 1590 010213 1592 010235 1593 010236 1594 010241 1596 010242 1598 010245 ----------------------------------------------------------- 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