1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17 match_arguments:
18 procedure (pa, pb) returns (bit (1) aligned);
19
20 dcl pa ptr;
21 dcl pb ptr;
22
23
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
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
45
46
47
48
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
113
114 match:
115 procedure (pa, pb) returns (bit (1) aligned);
116
117 dcl pa ptr;
118 dcl pb ptr;
119
120
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
261
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;