COMPILATION LISTING OF SEGMENT reduction_compiler_ Compiled by: Multics PL/I Compiler, Release 28e, of February 14, 1985 Compiled at: Honeywell Multics Op. - System M Compiled on: 03/17/86 1454.3 mst Mon Options: optimize map 1 2 3 /* * * * * * * * * * * * * * * * * * * * * * * */ 4 /* */ 5 /* COMPILED OUTPUT OF SEGMENT reduction_compiler_.rd */ 6 /* Compiled by: reduction_compiler, Version 2.5 of Oct 21, 1985 */ 7 /* Compiled on: 03/17/86 1454.2 mst Mon */ 8 /* */ 9 /* * * * * * * * * * * * * * * * * * * * * * * */ 10 11 /* *************************************************************** 12* * * 13* * Copyright (c) 1986 by Massachusetts Institute of Technology * 14* * * 15* * Copyright (c) 1975 by Massachusetts Institute of Technology * 16* * * 17* *************************************************************** */ 18 19 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 20 /* */ 21 /* N__a_m_e: reduction_compiler_ */ 22 /* */ 23 /* This procedure is the subroutine interface for the reduction_compiler. It */ 24 /* accepts as input a set of reductions, a temporary segment for use in allocations */ 25 /* of a temporary nature, and a pointer to and maximum length of the object segment to */ 26 /* be generated. It returns the actual length of the compiled object segment. */ 27 /* The reductions to be compiled have been pre-processed by the lex_string_ */ 28 /* subroutine, and are represented by a chain of input tokens. */ 29 /* This subroutine is, itself, driven by a set of reductions which were compiled */ 30 /* by a bootstrapped version of the reduction_compiler. */ 31 /* */ 32 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 33 34 35 /* HISTORY COMMENTS: 36* 1) change(74-04-05,GDixon), approve(), audit(), 37* install(86-03-17,MR12.0-1032): 38* Version 1.0-- 39* Created the reduction_compiler (rdc) command. 40* 2) change(74-05-06,GDixon), approve(), audit(), 41* install(86-03-17,MR12.0-1032): 42* Version 1.1-- 43* Fixed bugs in initial version. 44* 3) change(74-05-17,GDixon), approve(), audit(), 45* install(86-03-17,MR12.0-1032): 46* Version 1.2-- 47* Changed the following rdc constructs: 48* a) STACK-POP ==> STACK_POP 49* b) (PL/I-stmt) ==> [PL/I-stmt] for semantic statements. 50* 4) change(75-01-30,GDixon), approve(), audit(), 51* install(86-03-17,MR12.0-1032): 52* Version 1.3-- 53* Make relative syntax functions quick PL/I blocks by converting array of 54* entries into relative syntax functions into a label transfer vector into 55* calls to the relative syntax functions. 56* 5) change(75-02-03,GDixon), approve(), audit(), 57* install(86-03-17,MR12.0-1032): 58* Version 2.0-- 59* a) code generated for LEX converted to calls to a subroutine LEX(n). 60* b) new DELETE and DELETE_STMT built-in action routines added. 61* c) new INCLUDE attribute added to force inclusion of include segments. 62* d) code for PUSH DOWN LANGUAGE added but not documented. 63* e) allocate statements changed to calls to translator_temp_$allocate. 64* 65* 6) change(75-04-28,GDixon), approve(), audit(), 66* install(86-03-17,MR12.0-1032): 67* Version 2.1-- 68* a) put a space after all tokens in semantic statement brackets ([]), 69* except tokens, and the following paired token 70* sequences: 71* < = 72* > = 73* ^ = 74* ^ > 75* ^ < 76* - > 77* b) In order to implement this change, four new break characters were 78* added: - ^ = ; 79* c) Commenting delimiters were added: \" begins a comment, which ends 80* with a newline character. 81* 7) change(81-02-16,GDixon), approve(), audit(), 82* install(86-03-17,MR12.0-1032): 83* Version 2.2-- 84* a) INCLUDE LEX stmt added, because of 85* b) code added to detect only use of LEX (rather than LEX(N)). 86* If only LEX used, then the LEX subroutine is NOT included in 87* SEMANTIC_ANALYSIS by default. 88* c) Many data structures declared options(constant) 89* d) VT now acccpted in .rd segments as a whitespace character 90* e) in a PUSH DOWN LANGUAGE checks to see if token on top of 91* push down stack is the final input token (ie, all tokens are on the 92* stack or have been deleted. 93* f) Add code to support rdc's -trace control argument. 94* 8) change(83-07-23,GDixon), approve(), audit(), 95* install(86-03-17,MR12.0-1032): 96* Version 2.3-- 97* a) Place sequence numbers in unlabeled reductions appearing in the .pl1 98* and .list segments. The same numbers are placed in the reductions 99* printed during tracing. 100* b) Changed implementation of -trace to avoid temporary copying of 101* reduction source. Instead, reduction source is extracted from the 102* stmt descriptors. 103* 9) change(84-09-08,GDixon), approve(), audit(), 104* install(86-03-17,MR12.0-1032): 105* Version 2.4-- 106* a) Allow ERROR (named_constant) in addition to ERROR (decimal_integer) 107* b) Use perprocess date_time format for date put in header comment of 108* translator. 109* 10) change(85-10-21,GDixon), approve(86-02-06,MCR7339), 110* audit(86-02-19,Wallman), install(86-02-19,MR12.0-1022): 111* Version 2.5-- 112* Upgrade the severity of several error messages to severity 3, because 113* these messages describe conditions which are likely to make PL/I 114* compilation fail. Severity 3 errors prevent the PL/I compiler from 115* being invoked. (phx19850) 116* END HISTORY COMMENTS */ 117 118 119 120 /*++ 121*MAX_DEPTH 20 \ 122* 123*BEGIN / / ERROR(1) / stop \ 124*2 / / reductions_init / attributes \ 125* 126*attributes 127*3 \" 1) parse and process the reduction attributes. If present, these must precede any 128* \" reduction statements. 129* / BEGIN / [Psave = Pthis_token] / pass1 \ 130*4 / MAX_DEPTH "\" / LEX set_depth LEX(2) / attributes \ 131*5 / PUSH DOWN LANGUAGE "\" / LEX(4) [S_PDL = "1"b] / attributes \ 132*6 / INCLUDE DELETE "\" / LEX(3) [Sinclude_DELETE = "1"b] / attributes \ 133*7 / INCLUDE DELETE_STMT "\" / LEX(3) [Sinclude_DELETE_STMT = "1"b] / attributes \ 134*8 / INCLUDE ERROR "\" / LEX(3) [Sinclude_ERROR = "1"b] / attributes \ 135*9 / INCLUDE NEXT_STMT "\" / LEX(3) [Sinclude_NEXT_STMT = "1"b] / attributes \ 136*10 / INCLUDE LEX "\" / LEX(3) [Sinclude_LEX = "1"b] / attributes \ 137*11 / INCLUDE / ERROR(19) NEXT_STMT / attributes \ 138*12 / / ERROR(1) / stop \ 139*13 / / ERROR(2) NEXT_STMT / attributes \ 140* 141*pass1 \" 1) create a symbol table giving name and reduction number for all reduction labels. 142* \" 2) count the tokens in the syntax specification field to get an estimate of the amount 143* \" of temporary storage rdc will need to hold the syntax specifications. 144*set_label / /_ / count_reduction LEX / count \ 145*15 / / set_label LEX / set_label \ 146*16 / "\" / ERROR(22) LEX / set_label \ 147*17 / / reductions_begin [Pthis_token = Psave] / pass2 \ 148*18 / / ERROR(3) LEX / set_label \ 149* 150*count / / count_token(1) LEX(1) / count \ 151*20 / /_ _ / count_token(1) LEX(3) / count \ 152*21 / /_ / NEXT_STMT / set_label \ 153*22 / / count_token(1) LEX / count \ 154*23 / / ERROR(5) / stop \ 155* 156*pass2 \" Process the reduction statements, as follows: 157* \" 1) skip over any labels on the reduction statement. 158* \" 2) compile the syntax specifications by storing them in rdc's temporary syntax table. 159* \" 3) compile the action specifications by outputting calls to built-in action routines and 160* \" semantic subroutines, and by outputting semantic statements. 161* \" 4) compile the next reduction field by outputting code to transfer to the appropriate reduction. 162*label 163*skip_label 164* / /_ / reduction_begin LEX / first_token \ 165*25 / / LEX / skip_label \ 166*26 / "\" / LEX / skip_label \ 167*27 / / LEX / skip_label \ 168*28 / / / stop \ 169* 170*first_token 171*29 / / / token1 \ 172* \" For a non-PUSH DOWN LANGUAGE, followed by any syntax specification is in error 173* \" because tokens are checked from left to right; for a PUSH DOWN LANGUAGE, has 174* \" meaning as the first or last specification in a reduction. As the first spec, it identifies 175* \" the bottom of the push-down stack. As the last spec, it identifies when the list of input tokens 176* \" has run out. 177*30 / / / tokens \ 178* 179*token1 / / / tokens \ 180*32 / <_ no - token >_ / compile_token(1) LEX(5) / tokens \ 181* 182*tokens / / compile_token(0) LEX / tokens \ 183*34 / /_ _ / compile_token(0) LEX(3) / tokens \ 184*35 / /_ / LEX action_begin / action \ 185*36 / < _ / compile_token(0) LEX(3) / tokens \ 186*37 / > _ / compile_token(0) LEX(3) / tokens \ 187*38 / [ _ / compile_token(0) LEX(3) / tokens \ 188*39 / ] _ / compile_token(0) LEX(3) / tokens \ 189*40 / ( _ / compile_token(0) LEX(3) / tokens \ 190*41 / ) _ / compile_token(0) LEX(3) / tokens \ 191*42 / <_ no - token >_ /_ / compile_token(1) LEX(6) action_begin / action \ 192*43 / <_ no - token >_ / LEX(5) ERROR(14) / error_in_red \ 193*44 / <_ any - token >_ / compile_token(2) LEX(5) / tokens \ 194*45 / <_ name >_ / compile_token(3) LEX(3) / tokens \ 195*46 / <_ decimal - integer >_ / compile_token(4) LEX(5) / tokens \ 196*47 / <_ BS >_ / compile_token(5) LEX(3) / tokens \ 197*48 / <_ quoted - string >_ / compile_token(6) LEX(5) / tokens \ 198*49 / <_ >_ / LEX 199* compile_token(7) LEX(2) / tokens \ 200*50 / "\" / LEX ERROR(22) / label \ 201*51 / / compile_token(0) LEX / tokens \ 202*52 / / ERROR(5) / stop \ 203* 204*action / /_ / LEX / next_red \ 205*54 / LEX ( ) / set_action_with_args LEX(2) PUSH(last_paren) 206* [Sinclude_LEX = "1"b] / args \ 207*55 / LEX ( - ) / set_action_with_args LEX(2) PUSH(last_paren) 208* [Sinclude_LEX = "1"b] / args \ 209*56 / LEX ( + ) / set_action_with_args LEX(2) PUSH(last_paren) 210* [Sinclude_LEX = "1"b] / args \ 211*57 / LEX ( / ERROR(19) / error_in_red \ 212*58 / LEX / rtn(1) LEX / action \ 213*59 / NEXT_STMT ( / ERROR(19) / error_in_red \ 214*60 / NEXT_STMT / set_action LEX 215* [Sinclude_NEXT_STMT = "1"b] / action \ 216*61 / POP ( / ERROR(19) / error_in_red \ 217*62 / POP / rtn(2) LEX / action \ 218*63 / PUSH ( ) / LEX(2) rtn(3) LEX(2) / action \ 219*64 / PUSH / ERROR(19) / error_in_red \ 220*65 / DELETE / / DELETE \ 221* \" Remove tests for all of the DELETE cases from main stream of reductions to a subroutine. 222*66 / DELETE_STMT ( / ERROR(19) / error_in_red \ 223*67 / DELETE_STMT / set_action LEX 224* [Sinclude_DELETE_STMT = "1"b] / action \ 225*68 / ERROR ( ) / set_action_with_args LEX(2) 226* [Sinclude_ERROR = "1"b] PUSH(last_paren) / args \ 227*69 / ERROR ( / set_action_with_args LEX(2) 228* [Sinclude_ERROR = "1"b] PUSH(last_paren) / args \ 229* \" The preceding reduction allows the builtin ERROR routine to accept 230* \" a named constant instead of a decimal integer. 231*70 / [ / output((6)" " || (4)" ") 232* LEX / stmt \ 233*71 / ] / ERROR(21) LEX / action \ 234*72 / ( / ERROR(21) LEX / action \ 235*73 / ) / ERROR(21) LEX / action \ 236*74 / / ERROR(23) / error_in_red \ 237*75 / "\" / ERROR(22) / error_in_red \ 238*76 / ( / set_action_with_args LEX(2) PUSH(last_paren) / args \ 239*77 / / set_action LEX / action \ 240*78 / / ERROR(5) / stop \ 241* 242*error_in_red 243*79 / / [obj_red.Ilast(Nobj_red) = 0] 244* reduction_end NEXT_STMT / label \ 245* 246*DELETE / DELETE ( , ) / / DELETE_2 \ 247*81 / DELETE ( , - ) / / DELETE_2 \ 248*82 / DELETE ( , + ) / / DELETE_2 \ 249*83 / DELETE ( - , ) / / DELETE_2 \ 250*84 / DELETE ( - , - ) / / DELETE_2 \ 251*85 / DELETE ( - , + ) / / DELETE_2 \ 252*86 / DELETE ( + , ) / / DELETE_2 \ 253*87 / DELETE ( + , - ) / / DELETE_2 \ 254*88 / DELETE ( + , + ) / / DELETE_2 \ 255*89 / DELETE ( ) / / DELETE_1 \ 256*90 / DELETE ( - ) / / DELETE_1 \ 257*91 / DELETE ( + ) / / DELETE_1 \ 258* 259*92 / DELETE ( / ERROR(19) / error_in_red \ 260*93 / DELETE / set_action_with_args LEX output(" 0, 0 )") 261* [Sinclude_DELETE = "1"b] / last_paren\ 262* \" The only way to reach the next reduction is by branch. All possible cases of DELETE 263* \" have been handled above, including illegal ones. 264* 265*DELETE_1 / / set_action_with_args LEX(2) 266* [Sinclude_DELETE = "1"b] / \ 267*95 / / output(" ") output(token_value) LEX 268* output(token_value) LEX(-1) 269* output(",") PUSH(last_paren) / args \ 270*96 / / output(" ") output(token_value) 271* output(",") PUSH(last_paren) / args \ 272* 273*DELETE_2 / / set_action_with_args LEX(2) PUSH(last_paren) 274* [Sinclude_DELETE = "1"b] / args \ 275* 276*stmt \" Process the contents of semantic statements. Special attention is given when generating 277* \" PL/I code for the statements to the following cases: 278* \" 1) No space is placed between the last token of a semantic statement and its 279* \" ending semi-colon statement delimiter. 280* \" 2) No space is placed between an argument in a subprogram call and any comma delimiter 281* \" which may follow it. 282* \" 3) No space is placed between a quoted string and any b, b1, b2, b3 or b4 283* \" token which follows it in order to handle bit string constants (eg "101"b) 284* \" 4) No space is placed between any of the following pairs of characters which 285* \" have a special meaning in the PL/I language: -> >= <= ^= ^> ^< 286* \" 5) No space is placed between any minus sign (-) and the token which follows, in 287* \" order to handle signed numeric constants. 288* \" 6) Semantic statements appearing in the same pair of brackets in an action specification 289* \" are placed on different lines in the generated code (as if they had appeared in 290* \" separate brackets). 291* / b / / bit_constant \ 292*99 / b1 / / bit_constant \ 293*100 / b2 / / bit_constant \ 294*101 / b3 / / bit_constant \ 295*102 / b4 / / bit_constant \ 296*103 / / output(" ") output_quote(token_value) LEX / \ 297*104 / ( / output(" ") output("(") PUSH(stmt) LEX / args \ 298*105 / ] / LEX / last_paren \ 299*106 / ; / output (";" || NL || (6)" " || (4)" ") 300* LEX / stmt \ 301*107 / "\" / ERROR(24) / error_in_red \ 302*108 / / PUSH(stmt) PUSH(stmt1) / special_chars \ 303* \" Always branch to special subroutine to check for paired character sequences. 304* \" This subroutine returns to the 1st PUSHed label if a paired character sequence 305* \" is found, and to the second PUSHed label if no paired sequence is found. 306*stmt1 / / POP / \ 307*110 / / output(" ") output(token_value) LEX / stmt \ 308*111 / / ERROR(5) / stop \ 309* 310*bit_constant 311*112 / / output(" ") output_quote(token_value) LEX 312* output(token_value) LEX / stmt \ 313* 314* 315*args \" This reduction subroutine processed the arguments in calls to semantic subroutines, and 316* \" the parenthesized expression or sub-program arguments in semantic statements. It handles 317* \" the special cases described above under "stmt". Nested parentheses are handled to a 318* \" depth of about 17. It returns to the last PUSHed reduction label. 319* / ( / / quoted_arg \ 320*114 / "\" / / quoted_arg \ 321*115 / ) / / quoted_arg \ 322*116 / / output(" ") output_quote(token_value) LEX 323* output(token_value) LEX / args \ 324*quoted_arg 325*117 / / output(" ") output_quote(token_value) LEX / \ 326*118 / ( / output(" ") output("(") PUSH(args) LEX / args \ 327*119 / ) / output(" ") output(")") LEX / STACK_POP \ 328*120 / ; / ERROR(24) / error_in_red \ 329*121 / "\" / ERROR(24) / error_in_red \ 330*122 / / PUSH(args) PUSH(args1) / special_chars \ 331* \" Always branch to special subroutine to check for paired character sequences. 332* \" This subroutine returns to the 1st PUSHed label if a paired character sequence 333* \" is found, and to the second PUSHed label if no paired sequence is found. 334*args1 / / POP / \ 335*124 / , / output(token_value) LEX / args \ 336*125 / / output(" ") output(token_value) LEX / args \ 337*126 / / ERROR(5) / stop \ 338* 339*last_paren/ / output(";") output(NL) / action \ 340* 341*special_chars 342*128 \" Special reduction subroutine to check for paired character sequences in action specifications. 343* \" Calling sequence is: / / PUSH(label1) PUSH(label2) / special_chars \ 344* \" label2/ / POP / \ 345* \" This subroutine returns through the first PUSHed reduction label if a paired sequence 346* \" is found, and through the second PUSHed label if none if found. 347* / < = / / spec_found \ 348*129 / > = / / spec_found \ 349*130 / ^ = / / spec_found \ 350*131 / ^ > / / spec_found \ 351*132 / ^ < / / spec_found \ 352*133 / - > / / spec_found \ 353*134 / - / / spec_found \ 354*135 / + / / spec_found\ 355*136 / / / STACK_POP \ 356* 357*spec_found 358*137 / / output(" ") output(token_value) LEX 359* output(token_value) LEX POP / STACK_POP \ 360* 361*next_red \" The final group of reductions identifies and compiles code for the various next 362* \" reduction fields of a reduction statement. 363* / "\" / next_reduction reduction_end LEX / label \ 364*139 / RETURN "\" / terminal_reduction reduction_end LEX(2) / label \ 365*140 / STACK "\" / stacked_reduction reduction_end LEX(2) / label \ 366*141 / STACK_POP "\" / stacked_reduction_pop reduction_end LEX(2) / label \ 367*142 / "\" / specified_label reduction_end LEX(2) / label \ 368*143 / / specified_label reduction_end 369* ERROR(16) NEXT_STMT / label \ 370*144 / "\" / next_reduction reduction_end 371* ERROR(4) NEXT_STMT / label \ 372*145 / / next_reduction reduction_end 373* ERROR(15) NEXT_STMT / label \ 374*146 / / ERROR(5) / stop \ 375* 376*stop / / reductions_end / RETURN \ 377*148 / / reductions_end ERROR(6) / RETURN \ 378* ++*/ 379 380 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 381 382 383 reduction_compiler_: 384 proc (Psource, Lsource, Psegment, APobj, ALobj, Aname_source, Scontrol, Mseverity, Acode); 385 386 dcl Psource ptr, /* ptr to reduction source segment. (In) */ 387 Lsource fixed bin(21), /* length of reduction source segment (in chars). */ 388 /* (Input) */ 389 Psegment ptr, /* ptr to a segment in which allocations */ 390 /* may be performed. The segment must be a temp */ 391 /* segment provided by translator_temp_. (In) */ 392 APobj ptr, /* ptr to words of the object segment. (In) */ 393 ALobj fixed bin(21), /* maximum number of characters allowed in object */ 394 /* segment. (In) */ 395 /* number of words in constructed object segment. */ 396 /* (Out) */ 397 Aname_source char(32), /* entry name of input source segment. (In) */ 398 Scontrol bit(*), /* error format control bits. (In) */ 399 Mseverity fixed bin(35), /* severity of highest-severity error encountered */ 400 /* during the compilation. (Out) */ 401 Acode fixed bin(35); /* error code. (Out) */ 402 403 dcl /* automatic variables */ 404 (Ired_start, Ired_end) fixed bin(21), /* index into source of start/end of reductions. */ 405 Llongest_red fixed bin, /* length (in chars) of longest reduction. */ 406 Lobj fixed bin(21), /* length (in chars) of unused part of object */ 407 /* segment being created. */ 408 Lobj_part fixed bin(21) init (0), 409 /* length of a subset of the object segment. */ 410 Lobj_spaces fixed bin, /* number of spaces to be output into object seg. */ 411 Lobj_string fixed bin, /* maximum length of the string containing the */ 412 /* stored object token values. */ 413 Lobj_string_part fixed bin(21), /* length of a particular token value within the */ 414 /* string of all object token values. */ 415 Ltemp fixed bin(21), /* length of temporary character string. */ 416 Ltemp_obj fixed bin(21), /* length of temp copy of object segment contents.*/ 417 Mstack_depth fixed bin, /* user-specified maximum depth of the */ 418 /* next-reduction-label stack. */ 419 Nchar pic "----9" aligned,/* convert fixed bin integers to 4-char numbers. */ 420 Nobj_red fixed bin, /* index of the object reduction being compiled. */ 421 Nobj_token fixed bin, /* index of the object token being compiled. */ 422 Nobj_token_fcn fixed bin, /* index of the object token function being */ 423 /* compiled. */ 424 Nreductions fixed bin, /* number of reductions which can be stored in */ 425 /* object reduction storage structure. */ 426 Ntokens fixed bin, /* number of token requirements which can be */ 427 /* stored in object token storage structure. */ 428 Osc_start fixed bin(21), /* char offset of start of source to be output. */ 429 Pobj ptr, /* ptr to unused part of object segment. */ 430 Pobj_red ptr, /* ptr to temp. storage structure for object */ 431 /* reductions. */ 432 Pobj_spaces ptr, /* ptr to adjustable-length string of spaces. */ 433 Pobj_string ptr, /* ptr to temp. storage string for object token */ 434 /* values. */ 435 Pobj_string_part ptr, /* ptr to a particular token value within the */ 436 /* string of all object token values. */ 437 Pobj_token ptr, /* ptr to temp. storage structure for object */ 438 /* token requirements. */ 439 Pobj_token_quoted ptr, /* ptr to temp. storage for bits which are on if */ 440 /* object token was in quotes when input. */ 441 Psave ptr, /* ptr used in saving/restoring value of */ 442 /* Pthis_token between pass1 and pass2. */ 443 Ptemp ptr, /* ptr to temporary character string. */ 444 Ptemp_obj ptr, /* ptr to temp copy of object segment contents. */ 445 S_PDL bit(1) aligned, /* on if to be in 'PUSH DOWN LANGUAGE' mode. */ 446 S_TRACE bit(1) aligned, /* on if tracing code is to be generated. */ 447 S_TRACE_ON bit(1) aligned, /* on if tracing to be on initially. */ 448 Sinclude_DELETE bit(1) aligned, /* on if DELETE proc to be included in object seg.*/ 449 Sinclude_DELETE_STMT bit(1) aligned, /* on if DELETE_STMT proc to be included in obj. */ 450 Sinclude_ERROR bit(1) aligned, /* on if ERROR proc to be include in object seg. */ 451 Sinclude_NEXT_STMT bit(1) aligned, /* on if NEXT_STMT proc to be included. */ 452 Sinclude_LEX bit(1) aligned, /* on if LEX proc to be included. */ 453 Sinclude_STACK bit(1) aligned, /* on if STACK procs to be included in obj seg. */ 454 Soptimize_possible bit(1) aligned, /* on if optimization of object token storage */ 455 /* allocation is possible for the tokens assoc. */ 456 /* with the reduction being compiled. */ 457 code fixed bin(35), /* a status code. */ 458 date char(53), /* a date/time string. */ 459 form fixed bin, /* form of an object token. */ 460 i fixed bin, /* an integer temporary. */ 461 j fixed bin, /* an integer temporary. */ 462 name_source char(32), /* name of source segment, without its suffix. */ 463 1 obj_label aligned, /* temp storage for labels on object reductions. */ 464 2 N fixed bin, /* number of labels currently defined. */ 465 2 set (1000), /* space for up to 1000 labels. */ 466 3 name char(32) aligned, /* name of label. */ 467 3 reduction_no fixed bin, /* number of reduction labelled by this label. */ 468 1 obj_token_fcn aligned, /* temp storage for relative token requirement */ 469 /* functions. */ 470 2 N fixed bin, /* number of object token requirements defined. */ 471 2 name (100) char(32) varying, /* name of token requirement. */ 472 type fixed bin; /* type of an object token. */ 473 474 475 dcl /* builtin functions */ 476 (addcharno, addr, addrel, bit, char, charno, dimension, divide, 477 fixed, index, length, log, ltrim, max, min, null, rtrim, 478 size, string, substr, verify) 479 builtin; 480 481 dcl /* entries */ 482 clock_ entry returns (fixed bin(71)), 483 date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var), 484 lex_error_ entry options (variable), 485 lex_string_$lex entry (ptr, fixed bin(21), fixed bin(21), ptr, bit(*) aligned, 486 char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned, 487 char(*) aligned, char(*) varying aligned, char(*) varying aligned, 488 char(*) varying aligned, char(*) varying aligned, 489 ptr, ptr, fixed bin(35)), 490 lex_string_$init_lex_delims entry (char(*) aligned, char(*) aligned, char(*) aligned, char(*) aligned, 491 char(*) aligned, bit(*) aligned, char(*) varying aligned, 492 char(*) varying aligned, char(*) varying aligned, 493 char(*) varying aligned), 494 suffixed_name_$new_suffix entry (char(*), char(*), char(*), char(32), fixed bin(35)), 495 translator_temp_$allocate entry (ptr, fixed bin) returns (ptr); 496 497 dcl NL char(1) defined (NP) position (2); 498 499 dcl /* based variables */ 500 obj char(Lobj) aligned based (Pobj), 501 /* object segment being created. */ 502 1 obj_red aligned based (Pobj_red), 503 /* temp storage for object reductions, prior */ 504 /* to outputting them into the object segment. */ 505 2 N fixed bin, /* number of reductions currently defined. */ 506 2 M fixed bin, /* maximum number which may be defined. */ 507 2 token_reqd (Nreductions refer (obj_red.M)), 508 3 Ifirst fixed bin(17) unal, /* index of 1st and last token requirements */ 509 3 Ilast fixed bin(17) unal, /* associated with this reduction. */ 510 511 obj_spaces char(Lobj_spaces) based (Pobj_spaces), 512 /* overlay for a number of spaces used to */ 513 /* right-adjust an output line. */ 514 obj_string char(Lobj_string) varying aligned based (Pobj_string), 515 /* temp storage for object token values. */ 516 obj_string_part char(Lobj_string_part) based (Pobj_string_part), 517 /* overlay for a particular token value within */ 518 /* the string of all object token values. */ 519 obj_token_quoted (Ntokens) bit(1) unaligned based (Pobj_token_quoted), 520 /* on if object token was enclosed in quotes. */ 521 1 obj_token aligned based (Pobj_token), 522 /* temp storage for object token requirements, */ 523 /* prior to outputting them into the object seg. */ 524 2 N fixed bin, /* number of tokens currently defined. */ 525 2 M fixed bin, /* maximum number which may be defined. */ 526 2 token (Ntokens refer (obj_token.M)), 527 3 form fixed bin(17) unal, /* form of the object token: */ 528 /* -1 = relative token requirement function; */ 529 /* type = index of the particular token */ 530 /* function in the token_fcn array. */ 531 /* 0 = built-in token requirement function; */ 532 /* type = as defined below. */ 533 /* >0 = absolute token requirement: */ 534 /* form = index(token_strings,token_req); */ 535 /* type = length(token_req); */ 536 3 type fixed bin(17) unal, /* type of the built-in token requirement */ 537 /* function: */ 538 /* 1 = compile test to see if input token */ 539 /* chain is exhausted (). */ 540 /* 2 = compile test for any token value */ 541 /* (). */ 542 /* 3 = compile test for a PL/I identifier */ 543 /* () of 32 or fewer characters. */ 544 /* 4 = compile test for token which is a */ 545 /* . */ 546 /* 5 = compile test for token which is a single */ 547 /* backspace character (). */ 548 /* 6 = compile test for a token which is a */ 549 /* . */ 550 source char(Lsource) based(Psource), 551 /* overlay for reduction source segment. */ 552 temp char(Ltemp) based (Ptemp), 553 /* overlay for part of object segment contents */ 554 /* just generated. */ 555 temp_obj char(Ltemp_obj) based (Ptemp_obj); 556 /* temporary copy of object segment contents. */ 557 558 dcl /* static variables */ 559 HT char(1) int static options(constant) init(" "), 560 HT_SP char(2) int static options(constant) init(" "), 561 Mreductions fixed bin int static options(constant) init (9999), 562 MMstack_depth fixed bin int static options(constant) init (9999), 563 Mtokens fixed bin int static options(constant) init (9999), 564 NP char(2) int static options(constant) init (" 565 "), /* */ 566 Sinitialization_reqd bit(1) aligned int static init ("1"b), 567 breaks char(19) varying aligned int static options(constant) init (" 568 /\<>[]()-^=;, "), /* BS SP HT NL / \ < > [ ] ( ) - ^ = ; , VT NP */ 569 1 error_control_table (26) aligned internal static options(constant), 570 /* reduction compiler error message text and */ 571 /* action specifications. */ 572 /* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 */ 573 /*16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 */ 574 2 severity fixed bin(17) unaligned init ( 575 3, 2, 2, 3, 3, 2, 4, 4, 4, 4, 3, 4, 3, 2, 3, 576 3, 4, 2, 3, 4, 3, 3, 3, 3, 3, 3), 577 /* severity of each error. */ 578 2 Soutput_stmt bit(1) unaligned init ( 579 "0"b, "1"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, 580 "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "1"b, "0"b, "0"b), 581 /* on if "current" statement should be output */ 582 /* with the error message. */ 583 2 message char(252) varying init ( 584 /* 1 */ 585 "The reduction source segment does not contain any valid reductions.", 586 /* 2 */ 587 "The statement is not a valid attribute declaration or 588 reduction. (Remember, the label of the first reduction must 589 be 'BEGIN'.)", 590 /* 3 */ 591 "Label '^a' is invalid. The label has been ignored.", 592 /* 4 */ 593 "Label '^a' in the next-reduction field of the 594 reduction statement is invalid. The label has been ignored.", 595 /* 5 */ 596 "Unexpected end encountered. The reduction source segment ends 597 with an incomplete reduction.", 598 /* 6 */ 599 "Unexpected statement encountered when the end of the reduction 600 source segment was expected.", 601 /* 7 */ 602 "Compiler restriction: the reduction source segment contains 603 more than ^d labels. Label '^a' 604 and all labels which follow it have been ignored.", 605 /* 8 */ 606 "Compiler restriction: the reduction source segment contains 607 more than ^d reductions. The reduction on line ^d, 608 and those which follow it, could not be compiled.", 609 /* 9 */ 610 "Compiler restriction: the reduction source segment contains 611 more than ^d tokens. Token '^a' 612 could not be compiled.", 613 /* 10 */ 614 "Compiler restriction: the reduction source segment contains 615 too many different tokens. Because more than ^d token value 616 characters have been defined, token '^a' 617 could not be compiled.", 618 /* 11 */ 619 "Label '^a' is undefined. The reference to this label 620 could not be resolved.", 621 /* 12 */ 622 "The reduction source segment is too large to compile, causing 623 the object segment to overflow.", 624 /* 13 */ 625 "Label '^a' has been multiply-defined.", 626 /* 14 */ 627 "Token requirement '^a' appears in a reduction 628 after a token requirement. This combination of 629 requirements could never be satisfied. Therefore, the reduction 630 will be ignored.", 631 /* 15 */ 632 "Label '^a' in the next-reduction field 633 of a reduction is invalid. In addition, the next-reduction field 634 contains more than one label. This is not allowed.", 635 /* 16 */ 636 "The next-reduction field of a reduction contains more than one label. 637 This is not allowed.", 638 /* 17 */ 639 "Compiler restriction: the reduction source segment contains 640 more than ^d token requirement functions. 641 Function '<^a>' could not be compiled.", 642 /* 18 */ 643 "Compiler restriction: the number specified in a 'MAX_DEPTH' 644 attribute declaration is out of bounds. The allowable range is: 645 ^2-0 < MAX_DEPTH < ^d 646 A maximum depth of ^d will be assumed.", 647 /* 19 */ 648 "The '^a' built-in action routine has been used improperly 649 in a reduction.", 650 /* 20 */ 651 "In attempting to compile the reduction on line ^d, 652 the estimated number of reductions (^d) was exceeded. 653 The reduction on line ^d, and those which follow it, 654 could not be compiled.", 655 /* 21 */ 656 "Unexpected '^a' in the action field of the reduction statement.", 657 /* 22 */ 658 "One or more fields are missing from a reduction. All of the 659 reduction fields (label, syntax, action, & next-label field) 660 must be supplied.", 661 /* 23 */ 662 "A quoted string appears as the name of a semantic subroutine 663 in the action field. This is not permitted. The reduction 664 has been ignored.", 665 /* 24 */ 666 "A right parenthesis ()) is missing from the action field of 667 a reduction.", 668 /* 25 */ 669 "The reduction segment ends with an incomplete reduction.", 670 /* 26 */ 671 "The reduction delimiters in the reduction segment were not 672 found or were positioned improperly."), 673 /* text of the error message. */ 674 2 brief_message char(64) varying init ( 675 /* 1 */ 676 "No reductions.", 677 /* 2 */ 678 "Invalid statement.", 679 /* 3 */ 680 "Invalid label '^a' ignored.", 681 /* 4 */ 682 "Invalid label '^a' ignored.", 683 /* 5 */ 684 "Reductions are incomplete.", 685 /* 6 */ 686 "Unexpected statement after end of reductions.", 687 /* 7 */ 688 "Restriction: >^d labels. '^a' ignored.", 689 /* 8 */ 690 "Restriction: >^d reductions. Line ^d ignored.", 691 /* 9 */ 692 "Restriction: >^d tokens. '^a' ignored.", 693 /* 10 */ 694 "Restriction: >^d token characters. '^a' ignored.", 695 /* 11 */ 696 "Label '^a' undefined.", 697 /* 12 */ 698 "Object segment overflow.", 699 /* 13 */ 700 "Label '^a' multiply-defined.", 701 /* 14 */ 702 "'^a' appears after .", 703 /* 15 */ 704 "Label '^a' invalid & >1 next-reduction labels.", 705 /* 16 */ 706 ">1 label in next-reduction field.", 707 /* 17 */ 708 "Restriction: >^d token requirement functions. '<^a>' ignored.", 709 /* 18 */ 710 "Restriction: 0 < MAX_DEPTH < ^d. ^d assumed.", 711 /* 19 */ 712 "'^a' built-in used improperly.", 713 /* 20 */ 714 "#_reductions > ^s^d estimate.", 715 /* 21 */ 716 "Unexpected '^a' ignored.", 717 /* 22 */ 718 "Incomplete reduction.", 719 /* 23 */ 720 "Quoted subroutine name.", 721 /* 24 */ 722 "')' missing from action field.", 723 /* 25 */ 724 "Reductions incomplete.", 725 /* 26 */ 726 "Bad reduction delimiters."), 727 ignored_breaks char(5) varying aligned int static options(constant) init (" 728 "), /* SP HT NL VT NP */ 729 (error_table_$fatal_error, 730 error_table_$improper_data_format) 731 fixed bin(35) ext static, 732 lex_control_chars char(128) varying aligned int static, 733 lex_delims char(128) varying aligned int static, 734 nl char(1) aligned int static options(constant) init (" 735 "), 736 spaces char(120) aligned int static options(constant) init ((120)" "); 737 738 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 739 740 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 741 742 743 Acode = 0; /* initialize error code. */ 744 SERROR_CONTROL = Scontrol; 745 S_TRACE = substr(bit(Scontrol,36),3,1); 746 if S_TRACE then S_TRACE_ON = substr(bit(Scontrol,36),4,1); 747 else S_TRACE_ON = "0"b; 748 TRACING = S_TRACE; 749 Pobj_spaces = addr(spaces); 750 Pstmt, Pthis_token = null; /* start out with no input tokens. */ 751 Ired_start = index(source,"/*++"); /* find reductions in reduction source segment. */ 752 Ired_end = index(source,"++*/"); 753 if (Ired_start = 0) | (Ired_end = 0) | (Ired_start+4 >= Ired_end-1) then do; 754 call ERROR(26); 755 Acode = error_table_$improper_data_format; 756 go to RETURN; 757 end; 758 Ired_start = Ired_start + 4; /* skip over delimiters. */ 759 Ired_end = Ired_end - 1; 760 if Sinitialization_reqd then do; /* initialize static variables. */ 761 call lex_string_$init_lex_delims ("""", """", "\""", nl, "\", "10"b, 762 breaks, ignored_breaks, lex_delims, lex_control_chars); 763 Sinitialization_reqd = "0"b; 764 end; 765 call lex_string_$lex (Psource, Ired_end-Ired_start+1, Ired_start-1, Psegment, "1"b, 766 """", """", "\""", nl, "\", breaks, ignored_breaks, 767 lex_delims, lex_control_chars, null, Ptoken, code); 768 if code ^= 0 then /* lex source segment into tokens. */ 769 call ERROR(25); 770 if Ptoken = null then do; 771 Acode = code; 772 go to RETURN; 773 end; 774 Pthis_token = Ptoken; 775 call SEMANTIC_ANALYSIS; /* perform semantic analysis of tokens. */ 776 RETURN: Mseverity = MERROR_SEVERITY; 777 if Mseverity > 2 then do; /* Fatal error? Return nothing. */ 778 ALobj = 0; 779 if Acode = 0 then 780 Acode = error_table_$fatal_error; 781 end; 782 return; /* All done! */ 783 784 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 785 786 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 787 788 789 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 790 /* */ 791 /* RELATIVE SYNTAX FUNCTIONS */ 792 /* */ 793 /* The relative syntax functions below are invoked to compare the input tokens */ 794 /* with specifications built into the function. */ 795 /* */ 796 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 797 798 799 PUSH_DOWN_LANGUAGE: procedure returns (bit(1) aligned); /* returns "1"b if a 'PUSH DOWN LANGUAGE' is being*/ 800 /* compiled. */ 801 802 return (S_PDL); 803 804 end PUSH_DOWN_LANGUAGE; 805 806 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 807 808 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 809 810 811 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 812 /* */ 813 /* ACTION ROUTINES: */ 814 /* */ 815 /* The action routines below are invoked at various stages of the compilation */ 816 /* process to impart semantic meaning to the series of tokens which have passed the */ 817 /* syntactic analysis tests of the input reductions. */ 818 /* */ 819 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 820 821 822 action_begin: procedure; /* invoked when beginning to compile the actions */ 823 /* associated with a particular reduction. */ 824 825 call output (" 826 RD_ACTION("); /* output label array constant identifying rtn. */ 827 call output_number (Nobj_red); 828 call output ("): /* / */ 829 "); 830 end action_begin; 831 832 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 833 834 835 compile_token: procedure (type); /* invoked to compile a syntax specification for */ 836 /* the reduction being parsed. */ 837 838 dcl type fixed bin; /* type of specification to be compiled. (In) */ 839 /* 0 = compile absolute token requirement whose */ 840 /* value is the character string value of */ 841 /* the "current" token. */ 842 /* 1 = compile test to see if input token */ 843 /* chain is exhausted (). */ 844 /* 2 = compile test for any token value */ 845 /* (). */ 846 /* 3 = compile test for a PL/I identifier */ 847 /* () of 32 or fewer characters. */ 848 /* 4 = compile test for token which is a */ 849 /* . */ 850 /* 5 = compile test for token which is a single */ 851 /* backspace character (). */ 852 /* 6 = compile test for token which is a */ 853 /* . */ 854 /* 7 = compile relative token requirement fcn. */ 855 856 Nobj_token = obj_token.N + 1; /* increment count of object tokens. */ 857 if Nobj_token > obj_token.M then do; /* make sure we don't overflow obj token table. */ 858 call lex_error_ (9, SERROR_PRINTED(9), (error_control_table(9).severity), MERROR_SEVERITY, 859 addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(9).message), 860 (error_control_table(9).brief_message), obj_token.M, token_value); 861 go to RETURN; 862 end; 863 obj_token.N = Nobj_token; /* append token to obj token array, and to list */ 864 obj_red.Ilast (Nobj_red) /* of object tokens related to reduction being */ 865 = obj_red.Ilast (Nobj_red) + 1; /* parsed. */ 866 go to comp (type); /* compile the appropriate type of token. */ 867 868 comp(0): i = index (obj_string, token_value); /* see if current token exists in string */ 869 /* of previously-defined token values. */ 870 if i > 0 then do; /* if so, use previously-defined string. */ 871 obj_token.form (Nobj_token) = i; 872 obj_token.type (Nobj_token) = token.Lvalue; 873 obj_token_quoted (Nobj_token) = token.S.quoted_string; 874 end; 875 else do; /* if not found, add it to obj token string */ 876 /* values. */ 877 Soptimize_possible = "0"b; /* optimization of obj token storage requirements */ 878 /* no longer possible for this reduction. */ 879 if token.Lvalue + length (obj_string) > Lobj_string then do; 880 call lex_error_ (10, SERROR_PRINTED(10), (error_control_table(10).severity), MERROR_SEVERITY, 881 addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(10).message), 882 (error_control_table(10).brief_message), Lobj_string, token_value); 883 go to RETURN; /* complain if token too big for object string. */ 884 end; 885 else do; 886 obj_token.form (Nobj_token) = length (obj_string) + 1; 887 obj_token.type (Nobj_token) = token.Lvalue; 888 obj_token_quoted (Nobj_token) = token.S.quoted_string; 889 obj_string = obj_string || token_value; 890 end; 891 end; 892 return; 893 comp(1): 894 comp(2): 895 comp(3): 896 comp(4): 897 comp(5): 898 comp(6): obj_token.form (Nobj_token) = 0; /* indicate built-in nature of object token. */ 899 obj_token.type (Nobj_token) = type; /* set appropriate object token type. */ 900 return; 901 902 comp(7): obj_token.form (Nobj_token) = -1; 903 do Nobj_token_fcn = 1 to obj_token_fcn.N while (obj_token_fcn.name(Nobj_token_fcn) ^= token_value); 904 end; /* see if it was previously defined. */ 905 if Nobj_token_fcn <= obj_token_fcn.N then do; /* yes, it was. */ 906 obj_token.type (Nobj_token) = Nobj_token_fcn; 907 return; 908 end; 909 910 if Nobj_token_fcn > dimension (obj_token_fcn.name, 1) then do; 911 call lex_error_ (17, SERROR_PRINTED(17), (error_control_table(17).severity), MERROR_SEVERITY, 912 addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(17).message), 913 (error_control_table(17).brief_message), dimension(obj_token_fcn.name,1), token_value); 914 /* complain if no more room to define functions. */ 915 go to RETURN; 916 end; 917 obj_token.type(Nobj_token) = Nobj_token_fcn; 918 obj_token_fcn.N = Nobj_token_fcn; 919 obj_token_fcn.name(Nobj_token_fcn) = token_value; 920 921 end compile_token; 922 923 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 924 925 926 count_reduction: proc; /* invoked during pass 1 to count the number of */ 927 /* reductions and tokens being compiled. */ 928 929 Nreductions = Nreductions + 1; /* count reduction being parsed. */ 930 if Nreductions > Mreductions then do; /* check for too many reductions. */ 931 Nreductions = Mreductions; 932 Ptoken = Pthis_token; 933 Pstmt = token.Pstmt; 934 call lex_error_ (8, SERROR_PRINTED(8), (error_control_table(8).severity), MERROR_SEVERITY, 935 addrel(token.Pstmt,0), Ptoken, SERROR_CONTROL, (error_control_table(8).message), 936 (error_control_table(8).brief_message), Mreductions, fixed (stmt.line_no,35)); 937 go to RETURN; 938 end; 939 Pstmt = token.Pstmt; 940 Llongest_red = min (254, max(Llongest_red, length(stmt_value))); 941 return; 942 943 count_token: entry (N); 944 945 dcl N fixed bin; /* number of tokens to be counted. (In) */ 946 947 Ntokens = min (Mtokens, Ntokens + 1); /* By counting every token requirement of each */ 948 /* reduction, we get an upper limit on the number */ 949 /* of object tokens. */ 950 do i = 1 to N; /* in each reduction, count length of every token */ 951 Lobj_string = min (Mtokens, Lobj_string + token.Lvalue); 952 Ptoken = token.Pnext; /* to get upper limit on length of string in which*/ 953 end; /* tokens will be stored by compiler. */ 954 955 end count_reduction; 956 957 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 958 959 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 960 961 962 label_value: procedure (label_sought) /* invoked to obtain the reduction number which */ 963 returns (fixed bin(17)); /* is the value of a given reduction label. */ 964 965 dcl label_sought char(*), /* name of label whose value is sought. (In) */ 966 i fixed bin; /* do group index. */ 967 968 do i = 1 to obj_label.N while (obj_label.name(i) ^= label_sought); 969 end; /* search for the sought label in list of defined */ 970 /* labels. */ 971 if i > obj_label.N then do; /* if label not found in list, complain. */ 972 call ERROR(11); 973 return(1); /* return value for first reduction. */ 974 end; 975 else /* if label found, return its value. */ 976 return (obj_label.reduction_no(i)); 977 978 end label_value; 979 980 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 981 982 983 next_reduction: procedure; /* invoked to compile the next-reduction field of */ 984 /* a reduction where no label is specified. This */ 985 /* means "proceed with the next reduction". */ 986 987 call output (" go to RD_NEXT_REDUCTION; /* / \ */ 988 "); 989 990 end next_reduction; 991 992 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 993 994 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 995 996 997 number: procedure (no, statement) returns (char(*)); /* Procedure to put a sequence number at the */ 998 /* beginning of each reduction (in label field). */ 999 dcl no fixed bin, 1000 statement char(*); 1001 1002 dcl Isearch fixed bin, 1003 number char(4) varying; 1004 1005 number = ltrim(char(no)); 1006 if substr(ltrim(statement, HT_SP), 1, 1) = "/" then do; 1007 /* Don't put in a sequence number if a label */ 1008 /* is already present. */ 1009 if substr(statement,1,1) = HT then 1010 return (number || statement); 1011 if substr(statement,1,length(number)) = "" then 1012 return (number || substr(statement, length(number)+1)); 1013 if substr(statement,1,1) = "/" then 1014 return(statement); 1015 end; 1016 1017 Isearch = verify(statement, "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_0123456789"); 1018 Isearch = (Isearch-1) + verify(substr(statement,Isearch), HT_SP); 1019 if substr(statement,Isearch,1) = NL then do; /* Look for label on line by itself, with next */ 1020 /* line starting with whitespace. */ 1021 Isearch = Isearch + 1; 1022 if substr(statement,Isearch,1) = HT then /* line begins with HT. */ 1023 return (substr(statement,1,Isearch-1) || number || 1024 substr(statement,Isearch)); 1025 if substr(statement,Isearch,length(number)) = "" then 1026 return (substr(statement,1,Isearch-1) || number || 1027 substr(statement,Isearch+length(number))); 1028 end; 1029 return (statement); 1030 1031 end number; 1032 1033 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1034 1035 1036 output: procedure (chars); /* invoked to write a character string into the */ 1037 /* object segment. */ 1038 1039 dcl chars char(*); /* the character string to be written. (In) */ 1040 1041 if length (chars) > Lobj then do; /* make sure character string will fit. */ 1042 call ERROR(12); 1043 go to RETURN; /* give up completely. This error is very fatal. */ 1044 end; 1045 substr (obj, 1, length(chars)) = chars; 1046 Pobj = addr (substr (obj, length(chars)+1)); 1047 Lobj = Lobj - length(chars); 1048 Lobj_part = Lobj_part + length(chars); 1049 1050 end output; 1051 1052 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1053 1054 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1055 1056 1057 1058 output_quote: procedure (chars); /* invoked to write a character string into the */ 1059 /* object segment, handling the doubling of quotes*/ 1060 /* if necessary. */ 1061 1062 dcl chars char(*); /* the character string (possibly containing */ 1063 /* quotes which must be doubled) to be output. */ 1064 dcl Iquote fixed bin(21), /* index into part of character string. */ 1065 Lpart fixed bin(21), /* length of part of character string. */ 1066 Ppart ptr, /* ptr to part of character string. */ 1067 up_to_quote char(Iquote) based (Ppart), 1068 /* part of part up to the next quote. */ 1069 part char(Lpart) based (Ppart); 1070 /* part of character string. */ 1071 1072 call output (""""); 1073 Ppart = addr(chars); 1074 Lpart = length(chars); 1075 Iquote = index(part, """"); 1076 do while (Iquote > 0); 1077 call output (up_to_quote); 1078 call output (""""); 1079 Ppart = addr(substr(part,Iquote+1)); 1080 Lpart = Lpart - Iquote; 1081 Iquote = index(part, """"); 1082 end; 1083 if Lpart > 0 then call output (part); 1084 call output (""""); 1085 1086 end output_quote; 1087 1088 1089 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1090 1091 1092 output_number: procedure (number); /* invoked to convert a number to a character */ 1093 /* string, strip off leading blanks, and output */ 1094 /* the result. */ 1095 1096 dcl number fixed bin, /* number to be output. (In) */ 1097 ltrim builtin; 1098 1099 Nchar = number; /* convert number to a character string. */ 1100 call output (ltrim(Nchar)); 1101 1102 end output_number; 1103 1104 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1105 1106 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1107 1108 1109 output_source: 1110 procedure (Ostart, Iend); 1111 1112 dcl Ostart fixed bin(21), 1113 Iend fixed bin(21); 1114 1115 dcl Lsource_part fixed bin(21), 1116 Psource_part ptr, 1117 source_part char(Lsource_part) based(Psource_part); 1118 1119 Psource_part = addcharno(addr(source), Ostart); 1120 Lsource_part = Iend - Ostart; 1121 call output (source_part); 1122 1123 end output_source; 1124 1125 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1126 1127 1128 output_var: procedure (chars); /* invoked to write a varying character string */ 1129 /* into the output segment. */ 1130 1131 dcl chars char(*) varying aligned; 1132 /* the character string to be written. (In) */ 1133 1134 if length (chars) > Lobj then do; /* make sure character string will fit. */ 1135 call ERROR(12); 1136 go to RETURN; 1137 end; 1138 else do; 1139 substr (obj, 1, length(chars)) = chars; 1140 Pobj = addr (substr (obj, length(chars)+1)); 1141 Lobj = Lobj - length(chars); 1142 Lobj_part = Lobj_part + length(chars); 1143 end; 1144 1145 end output_var; 1146 1147 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1148 1149 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1150 1151 1152 reduction_begin: procedure; /* invoked to begin parsing a reduction. */ 1153 1154 Nobj_red = obj_red.N + 1; /* address the next object reduction. */ 1155 if Nobj_red > obj_red.M then do; /* if there is none, complain. */ 1156 Pstmt = token.Pstmt; 1157 call lex_error_ (20, SERROR_PRINTED(20), (error_control_table(20).severity), MERROR_SEVERITY, 1158 Pstmt, Ptoken, SERROR_CONTROL, (error_control_table(20).message), 1159 (error_control_table(20).brief_message), fixed(stmt.line_no,35), obj_red.M, 1160 fixed(stmt.line_no,35)); 1161 go to RETURN; 1162 end; 1163 1164 obj_red.Ifirst (Nobj_red) = obj_token.N + 1; /* initiate indices of first/last token req'mts */ 1165 obj_red.Ilast (Nobj_red) = obj_token.N; /* to reflect no token requirements (so far). */ 1166 Soptimize_possible = "1"b; /* indicate optimization of token requirements is */ 1167 /* possible (so far). */ 1168 end reduction_begin; 1169 1170 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1171 1172 1173 reduction_end: procedure; /* invoke to end parsing of a reduction. */ 1174 1175 obj_red.N = Nobj_red; /* Formally add the completed reduction to the */ 1176 /* object reduction array. */ 1177 if Soptimize_possible then; /* All end work involves optimization of token */ 1178 else /* requirement storage. If optimization not */ 1179 return; /* possible, quit while we're ahead. */ 1180 if obj_red.Ifirst (Nobj_red) > obj_red.Ilast (Nobj_red) then 1181 return; /* same if no token requirements associated with */ 1182 /* the reduction. */ 1183 form = obj_token.form (obj_red.Ifirst(Nobj_red)); /* for efficiency, save value of first token */ 1184 type = obj_token.type (obj_red.Ifirst(Nobj_red)); /* requirement associated with reduction. */ 1185 do i = 1 to obj_red.Ifirst(Nobj_red) - 1; /* search through previously-defined token */ 1186 if obj_token.form(i) = form then /* requirements for a series which match those */ 1187 if obj_token.type(i) = type then do; /* associated with reduction. */ 1188 do j = 1 to obj_red.Ilast(Nobj_red) - obj_red.Ifirst(Nobj_red); 1189 if obj_token.form(i+j) = obj_token.form(obj_red.Ifirst(Nobj_red)+j) then 1190 if obj_token.type(i+j) = obj_token.type(obj_red.Ifirst(Nobj_red)+j) then; 1191 else 1192 go to no_match; 1193 else 1194 go to no_match; 1195 end; 1196 j = j - 1; /* make j = do-group end limit above. */ 1197 obj_token.N = max(obj_red.Ifirst(Nobj_red)-1, i+j); 1198 obj_red.Ifirst (Nobj_red) = i; /* if search succeeds, use previously-defined */ 1199 obj_red.Ilast (Nobj_red) = i + j; /* tokens in this reduction. */ 1200 return; 1201 no_match: end; 1202 end; 1203 1204 end reduction_end; 1205 1206 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1207 1208 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1209 1210 1211 reductions_begin: procedure; /* invoked before parsing the first reduction to */ 1212 /* temporary storage for object reductions, object*/ 1213 /* tokens, and object token strings. */ 1214 /* Also initialize object segment and maximum */ 1215 /* severity value. */ 1216 Pobj_red = translator_temp_$allocate (Psegment, size(obj_red)); 1217 obj_red.M = Nreductions; 1218 Pobj_token = translator_temp_$allocate (Psegment, size(obj_token)); 1219 obj_token.M = Ntokens; 1220 Pobj_token_quoted = translator_temp_$allocate (Psegment, size(obj_token_quoted)); 1221 Pobj_string = translator_temp_$allocate (Psegment, size(obj_string)); 1222 if S_TRACE then 1223 Llongest_red = min(254, Llongest_red + log(Nreductions)); 1224 obj_red.N = 0; 1225 obj_token.N = 0; 1226 string (obj_token_quoted) = "0"b; 1227 obj_token_fcn.N = 0; 1228 Pobj = APobj; 1229 Lobj = ALobj; 1230 1231 end reductions_begin; 1232 1233 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1234 1235 1236 reductions_end: procedure; /* invoked after all reductions have been parsed, */ 1237 /* and after action routine calls have been */ 1238 /* output. */ 1239 1240 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1241 /* */ 1242 /* 1) Store maximum severity as an output value. If it is greater than 2, return with */ 1243 /* an empty object segment as output. */ 1244 /* 2) Otherwise: */ 1245 /* a) copy the action routine calls which have already been output into temporary */ 1246 /* storage. */ 1247 /* b) re-initialize the output object segment to zero length. */ 1248 /* c) output declarations for the object reduction and token structures. */ 1249 /* d) re-output the copied action routine calls. */ 1250 /* e) output an end statement. */ 1251 /* */ 1252 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1253 1254 if MERROR_SEVERITY > 2 then 1255 go to RETURN; 1256 if obj_red.N = 0 then do; /* if there is no output, give up. */ 1257 call ERROR(1); 1258 go to RETURN; 1259 end; 1260 Ptemp = APobj; /* copy contents of object segment output so far */ 1261 Ltemp = ALobj - Lobj; /* to temp storage so we can reuse */ 1262 Ltemp_obj = Ltemp; /* space at head of object segment. */ 1263 Ptemp_obj = translator_temp_$allocate (Psegment, size(temp_obj)); 1264 temp_obj = temp; 1265 Pobj = APobj; 1266 Lobj = ALobj; 1267 1268 call output(NP); /* output start of SEMANTIC_ANALYSIS subroutine. */ 1269 if S_TRACE_ON then 1270 call output (" 1271 dcl TRACING bit(1) aligned int static init(""1""b); 1272 "); 1273 else call output (" 1274 dcl TRACING bit(1) aligned int static init(""0""b); 1275 "); 1276 call output (" 1277 1278 %include rdc_start_; 1279 "); 1280 1281 call output (NP); /* output the reduction label stack. */ 1282 if S_PDL then 1283 call output (" dcl DIRECTION fixed bin init(-1); /* direction in which tokens compared. */ 1284 "); 1285 else call output (" dcl DIRECTION fixed bin init(+1); /* direction in which tokens compared. */ 1286 "); 1287 if Sinclude_STACK then do; 1288 call output (" dcl STACK ("); 1289 call output_number (Mstack_depth); 1290 call output (") fixed bin, /* reduction label stack. */ 1291 STACK_DEPTH fixed bin init (0); /* index into STACK. */ 1292 "); 1293 end; 1294 1295 /* output declaration for object reductions. */ 1296 call output (" 1297 1298 dcl 1 REDUCTION ("); 1299 call output_number (obj_red.N); 1300 call output (") unaligned based (addr (REDUCTIONS)), 1301 /* object reductions. */ 1302 2 TOKEN_REQD, 1303 "); 1304 call output (" 3 IFIRST fixed bin(17), /* index of first required token. */ 1305 3 ILAST fixed bin(17), /* index of last required token. */ 1306 1307 REDUCTIONS ("); 1308 call output_number (obj_red.N + obj_red.N); 1309 call output (") fixed bin(17) unaligned internal static options(constant) initial ( 1310 "); 1311 1312 do i = 1 to obj_red.N; 1313 call output (" "); 1314 if S_PDL then Nchar = obj_red.Ilast (i); 1315 else Nchar = obj_red.Ifirst(i); 1316 call output ((Nchar)); 1317 call output (", "); 1318 if S_PDL then Nchar = obj_red.Ifirst(i); 1319 else Nchar = obj_red.Ilast (i); 1320 call output ((Nchar)); 1321 if i = obj_red.N then 1322 call output ("); /* "); 1323 else 1324 call output (", /* "); 1325 Nchar = i; 1326 call output ((Nchar)); 1327 call output ("/ "); 1328 Lobj_part = 41; 1329 do j = obj_red.Ifirst(i) to obj_red.Ilast(i); 1330 if obj_token.form(j) > 0 then do; 1331 Pobj_string_part = addr(substr(obj_string, obj_token.form(j))); 1332 Lobj_string_part = obj_token.type(j); 1333 if obj_token_quoted(j) then 1334 call output_quote (obj_string_part); 1335 else call output (obj_string_part); 1336 call output (" "); 1337 end; 1338 else if obj_token.form(j) = 0 then do; 1339 go to comment (obj_token.type(j)); 1340 1341 comment(1): call output (" "); 1342 go to end_comment; 1343 comment(2): call output (" "); 1344 go to end_comment; 1345 comment(3): call output (" "); 1346 go to end_comment; 1347 comment(4): call output (" "); 1348 go to end_comment; 1349 comment(5): call output (" "); 1350 go to end_comment; 1351 comment(6): call output (" "); 1352 end_comment: end; 1353 else do; 1354 call output ("<"); 1355 call output_var (obj_token_fcn.name(obj_token.type(j))); 1356 call output ("> "); 1357 end; 1358 end; 1359 Lobj_spaces = max(0, 110-Lobj_part); 1360 call output (obj_spaces); 1361 call output ("*/ 1362 "); 1363 end; 1364 1365 call output (NP); /* output declaration for object tokens. */ 1366 call output (" dcl 1 TOKEN_REQUIREMENT ("); 1367 call output_number (obj_token.N); 1368 call output (") unaligned based (addr (TOKEN_REQUIREMENTS)), 1369 /* object token requirements. */ 1370 2 FORM fixed bin(17), /* form of the token requirement: */"); 1371 call output (" 1372 /* -1 = relative token requirement function; */ 1373 /* TYPE = index of the particular token */ 1374 /* function in the token_fcn array. */ 1375 /* 0 = built-in token requirement function; */"); 1376 call output (" 1377 /* TYPE = as defined below. */ 1378 /* >0 = absolute token requirement: */ 1379 /* FORM = index(TOKEN_STRINGS,TOKEN_REQD); */ 1380 /* TYPE = length(TOKEN_REQD); */"); 1381 call output (" 1382 2 TYPE fixed bin(17) unal, /* type of the built-in token requirement */ 1383 /* function: */ 1384 /* 1 = compile test to see if input token */"); 1385 call output (" 1386 /* chain is exhausted (). */ 1387 /* 2 = compile test for any token value */ 1388 /* (). */"); 1389 call output (" 1390 /* 3 = compile test for a PL/I identifier */ 1391 /* () of 32 or fewer characters. */ 1392 /* 4 = compile test for token which is a */ 1393 /* . */"); 1394 call output (" 1395 /* 5 = compile test for token which is a single */ 1396 /* backspace character (). */ 1397 /* 6 = compile test for a token which is a */ 1398 /* . */"); 1399 call output (" 1400 1401 TOKEN_REQUIREMENTS ("); 1402 call output_number (obj_token.N + obj_token.N); 1403 call output (") fixed bin(17) unaligned internal static options(constant) initial ("); 1404 do i = 1 to obj_token.N; 1405 call output (" 1406 "); 1407 do i = i to min (obj_token.N, i + 6); 1408 Nchar = obj_token.form(i); 1409 call output ((Nchar)); 1410 call output (","); 1411 Nchar = obj_token.type(i); 1412 call output ((Nchar)); 1413 if i = obj_token.N then 1414 call output ("); 1415 "); 1416 else 1417 call output (", "); 1418 end; 1419 i = i - 1; 1420 end; 1421 1422 i = length (obj_string); /* output declaration for object token values. */ 1423 call output (" 1424 1425 dcl TOKEN_STRINGS char("); 1426 call output_number (i); 1427 call output (") aligned based (addr (TOKEN_STRING_ARRAYS)), 1428 /* object token values. */ 1429 "); 1430 i = divide (length(obj_string),100,17,0) + 1; /* compute number of 100-char substrings. */ 1431 call output (" TOKEN_STRING_ARRAYS ("); 1432 call output_number (i); 1433 call output (") char(100) aligned internal static options(constant) initial ( 1434 "); 1435 Lobj_string_part = 100; 1436 do i = 0 to i-2; 1437 call output (" """); 1438 Pobj_string_part = addr (substr (obj_string, i*100+1)); 1439 call output (obj_string_part); 1440 call output (""", 1441 "); 1442 end; 1443 call output (" """); 1444 Pobj_string_part = addr (substr (obj_string, i*100+1)); 1445 Lobj_string_part = length(obj_string) - i*100; 1446 call output (obj_string_part); 1447 call output ("""); 1448 "); 1449 1450 call output (NP); /* output include statement for end semant. */ 1451 call output (" %include rdc_end_; 1452 "); 1453 if obj_token_fcn.N > 0 then do; /* output relative syntax function calls, if any. */ 1454 call output (" 1455 else do; /* relative syntax function. */ 1456 go to RD_TOKEN_FCN(TOKEN_REQD.TYPE); 1457 "); 1458 do i = 1 to obj_token_fcn.N; 1459 call output (" 1460 RD_TOKEN_FCN("); call output_number(i); 1461 call output("): STOKEN_FCN = "); 1462 call output_var (obj_token_fcn.name(i)); 1463 call output ("(); 1464 go to RD_TEST_RESULT;"); 1465 end; 1466 call output (" 1467 1468 RD_TEST_RESULT: if STOKEN_FCN then go to RD_MATCH; 1469 else go to RD_NEXT_REDUCTION; 1470 end; 1471 "); 1472 end; 1473 1474 if S_PDL then 1475 call output (" 1476 RD_MATCH: Ptoken = token.Plast; 1477 RD_MATCH_NO_TOKEN: 1478 end; 1479 Ptoken = Pthis_token; 1480 "); 1481 else call output (" 1482 RD_MATCH: Ptoken = token.Pnext; 1483 RD_MATCH_NO_TOKEN: 1484 end; 1485 Ptoken = Pthis_token; 1486 "); 1487 if S_TRACE then do; 1488 call output (" 1489 if TRACING then do; 1490 call PRINT_REDUCTION(NRED); 1491 call PRINT_TOKENS (DIRECTION, (RED.TOKEN_REQD.IFIRST), (RED.TOKEN_REQD.ILAST)); 1492 end; 1493 "); 1494 end; 1495 call output (" go to RD_ACTION(NRED); 1496 "); 1497 1498 if Sinclude_STACK then do; /* include the label stack functions. */ 1499 call output (NP); 1500 call output (" %include rdc_stack_fcns_; 1501 "); 1502 end; 1503 1504 call output (NP); /* output action routine calls saved previously. */ 1505 call output (temp_obj); 1506 if S_TRACE then do; 1507 call output (NP); 1508 call output ("%include rdc_tracing_fcns_; 1509 "); 1510 end; 1511 call output (" 1512 1513 end SEMANTIC_ANALYSIS; 1514 1515 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1516 "); 1517 1518 call output (NP); /* define the PUSH DOWN LANGUAGE switch and */ 1519 /* include the LEX subroutine in object seg. */ 1520 if S_PDL then 1521 call output (" dcl SPDL bit(1) aligned init (""1""b); 1522 /* on: This compiler parses a PUSH DOWN LANGUAGE. */ 1523 1524 "); else 1525 call output (" dcl SPDL bit(1) aligned init (""0""b); 1526 /* off: This compiler parses a non-PUSH DOWN */ 1527 /* LANGUAGE. */ 1528 "); 1529 if Sinclude_LEX then 1530 call output (" %include rdc_lex_; 1531 "); 1532 if Sinclude_DELETE then do; /* include the DELETE subroutine. */ 1533 call output (NP); 1534 call output (" %include rdc_delete_; 1535 "); end; 1536 if Sinclude_DELETE_STMT then do; /* include the DELETE_STMT subroutine. */ 1537 call output (NP); 1538 call output (" %include rdc_delete_stmt_; 1539 "); end; 1540 if Sinclude_ERROR then do; /* output include statement for ERROR message proc*/ 1541 call output (NP); 1542 call output (" %include rdc_error_; 1543 "); 1544 end; 1545 1546 if Sinclude_NEXT_STMT then do; /* output NEXT_STMT proc. */ 1547 call output (NP); 1548 call output (" %include rdc_next_stmt_; 1549 "); 1550 end; 1551 1552 if S_TRACE then do; 1553 call output (NP); 1554 call output (" dcl RED_TEXT ("); 1555 call output_number (Nreductions); 1556 call output (") char ("); 1557 call output_number (Llongest_red); 1558 Llongest_red = Llongest_red - log(Nreductions); 1559 /* leave room for reduction number. */ 1560 call output (") varying int static options(constant) init ( 1561 "); 1562 Pstmt = Psave -> token.Pstmt; 1563 call output_quote (number(1, substr(stmt_value,1,min(length(stmt_value), Llongest_red)))); 1564 do i = 2 to Nreductions; 1565 call output (", 1566 "); 1567 Pstmt = stmt.Pnext; 1568 call output_quote (number(i, substr(stmt_value,1,min(length(stmt_value), Llongest_red)))); 1569 end; 1570 call output ("); 1571 "); 1572 end; 1573 1574 Ptemp = APobj; /* again, copy what we've generated in obj seg */ 1575 Ltemp = ALobj - Lobj; /* so we can reuse beginning. */ 1576 Ltemp_obj = Ltemp; 1577 Ptemp_obj = translator_temp_$allocate (Psegment, size(temp_obj)); 1578 temp_obj = temp; 1579 1580 Pobj = APobj; /* output segment header for object segment. */ 1581 Lobj = ALobj; 1582 call output (" 1583 1584 /* * * * * * * * * * * * * * * * * * * * * * * */ 1585 /* */ 1586 /* COMPILED OUTPUT OF SEGMENT "); 1587 call output (Aname_source); 1588 call output (" */ 1589 /* Compiled by: reduction_compiler, Version 2.5 of Oct 21, 1985 */ 1590 /* Compiled on: "); 1591 date = date_time_$format ("date_time", clock_(), "", ""); 1592 call output (date); 1593 call output ("*/ 1594 /* */ 1595 /* * * * * * * * * * * * * * * * * * * * * * * */ 1596 "); 1597 call output(NP); 1598 1599 Pstmt = Psave -> token.Pstmt; /* copy source into object segment. */ 1600 Osc_start = 0; /* each reduction is written separately so it */ 1601 do i = 1 to Nreductions; /* can be numbered for ease of debugging. */ 1602 call output_source (Osc_start, charno(addr(stmt_value))); 1603 call output (number(i, stmt_value)); 1604 Osc_start = charno(addr(stmt_value)) + length(stmt_value); 1605 Pstmt = stmt.Pnext; 1606 end; 1607 call output_source (Osc_start, length(source)); 1608 1609 call output(temp_obj); /* output object previously generated & saved. */ 1610 /* output final end statement for translator. */ 1611 call suffixed_name_$new_suffix (Aname_source, "rd", "", name_source, code); 1612 call output (" 1613 end "); 1614 call output (rtrim(name_source)); 1615 call output ("; 1616 "); 1617 ALobj = ALobj - Lobj; /* adjust length of object seg returned to caller.*/ 1618 1619 end reductions_end; 1620 1621 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1622 1623 1624 reductions_init: procedure; /* invoked before pass1 of parse to */ 1625 /* initialize maximum stack depth, reduction and */ 1626 /* token counters, & maximum object string length.*/ 1627 /* Set switch to suppress inclusion of ERROR proc */ 1628 /* unless is it actually referenced. Do same for */ 1629 /* reduction STACK fcns, NEXT_STMT proc, and */ 1630 /* DELETE procs. Default to ^'PUSH DOWN LANGUAGE'.*/ 1631 Mstack_depth = 10; /* maximum stack depth is 10, by default. */ 1632 Nreductions = 0; 1633 Ntokens = 0; 1634 Llongest_red = 0; 1635 Lobj_string = 0; 1636 obj_label.N = 0; 1637 S_PDL = "0"b; 1638 Sinclude_DELETE = "0"b; 1639 Sinclude_DELETE_STMT = "0"b; 1640 Sinclude_ERROR = "0"b; 1641 Sinclude_NEXT_STMT = "0"b; 1642 Sinclude_LEX = "0"b; 1643 Sinclude_STACK = "0"b; 1644 1645 end reductions_init; 1646 1647 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1648 1649 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 1650 1651 1652 rtn: procedure (type); /* invoked to compile one of the pre-defined */ 1653 /* (pre-, mid-, or post-) actions. */ 1654 1655 dcl type fixed bin; /* type of action to be compiled. */ 1656 /* 1 = LEX */ 1657 /* 2 = POP */ 1658 /* 3 = PUSH(