moids-misc.c
1 //! @file moids-misc.c
2 //! @author J. Marcel van der Veer
3
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2024 J. Marcel van der Veer [algol68g@xs4all.nl].
8
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! Miscellaneous MOID routines.
25
26 #include "a68g.h"
27 #include "a68g-parser.h"
28 #include "a68g-moids.h"
29
30 // MODE checker routines.
31
32 //! @brief Absorb nested series modes recursively.
33
34 void absorb_series_pack (MOID_T ** p)
35 {
36 BOOL_T siga;
37 do {
38 PACK_T *z = NO_PACK;
39 siga = A68_FALSE;
40 for (PACK_T *t = PACK (*p); t != NO_PACK; FORWARD (t)) {
41 if (MOID (t) != NO_MOID && IS (MOID (t), SERIES_MODE)) {
42 siga = A68_TRUE;
43 for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) {
44 add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
45 }
46 } else {
47 add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
48 }
49 }
50 PACK (*p) = z;
51 } while (siga);
52 }
53
54 //! @brief Make SERIES (u, v).
55
56 MOID_T *make_series_from_moids (MOID_T * u, MOID_T * v)
57 {
58 MOID_T *x = new_moid ();
59 ATTRIBUTE (x) = SERIES_MODE;
60 add_mode_to_pack (&(PACK (x)), u, NO_TEXT, NODE (u));
61 add_mode_to_pack (&(PACK (x)), v, NO_TEXT, NODE (v));
62 absorb_series_pack (&x);
63 DIM (x) = count_pack_members (PACK (x));
64 (void) register_extra_mode (&TOP_MOID (&A68_JOB), x);
65 if (DIM (x) == 1) {
66 return MOID (PACK (x));
67 } else {
68 return x;
69 }
70 }
71
72 //! @brief Absorb firmly related unions in mode.
73
74 MOID_T *absorb_related_subsets (MOID_T * m)
75 {
76 // For instance invalid UNION (PROC REF UNION (A, B), A, B) -> valid UNION (A, B),
77 // which is used in balancing conformity clauses.
78 BOOL_T siga;
79 do {
80 PACK_T *u = NO_PACK;
81 siga = A68_FALSE;
82 for (PACK_T *v = PACK (m); v != NO_PACK; FORWARD (v)) {
83 MOID_T *n = depref_completely (MOID (v));
84 if (IS (n, UNION_SYMBOL) && is_subset (n, m, SAFE_DEFLEXING)) {
85 // Unpack it.
86 for (PACK_T *w = PACK (n); w != NO_PACK; FORWARD (w)) {
87 add_mode_to_pack (&u, MOID (w), NO_TEXT, NODE (w));
88 }
89 siga = A68_TRUE;
90 } else {
91 add_mode_to_pack (&u, MOID (v), NO_TEXT, NODE (v));
92 }
93 }
94 PACK (m) = absorb_union_pack (u);
95 } while (siga);
96 return m;
97 }
98
99 //! @brief Absorb nested series and united modes recursively.
100
101 void absorb_series_union_pack (MOID_T ** p)
102 {
103 BOOL_T siga;
104 do {
105 PACK_T *z = NO_PACK;
106 siga = A68_FALSE;
107 for (PACK_T *t = PACK (*p); t != NO_PACK; FORWARD (t)) {
108 if (MOID (t) != NO_MOID && (IS (MOID (t), SERIES_MODE) || IS (MOID (t), UNION_SYMBOL))) {
109 siga = A68_TRUE;
110 for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s)) {
111 add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
112 }
113 } else {
114 add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
115 }
116 }
117 PACK (*p) = z;
118 } while (siga);
119 }
120
121 //! @brief Make united mode, from mode that is a SERIES (..).
122
123 MOID_T *make_united_mode (MOID_T * m)
124 {
125 if (m == NO_MOID) {
126 return M_ERROR;
127 } else if (ATTRIBUTE (m) != SERIES_MODE) {
128 return m;
129 }
130 // Do not unite a single UNION.
131 if (DIM (m) == 1 && IS (MOID (PACK (m)), UNION_SYMBOL)) {
132 return MOID (PACK (m));
133 }
134 // Straighten the series.
135 absorb_series_union_pack (&m);
136 // Copy the series into a UNION.
137 MOID_T *u = new_moid ();
138 ATTRIBUTE (u) = UNION_SYMBOL;
139 PACK (u) = NO_PACK;
140 for (PACK_T *w = PACK (m); w != NO_PACK; FORWARD (w)) {
141 add_mode_to_pack (&(PACK (u)), MOID (w), NO_TEXT, NODE (m));
142 }
143 // Absorb and contract the new UNION.
144 absorb_series_union_pack (&u);
145 DIM (u) = count_pack_members (PACK (u));
146 PACK (u) = absorb_union_pack (PACK (u));
147 contract_union (u);
148 DIM (u) = count_pack_members (PACK (u));
149 // A UNION of one mode is that mode itself.
150 if (DIM (u) == 1) {
151 return MOID (PACK (u));
152 } else {
153 return register_extra_mode (&TOP_MOID (&A68_JOB), u);
154 }
155 }
156
157 //! @brief Make SOID data structure.
158
159 void make_soid (SOID_T * s, int sort, MOID_T * type, int attribute)
160 {
161 ATTRIBUTE (s) = attribute;
162 SORT (s) = sort;
163 MOID (s) = type;
164 CAST (s) = A68_FALSE;
165 }
166
167 //! @brief Whether mode is not well defined.
168
169 BOOL_T is_mode_isnt_well (MOID_T * p)
170 {
171 if (p == NO_MOID) {
172 return A68_TRUE;
173 } else if (!IF_MODE_IS_WELL (p)) {
174 return A68_TRUE;
175 } else if (PACK (p) != NO_PACK) {
176 for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q)) {
177 if (!IF_MODE_IS_WELL (MOID (q))) {
178 return A68_TRUE;
179 }
180 }
181 }
182 return A68_FALSE;
183 }
184
185 //! @brief Add SOID data to free chain.
186
187 void free_soid_list (SOID_T * root)
188 {
189 if (root != NO_SOID) {
190 SOID_T *q = root;
191 for (; NEXT (q) != NO_SOID; FORWARD (q)) {
192 ;
193 }
194 NEXT (q) = A68 (top_soid_list);
195 A68 (top_soid_list) = root;
196 }
197 }
198
199 //! @brief Add SOID data structure to soid list.
200
201 void add_to_soid_list (SOID_T ** root, NODE_T * where, SOID_T * soid)
202 {
203 if (*root != NO_SOID) {
204 add_to_soid_list (&(NEXT (*root)), where, soid);
205 } else {
206 SOID_T *new_one;
207 if (A68 (top_soid_list) == NO_SOID) {
208 new_one = (SOID_T *) get_temp_heap_space ((size_t) SIZE_ALIGNED (SOID_T));
209 } else {
210 new_one = A68 (top_soid_list);
211 FORWARD (A68 (top_soid_list));
212 }
213 make_soid (new_one, SORT (soid), MOID (soid), 0);
214 NODE (new_one) = where;
215 NEXT (new_one) = NO_SOID;
216 *root = new_one;
217 }
218 }
219
220 //! @brief Pack soids in moid, gather resulting moids from terminators in a clause.
221
222 MOID_T *pack_soids_in_moid (SOID_T * top_sl, int attribute)
223 {
224 MOID_T *x = new_moid ();
225 PACK_T *t, **p;
226 ATTRIBUTE (x) = attribute;
227 DIM (x) = 0;
228 SUB (x) = NO_MOID;
229 EQUIVALENT (x) = NO_MOID;
230 SLICE (x) = NO_MOID;
231 DEFLEXED (x) = NO_MOID;
232 NAME (x) = NO_MOID;
233 NEXT (x) = NO_MOID;
234 PACK (x) = NO_PACK;
235 p = &(PACK (x));
236 for (; top_sl != NO_SOID; FORWARD (top_sl)) {
237 t = new_pack ();
238 MOID (t) = MOID (top_sl);
239 TEXT (t) = NO_TEXT;
240 NODE (t) = NODE (top_sl);
241 NEXT (t) = NO_PACK;
242 DIM (x)++;
243 *p = t;
244 p = &NEXT (t);
245 }
246 (void) register_extra_mode (&TOP_MOID (&A68_JOB), x);
247 return x;
248 }
249
250 //! @brief Whether "p" is compatible with "q".
251
252 BOOL_T is_equal_modes (MOID_T * p, MOID_T * q, int deflex)
253 {
254 if (deflex == FORCE_DEFLEXING) {
255 return DEFLEX (p) == DEFLEX (q);
256 } else if (deflex == ALIAS_DEFLEXING) {
257 if (IS (p, REF_SYMBOL) && IS (q, REF_SYMBOL)) {
258 return p == q || DEFLEX (p) == q;
259 } else if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL)) {
260 return DEFLEX (p) == DEFLEX (q);
261 }
262 } else if (deflex == SAFE_DEFLEXING) {
263 if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL)) {
264 return DEFLEX (p) == DEFLEX (q);
265 }
266 }
267 return p == q;
268 }
269
270 //! @brief Whether mode is deprefable.
271
272 BOOL_T is_deprefable (MOID_T * p)
273 {
274 if (IS_REF (p)) {
275 return A68_TRUE;
276 } else {
277 return (BOOL_T) (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK);
278 }
279 }
280
281 //! @brief Depref mode once.
282
283 MOID_T *depref_once (MOID_T * p)
284 {
285 if (IS_REF_FLEX (p)) {
286 return SUB_SUB (p);
287 } else if (IS_REF (p)) {
288 return SUB (p);
289 } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
290 return SUB (p);
291 } else {
292 return NO_MOID;
293 }
294 }
295
296 //! @brief Depref mode completely.
297
298 MOID_T *depref_completely (MOID_T * p)
299 {
300 while (is_deprefable (p)) {
301 p = depref_once (p);
302 }
303 return p;
304 }
305
306 //! @brief Deproc_completely.
307
308 MOID_T *deproc_completely (MOID_T * p)
309 {
310 while (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
311 p = depref_once (p);
312 }
313 return p;
314 }
315
316 //! @brief Depref rows.
317
318 MOID_T *depref_rows (MOID_T * p, MOID_T * q)
319 {
320 if (q == M_ROWS) {
321 while (is_deprefable (p)) {
322 p = depref_once (p);
323 }
324 return p;
325 } else {
326 return q;
327 }
328 }
329
330 //! @brief Derow mode, strip FLEX and BOUNDS.
331
332 MOID_T *derow (MOID_T * p)
333 {
334 if (IS_ROW (p) || IS_FLEX (p)) {
335 return derow (SUB (p));
336 } else {
337 return p;
338 }
339 }
340
341 //! @brief Whether rows type.
342
343 BOOL_T is_rows_type (MOID_T * p)
344 {
345 switch (ATTRIBUTE (p)) {
346 case ROW_SYMBOL:
347 case FLEX_SYMBOL: {
348 return A68_TRUE;
349 }
350 case UNION_SYMBOL: {
351 PACK_T *t = PACK (p);
352 BOOL_T siga = A68_TRUE;
353 while (t != NO_PACK && siga) {
354 siga &= is_rows_type (MOID (t));
355 FORWARD (t);
356 }
357 return siga;
358 }
359 default: {
360 return A68_FALSE;
361 }
362 }
363 }
364
365 //! @brief Whether mode is PROC (REF FILE) VOID or FORMAT.
366
367 BOOL_T is_proc_ref_file_void_or_format (const MOID_T * p)
368 {
369 if (p == M_PROC_REF_FILE_VOID) {
370 return A68_TRUE;
371 } else if (p == M_FORMAT) {
372 return A68_TRUE;
373 } else {
374 return A68_FALSE;
375 }
376 }
377
378 //! @brief Whether mode can be transput.
379
380 BOOL_T is_transput_mode (MOID_T * p, char rw)
381 {
382 if (p == M_INT) {
383 return A68_TRUE;
384 } else if (p == M_LONG_INT) {
385 return A68_TRUE;
386 } else if (p == M_LONG_LONG_INT) {
387 return A68_TRUE;
388 } else if (p == M_REAL) {
389 return A68_TRUE;
390 } else if (p == M_LONG_REAL) {
391 return A68_TRUE;
392 } else if (p == M_LONG_LONG_REAL) {
393 return A68_TRUE;
394 } else if (p == M_BOOL) {
395 return A68_TRUE;
396 } else if (p == M_CHAR) {
397 return A68_TRUE;
398 } else if (p == M_BITS) {
399 return A68_TRUE;
400 } else if (p == M_LONG_BITS) {
401 return A68_TRUE;
402 } else if (p == M_LONG_LONG_BITS) {
403 return A68_TRUE;
404 } else if (p == M_COMPLEX) {
405 return A68_TRUE;
406 } else if (p == M_LONG_COMPLEX) {
407 return A68_TRUE;
408 } else if (p == M_LONG_LONG_COMPLEX) {
409 return A68_TRUE;
410 } else if (p == M_ROW_CHAR) {
411 return A68_TRUE;
412 } else if (p == M_STRING) {
413 return A68_TRUE;
414 } else if (p == M_SOUND) {
415 return A68_TRUE;
416 } else if (IS (p, UNION_SYMBOL) || IS (p, STRUCT_SYMBOL)) {
417 for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q)) {
418 if (! (is_transput_mode (MOID (q), rw) || is_proc_ref_file_void_or_format (MOID (q)))) {
419 return A68_FALSE;
420 }
421 }
422 return A68_TRUE;
423 } else if (IS_FLEX (p)) {
424 if (SUB (p) == M_ROW_CHAR) {
425 return A68_TRUE;
426 } else {
427 return (BOOL_T) (rw == 'w' ? is_transput_mode (SUB (p), rw) : A68_FALSE);
428 }
429 } else if (IS_ROW (p)) {
430 return (BOOL_T) (is_transput_mode (SUB (p), rw) || is_proc_ref_file_void_or_format (SUB (p)));
431 } else {
432 return A68_FALSE;
433 }
434 }
435
436 //! @brief Whether mode is printable.
437
438 BOOL_T is_printable_mode (MOID_T * p)
439 {
440 if (is_proc_ref_file_void_or_format (p)) {
441 return A68_TRUE;
442 } else {
443 return is_transput_mode (p, 'w');
444 }
445 }
446
447 //! @brief Whether mode is readable.
448
449 BOOL_T is_readable_mode (MOID_T * p)
450 {
451 if (is_proc_ref_file_void_or_format (p)) {
452 return A68_TRUE;
453 } else if (IS_REF (p)) {
454 return is_transput_mode (SUB (p), 'r');
455 } else if (IS_UNION (p)) {
456 for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q)) {
457 if (!IS_REF (MOID (q))) {
458 return A68_FALSE;
459 } else if (!is_transput_mode (SUB (MOID (q)), 'r')) {
460 return A68_FALSE;
461 }
462 }
463 return A68_TRUE;
464 } else {
465 return A68_FALSE;
466 }
467 }
468
469 //! @brief Whether name struct.
470
471 BOOL_T is_name_struct (MOID_T * p)
472 {
473 return (BOOL_T) (NAME (p) != NO_MOID ? IS (DEFLEX (SUB (p)), STRUCT_SYMBOL) : A68_FALSE);
474 }
475
476 //! @brief Yield mode to unite to.
477
478 MOID_T *unites_to (MOID_T * m, MOID_T * u)
479 {
480 // Uniting U (m).
481 MOID_T *v = NO_MOID;
482 if (u == M_SIMPLIN || u == M_SIMPLOUT) {
483 return m;
484 }
485 for (PACK_T *p = PACK (u); p != NO_PACK; FORWARD (p)) {
486 // Prefer []->[] over []->FLEX [].
487 if (m == MOID (p)) {
488 v = MOID (p);
489 } else if (v == NO_MOID && DEFLEX (m) == DEFLEX (MOID (p))) {
490 v = MOID (p);
491 }
492 }
493 return v;
494 }
495
496 //! @brief Whether moid in pack.
497
498 BOOL_T is_moid_in_pack (MOID_T * u, PACK_T * v, int deflex)
499 {
500 for (; v != NO_PACK; FORWARD (v)) {
501 if (is_equal_modes (u, MOID (v), deflex)) {
502 return A68_TRUE;
503 }
504 }
505 return A68_FALSE;
506 }
507
508 //! @brief Whether "p" is a subset of "q".
509
510 BOOL_T is_subset (MOID_T * p, MOID_T * q, int deflex)
511 {
512 BOOL_T j = A68_TRUE;
513 for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u)) {
514 j = (BOOL_T) (j && is_moid_in_pack (MOID (u), PACK (q), deflex));
515 }
516 return j;
517 }
518
519 //! @brief Whether "p" can be united to UNION "q".
520
521 BOOL_T is_unitable (MOID_T * p, MOID_T * q, int deflex)
522 {
523 if (IS (q, UNION_SYMBOL)) {
524 if (IS (p, UNION_SYMBOL)) {
525 return is_subset (p, q, deflex);
526 } else {
527 return is_moid_in_pack (p, PACK (q), deflex);
528 }
529 }
530 return A68_FALSE;
531 }
532
533 //! @brief Whether all or some components of "u" can be firmly coerced to a component mode of "v"..
534
535 void investigate_firm_relations (PACK_T * u, PACK_T * v, BOOL_T * all, BOOL_T * some)
536 {
537 *all = A68_TRUE;
538 *some = A68_FALSE;
539 for (; v != NO_PACK; FORWARD (v)) {
540 BOOL_T k = A68_FALSE;
541 for (PACK_T *w = u; w != NO_PACK; FORWARD (w)) {
542 k |= is_coercible (MOID (w), MOID (v), FIRM, FORCE_DEFLEXING);
543 }
544 *some |= k;
545 *all &= k;
546 }
547 }
548
549 //! @brief Whether there is a soft path from "p" to "q".
550
551 BOOL_T is_softly_coercible (MOID_T * p, MOID_T * q, int deflex)
552 {
553 if (is_equal_modes (p, q, deflex)) {
554 return A68_TRUE;
555 } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
556 return is_softly_coercible (SUB (p), q, deflex);
557 } else {
558 return A68_FALSE;
559 }
560 }
561
562 //! @brief Whether there is a weak path from "p" to "q".
563
564 BOOL_T is_weakly_coercible (MOID_T * p, MOID_T * q, int deflex)
565 {
566 if (is_equal_modes (p, q, deflex)) {
567 return A68_TRUE;
568 } else if (is_deprefable (p)) {
569 return is_weakly_coercible (depref_once (p), q, deflex);
570 } else {
571 return A68_FALSE;
572 }
573 }
574
575 //! @brief Whether there is a meek path from "p" to "q".
576
577 BOOL_T is_meekly_coercible (MOID_T * p, MOID_T * q, int deflex)
578 {
579 if (is_equal_modes (p, q, deflex)) {
580 return A68_TRUE;
581 } else if (is_deprefable (p)) {
582 return is_meekly_coercible (depref_once (p), q, deflex);
583 } else {
584 return A68_FALSE;
585 }
586 }
587
588 //! @brief Whether there is a firm path from "p" to "q".
589
590 BOOL_T is_firmly_coercible (MOID_T * p, MOID_T * q, int deflex)
591 {
592 if (is_equal_modes (p, q, deflex)) {
593 return A68_TRUE;
594 } else if (q == M_ROWS && is_rows_type (p)) {
595 return A68_TRUE;
596 } else if (is_unitable (p, q, deflex)) {
597 return A68_TRUE;
598 } else if (is_deprefable (p)) {
599 return is_firmly_coercible (depref_once (p), q, deflex);
600 } else {
601 return A68_FALSE;
602 }
603 }
604
605 //! @brief Whether firm.
606
607 BOOL_T is_firm (MOID_T * p, MOID_T * q)
608 {
609 return (BOOL_T) (is_firmly_coercible (p, q, SAFE_DEFLEXING) || is_firmly_coercible (q, p, SAFE_DEFLEXING));
610 }
611
612 //! @brief Whether "p" widens to "q".
613
614 MOID_T *widens_to (const MOID_T * p, const MOID_T * q)
615 {
616 if (p == M_INT) {
617 if (q == M_LONG_INT || q == M_LONG_LONG_INT || q == M_LONG_REAL || q == M_LONG_LONG_REAL || q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) {
618 return M_LONG_INT;
619 } else if (q == M_REAL || q == M_COMPLEX) {
620 return M_REAL;
621 } else {
622 return NO_MOID;
623 }
624 } else if (p == M_LONG_INT) {
625 if (q == M_LONG_LONG_INT) {
626 return M_LONG_LONG_INT;
627 } else if (q == M_LONG_REAL || q == M_LONG_LONG_REAL || q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) {
628 return M_LONG_REAL;
629 } else {
630 return NO_MOID;
631 }
632 } else if (p == M_LONG_LONG_INT) {
633 if (q == M_LONG_LONG_REAL || q == M_LONG_LONG_COMPLEX) {
634 return M_LONG_LONG_REAL;
635 } else {
636 return NO_MOID;
637 }
638 } else if (p == M_REAL) {
639 if (q == M_LONG_REAL || q == M_LONG_LONG_REAL || q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) {
640 return M_LONG_REAL;
641 } else if (q == M_COMPLEX) {
642 return M_COMPLEX;
643 } else {
644 return NO_MOID;
645 }
646 } else if (p == M_COMPLEX) {
647 if (q == M_LONG_COMPLEX || q == M_LONG_LONG_COMPLEX) {
648 return M_LONG_COMPLEX;
649 } else {
650 return NO_MOID;
651 }
652 } else if (p == M_LONG_REAL) {
653 if (q == M_LONG_LONG_REAL || q == M_LONG_LONG_COMPLEX) {
654 return M_LONG_LONG_REAL;
655 } else if (q == M_LONG_COMPLEX) {
656 return M_LONG_COMPLEX;
657 } else {
658 return NO_MOID;
659 }
660 } else if (p == M_LONG_COMPLEX) {
661 if (q == M_LONG_LONG_COMPLEX) {
662 return M_LONG_LONG_COMPLEX;
663 } else {
664 return NO_MOID;
665 }
666 } else if (p == M_LONG_LONG_REAL) {
667 if (q == M_LONG_LONG_COMPLEX) {
668 return M_LONG_LONG_COMPLEX;
669 } else {
670 return NO_MOID;
671 }
672 } else if (p == M_BITS) {
673 if (q == M_LONG_BITS || q == M_LONG_LONG_BITS) {
674 return M_LONG_BITS;
675 } else if (q == M_ROW_BOOL) {
676 return M_ROW_BOOL;
677 } else if (q == M_FLEX_ROW_BOOL) {
678 return M_FLEX_ROW_BOOL;
679 } else {
680 return NO_MOID;
681 }
682 } else if (p == M_LONG_BITS) {
683 if (q == M_LONG_LONG_BITS) {
684 return M_LONG_LONG_BITS;
685 } else if (q == M_ROW_BOOL) {
686 return M_ROW_BOOL;
687 } else if (q == M_FLEX_ROW_BOOL) {
688 return M_FLEX_ROW_BOOL;
689 } else {
690 return NO_MOID;
691 }
692 } else if (p == M_LONG_LONG_BITS) {
693 if (q == M_ROW_BOOL) {
694 return M_ROW_BOOL;
695 } else if (q == M_FLEX_ROW_BOOL) {
696 return M_FLEX_ROW_BOOL;
697 } else {
698 return NO_MOID;
699 }
700 } else if (p == M_BYTES && q == M_ROW_CHAR) {
701 return M_ROW_CHAR;
702 } else if (p == M_LONG_BYTES && q == M_ROW_CHAR) {
703 return M_ROW_CHAR;
704 } else if (p == M_BYTES && q == M_FLEX_ROW_CHAR) {
705 return M_FLEX_ROW_CHAR;
706 } else if (p == M_LONG_BYTES && q == M_FLEX_ROW_CHAR) {
707 return M_FLEX_ROW_CHAR;
708 } else {
709 return NO_MOID;
710 }
711 }
712
713 //! @brief Whether "p" widens to "q".
714
715 BOOL_T is_widenable (MOID_T * p, MOID_T * q)
716 {
717 MOID_T *z = widens_to (p, q);
718 if (z != NO_MOID) {
719 return (BOOL_T) (z == q ? A68_TRUE : is_widenable (z, q));
720 } else {
721 return A68_FALSE;
722 }
723 }
724
725 //! @brief Whether "p" is a REF ROW.
726
727 BOOL_T is_ref_row (MOID_T * p)
728 {
729 return (BOOL_T) (NAME (p) != NO_MOID ? IS_ROW (DEFLEX (SUB (p))) : A68_FALSE);
730 }
731
732 //! @brief Whether strong name.
733
734 BOOL_T is_strong_name (MOID_T * p, MOID_T * q)
735 {
736 if (p == q) {
737 return A68_TRUE;
738 } else if (is_ref_row (q)) {
739 return is_strong_name (p, NAME (q));
740 } else {
741 return A68_FALSE;
742 }
743 }
744
745 //! @brief Whether strong slice.
746
747 BOOL_T is_strong_slice (MOID_T * p, MOID_T * q)
748 {
749 if (p == q || is_widenable (p, q)) {
750 return A68_TRUE;
751 } else if (SLICE (q) != NO_MOID) {
752 return is_strong_slice (p, SLICE (q));
753 } else if (IS_FLEX (q)) {
754 return is_strong_slice (p, SUB (q));
755 } else if (is_ref_row (q)) {
756 return is_strong_name (p, q);
757 } else {
758 return A68_FALSE;
759 }
760 }
761
762 //! @brief Whether strongly coercible.
763
764 BOOL_T is_strongly_coercible (MOID_T * p, MOID_T * q, int deflex)
765 {
766 // Keep this sequence of statements.
767 if (is_equal_modes (p, q, deflex)) {
768 return A68_TRUE;
769 } else if (q == M_VOID) {
770 return A68_TRUE;
771 } else if ((q == M_SIMPLIN || q == M_ROW_SIMPLIN) && is_readable_mode (p)) {
772 return A68_TRUE;
773 } else if (q == M_ROWS && is_rows_type (p)) {
774 return A68_TRUE;
775 } else if (is_unitable (p, derow (q), deflex)) {
776 return A68_TRUE;
777 }
778 if (is_ref_row (q) && is_strong_name (p, q)) {
779 return A68_TRUE;
780 } else if (SLICE (q) != NO_MOID && is_strong_slice (p, q)) {
781 return A68_TRUE;
782 } else if (IS_FLEX (q) && is_strong_slice (p, q)) {
783 return A68_TRUE;
784 } else if (is_widenable (p, q)) {
785 return A68_TRUE;
786 } else if (is_deprefable (p)) {
787 return is_strongly_coercible (depref_once (p), q, deflex);
788 } else if (q == M_SIMPLOUT || q == M_ROW_SIMPLOUT) {
789 return is_printable_mode (p);
790 } else {
791 return A68_FALSE;
792 }
793 }
794
795 //! @brief Basic coercions.
796
797 BOOL_T basic_coercions (MOID_T * p, MOID_T * q, int c, int deflex)
798 {
799 if (is_equal_modes (p, q, deflex)) {
800 return A68_TRUE;
801 } else if (c == NO_SORT) {
802 return (BOOL_T) (p == q);
803 } else if (c == SOFT) {
804 return is_softly_coercible (p, q, deflex);
805 } else if (c == WEAK) {
806 return is_weakly_coercible (p, q, deflex);
807 } else if (c == MEEK) {
808 return is_meekly_coercible (p, q, deflex);
809 } else if (c == FIRM) {
810 return is_firmly_coercible (p, q, deflex);
811 } else if (c == STRONG) {
812 return is_strongly_coercible (p, q, deflex);
813 } else {
814 return A68_FALSE;
815 }
816 }
817
818 //! @brief Whether coercible stowed.
819
820 BOOL_T is_coercible_stowed (MOID_T * p, MOID_T * q, int c, int deflex)
821 {
822 if (c != STRONG) {
823 // Such construct is always in a strong position, is it not?
824 return A68_FALSE;
825 } else if (q == M_VOID) {
826 return A68_TRUE;
827 } else if (IS_FLEX (q)) {
828 BOOL_T j = A68_TRUE;
829 for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u)) {
830 j &= is_coercible (MOID (u), SLICE (SUB (q)), c, deflex);
831 }
832 return j;
833 } else if (IS_ROW (q)) {
834 BOOL_T j = A68_TRUE;
835 for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u)) {
836 j &= is_coercible (MOID (u), SLICE (q), c, deflex);
837 }
838 return j;
839 } else if (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL)) {
840 if (DIM (p) != DIM (q)) {
841 return A68_FALSE;
842 } else {
843 PACK_T *u = PACK (p), *v = PACK (q);
844 BOOL_T j = A68_TRUE;
845 while (u != NO_PACK && v != NO_PACK && j) {
846 j &= is_coercible (MOID (u), MOID (v), c, deflex);
847 FORWARD (u);
848 FORWARD (v);
849 }
850 return j;
851 }
852 } else {
853 return A68_FALSE;
854 }
855 }
856
857 //! @brief Whether coercible series.
858
859 BOOL_T is_coercible_series (MOID_T * p, MOID_T * q, int c, int deflex)
860 {
861 if (c == NO_SORT) {
862 return A68_FALSE;
863 } else if (p == NO_MOID || q == NO_MOID) {
864 return A68_FALSE;
865 } else if (IS (p, SERIES_MODE) && PACK (p) == NO_PACK) {
866 return A68_FALSE;
867 } else if (IS (q, SERIES_MODE) && PACK (q) == NO_PACK) {
868 return A68_FALSE;
869 } else if (PACK (p) == NO_PACK) {
870 return is_coercible (p, q, c, deflex);
871 } else {
872 BOOL_T j = A68_TRUE;
873 for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u)) {
874 if (MOID (u) != NO_MOID) {
875 j &= is_coercible (MOID (u), q, c, deflex);
876 }
877 }
878 return j;
879 }
880 }
881
882 //! @brief Whether "p" can be coerced to "q" in a "c" context.
883
884 BOOL_T is_coercible (MOID_T * p, MOID_T * q, int c, int deflex)
885 {
886 if (is_mode_isnt_well (p) || is_mode_isnt_well (q)) {
887 return A68_TRUE;
888 } else if (is_equal_modes (p, q, deflex)) {
889 return A68_TRUE;
890 } else if (p == M_HIP) {
891 return A68_TRUE;
892 } else if (IS (p, STOWED_MODE)) {
893 return is_coercible_stowed (p, q, c, deflex);
894 } else if (IS (p, SERIES_MODE)) {
895 return is_coercible_series (p, q, c, deflex);
896 } else if (p == M_VACUUM && IS_ROW (DEFLEX (q))) {
897 return A68_TRUE;
898 } else {
899 return basic_coercions (p, q, c, deflex);
900 }
901 }
902
903 //! @brief Whether coercible in context.
904
905 BOOL_T is_coercible_in_context (SOID_T * p, SOID_T * q, int deflex)
906 {
907 if (SORT (p) != SORT (q)) {
908 return A68_FALSE;
909 } else if (MOID (p) == MOID (q)) {
910 return A68_TRUE;
911 } else {
912 return is_coercible (MOID (p), MOID (q), SORT (q), deflex);
913 }
914 }
915
916 //! @brief Whether list "y" is balanced.
917
918 BOOL_T is_balanced (NODE_T * n, SOID_T * y, int sort)
919 {
920 if (sort == STRONG) {
921 return A68_TRUE;
922 } else {
923 BOOL_T k = A68_FALSE;
924 for (; y != NO_SOID && !k; FORWARD (y)) {
925 k = (BOOL_T) (!IS (MOID (y), STOWED_MODE));
926 }
927 if (k == A68_FALSE) {
928 diagnostic (A68_ERROR, n, ERROR_NO_UNIQUE_MODE);
929 }
930 return k;
931 }
932 }
933
934 //! @brief A moid from "m" to which all other members can be coerced.
935
936 MOID_T *get_balanced_mode (MOID_T * m, int sort, BOOL_T return_depreffed, int deflex)
937 {
938 MOID_T *common_moid = NO_MOID;
939 if (m != NO_MOID && !is_mode_isnt_well (m) && IS (m, UNION_SYMBOL)) {
940 int depref_level;
941 BOOL_T siga = A68_TRUE;
942 // Test for increasing depreffing.
943 for (depref_level = 0; siga; depref_level++) {
944 siga = A68_FALSE;
945 // Test the whole pack.
946 for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) {
947 // HIPs are not eligible of course.
948 if (MOID (p) != M_HIP) {
949 MOID_T *candidate = MOID (p);
950 int k;
951 // Depref as far as allowed.
952 for (k = depref_level; k > 0 && is_deprefable (candidate); k--) {
953 candidate = depref_once (candidate);
954 }
955 // Only need testing if all allowed deprefs succeeded.
956 if (k == 0) {
957 MOID_T *to = (return_depreffed ? depref_completely (candidate) : candidate);
958 BOOL_T all_coercible = A68_TRUE;
959 siga = A68_TRUE;
960 for (PACK_T *q = PACK (m); q != NO_PACK && all_coercible; FORWARD (q)) {
961 MOID_T *from = MOID (q);
962 if (p != q && from != to) {
963 all_coercible &= is_coercible (from, to, sort, deflex);
964 }
965 }
966 // If the pack is coercible to the candidate, we mark the candidate.
967 // We continue searching for longest series of REF REF PROC REF.
968 if (all_coercible) {
969 MOID_T *mark = (return_depreffed ? MOID (p) : candidate);
970 if (common_moid == NO_MOID) {
971 common_moid = mark;
972 } else if (IS_FLEX (candidate) && DEFLEX (candidate) == common_moid) {
973 // We prefer FLEX.
974 common_moid = mark;
975 }
976 }
977 }
978 }
979 } // for
980 } // for
981 }
982 return common_moid == NO_MOID ? m : common_moid;
983 }
984
985 //! @brief Whether we can search a common mode from a clause or not.
986
987 BOOL_T clause_allows_balancing (int att)
988 {
989 switch (att) {
990 case CLOSED_CLAUSE:
991 case CONDITIONAL_CLAUSE:
992 case CASE_CLAUSE:
993 case SERIAL_CLAUSE:
994 case CONFORMITY_CLAUSE: {
995 return A68_TRUE;
996 }
997 }
998 return A68_FALSE;
999 }
1000
1001 //! @brief A unique mode from "z".
1002
1003 MOID_T *determine_unique_mode (SOID_T * z, int deflex)
1004 {
1005 if (z == NO_SOID) {
1006 return NO_MOID;
1007 } else {
1008 MOID_T *x = MOID (z);
1009 if (is_mode_isnt_well (x)) {
1010 return M_ERROR;
1011 }
1012 x = make_united_mode (x);
1013 if (clause_allows_balancing (ATTRIBUTE (z))) {
1014 return get_balanced_mode (x, STRONG, NO_DEPREF, deflex);
1015 } else {
1016 return x;
1017 }
1018 }
1019 }
1020
1021 //! @brief Insert coercion "a" in the tree.
1022
1023 void make_coercion (NODE_T * l, int a, MOID_T * m)
1024 {
1025 make_sub (l, l, a);
1026 MOID (l) = depref_rows (MOID (l), m);
1027 }
1028
1029 //! @brief Make widening coercion.
1030
1031 void make_widening_coercion (NODE_T * n, MOID_T * p, MOID_T * q)
1032 {
1033 MOID_T *z = widens_to (p, q);
1034 make_coercion (n, WIDENING, z);
1035 if (z != q) {
1036 make_widening_coercion (n, z, q);
1037 }
1038 }
1039
1040 //! @brief Make ref rowing coercion.
1041
1042 void make_ref_rowing_coercion (NODE_T * n, MOID_T * p, MOID_T * q)
1043 {
1044 if (DEFLEX (p) != DEFLEX (q)) {
1045 if (is_widenable (p, q)) {
1046 make_widening_coercion (n, p, q);
1047 } else if (is_ref_row (q)) {
1048 make_ref_rowing_coercion (n, p, NAME (q));
1049 make_coercion (n, ROWING, q);
1050 }
1051 }
1052 }
1053
1054 //! @brief Make rowing coercion.
1055
1056 void make_rowing_coercion (NODE_T * n, MOID_T * p, MOID_T * q)
1057 {
1058 if (DEFLEX (p) != DEFLEX (q)) {
1059 if (is_widenable (p, q)) {
1060 make_widening_coercion (n, p, q);
1061 } else if (SLICE (q) != NO_MOID) {
1062 make_rowing_coercion (n, p, SLICE (q));
1063 make_coercion (n, ROWING, q);
1064 } else if (IS_FLEX (q)) {
1065 make_rowing_coercion (n, p, SUB (q));
1066 } else if (is_ref_row (q)) {
1067 make_ref_rowing_coercion (n, p, q);
1068 }
1069 }
1070 }
1071
1072 //! @brief Make uniting coercion.
1073
1074 void make_uniting_coercion (NODE_T * n, MOID_T * q)
1075 {
1076 make_coercion (n, UNITING, derow (q));
1077 if (IS_ROW (q) || IS_FLEX (q)) {
1078 make_rowing_coercion (n, derow (q), q);
1079 }
1080 }
1081
1082 //! @brief Make depreffing coercion.
1083
1084 void make_depreffing_coercion (NODE_T * n, MOID_T * p, MOID_T * q)
1085 {
1086 if (DEFLEX (p) == DEFLEX (q)) {
1087 return;
1088 } else if (q == M_SIMPLOUT && is_printable_mode (p)) {
1089 make_coercion (n, UNITING, q);
1090 } else if (q == M_ROW_SIMPLOUT && is_printable_mode (p)) {
1091 make_coercion (n, UNITING, M_SIMPLOUT);
1092 make_coercion (n, ROWING, M_ROW_SIMPLOUT);
1093 } else if (q == M_SIMPLIN && is_readable_mode (p)) {
1094 make_coercion (n, UNITING, q);
1095 } else if (q == M_ROW_SIMPLIN && is_readable_mode (p)) {
1096 make_coercion (n, UNITING, M_SIMPLIN);
1097 make_coercion (n, ROWING, M_ROW_SIMPLIN);
1098 } else if (q == M_ROWS && is_rows_type (p)) {
1099 make_coercion (n, UNITING, M_ROWS);
1100 MOID (n) = M_ROWS;
1101 } else if (is_widenable (p, q)) {
1102 make_widening_coercion (n, p, q);
1103 } else if (is_unitable (p, derow (q), SAFE_DEFLEXING)) {
1104 make_uniting_coercion (n, q);
1105 } else if (is_ref_row (q) && is_strong_name (p, q)) {
1106 make_ref_rowing_coercion (n, p, q);
1107 } else if (SLICE (q) != NO_MOID && is_strong_slice (p, q)) {
1108 make_rowing_coercion (n, p, q);
1109 } else if (IS_FLEX (q) && is_strong_slice (p, q)) {
1110 make_rowing_coercion (n, p, q);
1111 } else if (IS_REF (p)) {
1112 MOID_T *r = depref_once (p);
1113 make_coercion (n, DEREFERENCING, r);
1114 make_depreffing_coercion (n, r, q);
1115 } else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
1116 MOID_T *r = SUB (p);
1117 make_coercion (n, DEPROCEDURING, r);
1118 make_depreffing_coercion (n, r, q);
1119 } else if (p != q) {
1120 cannot_coerce (n, p, q, NO_SORT, SKIP_DEFLEXING, 0);
1121 }
1122 }
1123
1124 //! @brief Whether p is a nonproc mode (that is voided directly).
1125
1126 BOOL_T is_nonproc (MOID_T * p)
1127 {
1128 if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK) {
1129 return A68_FALSE;
1130 } else if (IS_REF (p)) {
1131 return is_nonproc (SUB (p));
1132 } else {
1133 return A68_TRUE;
1134 }
1135 }
1136
1137 //! @brief Make_void: voiden in an appropriate way.
1138
1139 void make_void (NODE_T * p, MOID_T * q)
1140 {
1141 switch (ATTRIBUTE (p)) {
1142 case ASSIGNATION:
1143 case IDENTITY_RELATION:
1144 case GENERATOR:
1145 case CAST:
1146 case DENOTATION: {
1147 make_coercion (p, VOIDING, M_VOID);
1148 return;
1149 }
1150 }
1151 // MORFs are an involved case.
1152 switch (ATTRIBUTE (p)) {
1153 case SELECTION:
1154 case SLICE:
1155 case ROUTINE_TEXT:
1156 case FORMULA:
1157 case CALL:
1158 case IDENTIFIER: {
1159 // A nonproc moid value is eliminated directly.
1160 if (is_nonproc (q)) {
1161 make_coercion (p, VOIDING, M_VOID);
1162 return;
1163 } else {
1164 // Descend the chain of e.g. REF PROC .. until a nonproc moid remains.
1165 MOID_T *z = q;
1166 while (!is_nonproc (z)) {
1167 if (IS_REF (z)) {
1168 make_coercion (p, DEREFERENCING, SUB (z));
1169 }
1170 if (IS (z, PROC_SYMBOL) && NODE_PACK (p) == NO_PACK) {
1171 make_coercion (p, DEPROCEDURING, SUB (z));
1172 }
1173 z = SUB (z);
1174 }
1175 if (z != M_VOID) {
1176 make_coercion (p, VOIDING, M_VOID);
1177 }
1178 return;
1179 }
1180 }
1181 }
1182 // All other is voided straight away.
1183 make_coercion (p, VOIDING, M_VOID);
1184 }
1185
1186 //! @brief Make strong coercion.
1187
1188 void make_strong (NODE_T * n, MOID_T * p, MOID_T * q)
1189 {
1190 if (q == M_VOID && p != M_VOID) {
1191 make_void (n, p);
1192 } else {
1193 make_depreffing_coercion (n, p, q);
1194 }
1195 }
1196
