a68: fix trimmers with implicit lower and upper bounds

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

gcc/algol68/ChangeLog

	* a68-low-units.cc (lower_subscript_for_trimmers): Do not crash
	with trimmers with implicit lower and upper bounds.

gcc/testsuite/ChangeLog

	* algol68/execute/trimmer-11.a68: New test.

gcc/ChangeLog

@@ -1,3 +1,53 @@
+2026-02-21  Takayuki 'January June' Suwa  <jjsuwa_sys3175@yahoo.co.jp>
+
+	* config/xtensa/xtensa.cc (constantsynth_pass1):
+	Add the case where the assignment destination is a stack pointer
+	to the exclusion criteria for processing.
+
+2026-02-21  Jeff Law  <jeffrey.law@oss.qualcomm.com>
+
+	PR rtl-optimization/123994
+	* rtl-ssa/changes.cc (function_info::verify_insn_changes): Bullet
+	proof loop to not fault if we run off the end of the insn chain.
+
+2026-02-21  Jeff Law  <jeffrey.law@oss.qualcomm.com>
+
+	PR target/124147
+	* config/riscv/riscv.cc (riscv_same_function_versions): Use nullptr_t rather
+	than UNKNOWN_LOCATION for pointer argument.
+
+2026-02-20  Kwok Cheung Yeung  <kcyeung@baylibre.com>
+
+	PR middle-end/113436
+	* omp-low.cc (omp_lower_target):  Do not check for variable-length
+	variables in private clauses by reference when allocating memory.
+
+2026-02-20  Richard Biener  <rguenther@suse.de>
+
+	PR tree-optimization/124068
+	* tree-vect-patterns.cc (target_has_vecop_for_code): Move
+	earlier, add defaulted optab_subtype parameter.
+	(vect_recog_over_widening_pattern): Check that the target
+	supports the narrowed operation before committing to the
+	pattern.
+
+2026-02-20  Martin Jambor  <mjambor@suse.cz>
+
+	PR ipa/122856
+	* ipa-cp.cc (self_recursive_pass_through_p): Test jump function type first.
+	(self_recursive_ancestor_p): New function.
+	(find_scalar_values_for_callers_subset): Test also for self-recursive
+	ancestor jump functions.
+	(push_agg_values_for_index_from_edge): Likewise.
+
+2026-02-20  Andrew Pinski  <andrew.pinski@oss.qualcomm.com>
+
+	PR tree-optimization/121103
+	* gimple-fold.cc (gimple_fold_call): Don't simplify
+	noreturn functions.
+	* tree-ssa-dse.cc (dse_optimize_stmt): Don't handle
+	calls to noreturn functions.
+
 2026-02-19  jlaw  <jeffreyalaw@gmail.com>
 
 	PR tree-optimization/124108

gcc/DATESTAMP

@@ -1 +1 @@
-20260220
+20260222

gcc/ada/ChangeLog

@@ -1,3 +1,8 @@
+2026-02-20  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* libgnat/s-stposu.adb (Finalize_Pool): Pass a local copy of the
+	handle in the call to Finalize_And_Deallocate.
+
 2026-02-16  Eric Botcazou  <ebotcazou@adacore.com>
 
 	PR ada/124106

gcc/algol68/ChangeLog

@@ -1,3 +1,135 @@
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* a68-parser-bottom-up.cc (reduce_formal_holes): Fix error format
+	tag.
+	* a68-parser-taxes.cc (test_firmly_related_ops_local): Likewise.
+	(already_declared_hidden): Likewise.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* a68-imports-archive.cc (Archive_file::initialize_big_archive):
+	Fix formatting tag in call to a68_error.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* a68-moids-diagnostics.cc (a68_mode_error_text): Properly escape
+	%< and %> in snprintf calls.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* 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.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* a68-low.cc (a68_make_formal_hole_decl): Get a boolean indicating
+	whether the declaration is for the address of the given symbol.
+	* a68.h: Update prototype of a68_make_formal_hole_decl.
+	* a68-low-holes.cc (a68_wrap_formal_var_hole): Pass a boolean to
+	a68_make_formal_hole_decl indicating whether an address is
+	required.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* a68-parser-prelude.cc (stand_prelude): Remove definitions for
+	bitpacks.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* a68-moids-misc.cc (a68_is_c_mode): Allow C formal holes for
+	routines yielding strings.
+	* a68-low-holes.cc (a68_wrap_formal_proc_hole): Support wrappers
+	that yield strings.
+	* a68.h: Remove a68_posix_* and a68_lower_posix* prototypes.
+	* a68-low-posix.cc: Remove.
+	* a68-imports.cc (a68_open_packet): Get argument filename.
+	* Make-lang.in (ALGOL68_OBJS): Remove algol68/a68-low-posix.o.
+	* a68-low-runtime.def: Remove POSIX_*.
+	* lang.opt (-fcheck): Add new undocumented option -fbuilding-libga68.
+	* a68-parser-prelude.cc (stand_transput): New function.
+	(posix_prelude): Remove hardcoded additions to the top-level
+	environment and use a68_extract_revelations instead.
+	* a68-parser-extract.cc (a68_extract_revelation): Renamed from
+	extract_revelation and made accessible externally.
+	* a68-low.cc (a68_make_formal_hole_decl): Remove unneeded check.
+	(lower_lude_decl): New function.
+	(lower_module_text): Add calls to preludes and postludes of
+	standard modules if not building libga68.
+	(a68_lower_particular_program): Likewise.
+	* a68-low-prelude.cc (a68_lower_posixargc): Remove.
+	(a68_lower_posixargv): Likewise.
+	(a68_lower_posixgetenv): Likewise.
+	(a68_lower_posixputchar): Likewise.
+	(a68_lower_posixputs): Likewise.
+	(a68_lower_posixfconnect): Likewise.
+	(a68_lower_posixfopen): Likewise.
+	(a68_lower_posixfcreate): Likewise.
+	(a68_lower_posixfclose): Likewise.
+	(a68_lower_posixfsize): Likewise.
+	(a68_lower_posixlseek): Likewise.
+	(a68_lower_posixseekcur): Likewise.
+	(a68_lower_posixseekend): Likewise.
+	(a68_lower_posixseekset): Likewise.
+	(a68_lower_posixstdinfiledes): Likewise.
+	(a68_lower_posixstdoutfiledes): Likewise.
+	(a68_lower_posixstderrfiledes): Likewise.
+	(a68_lower_posixfileodefault): Likewise.
+	(a68_lower_posixfileordwr): Likewise.
+	(a68_lower_posixfileordonly): Likewise.
+	(a68_lower_posixfileowronly): Likewise.
+	(a68_lower_posixfileotrunc): Likewise.
+	(a68_lower_posixerrno): Likewise.
+	(a68_lower_posixexit): Likewise.
+	(a68_lower_posixperror): Likewise.
+	(a68_lower_posixstrerror): Likewise.
+	(a68_lower_posixfputc): Likewise.
+	(a68_lower_posixfputs): Likewise.
+	(a68_lower_posixgetchar): Likewise.
+	(a68_lower_posixfgetc): Likewise.
+	(a68_lower_posixgets): Likewise.
+	(a68_lower_posixfgets): Likewise.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* a68-types.h (NO_LOWERER): Redefine as NULL.
+	(LOWERER_UNIMPL): Define.
+	* a68-parser-prelude.cc (a68_idf): Use LOWERER_UNIMPL instead of
+	NO_LOWERER.
+	(a68_prio): Likewise.
+	(a68_op): Likewise.
+	* a68-low-units.cc (a68_lower_identifier): Do not assume
+	declarations in A68_STANDENV all have lowerers.
+	(a68_lower_formula): Likewise.
+	(a68_lower_monadic_formula): Likewise.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* a68-imports.cc (a68_find_export_data): Make visible externally.
+	(a68_find_export_data): Try reading export data from an archive
+	file.
+	* a68.h: Adjust prototype of a68_find_export_data accordingly.
+	* a68-imports-archive.cc: New file.
+	* Make-lang.in (ALGOL68_OBJS): Build algol/a68-imports-archive.o.
+
 2026-02-16  Jose E. Marchesi  <jemarch@gnu.org>
 
 	PR algol68/124115

gcc/algol68/Make-lang.in

@@ -67,6 +67,7 @@ ALGOL68_OBJS = algol68/a68-lang.o \
                algol68/a68-diagnostics.o \
                algol68/a68-exports.o \
                algol68/a68-imports.o \
+               algol68/a68-imports-archive.o \
                algol68/a68-parser.o \
                algol68/a68-parser-keywords.o \
                algol68/a68-parser-bottom-up.o \
@@ -104,7 +105,6 @@ ALGOL68_OBJS = algol68/a68-lang.o \
                algol68/a68-low-reals.o \
                algol68/a68-low-complex.o \
                algol68/a68-low-bits.o \
-               algol68/a68-low-posix.o \
                algol68/a68-low-prelude.o \
                algol68/a68-low-ranges.o \
                algol68/a68-low-runtime.o \

gcc/algol68/a68-diagnostics.cc

@@ -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);

gcc/algol68/a68-imports-archive.cc

@@ -0,0 +1,885 @@
+/* Handling of module export data in library archives.
+   This code has bee adapted from the Go front-end.
+
+   Copyright (C) 2009 The Go Authors.
+   Copyright (C) 2026 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/>.  */
+
+#define INCLUDE_MEMORY
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "vec.h"
+
+#include <map>
+#include <string>
+
+#include "a68.h"
+
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+// Archive magic numbers.
+
+static const char armag[] =
+{
+  '!', '<', 'a', 'r', 'c', 'h', '>', '\n'
+};
+
+static const char armagt[] =
+{
+  '!', '<', 't', 'h', 'i', 'n', '>', '\n'
+};
+
+static const char armagb[] =
+{
+  '<', 'b', 'i', 'g', 'a', 'f', '>', '\n'
+};
+
+static const char arfmag[2] = { '`', '\n' };
+
+// Archive fixed length header for AIX big format.
+
+struct Archive_fl_header
+{
+  // Archive magic string.
+  char fl_magic[8];
+  // Offset to member table.
+  char fl_memoff[20];
+  // Offset to global symbol table.
+  char fl_gstoff[20];
+  // Offset to global symbol table for 64-bit objects.
+  char fl_gst64off[20];
+  // Offset to first archive member.
+  char fl_fstmoff[20];
+  // Offset to last archive member.
+  char fl_lstmoff[20];
+  // Offset to first member on free list.
+  char fl_freeoff[20];
+};
+
+// The header of an entry in an archive.  This is all readable text,
+// padded with spaces where necesary.
+
+struct Archive_header
+{
+  // The entry name.
+  char ar_name[16];
+  // The file modification time.
+  char ar_date[12];
+  // The user's UID in decimal.
+  char ar_uid[6];
+  // The user's GID in decimal.
+  char ar_gid[6];
+  // The file mode in octal.
+  char ar_mode[8];
+  // The file size in decimal.
+  char ar_size[10];
+  // The final magic code.
+  char ar_fmag[2];
+};
+
+// The header of an entry in an AIX big archive.
+// This is followed by ar_namlen bytes + 2 bytes for arfmag.
+
+struct Archive_big_header
+{
+  // The file size in decimal.
+  char ar_size[20];
+  // The next member offset in decimal.
+  char ar_nxtmem[20];
+  // The previous member offset in decimal.
+  char ar_prvmem[20];
+  // The file modification time in decimal.
+  char ar_date[12];
+  // The user's UID in decimal.
+  char ar_uid[12];
+  // The user's GID in decimal.
+  char ar_gid[12];
+  // The file mode in octal.
+  char ar_mode[12];
+  // The file name length in decimal.
+  char ar_namlen[4];
+};
+
+// The functions in this file extract Go export data from an archive.
+
+static const int archive_magic_len = 8;
+
+// return true if bytes, which are from the start of the file, are an
+// archive magic number.
+
+bool
+a68_is_archive_magic(const char* bytes)
+{
+  return (memcmp(bytes, armag, archive_magic_len) == 0
+	  || memcmp(bytes, armagt, archive_magic_len) == 0
+	  || memcmp(bytes, armagb, archive_magic_len) == 0);
+}
+
+// An object used to read an archive file.
+
+class Archive_file
+{
+ public:
+  Archive_file(const std::string& filename, int fd, location_t location)
+    : filename_(filename), fd_(fd), filesize_(-1), first_member_offset_(0),
+      extended_names_(), is_thin_archive_(false), is_big_archive_(false),
+      location_(location), nested_archives_()
+  { }
+
+  // Initialize.
+  bool
+  initialize();
+
+  // Return the file name.
+  const std::string&
+  filename() const
+  { return this->filename_; }
+
+  // Get the file size.
+  off_t
+  filesize() const
+  { return this->filesize_; }
+
+  // Return the offset of the first member.
+  off_t
+  first_member_offset() const
+  { return this->first_member_offset_; }
+
+  // Return whether this is a thin archive.
+  bool
+  is_thin_archive() const
+  { return this->is_thin_archive_; }
+
+  // Return whether this is a big archive.
+  bool
+  is_big_archive() const
+  { return this->is_big_archive_; }
+
+  // Return the location of the import statement.
+  location_t
+  location() const
+  { return this->location_; }
+
+  // Read bytes.
+  bool
+  read(off_t offset, off_t size, char*);
+
+  // Parse a decimal in readable text.
+  bool
+  parse_decimal(const char* str, off_t size, long* res) const;
+
+  // Read the archive header at OFF, setting *PNAME, *SIZE,
+  // *NESTED_OFF and *NEXT_OFF.
+  bool
+  read_header(off_t off, std::string* pname, off_t* size, off_t* nested_off,
+              off_t* next_off);
+
+  // Interpret the header of HDR, the header of the archive member at
+  // file offset OFF.  Return whether it succeeded.  Set *SIZE to the
+  // size of the member.  Set *PNAME to the name of the member.  Set
+  // *NESTED_OFF to the offset in a nested archive.
+  bool
+  interpret_header(const Archive_header* hdr, off_t off,
+		   std::string* pname, off_t* size, off_t* nested_off) const;
+
+  // Get the file and offset for an archive member.
+  bool
+  get_file_and_offset(off_t off, const std::string& hdrname,
+		      off_t nested_off, int* memfd, off_t* memoff,
+		      std::string* memname);
+
+ private:
+  // Initialize a big archive (AIX)
+  bool
+  initialize_big_archive();
+
+  // Initialize a normal archive
+  bool
+  initialize_archive();
+
+  // Read the big archive header at OFF, setting *PNAME, *SIZE and *NEXT_OFF.
+  bool
+  read_big_archive_header(off_t off, std::string* pname,
+                          off_t* size, off_t* next_off);
+
+  // Read the normal archive header at OFF, setting *PNAME, *SIZE,
+  // *NESTED_OFF and *NEXT_OFF.
+  bool
+  read_archive_header(off_t off, std::string* pname, off_t* size,
+                      off_t* nested_off, off_t* next_off);
+
+  // For keeping track of open nested archives in a thin archive file.
+  typedef std::map<std::string, Archive_file*> Nested_archive_table;
+
+  // The name of the file.
+  std::string filename_;
+  // The file descriptor.
+  int fd_;
+  // The file size;
+  off_t filesize_;
+  // The first member offset;
+  off_t first_member_offset_;
+  // The extended name table.
+  std::string extended_names_;
+  // Whether this is a thin archive.
+  bool is_thin_archive_;
+  // Whether this is a big archive.
+  bool is_big_archive_;
+  // The location of the import statements.
+  location_t location_;
+  // Table of nested archives.
+  Nested_archive_table nested_archives_;
+};
+
+bool
+Archive_file::initialize()
+{
+  struct stat st;
+  if (fstat(this->fd_, &st) < 0)
+    {
+      a68_error (NO_NODE, "%s: doing stat", this->filename_.c_str());
+      return false;
+    }
+  this->filesize_ = st.st_size;
+
+  char buf[sizeof(armagt)];
+  if (::lseek(this->fd_, 0, SEEK_SET) < 0
+      || ::read(this->fd_, buf, sizeof(armagt)) != sizeof(armagt))
+    {
+      a68_error (NO_NODE, "%s: reading from archive", this->filename_.c_str());
+      return false;
+    }
+  if (memcmp(buf, armagt, sizeof(armagt)) == 0)
+    this->is_thin_archive_ = true;
+  else if (memcmp(buf, armagb, sizeof(armagb)) == 0)
+    this->is_big_archive_ = true;
+
+  if (this->is_big_archive_)
+    return this->initialize_big_archive();
+  else
+    return this->initialize_archive();
+}
+
+// Initialize a big archive (AIX).
+
+bool
+Archive_file::initialize_big_archive()
+{
+  Archive_fl_header flhdr;
+
+  // Read the fixed length header.
+  if (::lseek(this->fd_, 0, SEEK_SET) < 0
+      || ::read(this->fd_, &flhdr, sizeof(flhdr)) != sizeof(flhdr))
+    {
+      a68_error (NO_NODE, "%s: could not read archive header",
+                  this->filename_.c_str());
+      return false;
+    }
+
+  // Parse offset of the first member.
+  long off;
+  if (!this->parse_decimal(flhdr.fl_fstmoff, sizeof(flhdr.fl_fstmoff), &off))
+    {
+      char* buf = new char[sizeof(flhdr.fl_fstmoff) + 1];
+      memcpy(buf, flhdr.fl_fstmoff, sizeof(flhdr.fl_fstmoff));
+      a68_error (NO_NODE,
+		 ("%s: malformed first member offset in archive header"
+                   " (expected decimal, got %qs)"),
+                  this->filename_.c_str(), buf);
+      delete[] buf;
+      return false;
+    }
+  if (off == 0) // Empty archive.
+    this->first_member_offset_ = this->filesize_;
+  else
+    this->first_member_offset_ = off;
+  return true;
+}
+
+// Initialize a normal archive.
+
+bool
+Archive_file::initialize_archive()
+{
+  this->first_member_offset_ = sizeof(armag);
+  if (this->first_member_offset_ == this->filesize_)
+    {
+      // Empty archive.
+      return true;
+    }
+
+  // Look for the extended name table.
+  std::string filename;
+  off_t size;
+  off_t next_off;
+  if (!this->read_header(this->first_member_offset_, &filename,
+                         &size, NULL, &next_off))
+    return false;
+  if (filename.empty())
+    {
+      // We found the symbol table.
+      if (!this->read_header(next_off, &filename, &size, NULL, NULL))
+	filename.clear();
+    }
+  if (filename == "/")
+    {
+      char* rdbuf = new char[size];
+      if (::read(this->fd_, rdbuf, size) != size)
+	{
+	  a68_error (NO_NODE, "%s: could not read extended names",
+		     filename.c_str());
+	  delete[] rdbuf;
+	  return false;
+	}
+      this->extended_names_.assign(rdbuf, size);
+      delete[] rdbuf;
+    }
+
+  return true;
+}
+
+// Read bytes from the file.
+
+bool
+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, "%s: reading from archive", this->filename_.c_str());
+      return false;
+    }
+  return true;
+}
+
+// Parse a decimal in readable text.
+
+bool
+Archive_file::parse_decimal(const char* str, off_t size, long* res) const
+{
+  char* buf = new char[size + 1];
+  memcpy(buf, str, size);
+  char* ps = buf + size;
+  while (ps > buf && ps[-1] == ' ')
+    --ps;
+  *ps = '\0';
+
+  errno = 0;
+  char* end;
+  *res = strtol(buf, &end, 10);
+  if (*end != '\0'
+      || *res < 0
+      || (*res == LONG_MAX && errno == ERANGE))
+    {
+      delete[] buf;
+      return false;
+    }
+  delete[] buf;
+  return true;
+}
+
+// Read the header at OFF.  Set *PNAME to the name, *SIZE to the size,
+// *NESTED_OFF to the nested offset, and *NEXT_OFF to the next member offset.
+
+bool
+Archive_file::read_header(off_t off, std::string* pname, off_t* size,
+			  off_t* nested_off, off_t* next_off)
+{
+  if (::lseek(this->fd_, off, SEEK_SET) < 0)
+    {
+      a68_error (NO_NODE, "%s: seeking in archive", this->filename_.c_str());
+      return false;
+    }
+  if (this->is_big_archive_)
+    return this->read_big_archive_header(off, pname, size, next_off);
+  else
+    return this->read_archive_header(off, pname, size, nested_off, next_off);
+}
+
+// Read the big archive header at OFF, setting *PNAME, *SIZE and *NEXT_OFF.
+
+bool
+Archive_file::read_big_archive_header(off_t off, std::string* pname,
+                                      off_t* size, off_t* next_off)
+{
+  Archive_big_header hdr;
+  ssize_t got;
+
+  got = ::read(this->fd_, &hdr, sizeof hdr);
+  if (got != sizeof hdr)
+    {
+      if (got < 0)
+        a68_error (NO_NODE, "%s: reading from archive", this->filename_.c_str());
+      else if (got > 0)
+        a68_error (NO_NODE, "%qs short entry header at %ld",
+                    this->filename_.c_str(), static_cast<long>(off));
+      else
+        a68_error (NO_NODE, "%s: unexpected EOF at %ld",
+		   this->filename_.c_str(), static_cast<long>(off));
+    }
+
+  long local_size;
+  if (!this->parse_decimal(hdr.ar_size, sizeof(hdr.ar_size), &local_size))
+    {
+      char* buf = new char[sizeof(hdr.ar_size) + 1];
+      memcpy(buf, hdr.ar_size, sizeof(hdr.ar_size));
+      a68_error (NO_NODE,
+                  ("%s: malformed size in entry header at %ld"
+                   " (expected decimal, got %s)"),
+		 this->filename_.c_str(), static_cast<long>(off), buf);
+      delete[] buf;
+      return false;
+    }
+  *size = local_size;
+
+  long namlen;
+  if (!this->parse_decimal(hdr.ar_namlen, sizeof(hdr.ar_namlen), &namlen))
+    {
+      char* buf = new char[sizeof(hdr.ar_namlen) + 1];
+      memcpy(buf, hdr.ar_namlen, sizeof(hdr.ar_namlen));
+      a68_error (NO_NODE,
+                  ("%s: malformed name length in entry header at %ld"
+                   " (expected decimal, got %s)"),
+                  this->filename_.c_str(), static_cast<long>(off), buf);
+      delete[] buf;
+      return false;
+    }
+  // Read member name following member header.
+  char* rdbuf = new char[namlen];
+  got = ::read(this->fd_, rdbuf, namlen);
+  if (got != namlen)
+    {
+      a68_error (NO_NODE,
+		 "%s: malformed member name in entry header at %ld",
+		 this->filename_.c_str(), static_cast<long>(off));
+      delete[] rdbuf;
+      return false;
+    }
+  pname->assign(rdbuf, namlen);
+  delete[] rdbuf;
+
+  long local_next_off;
+  if (!this->parse_decimal(hdr.ar_nxtmem, sizeof(hdr.ar_nxtmem), &local_next_off))
+    {
+      char* buf = new char[sizeof(hdr.ar_nxtmem) + 1];
+      memcpy(buf, hdr.ar_nxtmem, sizeof(hdr.ar_nxtmem));
+      a68_error (NO_NODE,
+		 ("%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;
+      return false;
+    }
+  if (next_off != NULL)
+    {
+      if (local_next_off == 0) // Last member.
+        *next_off = this->filesize_;
+      else
+        *next_off = local_next_off;
+    }
+  return true;
+}
+
+// Read the normal archive header at OFF, setting *PNAME, *SIZE,
+// *NESTED_OFF and *NEXT_OFF.
+
+bool
+Archive_file::read_archive_header(off_t off, std::string* pname, off_t* size,
+                                  off_t* nested_off, off_t* next_off)
+{
+  Archive_header hdr;
+  ssize_t got = ::read(this->fd_, &hdr, sizeof hdr);
+  if (got != sizeof hdr)
+    {
+      if (got < 0)
+	a68_error (NO_NODE, "%s: reading from archive", this->filename_.c_str());
+      else if (got > 0)
+	a68_error (NO_NODE, "%s: short archive header at %ld",
+		   this->filename_.c_str(), static_cast<long>(off));
+      else
+	a68_error (NO_NODE, "%s: unexpected EOF at %ld",
+		   this->filename_.c_str(), static_cast<long>(off));
+    }
+  off_t local_nested_off;
+  if (!this->interpret_header(&hdr, off, pname, size, &local_nested_off))
+    return false;
+  if (nested_off != NULL)
+    *nested_off = local_nested_off;
+
+  off_t local_next_off;
+  local_next_off = off + sizeof(Archive_header);
+  if (!this->is_thin_archive_ || pname->empty() || *pname == "/")
+    local_next_off += *size;
+  if ((local_next_off & 1) != 0)
+    ++local_next_off;
+  if (local_next_off > this->filesize_) // Last member.
+    local_next_off = this->filesize_;
+  if (next_off != NULL)
+    *next_off = local_next_off;
+  return true;
+}
+
+// Interpret the header of HDR, the header of the archive member at
+// file offset OFF.
+
+bool
+Archive_file::interpret_header(const Archive_header* hdr, off_t off,
+			       std::string* pname, off_t* size,
+			       off_t* nested_off) const
+{
+  if (memcmp(hdr->ar_fmag, arfmag, sizeof arfmag) != 0)
+    {
+      a68_error (NO_NODE, "%s: malformed archive header at %lu",
+		 this->filename_.c_str(), static_cast<unsigned long>(off));
+      return false;
+    }
+
+  long local_size;
+  if (!this->parse_decimal(hdr->ar_size, sizeof hdr->ar_size, &local_size))
+    {
+      a68_error (NO_NODE, "%s: malformed archive header size at %lu",
+		 this->filename_.c_str(), static_cast<unsigned long>(off));
+      return false;
+    }
+  *size = local_size;
+
+  *nested_off = 0;
+  if (hdr->ar_name[0] != '/')
+    {
+      const char* name_end = strchr(hdr->ar_name, '/');
+      if (name_end == NULL
+	  || name_end - hdr->ar_name >= static_cast<int>(sizeof hdr->ar_name))
+	{
+	  a68_error (NO_NODE,
+		     "%s: malformed archive header name at %lu",
+		     this->filename_.c_str(), static_cast<unsigned long>(off));
+	  return false;
+	}
+      pname->assign(hdr->ar_name, name_end - hdr->ar_name);
+    }
+  else if (hdr->ar_name[1] == ' ')
+    {
+      // This is the symbol table.
+      pname->clear();
+    }
+  else if (hdr->ar_name[1] == 'S' && hdr->ar_name[2] == 'Y'
+	   && hdr->ar_name[3] == 'M' && hdr->ar_name[4] == '6'
+	   && hdr->ar_name[5] == '4' && hdr->ar_name[6] == '/'
+	   && hdr->ar_name[7] == ' '
+	  )
+    {
+      // 64-bit symbol table.
+      pname->clear();
+    }
+  else if (hdr->ar_name[1] == '/')
+    {
+      // This is the extended name table.
+      pname->assign(1, '/');
+    }
+  else
+    {
+      char* end;
+      errno = 0;
+      long x = strtol(hdr->ar_name + 1, &end, 10);
+      long y = 0;
+      if (*end == ':')
+        y = strtol(end + 1, &end, 10);
+      if (*end != ' '
+	  || x < 0
+	  || (x == LONG_MAX && errno == ERANGE)
+	  || static_cast<size_t>(x) >= this->extended_names_.size())
+	{
+	  a68_error (NO_NODE, "%s: bad extended name index at %lu",
+		     this->filename_.c_str(), static_cast<unsigned long>(off));
+	  return false;
+	}
+
+      const char* name = this->extended_names_.data() + x;
+      const char* name_end = strchr(name, '\n');
+      if (static_cast<size_t>(name_end - name) > this->extended_names_.size()
+	  || name_end[-1] != '/')
+	{
+	  a68_error (NO_NODE,
+		     "%s: bad extended name entry at header %lu",
+		     this->filename_.c_str(), static_cast<unsigned long>(off));
+	  return false;
+	}
+      pname->assign(name, name_end - 1 - name);
+      *nested_off = y;
+    }
+
+  return true;
+}
+
+// Get the file and offset for an archive member.
+
+bool
+Archive_file::get_file_and_offset(off_t off, const std::string& hdrname,
+				  off_t nested_off, int* memfd, off_t* memoff,
+				  std::string* memname)
+{
+  if (this->is_big_archive_)
+    {
+      *memfd = this->fd_;
+      *memoff = (off + sizeof(Archive_big_header) + hdrname.length()
+                 + sizeof(arfmag));
+      if ((*memoff & 1) != 0)
+        ++*memoff;
+      *memname = this->filename_ + '(' + hdrname + ')';
+      return true;
+    }
+  else if (!this->is_thin_archive_)
+    {
+      *memfd = this->fd_;
+      *memoff = off + sizeof(Archive_header);
+      *memname = this->filename_ + '(' + hdrname + ')';
+      return true;
+    }
+
+  std::string filename = hdrname;
+  if (!IS_ABSOLUTE_PATH(filename.c_str()))
+    {
+      const char* archive_path = this->filename_.c_str();
+      const char* basename = lbasename(archive_path);
+      if (basename > archive_path)
+	filename.replace(0, 0,
+			 this->filename_.substr(0, basename - archive_path));
+    }
+
+  if (nested_off > 0)
+    {
+      // This is a member of a nested archive.
+      Archive_file* nfile;
+      Nested_archive_table::const_iterator p =
+	this->nested_archives_.find(filename);
+      if (p != this->nested_archives_.end())
+	nfile = p->second;
+      else
+	{
+	  int nfd = open(filename.c_str(), O_RDONLY | O_BINARY);
+	  if (nfd < 0)
+	    {
+	      a68_error (NO_NODE, "%s: cannot open nested archive %s",
+			 this->filename_.c_str(), filename.c_str());
+	      return false;
+	    }
+	  nfile = new Archive_file(filename, nfd, this->location_);
+	  if (!nfile->initialize())
+	    {
+	      delete nfile;
+	      return false;
+	    }
+	  this->nested_archives_[filename] = nfile;
+	}
+
+      std::string nname;
+      off_t nsize;
+      off_t nnested_off;
+      if (!nfile->read_header(nested_off, &nname, &nsize, &nnested_off, NULL))
+	return false;
+      return nfile->get_file_and_offset(nested_off, nname, nnested_off,
+					memfd, memoff, memname);
+    }
+
+  // An external member of a thin archive.
+  *memfd = open(filename.c_str(), O_RDONLY | O_BINARY);
+  if (*memfd < 0)
+    {
+      a68_error (NO_NODE, "%s: opening archive", filename.c_str());
+      return false;
+    }
+  *memoff = 0;
+  *memname = filename;
+  return true;
+}
+
+// An archive member iterator.  This is more-or-less copied from gold.
+
+class Archive_iterator
+{
+ public:
+  // The header of an archive member.  This is what this iterator
+  // points to.
+  struct Header
+  {
+    // The name of the member.
+    std::string name;
+    // The file offset of the member.
+    off_t off;
+    // The file offset of a nested archive member.
+    off_t nested_off;
+    // The size of the member.
+    off_t size;
+  };
+
+  Archive_iterator(Archive_file* afile, off_t off)
+    : afile_(afile), off_(off)
+  { this->read_next_header(); }
+
+  const Header&
+  operator*() const
+  { return this->header_; }
+
+  const Header*
+  operator->() const
+  { return &this->header_; }
+
+  Archive_iterator&
+  operator++()
+  {
+    if (this->off_ == this->afile_->filesize())
+      return *this;
+    this->off_ = this->next_off_;
+    this->read_next_header();
+    return *this;
+  }
+
+  Archive_iterator
+  operator++(int)
+  {
+    Archive_iterator ret = *this;
+    ++*this;
+    return ret;
+  }
+
+  bool
+  operator==(const Archive_iterator& p) const
+  { return this->off_ == p->off; }
+
+  bool
+  operator!=(const Archive_iterator& p) const
+  { return this->off_ != p->off; }
+
+ private:
+  void
+  read_next_header();
+
+  // The underlying archive file.
+  Archive_file* afile_;
+  // The current offset in the file.
+  off_t off_;
+  // The offset of the next member.
+  off_t next_off_;
+  // The current archive header.
+  Header header_;
+};
+
+// Read the next archive header.
+
+void
+Archive_iterator::read_next_header()
+{
+  off_t filesize = this->afile_->filesize();
+  while (true)
+    {
+      if (this->off_ == filesize)
+	{
+	  this->header_.off = filesize;
+	  return;
+	}
+
+      if (!this->afile_->read_header(this->off_, &this->header_.name,
+                                     &this->header_.size,
+                                     &this->header_.nested_off,
+                                     &this->next_off_))
+	{
+	  this->header_.off = filesize;
+	  this->off_ = filesize;
+	  return;
+	}
+      this->header_.off = this->off_;
+
+      // Skip special members.
+      if (!this->header_.name.empty() && this->header_.name != "/")
+	return;
+
+      this->off_ = this->next_off_;
+    }
+}
+
+// Initial iterator.
+
+Archive_iterator
+archive_begin(Archive_file* afile)
+{
+  return Archive_iterator(afile, afile->first_member_offset());
+}
+
+// Final iterator.
+
+Archive_iterator
+archive_end(Archive_file* afile)
+{
+  return Archive_iterator(afile, afile->filesize());
+}
+
+/* Get a68 imports from an archive.  We walk through the archive and read
+   imports from each member.  */
+
+char *
+a68_find_archive_export_data (const char *filename, int fd,
+			      size_t *size)
+{
+  char *ret = NULL;
+  size_t ret_size = 0;
+
+  Archive_file afile(filename, fd, UNKNOWN_LOCATION);
+  if (!afile.initialize())
+    return NULL;
+
+
+  Archive_iterator pend = archive_end(&afile);
+  for (Archive_iterator p = archive_begin(&afile); p != pend; p++)
+    {
+      int member_fd;
+      off_t member_off;
+      std::string member_name;
+      if (!afile.get_file_and_offset(p->off, p->name, p->nested_off,
+				     &member_fd, &member_off, &member_name))
+	{
+	  *size = 0;
+	  return NULL;
+	}
+
+      size_t exports_size;
+      char *exports = a68_find_object_export_data (member_name,
+						   member_fd,
+						   member_off,
+						   &exports_size);
+      if (exports != NULL)
+	{
+	  if (ret == NULL)
+	    {
+	      ret = exports;
+	      ret_size = exports_size;
+	    }
+	  else
+	    {
+	      ret = (char *) xrealloc (ret, ret_size + exports_size);
+	      memcpy (ret + ret_size, exports, exports_size);
+	      ret_size += exports_size;
+	      free (exports);
+	    }
+	}
+    }
+
+  *size = ret_size;
+  return ret;
+}

gcc/algol68/a68-imports.cc

@@ -231,9 +231,9 @@ a68_read_export_data (int fd, uint64_t offset, char **pbuf, size_t *plen,
 
 /* Look for export data in an object file.  */
 
-static char *
+char *
 a68_find_object_export_data (const std::string& filename,
-			     int fd, uint64_t offset, size_t *psize)
+			     int fd, off_t offset, size_t *psize)
 {
   char *buf;
   size_t len;
@@ -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;
         }
@@ -324,11 +324,26 @@ a68_find_export_data (const std::string &filename, int fd, size_t *psize)
       return buf;
     }
 
-#if 0
   /* See if we can read this as an archive.  */
-  if (Import::is_archive_magic(buf))
-    return Import::find_archive_export_data(filename, fd, location);
-#endif
+  {
+    char buf[8];
+
+    if (lseek (fd, 0, SEEK_SET) < 0)
+      {
+	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 %qs failed", filename.c_str ());
+	return NULL;
+      }
+
+    if (a68_is_archive_magic (buf))
+      return a68_find_archive_export_data(filename.c_str (), fd, psize);
+  }
 
   return NULL;
 }
@@ -394,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;
@@ -1351,10 +1366,14 @@ a68_decode_moifs (const char *data, size_t size, const char **errstr)
 }
 
 /* Get a moif with the exports for module named MODULE.  If no exports can be
-   found then return NULL.  */
+   found then return NULL.
+
+   If BASENAME is not NULL then it specifies the basefile of the file to open
+   for the module exports: BASENAME.o, libBASENAME.so, etc.  If BASENAME is
+   NULL then the filename is derived from the module name.  */
 
 MOIF_T *
-a68_open_packet (const char *module)
+a68_open_packet (const char *module, const char *basename)
 {
   /* We may have a suitable moif already decoded for the requested module.  If
      so, use it.  */
@@ -1375,21 +1394,26 @@ a68_open_packet (const char *module)
   if (moif == NO_MOIF)
     {
       char *filename;
-      const char **pfilename = A68_MODULE_FILES->get (module);
-      if (pfilename == NULL)
-	{
-	  /* Turn the module indicant in MODULE to lower-case.  */
-	  filename = (char *) alloca (strlen (module) + 1);
-	  size_t i = 0;
-	  for (; i < strlen (module); i++)
-	    filename[i] = TOLOWER (module[i]);
-	  filename[i] = '\0';
-	}
+      if (basename != NULL)
+	filename = xstrdup (basename);
       else
 	{
-	  size_t len = strlen (*pfilename) + 1;
-	  filename = (char *) alloca (len);
-	  memcpy (filename, *pfilename, len);
+	  const char **pfilename = A68_MODULE_FILES->get (module);
+	  if (pfilename == NULL)
+	    {
+	      /* Turn the module indicant in MODULE to lower-case.  */
+	      filename = (char *) alloca (strlen (module) + 1);
+	      size_t i = 0;
+	      for (; i < strlen (module); i++)
+		filename[i] = TOLOWER (module[i]);
+	      filename[i] = '\0';
+	    }
+	  else
+	    {
+	      size_t len = strlen (*pfilename) + 1;
+	      filename = (char *) alloca (len);
+	      memcpy (filename, *pfilename, len);
+	    }
 	}
 
       /* Try to read exports data in a buffer.  */
@@ -1405,7 +1429,7 @@ a68_open_packet (const char *module)
       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;
 	}
 

gcc/algol68/a68-low-holes.cc

@@ -75,8 +75,9 @@ tree
 a68_wrap_formal_var_hole (NODE_T *p)
 {
   gcc_assert (!IS (MOID (p), PROC_SYMBOL));
-  const char *symbol = get_hole_symbol (p, NULL /* addrp */);
-  return a68_make_formal_hole_decl (p, symbol);
+  bool addrp;
+  const char *symbol = get_hole_symbol (p, &addrp);
+  return a68_make_formal_hole_decl (p, symbol, addrp);
 }
 
 /* Build the body for a wrapper to the formal hole in P, which is of a proc
@@ -104,9 +105,13 @@ a68_wrap_formal_proc_hole (NODE_T *p, tree wrapper)
       else
 	wrapped_nargs += 1;
     }
+  if (SUB (m) == M_STRING)
+    wrapped_nargs += 2;
 
   /* Now build the type of the wrapped function.  */
-
+  tree wrapper_ret_type = TREE_TYPE (TREE_TYPE (wrapper));
+  tree wrapped_ret_type = (SUB (m) == M_STRING
+			   ? void_type_node : wrapper_ret_type);
   tree *wrapped_args_types = XALLOCAVEC (tree, wrapped_nargs);
   int nwrappedarg = 0;
   for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))
@@ -123,11 +128,18 @@ a68_wrap_formal_proc_hole (NODE_T *p, tree wrapper)
 	}
     }
 
-  tree wrapper_ret_type = TREE_TYPE (TREE_TYPE (wrapper));
-  tree wrapped_type = build_function_type_array (wrapper_ret_type,
+  if (SUB (m) == M_STRING)
+    {
+      wrapped_args_types[nwrappedarg++]
+	= build_pointer_type (build_pointer_type (a68_char_type));
+      wrapped_args_types[nwrappedarg++]
+	= build_pointer_type (size_type_node);
+    }
+
+  tree wrapped_type = build_function_type_array (wrapped_ret_type,
 						 wrapped_nargs,
 						 wrapped_args_types);
-      
+
   /* And a decl for the wrapped function.  */
   tree wrapped = build_decl (UNKNOWN_LOCATION,
 			     FUNCTION_DECL,
@@ -167,13 +179,56 @@ a68_wrap_formal_proc_hole (NODE_T *p, tree wrapper)
     }
   DECL_ARGUMENTS (wrapper) = nreverse (DECL_ARGUMENTS (wrapper));
 
+  tree body = NULL_TREE;
   a68_push_function_range (wrapper, wrapper_ret_type);
+  {
+    /* Note how we need a pointer to a function type for the call.  */
+    if (!POINTER_TYPE_P (TREE_TYPE (wrapped)))
+      wrapped = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (wrapped)),
+			     wrapped);
+    if (SUB (m) == M_STRING
+	|| (IS_REF (SUB (m)) && SUB (SUB (m)) == M_STRING))
+      {
+	a68_push_range (SUB (m));
+	tree ptrchar_type = build_pointer_type (a68_char_type);
+	tree r = a68_lower_tmpvar ("r%", ptrchar_type, build_int_cst (ptrchar_type, 0));
+	tree rlen = a68_lower_tmpvar ("rlen%", sizetype, size_int (0));
+	TREE_ADDRESSABLE (r) = 1;
+	TREE_ADDRESSABLE (rlen) = 1;
 
-  /* We need a pointer to a function type.  */
-  if (!POINTER_TYPE_P (TREE_TYPE (wrapped)))
-    wrapped = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (wrapped)),
-			   wrapped);
+	/* Add two additional arguments to the wrapped call if the wrapper
+	   returns a string.  */
+	wrapped_args->quick_push (fold_build1 (ADDR_EXPR,
+					       build_pointer_type (ptrchar_type), r));
+	wrapped_args->quick_push (fold_build1 (ADDR_EXPR,
+					       build_pointer_type (sizetype), rlen));
 
-  tree body = build_call_vec (TREE_TYPE (wrapped_type), wrapped, wrapped_args);
+	/* Call to the wrapped function.  */
+	tree call = build_call_vec (TREE_TYPE (wrapped_type), wrapped, wrapped_args);
+	a68_add_stmt (call);
+
+	/* Build the result string.  */
+	tree lower_bound = ssize_int (1);
+	tree upper_bound = fold_convert (ssizetype, rlen);
+	tree relems_size = fold_build2 (MULT_EXPR, sizetype,
+					rlen, size_in_bytes (a68_char_type));
+
+
+	if (SUB (m) == M_STRING)
+	  a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */,
+				       r, relems_size, &lower_bound, &upper_bound));
+	else
+	  {
+	    /* Return a ref to string.  */
+	    gcc_assert (IS_REF (SUB (m)) && SUB (SUB (m)) == M_STRING);
+	    a68_add_stmt (a68_row_malloc (M_STRING, 1 /* dim */,
+					  r, relems_size,
+					  &lower_bound, &upper_bound));
+	  }
+	body = a68_pop_range ();
+      }
+    else
+      body = build_call_vec (TREE_TYPE (wrapped_type), wrapped, wrapped_args);
+  }
   a68_pop_function_range (body);
 }

gcc/algol68/a68-low-posix.cc

@@ -1,556 +0,0 @@
-/* Lowering routines for the POSIX prelude.
-   Copyright (C) 2025 Jose E. Marchesi.
-
-   Written 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/>.  */
-
-#define INCLUDE_MEMORY
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-
-#include "tree.h"
-#include "fold-const.h"
-#include "diagnostic.h"
-#include "langhooks.h"
-#include "tm.h"
-#include "function.h"
-#include "cgraph.h"
-#include "toplev.h"
-#include "varasm.h"
-#include "predict.h"
-#include "stor-layout.h"
-#include "tree-iterator.h"
-#include "stringpool.h"
-#include "print-tree.h"
-#include "gimplify.h"
-#include "dumpfile.h"
-#include "convert.h"
-
-#include "a68.h"
-
-/* Number of command line arguments passed to the program.  */
-
-tree
-a68_posix_argc (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_ARGC);
-}
-
-/* Gets the Nth command line argument passed to the program.  If N is out of
-   range the result is an empty string.  */
-
-tree
-a68_posix_argv (void)
-{
-  static tree argv_fndecl;
-
-  if (argv_fndecl == NULL_TREE)
-    {
-      argv_fndecl
-	= a68_low_toplevel_func_decl ("argv",
-				      build_function_type_list (CTYPE (M_STRING),
-								a68_int_type,
-								NULL_TREE));
-      announce_function (argv_fndecl);
-
-      tree param = a68_low_func_param (argv_fndecl, "n", a68_int_type);
-      DECL_ARGUMENTS (argv_fndecl) = param;
-
-      a68_push_function_range (argv_fndecl, CTYPE (M_STRING),
-			       true /* top_level */);
-
-      a68_push_range (M_STRING);
-      tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0));
-      TREE_ADDRESSABLE (len) = 1;
-
-      tree ptrtochar_type = build_pointer_type (a68_char_type);
-      tree elems = a68_lower_tmpvar ("elems%", ptrtochar_type,
-				     a68_build_libcall (A68_LIBCALL_POSIX_ARGV,
-							ptrtochar_type, 2,
-							param,
-							fold_build1 (ADDR_EXPR, build_pointer_type (sizetype),
-								     len)));
-      tree lower_bound = ssize_int (1);
-      tree upper_bound = fold_convert (ssizetype, len);
-      tree elems_size = fold_build2 (MULT_EXPR, sizetype,
-				     len,
-				     size_in_bytes (a68_char_type));
-      a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */,
-				   elems, elems_size,
-				   &lower_bound, &upper_bound));
-      tree body = a68_pop_range ();
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (argv_fndecl)),
-		      argv_fndecl);
-}
-
-/* Gets the value of an environment variable, or an empty string if the
-   variable is not set.  */
-
-tree
-a68_posix_getenv (void)
-{
-  static tree getenv_fndecl;
-
-  if (getenv_fndecl == NULL_TREE)
-    {
-      getenv_fndecl
-	= a68_low_toplevel_func_decl ("getenv",
-				      build_function_type_list (CTYPE (M_STRING),
-								CTYPE (M_STRING),
-								NULL_TREE));
-      announce_function (getenv_fndecl);
-
-      tree param = a68_low_func_param (getenv_fndecl, "varname", CTYPE (M_STRING));
-      DECL_ARGUMENTS (getenv_fndecl) = param;
-
-      a68_push_function_range (getenv_fndecl, CTYPE (M_STRING),
-			       true /* top_level */);
-
-      a68_push_range (M_STRING);
-
-      tree varname = a68_lower_tmpvar ("varname%", CTYPE (M_STRING),
-				       param);
-
-      tree ptrtochar_type = build_pointer_type (a68_char_type);
-      tree convelems = a68_lower_tmpvar ("convelems%", ptrtochar_type,
-					 build_int_cst (ptrtochar_type, 0));
-      TREE_ADDRESSABLE (convelems) = 1;
-      tree convelemslen = a68_lower_tmpvar ("convelemslen%", sizetype,
-					    size_int (0));
-      TREE_ADDRESSABLE (convelemslen) = 1;
-
-      tree call = a68_build_libcall (A68_LIBCALL_POSIX_GETENV,
-				     void_type_node, 5,
-				     a68_multiple_elements (varname),
-				     a68_multiple_num_elems (varname),
-				     a68_multiple_stride (varname, size_zero_node),
-				     fold_build1 (ADDR_EXPR, build_pointer_type (ptrtochar_type),
-						  convelems),
-				     fold_build1 (ADDR_EXPR, build_pointer_type (sizetype),
-						  convelemslen));
-      a68_add_stmt (call);
-      tree lower_bound = ssize_int (1);
-      tree upper_bound = fold_convert (ssizetype, convelemslen);
-      tree convelems_size = fold_build2 (MULT_EXPR, sizetype,
-					 convelemslen,
-					 size_in_bytes (a68_char_type));
-      a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */,
-				   convelems, convelems_size,
-				   &lower_bound, &upper_bound));
-      tree body = a68_pop_range ();
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (getenv_fndecl)),
-		      getenv_fndecl);
-}
-
-tree
-a68_posix_putchar (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_PUTCHAR);
-}
-
-tree
-a68_posix_puts (void)
-{
-  static tree puts_fndecl;
-
-  if (puts_fndecl == NULL_TREE)
-    {
-      puts_fndecl
-	= a68_low_toplevel_func_decl ("puts",
-				      build_function_type_list (void_type_node,
-								CTYPE (M_STRING),
-								NULL_TREE));
-      announce_function (puts_fndecl);
-
-      tree param = a68_low_func_param (puts_fndecl, "str", CTYPE (M_STRING));
-      DECL_ARGUMENTS (puts_fndecl) = param;
-
-      a68_push_function_range (puts_fndecl, void_type_node,
-			       true /* top_level */);
-
-      tree call = a68_build_libcall (A68_LIBCALL_POSIX_PUTS,
-				     void_type_node, 3,
-				     a68_multiple_elements (param),
-				     a68_multiple_num_elems (param),
-				     a68_multiple_stride (param, size_zero_node));
-      a68_pop_function_range (call);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (puts_fndecl)),
-		      puts_fndecl);
-}
-
-tree
-a68_posix_fconnect (void)
-{
-  static tree fconnect_fndecl;
-
-  if (fconnect_fndecl == NULL_TREE)
-    {
-      fconnect_fndecl
-	= a68_low_toplevel_func_decl ("fconnect",
-				      build_function_type_list (a68_int_type,
-								CTYPE (M_STRING),
-								a68_bits_type,
-								NULL_TREE));
-      announce_function (fconnect_fndecl);
-
-      tree host = a68_low_func_param (fconnect_fndecl, "host", CTYPE (M_STRING));
-      tree port = a68_low_func_param (fconnect_fndecl, "port", a68_int_type);
-      DECL_ARGUMENTS (fconnect_fndecl) = chainon (host, port);
-
-      a68_push_function_range (fconnect_fndecl, a68_int_type,
-			       true /* top_level */);
-
-
-      tree body = a68_build_libcall (A68_LIBCALL_POSIX_FCONNECT,
-				     a68_int_type, 4,
-				     a68_multiple_elements (host),
-				     a68_multiple_num_elems (host),
-				     a68_multiple_stride (host, size_zero_node),
-				     port);
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fconnect_fndecl)),
-		      fconnect_fndecl);
-}
-
-tree
-a68_posix_fcreate (void)
-{
-  static tree fcreate_fndecl;
-
-  if (fcreate_fndecl == NULL_TREE)
-    {
-      fcreate_fndecl
-	= a68_low_toplevel_func_decl ("fcreate",
-				      build_function_type_list (a68_int_type,
-								CTYPE (M_STRING),
-								a68_bits_type,
-								NULL_TREE));
-      announce_function (fcreate_fndecl);
-
-      tree pathname = a68_low_func_param (fcreate_fndecl, "pathname", CTYPE (M_STRING));
-      tree mode = a68_low_func_param (fcreate_fndecl, "mode", a68_int_type);
-      DECL_ARGUMENTS (fcreate_fndecl) = chainon (pathname, mode);
-
-      a68_push_function_range (fcreate_fndecl, a68_int_type,
-			       true /* top_level */);
-
-
-      tree body = a68_build_libcall (A68_LIBCALL_POSIX_FCREATE,
-				     a68_int_type, 4,
-				     a68_multiple_elements (pathname),
-				     a68_multiple_num_elems (pathname),
-				     a68_multiple_stride (pathname, size_zero_node),
-				     mode);
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fcreate_fndecl)),
-		      fcreate_fndecl);
-}
-
-tree
-a68_posix_fopen (void)
-{
-  static tree fopen_fndecl;
-
-  if (fopen_fndecl == NULL_TREE)
-    {
-      fopen_fndecl
-	= a68_low_toplevel_func_decl ("fopen",
-				      build_function_type_list (a68_int_type,
-								CTYPE (M_STRING),
-								a68_bits_type,
-								NULL_TREE));
-      announce_function (fopen_fndecl);
-
-      tree pathname = a68_low_func_param (fopen_fndecl, "pathname", CTYPE (M_STRING));
-      tree flags = a68_low_func_param (fopen_fndecl, "flags", a68_int_type);
-      DECL_ARGUMENTS (fopen_fndecl) = chainon (pathname, flags);
-
-      a68_push_function_range (fopen_fndecl, a68_int_type,
-			       true /* top_level */);
-
-
-      tree body = a68_build_libcall (A68_LIBCALL_POSIX_FOPEN,
-				     a68_int_type, 4,
-				     a68_multiple_elements (pathname),
-				     a68_multiple_num_elems (pathname),
-				     a68_multiple_stride (pathname, size_zero_node),
-				     flags);
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fopen_fndecl)),
-		      fopen_fndecl);
-}
-
-tree
-a68_posix_fclose (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_FCLOSE);
-}
-
-tree
-a68_posix_fsize (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_FSIZE);
-}
-
-tree
-a68_posix_lseek (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_LSEEK);
-}
-
-tree
-a68_posix_errno (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_ERRNO);
-}
-
-tree
-a68_posix_exit (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_EXIT);
-}
-
-tree
-a68_posix_perror (void)
-{
-  static tree perror_fndecl;
-
-  if (perror_fndecl == NULL_TREE)
-    {
-      perror_fndecl
-	= a68_low_toplevel_func_decl ("perror",
-				      build_function_type_list (void_type_node,
-								CTYPE (M_STRING),
-								NULL_TREE));
-      announce_function (perror_fndecl);
-
-      tree str = a68_low_func_param (perror_fndecl, "str", CTYPE (M_STRING));
-      DECL_ARGUMENTS (perror_fndecl) = str;
-
-      a68_push_function_range (perror_fndecl, void_type_node,
-			       true /* top_level */);
-
-      tree body = a68_build_libcall (A68_LIBCALL_POSIX_PERROR,
-				     a68_int_type, 3,
-				     a68_multiple_elements (str),
-				     a68_multiple_num_elems (str),
-				     a68_multiple_stride (str, size_zero_node));
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (perror_fndecl)),
-		      perror_fndecl);
-}
-
-tree
-a68_posix_strerror (void)
-{
-  static tree strerror_fndecl;
-
-  if (strerror_fndecl == NULL_TREE)
-    {
-      strerror_fndecl
-	= a68_low_toplevel_func_decl ("strerror",
-				      build_function_type_list (CTYPE (M_STRING),
-								a68_int_type,
-								NULL_TREE));
-      announce_function (strerror_fndecl);
-
-      tree errnum = a68_low_func_param (strerror_fndecl, "errnum", a68_int_type);
-      DECL_ARGUMENTS (strerror_fndecl) = errnum;
-
-      a68_push_function_range (strerror_fndecl, CTYPE (M_STRING),
-			       true /* top_level */);
-
-      tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0));
-      TREE_ADDRESSABLE (len) = 1;
-
-      tree call = a68_build_libcall (A68_LIBCALL_POSIX_STRERROR,
-				     void_type_node, 2,
-				     errnum,
-				     fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), len));
-      tree elems = a68_lower_tmpvar ("elems%", build_pointer_type (a68_char_type), call);
-
-      tree lower_bound = ssize_int (1);
-      tree upper_bound = fold_convert (ssizetype, len);
-      tree elems_size = fold_build2 (MULT_EXPR, sizetype,
-				     len, size_in_bytes (a68_char_type));
-
-      tree body = a68_row_value (CTYPE (M_STRING), 1 /* dim */,
-				 elems, elems_size,
-				 &lower_bound, &upper_bound);
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (strerror_fndecl)),
-		      strerror_fndecl);
-}
-
-tree
-a68_posix_getchar (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_GETCHAR);
-}
-
-tree
-a68_posix_fgetc (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_FGETC);
-}
-
-tree
-a68_posix_fputc (void)
-{
-  return a68_get_libcall (A68_LIBCALL_POSIX_FPUTC);
-}
-
-tree
-a68_posix_fputs (void)
-{
-  static tree fputs_fndecl;
-
-  if (fputs_fndecl == NULL_TREE)
-    {
-      fputs_fndecl
-	= a68_low_toplevel_func_decl ("fputs",
-				      build_function_type_list (a68_int_type,
-								a68_int_type,
-								CTYPE (M_STRING),
-								NULL_TREE));
-      announce_function (fputs_fndecl);
-
-      tree fd = a68_low_func_param (fputs_fndecl, "fd", a68_int_type);
-      tree str = a68_low_func_param (fputs_fndecl, "str", CTYPE (M_STRING));
-      DECL_ARGUMENTS (fputs_fndecl) = chainon (fd, str);
-
-      a68_push_function_range (fputs_fndecl, a68_int_type,
-			       true /* top_level */);
-
-
-      tree body = a68_build_libcall (A68_LIBCALL_POSIX_FPUTS,
-				     a68_int_type, 4,
-				     fd,
-				     a68_multiple_elements (str),
-				     a68_multiple_num_elems (str),
-				     a68_multiple_stride (str, size_zero_node));
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fputs_fndecl)),
-		      fputs_fndecl);
-}
-
-tree
-a68_posix_fgets (void)
-{
-  static tree fgets_fndecl;
-
-  if (fgets_fndecl == NULL_TREE)
-    {
-      fgets_fndecl
-	= a68_low_toplevel_func_decl ("fgets",
-				      build_function_type_list (CTYPE (M_REF_STRING),
-								a68_int_type,
-								a68_int_type,
-								NULL_TREE));
-      announce_function (fgets_fndecl);
-
-      tree fd = a68_low_func_param (fgets_fndecl, "fd", a68_int_type);
-      tree n = a68_low_func_param (fgets_fndecl, "n", a68_int_type);
-      DECL_ARGUMENTS (fgets_fndecl) = chainon (fd, n);
-
-      a68_push_function_range (fgets_fndecl, CTYPE (M_REF_STRING),
-			       true /* top_level */);
-
-      tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0));
-      TREE_ADDRESSABLE (len) = 1;
-
-      tree call = a68_build_libcall (A68_LIBCALL_POSIX_FGETS,
-				     CTYPE (M_REF_STRING), 3,
-				     fd, n,
-				     fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), len));
-      tree elems = a68_lower_tmpvar ("elems%", build_pointer_type (a68_char_type), call);
-
-      tree lower_bound = ssize_int (1);
-      tree upper_bound = fold_convert (ssizetype, len);
-      tree elems_size = fold_build2 (MULT_EXPR, sizetype,
-				     len, size_in_bytes (a68_char_type));
-      tree body = a68_row_malloc (M_STRING, 1 /* dim */,
-				  elems, elems_size,
-				  &lower_bound, &upper_bound);
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (fgets_fndecl)),
-		      fgets_fndecl);
-}
-
-tree
-a68_posix_gets (void)
-{
-  static tree gets_fndecl;
-
-  if (gets_fndecl == NULL_TREE)
-    {
-      gets_fndecl
-	= a68_low_toplevel_func_decl ("gets",
-				      build_function_type_list (CTYPE (M_REF_STRING),
-								a68_int_type,
-								NULL_TREE));
-      announce_function (gets_fndecl);
-
-      tree n = a68_low_func_param (gets_fndecl, "n", a68_int_type);
-      DECL_ARGUMENTS (gets_fndecl) = n;
-
-      a68_push_function_range (gets_fndecl, CTYPE (M_REF_STRING),
-			       true /* top_level */);
-
-      tree len = a68_lower_tmpvar ("len%", sizetype, size_int (0));
-      TREE_ADDRESSABLE (len) = 1;
-
-      tree call = a68_build_libcall (A68_LIBCALL_POSIX_GETS,
-				     CTYPE (M_REF_STRING), 2,
-				     n, fold_build1 (ADDR_EXPR, build_pointer_type (sizetype), len));
-      tree elems = a68_lower_tmpvar ("elems%", build_pointer_type (a68_char_type), call);
-
-      tree lower_bound = ssize_int (1);
-      tree upper_bound = fold_convert (ssizetype, len);
-      tree elems_size = fold_build2 (MULT_EXPR, sizetype,
-				     len, size_in_bytes (a68_char_type));
-      tree body = a68_row_malloc (M_STRING, 1 /* dim */,
-				  elems, elems_size,
-				  &lower_bound, &upper_bound);
-      a68_pop_function_range (body);
-    }
-
-  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (gets_fndecl)),
-		      gets_fndecl);
-}

gcc/algol68/a68-low-prelude.cc

@@ -1923,296 +1923,3 @@ a68_lower_longlongrandom (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UN
 {
   return a68_get_libcall (A68_LIBCALL_LONGLONGRANDOM);
 }
-
-/********* POSIX prelude.  ***************/
-
-tree
-a68_lower_posixargc (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_argc ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixargv (NODE_T *p ATTRIBUTE_UNUSED,
-		     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_argv ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixgetenv (NODE_T *p ATTRIBUTE_UNUSED,
-		       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_getenv ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixputchar (NODE_T *p ATTRIBUTE_UNUSED,
-			LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_putchar ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixputs (NODE_T *p ATTRIBUTE_UNUSED,
-		     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_puts ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixfconnect (NODE_T *p ATTRIBUTE_UNUSED,
-			 LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_fconnect ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixfopen (NODE_T *p ATTRIBUTE_UNUSED,
-		      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_fopen ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixfcreate (NODE_T *p ATTRIBUTE_UNUSED,
-			LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_fcreate ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixfclose (NODE_T *p ATTRIBUTE_UNUSED,
-		       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_fclose ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixfsize (NODE_T *p ATTRIBUTE_UNUSED,
-		      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_fsize ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixlseek (NODE_T *p ATTRIBUTE_UNUSED,
-		      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_lseek ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixseekcur (NODE_T *p ATTRIBUTE_UNUSED,
-			LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  return build_int_cst (a68_int_type, 0);
-}
-
-tree
-a68_lower_posixseekend (NODE_T *p ATTRIBUTE_UNUSED,
-			LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  return build_int_cst (a68_int_type, 1);
-}
-
-tree
-a68_lower_posixseekset (NODE_T *p ATTRIBUTE_UNUSED,
-			LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  return build_int_cst (a68_int_type, 2);
-}
-
-tree
-a68_lower_posixstdinfiledes (NODE_T *p ATTRIBUTE_UNUSED,
-			     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  return build_int_cst (a68_int_type, 0);
-}
-
-tree
-a68_lower_posixstdoutfiledes (NODE_T *p ATTRIBUTE_UNUSED,
-			      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  return build_int_cst (a68_int_type, 1);
-}
-
-tree
-a68_lower_posixstderrfiledes (NODE_T *p ATTRIBUTE_UNUSED,
-			      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  return build_int_cst (a68_int_type, 2);
-}
-
-tree
-a68_lower_posixfileodefault (NODE_T *p ATTRIBUTE_UNUSED,
-			     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  /* Please keep in sync with libga68/ga68-posix.c  */
-  return build_int_cst (a68_bits_type, 0x99999999);
-}
-
-tree
-a68_lower_posixfileordwr (NODE_T *p ATTRIBUTE_UNUSED,
-			  LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  /* Please keep in sync with libga68/ga68-posix.c  */
-  return build_int_cst (a68_bits_type, 0x2);
-}
-
-tree
-a68_lower_posixfileordonly (NODE_T *p ATTRIBUTE_UNUSED,
-			    LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  /* Please keep in sync with libga68/ga68-posix.c  */
-  return build_int_cst (a68_bits_type, 0x0);
-}
-
-tree
-a68_lower_posixfileowronly (NODE_T *p ATTRIBUTE_UNUSED,
-			    LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  /* Please keep in sync with libga68/ga68-posix.c  */
-  return build_int_cst (a68_bits_type, 0x1);
-}
-
-tree
-a68_lower_posixfileotrunc (NODE_T *p ATTRIBUTE_UNUSED,
-			   LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  /* Please keep in sync with libga68/ga68-posix.c  */
-  return build_int_cst (a68_bits_type, 0x8);
-}
-
-tree
-a68_lower_posixerrno (NODE_T *p ATTRIBUTE_UNUSED,
-		      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_errno ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixexit (NODE_T *p ATTRIBUTE_UNUSED,
-		     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_exit ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixperror (NODE_T *p ATTRIBUTE_UNUSED,
-		       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_perror ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixstrerror (NODE_T *p ATTRIBUTE_UNUSED,
-			 LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_strerror ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixfputc (NODE_T *p ATTRIBUTE_UNUSED,
-		      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_fputc ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixfputs (NODE_T *p ATTRIBUTE_UNUSED,
-		      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_fputs ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixgetchar (NODE_T *p ATTRIBUTE_UNUSED,
-			LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_getchar ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-
-tree
-a68_lower_posixfgetc (NODE_T *p ATTRIBUTE_UNUSED,
-		      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_fgetc ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixgets (NODE_T *p ATTRIBUTE_UNUSED,
-		     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_gets ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}
-
-tree
-a68_lower_posixfgets (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
-{
-  tree t = a68_posix_fgets ();
-  if (CAN_HAVE_LOCATION_P (t))
-    SET_EXPR_LOCATION (t, a68_get_node_location (p));
-  return t;
-}

gcc/algol68/a68-low-runtime.def

@@ -61,27 +61,6 @@ DEF_A68_RUNTIME (ARRAYDIM, "_libga68_dim", RT(VOID),
 DEF_A68_RUNTIME (RANDOM, "_libga68_random", RT(FLOAT), P0(), 0)
 DEF_A68_RUNTIME (LONGRANDOM, "_libga68_longrandom", RT(DOUBLE), P0(), 0)
 DEF_A68_RUNTIME (LONGLONGRANDOM, "_libga68_longlongrandom", RT(LONGDOUBLE), P0(), 0)
-DEF_A68_RUNTIME (POSIX_FCONNECT, "_libga68_posixfconnect", RT(INT), P4(UNISTRPTR,SIZE,SIZE,INT), 0)
-DEF_A68_RUNTIME (POSIX_FOPEN, "_libga68_posixfopen", RT(INT), P4(UNISTRPTR,SIZE,SIZE,UINT), 0)
-DEF_A68_RUNTIME (POSIX_FCREATE, "_libga68_posixcreat", RT(INT), P4(UNISTRPTR,SIZE,SIZE,UINT), 0)
-DEF_A68_RUNTIME (POSIX_FCLOSE, "_libga68_posixclose", RT(INT), P0(), 0)
-DEF_A68_RUNTIME (POSIX_FSIZE, "_libga68_posixfsize", RT(LONGLONGINT), P1(INT), 0)
-DEF_A68_RUNTIME (POSIX_ARGC, "_libga68_posixargc", RT(INT), P0(), 0)
-DEF_A68_RUNTIME (POSIX_ARGV, "_libga68_posixargv", RT(UNISTRPTR), P2(INT, SIZEPTR), 0)
-DEF_A68_RUNTIME (POSIX_PUTCHAR, "_libga68_posixputchar", RT(CHAR), P1(CHAR), 0)
-DEF_A68_RUNTIME (POSIX_FPUTC, "_libga68_posixfputc", RT(CHAR), P2(INT,CHAR), 0)
-DEF_A68_RUNTIME (POSIX_PUTS, "_libga68_posixputs", RT(VOID), P3(UNISTR,SIZE,SIZE), 0)
-DEF_A68_RUNTIME (POSIX_FPUTS, "_libga68_posixfputs", RT(INT), P4(INT,UNISTRPTR,SIZE,SIZE), 0)
-DEF_A68_RUNTIME (POSIX_GETCHAR, "_libga68_posixgetchar", RT(CHAR), P0(), 0)
-DEF_A68_RUNTIME (POSIX_FGETC, "_libga68_posixfgetc", RT(CHAR), P1(INT), 0)
-DEF_A68_RUNTIME (POSIX_GETS, "_libga68_posixgets", RT(UNISTRPTR), P2(INT,SIZEPTR), 0)
-DEF_A68_RUNTIME (POSIX_FGETS, "_libga68_posixfgets", RT(UNISTRPTR), P3(INT,INT,SIZEPTR), 0)
-DEF_A68_RUNTIME (POSIX_GETENV, "_libga68_posixgetenv", RT(VOID), P5(UNISTR,SIZE,SIZE,UNISTRPTR,SIZEPTR), 0)
-DEF_A68_RUNTIME (POSIX_ERRNO, "_libga68_posixerrno", RT(INT), P0(), 0)
-DEF_A68_RUNTIME (POSIX_EXIT, "_libga68_posixexit", RT(VOID), P1(INT), 0)
-DEF_A68_RUNTIME (POSIX_PERROR, "_libga68_posixperror", RT(VOID), P3(UNISTR,SIZE,SIZE), 0)
-DEF_A68_RUNTIME (POSIX_STRERROR, "_libga68_posixstrerror", RT(UNISTRPTR), P2(INT, SIZEPTR), 0)
-DEF_A68_RUNTIME (POSIX_LSEEK, "_libga68_posixlseek", RT(LONGLONGINT), P3(INT,LONGLONGINT,INT), 0)
 DEF_A68_RUNTIME (U32_CMP2, "_libga68_u32_cmp2", RT(INT), P6(UNISTR, SIZE, SIZE, UNISTR, SIZE, SIZE), 0)
 
 #undef P0

gcc/algol68/a68-low-units.cc

@@ -54,11 +54,12 @@
 tree
 a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx)
 {
-  if (TAG_TABLE (TAX (p)) == A68_STANDENV)
+  LOWERER_T lowerer = LOWERER (TAX (p));
+
+  if (lowerer != NO_LOWERER)
     {
       /* This identifier is defined in the standard prelude.  Use its lowering
 	 handler.  */
-      LOWERER_T lowerer = LOWERER (TAX (p));
       return (*lowerer) (p, ctx);
     }
   else
@@ -551,22 +552,25 @@ lower_subscript_for_trimmers (NODE_T *p, LOW_CTX_T ctx,
 		  {
 		    /* Lower bound is implicit.  */
 		    FORWARD (q);
-		    if (IS (q, AT_SYMBOL))
+		    if (q != NO_NODE)
 		      {
-			/* Upper bound is implicit, AT specified.  */
-			gcc_assert (IS (q, AT_SYMBOL));
-			at = save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx)));
-		      }
-		    else
-		      {
-			upper_bound
-			  = save_expr (fold_convert (ssizetype, a68_lower_tree (q, ctx)));
-			FORWARD (q);
-			if (q != NO_NODE)
+			if (IS (q, AT_SYMBOL))
 			  {
+			    /* Upper bound is implicit, AT specified.  */
 			    gcc_assert (IS (q, AT_SYMBOL));
 			    at = save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx)));
 			  }
+			else
+			  {
+			    upper_bound
+			      = save_expr (fold_convert (ssizetype, a68_lower_tree (q, ctx)));
+			    FORWARD (q);
+			    if (q != NO_NODE)
+			      {
+				gcc_assert (IS (q, AT_SYMBOL));
+				at = save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx)));
+			      }
+			  }
 		      }
 		  }
 		else
@@ -959,11 +963,12 @@ a68_lower_formula (NODE_T *p, LOW_CTX_T ctx)
     return a68_lower_tree (SUB (p), ctx);
   else
     {
+      LOWERER_T lowerer = LOWERER (TAX (NEXT (SUB (p))));
+
       /* If the operator is defined in the standard prelude, then use its lowering
 	 code.  */
-      if (TAG_TABLE (TAX (NEXT (SUB (p)))) == A68_STANDENV)
+      if (lowerer != NO_LOWERER)
 	{
-	  LOWERER_T lowerer = LOWERER (TAX (NEXT (SUB (p))));
 	  return (*lowerer) (p, ctx);
 	}
       else
@@ -991,11 +996,12 @@ a68_lower_formula (NODE_T *p, LOW_CTX_T ctx)
 tree
 a68_lower_monadic_formula (NODE_T *p, LOW_CTX_T ctx)
 {
+  LOWERER_T lowerer = LOWERER (TAX (SUB (p)));
+
   /* If the operator is defined in the standard prelude, then use its lowering
      code.  */
-  if (TAG_TABLE (TAX (SUB (p))) == A68_STANDENV)
+  if (lowerer != NO_LOWERER)
     {
-      LOWERER_T lowerer = LOWERER (TAX (SUB (p)));
       return (*lowerer) (p, ctx);
     }
   else

gcc/algol68/a68-low.cc

@@ -39,6 +39,7 @@
 #include "gimplify.h"
 #include "dumpfile.h"
 #include "convert.h"
+#include "options.h"
 
 #include "a68.h"
 
@@ -631,31 +632,34 @@ a68_make_variable_declaration_decl (NODE_T *identifier,
   return decl;
 }
 
-/* Make an extern declaration for a formal hole.  */
+/* Make an extern declaration for a formal hole.
+
+   If ADDRP is true then it is the address of the external symbol we are
+   interested in.  In that case the mode of P shall be a ref.
+   
+   Note that this function is not used for formal holes with proc modes, called
+   from a68_wrap_formal_var_hole.  See a68_wrap_formal_proc_hole.  */
 
 tree
-a68_make_formal_hole_decl (NODE_T *p, const char *extern_symbol)
+a68_make_formal_hole_decl (NODE_T *p, const char *extern_symbol,
+			   bool addrp)
 {
-  /* The CTYPE of MODE is a pointer to a function.  We need the pointed
-     function type for the FUNCTION_DECL.  */
-  tree type = (IS (MOID (p), PROC_SYMBOL)
-	       ? TREE_TYPE (CTYPE (MOID (p)))
-	       : CTYPE (MOID (p)));
-
-  const char *sym = (strlen (extern_symbol) > 0 && extern_symbol[0] == '&'
-		     ? extern_symbol + 1
-		     : extern_symbol);
+  gcc_assert (!IS (MOID (p), PROC_SYMBOL));
 
+  tree type = CTYPE (MOID (p));
   tree decl = build_decl (a68_get_node_location (p),
 			  VAR_DECL,
-			  get_identifier (sym),
+			  get_identifier (extern_symbol),
 			  type);
   DECL_EXTERNAL (decl) = 1;
   TREE_PUBLIC (decl) = 1;
   DECL_INITIAL (decl) = a68_get_skip_tree (MOID (p));
 
-  if (extern_symbol[0] == '&')
-    decl = fold_build1 (ADDR_EXPR, type, decl);
+  if (addrp)
+    {
+      gcc_assert (IS_REF (MOID (p)));
+      decl = fold_build1 (ADDR_EXPR, type, decl);
+    }
   return decl;
 }
 
@@ -1246,6 +1250,23 @@ lower_revelations (NODE_T *p, LOW_CTX_T ctx, bool prelude)
   return NULL_TREE;
 }
 
+/* Lower the declaration of a prelude or postlude.  */
+
+static tree
+lower_lude_decl (const char *module, bool postludep)
+{
+  char *symbol = xasprintf ("%s__%s",
+			    module,
+			    postludep ? "postlude" : "prelude");
+  tree fdecl = build_decl (UNKNOWN_LOCATION, FUNCTION_DECL,
+			   get_identifier (symbol),
+			   build_function_type (void_type_node, void_list_node));
+  free (symbol);
+  DECL_EXTERNAL (fdecl) = 1;
+  TREE_PUBLIC (fdecl) = 1;
+  return fdecl;
+}
+
 /* Lower a module text.
 
      module text : revelation part, def part, postlude part, fed symbol ;
@@ -1318,6 +1339,15 @@ lower_module_text (NODE_T *p, LOW_CTX_T ctx)
     {
       a68_push_stmt_list (NULL);
       {
+	if (!flag_building_libga68)
+	  {
+	    /* Add calls to implicitly accessed standard preludes.  */
+	    tree standard_prelude = lower_lude_decl ("STANDARD", false);
+	    tree posix_prelude = lower_lude_decl ("POSIX", false);
+	    a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, standard_prelude, 0));
+	    a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, posix_prelude, 0));
+	  }
+
 	/* Add calls to preludes of modules in REVELATION_PART.  */
 	lower_revelations (revelation_part, ctx, true /* prelude */);
 	a68_add_stmt (a68_lower_tree (prelude_enquiry, ctx));
@@ -1367,14 +1397,24 @@ lower_module_text (NODE_T *p, LOW_CTX_T ctx)
     {
       a68_push_stmt_list (NULL);
       {
-	/* Add calls to postludes of modules in REVELATION_PART.  */
-	lower_revelations (revelation_part, ctx, false /* prelude */);
 	/* Perhaps the postlude code, if there is one.  */
 	NODE_T *postlude_serial = NO_NODE;
 	if (postlude_part != NO_NODE)
 	  postlude_serial = NEXT_SUB (postlude_part);
 	if (postlude_serial != NO_NODE)
 	  a68_add_stmt (a68_lower_tree (postlude_serial, ctx));
+
+	/* Add calls to postludes of modules in REVELATION_PART.  */
+	lower_revelations (revelation_part, ctx, false /* prelude */);
+
+	if (!flag_building_libga68)
+	  {
+	    /* Add calls to implicitly accessed standard postludes.  */
+	    tree standard_postlude = lower_lude_decl ("STANDARD", true);
+	    tree posix_postlude = lower_lude_decl ("POSIX", true);
+	    a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, posix_postlude, 0));
+	    a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, standard_postlude, 0));
+	  }
       }
       tree do_postlude = a68_pop_stmt_list ();
 
@@ -1473,10 +1513,24 @@ lower_particular_program (NODE_T *p, LOW_CTX_T ctx)
 			   void_type_node /* result_type */);
 
   /* Lower the body of the function.  */
+
+  tree standard_prelude = lower_lude_decl ("STANDARD", false);
+  tree standard_postlude = lower_lude_decl ("STANDARD", true);
+  tree posix_prelude = lower_lude_decl ("POSIX", false);
+  tree posix_postlude = lower_lude_decl ("POSIX", true);
+
   NODE_T *enclosed_clause = (IS (SUB (p), ENCLOSED_CLAUSE)
 			     ? SUB (p) : NEXT (SUB (p)));
-  tree body_expr = a68_lower_tree (enclosed_clause, ctx);
-  a68_pop_function_range (body_expr);
+
+  a68_push_range (M_VOID);
+  a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, standard_prelude, 0));
+  a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, posix_prelude, 0));
+  a68_add_stmt (a68_lower_tree (enclosed_clause, ctx));
+  a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, posix_postlude, 0));
+  a68_add_stmt (build_call_expr_loc (UNKNOWN_LOCATION, standard_postlude, 0));
+
+  tree body = a68_pop_range ();
+  a68_pop_function_range (body);
   return NULL_TREE;
 }
 

gcc/algol68/a68-moids-diagnostics.cc

@@ -25,6 +25,9 @@
 #include "options.h"
 
 #include "a68.h"
+#include "a68-pretty-print.h"
+
+#include <string>
 
 /* Give accurate error message.  */
 
@@ -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);
 }

gcc/algol68/a68-moids-misc.cc

@@ -1207,7 +1207,11 @@ a68_is_c_mode (MOID_T *m, int level)
     return a68_is_c_mode (SUB (m), level + 1);
   else if (IS (m, PROC_SYMBOL))
     {
-      bool yielded_mode_valid = a68_is_c_mode (SUB (m));
+      bool yielded_mode_valid =
+	((level == 0
+	  && (SUB (m) == M_STRING
+	      || (IS_REF (SUB (m)) && SUB (SUB (m)) == M_STRING)))
+	 || a68_is_c_mode (SUB (m), level + 1));
       bool params_valid = true;
 
       for (PACK_T *z = PACK (m); z != NO_PACK; FORWARD (z))

gcc/algol68/a68-parser-bottom-up.cc

@@ -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);
+		    }
 		}
 	    }
 	}
@@ -1868,7 +1875,7 @@ reduce_formal_holes (NODE_T *p)
 		       && IS (SUB (SUB (SUB (s))), DENOTATION)
 		       && IS (SUB (SUB (SUB (SUB (s)))), ROW_CHAR_DENOTATION)))
 		{
-		  a68_error (s, "expected row char denotation");
+		  a68_error (s, "expected %<row char%> denotation");
 		}
 	    }
 	}
@@ -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,

gcc/algol68/a68-parser-brackets.cc

@@ -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");
     }
 }

gcc/algol68/a68-parser-extract.cc

@@ -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;
@@ -197,19 +207,30 @@ skip_pack_declarer (NODE_T *p)
     return p;
 }
 
-/* Extract the revelation associated with the module MODULE.  The node Q is
-   used for symbol table and diagnostic purposes.  Publicized modules are
-   recursively extracted as well.  This call may result in one or more
-   errors.  */
+/* Extract the revelation associated with the module MODULE.
 
-static void
-extract_revelation (NODE_T *q, const char *module, TAG_T *tag)
+   The node Q is used for symbol table and diagnostic purposes
+
+   Publicized modules are recursively extracted as well.  This call may result
+   in one or more errors.
+
+   If FILENAME is not NULL then the module exports are looked in
+   libFILENAME.so, FILENAME.o, etc.  If it is NULL, the filename is derived
+   from the module name.
+
+   This function is visible externally because it is used to extract
+   revelations of modules distributed as part of libga68, in
+   a68-parser-prelude.cc */
+
+void
+a68_extract_revelation (NODE_T *q, const char *module, const char *filename,
+			TAG_T *tag)
 {
   /* Import the MOIF and install it in the tag.  */
-  MOIF_T *moif = a68_open_packet (module);
+  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;
     }
 
@@ -246,7 +267,7 @@ extract_revelation (NODE_T *q, const char *module, TAG_T *tag)
      extract_revelation calls is properly done.  */
 
   for (EXTRACT_T *e : MODULES (moif))
-    extract_revelation (q, EXTRACT_SYMBOL (e), NO_TAG);
+    a68_extract_revelation (q, EXTRACT_SYMBOL (e), filename, NO_TAG);
 
   /* Store mode indicants from the MOIF in the symbol table,
      and also in the moid list.  */
@@ -267,6 +288,7 @@ extract_revelation (NODE_T *q, const char *module, TAG_T *tag)
       /* INDICANT node.  */
       NODE_T *n = a68_some_node (a68_demangle_symbol (NAME (moif),
 						      EXTRACT_SYMBOL (e)));
+      MOID (n) = EXTRACT_MODE (e);
       /* EQUALS_SYMBOL node.  */
       NEXT (n) = a68_some_node ("=");
       ATTRIBUTE (NEXT (n)) = EQUALS_SYMBOL;
@@ -351,6 +373,21 @@ extract_revelation (NODE_T *q, const char *module, TAG_T *tag)
     }
 }
 
+/* This version of a68_extract_revelation gets a symbol table and line info
+   rather than a node.  It is used to extract revelations from standard modules
+   distributed in the run-time library.  See a68-parser-prelude.cc */
+
+void
+a68_extract_revelation (TABLE_T *t, LINE_T *l,
+			const char *module, const char *filename,
+			TAG_T *tag)
+{
+  NODE_T *q = a68_some_node ("");
+  TABLE (q) = t;
+  LINE (INFO (q)) = l;
+  a68_extract_revelation (q, module, filename, tag);
+}
+
 /* Search [MODE|MODULE] A = .., B = ..
    and    ACCESS A, B, ..
    and store indicants.  */
@@ -389,7 +426,8 @@ a68_extract_indicants (NODE_T *p)
 		    {
 		      TAG_T *tag = a68_add_tag (TABLE (bold_tag), MODULE_SYMBOL, bold_tag, NO_MOID, STOP);
 		      gcc_assert (tag != NO_TAG);
-		      extract_revelation (bold_tag, NSYMBOL (bold_tag), tag);
+		      a68_extract_revelation (bold_tag, NSYMBOL (bold_tag),
+					      NULL /* filename */, tag);
 		    }
 		}
 	    }
@@ -577,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);
@@ -694,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);
@@ -1007,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;
 	    }
 	}

gcc/algol68/a68-parser-modes.cc

@@ -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);
+	    }
 	}
     }
 

gcc/algol68/a68-parser-moids-check.cc

@@ -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)))

gcc/algol68/a68-parser-pragmat.cc

@@ -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;
 	    }
 	}

gcc/algol68/a68-parser-prelude.cc

@@ -22,6 +22,7 @@
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"
+#include "options.h"
 
 #include "a68.h"
 
@@ -48,7 +49,7 @@
 
 static void
 add_a68_standenv (bool portable, int a, NODE_T* n, char *c, MOID_T *m,
-		  int p, LOWERER_T l = NO_LOWERER)
+		  int p, LOWERER_T l = LOWERER_UNIMPL)
 {
 #define INSERT_TAG(l, n) \
   do {			 \
@@ -119,7 +120,7 @@ a68_proc (MOID_T *m, ...)
 /* Enter an identifier in standenv.  */
 
 static void
-a68_idf (bool portable, const char *n, MOID_T *m, LOWERER_T l = NO_LOWERER)
+a68_idf (bool portable, const char *n, MOID_T *m, LOWERER_T l = LOWERER_UNIMPL)
 {
   add_a68_standenv (portable, IDENTIFIER,
 		    a68_some_node (TEXT (a68_add_token (&A68 (top_token), n))),
@@ -144,13 +145,13 @@ a68_prio (const char *p, int b)
 {
   add_a68_standenv (true, PRIO_SYMBOL,
 		    a68_some_node (TEXT (a68_add_token (&A68 (top_token), p))),
-		    NO_TEXT, NO_MOID, b, NO_LOWERER);
+		    NO_TEXT, NO_MOID, b, LOWERER_UNIMPL);
 }
 
 /* Enter operator in standenv.  */
 
 static void
-a68_op (bool portable, const char *n, MOID_T *m, LOWERER_T l = NO_LOWERER)
+a68_op (bool portable, const char *n, MOID_T *m, LOWERER_T l = LOWERER_UNIMPL)
 {
   add_a68_standenv (portable, OP_SYMBOL,
 		    a68_some_node (TEXT (a68_add_token (&A68 (top_token), n))),
@@ -413,23 +414,8 @@ stand_prelude (void)
   a68_idf (A68_STD, "errorchar", M_CHAR, a68_lower_errorchar);
   a68_idf (A68_STD, "nullcharacter", M_CHAR, a68_lower_nullcharacter);
   a68_idf (A68_STD, "blank", M_CHAR, a68_lower_blank);
-  /* BITS procedures.  */
-  MOID_T *m = a68_proc (M_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "bitspack", m);
-  /* SHORT BITS procedures.  */
-  m = a68_proc (M_SHORT_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "shortbitspack", m);
-  /* SHORT SHORT BITS procedures.  */
-  m = a68_proc (M_SHORT_SHORT_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "shortshortbitspack", m);
-  /* LONG BITS procedures.  */
-  m = a68_proc (M_LONG_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "longbitspack", m);
-  /* LONG LONG BITS procedures.  */
-  m = a68_proc (M_LONG_LONG_BITS, M_ROW_BOOL, NO_MOID);
-  a68_idf (A68_STD, "longlongbitspack", m);
   /* RNG procedures.  */
-  m = a68_proc (M_VOID, M_INT, NO_MOID);
+  MOID_T *m = a68_proc (M_VOID, M_INT, NO_MOID);
   a68_idf (A68_STD, "firstrandom", m);
   /* REAL procedures.  */
   m = A68_MCACHE (proc_real);
@@ -1305,6 +1291,22 @@ stand_prelude (void)
   m = a68_proc (M_VOID, M_SEMA, NO_MOID);
   a68_op (A68_STD, "UP", m);
   a68_op (A68_STD, "DOWN", m);
+
+
+  /* Load Algol 68 parts.  */
+  if (!flag_building_libga68)
+    a68_extract_revelation (A68_STANDENV, LINE (INFO (TOP_NODE (&A68_JOB))),
+			    "STANDARD", "ga68");
+}
+
+/* Transput.  */
+
+static void
+stand_transput (void)
+{
+  //  if (!flag_building_libga68)
+  //    a68_extract_revelation (A68_STANDENV, LINE (INFO (TOP_NODE (&A68_JOB))),
+  //                            "TRANSPUT", "ga68");
 }
 
 /* GNU extensions for the standenv.  */
@@ -1404,83 +1406,11 @@ gnu_prelude (void)
 static void
 posix_prelude (void)
 {
-  MOID_T *m = NO_MOID;
-
-  /* Environment variables.  */
-  m = a68_proc (M_STRING, M_STRING, NO_MOID);
-  a68_idf (A68_EXT, "getenv", m, a68_lower_posixgetenv);
-  /* Exit status handling.  */
-  m = a68_proc (M_VOID, M_INT, NO_MOID);
-  a68_idf (A68_EXT, "posixexit", m, a68_lower_posixexit);
-  /* Argument handling.  */
-  m = A68_MCACHE (proc_int);
-  a68_idf (A68_EXT, "argc", m, a68_lower_posixargc);
-  m = a68_proc (M_STRING, M_INT, NO_MOID);
-  a68_idf (A68_EXT, "argv", m, a68_lower_posixargv);
-  /* Error procedures.  */
-  m = A68_MCACHE (proc_int);
-  a68_idf (A68_EXT, "errno", m, a68_lower_posixerrno);
-  m = a68_proc (M_VOID, M_STRING, NO_MOID);
-  a68_idf (A68_EXT, "perror", m, a68_lower_posixperror);
-  m = a68_proc (M_STRING, M_INT, NO_MOID);
-  a68_idf (A68_EXT, "strerror", m, a68_lower_posixstrerror);
-  /* I/O identifiers.  */
-  a68_idf (A68_EXT, "stdin", M_INT, a68_lower_posixstdinfiledes);
-  a68_idf (A68_EXT, "stdout", M_INT, a68_lower_posixstdoutfiledes);
-  a68_idf (A68_EXT, "stderr", M_INT, a68_lower_posixstderrfiledes);
-  a68_idf (A68_EXT, "fileodefault", M_BITS, a68_lower_posixfileodefault);
-  a68_idf (A68_EXT, "fileordwr", M_BITS, a68_lower_posixfileordwr);
-  a68_idf (A68_EXT, "fileordonly", M_BITS, a68_lower_posixfileordonly);
-  a68_idf (A68_EXT, "fileowronly", M_BITS, a68_lower_posixfileowronly);
-  a68_idf (A68_EXT, "fileotrunc", M_BITS, a68_lower_posixfileotrunc);
-  /* Opening and closing files.  */
-  m = a68_proc (M_INT, M_STRING, M_BITS, NO_MOID);
-  a68_idf (A68_EXT, "fopen", m, a68_lower_posixfopen);
-  a68_idf (A68_EXT, "fcreate", m, a68_lower_posixfcreate);
-  m = A68_MCACHE (proc_int_int);
-  a68_idf (A68_EXT, "fclose", m, a68_lower_posixfclose);
-  /* Getting properties of files.  */
-  m = a68_proc (M_LONG_LONG_INT, M_INT, NO_MOID);
-  a68_idf (A68_EXT, "fsize", m, a68_lower_posixfsize);
-  m = a68_proc (M_LONG_LONG_INT, M_INT, M_LONG_LONG_INT, M_INT, NO_MOID);
-  a68_idf (A68_EXT, "lseek", m, a68_lower_posixlseek);
-  a68_idf (A68_EXT, "seekcur", M_INT, a68_lower_posixseekcur);
-  a68_idf (A68_EXT, "seekend", M_INT, a68_lower_posixseekend);
-  a68_idf (A68_EXT, "seekset", M_INT, a68_lower_posixseekset);
-  /* Sockets.  */
-  m = a68_proc (M_INT, M_STRING, M_INT, NO_MOID);
-  a68_idf (A68_EXT, "fconnect", m, a68_lower_posixfconnect);
-  /* String and character output.  */
-  m = a68_proc (M_CHAR, M_CHAR, NO_MOID);
-  a68_idf (A68_EXT, "putchar", m, a68_lower_posixputchar);
-  m = a68_proc (M_VOID, M_STRING, NO_MOID);
-  a68_idf (A68_EXT, "puts", m, a68_lower_posixputs);
-  m = a68_proc (M_CHAR, M_INT, M_CHAR, NO_MOID);
-  a68_idf (A68_EXT, "fputc", m, a68_lower_posixfputc);
-  m = a68_proc (M_INT, M_INT, M_STRING, NO_MOID);
-  a68_idf (A68_EXT, "fputs", m, a68_lower_posixfputs);
-  /* String and character input.  */
-  m = A68_MCACHE (proc_char);
-  a68_idf (A68_EXT, "getchar", m, a68_lower_posixgetchar);
-  m = a68_proc (M_CHAR, M_INT, NO_MOID);
-  a68_idf (A68_EXT, "fgetc", m, a68_lower_posixfgetc);
-  m = a68_proc (M_REF_STRING, M_INT, NO_MOID);
-  a68_idf (A68_EXT, "gets", m, a68_lower_posixgets);
-  m = a68_proc (M_REF_STRING, M_INT, M_INT, NO_MOID);
-  a68_idf (A68_EXT, "fgets", m, a68_lower_posixfgets);
+  if (!flag_building_libga68)
+    a68_extract_revelation (A68_STANDENV, LINE (INFO (TOP_NODE (&A68_JOB))),
+			    "POSIX", "ga68");
 }
 
-/* Transput.  */
-
-static void
-stand_transput (void)
-{
-  /* Most of the standard transput is implemented in Algol 68 and doesn't
-     require compiler support.  See libga68/transput.a68.in */
-}
-
-/* Build the standard environ symbol table.  */
-
 void
 a68_make_standard_environ (void)
 {

gcc/algol68/a68-parser-scanner.cc

@@ -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.  */

gcc/algol68/a68-parser-scope.cc

@@ -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));
     }
 }

gcc/algol68/a68-parser-taxes.cc

@@ -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
@@ -585,23 +589,25 @@ test_firmly_related_ops_local (NODE_T *p, TAG_T *s)
 			  && warn_algol68_hidden_declarations > 0)
 			{
 			  if (a68_warning (p, OPT_Whidden_declarations_,
-					   "Z hides a firmly related operator in a larger reach",
+					   "%qs hides a firmly related operator in a larger reach",
 					   NSYMBOL (NODE (s))))
 			    {
+			      a68_moid_format_token m (MOID (t));
 			      a68_inform (NO_NODE,
-					  "operator M Z defined in the standard prelude",
-					  MOID (t), NSYMBOL (NODE (t)));
+					  "operator %e %qs defined in the standard prelude",
+					  &m, NSYMBOL (NODE (t)));
 			    }
 			}
 		      else if (warn_algol68_hidden_declarations > 1)
 			{
 			  if (a68_warning (p, OPT_Whidden_declarations_,
-					   "Z hides a firmly related operator in a larger reach",
+					   "%qs hides a firmly related operator in a larger reach",
 					   NSYMBOL (NODE (s))))
 			    {
+			      a68_symbol_format_token s1 (NODE (s));
 			      a68_inform (NODE (t),
-					  "previous hidden declaration of S declared here",
-					  NSYMBOL (NODE (s)));
+					  "previous hidden declaration of %e declared here",
+					  &s1);
 			    }
 			}
 
@@ -659,7 +665,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 +674,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));
 
@@ -677,16 +683,19 @@ already_declared_hidden (NODE_T *n, int a)
 	  || (TAG_TABLE (s) != A68_STANDENV && warn_algol68_hidden_declarations > 1)))
     {
       if (a68_warning (n, OPT_Whidden_declarations_,
-		       "Z hides a declaration with larger reach",
+		       "%qs hides a declaration with larger reach",
 		       NSYMBOL (n)))
 	{
 	  if (TAG_TABLE (s) == A68_STANDENV)
-	    a68_inform (NO_NODE,
-			"M Z defined in the standard prelude",
-			MOID (s), NSYMBOL (NODE (s)));
+	    {
+	      a68_moid_format_token m (MOID (s));
+	      a68_inform (NO_NODE,
+			  "%e %qs defined in the standard prelude",
+			  &m, NSYMBOL (NODE (s)));
+	    }
 	  else
 	    a68_inform (NODE (s),
-			"previous hidden declaration of S declared here",
+			"previous hidden declaration of %qs declared here",
 			NSYMBOL (n));
 	}
     }
@@ -1108,17 +1117,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 +1752,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 +1804,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;

gcc/algol68/a68-parser-top-down.cc

@@ -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);
     }
 }

gcc/algol68/a68-parser-victal.cc

@@ -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));
     }
 }

gcc/algol68/a68-pretty-print.h

@@ -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__ */

gcc/algol68/a68-types.h

@@ -151,7 +151,8 @@ typedef struct LOW_CTX_T LOW_CTX_T;
 /* Type of the lowerer routines defined in a68-low-prelude.cc.  */
 typedef tree (*LOWERER_T) (struct NODE_T *, struct LOW_CTX_T);
 
-#define NO_LOWERER a68_lower_unimplemented
+#define NO_LOWERER NULL
+#define LOWERER_UNIMPL a68_lower_unimplemented
 
 struct GTY((chain_next ("%h.more"), chain_prev ("%h.less"))) KEYWORD_T
 {

gcc/algol68/a68.h

@@ -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  */
 
@@ -338,6 +338,10 @@ void a68_extract_operators (NODE_T *p);
 void a68_extract_labels (NODE_T *p, int expect);
 void a68_extract_declarations (NODE_T *p);
 void a68_elaborate_bold_tags (NODE_T *p);
+void a68_extract_revelation (NODE_T *q, const char *module,
+			     const char *filename, TAG_T *tag = NO_TAG);
+void a68_extract_revelation (TABLE_T *t, LINE_T *l, const char *module,
+			     const char *filename, TAG_T *tag = NO_TAG);
 
 /* a68-parser-keywords.cc  */
 
@@ -584,30 +588,6 @@ tree a68_complex_im (tree z);
 tree a68_complex_conj (MOID_T *mode, tree z);
 tree a68_complex_widen_from_real (MOID_T *mode, tree r);
 
-/* a68-low-posix.cc  */
-
-tree a68_posix_argc (void);
-tree a68_posix_argv (void);
-tree a68_posix_getenv (void);
-tree a68_posix_putchar (void);
-tree a68_posix_puts (void);
-tree a68_posix_fconnect (void);
-tree a68_posix_fcreate (void);
-tree a68_posix_fopen (void);
-tree a68_posix_fclose (void);
-tree a68_posix_fsize (void);
-tree a68_posix_lseek (void);
-tree a68_posix_errno (void);
-tree a68_posix_exit (void);
-tree a68_posix_perror (void);
-tree a68_posix_strerror (void);
-tree a68_posix_getchar (void);
-tree a68_posix_fgetc (void);
-tree a68_posix_fputc (void);
-tree a68_posix_fputs (void);
-tree a68_posix_gets (void);
-tree a68_posix_fgets (void);
-
 /* a68-low-reals.cc  */
 
 tree a68_get_real_skip_tree (MOID_T *m);
@@ -818,7 +798,7 @@ tree a68_make_variable_declaration_decl (NODE_T *identifier, const char *module_
 tree a68_make_proc_identity_declaration_decl (NODE_T *identifier, const char *module_name = NULL,
 					      bool indicant = false, bool external = false,
 					      const char *extern_symbol = NULL);
-tree a68_make_formal_hole_decl (NODE_T *p, const char *extern_symbol);
+tree a68_make_formal_hole_decl (NODE_T *p, const char *extern_symbol, bool addrp);
 tree a68_make_anonymous_routine_decl (MOID_T *mode);
 tree a68_get_skip_tree (MOID_T *m);
 tree a68_get_empty (void);
@@ -1085,38 +1065,6 @@ tree a68_lower_longlongrandom (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_set3 (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_clear3 (NODE_T *p, LOW_CTX_T ctx);
 tree a68_lower_test3 (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixargc (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixargv (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixputchar (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixputs (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfputc (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfputs (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixgetenv (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfconnect (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfopen (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfcreate (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfclose (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfsize (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixlseek (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixseekcur (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixseekend (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixseekset (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixstdinfiledes (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixstdoutfiledes (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixstderrfiledes (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfileodefault (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfileordwr (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfileordonly (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfileowronly (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfileotrunc (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixerrno (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixexit (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixperror (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixstrerror (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixgetchar (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfgetc (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixgets (NODE_T *p, LOW_CTX_T ctx);
-tree a68_lower_posixfgets (NODE_T *p, LOW_CTX_T ctx);
 
 /* a68-exports.cc  */
 
@@ -1126,8 +1074,15 @@ void a68_do_exports (NODE_T *p);
 
 /* a68-imports.cc  */
 
-MOIF_T *a68_open_packet (const char *module);
+MOIF_T *a68_open_packet (const char *module, const char *filename = NULL);
 bool a68_process_module_map (const char *map, const char **errmsg);
+char *a68_find_object_export_data (const std::string &filename,
+				   int fd, off_t offset, size_t *size);
+
+/* a68-imports-archive.cc  */
+
+bool a68_is_archive_magic (const char *bytes);
+char *a68_find_archive_export_data (const char *filename, int fd, size_t *size);
 
 /* a68-parser-debug.cc  */
 

gcc/algol68/lang.opt

@@ -80,6 +80,9 @@ fcheck=
 Algol68 RejectNegative JoinedOrMissing
 -fcheck=[...]	Specify which runtime checks are to be performed.
 
+fbuilding-libga68
+Algol68 Undocumented Var(flag_building_libga68)
+
 fa68-dump-modes
 Algol68 Var(flag_a68_dump_modes)
 Dump Algol 68 modes after parsing.

gcc/config/riscv/riscv.cc

@@ -15008,8 +15008,8 @@ riscv_same_function_versions (string_slice v1, const_tree, string_slice v2,
 
   /* Invalid features should have already been rejected by this point so
      providing no location should be okay.  */
-  parse_features_for_version (v1, UNKNOWN_LOCATION, mask1, prio1);
-  parse_features_for_version (v2, UNKNOWN_LOCATION, mask2, prio2);
+  parse_features_for_version (v1, nullptr, mask1, prio1);
+  parse_features_for_version (v2, nullptr, mask2, prio2);
 
   return compare_fmv_features (mask1, mask2, prio1, prio2) == 0;
 }

gcc/config/xtensa/xtensa.cc

@@ -6028,7 +6028,7 @@ constantsynth_pass1 (rtx_insn *insn, constantsynth_info &info)
      constant.  */
   if (GET_CODE (pat = PATTERN (insn)) != SET
       || ! REG_P (dest = SET_DEST (pat)) || ! GP_REG_P (REGNO (dest))
-      || GET_MODE (dest) != SImode
+      || GET_MODE (dest) != SImode || rtx_equal_p (dest, stack_pointer_rtx)
       || ! CONST_INT_P (src = avoid_constant_pool_reference (SET_SRC (pat))))
     return false;
 

gcc/fortran/ChangeLog

@@ -1,3 +1,25 @@
+2026-02-21  Harald Anlauf  <anlauf@gmx.de>
+
+	Revert:
+	2026-02-20  Gonzalo Silvalde Blanco  <gonzalo.silvalde@gmail.com>
+
+	PR fortran/80012
+	* symbol.cc (gfc_add_procedure): Split error into gfc_error and
+	inform using auto_diagnostic_group.
+
+2026-02-20  Gonzalo Silvalde Blanco  <gonzalo.silvalde@gmail.com>
+
+	PR fortran/80012
+	* symbol.cc (gfc_add_procedure): Split error into gfc_error and
+	inform using auto_diagnostic_group.
+
+2026-02-20  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/123949
+	* decl.cc (gfc_get_pdt_instance): Use full integer string encoding
+	for PDT instance naming rather than 32-bit extraction, which caused
+	ICEs for valid large KIND values.
+
 2026-02-19  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/122491

gcc/fortran/symbol.cc

@@ -24,7 +24,6 @@ along with GCC; see the file COPYING3.  If not see
 #include "coretypes.h"
 #include "options.h"
 #include "gfortran.h"
-#include "diagnostic-core.h"
 #include "parse.h"
 #include "match.h"
 #include "constructor.h"
@@ -1888,19 +1887,19 @@ gfc_add_procedure (symbol_attribute *attr, procedure_type t,
   if (attr->proc != PROC_UNKNOWN && !attr->module_procedure
       && attr->access == ACCESS_UNKNOWN)
     {
-      auto_diagnostic_group d;
-      gfc_error ("%s procedure at %L is already declared as %s procedure",
-		 gfc_code2string (procedures, t), where,
-		 gfc_code2string (procedures, attr->proc));
       if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
 	  && !gfc_notification_std (GFC_STD_F2008))
-	{
-	  inform (gfc_get_location (where),
-		  "F2008: A pointer function assignment is ambiguous if it is "
-		  "the first executable statement after the specification "
-		  "block.  Please add any other kind of executable "
-		  "statement before it");
-	}
+	gfc_error ("%s procedure at %L is already declared as %s "
+		   "procedure. \nF2008: A pointer function assignment "
+		   "is ambiguous if it is the first executable statement "
+		   "after the specification block. Please add any other "
+		   "kind of executable statement before it. FIXME",
+		 gfc_code2string (procedures, t), where,
+		 gfc_code2string (procedures, attr->proc));
+      else
+	gfc_error ("%s procedure at %L is already declared as %s "
+		   "procedure", gfc_code2string (procedures, t), where,
+		   gfc_code2string (procedures, attr->proc));
 
       return false;
     }

gcc/rtl-ssa/changes.cc

@@ -110,9 +110,10 @@ function_info::verify_insn_changes (array_slice<insn_change *const> changes)
 	// Make sure that the changes can be kept in their current order
 	// while honoring all of the move ranges.
 	min_insn = later_insn (min_insn, change->move_range.first);
-	while (min_insn != change->insn () && !can_insert_after (min_insn))
+	while (min_insn && min_insn != change->insn () && !can_insert_after (min_insn))
 	  min_insn = min_insn->next_nondebug_insn ();
-	if (*min_insn > *change->move_range.last)
+
+	if (!min_insn || *min_insn > *change->move_range.last)
 	  {
 	    if (dump_file && (dump_flags & TDF_DETAILS))
 	      fprintf (dump_file, "no viable insn position assignment\n");

gcc/testsuite/ChangeLog

@@ -1,3 +1,229 @@
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* algol68/compile/warning-hidding-4.a68: Mention bitspack.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* lib/algol68.exp (algol68_init): Add -I options to
+	ALGOL68_UNDER_TEST so exports in libga68.{a,so} are found.
+	* algol68/compile/warning-hidding-6.a68: Likewise.
+	* algol68/compile/warning-hidding-5.a68: Use maxint instead of
+	getchar to trigger the warning.
+	* algol68/compile/error-nest-4.a68: Procedures yielding strings
+	are now on in C formal holes.
+
+2026-02-21  Jeff Law  <jeffrey.law@oss.qualcomm.com>
+
+	PR rtl-optimization/123994
+	* gcc.dg/torture/pr123994.c: New test.
+
+2026-02-21  Harald Anlauf  <anlauf@gmx.de>
+
+	Revert:
+	2026-02-21  Gonzalo Silvalde Blanco  <gonzalo.silvalde@gmail.com>
+
+	PR fortran/80012
+	* gfortran.dg/pr80012.f90: New test.
+
+2026-02-20  Gonzalo Silvalde Blanco  <gonzalo.silvalde@gmail.com>
+
+	PR fortran/80012
+	* gfortran.dg/pr80012.f90: New test.
+
+2026-02-20  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/123949
+	* gfortran.dg/pdt_85.f03: New test.
+	* gfortran.dg/pr123949.f90: New test.
+
+2026-02-20  Kwok Cheung Yeung  <kcyeung@baylibre.com>
+
+	PR middle-end/113436
+	* g++.dg/gomp/pr113436-2.C: New.
+
+2026-02-20  Richard Biener  <rguenther@suse.de>
+
+	PR tree-optimization/124068
+	* gcc.target/i386/vect-shift-1.c: New testcase.
+
+2026-02-20  Martin Jambor  <mjambor@suse.cz>
+
+	PR ipa/122856
+	* g++.dg/ipa/pr122856.C: New test.
+
+2026-02-20  Andrew Pinski  <andrew.pinski@oss.qualcomm.com>
+
+	PR tree-optimization/121103
+	* gcc.dg/torture/pr121103-1.c: New test.
+
+2026-02-20  Robert Dubner  <rdubner@symas.com>
+
+	* cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.cob: Updated.
+	* cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out: Updated.
+	* cobol.dg/group2/ALPHABETIC-LOWER_test.cob: Updated.
+	* cobol.dg/group2/ALPHABETIC-UPPER_test.cob: Updated.
+	* cobol.dg/group2/ALPHABETIC_test.cob: Updated.
+	* cobol.dg/group2/Context_sensitive_words__1_.cob: Updated.
+	* cobol.dg/group2/DEBUG_Line.cob: Updated.
+	* cobol.dg/group2/DISPLAY__Sign_ASCII.cob: Updated.
+	* cobol.dg/group2/DISPLAY__Sign_ASCII.out: Updated.
+	* cobol.dg/group2/DISPLAY__Sign_ASCII__2_.cob: Updated.
+	* cobol.dg/group2/DISPLAY__Sign_ASCII__2_.out: Updated.
+	* cobol.dg/group2/EC-BOUND-REF-MOD_checking_process_termination.cob: Updated.
+	* cobol.dg/group2/FUNCTION_BIGGER-POINTER.cob: Updated.
+	* cobol.dg/group2/FUNCTION_BYTE-LENGTH.cob: Updated.
+	* cobol.dg/group2/FUNCTION_BYTE-LENGTH.out: Updated.
+	* cobol.dg/group2/FUNCTION_CHAR.cob: Updated.
+	* cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob: Updated.
+	* cobol.dg/group2/FUNCTION_HEX-OF.cob: Updated.
+	* cobol.dg/group2/FUNCTION_HEX-OF.out: Updated.
+	* cobol.dg/group2/FUNCTION_ORD.cob: Updated.
+	* cobol.dg/group2/FUNCTION_ORD.out: Updated.
+	* cobol.dg/group2/FUNCTION_TEST-DAY-YYYYDDD__2_.cob: Updated.
+	* cobol.dg/group2/FUNCTION_TEST-FORMATTED-DATETIME_additional.cob: Updated.
+	* cobol.dg/group2/FUNCTION_as_CALL_parameter_BY_CONTENT.cob: Updated.
+	* cobol.dg/group2/Hexadecimal_literal.cob: Updated.
+	* cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constants.cob: Updated.
+	* cobol.dg/group2/INSPECT_CONVERTING_TO_figurative_constants.out: Updated.
+	* cobol.dg/group2/LENGTH_OF_omnibus.cob: Updated.
+	* cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob: Updated.
+	* cobol.dg/group2/PACKED-DECIMAL_dump.cob: Updated.
+	* cobol.dg/group2/PACKED-DECIMAL_dump.out: Updated.
+	* cobol.dg/group2/Refmod__comparisons_inside_numeric-display.cob: Updated.
+	* cobol.dg/group2/Refmod_sources_are_figurative_constants.cob: Updated.
+	* cobol.dg/group2/Refmod_sources_are_figurative_constants.out: Updated.
+	* cobol.dg/group2/debugging_lines__not_active_.cob: Updated.
+	* cobol.dg/group2/floating-point_SUBTRACT_FORMAT_2.out: Updated.
+	* cobol.dg/group2/floating-point_literals.out: Updated.
+	* cobol.dg/group2/37-digit_Initialization_of_fundamental_types.cob: New test.
+	* cobol.dg/group2/37-digit_Initialization_of_fundamental_types.out: New test.
+	* cobol.dg/group2/ACCEPT_FROM_ENVIRONMENT-NAME.cob: New test.
+	* cobol.dg/group2/ACCEPT_FROM_ENVIRONMENT-NAME.out: New test.
+	* cobol.dg/group2/ACCEPT_foo_FROM_COMMAND-LINE_1_.cob: New test.
+	* cobol.dg/group2/ADD_1_2_TO_3_GIVING_B.cob: New test.
+	* cobol.dg/group2/ALLOCATE_Rules_6_-_9._Without_OPTION_INITIALIZE_Without_-fdefaultbyte___ASCII_.cob:
+	New test.
+	* cobol.dg/group2/ALLOCATE_Rules_6_-_9._Without_OPTION_INITIALIZE_Without_-fdefaultbyte___ASCII_.out:
+	New test.
+	* cobol.dg/group2/ALLOCATE_Rules_6_-_9._Without_OPTION_INITIALIZE_Without_-fdefaultbyte___EBCDIC_.cob:
+	New test.
+	* cobol.dg/group2/ALLOCATE_Rules_6_-_9._Without_OPTION_INITIALIZE_Without_-fdefaultbyte___EBCDIC_.out:
+	New test.
+	* cobol.dg/group2/ALLOCATE_Rules_6_-_9_Without_OPTION_INITIALIZE_With_-fdefaultbyte___UTF16_.cob:
+	New test.
+	* cobol.dg/group2/ALLOCATE_Rules_6_-_9_Without_OPTION_INITIALIZE_With_-fdefaultbyte___UTF16_.out:
+	New test.
+	* cobol.dg/group2/ANY_LENGTH__7_.cob: New test.
+	* cobol.dg/group2/ANY_LENGTH__7_.out: New test.
+	* cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.cob: New test.
+	* cobol.dg/group2/Assorted_SPECIAL-NAMES_CLASS.out: New test.
+	* cobol.dg/group2/BINARY_and_COMP-5.cob: New test.
+	* cobol.dg/group2/BINARY_and_COMP-5.out: New test.
+	* cobol.dg/group2/CDF2_-_DEFINE_FOO_AS_literal-1.cob: New test.
+	* cobol.dg/group2/CDF2_-_DEFINE_FOO_AS_literal-1.out: New test.
+	* cobol.dg/group2/CDF2_Trouble_with___IF__1_.cob: New test.
+	* cobol.dg/group2/CDF2_Trouble_with___IF__2_.cob: New test.
+	* cobol.dg/group2/CDF2_Trouble_with___IF__2_.out: New test.
+	* cobol.dg/group2/CDF4_.cob: New test.
+	* cobol.dg/group2/CDF4_.out: New test.
+	* cobol.dg/group2/CDF_Feature_.cob: New test.
+	* cobol.dg/group2/CDF_Feature_.out: New test.
+	* cobol.dg/group2/CDF_IS_NOT_DEFINED.cob: New test.
+	* cobol.dg/group2/CDF_IS_NOT_DEFINED.out: New test.
+	* cobol.dg/group2/CDF__1__IF____text_.cob: New test.
+	* cobol.dg/group2/CDF__1__IF____text_.out: New test.
+	* cobol.dg/group2/CDF__2__IF____number_.cob: New test.
+	* cobol.dg/group2/CDF__2__IF____number_.out: New test.
+	* cobol.dg/group2/CDF__3__ALL_NUMERIC_COMPARISONS.cob: New test.
+	* cobol.dg/group2/CDF__3__ALL_NUMERIC_COMPARISONS.out: New test.
+	* cobol.dg/group2/COMP-5_Sanity_Check_.cob: New test.
+	* cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_ASCII_EBCDIC.cob: New test.
+	* cobol.dg/group2/Complex_HEX__VALUE_and_MOVE_-_ASCII_EBCDIC.out: New test.
+	* cobol.dg/group2/Complex_INITIALIZE_with_nested_tables__1_.cob: New test.
+	* cobol.dg/group2/Complex_INITIALIZE_with_nested_tables__1_.out: New test.
+	* cobol.dg/group2/Complex_INITIALIZE_with_nested_tables__2_.cob: New test.
+	* cobol.dg/group2/Complex_INITIALIZE_with_nested_tables__2_.out: New test.
+	* cobol.dg/group2/Default_Arithmetic__1_.cob: New test.
+	* cobol.dg/group2/Default_Arithmetic__1_.out: New test.
+	* cobol.dg/group2/ENTRY_statement.cob: New test.
+	* cobol.dg/group2/ENTRY_statement.out: New test.
+	* cobol.dg/group2/EVALUATE__A__OR__a_.cob: New test.
+	* cobol.dg/group2/EVALUATE__A__OR__a_.out: New test.
+	* cobol.dg/group2/EVALUATE_condition__1_.cob: New test.
+	* cobol.dg/group2/EVALUATE_condition__1_.out: New test.
+	* cobol.dg/group2/FIND-STRING__forward_.cob: New test.
+	* cobol.dg/group2/FIND-STRING__forward_.out: New test.
+	* cobol.dg/group2/FIND-STRING__reverse_.cob: New test.
+	* cobol.dg/group2/FIND-STRING__reverse_.out: New test.
+	* cobol.dg/group2/FIXED_FORMAT_data_in_cols_73_and_beyond.cob: New test.
+	* cobol.dg/group2/FIXED_FORMAT_data_in_cols_73_and_beyond.out: New test.
+	* cobol.dg/group2/FIXED_FORMAT_data_misplaced_asterisk.cob: New test.
+	* cobol.dg/group2/FUNCTION_CONVERT.cob: New test.
+	* cobol.dg/group2/FUNCTION_CONVERT.out: New test.
+	* cobol.dg/group2/Fundamental_INSPECT_BACKWARD_REPLACING.cob: New test.
+	* cobol.dg/group2/Fundamental_INSPECT_BACKWARD_REPLACING.out: New test.
+	* cobol.dg/group2/Fundamental_INSPECT_BACKWARD_TALLYING.cob: New test.
+	* cobol.dg/group2/Fundamental_INSPECT_BACKWARD_TALLYING.out: New test.
+	* cobol.dg/group2/Fundamental_INSPECT_REPLACING.cob: New test.
+	* cobol.dg/group2/Fundamental_INSPECT_REPLACING.out: New test.
+	* cobol.dg/group2/Fundamental_INSPECT_TALLYING.cob: New test.
+	* cobol.dg/group2/Fundamental_INSPECT_TALLYING.out: New test.
+	* cobol.dg/group2/INITIALIZE_OCCURS_with_SIGN_LEADING___TRAILING.cob: New test.
+	* cobol.dg/group2/INITIALIZE_OCCURS_with_SIGN_LEADING___TRAILING.out: New test.
+	* cobol.dg/group2/INITIALIZE_OCCURS_with_numeric_edited.cob: New test.
+	* cobol.dg/group2/INITIALIZE_complex_group__1_.cob: New test.
+	* cobol.dg/group2/INITIALIZE_complex_group__2_.cob: New test.
+	* cobol.dg/group2/INITIALIZE_complex_group__2_.out: New test.
+	* cobol.dg/group2/INITIALIZE_group_entry_with_OCCURS.cob: New test.
+	* cobol.dg/group2/INITIALIZE_of_EXTERNAL_data_items.cob: New test.
+	* cobol.dg/group2/INITIALIZE_with_-defaultbyte__ASCII_.cob: New test.
+	* cobol.dg/group2/INITIALIZE_with_-defaultbyte__ASCII_.out: New test.
+	* cobol.dg/group2/INITIALIZE_with_-defaultbyte__EBCDIC_.cob: New test.
+	* cobol.dg/group2/INITIALIZE_with_-defaultbyte__EBCDIC_.out: New test.
+	* cobol.dg/group2/INITIALIZE_with_FILLER.cob: New test.
+	* cobol.dg/group2/INITIALIZE_with_REDEFINES.cob: New test.
+	* cobol.dg/group2/INITIALIZE_with_reference_modification.cob: New test.
+	* cobol.dg/group2/Intrinsic_Function_ABS.cob: New test.
+	* cobol.dg/group2/Intrinsic_Function_ACOS.cob: New test.
+	* cobol.dg/group2/Intrinsic_Function_ANNUITY.cob: New test.
+	* cobol.dg/group2/Intrinsic_Function_DATE-YYYYMMDD.cob: New test.
+	* cobol.dg/group2/Intrinsic_Function_NUMVAL.cob: New test.
+	* cobol.dg/group2/Intrinsic_Function_NUMVAL.out: New test.
+	* cobol.dg/group2/Long_Division.cob: New test.
+	* cobol.dg/group2/Long_Division.out: New test.
+	* cobol.dg/group2/MOVE_X_000203_.cob: New test.
+	* cobol.dg/group2/MOVE_X_000203_.out: New test.
+	* cobol.dg/group2/MOVE_to_JUSTIFIED_items.cob: New test.
+	* cobol.dg/group2/MOVE_to_JUSTIFIED_items.out: New test.
+	* cobol.dg/group2/N-Queens_algorithm.cob: New test.
+	* cobol.dg/group2/N-Queens_algorithm.out: New test.
+	* cobol.dg/group2/Numeric_operations__6_.cob: New test.
+	* cobol.dg/group2/Numeric_operations__6_.out: New test.
+	* cobol.dg/group2/Preserve_collation_past_a_CALL.cob: New test.
+	* cobol.dg/group2/Preserve_collation_past_a_CALL.out: New test.
+	* cobol.dg/group2/RETURN-CODE_moving.cob: New test.
+	* cobol.dg/group2/RETURN-CODE_nested.cob: New test.
+	* cobol.dg/group2/SORT__table_sort__2___ASCII_.cob: New test.
+	* cobol.dg/group2/SORT__table_sort__2___ASCII_.out: New test.
+	* cobol.dg/group2/SORT__table_sort__2___EBCDIC_.cob: New test.
+	* cobol.dg/group2/SORT__table_sort__2___EBCDIC_.out: New test.
+	* cobol.dg/group2/Simple_DEBUG-ITEM.cob: New test.
+	* cobol.dg/group2/Simple_DEBUG-ITEM.out: New test.
+	* cobol.dg/group2/Simple_ENVIRONMENT-NAME_with_exception.cob: New test.
+	* cobol.dg/group2/Simple_ENVIRONMENT-NAME_with_exception.out: New test.
+	* cobol.dg/group2/UNSTRING_with_refmods.cob: New test.
+	* cobol.dg/group2/UNSTRING_with_refmods.out: New test.
+	* cobol.dg/group2/command-line.cob: New test.
+	* cobol.dg/group2/command-line.out: New test.
+	* cobol.dg/group2/floating-point_FORMAT_1.cob: New test.
+	* cobol.dg/group2/floating-point_FORMAT_1.out: New test.
+	* cobol.dg/group2/floating-point_FORMAT_2.cob: New test.
+	* cobol.dg/group2/floating-point_FORMAT_2.out: New test.
+	* cobol.dg/group2/procedure_division_using_by.cob: New test.
+	* cobol.dg/group2/repository.cob: New test.
+	* cobol.dg/group2/skipping_at_the_top.cob: New test.
+	* cobol.dg/group2/source-computer_object-computer_repository__2_.cob: New test.
+
 2026-02-19  Jeff Law  <jeffrey.law@oss.qualcomm.com>
 
 	* gcc.dg/torture/pr124108.c: Fix typo.

gcc/testsuite/algol68/compile/error-nest-4.a68

@@ -1,4 +1,4 @@
-begin string s =
+begin []string s =
          nest C "lala"; { dg-error "" }
       union(int,real) x =
          nest C "x"; { dg-error "" }

gcc/testsuite/algol68/compile/warning-hidding-4.a68

@@ -1,5 +1,6 @@
 { dg-options "-Whidden-declarations" }
 begin
+      int bitspack = 10; { dg-warning "" }
       op UPB = (int i, union (int,string) v) int: { dg-warning "hides" }
          (v | (string s): UPB s | 0);
       UPB "lala"

gcc/testsuite/algol68/compile/warning-hidding-5.a68

@@ -1,6 +1,6 @@
 { dg-options "-Whidden-declarations=none" }
 begin real b;
-      begin int getchar = 10;
+      begin int maxint = 10;
             int b;
             op UPB = (int i, union (int,string) v) int:
                (v | (string s): UPB s | 0);

gcc/testsuite/algol68/compile/warning-hidding-6.a68

@@ -1,6 +1,6 @@
 { dg-options "-Whidden-declarations=prelude" }
 begin real b;
-      begin int getchar = 10; { dg-warning "hides" }
+      begin int maxint = 10; { dg-warning "hides" }
             int b;
             op UPB = (int i, union (int,string) v) int: { dg-warning "hides" }
                (v | (string s): UPB s | 0);

gcc/testsuite/algol68/execute/trimmer-11.a68

@@ -0,0 +1,14 @@
+begin [,]int aa = ((1,2,3),
+                   (4,5,6),
+                   (7,8,9));
+      [,]int bb = aa[2:,:];
+
+      assert(1 ELEMS bb = 2);
+      assert(2 ELEMS bb = 3);
+      assert(bb[1,1] = 4);
+      assert(bb[1,2] = 5);
+      assert(bb[1,3] = 6);
+      assert(bb[2,1] = 7);
+      assert(bb[2,2] = 8);
+      assert(bb[2,3] = 9)
+end

gcc/testsuite/gcc.dg/torture/pr123994.c

@@ -0,0 +1,31 @@
+/* { dg-do compile } */
+/* { dg-require-effective-target lp64 } */
+/* { dg-additional-options "-w" } */
+#include <stdint.h>
+#define BS_VEC(type, num) type __attribute__((vector_size(num * sizeof(type))))
+uint8_t backsmith_snippet_141(int16_t, uint64_t);
+int32_t backsmith_snippet_122(uint64_t BS_ARG_0, uint32_t BS_ARG_1)
+{
+    BS_ARG_0 =
+        BS_ARG_1 ? (BS_VEC(uint64_t, 16)){}[BS_ARG_0] : 4054722019416799465;
+    return BS_ARG_0;
+}
+uint16_t backsmith_pure_0(uint64_t BS_ARG_2, uint32_t BS_ARG_3)
+{
+    int64_t BS_VAR_0[6];
+    int8_t BS_VAR_3[80];
+    for (uint16_t BS_INC_0 = 0; BS_INC_0 < 8; BS_INC_0 += 1)
+    {
+        uint64_t BS_TEMP_590 = BS_INC_0;
+        BS_VAR_0[BS_INC_0] = BS_INC_0
+            ? (BS_TEMP_590 ? BS_ARG_2 >> BS_TEMP_590 : 0)
+                ?: backsmith_snippet_141(0, BS_INC_0)
+            : 0;
+        BS_VAR_3[BS_INC_0] =
+            backsmith_snippet_122(BS_VAR_0[6 ? (uint64_t)BS_INC_0 : 0] < 0,
+                                  BS_ARG_3)
+            ?: BS_ARG_3;
+    }
+    if (BS_ARG_2) BS_VAR_3[BS_ARG_3 < 80 ? BS_ARG_3 : 0] = 0;
+    return BS_VAR_3[4];
+}

gcc/testsuite/gfortran.dg/pr80012.f90

@@ -1,14 +0,0 @@
-! { dg-do compile }
-! { dg-options "-std=gnu" }
-! PR fortran/80012
-! Test that the error message for ambiguous pointer function assignment
-! is split into an error and an informational note, without FIXME.
-
-two() = 7
-contains
-  function two () ! { dg-error "INTERNAL-PROC procedure at .1. is already declared as STATEMENT-PROC procedure" }
-! { dg-message "F2008: A pointer function assignment is ambiguous" "" { target *-*-* } 9 }
-    integer, pointer  :: two
-    allocate(two)
-  end function two
-end

gcc/testsuite/lib/algol68.exp

@@ -134,7 +134,7 @@ proc algol68_init { args } {
 		    set specpath [get_multilibs]
 		}
 		set algol68_init_set_ALGOL68_UNDER_TEST 1
-		set ALGOL68_UNDER_TEST [findfile $base_dir/../../ga68 "$base_dir/../../ga68 -B$base_dir/../../ -B$specpath/libga68/" [findfile $base_dir/ga68 "$base_dir/ga68 -B$base_dir/" [transform ga68]]]
+		set ALGOL68_UNDER_TEST [findfile $base_dir/../../ga68 "$base_dir/../../ga68 -B$base_dir/../.. -B$specpath/libga68 -I$base_dir/../../.libs -I$specpath/libga68/.libs" [findfile $base_dir/ga68 "$base_dir/ga68 -B$base_dir" [transform ga68]]]
 	    }
 	}
     }

libatomic/ChangeLog

@@ -1,3 +1,11 @@
+2026-02-21  Jakub Jelinek  <jakub@redhat.com>
+
+	* Makefile.am (all-local): Depend on stmp-libatomic and otherwise
+	do nothing.
+	(stmp-libatomic): New goal, move all commands from all-local here plus
+	touch $@ at the end.
+	* Makefile.in: Regenerate.
+
 2026-01-30  Jakub Jelinek  <jakub@redhat.com>
 
 	* Makefile.am (all-local, install-asneeded): Only create

libatomic/Makefile.am

@@ -181,7 +181,8 @@ all-multi: $(libatomic_la_LIBADD)
 # from $gcc_objdir seems to fix the issue.
 
 gcc_objdir = `pwd`/$(MULTIBUILDTOP)../../gcc/
-all-local: libatomic.la
+all-local: stmp-libatomic
+stmp-libatomic: libatomic.la
 	$(LIBTOOL) --mode=install $(INSTALL_DATA) libatomic.la $(gcc_objdir)$(MULTISUBDIR)/
 if LIBAT_BUILD_ASNEEDED_SOLINK
 	cd $(gcc_objdir)$(MULTISUBDIR) || exit 1; \
@@ -193,6 +194,7 @@ if LIBAT_BUILD_ASNEEDED_SOLINK
 	$(LN_S) libatomic.a libatomic_asneeded.a; fi
 endif
 	rm $(gcc_objdir)$(MULTISUBDIR)/libatomic.la
+	touch $@
 
 if LIBAT_BUILD_ASNEEDED_SOLINK
 install-data-am: install-asneeded

libatomic/Makefile.in

@@ -929,7 +929,8 @@ vpath % $(strip $(search_path))
 # makefile fragments to avoid broken *.Ppo getting included into the Makefile
 # when it is reloaded during the build of all-multi.
 all-multi: $(libatomic_la_LIBADD)
-all-local: libatomic.la
+all-local: stmp-libatomic
+stmp-libatomic: libatomic.la
 	$(LIBTOOL) --mode=install $(INSTALL_DATA) libatomic.la $(gcc_objdir)$(MULTISUBDIR)/
 @LIBAT_BUILD_ASNEEDED_SOLINK_TRUE@	cd $(gcc_objdir)$(MULTISUBDIR) || exit 1; \
 @LIBAT_BUILD_ASNEEDED_SOLINK_TRUE@	if test -f libatomic.so; then (echo "/* GNU ld script"; \
@@ -939,6 +940,7 @@ all-local: libatomic.la
 @LIBAT_BUILD_ASNEEDED_SOLINK_TRUE@	if test -f libatomic.a; then rm -f libatomic_asneeded.a; \
 @LIBAT_BUILD_ASNEEDED_SOLINK_TRUE@	$(LN_S) libatomic.a libatomic_asneeded.a; fi
 	rm $(gcc_objdir)$(MULTISUBDIR)/libatomic.la
+	touch $@
 
 @LIBAT_BUILD_ASNEEDED_SOLINK_TRUE@install-data-am: install-asneeded
 

libga68/ChangeLog

@@ -1,3 +1,37 @@
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* standard.a68.in ({L_}bits_pack): New procedures.
+
+2026-02-21  Jose E. Marchesi  <jemarch@gnu.org>
+
+	* posix.a68: New file.
+	* standard.a68.in: Likewise.
+	* ga68-posix.c (_libga68_stdin): Define.
+	(_libga68_stdout): Likewise.
+	(_libga68_stderr): Likewise.
+	(_libga68_file_o_default): Likewise.
+	(_libga68_file_o_rdonly): Likewise.
+	(_libga68_file_o_rdwr): Likewise.
+	(_libga68_file_o_trunc): Likewise.
+	(_libga68_seek_cur): Likewise.
+	(_libga68_seek_end): Likewise.
+	(_libga68_seek_set): Likewise.
+	(_libga68_posixstrerror): Update interface to new way of returning
+	Algol 68 strings.
+	(_libga68_posixargv): Likewise.
+	(_libga68_posixfgets): Likewise.
+	(_libga68_posixgets): Likewise.
+	(_libga68_posixfopen): Use _libga68_file_o_default rather than FILE_O_DEFAULT.
+	(_libga68_posixfopen): Ditto for other FILE_O_* values.
+	* ga68.h: Update prototypes.
+	* Makefile.am (libga68_la_LIBADD): Add standard.lo.
+	(libga68_la_DEPENDENCIES): Likeise.
+	(.a68.o): Pass -fbuilding-libga68.
+	(.a68.lo): Likewise.
+	(standard.a68): New rule.
+	* Makefile.in: Regenerate.
+	* transput.a68.in: Add Emacs -*- mode: a68 -*- comment.
+
 2026-01-30  Pietro Monteiro  <pietro@sociotechnical.xyz>
 
 	* ga68-alloc.c (_libga68_realloc_internal): New function.

libga68/Makefile.am

@@ -134,8 +134,8 @@ libga68_la_LIBTOOLFLAGS =
 libga68_la_CFLAGS = $(LIBGA68_GCFLAGS) $(LIBGA68_BOEHM_GC_INCLUDES)
 libga68_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` \
 		     $(version_arg) $(lt_host_flags) $(extra_darwin_ldflags_libga68)
-libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo
-libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo
+libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo standard.lo posix.lo
+libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo standard.lo posix.lo
 
 # Rules to build the Algol 68 code in the library.
 
@@ -143,15 +143,18 @@ LTA68COMPILE = $(LIBTOOL) --tag=A68 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
 	--mode=compile $(A68) $(AM_A68FLAGS)
 
 .a68.o:
-	$(A68) -o $@ $(A68FLAGS) -c $<
+	$(A68) -o $@ $(A68FLAGS) -fbuilding-libga68 -c $<
 
 .a68.lo:
-	$(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -c -o $@ $<
+	$(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -fbuilding-libga68 -c -o $@ $<
 
 transput.a68 : transput.a68.in
 	$(AWK) -f $(srcdir)/sppp.awk $< > $@
 
-BUILT_SOURCES = transput.a68
+standard.a68 : standard.a68.in
+	$(AWK) -f $(srcdir)/sppp.awk $< > $@
+
+BUILT_SOURCES = transput.a68 standard.a68
 
 # target overrides
 -include $(tmake_file)

libga68/Makefile.in

@@ -475,14 +475,14 @@ libga68_la_CFLAGS = $(LIBGA68_GCFLAGS) $(LIBGA68_BOEHM_GC_INCLUDES)
 libga68_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` \
 		     $(version_arg) $(lt_host_flags) $(extra_darwin_ldflags_libga68)
 
-libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo
-libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo
+libga68_la_DEPENDENCIES = libga68.spec $(version_dep) transput.lo standard.lo posix.lo
+libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS) transput.lo standard.lo posix.lo
 
 # Rules to build the Algol 68 code in the library.
 LTA68COMPILE = $(LIBTOOL) --tag=A68 $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) \
 	--mode=compile $(A68) $(AM_A68FLAGS)
 
-BUILT_SOURCES = transput.a68
+BUILT_SOURCES = transput.a68 standard.a68
 MULTISRCTOP = 
 MULTIBUILDTOP = 
 MULTIDIRS = 
@@ -896,14 +896,17 @@ uninstall-am: uninstall-toolexeclibDATA \
 @LIBGA68_USE_SYMVER_SUN_TRUE@@LIBGA68_USE_SYMVER_TRUE@	> $@ || (rm -f $@ ; exit 1)
 
 .a68.o:
-	$(A68) -o $@ $(A68FLAGS) -c $<
+	$(A68) -o $@ $(A68FLAGS) -fbuilding-libga68 -c $<
 
 .a68.lo:
-	$(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -c -o $@ $<
+	$(LTA68COMPILE) $(A68FLAGS) $(MULTIFLAGS) -fbuilding-libga68 -c -o $@ $<
 
 transput.a68 : transput.a68.in
 	$(AWK) -f $(srcdir)/sppp.awk $< > $@
 
+standard.a68 : standard.a68.in
+	$(AWK) -f $(srcdir)/sppp.awk $< > $@
+
 # target overrides
 -include $(tmake_file)
 

libga68/ga68-posix.c

@@ -47,6 +47,10 @@ static int _libga68_errno;
 
 /* Simple I/O based on POSIX file descriptors.  */
 
+int _libga68_stdin = 0;
+int _libga68_stdout = 1;
+int _libga68_stderr = 2;
+
 int
 _libga68_posixerrno (void)
 {
@@ -67,11 +71,11 @@ _libga68_posixperror (uint32_t *s, size_t len, size_t stride)
   _libga68_free_internal (u8str);
 }
 
-uint32_t *
-_libga68_posixstrerror (int errnum, size_t *len)
+void
+_libga68_posixstrerror (int errnum, uint32_t **r, size_t *rlen)
 {
   const char *str = strerror (errnum);
-  return _libga68_u8_to_u32 ((const uint8_t *)str, strlen (str), NULL, len);
+  *r = _libga68_u8_to_u32 ((const uint8_t *)str, strlen (str), NULL, rlen);
 }
 
 /* Helper for _libga68_posixfopen.  */
@@ -83,11 +87,11 @@ _libga68_open (const char *path, unsigned int flags)
   return fd;
 }
 
-#define FILE_O_DEFAULT 0x99999999
-#define FILE_O_RDONLY  0x0
-#define FILE_O_WRONLY  0x1
-#define FILE_O_RDWR    0x2
-#define FILE_O_TRUNC   0x8
+unsigned int _libga68_file_o_default = 0x99999999;
+unsigned int _libga68_file_o_rdonly = 0x0;
+unsigned int _libga68_file_o_wronly = 0x1;
+unsigned int _libga68_file_o_rdwr = 0x2;
+unsigned int _libga68_file_o_trunc = 0x8;
 
 int
 _libga68_posixfopen (const uint32_t *pathname, size_t len, size_t stride,
@@ -101,7 +105,7 @@ _libga68_posixfopen (const uint32_t *pathname, size_t len, size_t stride,
   /* Default mode: try read-write initially.
      If that fails, then try read-only.
      If that fails, then try write-only.  */
-  if (flags == FILE_O_DEFAULT)
+  if (flags == _libga68_file_o_default)
     {
       openflags = O_RDWR;
       if ((fd = _libga68_open (filepath, openflags)) < 0)
@@ -119,13 +123,13 @@ _libga68_posixfopen (const uint32_t *pathname, size_t len, size_t stride,
       return fd;
     }
 
-  if (flags & FILE_O_RDONLY)
+  if (flags & _libga68_file_o_rdonly)
     openflags |= O_RDONLY;
-  if (flags & FILE_O_WRONLY)
+  if (flags & _libga68_file_o_wronly)
     openflags |= O_WRONLY;
-  if (flags & FILE_O_RDWR)
+  if (flags & _libga68_file_o_rdwr)
     openflags |= O_RDWR;
-  if (flags & FILE_O_TRUNC)
+  if (flags & _libga68_file_o_trunc)
     openflags |= O_TRUNC;
 
   fd = _libga68_open (filepath, openflags);
@@ -164,19 +168,19 @@ _libga68_posixargc (void)
 
 /* Implementation of the posix prelude `posix argv'.  */
 
-uint32_t *
-_libga68_posixargv (int n, size_t *len)
+void
+_libga68_posixargv (int n, uint32_t **r, size_t *rlen)
 {
   if (n < 0 || n > _libga68_argc)
     {
       /* Return an empty string.  */
-      *len = 0;
-      return NULL;
+      *rlen = 0;
+      *r = NULL;
     }
   else
     {
       char *arg = _libga68_argv[n - 1];
-      return _libga68_u8_to_u32 (arg, strlen (arg), NULL, len);
+      *r = _libga68_u8_to_u32 (arg, strlen (arg), NULL, rlen);
     }
 }
 
@@ -307,8 +311,8 @@ _libga68_posixgetchar (void)
 
 /* Implementation of the posix prelude `posix fgets'.  */
 
-uint32_t *
-_libga68_posixfgets (int fd, int nchars, size_t *len)
+void
+_libga68_posixfgets (int fd, int nchars, uint32_t **r, size_t *rlen)
 {
   uint32_t *res = NULL;
   int n = 0;
@@ -347,16 +351,16 @@ _libga68_posixfgets (int fd, int nchars, size_t *len)
 	res = _libga68_realloc (res, n * 80 * sizeof (uint32_t));
     }
 
-  *len = n;
-  return res;
+  *rlen = n;
+  *r = res;
 }
 
 /* Implementation of the posix prelude `posix gets'.  */
 
-uint32_t *
-_libga68_posixgets (int nchars, size_t *len)
+void
+_libga68_posixgets (int nchars, uint32_t **r, size_t *rlen)
 {
-  return _libga68_posixfgets (0, nchars, len);
+  _libga68_posixfgets (0, nchars, r, rlen);
 }
 
 /* Implementation of the posix prelude `fconnect'.  */
@@ -429,10 +433,15 @@ _libga68_posixfsize (int fd)
 }
 
 /* Implementation of the posix prelude `lseek'.  */
+
 #define A68_SEEK_CUR 0
 #define A68_SEEK_END 1
 #define A68_SEEK_SET 2
 
+const int _libga68_seek_cur = A68_SEEK_CUR;
+const int _libga68_seek_end = A68_SEEK_END;
+const int _libga68_seek_set = A68_SEEK_SET;
+
 long long int
 _libga68_posixlseek (int fd, long long int offset, int whence)
 {

libga68/ga68.h

@@ -88,14 +88,14 @@ long double _libga68_longlongrandom (void);
 int _libga68_posixerrno (void);
 void _libga68_posixexit (int) __attribute__ ((__noreturn__));
 void _libga68_posixperror (uint32_t *s, size_t len, size_t stride);
-uint32_t *_libga68_posixstrerror (int errnum, size_t *len);
+void _libga68_posixstrerror (int errnum, uint32_t **r, size_t *rlen);
 long long int _libga68_posixfsize (int fd);
 int _libga68_posixfopen (const uint32_t *pathname, size_t len, size_t stride,
 			 unsigned int flags);
 int _libga68_posixcreat (uint32_t *pathname, size_t len, size_t stride, uint32_t mode);
 int _libga68_posixclose (int fd);
 int _libga68_posixargc (void);
-uint32_t *_libga68_posixargv (int n, size_t *len);
+void _libga68_posixargv (int n, uint32_t **r, size_t *rlen);
 void _libga68_posixgetenv (uint32_t *s, size_t len, size_t stride,
 			   uint32_t **r, size_t *rlen);
 void _libga68_posixputs (uint32_t *s, size_t len, size_t stride);
@@ -105,8 +105,8 @@ int _libga68_posixfputs (int fd, uint32_t *s, size_t len, size_t stride);
 
 uint32_t _libga68_posixgetchar (void);
 uint32_t _libga68_posixfgetc (int fd);
-uint32_t *_libga68_posixfgets (int fd, int nchars, size_t *len);
-uint32_t *_libga68_posixgets (int nchars, size_t *len);
+void _libga68_posixfgets (int fd, int nchars, uint32_t **r, size_t *rlen);
+void _libga68_posixgets (int nchars, uint32_t **r, size_t *rlen);
 
 int _libga68_posixfconnect (uint32_t *str, size_t len, size_t stride,
 			    int port);

libga68/posix.a68

@@ -0,0 +1,65 @@
+{ posix.a68 - POSIX prelude.
+
+  Copyright (C) 2026 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.
+
+  Under Section 7 of GPL version 3, you are granted additional
+  permissions described in the GCC Runtime Library Exception, version
+  3.1, as published by the Free Software Foundation.
+
+  You should have received a copy of the GNU General Public License
+  and a copy of the GCC Runtime Library Exception along with this
+  program; see the files COPYING3 and COPYING.RUNTIME respectively.
+  If not, see <http://www.gnu.org/licenses/>. }
+
+module POSIX =
+def
+    pub int stdin = nest C "_libga68_stdin",
+            stdout = nest C "_libga68_stdout",
+            stderr = nest C "_libga68_stderr";
+
+    pub bits file_o_default = nest C "_libga68_file_o_default",
+             file_o_rdwr    = nest C "_libga68_file_o_rdwr",
+             file_o_rdonly  = nest C "_libga68_file_o_rdonly",
+             file_o_wronly  = nest C "_libga68_file_o_wronly",
+             file_o_trunc   = nest C "_libga68_file_o_trunc";
+
+    pub int seekcur = nest C "_libga68_seek_cur",
+            seekend = nest C "_libga68_seek_end",
+            seekset = nest C "_libga68_seek_set";
+
+    pub proc int             errno = nest C "_libga68_posixerrno",
+                             argc  = nest C "_libga68_posixargc";
+    pub proc(int)string      argv = nest C "_libga68_posixargv";
+    pub proc(int)string      strerror = nest C "_libga68_posixstrerror";
+    pub proc(string,bits)int fopen = nest C "_libga68_posixfopen",
+                             fcreate = nest C "_libga68_posixcreat";
+    pub proc(string,int)int  fconnect = nest C "_libga68_posixfconnect";
+    pub proc(int)int         fclose = nest C "_libga68_posixclose";
+    pub proc(int)long long int
+                             fsize = nest C "_libga68_posixfsize";
+    pub proc(int,long long int,int)long long int
+                             lseek = nest C "_libga68_posixlseek";
+    pub proc char            getchar = nest C "_libga68_posixgetchar";
+    pub proc(char)char       putchar = nest C "_libga68_posixputchar";
+    pub proc(int)char        fgetc = nest C "_libga68_posixfgetc";
+    pub proc(int,char)char       fputc = nest C "_libga68_posixfputc";
+    pub proc(int)ref string      gets = nest C "_libga68_posixgets";
+    pub proc(string)void         puts = nest C "_libga68_posixputs";
+    pub proc(int,int)ref string  fgets = nest C "_libga68_posixfgets";
+    pub proc(int,string)int  fputs = nest C "_libga68_posixfputs";
+    pub proc(int)void        posix_exit = nest C "_libga68_posixexit";
+    pub proc(string)void     perror = nest C "_libga68_posixperror";
+    pub proc(string)string   getenv = nest C "_libga68_posixgetenv";
+
+    skip
+fed

libga68/standard.a68.in

@@ -0,0 +1,47 @@
+{ Process this file with sppp.awk  -*- mode: a68 -*- }
+
+{ standard.a68.in - Standard prelude, a68 part.
+
+  Copyright (C) 2026 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.
+
+  Under Section 7 of GPL version 3, you are granted additional
+  permissions described in the GCC Runtime Library Exception, version
+  3.1, as published by the Free Software Foundation.
+
+  You should have received a copy of the GNU General Public License
+  and a copy of the GCC Runtime Library Exception along with this
+  program; see the files COPYING3 and COPYING.RUNTIME respectively.
+  If not, see <http://www.gnu.org/licenses/>. }
+
+module Standard =
+def
+    { 10.2.3.8.l L bitspack
+      ───────────────────── }
+
+    {iter L  {short short}  {short}  {} {long}  {long long}}
+    {iter L_ {short_short_} {short_} {} {long_} {long_long_}}
+    pub proc {L_}bits_pack = ([]bool a) {L} bits:
+       if int n = UPB a[@1];
+          n <= {L_}bits_width
+       then {L} bits c := {L} 16r0;
+            for i to {L_}bits_width
+            do if i > {L_}bits_width - n
+                  andth a[@1][i - {L_}bits_width + n]
+               then c := c OR ({L} 2r1 SHL ({L_}bits_width - i)) fi
+            od;
+            c
+       fi;
+    {reti}
+
+    skip
+fed

libga68/transput.a68.in

@@ -1,4 +1,4 @@
-{ Process this file with sppp.awk  }
+{ Process this file with sppp.awk  -*- mode: a68 -*- }
 
 { transput.a68.in - Standard transput.
 

libstdc++-v3/ChangeLog

@@ -1,3 +1,8 @@
+2026-02-20  Jonathan Wakely  <jwakely@redhat.com>
+
+	* testsuite/lib/libstdc++.exp (v3-minimum-std): Remove second
+	and third args in favour of using globals.
+
 2026-02-19  Tomasz Kamiński  <tkaminsk@redhat.com>
 
 	* include/std/type_traits (_CWOperators::operator++)