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 /* Modified 780712 by PG for unsigned
 12    Modified 790812 by RAB to fix 1797 (erroneous WARNING 47 when array of
 13           character strings passed to function expecting star extents lengths.)
 14    Modified 4 October 1980 by M. N. Davidoff to eliminate internal static.  Fixes 2023.
 15 */
 16 /* format: style3,tree */
 17 match_arguments:
 18      procedure (pa, pb) returns (bit (1) aligned);
 19 
 20 dcl       pa                  ptr;
 21 dcl       pb                  ptr;
 22 
 23 /* automatic */
 24 
 25 dcl       a                   ptr;
 26 dcl       a_reference         bit (1) aligned;
 27 dcl       a_root              ptr;
 28 dcl       b                   ptr;
 29 dcl       found_brother       bit (1) aligned;
 30 dcl       parent_is_scalar    bit (1) aligned;
 31 
 32 /* builtin */
 33 
 34 dcl       (null, string, unspec)
 35                               builtin;
 36 ^L
 37 %include semant;
 38 %include array;
 39 %include nodes;
 40 %include picture_image;
 41 %include reference;
 42 %include symbol;
 43 ^L
 44 /* If a is a reference, the length given in the reference is used as the size
 45    and the bounds and dimensionality of b are ignored.  A star extent of b is
 46    considered to match any corresponding extent of a.  If the arguments are
 47    structures, this procedure makes a prefix walk over the members to ensure
 48    that the members match. */
 49 
 50           b = pb;
 51 
 52           if pa = b
 53           then return ("1"b);
 54 
 55           if pa = null
 56           then return ("0"b);
 57 
 58           if pa -> node.type = reference_node
 59           then do;
 60                     a_reference = "1"b;
 61                     a = pa -> reference.symbol;
 62                end;
 63           else do;
 64                     a_reference = "0"b;
 65                     a = pa;
 66                end;
 67 
 68           parent_is_scalar = "0"b;
 69           a_root = a;
 70           do while (a ^= a_root -> symbol.father);
 71                if b = null
 72                then return ("0"b);
 73 
 74                if a_reference
 75                then if a = a_root
 76                     then if ^match (pa, b)
 77                          then return ("0"b);
 78                          else ;
 79                     else if ^match ((a -> symbol.reference), b)
 80                          then return ("0"b);
 81                          else ;
 82                else if ^match (a, b)
 83                     then return ("0"b);
 84 
 85                if a -> symbol.son ^= null
 86                then do;
 87                          a = a -> symbol.son;
 88                          b = b -> symbol.son;
 89                     end;
 90                else do;
 91                          found_brother = "0"b;
 92                          do while (a ^= a_root -> symbol.father & ^found_brother);
 93                               if a -> symbol.brother = null | a = a_root
 94                               then do;
 95                                         if b -> symbol.brother ^= null & a ^= a_root
 96                                         then return ("0"b);
 97 
 98                                         a = a -> symbol.father;
 99                                         b = b -> symbol.father;
100                                    end;
101                               else do;
102                                         a = a -> symbol.brother;
103                                         b = b -> symbol.brother;
104                                         found_brother = "1"b;
105                                    end;
106                          end;
107                     end;
108           end;
109 
110           return ("1"b);
111 ^L
112 /* Check if two nodes match. */
113 
114 match:
115      procedure (pa, pb) returns (bit (1) aligned);
116 
117 dcl       pa                  ptr;
118 dcl       pb                  ptr;
119 
120 /* automatic */
121 
122 dcl       a                   ptr;
123 dcl       asize               ptr;
124 dcl       b                   ptr;
125 dcl       ba                  ptr;
126 dcl       bb                  ptr;
127 dcl       bsize               ptr;
128 dcl       c_asize             fixed bin (24);
129 dcl       c_bsize             fixed bin (24);
130 
131           b = pb;
132           asize, bsize = null;
133           c_asize, c_bsize = 0;
134 
135           if pa = b
136           then return ("1"b);
137 
138           if a_reference
139           then a = pa -> reference.symbol;
140           else a = pa;
141 
142           if string (a -> symbol.data_type) ^= string (b -> symbol.data_type) | a -> symbol.binary ^= b -> symbol.binary
143                | a -> symbol.real ^= b -> symbol.real | a -> symbol.scale ^= b -> symbol.scale
144                | a -> symbol.aligned ^= b -> symbol.aligned | a -> symbol.unsigned ^= b -> symbol.unsigned
145                | a -> symbol.varying ^= b -> symbol.varying
146           then return ("0"b);
147 
148           if ^a_reference & a -> symbol.dimensioned ^= b -> symbol.dimensioned
149           then return ("0"b);
150 
151           if a -> symbol.float | a -> symbol.fixed
152           then do;
153                     c_asize = a -> symbol.c_dcl_size;
154                     c_bsize = b -> symbol.c_dcl_size;
155                end;
156 
157           else if a -> symbol.char | a -> symbol.bit
158                then do;
159                          if a_reference & ^a -> symbol.varying
160                          then do;
161                                    asize = pa -> reference.length;
162                                    c_asize = pa -> reference.c_length;
163                               end;
164                          else do;
165                                    asize = a -> symbol.dcl_size;
166                                    c_asize = a -> symbol.c_dcl_size;
167                               end;
168 
169                          bsize = b -> symbol.dcl_size;
170                          c_bsize = b -> symbol.c_dcl_size;
171                     end;
172 
173           if a -> symbol.picture
174           then if unspec (a -> symbol.general -> reference.symbol -> symbol.initial -> picture_image)
175                     ^= unspec (b -> symbol.general -> reference.symbol -> symbol.initial -> picture_image)
176                then return ("0"b);
177                else ;
178 
179           else if a -> symbol.area
180                then do;
181                          asize = a -> symbol.dcl_size;
182                          bsize = b -> symbol.dcl_size;
183                          c_asize = a -> symbol.c_dcl_size;
184                          c_bsize = b -> symbol.c_dcl_size;
185                     end;
186 
187           if b -> symbol.star_extents
188           then if bsize = null & (c_asize ^= c_bsize | asize ^= null)
189                then return ("0"b);
190                else ;
191           else if c_asize ^= c_bsize | ^compare_expression (asize, bsize)
192                then return ("0"b);
193 
194           if a_reference & a -> symbol.father = null
195           then if pa -> reference.array_ref ^= b -> symbol.dimensioned
196                then return ("0"b);
197 
198           if b -> symbol.dimensioned
199           then do;
200                     if a -> symbol.array -> array.own_number_of_dimensions > b -> symbol.array -> array.number_of_dimensions
201                     then call semantic_translator$abort (269, a);
202 
203                     if a -> symbol.array -> array.number_of_dimensions ^= b -> symbol.array -> array.number_of_dimensions
204                          & (a -> symbol.array -> array.own_number_of_dimensions
205                          ^= b -> symbol.array -> array.own_number_of_dimensions | a -> symbol.father = null
206                          | b -> symbol.father = null)
207                     then return ("0"b);
208 
209                     ba = a -> symbol.array -> array.bounds;
210                     bb = b -> symbol.array -> array.bounds;
211 
212                     if bb = null
213                     then return ("0"b);
214 
215                     do while (ba ^= null & bb ^= null);
216                          if b -> symbol.star_extents
217                          then if constant_extent ((bb -> bound.lower)) & constant_extent ((bb -> bound.upper))
218                                    & (ba -> bound.c_lower ^= bb -> bound.c_lower
219                                    | ba -> bound.c_upper ^= bb -> bound.c_upper | ^constant_extent ((ba -> bound.lower))
220                                    | ^constant_extent ((ba -> bound.upper)))
221                               then return ("0"b);
222                               else ;
223 
224                          else if ba -> bound.c_lower ^= bb -> bound.c_lower | ba -> bound.c_upper ^= bb -> bound.c_upper
225                                    | ^same_extent_bounds ((ba -> bound.lower), (bb -> bound.lower))
226                                    | ^same_extent_bounds ((ba -> bound.upper), (bb -> bound.upper))
227                               then return ("0"b);
228 
229                          ba = ba -> bound.next;
230                          bb = bb -> bound.next;
231                     end;
232                end;
233 
234           else if a_reference
235                then if pa -> reference.array_ref
236                     then if ^parent_is_scalar
237                          then return ("0"b);
238                          else ;
239                     else parent_is_scalar = "1"b;
240                else if a -> symbol.dimensioned
241                     then return ("0"b);
242 
243           return ("1"b);
244 ^L
245 same_extent_bounds:
246      procedure (a, b) returns (bit (1) aligned) reducible;
247 
248 dcl       a                   ptr;
249 dcl       b                   ptr;
250 
251           if constant_extent (a)
252           then if constant_extent (b)
253                then return ("1"b);
254                else return ("0"b);
255           else if constant_extent (b)
256                then return ("0"b);
257                else return (compare_expression (a, b));
258      end same_extent_bounds;
259 
260 /* An extent is considered constant if it is null or a reference to a constant
261    symbol. */
262 
263 constant_extent:
264      procedure (p) returns (bit (1) aligned) reducible;
265 
266 dcl       p                   ptr;
267 
268           if p = null
269           then return ("1"b);
270 
271           else if p -> node.type = reference_node
272                then if p -> reference.symbol -> symbol.constant
273                     then return ("1"b);
274 
275           return ("0"b);
276      end constant_extent;
277 
278      end match;
279 
280      end match_arguments;