TeamHeptaMirrors/gcc
1
0
Fork 1
mirror of https://github.com/gcc-mirror/gcc.git synced 2026-05-06 23:25:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

a68: make Algol 68 diagnostics to use pp_format tags

Browse Source 
This commit changes the Algol 68 front-end diagnostics so it uses
regular format strings as recognized as pp_format, instead of the
upper-letter tags inherited from Genie.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>

gcc/algol68/ChangeLog

	* a68-pretty-print.h: New file.
	* a68.h: Mark prototypes of diagnostic functions with
	ATTRIBUTE_A68_DIAG.
	* a68-diagnostics.cc (diagnostic): Do not translate upper-case
	tags and pass a copy of the va_list `args' to diagnostic_set_info.
	Mark with ATTRIBUTE_A68_DIAG.
	* a68-imports-archive.cc: Convert to use standard error format
	tags.
	* a68-parser-victal.cc: Likewise.
	* a68-parser-top-down.cc: Likewise.
	* a68-parser-taxes.cc: Likewise.
	* a68-parser-scanner.cc: Likeise.
	* a68-parser-moids-check.cc: Likewise.
	* a68-parser-modes.cc: Likewise.
	* a68-parser-extract.cc: Likewise.
	* a68-parser-pragmat.cc: Likewise.
	* a68-parser-scope.cc: Likewise.
	* a68-parser-brackets.cc: Likewise.
	* a68-parser-bottom-up.cc: LIkewise.
	* a68-moids-diagnostics.cc: Likewise.
	* a68-imports.cc: Likewise.
This commit is contained in:
Jose E. Marchesi
2026-02-21 14:53:55 +01:00
parent d394677a34
commit 987dc2c482
17 changed files with 593 additions and 385 deletions
Download Patch File Download Diff File Expand all files Collapse all files

222
gcc/algol68/a68-diagnostics.cc
View File

@@ -26,6 +26,7 @@
#include "diagnostic.h"
#include "a68.h"
#include "a68-pretty-print.h"
/*
* Error handling routines.
@@ -41,227 +42,17 @@
#define A68_SCAN_ERROR 3
#define A68_INFORM 4
/* Auxiliary function used to grow an obstack by the contents of some given
string. */
static void
obstack_append_str (obstack *b, const char *str)
{
obstack_grow (b, str, strlen (str));
}
/* Give a diagnostic message. */
#if __GNUC__ >= 10
#pragma GCC diagnostic ignored "-Wsuggest-attribute=format"
#endif
ATTRIBUTE_A68_DIAG(6,0)
static bool
diagnostic (int sev, int opt,
NODE_T *p,
LINE_T *line,
char *pos,
const char *loc_str, va_list args)
const char *format, va_list args)
{
int res = 0;
MOID_T *moid = NO_MOID;
const char *t = loc_str;
obstack b;
/*
* Synthesize diagnostic message.
*
* Legend for special symbols:
* * as first character, copy rest of string literally
* @ AST node
* A AST node attribute
* B keyword
* C context
* L line number
* M moid - if error mode return without giving a message
* O moid - operand
* S quoted symbol, when possible with typographical display features
* X expected attribute
* Y string literal.
* Z quoted string. */
static va_list argp; /* Note this is empty. */
gcc_obstack_init (&b);
if (t[0] == '*')
obstack_append_str (&b, t + 1);
else
while (t[0] != '\0')
{
if (t[0] == '@')
{
const char *nt = a68_attribute_name (ATTRIBUTE (p));
if (t != NO_TEXT)
obstack_append_str (&b, nt);
else
obstack_append_str (&b, "construct");
}
else if (t[0] == 'A')
{
enum a68_attribute att = (enum a68_attribute) va_arg (args, int);
const char *nt = a68_attribute_name (att);
if (nt != NO_TEXT)
obstack_append_str (&b, nt);
else
obstack_append_str (&b, "construct");
}
else if (t[0] == 'B')
{
enum a68_attribute att = (enum a68_attribute) va_arg (args, int);
KEYWORD_T *nt = a68_find_keyword_from_attribute (A68 (top_keyword), att);
if (nt != NO_KEYWORD)
{
const char *strop_keyword = a68_strop_keyword (TEXT (nt));
obstack_append_str (&b, "%<");
obstack_append_str (&b, strop_keyword);
obstack_append_str (&b, "%>");
}
else
obstack_append_str (&b, "keyword");
}
else if (t[0] == 'C')
{
int att = va_arg (args, int);
const char *sort = NULL;
switch (att)
{
case NO_SORT: sort = "this"; break;
case SOFT: sort = "a soft"; break;
case WEAK: sort = "a weak"; break;
case MEEK: sort = "a meek"; break;
case FIRM: sort = "a firm"; break;
case STRONG: sort = "a strong"; break;
default:
gcc_unreachable ();
}
obstack_append_str (&b, sort);
}
else if (t[0] == 'L')
{
LINE_T *a = va_arg (args, LINE_T *);
gcc_assert (a != NO_LINE);
if (NUMBER (a) == 0)
obstack_append_str (&b, "in standard environment");
else if (p != NO_NODE && NUMBER (a) == LINE_NUMBER (p))
obstack_append_str (&b, "in this line");
else
{
char d[18];
if (snprintf (d, 18, "in line %d", NUMBER (a)) < 0)
gcc_unreachable ();
obstack_append_str (&b, d);
}
}
else if (t[0] == 'M')
{
const char *moidstr = NULL;
moid = va_arg (args, MOID_T *);
if (moid == NO_MOID || moid == M_ERROR)
moid = M_UNDEFINED;
if (IS (moid, SERIES_MODE))
{
if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK)
moidstr = a68_moid_to_string (MOID (PACK (moid)),
MOID_ERROR_WIDTH, p);
else
moidstr = a68_moid_to_string (moid, MOID_ERROR_WIDTH, p);
}
else
moidstr = a68_moid_to_string (moid, MOID_ERROR_WIDTH, p);
obstack_append_str (&b, "%<");
obstack_append_str (&b, moidstr);
obstack_append_str (&b, "%>");
}
else if (t[0] == 'O')
{
moid = va_arg (args, MOID_T *);
if (moid == NO_MOID || moid == M_ERROR)
moid = M_UNDEFINED;
if (moid == M_VOID)
obstack_append_str (&b, "UNION (VOID, ..)");
else if (IS (moid, SERIES_MODE))
{
const char *moidstr = NULL;
if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK)
moidstr = a68_moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p);
else
moidstr = a68_moid_to_string (moid, MOID_ERROR_WIDTH, p);
obstack_append_str (&b, moidstr);
}
else
{
const char *moidstr = a68_moid_to_string (moid, MOID_ERROR_WIDTH, p);
obstack_append_str (&b, moidstr);
}
}
else if (t[0] == 'S')
{
if (p != NO_NODE && NSYMBOL (p) != NO_TEXT)
{
const char *txt = NSYMBOL (p);
char *sym = NCHAR_IN_LINE (p);
int n = 0, size = (int) strlen (txt);
obstack_append_str (&b, "%<");
if (txt[0] != sym[0] || (int) strlen (sym) < size)
obstack_append_str (&b, txt);
else
{
while (n < size)
{
if (ISPRINT (sym[0]))
obstack_1grow (&b, sym[0]);
if (TOLOWER (txt[0]) == TOLOWER (sym[0]))
{
txt++;
n++;
}
sym++;
}
}
obstack_append_str (&b, "%>");
}
else
obstack_append_str (&b, "symbol");
}
else if (t[0] == 'X')
{
enum a68_attribute att = (enum a68_attribute) (va_arg (args, int));
const char *att_name = a68_attribute_name (att);
obstack_append_str (&b, att_name);
}
else if (t[0] == 'Y')
{
char *loc_string = va_arg (args, char *);
obstack_append_str (&b, loc_string);
}
else if (t[0] == 'Z')
{
char *str = va_arg (args, char *);
obstack_append_str (&b, "%<");
obstack_append_str (&b, str);
obstack_append_str (&b, "%>");
}
else
obstack_1grow (&b, t[0]);
t++;
}
obstack_1grow (&b, '\0');
char *format = (char *) obstack_finish (&b);
/* Construct a diagnostic message. */
if (sev == A68_WARNING)
@@ -305,9 +96,12 @@ diagnostic (int sev, int opt,
gcc_unreachable ();
}
diagnostic_set_info (&diagnostic, format,
&argp,
va_list cargs;
va_copy (cargs, args);
diagnostic_set_info (&diagnostic, format, &cargs,
&rich_loc, kind);
va_end (cargs);
if (opt != 0)
diagnostic.m_option_id = opt;
res = diagnostic_report_diagnostic (global_dc, &diagnostic);

48
gcc/algol68/a68-imports-archive.cc
View File

@@ -254,7 +254,7 @@ Archive_file::initialize()
struct stat st;
if (fstat(this->fd_, &st) < 0)
{
a68_error (NO_NODE, "Z: doing stat", this->filename_.c_str());
a68_error (NO_NODE, "%s: doing stat", this->filename_.c_str());
return false;
}
this->filesize_ = st.st_size;
@@ -263,7 +263,7 @@ Archive_file::initialize()
if (::lseek(this->fd_, 0, SEEK_SET) < 0
|| ::read(this->fd_, buf, sizeof(armagt)) != sizeof(armagt))
{
a68_error (NO_NODE, "Z: reading from archive", this->filename_.c_str());
a68_error (NO_NODE, "%s: reading from archive", this->filename_.c_str());
return false;
}
if (memcmp(buf, armagt, sizeof(armagt)) == 0)
@@ -288,7 +288,7 @@ Archive_file::initialize_big_archive()
if (::lseek(this->fd_, 0, SEEK_SET) < 0
|| ::read(this->fd_, &flhdr, sizeof(flhdr)) != sizeof(flhdr))
{
a68_error (NO_NODE, "Z: could not read archive header",
a68_error (NO_NODE, "%s: could not read archive header",
this->filename_.c_str());
return false;
}
@@ -300,7 +300,7 @@ Archive_file::initialize_big_archive()
char* buf = new char[sizeof(flhdr.fl_fstmoff) + 1];
memcpy(buf, flhdr.fl_fstmoff, sizeof(flhdr.fl_fstmoff));
a68_error (NO_NODE,
("Z: malformed first member offset in archive header"
("%s: malformed first member offset in archive header"
" (expected decimal, got Z)"),
this->filename_.c_str(), buf);
delete[] buf;
@@ -343,7 +343,7 @@ Archive_file::initialize_archive()
char* rdbuf = new char[size];
if (::read(this->fd_, rdbuf, size) != size)
{
a68_error (NO_NODE, "Z: could not read extended names",
a68_error (NO_NODE, "%s: could not read extended names",
filename.c_str());
delete[] rdbuf;
return false;
@@ -363,7 +363,7 @@ Archive_file::read(off_t offset, off_t size, char* buf)
if (::lseek(this->fd_, offset, SEEK_SET) < 0
|| ::read(this->fd_, buf, size) != size)
{
a68_error (NO_NODE, "Z: reading from archive", this->filename_.c_str());
a68_error (NO_NODE, "%s: reading from archive", this->filename_.c_str());
return false;
}
return true;
@@ -404,7 +404,7 @@ Archive_file::read_header(off_t off, std::string* pname, off_t* size,
{
if (::lseek(this->fd_, off, SEEK_SET) < 0)
{
a68_error (NO_NODE, "Z: seeking in archive", this->filename_.c_str());
a68_error (NO_NODE, "%s: seeking in archive", this->filename_.c_str());
return false;
}
if (this->is_big_archive_)
@@ -426,12 +426,12 @@ Archive_file::read_big_archive_header(off_t off, std::string* pname,
if (got != sizeof hdr)
{
if (got < 0)
a68_error (NO_NODE, "Z: reading from archive", this->filename_.c_str());
a68_error (NO_NODE, "%s: reading from archive", this->filename_.c_str());
else if (got > 0)
a68_error (NO_NODE, "Z short entry header at L",
a68_error (NO_NODE, "%qs short entry header at %ld",
this->filename_.c_str(), static_cast<long>(off));
else
a68_error (NO_NODE, "Z: unexpected EOF at L",
a68_error (NO_NODE, "%s: unexpected EOF at %ld",
this->filename_.c_str(), static_cast<long>(off));
}
@@ -441,7 +441,7 @@ Archive_file::read_big_archive_header(off_t off, std::string* pname,
char* buf = new char[sizeof(hdr.ar_size) + 1];
memcpy(buf, hdr.ar_size, sizeof(hdr.ar_size));
a68_error (NO_NODE,
("Z: malformed size in entry header at L"
("%s: malformed size in entry header at %ld"
" (expected decimal, got %s)"),
this->filename_.c_str(), static_cast<long>(off), buf);
delete[] buf;
@@ -455,7 +455,7 @@ Archive_file::read_big_archive_header(off_t off, std::string* pname,
char* buf = new char[sizeof(hdr.ar_namlen) + 1];
memcpy(buf, hdr.ar_namlen, sizeof(hdr.ar_namlen));
a68_error (NO_NODE,
("Z: malformed name length in entry header at L"
("%s: malformed name length in entry header at %ld"
" (expected decimal, got %s)"),
this->filename_.c_str(), static_cast<long>(off), buf);
delete[] buf;
@@ -467,7 +467,7 @@ Archive_file::read_big_archive_header(off_t off, std::string* pname,
if (got != namlen)
{
a68_error (NO_NODE,
"Z: malformed member name in entry header at L",
"%s: malformed member name in entry header at %ld",
this->filename_.c_str(), static_cast<long>(off));
delete[] rdbuf;
return false;
@@ -481,7 +481,7 @@ Archive_file::read_big_archive_header(off_t off, std::string* pname,
char* buf = new char[sizeof(hdr.ar_nxtmem) + 1];
memcpy(buf, hdr.ar_nxtmem, sizeof(hdr.ar_nxtmem));
a68_error (NO_NODE,
("Z: malformed next member offset in entry header at L"
("%s: malformed next member offset in entry header at %ld"
" (expected decimal, got %s)"),
this->filename_.c_str(), static_cast<long>(off), buf);
delete[] buf;
@@ -509,12 +509,12 @@ Archive_file::read_archive_header(off_t off, std::string* pname, off_t* size,
if (got != sizeof hdr)
{
if (got < 0)
a68_error (NO_NODE, "Z: reading from archive", this->filename_.c_str());
a68_error (NO_NODE, "%s: reading from archive", this->filename_.c_str());
else if (got > 0)
a68_error (NO_NODE, "Z: short archive header at L",
a68_error (NO_NODE, "%s: short archive header at %ld",
this->filename_.c_str(), static_cast<long>(off));
else
a68_error (NO_NODE, "Z: unexpected EOF at L",
a68_error (NO_NODE, "%s: unexpected EOF at %ld",
this->filename_.c_str(), static_cast<long>(off));
}
off_t local_nested_off;
@@ -546,7 +546,7 @@ Archive_file::interpret_header(const Archive_header* hdr, off_t off,
{
if (memcmp(hdr->ar_fmag, arfmag, sizeof arfmag) != 0)
{
a68_error (NO_NODE, "Z: malformed archive header at L",
a68_error (NO_NODE, "%s: malformed archive header at %lu",
this->filename_.c_str(), static_cast<unsigned long>(off));
return false;
}
@@ -554,7 +554,7 @@ Archive_file::interpret_header(const Archive_header* hdr, off_t off,
long local_size;
if (!this->parse_decimal(hdr->ar_size, sizeof hdr->ar_size, &local_size))
{
a68_error (NO_NODE, "Z: malformed archive header size at L",
a68_error (NO_NODE, "%s: malformed archive header size at %lu",
this->filename_.c_str(), static_cast<unsigned long>(off));
return false;
}
@@ -568,7 +568,7 @@ Archive_file::interpret_header(const Archive_header* hdr, off_t off,
|| name_end - hdr->ar_name >= static_cast<int>(sizeof hdr->ar_name))
{
a68_error (NO_NODE,
"Z: malformed archive header name at L",
"%s: malformed archive header name at %lu",
this->filename_.c_str(), static_cast<unsigned long>(off));
return false;
}
@@ -606,7 +606,7 @@ Archive_file::interpret_header(const Archive_header* hdr, off_t off,
|| (x == LONG_MAX && errno == ERANGE)
|| static_cast<size_t>(x) >= this->extended_names_.size())
{
a68_error (NO_NODE, "Z: bad extended name index at L",
a68_error (NO_NODE, "%s: bad extended name index at %lu",
this->filename_.c_str(), static_cast<unsigned long>(off));
return false;
}
@@ -617,7 +617,7 @@ Archive_file::interpret_header(const Archive_header* hdr, off_t off,
|| name_end[-1] != '/')
{
a68_error (NO_NODE,
"Z: bad extended name entry at header L",
"%s: bad extended name entry at header %lu",
this->filename_.c_str(), static_cast<unsigned long>(off));
return false;
}
@@ -676,7 +676,7 @@ Archive_file::get_file_and_offset(off_t off, const std::string& hdrname,
int nfd = open(filename.c_str(), O_RDONLY | O_BINARY);
if (nfd < 0)
{
a68_error (NO_NODE, "Z: cannot open nested archive Z",
a68_error (NO_NODE, "%s: cannot open nested archive %s",
this->filename_.c_str(), filename.c_str());
return false;
}
@@ -702,7 +702,7 @@ Archive_file::get_file_and_offset(off_t off, const std::string& hdrname,
*memfd = open(filename.c_str(), O_RDONLY | O_BINARY);
if (*memfd < 0)
{
a68_error (NO_NODE, "Z: opening archive", filename.c_str());
a68_error (NO_NODE, "%s: opening archive", filename.c_str());
return false;
}
*memoff = 0;

18
gcc/algol68/a68-imports.cc
View File

@@ -243,9 +243,9 @@ a68_find_object_export_data (const std::string& filename,
if (errmsg != NULL)
{
if (err == 0)
a68_error (NO_NODE, "Z: Z", filename.c_str (), errmsg);
a68_error (NO_NODE, "%s: %s", filename.c_str (), errmsg);
else
a68_error (NO_NODE, "Z: Z: Z", filename.c_str(), errmsg,
a68_error (NO_NODE, "%s: %s: %s", filename.c_str(), errmsg,
xstrerror(err));
return NULL;
}
@@ -266,7 +266,7 @@ a68_find_export_data (const std::string &filename, int fd, size_t *psize)
if (lseek (fd, 0, SEEK_SET) < 0)
{
a68_error (NO_NODE, "lseek Z failed", filename.c_str ());
a68_error (NO_NODE, "lseek %qs failed", filename.c_str ());
return NULL;
}
@@ -277,7 +277,7 @@ a68_find_export_data (const std::string &filename, int fd, size_t *psize)
if (lseek (fd, 0, SEEK_SET) < 0)
{
a68_error (NO_NODE, "lseek Z failed", filename.c_str ());
a68_error (NO_NODE, "lseek %qs failed", filename.c_str ());
return NULL;
}
@@ -292,7 +292,7 @@ a68_find_export_data (const std::string &filename, int fd, size_t *psize)
len = a68_file_size (fd);
if (len == -1)
{
a68_error (NO_NODE, "a68_file_size failed for Z",
a68_error (NO_NODE, "%<a68_file_size%> failed for %qs",
filename.c_str ());
return NULL;
}
@@ -330,14 +330,14 @@ a68_find_export_data (const std::string &filename, int fd, size_t *psize)
if (lseek (fd, 0, SEEK_SET) < 0)
{
a68_error (NO_NODE, "lseek Z failed", filename.c_str ());
a68_error (NO_NODE, "lseek %qs failed", filename.c_str ());
return NULL;
}
c = read (fd, buf, 8);
if (c < 8)
{
a68_error (NO_NODE, "read Z failed", filename.c_str ());
a68_error (NO_NODE, "read %qs failed", filename.c_str ());
return NULL;
}
@@ -409,7 +409,7 @@ a68_try_packet_in_directory (const std::string &filename, size_t *psize)
close (fd);
a68_error (NO_NODE, "file Z exists but does not contain any export data",
a68_error (NO_NODE, "file %qs exists but does not contain any export data",
found_filename.c_str ());
return NULL;
@@ -1429,7 +1429,7 @@ a68_open_packet (const char *module, const char *basename)
const char *errstr = NULL;
if (!a68_decode_moifs (exports_data, exports_data_size, &errstr))
{
a68_error (NO_NODE, "Y", errstr);
a68_error (NO_NODE, "%s", errstr);
return NULL;
}

56
gcc/algol68/a68-moids-diagnostics.cc
View File

@@ -25,6 +25,9 @@
#include "options.h"
#include "a68.h"
#include "a68-pretty-print.h"
#include <string>
/* Give accurate error message. */
@@ -75,7 +78,7 @@ a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, i
N++;
len = strlen (txt);
}
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%%<%s%%>",
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%<%s%>",
a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0)
gcc_unreachable ();
N++;
@@ -93,7 +96,7 @@ a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, i
gcc_unreachable ();
len = strlen (txt);
}
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %%<%s%%>",
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %<%s%>",
a68_moid_to_string (q, MOID_ERROR_WIDTH, n)) < 0)
gcc_unreachable ();
}
@@ -134,7 +137,7 @@ a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, i
}
}
len = strlen (txt);
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %%<%s%%>",
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, " cannot be coerced to %<%s%>",
a68_moid_to_string (SLICE (SUB (q)), MOID_ERROR_WIDTH, n)) < 0)
gcc_unreachable ();
}
@@ -168,7 +171,7 @@ a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, i
gcc_unreachable ();
len = strlen (txt);
}
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%%<%s%%>",
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%<%s%>",
a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0)
gcc_unreachable ();
}
@@ -209,7 +212,7 @@ a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, i
gcc_unreachable ();
len = strlen (txt);
}
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%%<%s%%> cannot be coerced to %%<%s%%>",
if (snprintf (TAIL (txt), ACTUAL_SNPRINTF_SIZE, "%<%s%> cannot be coerced to %<%s%>",
a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n),
a68_moid_to_string (MOID (v), MOID_ERROR_WIDTH, n)) < 0)
gcc_unreachable ();
@@ -230,19 +233,30 @@ a68_cannot_coerce (NODE_T *p, MOID_T *from, MOID_T *to, int context, int deflex,
{
const char *txt = a68_mode_error_text (p, from, to, context, deflex, 1);
a68_moid_format_token from1 (from);
a68_moid_format_token to1 (to);
a68_attr_format_token att1 ((a68_attribute) att);
a68_sort_format_token context1 (context);
if (att == STOP)
{
if (strlen (txt) == 0)
a68_error (p, "M cannot be coerced to M in C context", from, to, context);
a68_error (p, "%e cannot be coerced to %e in %e context", &from1, &to1, &context1);
else
a68_error (p, "Y in C context", txt, context);
{
std::string fmt (txt);
a68_error (p, (fmt + " in %e context").c_str (), &context1);
}
}
else
{
if (strlen (txt) == 0)
a68_error (p, "M cannot be coerced to M in C-A", from, to, context, att);
a68_error (p, "%e cannot be coerced to %e in %e-%e", &from1, &to1, &context1, &att1);
else
a68_error (p, "Y in C-A", txt, context, att);
{
std::string fmt (txt);
a68_error (p, (fmt + " in %e-%e").c_str (), &context1, &att1);
}
}
}
@@ -255,12 +269,15 @@ a68_warn_for_voiding (NODE_T *p, SOID_T *x, SOID_T *y, int c)
if (CAST (x) == false)
{
if (MOID (x) == M_VOID && MOID (y) != M_ERROR && !(MOID (y) == M_VOID || !a68_is_nonproc (MOID (y))))
if (MOID (x) == M_VOID
&& MOID (y) != M_ERROR
&& !(MOID (y) == M_VOID || !a68_is_nonproc (MOID (y))))
{
if (IS (p, FORMULA))
a68_warning (p, OPT_Wvoiding, "value of M @ will be voided", MOID (y));
else
a68_warning (p, OPT_Wvoiding, "value of M @ will be voided", MOID (y));
a68_moid_format_token m1 (MOID (y));
a68_construct_format_token c1 (p);
a68_warning (p, OPT_Wvoiding, "value of %e %e will be voided",
&m1, &c1);
}
}
}
@@ -274,8 +291,15 @@ a68_semantic_pitfall (NODE_T *p, MOID_T *m, int c, int u)
REF INT i := LOC INT := 0, which should probably be
REF INT i = LOC INT := 0. */
if (IS (p, u))
a68_warning (p, 0, "possibly unintended M A in M A",
MOID (p), u, m, c);
{
a68_moid_format_token m1 (MOID (p));
a68_moid_format_token m2 (m);
a68_construct_format_token u1 ((a68_attribute) u);
a68_construct_format_token c1 ((a68_attribute) c);
a68_warning (p, 0, "possibly unintended %e %e in %e %e",
&m1, &u1, &m2, &c1);
}
else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP))
a68_semantic_pitfall (SUB (p), m, c, u);
}

72
gcc/algol68/a68-parser-bottom-up.cc
View File

@@ -101,6 +101,7 @@
#include "options.h"
#include "a68.h"
#include "a68-pretty-print.h"
/* Bottom-up parser, reduces all constructs. */
@@ -374,14 +375,14 @@ ignore_superfluous_semicolons (NODE_T *p)
if (NEXT (p) != NO_NODE && IS (NEXT (p), SEMI_SYMBOL) && NEXT_NEXT (p) == NO_NODE)
{
a68_warning (NEXT (p), 0,
"skipped superfluous A", ATTRIBUTE (NEXT (p)));
a68_attr_format_token a (ATTRIBUTE (NEXT (p)));
a68_warning (NEXT (p), 0, "skipped superfluous %e", &a);
NEXT (p) = NO_NODE;
}
else if (IS (p, SEMI_SYMBOL) && a68_is_semicolon_less (NEXT (p)))
{
a68_warning (p, 0,
"skipped superfluous A", ATTRIBUTE (p));
a68_attr_format_token a (ATTRIBUTE (p));
a68_warning (p, 0, "skipped superfluous %e", &a);
if (PREVIOUS (p) != NO_NODE)
NEXT (PREVIOUS (p)) = NEXT (p);
PREVIOUS (NEXT (p)) = PREVIOUS (p);
@@ -791,8 +792,7 @@ reduce_declarers (NODE_T *p, enum a68_attribute expect)
if (SUB_NEXT (q) == NO_NODE)
{
a68_error (NEXT (q),
"Y expected", "appropriate declarer");
a68_error (NEXT (q), "appropriate declarer expected");
reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP);
}
else
@@ -807,8 +807,7 @@ reduce_declarers (NODE_T *p, enum a68_attribute expect)
}
else
{
a68_error (NEXT (q),
"Y expected", "appropriate declarer");
a68_error (NEXT (q), "appropriate declarer expected");
reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP);
}
}
@@ -819,8 +818,7 @@ reduce_declarers (NODE_T *p, enum a68_attribute expect)
if (SUB_NEXT (q) == NO_NODE)
{
a68_error (NEXT (q),
"Y expected", "appropriate declarer");
a68_error (NEXT (q), "appropriate declarer expected");
reduce (q, NO_NOTE, NO_TICK, DECLARER, SHORTETY, INDICANT, STOP);
}
else
@@ -833,8 +831,7 @@ reduce_declarers (NODE_T *p, enum a68_attribute expect)
}
else
{
a68_error (NEXT (q),
"Y expected", "appropriate declarer");
a68_error (NEXT (q), "appropriate declarer expected");
reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP);
}
}
@@ -1347,8 +1344,12 @@ ambiguous_patterns (NODE_T *p)
case COMPLEX_PATTERN:
case BITS_PATTERN:
if (last_pat != NO_NODE)
a68_error (q, "A and A must be separated by a comma-symbol",
ATTRIBUTE (last_pat), ATTRIBUTE (q));
{
a68_attr_format_token a1 (ATTRIBUTE (last_pat));
a68_attr_format_token a2 (ATTRIBUTE (q));
a68_error (q, "%e and %e must be separated by a comma-symbol",
&a1, &a2);
}
last_pat = q;
break;
case COMMA_SYMBOL:
@@ -1756,7 +1757,10 @@ reduce_formulae (NODE_T * p)
reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, FORMULA, STOP);
}
if (prio == 0 && siga)
a68_error (op, "S has no priority declaration");
{
a68_symbol_format_token s (op);
a68_error (op, "%e has no priority declaration", &s);
}
siga = true;
while (siga)
{
@@ -1769,7 +1773,10 @@ reduce_formulae (NODE_T * p)
if (operator_with_priority (q, prio))
reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, FORMULA, STOP);
if (prio == 0 && siga)
a68_error (op2, "S has no priority declaration");
{
a68_symbol_format_token s (op2);
a68_error (op2, "%e has no priority declaration", &s);
}
}
}
}
@@ -2299,7 +2306,10 @@ reduce_serial_clauses (NODE_T *p)
if (IS (u, EXIT_SYMBOL))
{
if (NEXT (u) == NO_NODE || !IS (NEXT (u), LABELED_UNIT))
a68_error (u, "S must be followed by a labeled unit");
{
a68_symbol_format_token s (u);
a68_error (u, "%e must be followed by a labeled unit", &s);
}
}
}
@@ -2819,10 +2829,16 @@ recover_from_error (NODE_T * p, enum a68_attribute expect, bool suppress)
if (strlen (seq) == 0)
{
if (ERROR_COUNT (&A68_JOB) == 0)
a68_error (w, "expected A", expect);
{
a68_attr_format_token a (expect);
a68_error (w, "expected %e", &a);
}
}
else
a68_error (w, "Y is an invalid A", seq, expect);
{
a68_attr_format_token a (expect);
a68_error (w, "%s is an invalid %e", seq, &a);
}
if (ERROR_COUNT (&A68_JOB) >= MAX_ERRORS)
longjmp (A68_PARSER (bottom_up_crash_exit), 1);
@@ -2895,7 +2911,8 @@ reduce_erroneous_units (NODE_T *p)
guide an unsuspecting user. */
if (a68_whether (q, SELECTOR, -SECONDARY, STOP))
{
a68_error (NEXT (q), "expected A", SECONDARY);
a68_attr_format_token a (SECONDARY);
a68_error (NEXT (q), "expected %e", &a);
reduce (q, NO_NOTE, NO_TICK, UNIT, SELECTOR, WILDCARD, STOP);
}
@@ -2904,14 +2921,16 @@ reduce_erroneous_units (NODE_T *p)
|| a68_whether (q, TERTIARY, IS_SYMBOL, -TERTIARY, STOP)
|| a68_whether (q, -TERTIARY, IS_SYMBOL, -TERTIARY, STOP))
{
a68_error (NEXT (q), "expected A", TERTIARY);
a68_attr_format_token a (TERTIARY);
a68_error (NEXT (q), "expected %e", &a);
reduce (q, NO_NOTE, NO_TICK, UNIT, WILDCARD, IS_SYMBOL, WILDCARD, STOP);
}
else if (a68_whether (q, -TERTIARY, ISNT_SYMBOL, TERTIARY, STOP)
|| a68_whether (q, TERTIARY, ISNT_SYMBOL, -TERTIARY, STOP)
|| a68_whether (q, -TERTIARY, ISNT_SYMBOL, -TERTIARY, STOP))
{
a68_error (NEXT (q), "expected A", TERTIARY);
a68_attr_format_token a (TERTIARY);
a68_error (NEXT (q), "expected %e", &a);
reduce (q, NO_NOTE, NO_TICK, UNIT, WILDCARD, ISNT_SYMBOL, WILDCARD, STOP);
}
}
@@ -2933,10 +2952,13 @@ a68_bottom_up_error_check (NODE_T *p)
int k = 0;
a68_count_pictures (SUB (p), &k);
if (!(k == 0 || k == 2))
a68_error (p, "incorrect number of pictures for A",
ATTRIBUTE (p));
{
a68_attr_format_token a (ATTRIBUTE (p));
a68_error (p, "incorrect number of pictures for %e", &a);
}
}
else if (a68_is_one_of (p, DEFINING_INDICANT, DEFINING_IDENTIFIER, DEFINING_OPERATOR, STOP))
else if (a68_is_one_of (p,
DEFINING_INDICANT, DEFINING_IDENTIFIER, DEFINING_OPERATOR, STOP))
{
if (PUBLICIZED (p) && !PUBLIC_RANGE (TABLE (p)))
a68_error (p,

11
gcc/algol68/a68-parser-brackets.cc
View File

@@ -25,6 +25,7 @@
#include "coretypes.h"
#include "a68.h"
#include "a68-pretty-print.h"
/* After this checker, we know that at least brackets are matched. This
stabilises later parser phases.
@@ -193,15 +194,16 @@ bracket_check_parse (NODE_T *top, NODE_T *p)
else if (q == NO_NODE)
{
char *diag = bracket_check_diagnose (top);
a68_error (p, "incorrect nesting, check for Y",
a68_error (p, "incorrect nesting, check for %s",
(strlen (diag) > 0 ? diag : "missing or unmatched keyword"));
longjmp (A68_PARSER (top_down_crash_exit), 1);
}
else
{
char *diag = bracket_check_diagnose (top);
a68_error (q, "unexpected X, check for Y",
ATTRIBUTE (q),
a68_attr_format_token a (ATTRIBUTE (q));
a68_error (q, "unexpected %e, check for %s", &a,
(strlen (diag) > 0 ? diag : "missing or unmatched keyword"));
longjmp (A68_PARSER (top_down_crash_exit), 1);
}
@@ -217,7 +219,6 @@ a68_check_parenthesis (NODE_T *top)
if (!setjmp (A68_PARSER (top_down_crash_exit)))
{
if (bracket_check_parse (top, top) != NO_NODE)
a68_error (top, "incorrect nesting, check for Y",
"missing or unmatched keyword");
a68_error (top, "incorrect nesting, check for missing or unmatched keyword");
}
}

40
gcc/algol68/a68-parser-extract.cc
View File

@@ -24,6 +24,7 @@
#include "coretypes.h"
#include "a68.h"
#include "a68-pretty-print.h"
/* This is part of the bottom-up parser. Here is a set of routines that gather
definitions from phrases. This way we can apply tags before defining them.
@@ -55,8 +56,11 @@ static void
detect_redefined_keyword (NODE_T *p, int construct)
{
if (p != NO_NODE && a68_whether (p, KEYWORD, EQUALS_SYMBOL, STOP))
a68_error (p, "attempt to redefine keyword Y in A",
NSYMBOL (p), construct);
{
a68_attr_format_token a ((a68_attribute) construct);
a68_error (p, "attempt to redefine keyword %s in %e",
NSYMBOL (p), &a);
}
}
/* Skip anything until a FED or ALT_ACCESS_SYMBOL is found. */
@@ -149,7 +153,10 @@ a68_elaborate_bold_tags (NODE_T *p)
&& IS (PREVIOUS (q), FORMAL_NEST_SYMBOL))
{
if (strcmp (NSYMBOL (q), "C") != 0)
a68_error (q, "S is not a valid language indication");
{
a68_symbol_format_token s (q);
a68_error (q, "%e is not a valid language indication", &s);
}
else
ATTRIBUTE (q) = LANGUAGE_INDICANT;
}
@@ -158,7 +165,10 @@ a68_elaborate_bold_tags (NODE_T *p)
switch (find_tag_definition (TABLE (q), NSYMBOL (q)))
{
case 0:
a68_error (q, "tag S has not been declared properly");
{
a68_symbol_format_token s (q);
a68_error (q, "indicant %e has not been declared properly", &s);
}
break;
case INDICANT:
ATTRIBUTE (q) = INDICANT;
@@ -220,7 +230,7 @@ a68_extract_revelation (NODE_T *q, const char *module, const char *filename,
MOIF_T *moif = a68_open_packet (module, filename);
if (moif == NULL)
{
a68_error (q, "cannot find module Z", module);
a68_error (q, "cannot find module %qs", module);
return;
}
@@ -605,7 +615,12 @@ a68_extract_priorities (NODE_T *p)
NSYMBOL (q) = TEXT (a68_add_token (&A68 (top_token), sym));
free (sym);
if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=')
a68_error (q, "probably a missing symbol near invalid operator S");
{
a68_symbol_format_token s (q);
a68_error (q,
"probably a missing symbol near invalid operator %e",
&s);
}
ATTRIBUTE (q) = DEFINING_OPERATOR;
PUBLICIZED (q) = is_public;
insert_alt_equals (q);
@@ -722,8 +737,14 @@ a68_extract_operators (NODE_T *p)
a68_bufcpy (sym, NSYMBOL (q), len + 1);
sym[len - 1] = '\0';
NSYMBOL (q) = TEXT (a68_add_token (&A68 (top_token), sym));
if (len > 2 && NSYMBOL (q)[len - 2] == ':' && NSYMBOL (q)[len - 3] != '=')
a68_error (q, "probably a missing symbol near invalid operator S");
if (len > 2 && NSYMBOL (q)[len - 2] == ':'
&& NSYMBOL (q)[len - 3] != '=')
{
a68_symbol_format_token s (q);
a68_error (q,
"probably a missing symbol near invalid operator %e",
&s);
}
ATTRIBUTE (q) = DEFINING_OPERATOR;
PUBLICIZED (q) = is_public;
insert_alt_equals (q);
@@ -1035,7 +1056,8 @@ a68_extract_declarations (NODE_T *p)
}
else
{
a68_error (q, "tag S has not been declared properly");
a68_symbol_format_token s (q);
a68_error (q, "indicant %e has not been declared properly", &s);
PRIO (INFO (q)) = 1;
}
}

35
gcc/algol68/a68-parser-modes.cc
View File

@@ -24,6 +24,7 @@
#include "coretypes.h"
#include "a68.h"
#include "a68-pretty-print.h"
/*
* Mode collection, equivalencing and derived modes.
@@ -518,7 +519,7 @@ get_mode_from_declarer (NODE_T *p)
/* Position of definition tells indicants apart. */
TAG_T *y = a68_find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
if (y == NO_TAG)
a68_error ( p, "tag Z has not been declared properly", NSYMBOL (p));
a68_error (p, "tag %qs has not been declared properly", NSYMBOL (p));
else
MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, NODE (y),
NO_MOID, NO_PACK);
@@ -1217,7 +1218,10 @@ compute_derived_modes (MODULE_T *mod)
for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
{
if (IS_FLEX (z) && !IS (SUB (z), ROW_SYMBOL))
a68_error (NODE (z), "M does not specify a well formed mode", z);
{
a68_moid_format_token m (z);
a68_error (NODE (z), "%e does not specify a well formed mode", &m);
}
}
/* Check on fields in structured modes f.i. STRUCT (REAL x, INT n, REAL x) is
@@ -1236,7 +1240,8 @@ compute_derived_modes (MODULE_T *mod)
{
if (TEXT (s) == TEXT (t))
{
a68_error (NODE (z), "multiple declaration of field S");
a68_symbol_format_token zs (NODE (z));
a68_error (NODE (z), "multiple declaration of field %e", &zs);
while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t))
FORWARD (s);
x = false;
@@ -1254,7 +1259,10 @@ compute_derived_modes (MODULE_T *mod)
PACK_T *s = PACK (z);
/* Discard unions with one member. */
if (a68_count_pack_members (s) == 1)
a68_error (NODE (z), "M must have at least two components", z);
{
a68_moid_format_token m (z);
a68_error (NODE (z), "%e must have at least two components", &m);
}
/* Discard incestuous unions with firmly related modes. */
for (; s != NO_PACK; FORWARD (s))
{
@@ -1265,7 +1273,10 @@ compute_derived_modes (MODULE_T *mod)
if (MOID (t) != MOID (s))
{
if (a68_is_firm (MOID (s), MOID (t)))
a68_error (NODE (z), "M has firmly related components", z);
{
a68_moid_format_token m (z);
a68_error (NODE (z), "%e has firmly related components", &m);
}
}
}
}
@@ -1276,7 +1287,11 @@ compute_derived_modes (MODULE_T *mod)
MOID_T *n = a68_depref_completely (MOID (s));
if (IS (n, UNION_SYMBOL) && a68_is_subset (n, z, NO_DEFLEXING))
a68_error (NODE (z), "M has firmly related subset M", z, n);
{
a68_moid_format_token m1 (z);
a68_moid_format_token m2 (n);
a68_error (NODE (z), "%e has firmly related subset %e", &m1, &m2);
}
}
}
}
@@ -1321,7 +1336,8 @@ a68_make_moid_list (MODULE_T *mod)
{
if (!is_well_formed (z, EQUIVALENT (z), false, false, true))
{
a68_error (NODE (z), "M does not specify a well formed mode", z);
a68_moid_format_token m (z);
a68_error (NODE (z), "%e does not specify a well formed mode", &m);
cont = false;
}
}
@@ -1334,7 +1350,10 @@ a68_make_moid_list (MODULE_T *mod)
else if (NODE (z) != NO_NODE)
{
if (!is_well_formed (NO_MOID, z, false, false, true))
a68_error (NODE (z), "M does not specify a well formed mode", z);
{
a68_moid_format_token m (z);
a68_error (NODE (z), "%e does not specify a well formed mode", &m);
}
}
}

106
gcc/algol68/a68-parser-moids-check.cc
View File

@@ -92,6 +92,7 @@
#include "options.h"
#include "a68.h"
#include "a68-pretty-print.h"
/* Forward declarations of some of the functions defined below. */
@@ -515,7 +516,11 @@ mode_check_specified_unit_list (SOID_T **r, NODE_T *p, SOID_T *x, MOID_T *u)
{
MOID_T *m = MOID (NEXT_SUB (p));
if (u != NO_MOID && !a68_is_unitable (m, u, SAFE_DEFLEXING))
a68_error (p, "M is neither component nor subset of M", m, u);
{
a68_moid_format_token m1 (m);
a68_moid_format_token m2 (u);
a68_error (p, "%e is neither component nor subset of %e", &m1, &m2);
}
}
else if (IS (p, UNIT))
@@ -590,7 +595,8 @@ mode_check_united_case_parts (SOID_T **ry, NODE_T *p, SOID_T *x)
}
else
{
a68_error (NEXT_SUB (p), "M is not a united mode", u);
a68_moid_format_token m (u);
a68_error (NEXT_SUB (p), "%e is not a united mode", &m);
return;
}
}
@@ -709,15 +715,16 @@ mode_check_collateral (NODE_T *p, SOID_T *x, SOID_T *y)
if (SORT (x) == STRONG)
{
if (MOID (x) == NO_MOID)
a68_error (p, "vacuum cannot have row elements (use a Y generator)",
"REF MODE");
a68_error (p, "vacuum cannot have row elements (use a %qs generator)",
a68_strop_keyword ("REF MODE"));
else if (IS_FLEXETY_ROW (MOID (x)))
a68_make_soid (y, STRONG, M_VACUUM, 0);
else
{
/* The syntax only allows vacuums in strong contexts with rowed
modes. See rule 33d. */
a68_error (p, "a vacuum is not a valid M", MOID (x));
a68_moid_format_token m (MOID (x));
a68_error (p, "a vacuum is not a valid %e", &m);
a68_make_soid (y, STRONG, M_ERROR, 0);
}
}
@@ -1103,7 +1110,8 @@ mode_check_monadic_operator (NODE_T *p, SOID_T *x, SOID_T *y)
a68_make_soid (y, SORT (x), M_ERROR, 0);
else if (u == M_HIP)
{
a68_error (NEXT (p), "M construct is an invalid operand", u);
a68_moid_format_token m (u);
a68_error (NEXT (p), "%e construct is an invalid operand", &m);
a68_make_soid (y, SORT (x), M_ERROR, 0);
}
else
@@ -1111,7 +1119,9 @@ mode_check_monadic_operator (NODE_T *p, SOID_T *x, SOID_T *y)
if (strchr (NOMADS, *(NSYMBOL (p))) != NO_TEXT)
{
t = NO_TAG;
a68_error (p, "monadic S cannot start with a character from Z", NOMADS);
a68_symbol_format_token s (p);
a68_error (p, "monadic %e cannot start with a character from %qs",
&s, NOMADS);
a68_make_soid (y, SORT (x), M_ERROR, 0);
}
else
@@ -1119,7 +1129,10 @@ mode_check_monadic_operator (NODE_T *p, SOID_T *x, SOID_T *y)
t = find_operator (TABLE (p), NSYMBOL (p), u, NO_MOID);
if (t == NO_TAG)
{
a68_error (p, "monadic operator S O has not been declared", u);
a68_symbol_format_token s (p);
a68_opmoid_format_token o (u);
a68_error (p, "monadic operator %e %e has not been declared",
&s, &o);
a68_make_soid (y, SORT (x), M_ERROR, 0);
}
}
@@ -1192,12 +1205,14 @@ mode_check_formula (NODE_T *p, SOID_T *x, SOID_T *y)
a68_make_soid (y, SORT (x), M_ERROR, 0);
else if (u == M_HIP)
{
a68_error (p, "M construct is an invalid operand", u);
a68_moid_format_token m (u);
a68_error (p, "%e construct is an invalid operand", &m);
a68_make_soid (y, SORT (x), M_ERROR, 0);
}
else if (v == M_HIP)
{
a68_error (q, "M construct is an invalid operand", u);
a68_moid_format_token m (u);
a68_error (q, "%e construct is an invalid operand", &m);
a68_make_soid (y, SORT (x), M_ERROR, 0);
}
else
@@ -1205,7 +1220,11 @@ mode_check_formula (NODE_T *p, SOID_T *x, SOID_T *y)
TAG_T *op = find_operator (TABLE (NEXT (p)), NSYMBOL (NEXT (p)), u, v);
if (op == NO_TAG)
{
a68_error (NEXT (p), "dyadic operator O S O has not been declared", u, v);
a68_symbol_format_token s (NEXT (p));
a68_opmoid_format_token o1 (u);
a68_opmoid_format_token o2 (v);
a68_error (NEXT (p), "dyadic operator %e %e %e has not been declared",
&o1, &s, &o2);
a68_make_soid (y, SORT (x), M_ERROR, 0);
}
if (op != NO_TAG)
@@ -1234,7 +1253,11 @@ mode_check_assignation (NODE_T *p, SOID_T *x, SOID_T *y)
if (ATTRIBUTE (name_moid) != REF_SYMBOL)
{
if (A68_IF_MODE_IS_WELL (name_moid))
a68_error (p, "M A does not yield a name", ori, ATTRIBUTE (SUB (p)));
{
a68_moid_format_token m (ori);
a68_attr_format_token a (ATTRIBUTE (SUB (p)));
a68_error (p, "%e %e does not yield a name", &m, &a);
}
a68_make_soid (y, SORT (x), M_ERROR, 0);
return;
}
@@ -1268,12 +1291,16 @@ mode_check_identity_relation (NODE_T *p, SOID_T *x, SOID_T *y)
MOID_T *rhs = a68_deproc_completely (orir);
if (A68_IF_MODE_IS_WELL (lhs) && lhs != M_HIP && ATTRIBUTE (lhs) != REF_SYMBOL)
{
a68_error (ln, "M A does not yield a name", oril, ATTRIBUTE (SUB (ln)));
a68_moid_format_token m (oril);
a68_attr_format_token a (ATTRIBUTE (SUB (ln)));
a68_error (ln, "%e %e does not yield a name", &m, &a);
lhs = M_ERROR;
}
if (A68_IF_MODE_IS_WELL (rhs) && rhs != M_HIP && ATTRIBUTE (rhs) != REF_SYMBOL)
{
a68_error (rn, "M A does not yield a name", orir, ATTRIBUTE (SUB (rn)));
a68_moid_format_token m (orir);
a68_attr_format_token a (ATTRIBUTE (SUB (rn)));
a68_error (rn, "%e %e does not yield a name", &m, &a);
rhs = M_ERROR;
}
if (lhs == M_HIP && rhs == M_HIP)
@@ -1371,7 +1398,8 @@ mode_check_argument_list (SOID_T **r, NODE_T *p, PACK_T **x, PACK_T **v, PACK_T
SOID_T z;
if (SUB (p) != NO_NODE)
{
a68_error (p, "syntax error detected in A", ARGUMENT);
a68_attr_format_token a (ARGUMENT);
a68_error (p, "syntax error detected in %e", &a);
a68_make_soid (&z, STRONG, M_ERROR, 0);
a68_add_mode_to_pack_end (v, M_VOID, NO_TEXT, p);
a68_add_mode_to_pack_end (w, MOID (*x), NO_TEXT, p);
@@ -1389,7 +1417,10 @@ mode_check_argument_list (SOID_T **r, NODE_T *p, PACK_T **x, PACK_T **v, PACK_T
a68_add_to_soid_list (r, p, &z);
}
else if (IS (p, SUB_SYMBOL) && !OPTION_BRACKETS (&A68_JOB))
a68_error (p, "syntax error detected in A", CALL);
{
a68_attr_format_token a (CALL);
a68_error (p, "syntax error detected in %e", &a);
}
}
}
@@ -1484,7 +1515,8 @@ mode_check_call (NODE_T *p, MOID_T *n, SOID_T *x, SOID_T *y)
PARTIAL_LOCALE (GINFO (p)) = a68_register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_LOCALE (GINFO (p)));
if (DIM (MOID (&d)) != DIM (n))
{
a68_error (p, "incorrect number of arguments for M", n);
a68_moid_format_token m (n);
a68_error (p, "incorrect number of arguments for %e", &m);
a68_make_soid (y, SORT (x), SUB (n), 0);
/* a68_make_soid (y, SORT (x), M_ERROR, 0);. */
}
@@ -1496,7 +1528,8 @@ mode_check_call (NODE_T *p, MOID_T *n, SOID_T *x, SOID_T *y)
a68_make_soid (y, SORT (x), SUB (n), 0);
else
{
a68_warning (NEXT (p), OPT_Wextensions, "@ is an extension");
a68_construct_format_token c (NEXT (p));
a68_warning (NEXT (p), OPT_Wextensions, "%e is an extension", &c);
a68_make_soid (y, SORT (x), PARTIAL_PROC (GINFO (p)), 0);
}
}
@@ -1515,8 +1548,11 @@ mode_check_slice (NODE_T *p, MOID_T *ori, SOID_T *x, SOID_T *y)
if (n == NO_MOID || !(SLICE (DEFLEX (n)) != NO_MOID || a68_is_ref_row (n)))
{
if (A68_IF_MODE_IS_WELL (n))
a68_error (p, "M A does not yield a row or procedure",
n, ATTRIBUTE (SUB (p)));
{
a68_moid_format_token m (n);
a68_attr_format_token a (ATTRIBUTE (SUB (p)));
a68_error (p, "%e %e does not yield a row or procedure", &m, &a);
}
a68_make_soid (y, SORT (x), M_ERROR, 0);
}
@@ -1531,7 +1567,8 @@ mode_check_slice (NODE_T *p, MOID_T *ori, SOID_T *x, SOID_T *y)
if ((subs + trims) != dim)
{
a68_error (p, "incorrect number of indexers for M", n);
a68_moid_format_token m (n);
a68_error (p, "incorrect number of indexers for %e", &m);
a68_make_soid (y, SORT (x), M_ERROR, 0);
}
else
@@ -1595,7 +1632,10 @@ mode_check_specification (NODE_T *p, SOID_T *x, SOID_T *y)
else
{
if (m != M_ERROR)
a68_error (p, "M construct must yield a routine or a row value", m);
{
a68_moid_format_token m1 (m);
a68_error (p, "%e construct must yield a routine or a row value", &m1);
}
a68_make_soid (y, SORT (x), M_ERROR, 0);
return PRIMARY;
}
@@ -1654,7 +1694,11 @@ mode_check_selection (NODE_T *p, SOID_T *x, SOID_T *y)
if (t == NO_PACK)
{
if (A68_IF_MODE_IS_WELL (MOID (&d)))
a68_error (secondary, "M A does not yield a structured value", ori, ATTRIBUTE (secondary));
{
a68_moid_format_token m (ori);
a68_attr_format_token a (ATTRIBUTE (secondary));
a68_error (secondary, "%e %e does not yield a structured value", &m, &a);
}
a68_make_soid (y, SORT (x), M_ERROR, 0);
return;
}
@@ -1685,7 +1729,8 @@ mode_check_selection (NODE_T *p, SOID_T *x, SOID_T *y)
FORWARD (t_2);
}
a68_make_soid (&d, NO_SORT, n, 0);
a68_error (p, "M has no field Z", str, fs);
a68_moid_format_token m (str);
a68_error (p, "%e has no field %qs", &m, fs);
a68_make_soid (y, SORT (x), M_ERROR, 0);
}
@@ -1757,7 +1802,7 @@ mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y)
if (att == STOP)
{
(void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
a68_error (p, "tag S has not been declared properly");
a68_error (p, "tag %qs has not been declared properly", NSYMBOL (p));
MOID (p) = M_ERROR;
}
else
@@ -1768,7 +1813,7 @@ mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y)
else
{
(void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
a68_error (p, "tag S has not been declared properly");
a68_error (p, "tag %qs has not been declared properly", NSYMBOL (p));
MOID (p) = M_ERROR;
}
}
@@ -1808,7 +1853,11 @@ mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y)
else if (a68_is_one_of (p, JUMP, SKIP, STOP))
{
if (SORT (x) != STRONG)
a68_warning (p, 0, "@ should not be in C context", SORT (x));
{
a68_construct_format_token c (p);
a68_sort_format_token s (SORT (x));
a68_warning (p, 0, "%e should not be in %e context", &c, &s);
}
/* a68_make_soid (y, STRONG, M_HIP, 0); */
a68_make_soid (y, SORT (x), M_HIP, 0);
}
@@ -1869,7 +1918,8 @@ mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y)
{
/* Additionally, the mode of the formal hole should be amenable to be
somehow "translated" to C semantics. */
a68_error (p, "formal hole cannot be of mode M", MOID (x));
a68_moid_format_token m (MOID (x));
a68_error (p, "formal hole cannot be of mode %e", &m);
a68_make_soid (y, STRONG, M_ERROR, 0);
}
else if (NSYMBOL (str)[0] == '&' && !IS_REF (MOID (x)))

6
gcc/algol68/a68-parser-pragmat.cc
View File

@@ -114,7 +114,7 @@ handle_access_in_pragmat (NODE_T *p, const char *pragmat, size_t pos)
char *found;
PARSE_WORD (pragmat, found);
a68_error_in_pragmat (p, off,
"in %<access%> pragmat, expected string, found Z",
"in %<access%> pragmat, expected string, found %qs",
found);
return NULL;
}
@@ -128,7 +128,7 @@ handle_access_in_pragmat (NODE_T *p, const char *pragmat, size_t pos)
if (pmodule != NULL)
{
a68_error_in_pragmat (p, pos + pragmat - beginning,
"module Z cannot appear in multiple %<access%> pragmats",
"module %qs cannot appear in multiple %<access%> pragmats",
module);
return NULL;
}
@@ -186,7 +186,7 @@ handle_pragmat (NODE_T *p)
else
{
a68_error_in_pragmat (p, pragmat - NPRAGMAT (p),
"unrecognized pragmat Z", word);
"unrecognized pragmat %qs", word);
break;
}
}

12
gcc/algol68/a68-parser-scanner.cc
View File

@@ -31,6 +31,7 @@
#include "vec.h"
#include "a68.h"
#include "a68-pretty-print.h"
/* A few forward references of static functions defined in this file. */
@@ -1801,7 +1802,7 @@ string break character point"));
}
SCAN_ERROR (c != ',', *start_l, *ref_s,
"expected , or ) in string break");
"expected %<,%> or %<)%> in string break");
}
else
{
@@ -2271,9 +2272,12 @@ tokenise_source (NODE_T **root, int level, bool in_format,
TOP_NODE (&A68_JOB) = q;
*root = q;
if (trailing != NO_TEXT)
a68_warning (q, 0,
"ignoring trailing character H in A",
trailing, att);
{
a68_attr_format_token a (att);
a68_warning (q, 0,
"ignoring trailing character %qs in %e",
trailing, &a);
}
}
/* Redirection in tokenising formats. The scanner is a recursive-descent type as
to know when it scans a format text and when not. */

21
gcc/algol68/a68-parser-scope.cc
View File

@@ -28,6 +28,7 @@
#include "options.h"
#include "a68.h"
#include "a68-pretty-print.h"
struct TUPLE_T
{
@@ -116,9 +117,17 @@ scope_check (SCOPE_T *top, int mask, int dest)
if (ws != NO_MOID)
{
if (IS_REF (ws) || IS (ws, PROC_SYMBOL) || IS (ws, FORMAT_SYMBOL) || IS (ws, UNION_SYMBOL))
a68_warning (WHERE (s), OPT_Wscope, "M A is a potential scope violation",
MOID (WHERE (s)), ATTRIBUTE (WHERE (s)));
if (IS_REF (ws)
|| IS (ws, PROC_SYMBOL)
|| IS (ws, FORMAT_SYMBOL)
|| IS (ws, UNION_SYMBOL))
{
a68_moid_format_token m (MOID (WHERE (s)));
a68_attr_format_token a (ATTRIBUTE (WHERE (s)));
a68_warning (WHERE (s), OPT_Wscope,
"%e %e is a potential scope violation",
&m, &a);
}
}
STATUS_SET (WHERE (s), SCOPE_ERROR_MASK);
errors++;
@@ -147,7 +156,11 @@ check_identifier_usage (TAG_T *t, NODE_T *p)
for (; p != NO_NODE; FORWARD (p))
{
if (IS (p, IDENTIFIER) && TAX (p) == t && ATTRIBUTE (MOID (t)) != PROC_SYMBOL)
a68_warning (p, OPT_Wuninitialized, "identifier S might be used uninitialised");
{
a68_symbol_format_token s (p);
a68_warning (p, OPT_Wuninitialized,
"identifier %e might be used uninitialised", &s);
}
check_identifier_usage (t, SUB (p));
}
}

28
gcc/algol68/a68-parser-taxes.cc
View File

@@ -25,6 +25,7 @@
#include "options.h"
#include "a68.h"
#include "a68-pretty-print.h"
/*
* Symbol table handling, managing TAGS.
@@ -265,7 +266,8 @@ bind_identifier_tag_to_symbol_table (NODE_T * p)
MOID (p) = MOID (z);
else
{
a68_error (p, "tag S has not been declared properly");
a68_error (p, "tag %qs has not been declared properly",
NSYMBOL (p));
z = a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
MOID (p) = M_ERROR;
}
@@ -565,8 +567,10 @@ test_firmly_related_ops_local (NODE_T *p, TAG_T *s)
if (t != NO_TAG)
{
a68_error (p, "M Z is firmly related to M Z",
MOID (s), NSYMBOL (NODE (s)), MOID (t),
a68_moid_format_token m1 (MOID (s));
a68_moid_format_token m2 (MOID (t));
a68_error (p, "%e %qs is firmly related to %e %qs",
&m1, NSYMBOL (NODE (s)), &m2,
NSYMBOL (NODE (t)));
}
else
@@ -659,7 +663,7 @@ static void
already_declared (NODE_T *n, int a)
{
if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG)
a68_error (n, "multiple declaration of tag S");
a68_error (n, "multiple declaration of tag %qs", NSYMBOL (n));
}
/* Whether tag has already been declared in this range. */
@@ -668,7 +672,7 @@ static void
already_declared_hidden (NODE_T *n, int a)
{
if (find_tag_local (TABLE (n), a, NSYMBOL (n)) != NO_TAG)
a68_error (n, "multiple declaration of tag S");
a68_error (n, "multiple declaration of tag %qs", NSYMBOL (n));
TAG_T *s = a68_find_tag_global (PREVIOUS (TABLE (n)), a, NSYMBOL (n));
@@ -1108,17 +1112,21 @@ check_operator_dec (NODE_T *p, MOID_T *u)
if (k < 1 || k > 2)
{
a68_error (p, "incorrect number of operands for S");
a68_symbol_format_token s (p);
a68_error (p, "incorrect number of operands for %e", &s);
k = 0;
}
if (k == 1 && strchr (NOMADS, NSYMBOL (p)[0]) != NO_TEXT)
{
a68_error (p, "monadic S cannot start with a character from Z", NOMADS);
a68_symbol_format_token s (p);
a68_error (p, "monadic %e cannot start with a character from %qs",
&s, NOMADS);
}
else if (k == 2 && !a68_find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p)))
{
a68_error (p, "dyadic S has no priority declaration");
a68_symbol_format_token s (p);
a68_error (p, "dyadic %e has no priority declaration", &s);
}
}
@@ -1739,7 +1747,7 @@ unused (TAG_T *s)
for (; s != NO_TAG; FORWARD (s))
{
if (LINE_NUMBER (NODE (s)) > 0 && !USE (s))
a68_warning (NODE (s), OPT_Wunused, "tag S is not used", NODE (s));
a68_warning (NODE (s), OPT_Wunused, "tag %qs is not used", NSYMBOL (NODE (s)));
}
}
@@ -1791,7 +1799,7 @@ a68_jumps_from_procs (NODE_T *p)
&& (a68_find_tag_global (TABLE (u), LABEL, NSYMBOL (u)) == NO_TAG))
{
(void) a68_add_tag (TABLE (u), LABEL, u, NO_MOID, LOCAL_LABEL);
a68_error (u, "tag S has not been declared properly");
a68_error (u, "tag %qs has not been declared properly", NSYMBOL (u));
}
else
USE (TAX (u)) = true;

20
gcc/algol68/a68-parser-top-down.cc
View File

@@ -24,6 +24,7 @@
#include "coretypes.h"
#include "a68.h"
#include "a68-pretty-print.h"
/* A few forward prototypes of functions defined below. */
@@ -164,12 +165,19 @@ top_down_diagnose (NODE_T *start, NODE_T *p, int clause, int expected)
NODE_T *issue = (p != NO_NODE ? p : start);
const char *strop_keyword = a68_strop_keyword (NSYMBOL (start));
a68_line_format_token l (LINE (INFO (start)), issue);
a68_attr_format_token a1 ((a68_attribute) clause);
if (expected != 0)
a68_error (issue, "B expected in A, near Z L",
expected, clause, strop_keyword, LINE (INFO (start)));
{
a68_attr_format_token a2 ((a68_attribute) expected);
a68_error (issue, "%e expected in %e, near %qs %e",
&a2, &a1, strop_keyword, &l);
}
else
a68_error (issue, "missing or unbalanced keyword in A, near Z L",
clause, strop_keyword, LINE (INFO (start)));
a68_error (issue, "missing or unbalanced keyword in %e, near %qs %e",
&a1, strop_keyword, &l);
}
/* Check for premature exhaustion of tokens. */
@@ -179,7 +187,9 @@ tokens_exhausted (NODE_T *p, NODE_T *q)
{
if (p == NO_NODE)
{
a68_error (q, "check for missing or unmatched keyword in clause starting at S");
a68_symbol_format_token s (q);
a68_error (q, "check for missing or unmatched keyword in clause starting at %e",
&s);
longjmp (A68_PARSER (top_down_crash_exit), 1);
}
}

30
gcc/algol68/a68-parser-victal.cc
View File

@@ -34,7 +34,7 @@ static void
victal_check_generator (NODE_T * p)
{
if (!victal_check_declarer (NEXT (p), ACTUAL_DECLARER_MARK))
a68_error (p, "Y expected", "actual declarer");
a68_error (p, "actual declarer expected");
}
/* Check formal pack. */
@@ -71,11 +71,11 @@ victal_check_operator_dec (NODE_T *p)
bool z = true;
victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z);
if (!z)
a68_error (p, "Y expected", "formal declarers");
a68_error (p, "formal declarers expected");
FORWARD (p);
}
if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK))
a68_error (p, "Y expected", "formal declarer");
a68_error (p, "formal declarer expected");
}
/* Check mode declaration. */
@@ -102,7 +102,7 @@ victal_check_mode_dec (NODE_T *p)
else if (IS (p, DECLARER))
{
if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK))
a68_error (p, "Y expected", "actual declarer");
a68_error (p, "actual declarer expected");
}
}
}
@@ -135,7 +135,7 @@ victal_check_variable_dec (NODE_T *p)
else if (IS (p, DECLARER))
{
if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK))
a68_error (p, "Y expected", "actual declarer");
a68_error (p, "actual declarer expected");
victal_check_variable_dec (NEXT (p));
}
}
@@ -162,7 +162,7 @@ victal_check_identity_dec (NODE_T * p)
else if (IS (p, DECLARER))
{
if (!victal_check_declarer (p, FORMAL_DECLARER_MARK))
a68_error (p, "Y expected", "formal declarer");
a68_error (p, "formal declarer expected");
victal_check_identity_dec (NEXT (p));
}
}
@@ -199,11 +199,11 @@ victal_check_routine_text (NODE_T *p)
bool z = true;
victal_check_routine_pack (p, FORMAL_DECLARER_MARK, &z);
if (!z)
a68_error (p, "Y expected", "formal declarers");
a68_error (p, "formal declarers expected");
FORWARD (p);
}
if (!victal_check_declarer (p, FORMAL_DECLARER_MARK))
a68_error (p, "Y expected", "formal declarer");
a68_error (p, "formal declarer expected");
a68_victal_checker (NEXT (p));
}
@@ -274,13 +274,13 @@ victal_check_declarer (NODE_T *p, int x)
a68_victal_checker (SUB (p));
if (x == FORMAL_DECLARER_MARK)
{
a68_error (p, "Y expected", "formal bounds");
a68_error (p, "formal bounds expected");
(void) victal_check_declarer (NEXT (p), x);
return true;
}
else if (x == VIRTUAL_DECLARER_MARK)
{
a68_error (p, "Y expected", "virtual bounds");
a68_error (p, "virtual bounds expected");
(void) victal_check_declarer (NEXT (p), x);
return true;
}
@@ -292,7 +292,7 @@ victal_check_declarer (NODE_T *p, int x)
a68_victal_checker (SUB (p));
if (x == ACTUAL_DECLARER_MARK)
{
a68_error (p, "Y expected", "actual bounds");
a68_error (p, "actual bounds expected");
(void) victal_check_declarer (NEXT (p), x);
return true;
}
@@ -310,7 +310,7 @@ victal_check_declarer (NODE_T *p, int x)
bool z = true;
victal_check_union_pack (NEXT (p), FORMAL_DECLARER_MARK, &z);
if (!z)
a68_error (p, "Y expected", "formal declarer pack");
a68_error (p, "formal declarer pack expected");
return true;
}
else if (IS (p, PROC_SYMBOL))
@@ -320,11 +320,11 @@ victal_check_declarer (NODE_T *p, int x)
bool z = true;
victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z);
if (!z)
a68_error (p, "Y expected", "formal declarer");
a68_error (p, "formal declarer expected");
FORWARD (p);
}
if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK))
a68_error (p, "Y expected", "formal declarer");
a68_error (p, "formal declarer expected");
return true;
}
else
@@ -338,7 +338,7 @@ victal_check_cast (NODE_T *p)
{
if (!victal_check_declarer (p, FORMAL_DECLARER_MARK))
{
a68_error (p, "Y expected", "formal declarer");
a68_error (p, "formal declarer expected");
a68_victal_checker (NEXT (p));
}
}

241
gcc/algol68/a68-pretty-print.h Normal file
View File

@@ -0,0 +1,241 @@
/* Pretty printers for Algol 68 front-end specific %e tags.
Copyright (C) 2026 Jose E. Marchesi.
Original implementation by J. Marcel van der Veer.
Adapted for GCC by Jose E. Marchesi.
GCC is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.
GCC is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
License for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#ifndef __A68_PRETTY_PRINT__
#define __A68_PRETTY_PRINT__
#include "config.h"
#include "system.h"
#include "pretty-print.h"
#include "pretty-print-format-impl.h"
#include "pretty-print-markup.h"
struct a68_format_token : public pp_element
{
public:
struct value : public pp_token_custom_data::value
{
value (a68_format_token &token)
: m_token (token)
{
}
value (const value &other)
: m_token (other.m_token)
{
}
value (value &&other)
: m_token (other.m_token)
{
}
value &operator= (const value &other) = delete;
value &operator= (value &&other) = delete;
~value ()
{
}
void dump (FILE *out) const final override
{
fprintf (out, "%s", m_token.m_str);
}
bool as_standard_tokens (pp_token_list &out) final override
{
out.push_back<pp_token_text> (label_text::borrow (m_token.m_str));
return true;
}
a68_format_token &m_token;
};
a68_format_token ()
{
m_str = NULL;
}
~a68_format_token ()
{
free (m_str);
}
void add_to_phase_2 (pp_markup::context &ctxt) final override
{
auto val_ptr = std::make_unique<value> (*this);
ctxt.m_formatted_token_list->push_back<pp_token_custom_data>
(std::move (val_ptr));
}
char *m_str;
};
struct a68_moid_format_token : public a68_format_token
{
public:
a68_moid_format_token (MOID_T *m)
{
m_str = xstrdup (a68_moid_to_string (m, MOID_ERROR_WIDTH, NO_NODE));
}
};
struct a68_opmoid_format_token : public a68_format_token
{
public:
a68_opmoid_format_token (MOID_T *m)
{
if (m == NO_MOID || m == M_ERROR)
m = M_UNDEFINED;
const char *str;
if (m == M_VOID)
str = (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING
? "UNION (VOID, ..)"
: "union (void, ..)");
else if (IS (m, SERIES_MODE))
{
if (PACK (m) != NO_PACK && NEXT (PACK (m)) == NO_PACK)
str = a68_moid_to_string (MOID (PACK (m)), MOID_ERROR_WIDTH, NO_NODE);
else
str = a68_moid_to_string (m, MOID_ERROR_WIDTH, NO_NODE);
}
else
str = a68_moid_to_string (m, MOID_ERROR_WIDTH, NO_NODE);
m_str = xstrdup (str);
}
};
struct a68_attr_format_token : public a68_format_token
{
public:
a68_attr_format_token (enum a68_attribute a)
{
KEYWORD_T *nt = a68_find_keyword_from_attribute (A68 (top_keyword), a);
if (nt != NO_KEYWORD)
m_str = xstrdup (a68_strop_keyword (TEXT (nt)));
else
m_str = xstrdup ("keyword");
}
};
struct a68_construct_format_token : public a68_format_token
{
public:
a68_construct_format_token (a68_attribute a)
{
do_attr (a);
}
a68_construct_format_token (NODE_T *p)
{
do_attr (ATTRIBUTE (p));
}
private:
void do_attr (a68_attribute a)
{
const char *nt = a68_attribute_name (a);
if (nt != NO_TEXT)
m_str = xstrdup (nt);
else
m_str = xstrdup ("construct");
}
};
struct a68_symbol_format_token : public a68_format_token
{
public:
a68_symbol_format_token (NODE_T *p)
{
const char *txt = NSYMBOL (p);
char *sym = NCHAR_IN_LINE (p);
int n = 0, size = (int) strlen (txt);
if (txt == NO_TEXT)
m_str = xstrdup ("symbol");
else
{
if (txt[0] != sym[0] || (int) strlen (sym) < size)
m_str = xstrdup (txt);
else
{
m_str = (char *) xmalloc (size + 1);
while (n < size)
{
if (ISPRINT (sym[0]))
m_str[n] = sym[0];
if (TOLOWER (txt[0]) == TOLOWER (sym[0]))
{
txt++;
n++;
}
sym++;
}
m_str[n] = '\0';
}
}
}
};
struct a68_sort_format_token : public a68_format_token
{
public:
a68_sort_format_token (int s)
{
const char *cstr;
switch (s)
{
case NO_SORT: cstr = "this"; break;
case SOFT: cstr = "a soft"; break;
case WEAK: cstr = "a weak"; break;
case MEEK: cstr = "a meek"; break;
case FIRM: cstr = "a firm"; break;
case STRONG: cstr = "a strong"; break;
default:
gcc_unreachable ();
}
m_str = xstrdup (cstr);
}
};
struct a68_line_format_token : public a68_format_token
{
public:
a68_line_format_token (LINE_T *l, NODE_T *n)
{
gcc_assert (l != NO_LINE);
if (NUMBER (l) == 0)
m_str = xstrdup ("in standard environment");
else if (n != NO_NODE && NUMBER (l) == LINE_NUMBER (n))
m_str = xstrdup ("in this line");
else
{
m_str = (char *) xmalloc (18);
if (snprintf (m_str, 18, "in line %d", NUMBER (l)) < 0)
gcc_unreachable ();
}
}
};
#endif /* ! __A68_PRETTY_PRINT__ */

12
gcc/algol68/a68.h
View File

@@ -270,13 +270,13 @@ MOID_T *a68_type_moid (tree type);
/* a68-diagnostics.cc */
void a68_error (NODE_T *p, const char *loc_str, ...);
void a68_error (NODE_T *p, const char *loc_str, ...) ATTRIBUTE_A68_DIAG(2,3);
void a68_error_in_pragmat (NODE_T *p, size_t off,
const char *loc_str, ...);
bool a68_warning (NODE_T *p, int opt, const char *loc_str, ...);
void a68_inform (NODE_T *p, const char *loc_str, ...);
void a68_fatal (NODE_T *p, const char *loc_str, ...);
void a68_scan_error (LINE_T *u, char *v, const char *txt, ...);
const char *loc_str, ...) ATTRIBUTE_A68_DIAG(3,4);
bool a68_warning (NODE_T *p, int opt, const char *loc_str, ...) ATTRIBUTE_A68_DIAG(3,4);
void a68_inform (NODE_T *p, const char *loc_str, ...) ATTRIBUTE_A68_DIAG(2,3);
void a68_fatal (NODE_T *p, const char *loc_str, ...) ATTRIBUTE_A68_DIAG(2,3);
void a68_scan_error (LINE_T *u, char *v, const char *txt, ...) ATTRIBUTE_A68_DIAG(3,4);
/* a68-parser-scanner.cc */