1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  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 /****^  HISTORY COMMENTS:
 15   1) change(1974-01-27,BWolman), approve(), audit(), install():
 16      Initial version by Barry L. Wolman.
 17   2) change(1976-07-08,Herbst), approve(), audit(), install():
 18      Fixed min and others to operate with no args.
 19   3) change(2021-12-05,GDixon), approve(2022-07-13,MCR10101),
 20      audit(2022-07-27,Swenson):
 21       A) Use cv_fixed_point_string_ to convert input numbers to float dec(59)
 22          data type, thereby supporting inputs in non-decimal bases.
 23       B) Add the round command/active function.
 24                                                    END HISTORY COMMENTS */
 25 
 26 
 27 /* Arithmetic active functions
 28 
 29           FUNCTION                      VALUE
 30           plus A1 A2 ... An             0 + A1 + A2 + ... + An
 31           minus A1 A2                   A1 - A2  or  -A1 if A2 is not specified
 32           times A1 A2 ... An            1 * A1 * A2 * ... * An
 33           divide A1 A2                  trunc(A1 / A2)
 34           quotient A1 A2                A1 / A2
 35           mod A1 A2                     mod(A1,A2)
 36           max A1 A2 ... An              max(A1,A2, ..., An)
 37           min A1 A2 ... An              min(A1,A2, ..., An)
 38           trunc A1                      trunc(A1)
 39           floor A1                      floor(A1)
 40           ceil A1                       ceil(A1)
 41           round A1 A2                   round(A1, A2)
 42 
 43    Each Ai is the character string representation of either:
 44      - a valid PL/I decimal number (either fixed or float), or
 45      - a valid fixed-point number expressed in a base from 2 to 16.
 46 
 47    Calculations are performed internally using float dec(59) arithmetic.
 48 
 49    The result is in I-, F-, or E-format depending on its value.
 50 
 51    All of these active functions can be called as functions or as commands,
 52    in which case they print the result.
 53 
 54    --------------------------------------------------------------------------- */
 55 
 56 plus:     proc;
 57 
 58 dcl       op char(8) var,
 59           (number1,number2) float dec(59),
 60           prec_fixed fixed bin,
 61           result char(72) varying,
 62           code fixed bin(35),
 63           not_active_function bit(1),
 64           (i,count) fixed bin,
 65           get_arg variable entry(fixed bin,ptr,fixed bin,fixed bin(35)),
 66           (ap,ap1) ptr,
 67           (al,al1) fixed bin,
 68           answer char(al1) varying based(ap1),
 69           arg char(al) based(ap),
 70           (mod,max,min,fixed,string,trunc,floor,ceil) builtin,
 71           (conversion, overflow, underflow, zerodivide) condition;
 72 
 73 dcl       BASE_10 fixed bin int static options (constant) init (10);
 74 
 75 dcl       (cu_$arg_ptr,cu_$af_arg_ptr,cu_$af_return_arg) entry(fixed bin,ptr,fixed bin,fixed bin(35)),
 76           cu_$arg_count entry returns(fixed bin),
 77           cv_condition_$display entry (char(*), char(32) var),
 78           cv_fixed_point_string_ entry (char(*), fixed bin, bit(*), fixed bin(35)) returns(float dec(59)),
 79           move_r_or_t_ entry(float dec(59), float dec(59), fixed bin),
 80           numeric_to_ascii_ entry(float dec(59),fixed bin,char(72) varying),
 81           (ioa_,com_err_,active_fnc_err_) options(variable),
 82           gripe entry variable options(variable);
 83 
 84 dcl       (error_table_$not_act_fnc,
 85            error_table_$wrong_no_of_args) fixed bin(35) ext static;
 86 
 87 dcl       1 op_type,
 88           2 multi   bit(1) unaligned,                       /* More than 2 arguments supported.                       */
 89           2 unary   bit(1) unaligned;                       /* Only 1 argument allowed.                               */
 90 %page;
 91           op = "plus";
 92           string(op_type) = "11"b;
 93           goto join;
 94 
 95 minus:    entry;
 96 
 97           op = "minus";
 98           string(op_type) = "00"b;
 99           goto join;
100 
101 times:    entry;
102 
103           op = "times";
104           string(op_type) = "11"b;
105           goto join;
106 
107 divide:   entry;
108 
109           op = "divide";
110           string(op_type) = "00"b;
111           goto join;
112 
113 quotient: entry;
114 
115           op = "quotient";
116           string(op_type) = "00"b;
117           goto join;
118 
119 mod:      entry;
120 
121           op = "mod";
122           string(op_type) = "00"b;
123           goto join;
124 
125 max:      entry;
126 
127           op = "max";
128           string(op_type) = "10"b;
129           goto join;
130 
131 min:      entry;
132 
133           op = "min";
134           string(op_type) = "10"b;
135           goto join;
136 
137 trunc:    entry;
138 
139           op = "trunc";
140           string(op_type) = "01"b;
141           goto join;
142 
143 floor:    entry;
144 
145           op = "floor";
146           string(op_type) = "01"b;
147           goto join;
148 
149 ceil:     entry;
150 
151           op = "ceil";
152           string(op_type) = "01"b;
153           goto join;
154 
155 round:    entry;
156 
157           op = "round";
158           string(op_type) = "00"b;
159           goto join;
160 %page;
161 join:     call cu_$af_return_arg(count,ap1,al1,code);
162 
163           not_active_function = code = error_table_$not_act_fnc;
164 
165           if not_active_function
166           then do;
167                count = cu_$arg_count();
168                get_arg = cu_$arg_ptr;
169                gripe = com_err_;
170                code = 0;
171                end;
172           else do;
173                if code ^= 0 then go to simple_err;
174 
175                get_arg = cu_$af_arg_ptr;
176                gripe = active_fnc_err_;
177                end;
178 
179           if count = 0 then do;
180                if op = "plus" | op = "minus" then number1 = 0;
181                else if op = "times" then number1 = 1;
182                else go to wrong_args;
183                go to output;
184           end;
185 
186           if (count ^= 1 & unary & ^ multi)
187            | (count < 2 & ^ unary & op ^= "minus")
188            | (count > 2 & ^ multi)
189           then do;
190 wrong_args:    code = error_table_$wrong_no_of_args;
191 simple_err:    call gripe (code, op);
192                go to exit;
193                end;
194 
195           on overflow goto too_big;
196           on underflow goto too_small;
197           on zerodivide goto zero_divide;
198 
199           on conversion begin;
200                call cv_condition_$display( (op), "" );
201                goto exit;
202                end;
203 
204           call get_arg(1,ap,al,code);
205           if code ^= 0 then do;
206                call gripe(code, op, "Numeric argument.");
207                goto exit;
208                end;
209 
210           number1 = cv_fixed_point_string_( arg, BASE_10, FIXED_POINT_SIG_EXP_CONVERT_DEC, code );
211 
212           if count = 1 & op = "minus" then number1 = -number1;
213 
214           if unary
215           then do;
216                if op = "trunc" then number1 = trunc(number1);
217                if op = "floor" then number1 = floor(number1);
218                if op = "ceil" then number1 = ceil(number1);
219                end;
220 
221           do i = 2 to count;
222                call get_arg(i,ap,al,code);
223                if code ^= 0 then do;
224                     call gripe(code, op, "Second numeric argument.");
225                     goto exit;
226                     end;
227 
228                number2 = cv_fixed_point_string_( arg, BASE_10, FIXED_POINT_SIG_EXP_CONVERT_DEC, code );
229 
230                if op = "plus" then number1 = number1 + number2;
231                if op = "minus" then number1 = number1 - number2;
232                if op = "times" then number1 = number1 * number2;
233                if op = "divide" then number1 = trunc (number1 / number2);
234                if op = "quotient" then number1 = number1 / number2;
235                if op = "mod" then number1 = mod(number1, number2);
236                if op = "max" then number1 = max(number1, number2);
237                if op = "min" then number1 = min(number1, number2);
238                if op = "round" then do;                     /* PL/1 round built-in accepts only a constant 2nd op     */
239                                                             /*  between 1 and 59 when 1st operand is float dec(59).   */
240                     number2 = abs(trunc(number2));          /*  - Convert number2 to non-negative integer.            */
241                     number2 = min(59.0, number2);           /*     which is between 0 and 59                          */
242                     prec_fixed = number2;                   /*  - Convert to fixed bin data type required by          */
243                                                             /*     move_r_or_t_ so we can reuse number2 as temporary  */
244                                                             /*     target of specified precision.                     */
245                     if prec_fixed > 0 then do;              /*  - Copy:                                               */
246                          number2 = number1;                 /*      number1 => number2                                */
247                          call move_r_or_t_(number1, number2, prec_fixed);
248                          end;                               /*      number2 => round(number1,prec_fixed)              */
249                     end;
250                end;
251 
252 output:
253           call numeric_to_ascii_(number1,0,result);
254           if substr (result, 1, 1) = "0" & length (result) > 60 then do;        /* trim it so it will work better */
255                result = substr (result, 1, length (result) - 1);
256                end;
257 
258           if not_active_function then call ioa_(result);
259           else answer = result;
260 
261           return;
262 
263 zero_divide:
264           call gripe(0,op,"Attempt to divide by zero.");
265           goto exit;
266 
267 too_big:
268           call gripe(0,op,"Exponent overflow");
269           goto exit;
270 
271 too_small:
272           call gripe(0,op,"Exponent underflow");
273           goto exit;
274 
275 exit:     return;
276 %page;
277 %include cv_fixed_point_string_;
278 
279 end plus;
280