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 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(88-01-29,RWaters), approve(88-01-29,MCR7724), audit(88-02-05,Huen),
 17      install(88-02-16,MR12.2-1024):
 18      Changed to use assign_.
 19                                                    END HISTORY COMMENTS */
 20 
 21 
 22 /* Procedure to evaluate operator with constant operands.
 23 
 24    Preliminary version deals only with decimal integers and returns an operator
 25    node if other types of constants appear
 26 
 27    Initial Version: 16 October 1972 by BLW
 28           Modified: 11 December 1976 by RAB for ||
 29           Modified: 28 January 1988 by RW to use assign_
 30 */
 31 
 32 evaluate: proc(opcode,r2,r3) returns(ptr);
 33 
 34 dcl       opcode bit(9) aligned,
 35           (r2,r3) ptr;
 36 
 37 dcl       q ptr,
 38           ans char(32) aligned,
 39           (i,n,prec,prec2,prec3) fixed bin(35);
 40 
 41 dcl       (v2,v3) fixed decimal (31);
 42 dcl       v fixed decimal (50);
 43 dcl       v_chars char (51) based (addr (v));
 44 
 45 dcl       string_max fixed bin int static init(256);
 46 
 47 dcl       (substr,length,max) builtin;
 48 
 49 dcl       assign_ entry (ptr, fixed bin, fixed bin(35), ptr, fixed bin, fixed bin(35));
 50 
 51 %include op_codes;
 52 %include operator;
 53 %include token;
 54 %include token_types;
 55 %include language_utility;
 56 %include std_descriptor_types;
 57 
 58           if opcode = cat_string then go to concatenate;
 59 
 60           if opcode >= div
 61           then do;
 62 make:          q = create_operator(opcode,3);
 63                q -> operand(2) = r2;
 64                q -> operand(3) = r3;
 65                return(q);
 66                end;
 67 
 68           if r2 -> token.type ^= r3 -> token.type then goto make;
 69 
 70           if r2 -> token.type ^= dec_integer then goto make;
 71 
 72           if r2 -> token.loc ^= r3 -> token.loc
 73           then go to make;                                  /* require "p" flag to be same */
 74 
 75           prec2 = length(r2 -> token.string);
 76           prec3 = length(r3 -> token.string);
 77 
 78           if prec2 > 31 | prec3 > 31 then goto make;
 79 
 80           call assign_ (addr (v2), real_fix_dec_9bit_ls_dtype*2, 31,
 81                addr (r2 -> token.string), char_dtype*2, prec2);
 82           call assign_ (addr (v3), real_fix_dec_9bit_ls_dtype*2, 31,
 83                addr (r3 -> token.string), char_dtype*2, prec3);
 84 
 85           if opcode = add
 86           then v = v2 + v3;
 87 
 88           else if opcode = sub
 89                then v = v2 - v3;
 90                else v = v2 * v3;
 91 
 92 /* determine the resultant precision needed. */
 93 
 94           i = verify (substr (v_chars, 2), "0");
 95           prec = max (length (v_chars)-i, 1);
 96 
 97           if substr (v_chars, 1, 1) ^= "-" then
 98                return (create_token$protected (substr (v_chars, length (v_chars)-prec+1, prec), dec_integer, (r2 -> token.loc)));
 99           else return (create_token$protected ("-" || substr (v_chars, length (v_chars)-prec+1, prec), dec_integer, (r2 -> token.loc)));
100 
101 
102 concatenate:
103           if r2 -> token.type ^= r3 -> token.type then goto make;
104 
105           if r2 -> token.type = char_string
106           then prec2 = length(r2 -> token.string);
107           else if r2 -> token.type = bit_string
108                then prec2 = length(r2 -> token.string) - 1;
109                else go to make;
110 
111           if prec2 + length(r3 -> token.string) > string_max
112                then go to make;
113 
114           return(create_token(substr(r2 -> token.string,1,prec2) || r3 -> token.string, (r2 -> token.type)));
115           end;