1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 expression_parse:
 12           procedure(i,cblock) recursive returns(pointer);
 13 
 14 
 15 /*        Parameters          */
 16 
 17 dcl       i                   fixed bin(15),
 18           r                   ptr,
 19           cblock              ptr;
 20 
 21 dcl       (addr,binary,fixed,index,null,search,substr) builtin;
 22 
 23 
 24 /*        Automatic stuff.    */
 25 
 26 dcl       (j, k, si, n)       fixed bin(15),
 27           (eloc,oploc)        fixed bin(15),
 28           ch                  char(1),
 29           opindex             fixed bin(5),
 30           q                   ptr,
 31           type                bit(9) aligned,
 32           (r2,r3)             ptr,
 33           stack(0:12)         ptr;
 34 
 35 /*        Constants.          */
 36 
 37 dcl       precedence(0:18) fixed bin(15) internal static
 38           initial(  0,        /* illegal */
 39                     5,        /* +, plus */
 40                     5,        /* -, minus */
 41                     6,        /* *, asterisk */
 42                     6,        /* /, slash */
 43                     7,        /* **, expon */
 44                     7,        /* ^, not */
 45                     2,        /* &, and */
 46                     1,        /* |, or */
 47                     4,        /* ||, cat */
 48                     3,        /* =, eq  */
 49                     3,        /* ^=, ne */
 50                     3,        /* <, lt */
 51                     3,        /* >, gt */
 52                     3,        /* <=, le */
 53                     3,        /* >=, ge */
 54                     3,        /* ^>, ngt */
 55                     3,        /* ^<, nlt */
 56                     3);       /* =, assignment */
 57 
 58 dcl       op_table(0:18) bit(9) aligned internal static options(constant)
 59           initial(  ""b,                /* illegal */
 60                     "000010001"b,       /* +, plus */
 61                     "000010010"b,       /* -, minus */
 62                     "000010011"b,       /* *, asterisk */
 63                     "000010100"b,       /* /, slash */
 64                     "100100100"b,       /* **, expon */
 65                     "000100100"b,       /* ^, not */
 66                     "000100001"b,       /* &, and */
 67                     "000100010"b,       /* |, or */
 68                     "000100101"b,       /* ||, cat */
 69                     "001000110"b,       /* =, eq */
 70                     "001000111"b,       /* ^=, ne */
 71                     "001000100"b,       /* <, lt */
 72                     "001000101"b,       /* >, gt */
 73                     "001001000"b,       /* <=, le */
 74                     "001001001"b,       /* >=, ge */
 75                     "001001000"b,       /* ^>, ngt */
 76                     "001001001"b,       /* ^<, nlt */
 77                     "001000110"b);      /* =, assignment ( equal relational ) */
 78 
 79 /*        t and tlist are used to get better accessing to token_list in
 80           inner procedure "primitive".                      */
 81 
 82 dcl       t                   ptr internal static,
 83           tlist(3000)         ptr based(t);
 84 
 85 %include parse;
 86 %include token_list;
 87 %include token;
 88 %include nodes;
 89 %include operator;
 90 %include op_codes;
 91 %include token_types;
 92 /*^L                This procedure parses expressions using a simple operator
 93           precedence technique.  The syntax parsed is
 94 
 95                     <expression> ::= <primitive> [<operator> <primitive>]...
 96 
 97           where the nth operator and its operands are stacked if the
 98           n+1st operator has higher precedence.  The primitive is parsed by
 99           the internal entry called "primitive".  The primitives include
100           parenthesized expressions, prefix operators, and exponentiation. */
101 
102           t = pl1_stat_$token_list_ptr;
103           k = i;
104           si = 0;
105           stack(0) = primitive(k);
106 
107 fetchop:  type = t_table.type;
108 
109 checkop:  if type & is_delimiter
110           then if type <= assignment
111           then do;
112 
113                     if type = not then goto fail;
114 
115                     if si ^= 0                    /* If past first op then check prec. */
116                     then do;
117 
118                               opindex = binary(substr(stack(si-1) -> token.type,5,5));
119                               if precedence(opindex) >=
120                                  precedence(fixed(substr(type,5,5),5)) then go to unstack;
121 
122                          end;
123 
124 stackop:            si = si + 1;
125                     stack(si) = token_list(k);
126                     si = si + 1;
127                     k = k + 1;
128                     stack(si) = primitive(k);
129 
130                     go to fetchop;
131 
132                end;
133 
134           if si = 0 then go to succeed;
135 
136 unstackop:opindex = binary(substr(stack(si-1) -> token.type,5,5));
137 
138 unstack:  r2 = stack(si-2);
139           r3 = stack(si);
140 
141           if opindex = 9
142           then do;
143 
144                /* attempt to optimize cat (||) */
145 
146                if r2 -> node.type = token_node
147                then if r3 -> node.type = token_node
148                then if r2 -> token.type & r3 -> token.type & is_constant
149                then do;
150                     q = evaluate(op_table(9),r2,r3);
151                     go to pop;
152                     end;
153                end;
154 
155           if opindex >= 4
156           then do;
157 
158                /* operator not + - or * */
159 
160 make_op:       q = create_operator((op_table(opindex)),3);
161                q -> operator.operand(2) = r2;
162                q -> operator.operand(3) = r3;
163 
164 pop:           si = si - 2;
165                stack(si) = q;
166 
167                go to checkop;
168                end;
169 
170           if r2 -> node.type ^= token_node then goto make_op;
171           if r3 -> node.type ^= token_node then goto make_op;
172 
173           /* Check for constants on both sides of operator */
174 
175           if (r2 -> token.type & is_arithmetic_constant) ^= is_arithmetic_constant then goto make_op;
176           if r2 -> token.type >= i_fixed_bin then goto make_op;
177 
178           if (r3 -> token.type & is_arithmetic_constant) ^= is_arithmetic_constant then goto make_op;
179 
180           if r2 -> token.loc ^= r3 -> token.loc then go to make_op;   /* require both to have same "p" attribute */
181 
182           /* Check for "complex" constant */
183 
184           if r3 -> token.type >= i_fixed_bin
185           then do;
186                if opindex >= 3 then goto make_op;
187 
188                oploc = search(substr(r3->token.string,2),"+-");       /* This block of code is to ensure      */
189                if oploc ^= 0 then do;                                 /* that r3 points to an imaginary,      */
190                     eloc = index(r3->token.string,"e");               /* not complex, number.                 */
191                     if eloc = 0 then goto make_op;
192                     if oploc < eloc then goto make_op;
193                     if search(substr(r3->token.string,eloc+2),"+-") ^= 0 then goto make_op;
194                     end;
195 
196                /* form new token representing the complex constant */
197 
198                if opindex = 1           /* addition */
199                then if substr(r3 -> token.string,1,1) = "-"
200                     then do;
201                          j = 2;
202                          ch = "-";
203                          end;
204                     else do;
205                          ch = "+";
206                          if substr(r3 -> token.string,1,1) = "+" then j = 2; else j = 1;
207                          end;
208                else if substr(r3 -> token.string,1,1) = "-"
209                     then do;
210                          j = 2;
211                          ch = "+";
212                          end;
213                     else do;
214                          ch = "-";
215                          if substr(r3 -> token.string,1,1) = "+" then j = 2; else j = 1;
216                          end;
217 
218                q = create_token$protected (r2 -> token.string || ch || substr (r3 ->token.string, j), (r3 -> token.type), (r2 -> token.loc));
219                goto pop;
220                end;
221 
222           /* have constant operands, evalute expression if possible */
223 
224           q = evaluate((op_table(opindex)),r2,r3);
225           goto pop;
226 
227 fail:     r = null;
228           go to ret;
229 
230 succeed:  r = stack(0);
231           i = k;
232 
233 ret:      return(r);
234 ^L
235 /*        Primitive parses prefix expressions, exponentiation operators,
236           and parenthesized expressions.                    */
237 
238 primitive: proc(i) returns(ptr);
239 
240 dcl       (p,q)     ptr,
241           i         fixed bin(15),
242           (ttype,
243             type)   bit(9) aligned;
244 
245           type = tlist(i) -> token.type;
246 
247           if type = plus
248           then do;
249                     i = i + 1;
250                     p = primitive(i);
251                     if p -> node.type = token_node
252                     then do;
253                               ttype, type = p -> token.type;
254                               if (type & is_arithmetic_constant) = is_arithmetic_constant
255                               then      if substr(p->token.string,1,1) = "-" | substr(p->token.string,1,1) = "+"
256                                         then q = p;
257                                         else q = create_token$protected ("+" || p -> token.string, ttype, (p -> token.loc));
258                               else go to plusop;
259                          end;
260                     else do;
261 plusop:
262                               q = create_operator((prefix_plus),2);
263                               q->operator.operand(2) = p;
264                          end;
265 
266                end;
267 
268           else if type = minus
269           then do;
270 
271                     i = i + 1;
272                     p = primitive(i);
273                     if p -> node.type = token_node
274                     then do;
275 
276                               ttype, type = p -> token.type;
277 
278                               if (type & is_arithmetic_constant) = is_arithmetic_constant
279                               then      if substr(p->token.string,1,1) = "-"
280                                         then q = create_token$protected (substr (p -> token.string, 2), ttype, (p -> token.loc));
281                                         else      if substr (p -> token.string, 1, 1) = "+"
282                                                   then q = create_token$protected ("-" || substr (p -> token.string, 2), ttype, (p -> token.loc));
283                                                   else q = create_token$protected ("-" || p -> token.string, ttype, (p -> token.loc));
284                               else go to negop;
285                          end;
286                     else do;
287 
288 negop:                        q = create_operator((negate), 2);
289                               q -> operator.operand(2) = p;
290 
291                          end;
292 
293                end;
294 
295           else if type = not
296           then do;
297 
298                     i = i + 1;
299                     q = create_operator((not_bits), 2);
300                     q -> operator.operand(2) = primitive(i);
301 
302                end;
303 
304           else if type = left_parn
305           then do;
306 
307                     i = i + 1;
308                     q = expression_parse(i,cblock);
309                     if q = null then go to phail;
310                     if tlist(i) -> token.type ^= right_parn then go to phail;
311 
312                     i = i + 1;
313                end;
314 
315           else if type & is_constant
316           then do;
317 
318                     q = tlist(i);
319                     i = i + 1;
320 
321                end;
322 
323           else do;
324                     q = reference_parse(i,cblock);
325                     if q = null then go to phail;
326                end;
327 
328           if tlist(i) -> token.type = expon
329           then do;
330 
331                     i = i + 1;
332                     p = q;
333                     q = create_operator((exp), 3);
334                     q -> operator.operand(2) = p;
335                     q -> operator.operand(3) = primitive(i);
336 
337                end;
338 
339           return(q);
340 
341 phail:    go to fail;
342 
343           end primitive;
344           end expression_parse;