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