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