1 /****^  ************************************************************
  2         *                                                          *
  3         * Copyright, (C) Honeywell Bull Inc., 1989                 *
  4         *                                                          *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982  *
  6         *                                                          *
  7         * Copyright, (C) Honeywell Information Systems Inc., 1980. *
  8         *                                                          *
  9         ************************************************************ */
 10 
 11 
 12 
 13 /****^  HISTORY COMMENTS:
 14   1) change(1988-10-19,Lee), approve(1988-11-21,MCR8025),
 15      audit(1988-12-23,Flegel), install(1989-01-23,MR12.3-1010):
 16      Commands 421 (phx09588, phx18231) - modified to not set up a pi
 17      handler if it is being invoked as an active function.
 18   2) change(1988-10-19,Lee), approve(1988-11-21,MCR8025),
 19      audit(1988-12-23,Flegel), install(1989-01-23,MR12.3-1010):
 20      Commands 464 (phx10119, phx20071) - modified to complain about
 21      invalid characters specified in function names.
 22   3) change(1988-10-19,Lee), approve(1988-11-21,MCR8025),
 23      audit(1988-12-23,Flegel), install(1989-01-23,MR12.3-1010):
 24      Commands 805 (phx21221) - modified to accept "reasonable" variable
 25      names and to clean up invalid variables left after an error occurs.
 26   4) change(2021-12-03,GDixon), approve(2022-07-13,MCR10101),
 27      audit(2022-07-27,Swenson):
 28      Upgrade calc from version 1.1 to version 2.0.  This version:
 29       A) Changes the data type used by calc from float bin(27) to
 30          float dec(59) permitting calc to support: more precise calculations
 31          (up to 59 decimal digits); a broader range of exponents (from
 32          1.0E-128 to 1.0E+127).
 33       B) Calls cv_fixed_point_string_ to convert numeric strings to
 34          the float dec(59) data type.  This program supports inputs in
 35          numeric bases from 2 (binary) through 16 (hexadecimal) when the
 36          numeric string ends with a radix indicator.
 37       C) Provide a more detailed description of errors found when converting
 38          a numeric string to a float dec(59) number.
 39       D) Calls numeric_to_ascii_ to convert float dec(59) values to display
 40          format.
 41       E) Adds db_on and db_off requests to display push-down stack as an
 42          aid in analyzing EXPRESSION errors and calc bugs.
 43       F) Changes overflow, fixedoverflow and underflow on-units to
 44          automatically display push-down stack as an aid to explaining the
 45          condition.  This occurs only if invoked as calc subsystem, and
 46          only when db_on has not been given explicitly.
 47       G) Follow the PL/I definition for log(x):  it now implements ln(x)
 48          (otherwise known as the natural logarithm of x).  ln(x) is retained
 49          for compatibility.
 50       H) Adds log10(x) to implement log to base 10 of x.
 51       I) Adds log2(x)  to implement log to base 2  of x.
 52                                                    END HISTORY COMMENTS */
 53 
 54 
 55 
 56 /* The calc command provides the user with a calculator capable of evaluatiing PL/I-like expressions */
 57 /* with operator precedence, a set of often used functions, and an addressable-by-identifier memory. */
 58 
 59 /* Changed to work as an active function by S. Herbst 10/07/78 */
 60 /* Handlers added for pi, oveflow, underflow 09/28/79 S. Herbst */
 61 /* . and .. features added 12/12/79 S. Herbst */
 62 /* Red & black shifts removed, "q =" bug fixed 04/14/80 S. Herbst */
 63 /* Fixed not to prompt with a space 01/12/81 S. Herbst */
 64 
 65 /* format: style4,ind3 */
 66 
 67 calc: proc;
 68 
 69 dcl  arg char (arg_len) based (arg_ptr);
 70 dcl  return_string char (return_len) varying based (return_ptr);
 71 
 72 dcl (F init("0"b), T init("1"b)) bit(1) aligned int static options(constant);
 73 dcl  (af_sw, expr_arg_sw) bit (1) aligned;
 74 dcl  debug_sw bit(1) aligned internal static init(F);
 75 
 76 dcl  (arg_ptr, return_ptr) ptr;
 77 
 78 dcl  arg_count fixed bin;
 79 dcl  (arg_len, return_len) fixed bin (21);
 80 
 81 dcl  error_table_$not_act_fnc fixed bin (35) ext;
 82 
 83 dcl  (active_fnc_err_, active_fnc_err_$af_suppress_name) entry options (variable);
 84 dcl  (com_err_, com_err_$suppress_name) entry options (variable);
 85 dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 86 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 87 
 88 
 89 dcl  (calls, ss, fv, fv_save) fixed bin (17);
 90 dcl  code fixed bin (35);
 91 dcl  condition_name char(32) var;
 92 dcl  dum float dec (59);
 93 dcl  num fixed bin (21);
 94 dcl  (sv, iptr, fvp, vp) ptr;
 95 dcl  floatval float dec (59) based (fvp);
 96 dcl  funcs (0:12) char (8) var int static options (constant) init (
 97        "sind", "sin", "cosd", "cos", "tand", "tan", "atand", "atan", "abs", "log10", "log2", "ln", "log");
 98                                                             /* Array searched from index 0 ... N so funcs containing */
 99                                                             /*  another func name must appear BEFORE that function:  */
100                                                             /*   "sind" must appear in list BEFORE "sin", etc.       */
101 dcl  varname char(8) aligned based;
102 dcl  in char (1300) unaligned;
103 dcl  out char (256) var;
104 dcl  1 space aligned like vars;
105 dcl  error_string char (600) var;
106 dcl  (noprt, ileq) bit (1) aligned;
107 dcl  LPAREN_INCREASES_PRECEDENCE init(5) fixed bin int static options(constant);
108 dcl  NL char (1) aligned int static options (constant) init ("
109 ");
110 dcl  SP char (1) aligned int static options (constant) init (" ");
111 dcl  var_name_chars char (63) static options (constant)     /* for variable/function name check */
112           init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_");
113 dcl  valid_token_delimiters char (9)                        /* for variable/function name delimiter check */
114           static options (constant) init (" .()=+-*/");
115 
116 dcl  1 in_structure unaligned based (addr (in)),            /* view ..COMMAND_LINE without leading dots. */
117        2 pad char (2),
118        2 in_com char (1298);
119 
120 dcl  1 s (0:63) aligned,                                    /* PUSH-DOWN STACK:  s(ss)     is  top-of-stack
121                                                             /*                   s(ss - N) are items pushed earlier   */
122        2 op fixed bin (17),                                 /*  0: <val>  or  <variable>
123                                                             /*  1: <sos>  or  start-of-stack pushed for prec_calc call
124                                                             /*  2: <eoi>  or  end-of-input  reached for prec_calc call
125                                                             /*  3:   =          <variable> = <val>
126                                                             /*  4:   +          <val> + <val>
127                                                             /*  5:   -          <val> - <val>
128                                                             /*  6:   *          <val> * <val>
129                                                             /*  7:   /          <val> / <val>
130                                                             /*  8:   **         <val> ** <val>                        */
131        2 type fixed bin (17),                               /* precedence of <op> range(1:4) w/ +5 for each (..) set
132                                                             /*  =4   **
133                                                             /*  =3   * | /
134                                                             /*  =2   * | -
135                                                             /*  =1              for other stack items                 */
136        2 open_paren bit(1) aligned,                         /* open paren "(" preceded <val> or <variable> or <func>  */
137        2 value float dec (59),                              /* numeric value of <val> or <variable> item              */
138        2 close_paren bit(1) aligned,                        /* close paren ")" followed <val> or <variable>           */
139        2 var ptr,                                           /* for <variable>, var points to vars item giving its     */
140                                                             /*   name and numeric value.                              */
141      1 move aligned like s based;
142 
143 dcl  1 vars based (vp) aligned,                             /* list of variables given their name and value           */
144        2 next ptr,                                          /*   pointer to next array if > 32 vars are needed        */
145        2 d (0:31),
146          3 name char (8) aligned,
147          3 value float dec (59);
148 
149 dcl  cv_condition_$message entry() options(variable);
150 dcl  cv_fixed_point_string_ entry (char(*), fixed bin, bit(*), fixed bin(35)) returns(float dec(59));
151 dcl  numeric_to_ascii_ entry (float dec (59), fixed bin) returns (char (72) var);
152 dcl  (ioa_, ioa_$ioa_switch) entry options (variable);
153 dcl  iox_$error_output ptr external;
154 dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
155 dcl  iox_$user_input ptr ext static;
156 dcl  cu_$cp entry (ptr, fixed bin (21), fixed bin (35));
157 dcl  cu_$grow_stack_frame entry (fixed bin, ptr, fixed bin (35));
158 
159 dcl  (abs, addcharno, addr, after, atan, atand, before, cos, cosd, fixed,
160       hbound, index, lbound, length, log, log2, log10, ltrim,
161       maxlength, mod, null, rtrim, search, sin, sind, size, substr, tan, tand, verify) builtin;
162 
163 dcl  (conversion, fixedoverflow, overflow, program_interrupt, underflow) condition;
164 %page;
165 
166       call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
167       if code = error_table_$not_act_fnc then do;
168          if arg_count > 1 then do;
169             call com_err_$suppress_name (0, "calc", "Usage:  calc {expression}");
170             return;
171          end;
172          else if arg_count = 1 then expr_arg_sw = T;
173          else expr_arg_sw = F;
174          af_sw = F;
175       end;
176       else do;
177          if arg_count = 0 | arg_count > 1 then do;
178             call active_fnc_err_$af_suppress_name (0, "calc", "Usage:  [calc expression]");
179             return;
180          end;
181          af_sw, expr_arg_sw = T;
182       end;
183 
184       vp, sv = addr (space);                                /* initialize vars with e and pi */
185       iptr = addr (in);
186       vars.next = null;
187       vars.d.name (0) = "pi";
188       vars.d.value (0) = 3.1415926535897932384626433832795028841971693993751058209749e0;
189                                                             /* From www.math.com  (59 digits of precision) */
190       vars.d.name (1) = "e";
191       vars.d.value (1) = 2.7182818284590452353602874713526624977572470936999595749669e0;
192                                                             /* From math.utah.edu (59 digits of precision) */
193       fv = 2;
194 
195       if ^af_sw then                                        /* phx09588,phx18231: */
196          on program_interrupt go to new_line;               /* set up pi handler only if not active function */
197 
198 new_line:
199       ss = -1;                                              /* reinitialize variables */
200       calls = 0;
201       noprt, ileq = F;
202       if fv > 31 then do;
203          call cu_$grow_stack_frame (size (vars), vp, code); /* if vars too big, get more space */
204          if code ^= 0 then do;
205             call ioa_ ("Fatal out of space");
206             return;
207          end;
208          vars.next = sv;
209          sv = vp;
210          fv = 0;
211       end;
212 
213       if expr_arg_sw then do;
214          call cu_$arg_ptr (1, arg_ptr, arg_len, code);
215          call prec_calc (arg || NL, arg_len + 1, dum, code);
216 RETURN_FROM_AF:
217          return;
218       end;
219 
220 GET_LINE: call iox_$get_line (iox_$user_input, iptr, length (in), num, (0));
221 
222       if num = 1 then go to GET_LINE;                       /* newline */
223       else if num = 2 & substr (in, 1, 1) = "." then do;
224          call ioa_ ("CALC 2.0");
225          go to GET_LINE;
226       end;
227       else if substr (in, 1, 2) = ".." then do;
228          call cu_$cp (addr (in_com), num - 2, code);
229          go to GET_LINE;
230       end;
231 
232       fv_save = fv;                                         /* phx21221: save to restore on error */
233       call prec_calc (in, num, dum, code);
234       if code > 1 then return;
235       go to new_line;
236 
237 %page;
238 /**** ****************************INTERNAL PROC PREC_CALC************************************* ****/
239 
240 
241 /* prec_calc does the actual work of the calc command.  It is recursive so function references may */
242 /* contain expressions (including other function references). */
243 
244 prec_calc: proc (in, num, fval, code);
245                                                             /* declarations */
246 dcl  (i, j, k, num, last, level, ip, strt) fixed bin (21);
247 dcl  code fixed bin (35);
248 dcl  (x, fval) float dec (59);
249 dcl  wrk char (1);
250 dcl  wrka char (8);
251 dcl  in char (*);
252 dcl  msg char (40) aligned;
253 dcl  (end_of_input_displayed, set_open_paren_needed) bit(1) aligned;
254 
255       on overflow, fixedoverflow, underflow begin;
256          call cv_condition_$message( error_string, condition_name );
257          if index(error_string, " by ") > 1 then
258             error_string = before(error_string, " by ");
259 
260          if af_sw then call active_fnc_err_ (0, "calc", "^a", error_string);
261          else do;
262             if ^expr_arg_sw & ^debug_sw then do;            /* Hint which part of EXPRESSION caused condition. */
263                end_of_input_displayed = T;
264                call display_push_down_stack();
265             end;
266             call ioa_$ioa_switch (iox_$error_output, "^a", error_string);
267          end;
268          if expr_arg_sw then go to RETURN_FROM_AF;
269          else go to new_line;
270       end;
271 
272       fval = 0;                                             /* initialize return value in case error occurs. */
273       code, ip, last = 1; level = 0;
274       calls = calls + 1;
275       set_open_paren_needed = F;
276       end_of_input_displayed = F;                           /* For each prec_calc call, track display "END of input string" */
277 
278       ss = ss + 1;                                          /* put a start-of-stack char on s */
279       s.type (ss) = 0;
280       s.op (ss) = 1;
281       s.value (ss) = 0.0;
282       s.var (ss) = null();
283       s.open_paren (ss) = F;
284       s.close_paren (ss) = F;
285 
286       strt = ss - 1;
287 
288       if debug_sw then                                      /* when debugging, display prec_calc input string */
289          call ioa_ ("^/calc(^d):  ^a", calls, substr(in,1,num-1) );
290 
291 start:
292       if debug_sw & ss >= 0 then call display_push_down_stack();
293       if s.op (ss) ^= 0 then go to op_red;                  /* if s: <op> */
294       i = s.op (ss - 1);
295       if i = 0 then do;                                     /* if s: <val> <val>  then error */
296 miss_op: msg = "Missing operator";
297          go to err;
298       end;
299       if ss - 2 = strt then go to add;                      /* if s: "sos" <val>  then add */
300       if s.op (ss - 2) = 0 then go to add;                  /* if s: <val> <op> <val> then add */
301       if i ^= 4 then
302          if i ^= 5 then do;                                 /* if s ^ : <op> "+"|"-" <val>  error */
303 ill_prefix: msg = "Invalid prefix operator";
304             go to err;
305          end;
306       go to add;                                            /* syntax is OK so add to prefix to check prec */
307 
308 op_red:
309       i = s.op (ss);
310       if i = 1 then go to add;                              /* if s: "sos" then add */
311       j = s.op (ss - 1);
312       if j ^= 0 then do;                                    /* if s: <op> "-"|"+"  then add */
313          if i = 4 then go to add;
314          if i = 5 then go to add;
315       end;
316       if i = 2 then
317          if j = 1 then do;                                  /* if s: "sos" "eoi"  error */
318             if calls = 1 then return;
319             else do;
320                msg = "Null expression";
321                go to err;
322             end;
323          end;
324       if i > 2 then
325          if j ^= 0 then go to ill_prefix;                   /* error if: <op> ^"eoi" */
326       j = s.op (ss - 2);
327       if j = 0 then go to miss_op;                          /* error */
328       if i = 2 then
329          if j = 1 then go to print;                         /* if: "sos" <any> "eoi"  then print */
330                                                             /* if op1>op2 then add, i.e. check precedence */
331       if ss - 3 = strt then go to add;                      /* if <val2> is really "sos" then add */
332       if s.op (ss - 3) ^= 0 then do;                        /* check for prefix op */
333          if s.type (ss) > s.type (ss - 2) + 4 then go to add; /* check precdence - prefix is very strong */
334          if j = 5 then s.value (ss - 1) = -s.value (ss - 1);/* do negation */
335          if s.open_paren (ss - 1) & s.close_paren (ss - 1)  then
336             s.open_paren (ss - 1), s.close_paren (ss - 1) = F;
337          addr (s (ss - 2)) -> move = addr (s (ss - 1)) -> move; /* move over sign */
338          addr (s (ss - 1)) -> move = addr (s (ss)) -> move;
339          ss = ss - 1;
340          go to start;
341       end;
342       if s.type (ss) > s.type (ss - 2) then go to add;      /* s is: <val2><op2><val1><op1> */
343       go to operator (j);
344 
345                                                             /* NOTE: In each op below, don't change operand */
346                                                             /*       value until after op has executed so   */
347                                                             /*       original operands are visible if a     */
348                                                             /*       condition occurs during operation.     */
349 operator (3):
350 ASSIGN:
351       s.var (ss - 3) -> floatval = s.value (ss - 1);        /* do assignment */
352       noprt = T;
353       go to clean;
354 operator (4):
355 ADD:  x = s.value (ss - 3) + s.value (ss - 1);              /* do addition */
356       s.value (ss - 3) = x;
357       go to clean;
358 operator (5):
359 SUBTRACT:
360       x = s.value (ss - 3) - s.value (ss - 1);              /* do subtraction */
361       s.value (ss - 3) = x;
362       go to clean;
363 operator (6):
364 MULTIPLY:
365       x = s.value (ss - 3) * s.value (ss - 1);              /* do multiplication */
366       s.value (ss - 3) = x;
367       go to clean;
368 operator (7):
369 DIVIDE:
370       if s.value (ss - 1) = 0e0 then do;                    /* division by zero */
371          msg = "Divide by zero";
372          go to err;
373       end;
374       x = s.value (ss - 3) / s.value (ss - 1);              /* do division */
375       s.value (ss - 3) = x;
376       go to clean;
377 operator (8):
378 EXPONENT:
379       if s.value (ss - 3) < 0e0 then do;                    /* ** of neg number */
380          if mod (s.value (ss - 1), 1e0) = 0e0 then do;      /* neg to integer power */
381             s.value (ss - 3) = s.value (ss - 3) ** fixed (s.value (ss - 1), 17, 0);
382             go to clean;
383          end;
384          msg = "Neg num ** non-integer";
385          go to err;
386       end;
387       if s.value (ss - 1) = 0e0 then
388          if s.value (ss - 3) = 0e0 then do;                 /* zero ** zero */
389             msg = "Zero ** zero";
390             go to err;
391          end;
392       x = s.value (ss - 3) ** s.value (ss - 1);             /* do exponentiation */
393       s.value (ss - 3) = x;
394 
395 clean:
396       s.var (ss - 3) = null();                              /* op result no longer refers to named variable */
397       if s.open_paren (ss - 1) & s.close_paren (ss - 1)  then do;
398          s.open_paren  (ss - 1) = F;                        /* remove parens around parenthesized expression */
399          s.close_paren (ss - 1) = F;
400       end;
401       else if s.open_paren (ss - 3) & s.close_paren (ss - 1)  then do;
402          s.open_paren  (ss - 3) = F;                        /* remove parens around parenthesized expression */
403          s.close_paren (ss - 1) = F;
404       end;
405       else s.close_paren (ss - 3) = s.close_paren (ss - 1);
406                                                             /* otherwise, move any ) to prior value on stack */
407       addr (s (ss - 2)) -> move = addr (s (ss)) -> move;    /* remove top of stack */
408       ss = ss - 2;
409       go to start;
410 
411 print: fval = s.value (ss - 1);
412       if calls > 1 then go to no_print;
413 
414       if af_sw then do;
415          ip = 1;
416          out = numeric_to_ascii_ (fval, 0);
417          if index(out, ".") > 0 then
418               return_string = rtrim (ltrim (out), " 0");
419          else return_string = rtrim (ltrim (out));
420          return;
421       end;
422 
423       if noprt then go to no_print;
424       ip = 5;
425       out = numeric_to_ascii_ (fval, 0);                    /* set up output line */
426          if index(out, ".") > 0 then
427               out = rtrim (ltrim (out), " 0");
428          else out = rtrim (ltrim (out));
429       call ioa_ ("=   ^a^/", out);
430 
431 no_print: calls = calls - 1;                                /* return to caller */
432       code = 0;
433       ss = strt;
434       return;
435 
436 add:  ss = ss + 1;                                          /* put new cell on stack */
437       if ss > 63 then do;                                   /* too many tokens on stack */
438          msg = "Simplify expression";
439          go to err;
440       end;
441       s.type (ss) = 0;                                      /* initialize new cell */
442       s.op (ss) = 0;
443       s.value (ss) = 0.0;
444       s.var (ss) = null();
445       s.open_paren (ss) = set_open_paren_needed;
446       set_open_paren_needed = F;
447       s.close_paren (ss) = F;
448 
449 blank:
450       if ip >= num then do;                                 /* look for end of input line */
451          if level ^= 0 then do;
452             msg = "Too few )'s";
453             go to err;
454          end;
455          s.type (ss) = 0;
456          s.op (ss) = 2;                                     /* put "eoi" on stack */
457          if s.open_paren (ss - 1) & s.close_paren (ss - 1) then
458             s.open_paren (ss - 1), s.close_paren (ss - 1) = F;
459          else do;
460             s.open_paren (ss - 1) = set_open_paren_needed;
461             set_open_paren_needed = F;
462          end;
463          go to start;
464       end;
465       wrk = substr (in, ip, 1);
466       if wrk ^= " " then go to non_blank;                   /* look for non-blank */
467 incr: ip = ip + 1;
468       go to blank;
469 non_blank:
470       i = index ("0123456789.()=+-*/", wrk);
471       if i = 0 then go to var_ref;                          /* if not as in index, then go to var_ref */
472       if i <= 11 then do;
473          call get_number (addr (in), num - 1, ip, s.value (ss));
474          s.op (ss) = 0;
475          ileq = T;
476          last = 2;
477          if set_open_paren_needed then do;
478             s.open_paren (ss) = T;
479             set_open_paren_needed = F;
480          end;
481          go to start;
482       end;
483       if i = 12 then do;                                    /* if open paren then up prec level */
484          if last ^= 1 then
485             if last ^= 3 then do;                           /* error if ( follows value or ) */
486                msg = "Invalid use of (";
487                go to err;
488             end;
489          last = 3;
490          level = level + LPAREN_INCREASES_PRECEDENCE;
491          ileq = T;
492          set_open_paren_needed = T;
493          go to incr;
494       end;
495 
496       if i = 13 then do;                                    /* if ) check for error then lower prec level */
497          if level = 0 then do;
498             msg = "Too many )'s";
499             go to err;
500          end;
501          if last ^= 2 then
502             if last ^= 4 then do;                           /* error if ) follows ( or operator */
503                msg = "Invalid use of )";
504                go to err;
505             end;
506          last = 4;
507          level = level - LPAREN_INCREASES_PRECEDENCE;
508          s.close_paren (ss - 1) = T;
509          ileq = T;
510          go to incr;
511       end;
512 
513       if last = 3 then
514          if i ^= 15 then
515             if i ^= 16 then do;                             /* "(" <op>^="+"|"-" */
516                msg = "Invalid op after (";
517                go to err;
518             end;
519       last = 1;
520       if substr (in, ip, 2) = "**" then do;
521          i = 19;                                            /* check for ** */
522          ip = ip + 1;
523       end;
524 
525       if i = 14 then
526          if ileq then do;                                   /* anything but <variable> before "=" is error */
527             msg = "Invalid use of =";
528             go to err;
529          end;
530 
531       k = level + 1;                                        /* assign precedence level to operator */
532       if i > 18 then k = k + 3;                             /*  **      gets  k + 3  */
533       else if i > 16 then k = k + 2;                        /*  * | /   gets  k + 2  */
534       else if i > 14 then k = k + 1;                        /*  + | -   gets  k + 1  */
535       s.type (ss) = k;
536 
537       s.op (ss) = i - 11;
538       ileq = T;
539       ip = ip + 1;
540       go to start;
541 
542 var_ref: i = ip;                                            /* save start of var name */
543       last = 2;
544       if verify (wrk, var_name_chars) ^= 0 then do;         /* phx10119,20071,21221: name validity check */
545 bad_char:
546          msg = "Invalid char " || wrk;
547          go to err;
548       end;
549       go to first;
550 var_loop:
551       ip = ip + 1;
552       wrk = substr (in, ip, 1);
553 first:
554       if ip < num then do;
555          if verify (wrk, var_name_chars) = 0 then           /* phx10119,20071,21221: name validity check */
556             go to var_loop;                                 /* find end of name */
557 
558          if verify (wrk, valid_token_delimiters) ^= 0 then  /* check for invalid */
559             go to bad_char;                                 /* char after name */
560       end;
561 
562       wrka = substr (in, i, ip - i);                        /* wrka is var name */
563 
564       if wrka = "db_on" then do;                            /* hidden variable name to enable display_push_down_stack. */
565          debug_sw = T;
566          return;
567       end;
568       if wrka = "db_off" then do;
569          debug_sw = F;
570          return;
571       end;
572 
573       if expr_arg_sw then do;
574          do i = lbound(funcs,1) to hbound(funcs,1);
575             if wrka = funcs (i) then go to func_ref;
576          end;
577          if af_sw then call active_fnc_err_ (0, "calc", "Variables not allowed in expression argument.");
578          else call com_err_ (0, "calc", "Variables not allowed in expression argument.");
579          return;
580       end;
581 
582       vp = sv;
583       k = fv - 1;
584 next_v: do j = k to 0 by -1;                                /* search vars for wrka */
585          if wrka = vars.d.name (j) then go to found;
586       end;
587       vp = vars.next;                                       /* chain to next block of vars */
588       k = 31;
589       if vp ^= null then go to next_v;                      /* if null then name is undefined */
590       if wrka = "q" then do;                                /* a name of "q" is a quit so return  with quit code */
591          if num > 2 then do;                                /* other chars on the line */
592             msg = "Invalid var q";
593             go to err;
594          end;
595          code = 2;
596          return;
597       end;
598       if wrka = "list" then do;                             /* a name of "list" means list all vars */
599          if num > 5 then do;                                /* other chars on the line */
600             msg = "Invalid var list";
601             go to err;
602          end;
603          call ioa_ ("");
604          vp = sv;
605          k = fv - 1;
606 another: do j = k to 0 by -1;                               /* go through vars printing out values and names */
607             out = numeric_to_ascii_ (vars.d.value (j), 0);
608             call ioa_ ("^va =  ^a", maxlength (vars.d.name (j)), vars.d.name (j), out);
609          end;
610          vp = vars.next;
611          k = 31;
612          if vp ^= null then go to another;
613          call ioa_ (" ");
614          return;
615       end;
616       do i = lbound(funcs,1) to hbound(funcs,1);
617          if wrka = funcs (i) then go to func_ref;
618       end;
619       if ileq then do;                                      /* since not command or func then undef var */
620                                                             /* so invalid if not first in line */
621          msg = "Undef var " || wrka;
622          go to err;
623       end;
624       vp = sv;
625       j = fv;
626       fv = fv + 1;                                          /* define var */
627       vars.d.name (j) = wrka;
628       vars.d.value (j) = 0e0;
629 
630 found:
631       s.op (ss) = 0;
632       s.value (ss) = vars.d.value (j);                      /* put <val> on stack */
633       s.var (ss) = addr (vars.d.value (j));
634       if set_open_paren_needed then do;
635          s.open_paren (ss) = T;
636          set_open_paren_needed = F;
637       end;
638       go to start;
639 
640 func_ref:
641       do ip = ip to num while (substr (in, ip, 1) ^= "("); /* find open paren */
642       end;
643       j = 0;
644       do k = ip to num;                                     /* find close paren */
645          if substr (in, k, 1) = "(" then j = j + 1;
646          if substr (in, k, 1) = ")" then j = j - 1;
647          if j = 0 then go to end_ref;
648       end;
649       msg = "Missing ) after " || wrka;
650       go to err;
651 
652 end_ref:
653       call prec_calc (substr (in, ip, k - ip + 2), k - ip + 2, x, code);
654       if code ^= 0 then return;
655       code = 1;
656       ip = k + 1;
657       s.op (ss) = 0;
658       s.var (ss) = null;
659       if debug_sw then do;
660          ss = ss - 1;  call display_push_down_stack();   ss = ss + 1;
661 
662          call ioa_$ioa_switch (iox_$error_output, "^/ ----- PUSH-DOWN STACK -----" );
663          call ioa_$ioa_switch (iox_$error_output, " s(^2d):      ^a( ^f )", ss, funcs(i), x);
664          if ip >= num then
665             call ioa_$ioa_switch (iox_$error_output, "^2x END of input string^[ ^40x precedence: ^2d^;^s^]",
666               s(ss).type^=0, s(ss).type);
667       end;
668 
669       go to func (i);
670 func (0):
671       s.value (ss) = sind (x); go to end_func;
672 func (1):
673       s.value (ss) = sin (x); go to end_func;
674 func (2):
675       s.value (ss) = cosd (x); go to end_func;
676 func (3):
677       s.value (ss) = cos (x); go to end_func;
678 func (4):
679       s.value (ss) = tand (x); go to end_func;
680 func (5):
681       s.value (ss) = tan (x); go to end_func;
682 func (6):
683       s.value (ss) = atand (x); go to end_func;
684 func (7):
685       s.value (ss) = atan (x); go to end_func;
686 func (8):
687       s.value (ss) = abs (x); go to end_func;
688 func (9):
689       s.value (ss) = log10 (x); go to end_func;             /* calc 1.1 used to call this function "log"              */
690 func (10):
691       s.value (ss) = log2 (x); go to end_func;
692 func (11):
693 LN:                                                         /* calc 1.1 function name retained for compatibility      */
694 func (12):
695       s.value (ss) = log (x); go to end_func;               /* calc 2.0 calls this function "log", per PL/I           */
696 
697 end_func:
698       if set_open_paren_needed then do;                     /* check if func value needs ( char */
699          s.open_paren (ss) = T;
700          set_open_paren_needed = F;
701       end;
702       go to start;
703 
704 err:                                                        /* error printout section */
705       if af_sw then do;
706          call active_fnc_err_ (0, "calc", "^a", msg);
707       end;
708       else call ioa_$ioa_switch (iox_$error_output, "^a", msg);
709       fv = fv_save;                                         /* phx21221 - clean up invalid variables on error */
710       ss = strt;
711 
712       return;
713 %page;
714 display_push_down_stack:
715    proc;
716 
717 dcl  d fixed bin;
718 dcl  valname char(8) var;
719 
720    if ss = strt+1  then return;                             /* Display nothing if only START of STACK item is present */
721    if s(ss).op = 2 & ^end_of_input_displayed then do;
722                                                             /* Display only "END of input string" at end of prior stack */
723       call ioa_$ioa_switch (iox_$error_output, "^[^25x )^/^] ^5x END of input string^[ ^40x precedence: ^2d^;^s^]",
724            s(ss-1).close_paren, s(ss).type^=0, s(ss).type);
725       end_of_input_displayed = T;
726       return;
727    end;
728 
729    call ioa_$ioa_switch (iox_$error_output, "");
730    do d = strt+1 to ss by +1;
731       if s(d).op = 1 then                                   /* Start of stack. */
732            call ioa_$ioa_switch (iox_$error_output, " ----- PUSH-DOWN STACK -----^[ ^22x value: ^f^]",
733                 s(d).value ^= 0.0, s(d).value );
734 
735       else if s(d).op = 2 then                              /* End of input */
736            call ioa_$ioa_switch (iox_$error_output, "^2x END of input string^[ ^40x precedence: ^2d^;^s^]",
737                 s(d).type^=0, s(d).type);
738 
739       else if s(d).op = 8 then                              /* Exponentiation (**) -- the only 2-char op */
740            call ioa_$ioa_switch (iox_$error_output, " s(^2d):   ^6x ^2a       precedence: ^2d   ^[value: ^f^;^s^]",
741              d, "**", s(d).type, s(d).value ^= 0.0, s(d).value );
742 
743       else if s(d).op = 0 then do;                          /* Value or variable. */
744            if s(d).var ^= null then
745                 valname = rtrim(addcharno(s(d).var, -8)->varname);
746            else valname = "value";
747            if calls > 1  &  ip = num - 1  &  d = ss then    /* LOOK AHEAD: if end of recursive call...  */
748                 s(d).close_paren = T;                       /*  - Include ) at end of value.            */
749            call ioa_$ioa_switch (iox_$error_output, " s(^2d): ^[(^; ^] ^vx^a: ^f  ^[)^; ^] ^[precedence: ^2d^]",
750                 d, s(d).open_paren, 8-length(valname), valname, s(d).value,
751                 s(d).close_paren, s(d).type ^= 0, s(d).type );
752       end;
753 
754       else call ioa_$ioa_switch (iox_$error_output, " s(^2d):   ^6x ^2a       precedence: ^2d   ^[value: ^f^;^s^]",
755              d, substr(" ()=+-*/", s(d).op+1, 1), s(d).type, s(d).value ^= 0.0, s(d).value );
756    end;
757 
758    end display_push_down_stack;
759 
760    end prec_calc;
761 
762 /**** *****************************************END INTERNAL PROC PREC_CALC********************************** ****/
763 
764 /* format: off */
765 %page;
766 /* --------------------------------------------------------------------------------
767    QUICK INTERNAL PROCEDURE:  get_number
768 
769    Function:  Locates end of the next number_string in input line (var: in) and
770               passes number_string to cv_fixed_point_string_ to convert
771               it to a float dec(59) data scalar.
772 
773    Formats supported:  Valid numbers accepted, expressed as Perl patterns (regular expressions).
774                        Note that leading sign is processed by prec_calc routine as a unary operator.
775                        So leading sign (while permitted) is not shown in the following patterns.
776 
777              Simplest:  [0-9A-Fa-f.]+                       ( Just a fixed-point numeric string, no exponent )
778 
779    w/ Radix Indicator:  [0-9A-Fa-f.]+_?[BQODXbqodx]         ( fixed-point string followed by radix indicator )
780                     |   [0-9A-Fa-f.]+_?[Rr][0-9]+
781 
782           w/ Exponent:  [0-9.]+[Ee][+-]?[0-9]+              ( E-format exponent allowed IFF base-10 )
783                     |   [0-9.]+[Ee][+-]?[0-9]+_?[Dd]
784                     |   [0-9.]+[Ee][+-]?[0-9]+_?[Rr]10
785 
786 
787    The following characters break the sequences of characters that can appear in a
788    number string:
789 
790          Ending Break:  [) =+-/*]                           ( skip over pattern: [Ee][+-]
791                                                               which occurs in E-format exponent
792                                                               of a possible decimal number string )
793 
794    -------------------------------------------------------------------------------- */
795 /* format: on */
796 
797 get_number:                                                 /* Convert next input token in input line to a number     */
798    proc (inP, inL, inX, number);
799 
800 dcl  in char (inL) based (inP),
801      inP ptr,
802      inL fixed bin (21);
803 dcl  inX fixed bin (21);
804 dcl  number float dec (59);
805 
806 dcl  BREAK_CHARS char (7) int static options (constant) init (") =+-/*");
807 dcl  breakL fixed bin (21) init (0);
808 
809 dcl  number_string char (number_stringL) based (number_stringP),
810      number_stringP ptr,                                    /* Candidate to be the numeric token                      */
811      number_stringL fixed bin (21);
812 dcl  numberX fixed bin (21);                                /* Index into number_string of next BREAK_CHAR            */
813       number_stringP = addcharno (inP, inX - 1);
814       number_stringL = inL - (inX - 1);
815 
816 dcl  exponent_string char (exponent_stringL) based (exponent_stringP),
817      exponent_stringP ptr,                                  /* Candidate for exponent in an E-format number string.   */
818      exponent_stringL fixed bin (21);
819 dcl  exponentX fixed bin (21);
820 
821       numberX = search (number_string, BREAK_CHARS);        /* Find possible end of the numeric_string token.         */
822       if numberX > 0 then do;
823          if (substr (number_string, numberX, length ("+")) = "+" |
824               substr (number_string, numberX, length ("-")) = "-") then do;
825                                                             /*  - If BREAK_CHAR is + or -, it could be sign in the    */
826                                                             /*    exponent part of E-format numeric string.           */
827 
828             if (substr (number_string, numberX - 1, length ("E")) = "E" |
829                  substr (number_string, numberX - 1, length ("e")) = "e") then do;
830                exponent_stringP = addcharno (number_stringP, numberX);
831                exponent_stringL = length (number_string) - numberX;
832                                                             /*    Overlay just the exponent part of the number.       */
833                number_stringL = numberX;                    /*    number_string overlays mantissa of E-format number. */
834 
835                exponentX = search (exponent_string, BREAK_CHARS);
836                if exponentX > 0 then                        /*  - Next BREAK_CHAR definitely ends number_string token.*/
837                     exponent_stringL = exponentX - 1;
838                number_stringL = length (number_string) + length (exponent_string);
839                                                             /*    Recombine mantissa and exponent parts.              */
840             end;
841 
842             else number_stringL = numberX - 1;              /*  - Not in E-format so BREAK_CHAR ends number_string    */
843          end;
844          else number_stringL = numberX - 1;                 /*  - Not + or -, so BREAK_CHAR ends number_string.       */
845       end;
846 
847 dcl  BASE_10 fixed bin int static options (constant) init (10);
848 dcl  SIGNAL_ERRORS bit (1) aligned int static options (constant) init (T);
849                                                             /* Use onsource/onchar to better diagnose location of     */
850                                                             /*  conversion error in number_string.                    */
851 dcl  ENABLE_E_FORMAT bit (1) aligned int static options (constant) init (T);
852                                                             /* For base-10 inputs, E-format number_string allowed.    */
853                                                             /*  Conversion actually done by PL/I convert builtin.     */
854                                                             /*  E-format is not meaningful in other numeric bases.    */
855       inX = inX + length (number_string);
856 
857       on conversion, overflow, underflow begin;
858          call cv_condition_$message( error_string, condition_name );
859          if index(error_string, " by ") > 1 then
860               error_string = before(error_string, " by ");
861          if condition_name = "overflow" | condition_name = "underflow" then do;
862               error_string = error_string || "
863   onsource: """ || number_string || """
864 ";
865          end;
866 
867          if af_sw then call active_fnc_err_ (0, "calc", "^a", error_string);
868          else call ioa_$ioa_switch (iox_$error_output, "^a", error_string);
869          if expr_arg_sw then go to RETURN_FROM_AF;
870          else go to new_line;
871       end;
872 
873       number = cv_fixed_point_string_ (number_string, BASE_10, FIXED_POINT_SIG_EXP_CONVERT_DEC, code);
874 
875    end get_number;
876 %page;
877 %include cv_fixed_point_string_;
878    end calc;