1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
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
99
100
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)
112 init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_");
113 dcl valid_token_delimiters char (9)
114 static options (constant) init (" .()=+-*/");
115
116 dcl 1 in_structure unaligned based (addr (in)),
117 2 pad char (2),
118 2 in_com char (1298);
119
120 dcl 1 s (0:63) aligned,
121
122 2 op fixed bin (17),
123
124
125
126
127
128
129
130
131 2 type fixed bin (17),
132
133
134
135
136 2 open_paren bit(1) aligned,
137 2 value float dec (59),
138 2 close_paren bit(1) aligned,
139 2 var ptr,
140
141 1 move aligned like s based;
142
143 dcl 1 vars based (vp) aligned,
144 2 next ptr,
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);
185 iptr = addr (in);
186 vars.next = null;
187 vars.d.name (0) = "pi";
188 vars.d.value (0) = 3.1415926535897932384626433832795028841971693993751058209749e0;
189
190 vars.d.name (1) = "e";
191 vars.d.value (1) = 2.7182818284590452353602874713526624977572470936999595749669e0;
192
193 fv = 2;
194
195 if ^af_sw then
196 on program_interrupt go to new_line;
197
198 new_line:
199 ss = -1;
200 calls = 0;
201 noprt, ileq = F;
202 if fv > 31 then do;
203 call cu_$grow_stack_frame (size (vars), vp, code);
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;
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;
233 call prec_calc (in, num, dum, code);
234 if code > 1 then return;
235 go to new_line;
236
237 %page;
238
239
240
241
242
243
244 prec_calc: proc (in, num, fval, code);
245
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;
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;
273 code, ip, last = 1; level = 0;
274 calls = calls + 1;
275 set_open_paren_needed = F;
276 end_of_input_displayed = F;
277
278 ss = ss + 1;
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
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;
294 i = s.op (ss - 1);
295 if i = 0 then do;
296 miss_op: msg = "Missing operator";
297 go to err;
298 end;
299 if ss - 2 = strt then go to add;
300 if s.op (ss - 2) = 0 then go to add;
301 if i ^= 4 then
302 if i ^= 5 then do;
303 ill_prefix: msg = "Invalid prefix operator";
304 go to err;
305 end;
306 go to add;
307
308 op_red:
309 i = s.op (ss);
310 if i = 1 then go to add;
311 j = s.op (ss - 1);
312 if j ^= 0 then do;
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;
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;
326 j = s.op (ss - 2);
327 if j = 0 then go to miss_op;
328 if i = 2 then
329 if j = 1 then go to print;
330
331 if ss - 3 = strt then go to add;
332 if s.op (ss - 3) ^= 0 then do;
333 if s.type (ss) > s.type (ss - 2) + 4 then go to add;
334 if j = 5 then s.value (ss - 1) = -s.value (ss - 1);
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;
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;
343 go to operator (j);
344
345 NOTE
346
347
348
349 operator (3):
350 ASSIGN:
351 s.var (ss - 3) -> floatval = s.value (ss - 1);
352 noprt = T;
353 go to clean;
354 operator (4):
355 ADD: x = s.value (ss - 3) + s.value (ss - 1);
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);
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);
366 s.value (ss - 3) = x;
367 go to clean;
368 operator (7):
369 DIVIDE:
370 if s.value (ss - 1) = 0e0 then do;
371 msg = "Divide by zero";
372 go to err;
373 end;
374 x = s.value (ss - 3) / s.value (ss - 1);
375 s.value (ss - 3) = x;
376 go to clean;
377 operator (8):
378 EXPONENT:
379 if s.value (ss - 3) < 0e0 then do;
380 if mod (s.value (ss - 1), 1e0) = 0e0 then do;
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;
389 msg = "Zero ** zero";
390 go to err;
391 end;
392 x = s.value (ss - 3) ** s.value (ss - 1);
393 s.value (ss - 3) = x;
394
395 clean:
396 s.var (ss - 3) = null();
397 if s.open_paren (ss - 1) & s.close_paren (ss - 1) then do;
398 s.open_paren (ss - 1) = F;
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;
403 s.close_paren (ss - 1) = F;
404 end;
405 else s.close_paren (ss - 3) = s.close_paren (ss - 1);
406
407 addr (s (ss - 2)) -> move = addr (s (ss)) -> move;
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);
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;
432 code = 0;
433 ss = strt;
434 return;
435
436 add: ss = ss + 1;
437 if ss > 63 then do;
438 msg = "Simplify expression";
439 go to err;
440 end;
441 s.type (ss) = 0;
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;
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;
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;
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;
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;
484 if last ^= 1 then
485 if last ^= 3 then do;
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;
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;
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;
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;
522 ip = ip + 1;
523 end;
524
525 if i = 14 then
526 if ileq then do;
527 msg = "Invalid use of =";
528 go to err;
529 end;
530
531 k = level + 1;
532 if i > 18 then k = k + 3;
533 else if i > 16 then k = k + 2;
534 else if i > 14 then k = 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;
543 last = 2;
544 if verify (wrk, var_name_chars) ^= 0 then do;
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
556 go to var_loop;
557
558 if verify (wrk, valid_token_delimiters) ^= 0 then
559 go to bad_char;
560 end;
561
562 wrka = substr (in, i, ip - i);
563
564 if wrka = "db_on" then do;
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;
585 if wrka = vars.d.name (j) then go to found;
586 end;
587 vp = vars.next;
588 k = 31;
589 if vp ^= null then go to next_v;
590 if wrka = "q" then do;
591 if num > 2 then do;
592 msg = "Invalid var q";
593 go to err;
594 end;
595 code = 2;
596 return;
597 end;
598 if wrka = "list" then do;
599 if num > 5 then do;
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;
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;
620
621 msg = "Undef var " || wrka;
622 go to err;
623 end;
624 vp = sv;
625 j = fv;
626 fv = fv + 1;
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);
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) ^= "(");
642 end;
643 j = 0;
644 do k = ip to num;
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, "^/
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;
690 func (10):
691 s.value (ss) = log2 (x); go to end_func;
692 func (11):
693 LN:
694 func (12):
695 s.value (ss) = log (x); go to end_func;
696
697 end_func:
698 if set_open_paren_needed then do;
699 s.open_paren (ss) = T;
700 set_open_paren_needed = F;
701 end;
702 go to start;
703
704 err:
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;
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;
721 if s(ss).op = 2 & ^end_of_input_displayed then do;
722
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
732 call ioa_$ioa_switch (iox_$error_output, "
733 s(d).value ^= 0.0, s(d).value );
734
735 else if s(d).op = 2 then
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
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;
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
748 s(d).close_paren = T;
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
763
764
765 %page;
766
767
768
769
770
771
772
773
774 Note
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797 get_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
808
809
810
811 number_stringL fixed bin (21);
812 dcl numberX fixed bin (21);
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,
818 exponent_stringL fixed bin (21);
819 dcl exponentX fixed bin (21);
820
821 numberX = search (number_string, BREAK_CHARS);
822 if numberX > 0 then do;
823 if (substr (number_string, numberX, length ("+")) = "+" |
824 substr (number_string, numberX, length ("-")) = "-") then do;
825
826
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
833 number_stringL = numberX;
834
835 exponentX = search (exponent_string, BREAK_CHARS);
836 if exponentX > 0 then
837 exponent_stringL = exponentX - 1;
838 number_stringL = length (number_string) + length (exponent_string);
839
840 end;
841
842 else number_stringL = numberX - 1;
843 end;
844 else number_stringL = numberX - 1;
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
850
851 dcl ENABLE_E_FORMAT bit (1) aligned int static options (constant) init (T);
852
853
854
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;