1           /* START OF:        rdc_stack_fcns_.incl.pl1        *  *  *  *  *  *  */
 2 
 3           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 4           /*                                                                    */
 5           /* N^H__^Ha_^Hm_^He:  rdc_stack_fcns_.incl.pl1                                  */
 6           /*                                                                    */
 7           /*      This include segment is used by compilers generated by the    */
 8           /* reduction_compiler.  It includes code for manipulating the         */
 9           /* reduction label stack.                                             */
10           /*                                                                    */
11           /* S^H__^Ht_^Ha_^Ht_^Hu_^Hs                                                               */
12           /*                                                                    */
13           /* 0) Created:  April, 1974 by G. C. Dixon                            */
14           /*                                                                    */
15           /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
16 
17 RD_STACK: if STACK_DEPTH > 0 then do;
18                NRED = STACK (STACK_DEPTH);
19                go to RD_TEST_REDUCTION;
20                end;
21           else
22                go to RD_NEXT_REDUCTION;
23 
24 RD_STACK_POP:
25           if STACK_DEPTH > 0 then do;
26                NRED = STACK (STACK_DEPTH);
27                STACK_DEPTH = max (STACK_DEPTH-1, 0);
28                go to RD_TEST_REDUCTION;
29                end;
30           else
31                go to RD_NEXT_REDUCTION;
32 ^L
33 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
34 
35 
36 PUSH:     procedure (N);                                    /* invoked to push reduction number 'N' onto      */
37                                                             /* the reduction stack.                           */
38      dcl  N                             fixed bin;
39 
40      dcl (addr, dimension, length, null)
41                                         builtin;
42 
43      dcl  cu_$cl                        entry,
44           iox_$put_chars                entry (ptr, ptr, fixed bin, fixed bin(35)),
45           iox_$error_output             ptr ext static,
46           lex_error_                    entry options(variable);
47 
48      dcl  brief_error                   char(4) varying initial ("") int static,
49           long_error                    char(234) varying int static init(
50 "An internal stack (the reduction stack) has overflowed.
51 The translation has failed.  Contact translator maintenance
52 personnel for assistance.
53      Processing reduction: ^d
54      Reduction being stacked: ^d
55      Maximum stack depth: ^d"),
56           non_restart_error             char(33) int static init ("Translation cannot be restarted.
57 ");
58 
59           if STACK_DEPTH >= dimension (STACK, 1) then do;
60                call lex_error_ (0, "0"b, 4, 0, null, null, "11"b, long_error, brief_error, NRED, N,
61                                 dimension(STACK,1));
62 get_to_cl:     call cu_$cl();
63                call iox_$put_chars (iox_$error_output, addr(non_restart_error), length(non_restart_error), 0);
64                go to get_to_cl;
65                end;                                         /* stack overflow is a non-recoverable error.     */
66           else
67                STACK_DEPTH = STACK_DEPTH + 1;
68           STACK (STACK_DEPTH) = N;
69 
70           end PUSH;
71 
72 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
73 
74           /* END OF:          rdc_stack_fcns_.incl.pl1        *  *  *  *  *  *  */