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 /* this procedure compiles arithmetic expressions
 12 
 13    Initial Version:  5 October, 1968 by BLW
 14           Modified: 24 May, 1971 by BLW for Version II
 15           Modified: 21 January, 1973 by BLW
 16           Modified: 8 November 1973 by RAB for fixed divide
 17           Modified: 16 September 1974 by RAB for bug 1230 (float divide)
 18           Modified: 24 September 1975 by RAB for bug 1424
 19           Modified: 29 October 1975 by RAB to check p3 in q
 20           Modified: 2 April 1976 by RHS to improve code for constant*2
 21           Modified: 9 March 1978 by RAB to check p3 in q for floating divide    */
 22 
 23 arith_op: proc(node_pts,refs,atom);
 24 
 25 dcl       node_pts  ptr,                /* points at operator node */
 26           refs(3)   ptr,                /* ptrs to ref nodes of operands */
 27           atom(3)   bit(1) aligned;     /* ON is operand is atomic */
 28 
 29 dcl       node_pt   ptr defined(node_pts),
 30           ref(3)    ptr defined(refs);
 31 
 32 dcl       (p,p1,p2,p3,q2,q3) ptr,
 33           complex_stuff$complex_stuff fixed bin ext,
 34           based_int fixed bin(18) based,
 35           (type1,type2,type3,scale1,scale2,scale3,op,k,rev,comp,max_type,op_code,n) fixed bin(15),
 36           shift fixed bin,
 37           (check_scale,check_type,mult_scaled,reversed) bit(1) aligned,
 38           negate_op(4) fixed bin(15) int static initial(255,38,39,39),
 39           load entry(ptr,fixed bin(15)),
 40           power_of_two entry(fixed bin(18)) returns(fixed bin(18)),
 41           c_a entry(fixed bin,fixed bin) returns(ptr),
 42           expmac$interpret entry(fixed bin,ptr,(3) ptr,(3) bit(1) aligned),
 43           expmac entry(fixed bin(15),ptr),
 44           expmac$zero entry(fixed bin(15)),
 45           expmac$abs entry(ptr,fixed bin),
 46           compile_exp entry(ptr),
 47           (compile_exp$save,compile_exp$save_exp,compile_exp$save_float_2,copy_temp) entry(ptr) returns(ptr);
 48 
 49 dcl       (fixed_to_float,float_to_fixed) entry(ptr),
 50           compile_exp$save_fix_scaled entry(ptr,fixed bin(15),fixed bin(15)) returns(ptr),
 51           aq_man$fix_scale entry(ptr,fixed bin(15),fixed bin(15));
 52 
 53 dcl       divide_fx1 init(535) fixed bin(15) int static;
 54 
 55 dcl       (addr,fixed,max,mod) builtin;
 56 
 57 dcl       1 arith_data$fixed(3) ext static,
 58           2 left_type(2),
 59           3 right_type(2),
 60           4 body              fixed bin(15),
 61           4 rev               fixed bin(15),
 62           4 comp              fixed bin(15),
 63 
 64           1 fix_info          based(p),
 65           2 body              fixed bin(15),
 66           2 rev               fixed bin(15),
 67           2 comp              fixed bin(15);
 68 
 69 dcl (     add_op              init(1),
 70           sub_op              init(2),
 71           mult_op             init(3),
 72           div_op              init(4)) fixed bin int static;
 73 
 74 
 75 %include reference;
 76 %include operator;
 77 %include symbol;
 78 %include data_types;
 79 %include op_codes;
 80 %include "645op2";
 81 %include "645op3";
 82 
 83 dcl (     fx1_to_fl2          init(122),
 84           fl2_to_fx2          init(125)) fixed bin(15) int static;
 85 
 86 
 87 begin:    p1 = ref(1);
 88 
 89           reversed,
 90           mult_scaled,
 91           check_type,
 92           check_scale = "0"b;
 93 
 94           p2 = ref(2);
 95 
 96           p = node_pt;
 97           q2 = p -> operand(2);
 98 
 99           if p1 -> reference.symbol -> symbol.complex
100           then do;
101                call expmac$interpret(complex_stuff$complex_stuff,node_pt,refs,atom);
102                return;
103                end;
104 
105           type1 = p1 -> reference.data_type;
106           type2 = p2 -> reference.data_type;
107 
108           /* check for special attention */
109 
110           if p -> operator.op_code = negate then goto neg_op;
111 
112           p3 = ref(3);
113           q3 = p -> operand(3);
114 
115           op_code = fixed(p -> operator.op_code,9) - 16;
116 
117           type3 = p3 -> reference.data_type;
118 
119           /* if p3 is in q, try to flip_rands */
120 
121           if p3 -> reference.value_in.q
122           then if atom(2)
123           then if op_code ^= sub_op
124           then if op_code ^= div_op
125           then if atom(3)
126           then do;
127                call flip_rands;
128                reversed = "0"b;
129                end;
130 
131           /* get information for this combination of operator
132              and data types */
133 
134           if type1 >= real_flt_bin_1
135           then do;
136 
137                /* have floating point operation, we use the
138                   manner in which macro values are coded to
139                   calculate the appropriate macro to use */
140 
141                max_type = type1;
142                rev, comp = 0;
143                op = adfl1 + 2 * op_code - real_flt_bin_1 - 2;
144 
145                if op_code = 4
146                then do;
147 
148                     /* have floating divide, must avoid FDV & FDI
149                        instructions for double precision result
150                        (fixes bug 1230) */
151 
152                     if type1 > type2
153                     then do;
154                          atom(2) = "0"b;
155                          check_type = "1"b;
156                          end;
157 
158                     if type1 > type3
159                     then do;
160                          atom(3) = "0"b;
161                          check_type = "1"b;
162                          end;
163 
164                     /* if p3 is in q, try to flip rands and use inverted divide */
165 
166                     if p3 -> reference.value_in.q & atom(2) & atom(3)
167                     then do;
168                          call flip_rands;
169                          op = op + 2;
170                          end;
171                     end;
172                end;
173           else do;
174 
175                /* have fixed point operation; all division (except
176                   for fx1/fx1) is handled by external
177                   operator */
178 
179                scale1 = p1 -> reference.symbol -> symbol.scale;
180                scale2 = p2 -> reference.symbol -> symbol.scale;
181                scale3 = p3 -> reference.symbol -> symbol.scale;
182 
183                if op_code ^= div_op then goto normal;
184 
185                if scale1 ^= 0 then goto punt;
186                if scale2 ^= 0 then goto punt;
187                if scale3 ^= 0 then goto punt;
188 
189 
190                if max(type1,type2,type3) = real_fix_bin_1
191                then do;
192                     k = type2;
193                     goto gi;
194                     end;
195 
196 punt:          if ^ atom(3) then p3 = compile_exp$save(q3);
197                if atom(2) then call load(p2,0); else call compile_exp(q2);
198                op = divide_fx1 + 2*type2 + type3 - 3;
199                shift = scale1 - (scale2 - scale3);
200                call expmac(op,p3);
201                call expmac$abs(addr(shift),1);
202                return;
203 
204 normal:        if op_code = mult_op
205                then do;
206                     k = type2;
207                     if scale1 ^= scale2 + scale3
208                          then mult_scaled = "1"b;
209                     end;
210 
211                else do;
212                     max_type = max(type2,type3);
213                     if max_type = real_fix_bin_1 & type1 = real_fix_bin_2
214                     then k = real_fix_bin_2; else k = type2;
215 
216                     if scale1 ^= scale2
217                     then do;
218                          atom(2) = "0"b;
219                          check_scale = "1"b;
220                          end;
221 
222                     if scale1 ^= scale3
223                     then do;
224                          atom(3) = "0"b;
225                          check_scale = "1"b;
226                          end;
227 
228                     end;
229 
230 gi:            call get_information;
231                end;
232 
233           /* dispatch on form of operands */
234 
235           goto arith_switch(fixed(atom(2) || atom(3),2));
236 
237           /* both operands are atomic.  check to see if body of
238              operation takes left operand instead of right */
239 
240 arith_switch(3):
241 atm_atm:  if rev > 0
242           then do;
243 faa:           call flip_rands;
244                goto aa_2;
245                end;
246 
247           if op_code = mult_op
248           then if type1 = real_fix_bin_1
249                then if p2 -> reference.symbol -> symbol.constant
250                     then if ^p3->reference.symbol->symbol.constant
251                          then goto faa;
252                          else if power_of_two(p2->reference.symbol->symbol.initial->based_int) ^= 0
253                               then goto faa;
254 
255           /* expand load(p2) and body(p3) */
256 
257 aa_2:     call load(p2,comp);
258 
259 aa_3:     if op_code <= sub_op
260           then do;
261                if check_scale
262                     then max_type = max(type2,type3);
263 
264                if max_type < type1
265                     then call expmac$zero(rfb1_to_rfb2);
266                end;
267 
268           if type1 >= real_flt_bin_1 then op = op + type3;
269 aa_4:     call expmac(op,p3);
270 
271           if mult_scaled
272           then do;
273                p1 -> reference.symbol -> symbol.scale = scale2 + scale3;
274                call aq_man$fix_scale(p1,scale1,type1);
275                p1 -> reference.symbol -> symbol.scale = scale1;
276                end;
277 
278           return;
279 
280           /* expressions on both sides, the case real_fix_bin_1 - real_fix_bin_2
281              is given special treatment */
282 
283 arith_switch(0):
284 exp_exp:  if op_code ^= sub_op then goto ee_0;
285 
286           if type1 >= real_flt_bin_1 then goto ee_0;
287 
288           if type2 < type3 & ^ check_scale
289           then do;
290                p2 = compile_exp$save(q2);
291                call compile_exp(q3);
292                call expmac$zero(negl);
293                call expmac(adfx3,p2);
294                return;
295                end;
296 
297           /* both operands are expressions, evaluate right expression
298              and store in a temporary, then treat like exp_atm case */
299 
300 ee_0:     if rev > 0 then call flip_rands;
301 
302           if check_scale & scale1 ^= scale3
303           then do;
304                p3 = compile_exp$save_fix_scaled(q3,scale1,type1);
305                type3 = type1;
306                call get_info;
307                if reversed
308                then if rev = 0
309                     then do;
310                          call flip_rands;
311                          go to atm_exp;
312                          end;
313                end;
314           else if check_type & type1 > type3
315                then do;
316                     p3 = compile_exp$save_float_2(q3);
317                     type3 = type1;
318                     end;
319                else p3 = compile_exp$save(q3);
320 
321           goto ea_0;
322 
323           /* left operand is atomic, right is an expression. */
324 
325 arith_switch(2):
326 atm_exp:  goto ae_switch(op_code);
327 
328           /* operation is addtion */
329 
330 ae_switch(1):
331 ae_add:   call flip_rands;
332           goto ea_0;
333 
334           /* operation is multiplication */
335 
336 ae_switch(3):
337 ae_mpy:   if type2 = real_fix_bin_1
338           then if type3 = real_fix_bin_2
339                then rev = 1; else;
340           else if type2 = real_fix_bin_2
341                then if type3 = real_fix_bin_1
342                     then rev = 0;
343 
344           goto ae_gen;
345 
346           /* operation is subtraction, evaluate expression and
347              save if fixed single */
348 
349 ae_switch(2):
350 ae_sub:   if type3 = real_fix_bin_1
351           then do;
352 ae_sub_1:      if check_scale & scale1 ^= scale3
353                then do;
354                     p3 = compile_exp$save_fix_scaled(q3,scale1,type1);
355                     type3 = type1;
356                     call get_info;
357                     end;
358                else p3 = compile_exp$save(q3);
359 
360                goto aa_2;
361                end;
362 
363           call compile_exp(q3);
364 
365           if check_scale & scale1 ^= scale3
366           then do;
367                call aq_man$fix_scale(p3,scale1,type1);
368                type3 = type1;
369                call get_info;
370                end;
371 
372           k = 1 - mod(type2,2);
373           if type3 >= real_flt_bin_1
374           then op = adfl1 + k;
375           else op = adfx3 - k;
376 
377           /* we use the fact that:
378                real_fix_bin_2 = real_fix_bin_1+1
379                real_flt_bin_2 = real_flt_bin_1+1
380              and the fact that:
381                mod(real_fix_bin_1,2) = mod(real_fix_bin_2,2) = 1;
382 
383              Thus we generate op for single precision atom,
384              and op+|-1 for double precision atom      */
385 
386           call expmac$zero(negate_op(type3));
387           call expmac(op,p2);
388           return;
389 
390           /* operation is division.  evaluate expression and
391              save if fixed point or use inverse divide if floating */
392 
393 ae_switch(4):
394 ae_div:   if type1 <= real_fix_bin_2
395           then do;
396                p3 = compile_exp$save(q3);
397                goto aa_2;
398                end;
399 
400           op = op+2;
401 
402           /* for general operation, reverse operands */
403 
404 ae_gen:   call flip_rands;
405 
406           /* left operand is an expression, right is atomic. */
407 
408 arith_switch(1):
409 exp_atm:  if check_scale & scale1 ^= scale2
410           then do;
411                type2 = type1;
412                call get_info;
413                end;
414 
415           if rev > 0
416           then do;
417                if check_scale & scale1 ^= scale2
418                then p2 = compile_exp$save_fix_scaled(q2,scale1,type1);
419                else p2 = compile_exp$save(q2);
420 
421                call flip_rands;
422                goto aa_2;
423                end;
424 
425 ea_0:     call compile_exp(q2);
426 
427           if check_scale & scale1 ^= scale2
428           then do;
429                call aq_man$fix_scale(p2,scale1,type1);
430                type2 = type1;
431                call get_info;
432                end;
433 
434           if op_code = add_op
435           then do;
436                if type2 ^= real_fix_bin_1 then goto aa_3;
437                if type3 ^= real_fix_bin_2 then goto aa_3;
438                call expmac$zero(rfb1_to_rfb2);
439                op = adfx2;
440                goto aa_4;
441                end;
442 
443           if comp > 0 then call expmac$zero(negate_op(type2));
444           goto aa_3;
445 
446           /* negation operator */
447 
448 neg_op:   if atom(2)
449           then do;
450 
451                /* set k = 3 if double length atom and 1 otherwise */
452 
453                if mod(type2,2) = 0 then k = 3; else k = 1;
454                call load(p2,k);
455                end;
456           else do;
457 
458                /* have expression */
459 
460                call compile_exp(q2);
461                call expmac$zero(negate_op(type1));
462                end;
463           return;
464 
465 flip_rands:    proc;
466 
467                /* this procedure is called to reverse the operands of a node */
468 
469                dcl p ptr,t fixed bin,b bit(1) aligned;
470 
471                p = p2; p2 = p3; p3 = p;
472                p = q2; q2 = q3; q3 = p;
473                t = type2; type2 = type3; type3 = t;
474                t = scale2; scale2 = scale3; scale3 = t;
475                b = atom(2); atom(2) = atom(3); atom(3) = b;
476                reversed = ^ reversed;
477 
478                end;
479 
480 get_info:      proc;
481 
482 dcl            j fixed bin,
483                info_pt ptr;
484 
485                j = type2;
486                goto common;
487 
488 get_information: entry;
489 
490                j = k;
491 
492 common:        info_pt = addr(arith_data$fixed(op_code).left_type(j).
493                 right_type(type3));
494                op = info_pt -> fix_info.body;
495                rev = info_pt -> fix_info.rev;
496                comp = info_pt -> fix_info.comp;
497                end;
498 
499           end;