moids-diagnostics.c
1 //! @file moids-diagnostic.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 //! MOID diagnostics routines.
25
26 #include "a68g.h"
27 #include "a68g-parser.h"
28 #include "a68g-prelude.h"
29 #include "a68g-moids.h"
30
31 //! @brief Give accurate error message.
32
33 char *mode_error_text (NODE_T * n, MOID_T * p, MOID_T * q, int context, int deflex, int depth)
34 {
35 #define TAIL(z) (&(z)[strlen (z)])
36 static BUFFER txt;
37 if (depth == 1) {
38 txt[0] = NULL_CHAR;
39 }
40 if (IS (p, SERIES_MODE)) {
41 PACK_T *u = PACK (p);
42 int N = 0;
43 if (u == NO_PACK) {
44 ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0);
45 N++;
46 } else {
47 for (; u != NO_PACK; FORWARD (u)) {
48 if (MOID (u) != NO_MOID) {
49 if (IS (MOID (u), SERIES_MODE)) {
50 (void) mode_error_text (n, MOID (u), q, context, deflex, depth + 1);
51 } else if (!is_coercible (MOID (u), q, context, deflex)) {
52 int len = (int) strlen (txt);
53 if (len > BUFFER_SIZE / 2) {
54 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0);
55 N++;
56 } else {
57 if (strlen (txt) > 0) {
58 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0);
59 N++;
60 }
61 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0);
62 N++;
63 }
64 }
65 }
66 }
67 }
68 if (depth == 1) {
69 if (N == 0) {
70 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "mode") >= 0);
71 }
72 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s", moid_to_string (q, MOID_ERROR_WIDTH, n)) >= 0);
73 }
74 } else if (IS (p, STOWED_MODE) && IS_FLEX (q)) {
75 PACK_T *u = PACK (p);
76 if (u == NO_PACK) {
77 ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0);
78 } else {
79 for (; u != NO_PACK; FORWARD (u)) {
80 if (!is_coercible (MOID (u), SLICE (SUB (q)), context, deflex)) {
81 int len = (int) strlen (txt);
82 if (len > BUFFER_SIZE / 2) {
83 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0);
84 } else {
85 if (strlen (txt) > 0) {
86 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0);
87 }
88 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0);
89 }
90 }
91 }
92 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s", moid_to_string (SLICE (SUB (q)), MOID_ERROR_WIDTH, n)) >= 0);
93 }
94 } else if (IS (p, STOWED_MODE) && IS (q, ROW_SYMBOL)) {
95 PACK_T *u = PACK (p);
96 if (u == NO_PACK) {
97 ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0);
98 } else {
99 for (; u != NO_PACK; FORWARD (u)) {
100 if (!is_coercible (MOID (u), SLICE (q), context, deflex)) {
101 int len = (int) strlen (txt);
102 if (len > BUFFER_SIZE / 2) {
103 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0);
104 } else {
105 if (strlen (txt) > 0) {
106 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0);
107 }
108 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) >= 0);
109 }
110 }
111 }
112 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s", moid_to_string (SLICE (q), MOID_ERROR_WIDTH, n)) >= 0);
113 }
114 } else if (IS (p, STOWED_MODE) && (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL))) {
115 PACK_T *u = PACK (p), *v = PACK (q);
116 if (u == NO_PACK) {
117 ASSERT (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") >= 0);
118 } else {
119 for (; u != NO_PACK && v != NO_PACK; FORWARD (u), FORWARD (v)) {
120 if (!is_coercible (MOID (u), MOID (v), context, deflex)) {
121 int len = (int) strlen (txt);
122 if (len > BUFFER_SIZE / 2) {
123 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") >= 0);
124 } else {
125 if (strlen (txt) > 0) {
126 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") >= 0);
127 }
128 ASSERT (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s cannot be coerced to %s", moid_to_string (MOID (u), MOID_ERROR_WIDTH, n), moid_to_string (MOID (v), MOID_ERROR_WIDTH, n)) >= 0);
129 }
130 }
131 }
132 }
133 }
134 return txt;
135 #undef TAIL
136 }
137
138 //! @brief Cannot coerce error.
139
140 void cannot_coerce (NODE_T * p, MOID_T * from, MOID_T * to, int context, int deflex, int att)
141 {
142 char *txt = mode_error_text (p, from, to, context, deflex, 1);
143 if (att == STOP) {
144 if (strlen (txt) == 0) {
145 diagnostic (A68_ERROR, p, "M cannot be coerced to M in C context", from, to, context);
146 } else {
147 diagnostic (A68_ERROR, p, "Y in C context", txt, context);
148 }
149 } else {
150 if (strlen (txt) == 0) {
151 diagnostic (A68_ERROR, p, "M cannot be coerced to M in C-A", from, to, context, att);
152 } else {
153 diagnostic (A68_ERROR, p, "Y in C-A", txt, context, att);
154 }
155 }
156 }
157
158 //! @brief Give a warning when a value is silently discarded.
159
160 void warn_for_voiding (NODE_T * p, SOID_T * x, SOID_T * y, int c)
161 {
162 (void) c;
163 if (CAST (x) == A68_FALSE) {
164 if (MOID (x) == M_VOID && MOID (y) != M_ERROR && !(MOID (y) == M_VOID || !is_nonproc (MOID (y)))) {
165 if (IS (p, FORMULA)) {
166 diagnostic (A68_WARNING | A68_FORCE_DIAGNOSTICS, p, WARNING_VOIDED, MOID (y));
167 } else {
168 diagnostic (A68_WARNING, p, WARNING_VOIDED, MOID (y));
169 }
170 }
171 }
172 }
173
174 //! @brief Warn for things that are likely unintended.
175
176 void semantic_pitfall (NODE_T * p, MOID_T * m, int c, int u)
177 {
178 // semantic_pitfall: warn for things that are likely unintended, for instance
179 // REF INT i := LOC INT := 0, which should probably be
180 // REF INT i = LOC INT := 0.
181 if (IS (p, u)) {
182 diagnostic (A68_WARNING, p, WARNING_UNINTENDED, MOID (p), u, m, c);
183 } else if (is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP)) {
184 semantic_pitfall (SUB (p), m, c, u);
185 }
186 }
187
