1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  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 expevl_:
 14      proc (tbool, inexp, lc, expevl_answer) ;
 15 
 16 /*
 17    Modified 740821 by PG to allow stack-references wherever references are allowed.
 18    Modified on 12/07/72 at 20:29:45 by R F Mabee. Fixed up prntr problem for good.
 19    Modified by RHG on 17 August 1970 at 1614 to clean up some bad code
 20    by RHG on 11 August 1970 at 0537 to get rid of return value (make it a parameter)
 21    by RHG on 10 August 1970 at 2139 to allow "^" as substitute for "/" in bool expressions
 22    by RHG on 10 August 1970 at 2032 to eliminate calls to prec_ and utils_$(and or xor)
 23    by Nate Adleman on June 28, 1970 at 2006 for the new CODTAB
 24 */
 25 
 26 /* EXPEVL:   evaluate internal expressions for MA */
 27 
 28 /*   internal expression evaluation routine. this routine evaluates */
 29 /*   expressions consisting entirely of internal references using a */
 30 /*   stack technique. nested expressions are allowed as normal */
 31 /*   subexpressions, and evaluation is done on either an arithmetic */
 32 /*   or boolean operator interpretation. the stack is an internal */
 33 /*   array of nstk( = 100) locations, sufficient for most expressions. */
 34 
 35 /* modifications by wagner for multiple location counters, */
 36 /* june 13, 1967. returns in lc the address of the assignment */
 37 /* table entry for the location counter to which inexp is relative. */
 38 /* if call has tbool =  1;    (TRUE) then caller must ignore lc. */
 39 
 40 /* a second stack, lstk, runs parallel to stk. lstk(i) is-- */
 41 
 42 /*   lc  if stk(i) is relative to a location counter. */
 43 /*   0  if stk(i) is absolute. */
 44 /*   garbage  if stk(i) is an operator. */
 45 
 46 /* then at each arithmetic operator there must be a check */
 47 /* that operands are of consistent types. */
 48 
 49 
 50 
 51 /* INCLUDE FILES USED BY EXPEVL */
 52 
 53 % include varcom;
 54 % include concom;
 55 % include erflgs;
 56 % include codtab;
 57 % include curlc;
 58 /* ^L */
 59 /* EXTERNAL ENTRIES USED BY EXPEVL */
 60 
 61 declare  getid_$getid_ external entry,
 62          inputs_$next external entry ;
 63 
 64 /* EXTERNAL FUNCTIONS USED BY EXPEVL */
 65 
 66 declare  glpl_$clh external entry (fixed bin) returns (fixed bin),
 67          glpl_$crh external entry (fixed bin) returns (fixed bin),
 68          table_$table_ external entry (fixed bin (26), fixed bin (26), fixed bin, fixed bin (26), fixed bin) returns (fixed bin (26));
 69 
 70 
 71 /* EXTERNAL DATA USED BY EXPEVL */
 72 
 73 declare (eb_data_$ilend, eb_data_$ineg, eb_data_$inot) ext fixed bin (35);
 74 
 75 
 76 /* AUTOMATIC DATA USED BY EXPEVL */
 77 
 78 declare  expevl_answer fixed bin (35) ;
 79 
 80 
 81 declare (inexp, i, lc, l1, l2, lstk (100), op, rprec,
 82          stk (100), tbad, tbool, val, vlc, radix, brk_temp) fixed bin (17);
 83 
 84 declare  nstk fixed bin internal static init (100);
 85 
 86 /* ^L */
 87 /* - - - - - NORMAL ENTRY, break in brk, and perhaps symbol in xsym. */
 88 
 89 label_100:
 90           radix = 10 -tbool - tbool ;                       /* set the radix for numeric constants to 8 or 10 */
 91           expevl_answer = 1;                                /* TRUE */;
 92           tbad = 0;                                         /* FALSE */;
 93           i = 1;
 94           stk (1) = eb_data_$ilend;
 95           go to label_210;
 96 
 97 /*   re-entry to get next identifier. */
 98 label_200:
 99           call getid_$getid_;
100 label_210:
101           if (brk (1) = inum) then go to label_230;
102           if (sym (1) = 0) then go to label_300;
103 
104 /*   not number nor void, look up symbol in assignment table. */
105 label_220:
106           if (table_$table_ (iserch, sym (1), val, clint, vlc) ^= 0) then go to label_400;
107           if (table_$table_ (iserch, sym (1), val, clmlc, vlc) ^= 0) then go to label_400;
108           if (table_$table_ (iserch, sym (1), val, clstk, vlc) ^= 0) then go to label_400;
109 label_225:
110           prntu = 1;                                        /* TRUE */;
111           expevl_answer = 0;                                /* FALSE */;
112           go to label_400;
113 
114 /*   number, convert to binary. */
115 label_230:
116           unspec (val) = unspec (brk (2)) & "000000000000000000000000000000001111"b; /* val = utils_$and( brk(2), 15) */
117           vlc = 0;
118 label_240:
119           call inputs_$next;
120           if (brk (1) ^= inum) then go to label_400;
121           val = radix * val + fixed (unspec (brk (2)) & "000000000000000000000000000000001111"b, 17, 0) ;
122           go to label_240;
123 
124 /*   unary operator, check which and process. */
125 label_300:
126           brk_temp = brk (1);                               /* set brk_temp which is not abnormal so pl1 can optimize */
127           if (brk_temp = iplus) then go to label_310;
128           if (brk_temp = iminus) then go to label_320;
129           if (brk_temp = istar) then go to label_330;
130           if (brk_temp = islash) then go to label_340;
131           if (brk_temp = icflx) then go to label_340;
132           if (brk_temp = ilpar) then go to label_350;
133           go to label_360;
134 
135 /*   ignore unary plus. */
136 label_310:
137           go to label_200;
138 
139 /*   replace unary minus by _$neg_$, put instack, and . */
140 label_320:
141           i = i+1;
142           stk (i) = eb_data_$ineg;
143           go to label_200;
144 
145 /*   unary star is symbol for this location. */
146 label_330:
147           val = pc;
148           vlc = curlc;
149           call getid_$getid_;
150           if (sym (1) ^= 0) then go to label_800;
151           go to label_400;
152 
153 /*   unary slash for booleans means not. */
154 label_340:
155           i = i+1;
156           stk (i) = eb_data_$inot;
157           go to label_200;
158 
159 /*   simply insert ( and scan. */
160 label_350:
161           i = i+1;
162           stk (i) = ilpar;
163           go to label_200;
164 
165 /*   unknown break, val is zero and treat as binary end. */
166 label_360:
167           val = 0;
168           vlc = 0;
169           go to label_400;
170 
171 
172 /*   binary operator, insert operand, and check precedence of */
173 /*   operator. if current precedence greater than last operator, */
174 /*   insert new operator in stack, otherwise, begin evaluating */
175 /*   operators up the stack. parentheses and end of field are */
176 /*   treated in special ways. */
177 
178 label_400:
179           if (i > (nstk-4)) then go to label_800;
180           i = i+1;
181           stk (i) = val;
182           lstk (i) = vlc;
183 label_410:
184           unspec (rprec) = unspec (brk (1)) & "000000000000000000000000000000001111"b; /* rprec = utils_$and(brk(1), 15); */
185 label_420:
186           op = stk (i-1);
187           if fixed (unspec (op) & "000000000000000000000000000000001111"b, 17, 0) >= rprec then goto label_460;
188           if (brk (1) = irpar) then go to label_450;
189           if (rprec <= 4) then go to label_440;
190 
191 /*   precedence greater, insert operator in stack. */
192 label_430:
193           i = i+1;
194           stk (i) = brk (1);
195           go to label_200;
196 
197 /*   end terminator, check results and return answer. */
198 label_440:
199           if (i ^= 2) then go to label_800;
200           go to label_900;
201 
202 /*   right parenthesis processed only after ops evaluated. */
203 label_450:
204           if (op = eb_data_$ilend) then go to label_440;
205           if (op ^= ilpar) then go to label_800;
206           i = i-1;
207           stk (i) = stk (i+1);
208           lstk (i) = lstk (i+1);
209           call getid_$getid_;
210           if (sym (1) ^= 0) then go to label_800;
211           go to label_410;
212 
213 /*   work operators up stack until precedence is in order. */
214 /*   seperate evaluators for boolean and arithmetic operators. */
215 label_460:
216           if (tbool ^= 0) then go to label_600;
217 
218 /*   arithmetic operator, branch on type. */
219 label_500:
220           l1 = lstk (i-2);
221           l2 = lstk (i);
222           if (op = iplus) then go to label_510;
223           if (op = iminus) then go to label_520;
224           if (op = istar) then go to label_530;
225           if (op = islash) then go to label_540;
226           if (op = eb_data_$ineg) then go to label_550;
227           if (op = eb_data_$ilend) then go to label_900;
228           go to label_800;
229 
230 /*   evaluate binary +. */
231 label_510:
232           stk (i-2) = stk (i-2)+stk (i);
233           if (l1 ^= 0 & l2 ^= 0) then tbad = 1;             /* TRUE */;
234           if (l1+l2 = 0) then vlc = 0;
235           if (l1 ^= 0) then vlc = l1;
236           if (l2 ^= 0) then vlc = l2;
237           go to label_700;
238 
239 /*   evaluate binary -. */
240 
241 /*   special patch has been added to permit */
242 /*   the evaluation of a difference when the */
243 /*   symbols are both relocatable and in the */
244 /*   same segment but are defined under different */
245 /*   location counters. in this case the result */
246 /*   is modified by adding the difference between */
247 /*   the origins of the two location counters. */
248 label_520:
249           stk (i-2) = stk (i-2)-stk (i);
250           if (^(tpass2 ^= 0 & l1 ^= 0 & l2 ^= 0)) then go to label_525;
251           if (glpl_$crh (l1+4) ^= glpl_$crh (l2+4)) then tbad = 1; /* TRUE */;
252           stk (i-2) = stk (i-2) + (glpl_$clh (l1+3)-glpl_$clh (l2+3));
253           vlc = 0;
254           go to label_700;
255 label_525:
256 
257 
258           if (l2 ^= 0 & l1 ^= l2) then tbad = 1;            /* TRUE */;
259           if (l1+l2 = 0) then vlc = 0;
260           if (l1 ^= 0 & l2 = 0) then vlc = l1;
261           if (l1 ^= 0 & l2 ^= 0) then vlc = 0;
262           go to label_700;
263 
264 /*   evaluate binary *. */
265 label_530:
266           stk (i-2) = stk (i-2)*stk (i);
267           if (l1+l2 ^= 0) then tbad = 1;                    /* TRUE */;
268           vlc = 0;
269           go to label_700;
270 
271 /*   evaluate binary /. */
272 label_540:
273           if (stk (i) ^= 0) then stk (i-2) = divide (stk (i-2), stk (i), 17, 0);
274           if (l1+l2 ^= 0) then tbad = 1;                    /* TRUE */;
275           vlc = 0;
276           go to label_700;
277 
278 /*   evaluate unary -. */
279 label_550:
280           stk (i-1) = -stk (i);
281           if (lstk (i) ^= 0) then tbad = 1;                 /* TRUE */;
282           vlc = 0;
283           go to label_710;
284 
285 
286 /*   boolean operator, branch on type. */
287 label_600:
288           if (op = iplus) then go to label_610;
289           if (op = iminus) then go to label_620;
290           if (op = istar) then go to label_630;
291           if (op = islash) then go to label_640;
292           if (op = icflx) then go to label_640;
293           if (op = eb_data_$inot) then go to label_650;
294           if (op = eb_data_$ilend) then go to label_900;
295           go to label_800;
296 
297 /*   evaluate boolean .or. function. */
298 label_610:
299           unspec (stk (i-2)) = unspec (stk (i-2)) | unspec (stk (i)) ;
300           go to label_700;
301 
302 /*   evaluate boolean .xor. function. */
303 label_620:
304           unspec (stk (i-2)) = bool (unspec (stk (i-2)), unspec (stk (i)), "0110"b) ;
305           go to label_700;
306 
307 /*   evaluate boolean .and. function. */
308 label_630:
309           unspec (stk (i-2)) = unspec (stk (i-2)) & unspec (stk (i)) ;
310           go to label_700;
311 
312 /*   evaluate boolean .and not. function. */
313 label_640:
314           unspec (stk (i-2)) = unspec (stk (i-2)) & ^unspec (stk (i)) ;
315           go to label_700;
316 
317 /*   evaluate boolean .not. function. */
318 label_650:
319           stk (i-1) = -1 - stk (i) ;
320           go to label_710;
321 
322 
323 /*   termination for binary operator evaluation, reduce stack */
324 /*   level, and go test new operator. */
325 label_700:
326           lstk (i-2) = vlc;
327           i = i-2;
328           if (i >= 2) then go to label_420;
329           go to label_800;
330 
331 /*   termination for unary operations in stack. */
332 label_710:
333           lstk (i-1) = vlc;
334           i = i-1;
335           if (i >= 2) then go to label_420;
336           go to label_800;
337 
338 
339 /*   phase error return. */
340 label_800:
341           prntf = 1;                                        /* TRUE */
342           expevl_answer = 0;                                /* FALSE */
343 label_810:
344           inexp = 0;
345           lc = 0;
346           return ;
347 
348 
349 /*   normal termination return, answer is stk(2). */
350 label_900:
351           inexp = stk (2);
352           if (tbad ^= 0) then go to label_910;
353           lc = lstk (2);
354           return ;
355 
356 /* invalid operator-operand modes somewhere in evaluation */
357 label_910:
358           lc = 0;
359           if tpass1 = 0 then prntr = 1;
360           expevl_answer = 0;                                /* FALSE */;
361           return ;
362 
363 
364      end expevl_;