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 /* Check to see if the length argument is equal to a constant         */
12 
13 constant_length:
14      procedure (P_tree, P_constant_value) returns (bit (1) aligned);
15 
16 /* parameter */
17 
18 dcl       (
19           P_tree              ptr,
20           P_constant_value    fixed bin (71)
21           )                   parameter;
22 
23 /* automatic */
24 
25 dcl       tree                ptr;
26 
27 /* builtins */
28 
29 dcl       null                builtin;
30 
31 /* program */
32 
33           tree = P_tree;
34 
35           if tree -> reference.length = null
36           then do;
37                     if tree -> reference.c_length ^= P_constant_value
38                     then return ("0"b);
39 
40                     return ("1"b);
41                end;
42 
43           if tree -> reference.length -> node.type = operator_node
44           then if tree -> reference.length -> operator.op_code = range_ck
45                then if tree -> reference.length -> operand (2) -> node.type = reference_node
46                     then if tree -> reference.length -> operand (2) -> reference.symbol -> symbol.constant
47                          then if constant_value ((tree -> reference.length -> operand (2) -> reference.symbol))
48                                    ^= P_constant_value
49                               then return ("0"b);
50                               else return ("1"b);
51 
52           return ("0"b);
53 
54 /* get the initial value of a fixed binary variable with a scale factor of zero */
55 
56 constant_value:
57      procedure (sym_ptr) returns (fixed bin (71));
58 
59 /* parameter */
60 
61 dcl       sym_ptr             ptr;
62 
63 /* based */
64 
65 dcl       integer_1           based fixed bin (35);
66 dcl       integer_2           based fixed bin (71);
67 
68 /* automatic */
69 
70 dcl       initial_value       fixed bin (71);
71 
72           if sym_ptr -> symbol.c_dcl_size > max_p_fix_bin_1
73           then initial_value = sym_ptr -> symbol.initial -> integer_2;
74           else initial_value = sym_ptr -> symbol.initial -> integer_1;
75 
76           return (initial_value);
77 
78      end /* constant_value */;
79 ^L
80 /* include files */
81 
82 %include nodes;
83 %include op_codes;
84 %include operator;
85 %include reference;
86 %include symbol;
87 %include system;
88      end /* constant_length */;