[PATCH V4 00/47] Algol 68 GCC Front-End

public inbox for gcc-patches@gcc.gnu.org
 help / color / mirror / Atom feed

* [PATCH V4 00/47] Algol 68 GCC Front-End
@ 2025-10-18 21:51 Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 01/47] a68: top-level misc files Jose E. Marchesi
                   ` (47 more replies)
  0 siblings, 48 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

[My apologies for the short-lived V3]

[Changes from V3:
 - lang.opt.urls regenerated.
 - Added missing rules for building the html, dvi and pdf versions of the
   ga68-internals manual.
 - Torture tests adapted to use new run-time checking options.
 - Added libga68 patch by Pietro Monteiro with a fix for posixstrerror.
 - Patch 07/47: "a68: darwin specific support" approved.
 Changes from V2:
 - Rebased to today's master.
 - All generated filed moved to their own commits to ease review.
 - Spurious change removed from DWARF patch.
 - Consolidate command-line options:
   + Substitute -fa68-nil-checking and -fa68-bounds-checking with
     -fcheck={all,none,[no-]nil,[no-]bounds}.
   + Make -fbounds-check an alias for -fcheck=bounds.
   + Rename -fa68-brackets to -fbrackets.
   + Rename -fa68-assert to -fassert.
   + Rename -fdump-algol68-modes to -fa68-dump-modes.
   + Rename -fdump-algol68-tree to -fa68-dump-ast.
   + Remove unused -fa68-safe, -fa68-safe-bounds, -fa68-debug and -fa68-portcheck
 - Series tested with --enable-host-pie and
   --enable-version-specific-runtime-libs.
 Changes from V1:
 - All the missing core language constructs have been implemented,
   with the exception of parallel clauses.
 - Standard prelude has been completed.
 - A POSIX prelude has been added.
 - Many bugs fixed and improvements done in more than 530 commits
   since last submission.]

[Approved patches in this series so far:
 - Patch 01/47: a68: top-level misc files
 - Patch 02/47: a68: build system
 - Patch 03/47: a68: build system (regenerated files)
 - Patch 04/47: a68: documentation
 - Patch 05/47: a68: command-line options
 - Patch 06/47: a68: DWARF language codes
 - Patch 07/47: a68: darwin specific support
 - Patch 40/47: a68: libga68: build system
 - Patch 41/47: a68: libga68: build system (generated files)]

[Patches that need reviews from area maintainers (in CC):
 - Patch 08/47: a68: powerpc specific support]

QUESTION: The remainding patches are specific to the Algol 68 support
and do not touch common code/infrastructure.  Should I purse explicit
reviews for these?

This is a GCC front-end for Algol 68, the fascinating, generally
poorly understood and often vilified programming language.  It is
common knowledge that Algol 68 was well ahead of its time back when it
was introduced, and anyone who knows the language well will suspect
this probably still holds true today, but more than fifty years after
the publication of the Revised Report the world may finally be ready
for it, or perhaps not, we shall see ;) At the very least having
support in GCC will make it easier for Algol 68 enthusiasts to write,
share and use their programs in modern systems.

The compiler driver is called `ga68'.
The compiler proper is called `a681'.
The run-time library is called `libga68'.

This front-end can compile all of the core language constructs, with
only very few exceptions, and can be already used to write full
fledged real life programs such as

  https://git.sr.ht/~jemarch/godcc

Please take a look to see some modern Algol 68 code in action.

Information on the development of this front-end can be found in the
GCC wiki page

  https://gcc.gnu.org/wiki/Algol68FrontEnd

Notes on this patch series
==========================

This patch series is also available in the git repository

  https://forge.sourceware.org/gcc/gcc-a68

in the branch a68-v4.

Some auto-generated files like 'configure' have been ommitted from this series
because they are too big.  These can be found in the git branch above.

ChangeLog entries are included in every commit message, all of them verified
with git_check_commit.py.

All the C and C++ code is formatted following the GNU Coding Standards.

Notes on the implementation
===========================

The parser used in this front-end has been borrowed and adapted from Algol 68
Genie, an Algol 68 interpreter written by Marcel van der Veer.  It is worth
noting that this parser is not your typical garden variety parser, as it is
capable of effectively parsing the two-level grammar of Algol 68, which is no
small deal.  Parsing Algol 68 is notoriously difficult, and without Marcel's
careful work of many years this front-end would most probably not exist.  It
is also a beautiful implementation that is a delight to both read and work
with.  I certainly have learned a lot from it.  The syntax tree built by the
parser is then lowered into a GENERIC tree by a lowering pass, which then
invokes the gimplifier and hands the resulting gimple IR over to the rest of
the compilation, down the rabbit hole all the way to optimized assembly code.

The DWARF currently generated by the compiler is not very useful.  Emitting
DWARF that accurately describes the Algol 68 data structures is still to be
done.  As is GDB support and its corresponding expressions parser, which by
the way will be lots of fun to do, considering the language in question ^^

The mangling of symbols is currently very dumb.  This is because we need to
design and decide on a separated compilation model first in order to determine
what information to encode in the symbols.

The front-end is very slow (not so the generated code).  This is because a lot
of code is emitted inline in the tree, and that code has to be optimized.  As
soon as we optimize copies and move some of that code to functions then
performance will improve.

Testing and documentation
=========================

The front-end includes several test suites for catching regressions.  This
covers compile-only, execution and torture tests.

  $ make check-algol68 RUNTESTFLAGS="--target_board=unix\{-m64,-m32\}"

		=== algol68 Summary for unix/-m64 ===

  # of expected passes		10755

		=== algol68 Summary for unix/-m32 ===

  # of expected passes		10747
  # of unexpected failures	8

		=== algol68 Summary ===

  # of expected passes		21502
  # of unexpected failures	8

The front-end includes two new manuals:

 ga68.texi               The GNU Algol 68 Compiler
 ga68-internals.texi     GNU Algol 68 Compiler Internals

GNU Algol 68
============

The GNU Algol 68 Working Group is a group of hackers whose purpose is to bring
Algol 68 to the first line of programming where it belongs, to provide modern
implementations of the language well integrated in today's operating systems
and computers (like this front-end), to produce documentation to help people
to learn this fascinating language, and to explore extensions and evolve the
language with the rigor, respect and seriousness that it deserves and demands.

The goal is for GNU Algol 68 to be a strict super-language of Algol 68, as is
blessed by the Report.

The GNU extensions to Algol 68 are prepared at

  https://git.sr.ht/~jemarch/gnu68

and then published in the Algol 68 homepage:

  https://algol68-lang.org

Below is the current list of GNU extensions already designed and implemented
by this front-end:

  GNU68-2025-001  An 'unsafe' clause for Algol 68.
  GNU68-2025-002  Bold taggles in Algol 68.
  GNU68-2025-003  Short-circuit logical pseudo-operators for Algol 68.
  GNU68-2025-004  SUPPER, a modern stropping regime for Algol 68.

Other GNU extensions being prepared are:

  GNU68-2025-???  Separated compilation and modules for Algol 68.
  GNU68-2025-???  Modals, generic programming for Algol 68.

Authorship and Copyright
========================

The original parser is copyright Marcel van der Veer.  The rest of the code is
either copyright of yours humble, boilerplate taken from other GCC front-ends,
or FSF copyrighted code from gnulib.

I am looking to clarify th copyright status of the tests adapted from
Th Revised MC Algol 68 Test Set, published by Dick Grüne.

Signed-off-by and Co-authored-by marks have been carefully included in each
individual patch.  Precise copyright notices can be found in all source files.

All the code is licensed under GPLv3+, with the GCC Runtime Library exception
for run-time components.  The manuals are licensed under the GNU FDL like the
rest of the documentation shipped with GCC.

What is next
============

The Revised Report didn't concern itself with mundane topics as
separated compilation, so at this point each compilation unit is a
full program.  Early Algol 68 compilers supported separated
compilation, each on its own way.  The WG 2.1 also produced a proposal
for a standard modules system for Algol 68, never implemented to my
knowledge.  A proper modules system is also in the works.  Once the
separated compilation and modules are done then we will be
implementing a full-fledged transput system, as well as support for
"modals" to ease generic programming, and more extensions.

Related projects and tools
==========================

A homepage for Algol 68 has been set up at https://algol68-lang.org.

An Emacs mode for editing Algol 68 programs can be found at
https://git.sr.ht/~jemarch/a68-mode.  It supports automatic indentation and
other useful features.  It can be installed from ELPA using
M-xpackage-install.

Another Emacs mode for help editing RR-like language descriptions and
two-level grammars can be found at https://git.sr.ht/~jemarch/vw-mode.

Automake supports Algol 68 starting with version 1.18.

Autoconf patches have been sent to their development mailing list and are
still to be approved.  In the meanwhile the algol 68 support can be found at
https://git.sr.ht/~jemarch/autoconf-a68.

Compiler Explorer supports ga68 thanks to Marc Poulhiès.

The Algol 68 Jargon File at https://jemarch.net/a68-jargon aims to provide a
comprehensive list of definitions for technical and non-technical terms used
in the context of Algol 68, which are many.  It contains few entries at the
moment but I am progressively expanding it as time allows.  The sources of the
jargon are at https://git.sr.ht/~jemarch/a68-jargon.

Community
=========

The development mailing list for the front-end is algol68@gcc.gnu.org.

We are also using the #gnualgol channel in irc.oftc.net.

Everyone is welcome to join and have fun with Algol 68.
Salud!

Jose E. Marchesi (47):
  a68: top-level misc files
  a68: build system
  a68: build system (regenerated files)
  a68: documentation
  a68: command-line options
  a68: DWARF language codes
  a68: darwin specific support
  a68: powerpc specific support
  a68: gcc/algol68 misc files
  a68: ga68 compiler driver
  a68: a681 compiler proper
  a68: unicode support routines
  a68: front-end diagnostics
  a68: parser: entry point
  a68: parser: AST nodes attributes/types
  a68: parser: scanner
  a68: parser: keyword tables management
  a68: parser: top-down parser
  a68: parser: parenthesis checker
  a68: parser: bottom-up parser
  a68: parser: syntax check for declarers
  a68: parser: standard prelude definitions
  a68: parser: parsing of modes
  a68: parser: symbol table management
  a68: parser: static scope checker
  a68: parser: debug facilities
  a68: parser: extraction of tags from phrases
  a68: parser: dynamic stack usage in serial clauses
  a68: low: lowering entry point and misc handlers
  a68: low: plain values
  a68: low: stowed values
  a68: low: standard prelude
  a68: low: clauses and declarations
  a68: low: runtime
  a68: low: builtins
  a68: low: ranges
  a68: low: units and coercions
  a68: low: modes
  a68: libga68: sources, spec and misc files
  a68: libga68: build system
  a68: libga68: build system (generated files)
  a68: testsuite: infrastructure
  a68: testsuite: execution tests 1/2
  a68: testsuite: execution tests 2/2
  a68: testsuite: compilation tests
  a68: testsuite: revised MC Algol 68 test set
  a68: testsuite: mcgt tests

 MAINTAINERS                                   |     2 +
 Makefile.def                                  |     4 +
 Makefile.in                                   |   737 +-
 Makefile.tpl                                  |    14 +
 SECURITY.txt                                  |     1 +
 config/acx.m4                                 |     6 +
 configure                                     |   355 +-
 configure.ac                                  |    47 +-
 contrib/gcc-changelog/git_commit.py           |     1 +
 gcc/Makefile.in                               |    36 +-
 gcc/algol68/Make-lang.in                      |   284 +
 gcc/algol68/README                            |   126 +
 gcc/algol68/a68-diagnostics.cc                |   360 +
 gcc/algol68/a68-lang.cc                       |   751 +
 gcc/algol68/a68-low-bits.cc                   |   297 +
 gcc/algol68/a68-low-bools.cc                  |    77 +
 gcc/algol68/a68-low-builtins.cc               |   533 +
 gcc/algol68/a68-low-chars.cc                  |   170 +
 gcc/algol68/a68-low-clauses.cc                |  1407 ++
 gcc/algol68/a68-low-coercions.cc              |   471 +
 gcc/algol68/a68-low-complex.cc                |   141 +
 gcc/algol68/a68-low-decls.cc                  |   629 +
 gcc/algol68/a68-low-generator.cc              |   533 +
 gcc/algol68/a68-low-ints.cc                   |   327 +
 gcc/algol68/a68-low-misc.cc                   |   213 +
 gcc/algol68/a68-low-moids.cc                  |   729 +
 gcc/algol68/a68-low-multiples.cc              |  1097 +
 gcc/algol68/a68-low-posix.cc                  |   553 +
 gcc/algol68/a68-low-prelude.cc                |  2151 ++
 gcc/algol68/a68-low-procs.cc                  |    52 +
 gcc/algol68/a68-low-ranges.cc                 |   697 +
 gcc/algol68/a68-low-reals.cc                  |   620 +
 gcc/algol68/a68-low-refs.cc                   |    52 +
 gcc/algol68/a68-low-runtime.cc                |   225 +
 gcc/algol68/a68-low-runtime.def               |    91 +
 gcc/algol68/a68-low-strings.cc                |   390 +
 gcc/algol68/a68-low-structs.cc                |    63 +
 gcc/algol68/a68-low-unions.cc                 |   279 +
 gcc/algol68/a68-low-units.cc                  |  1191 +
 gcc/algol68/a68-low.cc                        |  1153 +
 gcc/algol68/a68-moids-diagnostics.cc          |   269 +
 gcc/algol68/a68-moids-misc.cc                 |  1370 ++
 gcc/algol68/a68-moids-to-string.cc            |   366 +
 gcc/algol68/a68-parser-attrs.def              |   362 +
 gcc/algol68/a68-parser-bottom-up.cc           |  2542 ++
 gcc/algol68/a68-parser-brackets.cc            |   220 +
 gcc/algol68/a68-parser-debug.cc               |    90 +
 gcc/algol68/a68-parser-extract.cc             |   675 +
 gcc/algol68/a68-parser-keywords.cc            |   226 +
 gcc/algol68/a68-parser-modes.cc               |  1301 +
 gcc/algol68/a68-parser-moids-check.cc         |  1811 ++
 gcc/algol68/a68-parser-moids-coerce.cc        |   874 +
 gcc/algol68/a68-parser-moids-equivalence.cc   |   174 +
 gcc/algol68/a68-parser-prelude.cc             |  1493 ++
 gcc/algol68/a68-parser-scanner.cc             |  2277 ++
 gcc/algol68/a68-parser-scope.cc               |   975 +
 gcc/algol68/a68-parser-serial-dsa.cc          |   114 +
 gcc/algol68/a68-parser-taxes.cc               |  1648 ++
 gcc/algol68/a68-parser-top-down.cc            |   785 +
 gcc/algol68/a68-parser-victal.cc              |   362 +
 gcc/algol68/a68-parser.cc                     |  1134 +
 gcc/algol68/a68-postulates.cc                 |   103 +
 gcc/algol68/a68-tree.def                      |    24 +
 gcc/algol68/a68-types.h                       |   964 +
 gcc/algol68/a68-unistr.c                      |   453 +
 gcc/algol68/a68.h                             |  1042 +
 gcc/algol68/a68spec.cc                        |   222 +
 gcc/algol68/algol68-target.def                |    52 +
 gcc/algol68/config-lang.in                    |    29 +
 gcc/algol68/ga68-internals.texi               |   383 +
 gcc/algol68/ga68.texi                         |  3121 +++
 gcc/algol68/ga68.vw                           |  1837 ++
 gcc/algol68/lang-specs.h                      |    24 +
 gcc/algol68/lang.opt                          |   102 +
 gcc/algol68/lang.opt.urls                     |    41 +
 gcc/common.opt                                |     3 +
 gcc/common.opt.urls                           |     3 +
 gcc/config.gcc                                |    44 +
 gcc/config/darwin.h                           |     1 +
 gcc/config/rs6000/rs6000-logue.cc             |    14 +-
 gcc/configure                                 |    20 +-
 gcc/configure.ac                              |    13 +
 gcc/doc/tm.texi                               |    18 +
 gcc/doc/tm.texi.in                            |     9 +
 gcc/dwarf2out.cc                              |     8 +
 gcc/gcc.cc                                    |     2 +
 gcc/genhooks.cc                               |     1 +
 gcc/regenerate-opt-urls.py                    |     3 +-
 gcc/testsuite/algol68/README.mcts             |    37 +
 .../compile/a68includes/goodbye-supper.a68    |     4 +
 .../algol68/compile/a68includes/goodbye.a68   |     8 +
 .../compile/a68includes/hello-supper.a68      |     5 +
 .../algol68/compile/a68includes/hello.a68     |     8 +
 .../compile/actual-bounds-expected-1.a68      |     4 +
 .../compile/actual-bounds-expected-2.a68      |     4 +
 .../compile/actual-bounds-expected-3.a68      |     6 +
 gcc/testsuite/algol68/compile/balancing-1.a68 |     7 +
 .../compile/bold-nestable-comment-1.a68       |     7 +
 .../algol68/compile/bold-taggle-1.a68         |     6 +
 .../compile/brief-nestable-comment-1.a68      |     4 +
 .../compile/brief-nestable-comment-2.a68      |     6 +
 .../algol68/compile/char-break-1.a68          |    11 +
 gcc/testsuite/algol68/compile/compile.exp     |    34 +
 .../algol68/compile/conditional-clause-1.a68  |     9 +
 .../algol68/compile/error-bold-taggle-1.a68   |     6 +
 .../algol68/compile/error-coercion-1.a68      |     5 +
 .../algol68/compile/error-coercion-2.a68      |     6 +
 .../algol68/compile/error-coercion-flex-1.a68 |     8 +
 .../compile/error-conformance-clause-1.a68    |     8 +
 .../algol68/compile/error-contraction-1.a68   |     6 +
 .../algol68/compile/error-contraction-2.a68   |     8 +
 .../compile/error-incestuous-union-1.a68      |     8 +
 .../compile/error-label-after-decl-1.a68      |     8 +
 .../compile/error-nestable-comments-1.a68     |     9 +
 .../compile/error-nested-comment-1.a68        |     6 +
 .../compile/error-no-bounds-allowed-1.a68     |    15 +
 .../algol68/compile/error-string-break-1.a68  |     4 +
 .../algol68/compile/error-string-break-2.a68  |     2 +
 .../algol68/compile/error-string-break-3.a68  |     2 +
 .../algol68/compile/error-string-break-4.a68  |     2 +
 .../algol68/compile/error-string-break-5.a68  |     2 +
 .../algol68/compile/error-string-break-6.a68  |     2 +
 .../algol68/compile/error-string-break-7.a68  |     2 +
 .../algol68/compile/error-supper-1.a68        |     3 +
 .../algol68/compile/error-supper-2.a68        |     5 +
 .../algol68/compile/error-supper-3.a68        |     5 +
 .../algol68/compile/error-supper-4.a68        |     5 +
 .../algol68/compile/error-supper-5.a68        |     5 +
 .../algol68/compile/error-supper-6.a68        |     6 +
 .../compile/error-underscore-in-mode-1.a68    |     7 +
 .../compile/error-underscore-in-tag-1.a68     |     7 +
 .../algol68/compile/error-upper-1.a68         |     3 +
 .../algol68/compile/error-widening-1.a68      |     6 +
 .../algol68/compile/error-widening-2.a68      |     6 +
 .../algol68/compile/error-widening-3.a68      |    10 +
 .../algol68/compile/error-widening-4.a68      |    10 +
 .../algol68/compile/error-widening-5.a68      |     6 +
 .../algol68/compile/error-widening-6.a68      |     6 +
 .../algol68/compile/error-widening-7.a68      |     6 +
 .../algol68/compile/error-widening-8.a68      |     6 +
 .../algol68/compile/error-widening-9.a68      |    10 +
 .../algol68/compile/hidden-operators-1.a68    |    11 +
 .../algol68/compile/implicit-widening-1.a68   |    10 +
 .../algol68/compile/include-supper.a68        |    16 +
 gcc/testsuite/algol68/compile/include.a68     |    19 +
 .../algol68/compile/labeled-unit-1.a68        |     7 +
 gcc/testsuite/algol68/compile/mcgt-1.3b.a68   |     5 +
 .../algol68/compile/mcgt-7.1.3a-bis.a68       |     8 +
 gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68 |     8 +
 .../algol68/compile/mcts/compile.exp          |    34 +
 gcc/testsuite/algol68/compile/mcts/decl06.a68 |   258 +
 gcc/testsuite/algol68/compile/mcts/idef10.a68 |     6 +
 gcc/testsuite/algol68/compile/mcts/mdeq01.a68 |     6 +
 gcc/testsuite/algol68/compile/mcts/mdeq03.a68 |     8 +
 gcc/testsuite/algol68/compile/mcts/mdeq05.a68 |     8 +
 gcc/testsuite/algol68/compile/mcts/mdeq06.a68 |    18 +
 gcc/testsuite/algol68/compile/mcts/oper05.a68 |     8 +
 gcc/testsuite/algol68/compile/mcts/oper06.a68 |     6 +
 gcc/testsuite/algol68/compile/mcts/oper12.a68 |    13 +
 gcc/testsuite/algol68/compile/mcts/oper15.a68 |     7 +
 .../algol68/compile/nested-comment-1.a68      |     4 +
 .../algol68/compile/nested-comment-2.a68      |     6 +
 .../compile/operators-firmly-related.a68      |     7 +
 .../algol68/compile/recursive-modes-1.a68     |    33 +
 .../algol68/compile/recursive-modes-2.a68     |     7 +
 .../algol68/compile/serial-clause-jump-1.a68  |     7 +
 gcc/testsuite/algol68/compile/snobol.a68      |  1100 +
 gcc/testsuite/algol68/compile/supper-1.a68    |    11 +
 gcc/testsuite/algol68/compile/supper-10.a68   |     6 +
 gcc/testsuite/algol68/compile/supper-11.a68   |     6 +
 gcc/testsuite/algol68/compile/supper-12.a68   |     6 +
 gcc/testsuite/algol68/compile/supper-13.a68   |     7 +
 gcc/testsuite/algol68/compile/supper-2.a68    |     5 +
 gcc/testsuite/algol68/compile/supper-3.a68    |     5 +
 gcc/testsuite/algol68/compile/supper-4.a68    |     5 +
 gcc/testsuite/algol68/compile/supper-5.a68    |     6 +
 gcc/testsuite/algol68/compile/supper-6.a68    |     5 +
 gcc/testsuite/algol68/compile/supper-7.a68    |     5 +
 gcc/testsuite/algol68/compile/supper-8.a68    |     6 +
 gcc/testsuite/algol68/compile/supper-9.a68    |     6 +
 gcc/testsuite/algol68/compile/uniting-1.a68   |     8 +
 gcc/testsuite/algol68/compile/upper-1.a68     |    11 +
 .../algol68/compile/warning-scope-1.a68       |     9 +
 .../algol68/compile/warning-scope-2.a68       |     8 +
 .../algol68/compile/warning-scope-3.a68       |     3 +
 .../algol68/compile/warning-scope-4.a68       |     3 +
 .../algol68/compile/warning-scope-5.a68       |     8 +
 .../algol68/compile/warning-scope-6.a68       |     6 +
 .../algol68/compile/warning-scope-7.a68       |    12 +
 .../algol68/compile/warning-voiding-1.a68     |     5 +
 .../algol68/compile/warning-voiding-2.a68     |     6 +
 gcc/testsuite/algol68/execute/abs-bits-1.a68  |     7 +
 gcc/testsuite/algol68/execute/abs-bool-1.a68  |     4 +
 gcc/testsuite/algol68/execute/abs-char-1.a68  |     3 +
 gcc/testsuite/algol68/execute/abs-int-1.a68   |    10 +
 .../algol68/execute/abs-int-negative-1.a68    |     4 +
 .../execute/abs-int-negative-gnu-1.a68        |     4 +
 gcc/testsuite/algol68/execute/acos-1.a68      |     8 +
 .../algol68/execute/affirm-int-1.a68          |    10 +
 gcc/testsuite/algol68/execute/and-bits-1.a68  |    18 +
 gcc/testsuite/algol68/execute/andf-1.a68      |     4 +
 .../algol68/execute/ascription-1.a68          |    12 +
 gcc/testsuite/algol68/execute/asin-1.a68      |     8 +
 gcc/testsuite/algol68/execute/assert-1.a68    |     3 +
 .../algol68/execute/assignation-char-1.a68    |     5 +
 .../algol68/execute/assignation-int-1.a68     |     5 +
 .../algol68/execute/assignation-int-2.a68     |     5 +
 .../algol68/execute/assignation-int-3.a68     |     6 +
 .../algol68/execute/assignation-int-4.a68     |     5 +
 .../algol68/execute/assignation-int-5.a68     |     6 +
 .../execute/assignation-multiple-1.a68        |     4 +
 .../execute/assignation-multiple-2.a68        |    15 +
 .../algol68/execute/assignation-struct-1.a68  |     6 +
 .../algol68/execute/assignation-struct-2.a68  |     8 +
 gcc/testsuite/algol68/execute/atan-1.a68      |     8 +
 gcc/testsuite/algol68/execute/balancing-1.a68 |    12 +
 .../algol68/execute/balancing-rows-1.a68      |     4 +
 gcc/testsuite/algol68/execute/bin-1.a68       |     6 +
 .../algol68/execute/bin-negative-1.a68        |     3 +
 .../algol68/execute/bin-negative-gnu-1.a68    |     3 +
 gcc/testsuite/algol68/execute/boolops-1.a68   |    18 +
 gcc/testsuite/algol68/execute/call-1.a68      |    19 +
 gcc/testsuite/algol68/execute/call-2.a68      |    21 +
 .../algol68/execute/case-clause-1.a68         |    10 +
 .../algol68/execute/case-clause-2.a68         |     8 +
 .../algol68/execute/case-clause-3.a68         |     7 +
 .../algol68/execute/case-clause-4.a68         |     5 +
 .../algol68/execute/closed-clause-1.a68       |    10 +
 .../algol68/execute/closed-clause-2.a68       |     9 +
 .../algol68/execute/collateral-clause-1.a68   |     4 +
 .../algol68/execute/collateral-clause-2.a68   |     9 +
 .../algol68/execute/collateral-clause-3.a68   |    11 +
 .../algol68/execute/collateral-clause-4.a68   |     3 +
 .../algol68/execute/collateral-clause-5.a68   |     5 +
 .../algol68/execute/collateral-clause-6.a68   |     8 +
 gcc/testsuite/algol68/execute/completer-1.a68 |     9 +
 .../algol68/execute/completer-10.a68          |     7 +
 gcc/testsuite/algol68/execute/completer-2.a68 |     7 +
 gcc/testsuite/algol68/execute/completer-3.a68 |     4 +
 gcc/testsuite/algol68/execute/completer-4.a68 |     4 +
 gcc/testsuite/algol68/execute/completer-5.a68 |     5 +
 gcc/testsuite/algol68/execute/completer-6.a68 |     5 +
 gcc/testsuite/algol68/execute/completer-7.a68 |     5 +
 gcc/testsuite/algol68/execute/completer-8.a68 |     5 +
 gcc/testsuite/algol68/execute/completer-9.a68 |     6 +
 .../algol68/execute/cond-clause-1.a68         |     5 +
 .../algol68/execute/cond-clause-2.a68         |     5 +
 .../algol68/execute/cond-clause-3.a68         |     7 +
 .../algol68/execute/cond-clause-4.a68         |     3 +
 .../algol68/execute/cond-clause-5.a68         |     3 +
 .../algol68/execute/cond-clause-6.a68         |    23 +
 .../algol68/execute/cond-clause-7.a68         |    23 +
 .../algol68/execute/cond-clause-8.a68         |    20 +
 .../algol68/execute/cond-clause-9.a68         |    23 +
 .../algol68/execute/conformity-clause-1.a68   |    10 +
 .../algol68/execute/conformity-clause-2.a68   |    11 +
 .../algol68/execute/conformity-clause-3.a68   |    11 +
 .../algol68/execute/conformity-clause-4.a68   |     7 +
 .../algol68/execute/conformity-clause-5.a68   |    14 +
 .../algol68/execute/conformity-clause-6.a68   |     8 +
 .../algol68/execute/conformity-clause-7.a68   |     7 +
 .../algol68/execute/conformity-clause-8.a68   |    11 +
 .../algol68/execute/conformity-clause-9.a68   |    10 +
 gcc/testsuite/algol68/execute/conj-1.a68      |     9 +
 gcc/testsuite/algol68/execute/cos-1.a68       |     8 +
 gcc/testsuite/algol68/execute/declarer-1.a68  |     9 +
 gcc/testsuite/algol68/execute/declarer-2.a68  |     6 +
 .../algol68/execute/deprocedure-1.a68         |     5 +
 .../algol68/execute/deprocedure-2.a68         |     6 +
 gcc/testsuite/algol68/execute/deref-1.a68     |     5 +
 gcc/testsuite/algol68/execute/deref-2.a68     |     6 +
 gcc/testsuite/algol68/execute/deref-3.a68     |    11 +
 gcc/testsuite/algol68/execute/deref-4.a68     |     8 +
 gcc/testsuite/algol68/execute/deref-5.a68     |    42 +
 gcc/testsuite/algol68/execute/deref-6.a68     |    48 +
 gcc/testsuite/algol68/execute/deref-7.a68     |    48 +
 gcc/testsuite/algol68/execute/deref-8.a68     |    53 +
 gcc/testsuite/algol68/execute/div-int-1.a68   |     7 +
 .../algol68/execute/divab-real-1.a68          |    11 +
 gcc/testsuite/algol68/execute/elem-bits-1.a68 |    18 +
 gcc/testsuite/algol68/execute/elems-1.a68     |     6 +
 gcc/testsuite/algol68/execute/elems-2.a68     |     7 +
 gcc/testsuite/algol68/execute/entier-1.a68    |     8 +
 .../execute/environment-enquiries-1.a68       |    10 +
 .../execute/environment-enquiries-2.a68       |    12 +
 .../execute/environment-enquiries-3.a68       |     9 +
 .../execute/environment-enquiries-4.a68       |     7 +
 .../execute/environment-enquiries-5.a68       |     5 +
 .../execute/environment-enquiries-6.a68       |     7 +
 .../execute/environment-enquiries-7.a68       |    15 +
 .../execute/environment-enquiries-8.a68       |     6 +
 gcc/testsuite/algol68/execute/eq-bits-1.a68   |    10 +
 .../algol68/execute/eq-char-char-1.a68        |     4 +
 gcc/testsuite/algol68/execute/eq-int-1.a68    |    10 +
 gcc/testsuite/algol68/execute/eq-string-1.a68 |    16 +
 .../algol68/execute/eq-string-stride-1.a68    |     6 +
 gcc/testsuite/algol68/execute/execute.exp     |    37 +
 gcc/testsuite/algol68/execute/factorial-1.a68 |   170 +
 .../algol68/execute/flat-assignation-1.a68    |     7 +
 .../algol68/execute/flat-assignation-2.a68    |     8 +
 gcc/testsuite/algol68/execute/flex-1.a68      |     5 +
 gcc/testsuite/algol68/execute/flex-2.a68      |     8 +
 gcc/testsuite/algol68/execute/flex-3.a68      |     7 +
 gcc/testsuite/algol68/execute/flex-4.a68      |     6 +
 gcc/testsuite/algol68/execute/flex-5.a68      |    12 +
 gcc/testsuite/algol68/execute/formula-1.a68   |     9 +
 gcc/testsuite/algol68/execute/formula-2.a68   |     7 +
 gcc/testsuite/algol68/execute/fsize-1.a68     |     2 +
 gcc/testsuite/algol68/execute/ge-int-1.a68    |    10 +
 .../algol68/execute/ge-string-stride-1.a68    |     7 +
 gcc/testsuite/algol68/execute/gen-flex-1.a68  |    10 +
 gcc/testsuite/algol68/execute/gen-heap-1.a68  |     6 +
 gcc/testsuite/algol68/execute/gen-heap-2.a68  |     6 +
 gcc/testsuite/algol68/execute/gen-heap-3.a68  |     5 +
 .../algol68/execute/gen-heap-bool-1.a68       |     6 +
 .../algol68/execute/gen-heap-int-1.a68        |     4 +
 .../algol68/execute/gen-heap-real-1.a68       |     4 +
 .../algol68/execute/gen-heap-struct-1.a68     |     4 +
 .../algol68/execute/gen-heap-struct-2.a68     |     5 +
 .../algol68/execute/gen-heap-struct-3.a68     |     5 +
 gcc/testsuite/algol68/execute/gen-loc-1.a68   |     6 +
 gcc/testsuite/algol68/execute/gen-loc-2.a68   |     6 +
 gcc/testsuite/algol68/execute/gen-loc-3.a68   |     5 +
 gcc/testsuite/algol68/execute/gen-loc-4.a68   |     8 +
 .../algol68/execute/gen-multiple-1.a68        |     5 +
 gcc/testsuite/algol68/execute/gen-union-1.a68 |    17 +
 gcc/testsuite/algol68/execute/gen-union-2.a68 |    20 +
 gcc/testsuite/algol68/execute/gen-union-3.a68 |    14 +
 gcc/testsuite/algol68/execute/goto-1.a68      |     7 +
 gcc/testsuite/algol68/execute/goto-2.a68      |     5 +
 gcc/testsuite/algol68/execute/goto-3.a68      |     9 +
 gcc/testsuite/algol68/execute/goto-4.a68      |     9 +
 gcc/testsuite/algol68/execute/goto-5.a68      |    20 +
 gcc/testsuite/algol68/execute/gt-int-1.a68    |    10 +
 .../algol68/execute/gt-string-stride-1.a68    |     7 +
 gcc/testsuite/algol68/execute/i-1.a68         |     6 +
 gcc/testsuite/algol68/execute/i-2.a68         |     6 +
 .../algol68/execute/identification-1.a68      |     6 +
 .../algol68/execute/identification-2.a68      |    14 +
 .../execute/identity-declaration-1.a68        |     6 +
 .../execute/identity-declaration-2.a68        |     6 +
 .../execute/identity-declaration-3.a68        |     6 +
 .../execute/identity-declaration-4.a68        |     5 +
 .../execute/identity-declaration-5.a68        |     5 +
 .../identity-declaration-multiple-1.a68       |     4 +
 .../identity-declaration-multiple-2.a68       |     4 +
 .../identity-declaration-multiple-3.a68       |     6 +
 .../identity-declaration-multiple-5.a68       |     4 +
 .../identity-declaration-multiple-empty-1.a68 |     6 +
 .../identity-declaration-multiple-empty-2.a68 |    12 +
 .../identity-declaration-multiple-empty-3.a68 |     4 +
 .../identity-declaration-multiple-empty-4.a68 |     4 +
 .../execute/identity-declaration-struct-1.a68 |    10 +
 gcc/testsuite/algol68/execute/infinity-1.a68  |     4 +
 .../algol68/execute/le-ge-bits-1.a68          |    17 +
 gcc/testsuite/algol68/execute/le-int-1.a68    |    10 +
 .../algol68/execute/le-string-stride-1.a68    |     7 +
 .../algol68/execute/leng-shorten-bits-1.a68   |     7 +
 .../algol68/execute/leng-shorten-ints-1.a68   |    27 +
 .../algol68/execute/leng-shorten-reals-1.a68  |    17 +
 .../algol68/execute/lengths-shorths-1.a68     |     8 +
 gcc/testsuite/algol68/execute/lisp-1.a68      |    25 +
 gcc/testsuite/algol68/execute/lisp-2.a68      |    21 +
 gcc/testsuite/algol68/execute/ln-1.a68        |     8 +
 gcc/testsuite/algol68/execute/log-1.a68       |     8 +
 gcc/testsuite/algol68/execute/loop-1.a68      |     6 +
 gcc/testsuite/algol68/execute/loop-10.a68     |     5 +
 gcc/testsuite/algol68/execute/loop-11.a68     |     6 +
 gcc/testsuite/algol68/execute/loop-12.a68     |     5 +
 gcc/testsuite/algol68/execute/loop-13.a68     |     6 +
 gcc/testsuite/algol68/execute/loop-14.a68     |     7 +
 gcc/testsuite/algol68/execute/loop-2.a68      |     7 +
 gcc/testsuite/algol68/execute/loop-3.a68      |    14 +
 gcc/testsuite/algol68/execute/loop-4.a68      |    13 +
 gcc/testsuite/algol68/execute/loop-5.a68      |     7 +
 gcc/testsuite/algol68/execute/loop-6.a68      |     7 +
 gcc/testsuite/algol68/execute/loop-7.a68      |     5 +
 gcc/testsuite/algol68/execute/loop-8.a68      |     5 +
 gcc/testsuite/algol68/execute/loop-9.a68      |     5 +
 .../execute/loop-overflow-underflow.a68       |    55 +
 gcc/testsuite/algol68/execute/lt-int-1.a68    |    10 +
 .../algol68/execute/lt-string-stride-1.a68    |     7 +
 gcc/testsuite/algol68/execute/lwb-1.a68       |     6 +
 .../algol68/execute/mcgt/execute.exp          |    29 +
 .../algol68/execute/mcgt/mcgt-1.3a.a68        |     4 +
 .../algol68/execute/mcgt/mcgt-1.3c.a68        |     4 +
 .../algol68/execute/mcgt/mcgt-2.2.1a.a68      |     4 +
 .../algol68/execute/mcgt/mcgt-2.2.2a.a68      |     5 +
 .../algol68/execute/mcgt/mcgt-2.2.3a.a68      |     4 +
 .../algol68/execute/mcgt/mcgt-2.3a.a68        |     5 +
 .../algol68/execute/mcgt/mcgt-2.3b.a68        |     5 +
 .../algol68/execute/mcgt/mcgt-2.3c.a68        |     6 +
 .../algol68/execute/mcgt/mcgt-2.3e.a68        |     5 +
 .../algol68/execute/mcgt/mcgt-2.4.2a.a68      |     6 +
 .../algol68/execute/mcgt/mcgt-2.4.2b.a68      |    11 +
 .../algol68/execute/mcgt/mcgt-2.4.2c.a68      |     9 +
 .../algol68/execute/mcgt/mcgt-2.4.3a.a68      |     4 +
 .../algol68/execute/mcgt/mcgt-2.6a.a68        |     6 +
 .../algol68/execute/mcgt/mcgt-2.6b.a68        |     5 +
 .../algol68/execute/mcgt/mcgt-2.7d.a68        |     5 +
 .../algol68/execute/mcgt/mcgt-2.7e.a68        |     5 +
 .../algol68/execute/mcgt/mcgt-2.8a.a68        |     6 +
 .../algol68/execute/mcgt/mcgt-2.8b.a68        |     5 +
 .../algol68/execute/mcgt/mcgt-2.9.1a.a68      |     6 +
 .../algol68/execute/mcgt/mcgt-3.5.1a.a68      |    10 +
 .../algol68/execute/mcgt/mcgt-3.5d.a68        |     9 +
 .../algol68/execute/mcgt/mcgt-3.7.2a.a68      |     5 +
 .../algol68/execute/mcgt/mcgt-3.8.2a.a68      |    13 +
 .../algol68/execute/mcgt/mcgt-3.9.1b.a68      |    16 +
 .../algol68/execute/mcgt/mcgt-4.1.2a.a68      |     7 +
 .../algol68/execute/mcgt/mcgt-4.1.3a.a68      |     9 +
 .../algol68/execute/mcgt/mcgt-4.1.6a.a68      |     8 +
 .../algol68/execute/mcgt/mcgt-4.1.6b.a68      |     7 +
 .../algol68/execute/mcgt/mcgt-4.1.6c.a68      |     7 +
 .../algol68/execute/mcgt/mcgt-4.2.6a.a68      |     7 +
 .../algol68/execute/mcgt/mcgt-4.2.6b.a68      |     7 +
 .../algol68/execute/mcgt/mcgt-4.2.6d.a68      |    11 +
 .../algol68/execute/mcgt/mcgt-4.3.1a.a68      |     7 +
 .../algol68/execute/mcgt/mcgt-4.3.1b.a68      |    15 +
 .../algol68/execute/mcgt/mcgt-4.3.2a.a68      |     5 +
 .../algol68/execute/mcgt/mcgt-5.1.2a.a68      |    15 +
 .../algol68/execute/mcgt/mcgt-5.1.3a.a68      |    12 +
 .../algol68/execute/mcgt/mcgt-5.1.3c.a68      |    29 +
 .../algol68/execute/mcgt/mcgt-5.1.5a.a68      |    19 +
 .../algol68/execute/mcgt/mcgt-6.2.2a.a68      |     5 +
 .../algol68/execute/mcgt/mcgt-6.2.2b.a68      |     6 +
 .../algol68/execute/mcgt/mcgt-6.2.2c.a68      |     6 +
 .../algol68/execute/mcgt/mcgt-7.1.1a.a68      |     8 +
 .../algol68/execute/mcgt/mcgt-7.1.1b.a68      |    11 +
 .../algol68/execute/mcgt/mcgt-7.1.3a.a68      |     8 +
 .../algol68/execute/mcgt/mcgt-7.3.2a.a68      |    11 +
 .../algol68/execute/mcgt/mcgt-7.3.6a.a68      |    23 +
 .../algol68/execute/mcgt/mcgt-7.3.6b.a68      |    12 +
 .../algol68/execute/mcgt/mcgt-7.5.3a.a68      |     8 +
 gcc/testsuite/algol68/execute/mcts/clau02.a68 |    23 +
 gcc/testsuite/algol68/execute/mcts/clau04.a68 |    11 +
 gcc/testsuite/algol68/execute/mcts/clau05.a68 |    11 +
 gcc/testsuite/algol68/execute/mcts/clau07.a68 |    21 +
 gcc/testsuite/algol68/execute/mcts/clau08.a68 |   159 +
 gcc/testsuite/algol68/execute/mcts/clau09.a68 |    82 +
 gcc/testsuite/algol68/execute/mcts/coer01.a68 |     4 +
 gcc/testsuite/algol68/execute/mcts/coer02.a68 |    20 +
 gcc/testsuite/algol68/execute/mcts/coer03.a68 |    53 +
 gcc/testsuite/algol68/execute/mcts/coer07.a68 |    14 +
 gcc/testsuite/algol68/execute/mcts/coer08.a68 |     9 +
 gcc/testsuite/algol68/execute/mcts/coer09.a68 |    16 +
 gcc/testsuite/algol68/execute/mcts/coer10.a68 |    62 +
 gcc/testsuite/algol68/execute/mcts/coer11.a68 |    37 +
 gcc/testsuite/algol68/execute/mcts/coer13.a68 |    19 +
 gcc/testsuite/algol68/execute/mcts/coer14.a68 |     4 +
 gcc/testsuite/algol68/execute/mcts/decl01.a68 |     8 +
 gcc/testsuite/algol68/execute/mcts/decl03.a68 |    40 +
 gcc/testsuite/algol68/execute/mcts/decl04.a68 |     3 +
 gcc/testsuite/algol68/execute/mcts/decl05.a68 |     7 +
 .../algol68/execute/mcts/execute.exp          |    29 +
 gcc/testsuite/algol68/execute/mcts/flex01.a68 |    10 +
 gcc/testsuite/algol68/execute/mcts/flex02.a68 |    11 +
 gcc/testsuite/algol68/execute/mcts/idef01.a68 |     6 +
 gcc/testsuite/algol68/execute/mcts/idef02.a68 |     6 +
 gcc/testsuite/algol68/execute/mcts/idef03.a68 |     7 +
 gcc/testsuite/algol68/execute/mcts/idef04.a68 |    11 +
 gcc/testsuite/algol68/execute/mcts/idef05.a68 |     4 +
 gcc/testsuite/algol68/execute/mcts/idef06.a68 |    23 +
 gcc/testsuite/algol68/execute/mcts/idef07.a68 |     8 +
 gcc/testsuite/algol68/execute/mcts/idef11.a68 |    17 +
 gcc/testsuite/algol68/execute/mcts/idef12.a68 |    52 +
 gcc/testsuite/algol68/execute/mcts/idrl01.a68 |     7 +
 gcc/testsuite/algol68/execute/mcts/jump01.a68 |     9 +
 gcc/testsuite/algol68/execute/mcts/jump02.a68 |     7 +
 gcc/testsuite/algol68/execute/mcts/jump03.a68 |     5 +
 gcc/testsuite/algol68/execute/mcts/jump04.a68 |    11 +
 gcc/testsuite/algol68/execute/mcts/mdeq02.a68 |     8 +
 gcc/testsuite/algol68/execute/mcts/mdeq04.a68 |    17 +
 gcc/testsuite/algol68/execute/mcts/misc07.a68 |   207 +
 gcc/testsuite/algol68/execute/mcts/null01.a68 |     5 +
 gcc/testsuite/algol68/execute/mcts/null02.a68 |     3 +
 gcc/testsuite/algol68/execute/mcts/null03.a68 |     4 +
 gcc/testsuite/algol68/execute/mcts/null04.a68 |     2 +
 gcc/testsuite/algol68/execute/mcts/null05.a68 |     2 +
 gcc/testsuite/algol68/execute/mcts/null06.a68 |     4 +
 gcc/testsuite/algol68/execute/mcts/null07.a68 |     2 +
 gcc/testsuite/algol68/execute/mcts/null08.a68 |     3 +
 gcc/testsuite/algol68/execute/mcts/null09.a68 |     3 +
 gcc/testsuite/algol68/execute/mcts/numr07.a68 |    81 +
 gcc/testsuite/algol68/execute/mcts/oper01.a68 |     8 +
 gcc/testsuite/algol68/execute/mcts/oper02.a68 |     6 +
 gcc/testsuite/algol68/execute/mcts/oper03.a68 |    12 +
 gcc/testsuite/algol68/execute/mcts/oper04.a68 |    21 +
 gcc/testsuite/algol68/execute/mcts/oper05.a68 |     8 +
 gcc/testsuite/algol68/execute/mcts/oper07.a68 |    12 +
 gcc/testsuite/algol68/execute/mcts/oper08.a68 |    18 +
 gcc/testsuite/algol68/execute/mcts/oper09.a68 |    65 +
 gcc/testsuite/algol68/execute/mcts/oper10.a68 |    87 +
 gcc/testsuite/algol68/execute/mcts/oper11.a68 |   141 +
 gcc/testsuite/algol68/execute/mcts/oper14.a68 |    32 +
 gcc/testsuite/algol68/execute/mcts/oper16.a68 |   866 +
 gcc/testsuite/algol68/execute/mcts/simp01.a68 |     8 +
 gcc/testsuite/algol68/execute/mcts/simp02.a68 |    13 +
 gcc/testsuite/algol68/execute/mcts/simp03.a68 |    12 +
 gcc/testsuite/algol68/execute/mcts/simp04.a68 |    46 +
 gcc/testsuite/algol68/execute/mcts/simp05.a68 |    28 +
 gcc/testsuite/algol68/execute/mcts/simp07.a68 |    14 +
 gcc/testsuite/algol68/execute/mcts/simp08.a68 |    35 +
 gcc/testsuite/algol68/execute/mcts/simp09.a68 |    17 +
 gcc/testsuite/algol68/execute/mcts/simp10.a68 |     6 +
 gcc/testsuite/algol68/execute/mcts/simp11.a68 |    36 +
 gcc/testsuite/algol68/execute/mcts/simp13.a68 |    13 +
 gcc/testsuite/algol68/execute/mcts/stow02.a68 |    15 +
 gcc/testsuite/algol68/execute/mcts/stow06.a68 |    30 +
 gcc/testsuite/algol68/execute/minus-int-1.a68 |    10 +
 gcc/testsuite/algol68/execute/minusab-1.a68   |    32 +
 gcc/testsuite/algol68/execute/minusab-2.a68   |    20 +
 gcc/testsuite/algol68/execute/minusab-3.a68   |     5 +
 gcc/testsuite/algol68/execute/minusab-4.a68   |     6 +
 gcc/testsuite/algol68/execute/mod-int-1.a68   |    10 +
 gcc/testsuite/algol68/execute/modab-1.a68     |    10 +
 gcc/testsuite/algol68/execute/modab-2.a68     |     5 +
 .../algol68/execute/mode-indication-1.a68     |    10 +
 gcc/testsuite/algol68/execute/mult-char-1.a68 |     5 +
 gcc/testsuite/algol68/execute/mult-int-1.a68  |    10 +
 .../algol68/execute/mult-string-1.a68         |    13 +
 .../algol68/execute/mult-string-2.a68         |    13 +
 .../algol68/execute/mult-string-3.a68         |    13 +
 .../algol68/execute/mult-string-4.a68         |     4 +
 gcc/testsuite/algol68/execute/multab-1.a68    |    31 +
 gcc/testsuite/algol68/execute/multab-2.a68    |    31 +
 gcc/testsuite/algol68/execute/multab-3.a68    |     6 +
 .../algol68/execute/mutual-recursion-1.a68    |     6 +
 gcc/testsuite/algol68/execute/ne-bits-1.a68   |     9 +
 .../algol68/execute/ne-char-char-1.a68        |     3 +
 gcc/testsuite/algol68/execute/ne-int-1.a68    |    10 +
 gcc/testsuite/algol68/execute/ne-string-1.a68 |    15 +
 gcc/testsuite/algol68/execute/neg-int-1.a68   |    10 +
 gcc/testsuite/algol68/execute/not-bits-1.a68  |    13 +
 gcc/testsuite/algol68/execute/odd-1.a68       |     8 +
 gcc/testsuite/algol68/execute/op-1.a68        |     5 +
 gcc/testsuite/algol68/execute/op-2.a68        |     4 +
 gcc/testsuite/algol68/execute/op-3.a68        |     9 +
 .../execute/operator-declaration-1.a68        |    13 +
 gcc/testsuite/algol68/execute/or-bits-1.a68   |    18 +
 gcc/testsuite/algol68/execute/orf-1.a68       |     4 +
 gcc/testsuite/algol68/execute/over-int-1.a68  |    10 +
 gcc/testsuite/algol68/execute/overab-1.a68    |    12 +
 gcc/testsuite/algol68/execute/overab-2.a68    |     5 +
 .../algol68/execute/particular-program-1.a68  |     4 +
 gcc/testsuite/algol68/execute/plus-char-1.a68 |     4 +
 gcc/testsuite/algol68/execute/plus-int-1.a68  |    10 +
 .../algol68/execute/plus-string-1.a68         |    11 +
 .../algol68/execute/plus-string-2.a68         |    11 +
 .../algol68/execute/plus-string-stride-1.a68  |     7 +
 gcc/testsuite/algol68/execute/plusab-1.a68    |    34 +
 gcc/testsuite/algol68/execute/plusab-2.a68    |    20 +
 gcc/testsuite/algol68/execute/plusab-3.a68    |     5 +
 gcc/testsuite/algol68/execute/plusab-4.a68    |     6 +
 .../algol68/execute/plusab-string-1.a68       |     7 +
 .../algol68/execute/plusto-char-1.a68         |     7 +
 .../algol68/execute/plusto-string-1.a68       |     6 +
 .../algol68/execute/posix-argc-argv-1.a68     |     7 +
 .../algol68/execute/posix-fopen-1.a68         |     4 +
 .../algol68/execute/posix-fputc-fputs-1.a68   |     8 +
 .../algol68/execute/posix-getenv-1.a68        |     4 +
 .../algol68/execute/posix-perror-1.a68        |     8 +
 .../algol68/execute/posix-putchar-1.a68       |     6 +
 .../algol68/execute/posix-stdinouterr-1.a68   |     5 +
 .../algol68/execute/posix-strerror-1.a68      |     4 +
 .../algol68/execute/posix-stride-1.a68        |    14 +
 gcc/testsuite/algol68/execute/pow-int-1.a68   |    10 +
 gcc/testsuite/algol68/execute/pow-real-1.a68  |     7 +
 gcc/testsuite/algol68/execute/proc-1.a68      |     4 +
 gcc/testsuite/algol68/execute/proc-10.a68     |     4 +
 gcc/testsuite/algol68/execute/proc-12.a68     |     6 +
 gcc/testsuite/algol68/execute/proc-13.a68     |     6 +
 gcc/testsuite/algol68/execute/proc-14.a68     |     8 +
 gcc/testsuite/algol68/execute/proc-15.a68     |     8 +
 gcc/testsuite/algol68/execute/proc-16.a68     |     8 +
 gcc/testsuite/algol68/execute/proc-17.a68     |    11 +
 gcc/testsuite/algol68/execute/proc-18.a68     |     6 +
 gcc/testsuite/algol68/execute/proc-19.a68     |     5 +
 gcc/testsuite/algol68/execute/proc-2.a68      |     6 +
 gcc/testsuite/algol68/execute/proc-20.a68     |     5 +
 gcc/testsuite/algol68/execute/proc-21.a68     |     8 +
 gcc/testsuite/algol68/execute/proc-22.a68     |     7 +
 gcc/testsuite/algol68/execute/proc-23.a68     |     8 +
 gcc/testsuite/algol68/execute/proc-25.a68     |     8 +
 gcc/testsuite/algol68/execute/proc-26.a68     |     6 +
 gcc/testsuite/algol68/execute/proc-27.a68     |     5 +
 gcc/testsuite/algol68/execute/proc-28.a68     |    10 +
 gcc/testsuite/algol68/execute/proc-29.a68     |     5 +
 gcc/testsuite/algol68/execute/proc-3.a68      |     4 +
 gcc/testsuite/algol68/execute/proc-4.a68      |     5 +
 gcc/testsuite/algol68/execute/proc-5.a68      |     5 +
 gcc/testsuite/algol68/execute/proc-6.a68      |     6 +
 gcc/testsuite/algol68/execute/proc-7.a68      |     5 +
 gcc/testsuite/algol68/execute/proc-8.a68      |     4 +
 .../algol68/execute/procedured-goto-1.a68     |    11 +
 gcc/testsuite/algol68/execute/quine.a68       |     2 +
 gcc/testsuite/algol68/execute/random-1.a68    |     7 +
 gcc/testsuite/algol68/execute/re-im-1.a68     |     8 +
 .../algol68/execute/rela-string-1.a68         |     7 +
 gcc/testsuite/algol68/execute/repr-1.a68      |     3 +
 gcc/testsuite/algol68/execute/round-1.a68     |     8 +
 .../algol68/execute/row-display-1.a68         |    13 +
 .../algol68/execute/row-display-2.a68         |    13 +
 .../algol68/execute/row-display-3.a68         |    15 +
 .../algol68/execute/row-display-4.a68         |    16 +
 .../algol68/execute/row-display-5.a68         |    10 +
 gcc/testsuite/algol68/execute/rowing-1.a68    |     5 +
 gcc/testsuite/algol68/execute/rowing-10.a68   |     8 +
 gcc/testsuite/algol68/execute/rowing-11.a68   |     9 +
 gcc/testsuite/algol68/execute/rowing-12.a68   |     6 +
 gcc/testsuite/algol68/execute/rowing-13.a68   |     6 +
 gcc/testsuite/algol68/execute/rowing-2.a68    |     6 +
 gcc/testsuite/algol68/execute/rowing-3.a68    |     7 +
 gcc/testsuite/algol68/execute/rowing-4.a68    |     8 +
 gcc/testsuite/algol68/execute/rowing-5.a68    |     8 +
 gcc/testsuite/algol68/execute/rowing-6.a68    |     5 +
 gcc/testsuite/algol68/execute/rowing-7.a68    |     6 +
 gcc/testsuite/algol68/execute/rowing-8.a68    |    12 +
 gcc/testsuite/algol68/execute/rowing-9.a68    |     7 +
 gcc/testsuite/algol68/execute/selection-1.a68 |     7 +
 gcc/testsuite/algol68/execute/selection-2.a68 |    14 +
 gcc/testsuite/algol68/execute/selection-3.a68 |    12 +
 gcc/testsuite/algol68/execute/selection-4.a68 |    19 +
 gcc/testsuite/algol68/execute/selection-5.a68 |     6 +
 .../algol68/execute/selection-multiple-1.a68  |    12 +
 .../algol68/execute/selection-multiple-2.a68  |    18 +
 .../algol68/execute/serial-clause-1.a68       |     8 +
 .../algol68/execute/serial-clause-10.a68      |     5 +
 .../algol68/execute/serial-clause-2.a68       |     7 +
 .../algol68/execute/serial-clause-3.a68       |     5 +
 .../algol68/execute/serial-clause-4.a68       |     7 +
 .../algol68/execute/serial-clause-5.a68       |     7 +
 .../algol68/execute/serial-clause-6.a68       |    10 +
 .../algol68/execute/serial-clause-7.a68       |    10 +
 .../algol68/execute/serial-clause-8.a68       |    10 +
 .../algol68/execute/serial-clause-9.a68       |     9 +
 .../algol68/execute/serial-dsa-1.a68          |    18 +
 .../algol68/execute/serial-dsa-2.a68          |     5 +
 .../algol68/execute/serial-dsa-3.a68          |    12 +
 .../algol68/execute/serial-dsa-4.a68          |     4 +
 .../algol68/execute/serial-dsa-5.a68          |     3 +
 .../algol68/execute/serial-dsa-6.a68          |     4 +
 gcc/testsuite/algol68/execute/sign-int-1.a68  |    28 +
 gcc/testsuite/algol68/execute/sign-real-1.a68 |    17 +
 gcc/testsuite/algol68/execute/sin-1.a68       |     8 +
 gcc/testsuite/algol68/execute/skip-1.a68      |    13 +
 gcc/testsuite/algol68/execute/skip-2.a68      |     7 +
 .../algol68/execute/skip-struct-1.a68         |     7 +
 .../algol68/execute/slice-indexing-1.a68      |    10 +
 .../algol68/execute/slice-indexing-2.a68      |    10 +
 .../algol68/execute/slice-indexing-3.a68      |    10 +
 .../algol68/execute/slice-indexing-4.a68      |    10 +
 .../algol68/execute/slice-indexing-5.a68      |     4 +
 .../algol68/execute/slice-indexing-6.a68      |     5 +
 .../algol68/execute/slice-indexing-7.a68      |     4 +
 gcc/testsuite/algol68/execute/sqrt-1.a68      |     8 +
 gcc/testsuite/algol68/execute/string-1.a68    |     6 +
 gcc/testsuite/algol68/execute/string-2.a68    |    13 +
 gcc/testsuite/algol68/execute/string-4.a68    |     6 +
 .../algol68/execute/string-break-1.a68        |     8 +
 .../algol68/execute/struct-self-1.a68         |     5 +
 .../algol68/execute/struct-self-2.a68         |     6 +
 .../algol68/execute/struct-self-3.a68         |     7 +
 .../algol68/execute/structure-display-1.a68   |     9 +
 .../algol68/execute/structure-display-2.a68   |     6 +
 .../algol68/execute/structure-display-3.a68   |     7 +
 .../algol68/execute/structure-display-4.a68   |     8 +
 .../algol68/execute/structure-display-5.a68   |    10 +
 gcc/testsuite/algol68/execute/tan-1.a68       |     8 +
 .../algol68/execute/timesab-string-1.a68      |     7 +
 gcc/testsuite/algol68/execute/trimmer-1.a68   |     7 +
 gcc/testsuite/algol68/execute/trimmer-10.a68  |    14 +
 gcc/testsuite/algol68/execute/trimmer-2.a68   |     7 +
 gcc/testsuite/algol68/execute/trimmer-3.a68   |     7 +
 gcc/testsuite/algol68/execute/trimmer-4.a68   |     7 +
 gcc/testsuite/algol68/execute/trimmer-5.a68   |     7 +
 gcc/testsuite/algol68/execute/trimmer-6.a68   |     7 +
 gcc/testsuite/algol68/execute/trimmer-7.a68   |     7 +
 gcc/testsuite/algol68/execute/trimmer-8.a68   |     9 +
 gcc/testsuite/algol68/execute/trimmer-9.a68   |     7 +
 .../algol68/execute/trimmer-matrix-1.a68      |     8 +
 .../algol68/execute/trimmer-matrix-2.a68      |     8 +
 .../algol68/execute/trimmer-matrix-3.a68      |     9 +
 .../algol68/execute/trimmer-matrix-4.a68      |     9 +
 .../algol68/execute/trimmer-matrix-5.a68      |     9 +
 .../algol68/execute/trimmer-matrix-6.a68      |     9 +
 .../algol68/execute/trimmer-name-1.a68        |     7 +
 gcc/testsuite/algol68/execute/undefined-1.a68 |    10 +
 gcc/testsuite/algol68/execute/undefined-2.a68 |     9 +
 gcc/testsuite/algol68/execute/undefined-3.a68 |     6 +
 gcc/testsuite/algol68/execute/undefined-4.a68 |     8 +
 gcc/testsuite/algol68/execute/undefined-5.a68 |     9 +
 gcc/testsuite/algol68/execute/uniting-1.a68   |    11 +
 gcc/testsuite/algol68/execute/uniting-2.a68   |    11 +
 gcc/testsuite/algol68/execute/uniting-3.a68   |    11 +
 gcc/testsuite/algol68/execute/uniting-4.a68   |     5 +
 .../algol68/execute/up-down-bits-1.a68        |    33 +
 gcc/testsuite/algol68/execute/upb-1.a68       |     6 +
 gcc/testsuite/algol68/execute/vacuum-1.a68    |     4 +
 .../execute/variable-declaration-1.a68        |     5 +
 .../execute/variable-declaration-2.a68        |     5 +
 .../execute/variable-declaration-3.a68        |     5 +
 .../execute/variable-declaration-4.a68        |     5 +
 .../execute/variable-declaration-5.a68        |     5 +
 .../execute/variable-declaration-6.a68        |     5 +
 .../execute/variable-declaration-heap-1.a68   |     4 +
 .../execute/variable-declaration-heap-2.a68   |     4 +
 .../variable-declaration-multiple-1.a68       |     5 +
 .../variable-declaration-multiple-2.a68       |     6 +
 .../variable-declaration-multiple-3.a68       |     6 +
 .../variable-declaration-multiple-4.a68       |     6 +
 .../variable-declaration-multiple-5.a68       |     8 +
 .../variable-declaration-multiple-6.a68       |     8 +
 .../variable-declaration-multiple-7.a68       |     8 +
 .../variable-declaration-multiple-8.a68       |    10 +
 .../variable-declaration-multiple-9.a68       |     4 +
 gcc/testsuite/algol68/execute/voiding-1.a68   |     4 +
 gcc/testsuite/algol68/execute/widening-1.a68  |     6 +
 gcc/testsuite/algol68/execute/widening-2.a68  |     6 +
 .../algol68/execute/widening-bits-1.a68       |     7 +
 .../algol68/execute/widening-bits-2.a68       |     7 +
 .../algol68/execute/widening-bits-3.a68       |     7 +
 gcc/testsuite/algol68/execute/xor-bits-1.a68  |    18 +
 gcc/testsuite/lib/algol68-dg.exp              |    57 +
 gcc/testsuite/lib/algol68-torture.exp         |   430 +
 gcc/testsuite/lib/algol68.exp                 |   217 +
 include/dwarf2.h                              |     2 +
 libga68/Makefile.am                           |   122 +
 libga68/Makefile.in                           |   906 +
 libga68/README                                |     2 +
 libga68/aclocal.m4                            |  1200 +
 libga68/config.h.in                           |    97 +
 libga68/configure                             | 19735 ++++++++++++++++
 libga68/configure.ac                          |   420 +
 libga68/ga68-alloc.c                          |   114 +
 libga68/ga68-error.c                          |   151 +
 libga68/ga68-posix.c                          |   403 +
 libga68/ga68-standenv.c                       |    48 +
 libga68/ga68-unistr.c                         |   615 +
 libga68/ga68.h                                |   119 +
 libga68/libga68.c                             |    52 +
 libga68/libga68.spec.in                       |    11 +
 742 files changed, 78289 insertions(+), 37 deletions(-)
 create mode 100644 gcc/algol68/Make-lang.in
 create mode 100644 gcc/algol68/README
 create mode 100644 gcc/algol68/a68-diagnostics.cc
 create mode 100644 gcc/algol68/a68-lang.cc
 create mode 100644 gcc/algol68/a68-low-bits.cc
 create mode 100644 gcc/algol68/a68-low-bools.cc
 create mode 100644 gcc/algol68/a68-low-builtins.cc
 create mode 100644 gcc/algol68/a68-low-chars.cc
 create mode 100644 gcc/algol68/a68-low-clauses.cc
 create mode 100644 gcc/algol68/a68-low-coercions.cc
 create mode 100644 gcc/algol68/a68-low-complex.cc
 create mode 100644 gcc/algol68/a68-low-decls.cc
 create mode 100644 gcc/algol68/a68-low-generator.cc
 create mode 100644 gcc/algol68/a68-low-ints.cc
 create mode 100644 gcc/algol68/a68-low-misc.cc
 create mode 100644 gcc/algol68/a68-low-moids.cc
 create mode 100644 gcc/algol68/a68-low-multiples.cc
 create mode 100644 gcc/algol68/a68-low-posix.cc
 create mode 100644 gcc/algol68/a68-low-prelude.cc
 create mode 100644 gcc/algol68/a68-low-procs.cc
 create mode 100644 gcc/algol68/a68-low-ranges.cc
 create mode 100644 gcc/algol68/a68-low-reals.cc
 create mode 100644 gcc/algol68/a68-low-refs.cc
 create mode 100644 gcc/algol68/a68-low-runtime.cc
 create mode 100644 gcc/algol68/a68-low-runtime.def
 create mode 100644 gcc/algol68/a68-low-strings.cc
 create mode 100644 gcc/algol68/a68-low-structs.cc
 create mode 100644 gcc/algol68/a68-low-unions.cc
 create mode 100644 gcc/algol68/a68-low-units.cc
 create mode 100644 gcc/algol68/a68-low.cc
 create mode 100644 gcc/algol68/a68-moids-diagnostics.cc
 create mode 100644 gcc/algol68/a68-moids-misc.cc
 create mode 100644 gcc/algol68/a68-moids-to-string.cc
 create mode 100644 gcc/algol68/a68-parser-attrs.def
 create mode 100644 gcc/algol68/a68-parser-bottom-up.cc
 create mode 100644 gcc/algol68/a68-parser-brackets.cc
 create mode 100644 gcc/algol68/a68-parser-debug.cc
 create mode 100644 gcc/algol68/a68-parser-extract.cc
 create mode 100644 gcc/algol68/a68-parser-keywords.cc
 create mode 100644 gcc/algol68/a68-parser-modes.cc
 create mode 100644 gcc/algol68/a68-parser-moids-check.cc
 create mode 100644 gcc/algol68/a68-parser-moids-coerce.cc
 create mode 100644 gcc/algol68/a68-parser-moids-equivalence.cc
 create mode 100644 gcc/algol68/a68-parser-prelude.cc
 create mode 100644 gcc/algol68/a68-parser-scanner.cc
 create mode 100644 gcc/algol68/a68-parser-scope.cc
 create mode 100644 gcc/algol68/a68-parser-serial-dsa.cc
 create mode 100644 gcc/algol68/a68-parser-taxes.cc
 create mode 100644 gcc/algol68/a68-parser-top-down.cc
 create mode 100644 gcc/algol68/a68-parser-victal.cc
 create mode 100644 gcc/algol68/a68-parser.cc
 create mode 100644 gcc/algol68/a68-postulates.cc
 create mode 100644 gcc/algol68/a68-tree.def
 create mode 100644 gcc/algol68/a68-types.h
 create mode 100644 gcc/algol68/a68-unistr.c
 create mode 100644 gcc/algol68/a68.h
 create mode 100644 gcc/algol68/a68spec.cc
 create mode 100644 gcc/algol68/algol68-target.def
 create mode 100644 gcc/algol68/config-lang.in
 create mode 100644 gcc/algol68/ga68-internals.texi
 create mode 100644 gcc/algol68/ga68.texi
 create mode 100644 gcc/algol68/ga68.vw
 create mode 100644 gcc/algol68/lang-specs.h
 create mode 100644 gcc/algol68/lang.opt
 create mode 100644 gcc/algol68/lang.opt.urls
 create mode 100644 gcc/testsuite/algol68/README.mcts
 create mode 100644 gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68
 create mode 100644 gcc/testsuite/algol68/compile/a68includes/goodbye.a68
 create mode 100644 gcc/testsuite/algol68/compile/a68includes/hello-supper.a68
 create mode 100644 gcc/testsuite/algol68/compile/a68includes/hello.a68
 create mode 100644 gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/balancing-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/bold-taggle-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/char-break-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/compile.exp
 create mode 100644 gcc/testsuite/algol68/compile/conditional-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-bold-taggle-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-coercion-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-coercion-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-coercion-flex-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-conformance-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-contraction-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-contraction-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-incestuous-union-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-label-after-decl-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-nestable-comments-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-nested-comment-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-7.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-upper-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-7.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-8.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-9.a68
 create mode 100644 gcc/testsuite/algol68/compile/hidden-operators-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/implicit-widening-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/include-supper.a68
 create mode 100644 gcc/testsuite/algol68/compile/include.a68
 create mode 100644 gcc/testsuite/algol68/compile/labeled-unit-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcgt-1.3b.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcgt-7.1.3a-bis.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/compile.exp
 create mode 100644 gcc/testsuite/algol68/compile/mcts/decl06.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/idef10.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/mdeq01.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/mdeq03.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/mdeq05.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/mdeq06.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/oper05.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/oper06.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/oper12.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/oper15.a68
 create mode 100644 gcc/testsuite/algol68/compile/nested-comment-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/nested-comment-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/operators-firmly-related.a68
 create mode 100644 gcc/testsuite/algol68/compile/recursive-modes-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/recursive-modes-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/serial-clause-jump-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/snobol.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-10.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-11.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-12.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-13.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-7.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-8.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-9.a68
 create mode 100644 gcc/testsuite/algol68/compile/uniting-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/upper-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-7.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-voiding-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-voiding-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-bool-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-int-negative-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-int-negative-gnu-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/acos-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/affirm-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/and-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/andf-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ascription-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/asin-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assert-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-multiple-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-struct-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-struct-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/atan-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/balancing-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/balancing-rows-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/bin-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/bin-negative-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/bin-negative-gnu-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/boolops-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/call-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/call-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/case-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/case-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/case-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/case-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/closed-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/closed-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/conj-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/cos-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/declarer-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/declarer-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/deprocedure-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/deprocedure-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/div-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/divab-real-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/elem-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/elems-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/elems-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/entier-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-char-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/execute.exp
 create mode 100644 gcc/testsuite/algol68/execute/factorial-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/flat-assignation-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/flat-assignation-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/formula-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/formula-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/fsize-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ge-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ge-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-flex-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-bool-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-real-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-struct-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-struct-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-struct-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-loc-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-loc-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-loc-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-loc-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-union-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-union-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-union-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/gt-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gt-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/i-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/i-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identification-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/identification-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-struct-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/infinity-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/le-ge-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/le-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/le-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/leng-shorten-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/leng-shorten-ints-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/leng-shorten-reals-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lengths-shorths-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lisp-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lisp-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/ln-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/log-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-11.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-12.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-13.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-14.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-overflow-underflow.a68
 create mode 100644 gcc/testsuite/algol68/execute/lt-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lt-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lwb-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/execute.exp
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-1.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-1.3c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.3b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.3c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.3e.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.6a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.6b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.7d.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.7e.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.8a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.8b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.9.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.5.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.5d.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.7.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.8.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.9.1b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6d.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.5a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.5.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer10.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer11.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer13.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer14.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/decl01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/decl03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/decl04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/decl05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/execute.exp
 create mode 100644 gcc/testsuite/algol68/execute/mcts/flex01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/flex02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef06.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef11.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef12.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idrl01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/jump01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/jump02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/jump03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/jump04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/mdeq02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/mdeq04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/misc07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null06.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/numr07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper10.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper11.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper14.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper16.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp10.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp11.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp13.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/stow02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/stow06.a68
 create mode 100644 gcc/testsuite/algol68/execute/minus-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/minusab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/minusab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/minusab-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/minusab-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/mod-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/modab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/modab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/mode-indication-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-string-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-string-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-string-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/multab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/multab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/multab-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/mutual-recursion-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ne-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ne-char-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ne-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ne-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/neg-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/not-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/odd-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/op-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/op-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/op-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/operator-declaration-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/or-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/orf-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/over-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/overab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/overab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/particular-program-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-string-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusto-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusto-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-argc-argv-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-fopen-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-fputc-fputs-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-getenv-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-perror-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-putchar-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-stdinouterr-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-strerror-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/pow-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/pow-real-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-12.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-13.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-14.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-15.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-16.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-17.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-18.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-19.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-20.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-21.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-22.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-23.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-25.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-26.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-27.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-28.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-29.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/procedured-goto-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/quine.a68
 create mode 100644 gcc/testsuite/algol68/execute/random-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/re-im-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/rela-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/repr-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/round-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-11.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-12.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-13.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-multiple-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/sign-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/sign-real-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/sin-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/skip-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/skip-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/skip-struct-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/sqrt-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/string-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/string-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/string-break-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/struct-self-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/struct-self-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/struct-self-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/tan-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/timesab-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-name-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/uniting-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/uniting-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/uniting-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/uniting-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/up-down-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/upb-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/vacuum-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-heap-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-heap-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/voiding-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-bits-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-bits-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/xor-bits-1.a68
 create mode 100644 gcc/testsuite/lib/algol68-dg.exp
 create mode 100644 gcc/testsuite/lib/algol68-torture.exp
 create mode 100644 gcc/testsuite/lib/algol68.exp
 create mode 100644 libga68/Makefile.am
 create mode 100644 libga68/Makefile.in
 create mode 100644 libga68/README
 create mode 100644 libga68/aclocal.m4
 create mode 100644 libga68/config.h.in
 create mode 100755 libga68/configure
 create mode 100644 libga68/configure.ac
 create mode 100644 libga68/ga68-alloc.c
 create mode 100644 libga68/ga68-error.c
 create mode 100644 libga68/ga68-posix.c
 create mode 100644 libga68/ga68-standenv.c
 create mode 100644 libga68/ga68-unistr.c
 create mode 100644 libga68/ga68.h
 create mode 100644 libga68/libga68.c
 create mode 100644 libga68/libga68.spec.in

-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 01/47] a68: top-level misc files
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 02/47] a68: build system Jose E. Marchesi
                   ` (46 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit updates a few administrative files in the top-level
directory.

The MAINTAINERS file is updated with new entries for the Algol 68
front-end and the libga68 run-time library.

SECURITY.txt is updated to add libga68 to the list of the other
run-time libraries.

contrib/gcc-changelog/git_commit.py is updated so it knows about the
'algol68' bugzilla component.

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

ChangeLog

	* MAINTAINERS: Add Algol 68 subsystems.
	* SECURITY.txt: add libga68 to list of libraries.

contrib/ChangeLog

	* gcc-changelog/git_commit.py: add algol68 bugzilla
	component.
---
 MAINTAINERS                         | 2 ++
 SECURITY.txt                        | 1 +
 contrib/gcc-changelog/git_commit.py | 1 +
 3 files changed, 4 insertions(+)

diff --git a/MAINTAINERS b/MAINTAINERS
index 05598811322..0ba226df074 100644
--- a/MAINTAINERS
+++ b/MAINTAINERS
@@ -172,6 +172,7 @@ objective-c/c++         Mike Stump              <mikestump@comcast.net>
 objective-c/c++         Iain Sandoe             <iain@sandoe.co.uk>
 Rust                    Arthur Cohen            <arthur.cohen@embecosm.com>
 Rust                    Philip Herron           <herron.philip@googlemail.com>
+Algol 68                Jose E. Marchesi        <jemarch@gnu.org>
 
                         Various Maintainers
 
@@ -180,6 +181,7 @@ libcpp                  Per Bothner             <per@bothner.com>
 libcpp                  All C and C++ front end maintainers
 libcpp                  David Malcolm           <dmalcolm@redhat.com>
 fp-bit                  Ian Lance Taylor        <ian@airs.com>
+libga68                 Jose E. Marchesi        <jemarch@gnu.org>
 libgcc                  Ian Lance Taylor        <ian@airs.com>
 libgo                   Ian Lance Taylor        <ian@airs.com>
 libgomp                 Jakub Jelinek           <jakub@redhat.com>
diff --git a/SECURITY.txt b/SECURITY.txt
index b38425ea223..ba3e42ac723 100644
--- a/SECURITY.txt
+++ b/SECURITY.txt
@@ -85,6 +85,7 @@ Language runtime libraries
     * libcpp
     * libdecnumber
     * libffi
+    * liga68
     * libgcc
     * libgfortran
     * libgm2
diff --git a/contrib/gcc-changelog/git_commit.py b/contrib/gcc-changelog/git_commit.py
index e0c46be8ab2..7da73e5869f 100755
--- a/contrib/gcc-changelog/git_commit.py
+++ b/contrib/gcc-changelog/git_commit.py
@@ -88,6 +88,7 @@ default_changelog_locations = {
 
 bug_components = {
     'ada',
+    'algol68',
     'analyzer',
     'boehm-gc',
     'bootstrap',
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 02/47] a68: build system
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 01/47] a68: top-level misc files Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 03/47] a68: build system (regenerated files) Jose E. Marchesi
                   ` (45 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds support for building the Algol 68 front-end to the
build system.

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

ChangeLog

	* Makefile.def (libga68): New module.
	(configure-target-libga68): Likewise.
	* Makefile.tpl (GA68): Define.
	(GA68_FOR_BUILD): Likewise.
	(GA68FLAGS): Likewise.
	* configure.ac (--enable-libga68): New option.
	(--enble-algol68-gc): Likewise.
	(GA68): Subst.
	(GA68FLAGS): Likewise.
	Invoke ACX_PROG_GA68.

config/ChangeLog

	* acx.m4 (ACX_PROG_GA68): New defun.

gcc/ChangeLog

	* algol68/Make-lang.in: New file.
	* algol68/config-lang.in: Likewise.
	* config.gcc (tm_algol68_file): Define.
	(algol68_target_objs): Likewise.
	(target_has_targetalgol68m): Likewise.
	* configure.ac (tm_algol68_file_list): Subst.
	(tm_algol68_include_list): Likewise.
	(algol68_target_objs): Likewise.
	* Makefile.in (tm_algol68_file_list): Define.
	(tm_algol68_include_list): Likewise.
	(TM_ALGOL68_H): Likewise.
	(ALGOL68_TARGET_DEF): Likewise.
	(ALGOL68_TARGET_H): Likewise.
	(ALGOL68_TARGET_OBJS): Likewise.
	(tm_algol68.h): New target.
	(cs-tm_algol68.h): Likewise.
	(default-algol68.o): Likewise.
---
 Makefile.def               |   4 +
 Makefile.tpl               |  14 ++
 config/acx.m4              |   6 +
 configure.ac               |  47 ++++--
 gcc/Makefile.in            |  36 ++++-
 gcc/algol68/Make-lang.in   | 284 +++++++++++++++++++++++++++++++++++++
 gcc/algol68/config-lang.in |  29 ++++
 gcc/config.gcc             |  44 ++++++
 gcc/configure.ac           |  13 ++
 9 files changed, 462 insertions(+), 15 deletions(-)
 create mode 100644 gcc/algol68/Make-lang.in
 create mode 100644 gcc/algol68/config-lang.in

diff --git a/Makefile.def b/Makefile.def
index e7f33345aa8..12d4e48c97e 100644
--- a/Makefile.def
+++ b/Makefile.def
@@ -205,6 +205,7 @@ target_modules = { module= zlib; bootstrap=true; };
 target_modules = { module= rda; };
 target_modules = { module= libada; };
 target_modules = { module= libgm2; lib_path=.libs; };
+target_modules = { module= libga68; lib_path=.libs; };
 target_modules = { module= libgomp; bootstrap= true; lib_path=.libs; };
 target_modules = { module= libitm; lib_path=.libs; };
 target_modules = { module= libatomic; bootstrap=true; lib_path=.libs; };
@@ -678,6 +679,7 @@ dependencies = { module=configure-target-libstdc++-v3; on=configure-target-libgo
 dependencies = { module=configure-target-libsanitizer; on=all-target-libstdc++-v3; };
 dependencies = { module=configure-target-libvtv; on=all-target-libstdc++-v3; };
 dependencies = { module=configure-target-libgrust; on=all-target-libstdc++-v3; };
+dependencies = { module=configure-target-libga68; on=all-target-libstdc++-v3; };
 // parallel_list.o and parallel_settings.o depend on omp.h, which is
 // generated by the libgomp configure.  Unfortunately, due to the use of
 //  recursive make, we can't be that specific.
@@ -736,6 +738,8 @@ languages = { language=jit;	gcc-check-target=check-jit; };
 languages = { language=rust;	gcc-check-target=check-rust; };
 languages = { language=cobol;	gcc-check-target=check-cobol;
 				lib-check-target=check-target-libgcobol; };
+languages = { language=algol68; gcc-check-target=check-algol68;
+          			lib-check-target=check-target-libga68; };
 
 // Toplevel bootstrap
 bootstrap_stage = { id=1 ; };
diff --git a/Makefile.tpl b/Makefile.tpl
index 7797dca3de9..37c26a36111 100644
--- a/Makefile.tpl
+++ b/Makefile.tpl
@@ -281,6 +281,11 @@ POSTSTAGE1_HOST_EXPORTS = \
 	CC_FOR_BUILD="$$CC"; export CC_FOR_BUILD; \
 	$(POSTSTAGE1_CXX_EXPORT) \
 	$(LTO_EXPORTS) \
+	GA68="$$r/$(HOST_SUBDIR)/prev-gcc/ga68$(exeext) -B$$r/$(HOST_SUBDIR)/prev-gcc/ \
+	  -B$(build_tooldir)/bin/ $(GA68FLAGS_FOR_TARGET) \
+	  -B$$r/prev-$(TARGET_SUBDIR)/libga68/.libs"; \
+	export GA68; \
+	GA68_FOR_BUILD="$$GA68"; export GA68_FOR_BUILD; \
 	GDC="$$r/$(HOST_SUBDIR)/prev-gcc/gdc$(exeext) -B$$r/$(HOST_SUBDIR)/prev-gcc/ \
 	  -B$(build_tooldir)/bin/ $(GDCFLAGS_FOR_TARGET) \
 	  -B$$r/prev-$(TARGET_SUBDIR)/libphobos/libdruntime/gcc \
@@ -313,6 +318,7 @@ BASE_TARGET_EXPORTS = \
 	CPPFLAGS="$(CPPFLAGS_FOR_TARGET)"; export CPPFLAGS; \
 	CXXFLAGS="$(CXXFLAGS_FOR_TARGET)"; export CXXFLAGS; \
 	GFORTRAN="$(GFORTRAN_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GFORTRAN; \
+	GA68="$(GA68_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GA68; \
 	GOC="$(GOC_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GOC; \
 	GDC="$(GDC_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GDC; \
 	GM2="$(GM2_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GM2; \
@@ -383,6 +389,7 @@ CXX_FOR_BUILD = @CXX_FOR_BUILD@
 DLLTOOL_FOR_BUILD = @DLLTOOL_FOR_BUILD@
 DSYMUTIL_FOR_BUILD = @DSYMUTIL_FOR_BUILD@
 GFORTRAN_FOR_BUILD = @GFORTRAN_FOR_BUILD@
+GA68_FOR_BUILD = @GA68_FOR_BUILD@
 GOC_FOR_BUILD = @GOC_FOR_BUILD@
 GDC_FOR_BUILD = @GDC_FOR_BUILD@
 GM2_FOR_BUILD = @GM2_FOR_BUILD@
@@ -446,6 +453,7 @@ STRIP = @STRIP@
 WINDRES = @WINDRES@
 WINDMC = @WINDMC@
 
+GA68 = @GA68@
 GDC = @GDC@
 GNATBIND = @GNATBIND@
 GNATMAKE = @GNATMAKE@
@@ -456,6 +464,7 @@ LIBCFLAGS = $(CFLAGS)
 CXXFLAGS = @CXXFLAGS@
 LIBCXXFLAGS = $(CXXFLAGS) -fno-implicit-templates
 GOCFLAGS = $(CFLAGS)
+GA68FLAGS = @GA68FLAGS@
 GDCFLAGS = @GDCFLAGS@
 GM2FLAGS = $(CFLAGS)
 
@@ -601,6 +610,7 @@ CXX_FOR_TARGET=$(STAGE_CC_WRAPPER) @CXX_FOR_TARGET@
 RAW_CXX_FOR_TARGET=$(STAGE_CC_WRAPPER) @RAW_CXX_FOR_TARGET@
 GFORTRAN_FOR_TARGET=$(STAGE_CC_WRAPPER) @GFORTRAN_FOR_TARGET@
 GOC_FOR_TARGET=$(STAGE_CC_WRAPPER) @GOC_FOR_TARGET@
+GA68_FOR_TARGET=$(STAGE_CC_WRAPPER) @GA68_FOR_TARGET@
 GDC_FOR_TARGET=$(STAGE_CC_WRAPPER) @GDC_FOR_TARGET@
 GM2_FOR_TARGET=$(STAGE_CC_WRAPPER) @GM2_FOR_TARGET@
 DLLTOOL_FOR_TARGET=@DLLTOOL_FOR_TARGET@
@@ -630,6 +640,7 @@ LIBCXXFLAGS_FOR_TARGET = $(CXXFLAGS_FOR_TARGET) -fno-implicit-templates
 LDFLAGS_FOR_TARGET = @LDFLAGS_FOR_TARGET@
 GM2FLAGS_FOR_TARGET = -O2 -g
 GOCFLAGS_FOR_TARGET = -O2 -g
+GA68FLAGS_FOR_TARGET = -O2 -g
 GDCFLAGS_FOR_TARGET = -O2 -g
 
 FLAGS_FOR_TARGET = @FLAGS_FOR_TARGET@
@@ -734,6 +745,7 @@ EXTRA_HOST_FLAGS = \
 	'DSYMUTIL=$(DSYMUTIL)' \
 	'GFORTRAN=$(GFORTRAN)' \
 	'GOC=$(GOC)' \
+	'GA68=$(GA68)' \
 	'GDC=$(GDC)' \
 	'GM2=$(GM2)' \
 	'LD=$(LD)' \
@@ -762,6 +774,7 @@ STAGE1_FLAGS_TO_PASS = \
 POSTSTAGE1_FLAGS_TO_PASS = \
 	CC="$${CC}" CC_FOR_BUILD="$${CC_FOR_BUILD}" \
 	CXX="$${CXX}" CXX_FOR_BUILD="$${CXX_FOR_BUILD}" \
+	GA68="$${GA68}" GA68_FOR_BUILD="$${GA68_FOR_BUILD}" \
 	GDC="$${GDC}" GDC_FOR_BUILD="$${GDC_FOR_BUILD}" \
 	GM2="$${GM2}" GM2_FOR_BUILD="$${GM2_FOR_BUILD}" \
 	GNATBIND="$${GNATBIND}" \
@@ -797,6 +810,7 @@ EXTRA_TARGET_FLAGS = \
 	'GFORTRAN=$$(GFORTRAN_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
 	'GOC=$$(GOC_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
 	'GOCFLAGS=$$(GOCFLAGS_FOR_TARGET)' \
+	'GA68=$$(GA68_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
 	'GDC=$$(GDC_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
 	'GDCFLAGS=$$(GDCFLAGS_FOR_TARGET)' \
 	'GM2=$$(GM2_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
diff --git a/config/acx.m4 b/config/acx.m4
index db54ccf1c7c..4e0c64172e6 100644
--- a/config/acx.m4
+++ b/config/acx.m4
@@ -434,6 +434,12 @@ else
   have_cargo=no
 fi])
 
+# Test for Algol 68
+AC_DEFUN([ACX_PROG_GA68],
+[AC_REQUIRE([AC_CHECK_TOOL_PREFIX])
+AC_REQUIRE([AC_PROG_CC])
+AC_CHECK_TOOL(GA68, ga68, no)])
+
 # Test for D.
 AC_DEFUN([ACX_PROG_GDC],
 [AC_REQUIRE([AC_CHECK_TOOL_PREFIX])
diff --git a/configure.ac b/configure.ac
index 94321ffd20a..8f249675e5a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -166,6 +166,7 @@ target_libraries="target-libgcc \
 		target-libgcobol \
 		target-libada \
 		target-libgm2 \
+                target-libga68 \
 		target-libgo \
 		target-libgrust \
 		target-libphobos \
@@ -514,6 +515,11 @@ if test "${ENABLE_LIBGM2}" != "yes" ; then
   noconfigdirs="$noconfigdirs gm2tools"
 fi
 
+AC_ARG_ENABLE(libga68,
+[AS_HELP_STRING([--enable-libga68], [build libga68 directory])],
+ENABLE_LIBGA68=$enableval,
+ENABLE_LIBGA68=yes)
+
 AC_ARG_ENABLE(libssp,
 [AS_HELP_STRING([--enable-libssp], [build libssp directory])],
 ENABLE_LIBSSP=$enableval,
@@ -1451,6 +1457,7 @@ if test "${build}" != "${host}" ; then
   DLLTOOL_FOR_BUILD=${DLLTOOL_FOR_BUILD-dlltool}
   DSYMUTIL_FOR_BUILD=${DSYMUTIL_FOR_BUILD-dsymutil}
   GFORTRAN_FOR_BUILD=${GFORTRAN_FOR_BUILD-gfortran}
+  GA68_FOR_BUILD=${GA68_FOR_BUILD-ga68}
   GOC_FOR_BUILD=${GOC_FOR_BUILD-gccgo}
   GDC_FOR_BUILD=${GDC_FOR_BUILD-gdc}
   GNATMAKE_FOR_BUILD=${GNATMAKE_FOR_BUILD-gnatmake}
@@ -1467,6 +1474,7 @@ else
   DLLTOOL_FOR_BUILD="\$(DLLTOOL)"
   DSYMUTIL_FOR_BUILD="\$(DSYMUTIL)"
   GFORTRAN_FOR_BUILD="\$(GFORTRAN)"
+  GA68_FOR_BUILD="\$(GA68)"
   GOC_FOR_BUILD="\$(GOC)"
   GDC_FOR_BUILD="\$(GDC)"
   GNATMAKE_FOR_BUILD="\$(GNATMAKE)"
@@ -1520,6 +1528,7 @@ int main() {}])],
 fi
 
 ACX_PROG_GNAT
+ACX_PROG_GA68
 ACX_PROG_GDC
 ACX_PROG_CARGO
 ACX_PROG_CMP_IGNORE_INITIAL
@@ -2644,6 +2653,10 @@ AC_ARG_ENABLE(objc-gc,
 [AS_HELP_STRING([--enable-objc-gc],
 		[enable use of Boehm's garbage collector with the
 		 GNU Objective-C runtime])])
+AC_ARG_ENABLE(algol68-gc,
+[AS_HELP_STRING([--enable-algol68-gc],
+                [enable use of Boehm's garbage collector with the
+                 GNU Algol runtime])])
 AC_ARG_WITH([target-bdw-gc],
 [AS_HELP_STRING([--with-target-bdw-gc=PATHLIST],
 		[specify prefix directory for installed bdw-gc package.
@@ -2656,21 +2669,22 @@ AC_ARG_WITH([target-bdw-gc-lib],
 [AS_HELP_STRING([--with-target-bdw-gc-lib=PATHLIST],
 		[specify directories for installed bdw-gc library])])
 		  
-case ,${enable_languages},:${enable_objc_gc} in *,objc,*:yes|*,objc,*:auto)
-  AC_MSG_CHECKING([for bdw garbage collector])
-  if test "x$with_target_bdw_gc$with_target_bdw_gc_include$with_target_bdw_gc_lib" = x; then
-    dnl no bdw-gw options, assume default locations
-    AC_MSG_RESULT([using bdw-gc in default locations])
-  else
-    dnl bdw-gw options, first error checking, complete checking in libobjc
-    if test "x$with_target_bdw_gc_include" = x && test "x$with_target_bdw_gc_lib" != x; then
-      AC_MSG_ERROR([found --with-target-bdw-gc-lib but --with-target-bdw-gc-include missing])
-    elif test "x$with_target_bdw_gc_include" != x && test "x$with_target_bdw_gc_lib" = x; then
-      AC_MSG_ERROR([found --with-target-bdw-gc-include but --with-target-bdw-gc-lib missing])
+case ,${enable_languages},:${enable_objc_gc}:${enable_algol68_gc} in
+  *,objc,*:yes:*|*,objc,*:auto:*|*,algol68,*:*:yes|*,algol68,*:*:auto)
+    AC_MSG_CHECKING([for bdw garbage collector])
+    if test "x$with_target_bdw_gc$with_target_bdw_gc_include$with_target_bdw_gc_lib" = x; then
+      dnl no bdw-gw options, assume default locations
+      AC_MSG_RESULT([using bdw-gc in default locations])
     else
-      AC_MSG_RESULT([using paths configured with --with-target-bdw-gc options])
+      dnl bdw-gw options, first error checking, complete checking in libobjc and libga68
+      if test "x$with_target_bdw_gc_include" = x && test "x$with_target_bdw_gc_lib" != x; then
+        AC_MSG_ERROR([found --with-target-bdw-gc-lib but --with-target-bdw-gc-include missing])
+      elif test "x$with_target_bdw_gc_include" != x && test "x$with_target_bdw_gc_lib" = x; then
+        AC_MSG_ERROR([found --with-target-bdw-gc-include but --with-target-bdw-gc-lib missing])
+      else
+        AC_MSG_RESULT([using paths configured with --with-target-bdw-gc options])
+      fi
     fi
-  fi
 esac
 
 # Disable libitm, libsanitizer, libvtv if we're not building C++
@@ -3918,6 +3932,7 @@ AC_SUBST(CXX_FOR_BUILD)
 AC_SUBST(DLLTOOL_FOR_BUILD)
 AC_SUBST(DSYMUTIL_FOR_BUILD)
 AC_SUBST(GFORTRAN_FOR_BUILD)
+AC_SUBST(GA68_FOR_BUILD)
 AC_SUBST(GOC_FOR_BUILD)
 AC_SUBST(GDC_FOR_BUILD)
 AC_SUBST(GNATMAKE_FOR_BUILD)
@@ -4013,6 +4028,9 @@ AC_SUBST(CC)
 AC_SUBST(CXX)
 AC_SUBST(CFLAGS)
 AC_SUBST(CXXFLAGS)
+AC_SUBST(GA68)
+AC_SUBST(GA68FLAGS)
+GA68FLAGS=${GA68FLAGS-${CFLAGS}}
 AC_SUBST(GDC)
 AC_SUBST(GDCFLAGS)
 GDCFLAGS=${GDCFLAGS-${CFLAGS}}
@@ -4061,6 +4079,7 @@ NCN_STRICT_CHECK_TARGET_TOOLS(CC_FOR_TARGET, cc gcc)
 NCN_STRICT_CHECK_TARGET_TOOLS(CXX_FOR_TARGET, c++ g++ cxx gxx)
 NCN_STRICT_CHECK_TARGET_TOOLS(GCC_FOR_TARGET, gcc, ${CC_FOR_TARGET})
 NCN_STRICT_CHECK_TARGET_TOOLS(GFORTRAN_FOR_TARGET, gfortran)
+NCN_STRICT_CHECK_TARGET_TOOLS(GA68_FOR_TARGET, ga68)
 NCN_STRICT_CHECK_TARGET_TOOLS(GOC_FOR_TARGET, gccgo)
 NCN_STRICT_CHECK_TARGET_TOOLS(GDC_FOR_TARGET, gdc)
 NCN_STRICT_CHECK_TARGET_TOOLS(GM2_FOR_TARGET, gm2)
@@ -4112,6 +4131,8 @@ GCC_TARGET_TOOL(gfortran, GFORTRAN_FOR_TARGET, GFORTRAN,
 		[gcc/gfortran -B$$r/$(HOST_SUBDIR)/gcc/], fortran)
 GCC_TARGET_TOOL(gccgo, GOC_FOR_TARGET, GOC,
 		[gcc/gccgo -B$$r/$(HOST_SUBDIR)/gcc/], go)
+GCC_TARGET_TOOL(ga68, GA68_FOR_TARGET, GA68,
+                [gcc/ga68 -B$$r/$(HOST_SUBDIR)/gcc/], algol68)
 GCC_TARGET_TOOL(gdc, GDC_FOR_TARGET, GDC,
 		[gcc/gdc -B$$r/$(HOST_SUBDIR)/gcc/], d)
 GCC_TARGET_TOOL(gm2, GM2_FOR_TARGET, GM2,
diff --git a/gcc/Makefile.in b/gcc/Makefile.in
index 5c24a9aab00..7458daf94be 100644
--- a/gcc/Makefile.in
+++ b/gcc/Makefile.in
@@ -615,6 +615,8 @@ tm_rust_file_list=@tm_rust_file_list@
 tm_rust_include_list=@tm_rust_include_list@
 tm_jit_file_list=@tm_jit_file_list@
 tm_jit_include_list=@tm_jit_include_list@
+tm_algol68_file_list=@tm_algol68_file_list@
+tm_algol68_include_list=@tm_algol68_include_list@
 build_xm_file_list=@build_xm_file_list@
 build_xm_include_list=@build_xm_include_list@
 build_xm_defines=@build_xm_defines@
@@ -920,6 +922,7 @@ TM_P_H    = tm_p.h    $(tm_p_file_list) $(TREE_H)
 TM_D_H    = tm_d.h    $(tm_d_file_list)
 TM_RUST_H = tm_rust.h $(tm_rust_file_list)
 TM_JIT_H  = tm_jit.h    $(tm_jit_file_list)
+TM_ALGOL68_H = tm_algol68.h $(tm_algol68_file_list)
 GTM_H     = tm.h      $(tm_file_list) insn-constants.h
 TM_H      = $(GTM_H) insn-flags.h $(OPTIONS_H)
 
@@ -981,12 +984,14 @@ COMMON_TARGET_DEF = common/common-target.def target-hooks-macros.h
 D_TARGET_DEF = d/d-target.def target-hooks-macros.h
 RUST_TARGET_DEF = rust/rust-target.def target-hooks-macros.h
 JIT_TARGET_DEF = jit/jit-target.def target-hooks-macros.h
+ALGOL68_TARGET_DEF = algol68/algol68-target.def target-hooks-macros.h
 TARGET_H = $(TM_H) target.h $(TARGET_DEF) insn-modes.h insn-codes.h
 C_TARGET_H = c-family/c-target.h $(C_TARGET_DEF)
 COMMON_TARGET_H = common/common-target.h $(INPUT_H) $(COMMON_TARGET_DEF)
 D_TARGET_H = d/d-target.h $(D_TARGET_DEF)
 RUST_TARGET_H = rust/rust-target.h $(RUST_TARGET_DEF)
 JIT_TARGET_H = jit/jit-target.h $(JIT_TARGET_DEF)
+ALGOL68_TARGET_H = algol68/algol68-target.h $(ALGOL68_TARGET_DEF)
 MACHMODE_H = machmode.h mode-classes.def
 HOOKS_H = hooks.h
 HOSTHOOKS_DEF_H = hosthooks-def.h $(HOOKS_H)
@@ -1311,6 +1316,9 @@ FORTRAN_TARGET_OBJS=@fortran_target_objs@
 # Target specific, Rust specific object file
 RUST_TARGET_OBJS=@rust_target_objs@
 
+# Target specific, Algol68 specific object file
+ALGOL68_TARGET_OBJS=@algol68_target_objs@
+
 # Object files for gcc many-languages driver.
 GCC_OBJS = gcc.o gcc-main.o ggc-none.o gcc-urlifier.o options-urls.o
 
@@ -2117,6 +2125,7 @@ tm_p.h: cs-tm_p.h ; @true
 tm_d.h: cs-tm_d.h ; @true
 tm_rust.h: cs-tm_rust.h ; @true
 tm_jit.h: cs-tm_jit.h ; @true
+tm_algol68.h: cs-tm_algol68.h; @true
 
 cs-config.h: Makefile
 	TARGET_CPU_DEFAULT="" \
@@ -2161,6 +2170,11 @@ cs-tm_jit.h: Makefile
 	HEADERS="$(tm_jit_include_list)" DEFINES="" \
 	$(SHELL) $(srcdir)/mkconfig.sh tm_jit.h
 
+cs-tm_algol68.h: Makefile
+	TARGET_CPU_DEFAULT="" \
+	HEADERS="$(tm_algol68_include_list)" DEFINES="" \
+	$(SHELL) $(srcdir)/mkconfig.sh tm_algol68.h
+
 # Don't automatically run autoconf, since configure.ac might be accidentally
 # newer than configure.  Also, this writes into the source directory which
 # might be on a read-only file system.  If configured for maintainer mode
@@ -2640,6 +2654,12 @@ default-rust.o: config/default-rust.cc
 	$(COMPILE) $<
 	$(POSTCOMPILE)
 
+# Files used by the Algol68 language front end.
+
+default-algol68.o: config/default-algol68.cc
+	$(COMPILE) $<
+	$(POSTCOMPILE)
+
 # Language-independent files.
 
 DRIVER_DEFINES = \
@@ -2995,6 +3015,15 @@ s-jit-target-hooks-def-h: build/genhooks$(build_exeext)
 					     jit/jit-target-hooks-def.h
 	$(STAMP) s-jit-target-hooks-def-h
 
+algol68/algol68-target-hooks-def.h: s-algol68-target-hooks-def-h; @true
+
+s-algol68-target-hooks-def-h: build/genhooks$(build_exeext)
+	$(RUN_GEN) build/genhooks$(build_exeext) "Algol68 Target Hook" \
+					     > tmp-algol68-target-hooks-def.h
+	$(SHELL) $(srcdir)/../move-if-change tmp-algol68-target-hooks-def.h \
+					     algol68/algol68-target-hooks-def.h
+	$(STAMP) s-algol68-target-hooks-def-h
+
 # check if someone mistakenly only changed tm.texi.
 # We use a different pathname here to avoid a circular dependency.
 s-tm-texi: $(srcdir)/doc/../doc/tm.texi
@@ -3020,6 +3049,7 @@ s-tm-texi: build/genhooks$(build_exeext) $(srcdir)/doc/tm.texi.in
 	    || test $(srcdir)/doc/tm.texi -nt $(srcdir)/common/common-target.def \
 	    || test $(srcdir)/doc/tm.texi -nt $(srcdir)/d/d-target.def \
 	    || test $(srcdir)/doc/tm.texi -nt $(srcdir)/rust/rust-target.def \
+	    || test $(srcdir)/doc/tm.texi -nt $(srcdir)/algol68/algol68-target.def \
 	  ); then \
 	  echo >&2 ; \
 	  echo You should edit $(srcdir)/doc/tm.texi.in rather than $(srcdir)/doc/tm.texi . >&2 ; \
@@ -3203,6 +3233,7 @@ generated_files = config.h tm.h $(TM_P_H) $(TM_D_H) $(TM_JIT_H) $(TM_H) \
        gimple-match-auto.h generic-match-auto.h \
        c-family/c-target-hooks-def.h d/d-target-hooks-def.h \
        $(TM_RUST_H) rust/rust-target-hooks-def.h \
+       $(TM_ALGOL68_H) algol68/algol68-target-hooks-def.h \
        case-cfn-macros.h \
        jit/jit-target-hooks-def.h case-cfn-macros.h \
        cfn-operators.pd omp-device-properties.h
@@ -3339,7 +3370,7 @@ build/genrecog.o : genrecog.cc $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H)	\
   $(HASH_TABLE_H) inchash.h
 build/genhooks.o : genhooks.cc $(TARGET_DEF) $(C_TARGET_DEF)		\
   $(COMMON_TARGET_DEF) $(D_TARGET_DEF) $(RUST_TARGET_DEF) $(JIT_TARGET_DEF) \
-  $(BCONFIG_H) $(SYSTEM_H) errors.h
+  $(ALGOL68_TARGET_DEF) $(BCONFIG_H) $(SYSTEM_H) errors.h
 build/genmddump.o : genmddump.cc $(RTL_BASE_H) $(BCONFIG_H) $(SYSTEM_H)	\
   $(CORETYPES_H) $(GTM_H) errors.h $(READ_MD_H) $(GENSUPPORT_H)
 build/genmatch.o : genmatch.cc $(BCONFIG_H) $(SYSTEM_H) $(CORETYPES_H) \
@@ -3891,7 +3922,8 @@ $(build_htmldir)/gccinstall/index.html: $(TEXI_GCCINSTALL_FILES)
 .PHONY: regenerate-opt-urls
 OPT_URLS_HTML_DEPS = $(build_htmldir)/gcc/Option-Index.html \
 	$(build_htmldir)/gdc/Option-Index.html \
-	$(build_htmldir)/gfortran/Option-Index.html
+	$(build_htmldir)/gfortran/Option-Index.html \
+	$(build_htmldir)/ga68/Option-Index.html
 $(OPT_URLS_HTML_DEPS): %/Option-Index.html: %/index.html
 
 regenerate-opt-urls: $(srcdir)/regenerate-opt-urls.py $(OPT_URLS_HTML_DEPS)
diff --git a/gcc/algol68/Make-lang.in b/gcc/algol68/Make-lang.in
new file mode 100644
index 00000000000..26a25193e90
--- /dev/null
+++ b/gcc/algol68/Make-lang.in
@@ -0,0 +1,284 @@
+# Make-lang.in -- Top level -*- makefile -*- fragment for GCC Algol 68
+# frontend.
+
+# Copyright (C) 2025 Free Software Foundation, Inc.
+
+# This file is NOT part of GCC.
+
+# 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/>.
+
+# This file provides the language dependent support in the main Makefile.
+
+.PHONY: algol68
+
+# Installation name.
+
+A68_INSTALL_NAME = $(shell echo ga68|sed '$(program_transform_name)')
+A68_TARGET_INSTALL_NAME = $(target_noncanonical)-$(shell echo ga68|sed '$(program_transform_name)')
+
+# General hooks
+
+algol68: a681$(exeext)
+algol68.serial = a681$(exeext)
+
+.PHONY: algol68
+
+# Use maximal warnings for this front end.
+algol68-warn = $(STRICT_WARN)
+
+# First the driver, ga68.
+
+GA68_OBJS = \
+   $(GCC_OBJS) \
+   algol68/a68spec.o \
+   $(END)
+
+a68spec.o: $(srcdir)/algol68/a68spec.cc $(SYSTEM_H) coretypes.h $(TM_H) $(GCC_H) \
+     $(CONFIG_H) opts.h
+	$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \
+                $(INCLUDES) $(srcdir)/algol68/a68spec.cc
+
+ga68$(exeext): $(GA68_OBJS) $(EXTRA_GCC_OBJS) libcommon-target.a $(LIBDEPS)
+	+$(LINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \
+	  $(GA68_OBJS) $(EXTRA_GCC_OBJS) libcommon-target.a \
+	  $(EXTRA_GCC_LIBS) $(LIBS)
+
+# Now the compiler proper, a681.
+
+ALGOL68_OBJS = algol68/a68-lang.o \
+               algol68/a68-unistr.o \
+               algol68/a68-moids-diagnostics.o \
+               algol68/a68-moids-misc.o \
+               algol68/a68-moids-to-string.o \
+               algol68/a68-postulates.o \
+               algol68/a68-diagnostics.o \
+               algol68/a68-parser.o \
+               algol68/a68-parser-keywords.o \
+               algol68/a68-parser-bottom-up.o \
+               algol68/a68-parser-brackets.o \
+               algol68/a68-parser-debug.o \
+               algol68/a68-parser-extract.o \
+               algol68/a68-parser-modes.o \
+               algol68/a68-parser-moids-check.o \
+               algol68/a68-parser-moids-coerce.o \
+               algol68/a68-parser-moids-equivalence.o \
+               algol68/a68-parser-scanner.o \
+               algol68/a68-parser-scope.o \
+               algol68/a68-parser-serial-dsa.o \
+               algol68/a68-parser-taxes.o \
+               algol68/a68-parser-top-down.o \
+               algol68/a68-parser-victal.o \
+               algol68/a68-parser-prelude.o \
+               algol68/a68-low.o \
+               algol68/a68-low-builtins.o \
+               algol68/a68-low-clauses.o \
+               algol68/a68-low-coercions.o \
+               algol68/a68-low-decls.o \
+               algol68/a68-low-generator.o \
+               algol68/a68-low-misc.o \
+               algol68/a68-low-moids.o \
+               algol68/a68-low-multiples.o \
+               algol68/a68-low-refs.o \
+               algol68/a68-low-procs.o \
+               algol68/a68-low-structs.o \
+               algol68/a68-low-chars.o \
+               algol68/a68-low-strings.o \
+               algol68/a68-low-ints.o \
+               algol68/a68-low-bools.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 \
+               algol68/a68-low-unions.o \
+               algol68/a68-low-units.o \
+               $(END)
+
+ALGOL68_ALL_OBJS = $(ALGOL68_OBJS) $(ALGOL68_TARGET_OBJS)
+
+algol68_OBJS = $(ALGOL68_ALL_OBJS) algol68/a68spec.o
+
+a681$(exeext): $(ALGOL68_ALL_OBJS) attribs.o $(BACKEND) $(LIBDEPS) $(algol68.prev)
+	@$(call LINK_PROGRESS,$(INDEX.algol68),start)
+	+$(LLINKER) $(ALL_LINKERFLAGS) $(LDFLAGS) -o $@ \
+	      $(ALGOL68_OBJS) attribs.o $(BACKEND) $(LIBS) $(A681_LIBS) $(BACKENDLIBS)
+	@$(call LINK_PROGRESS,$(INDEX.algol68),end)
+
+algol68/tfspec.o: $(srcdir)/algol68/tfspec.c \
+                     $(SYSTEM_H) coretypes.h $(TM_H) $(GCC_H) $(CONFIG_H) $(TREE_H)
+
+# Documentation.
+
+A68_MANUAL_FILES =
+
+A68_MANUAL_FILES = \
+		algol68/ga68.texi \
+		$(gcc_docdir)/include/fdl.texi \
+		$(gcc_docdir)/include/gpl_v3.texi \
+		$(gcc_docdir)/include/gcc-common.texi \
+		gcc-vers.texi
+
+A68_INT_MANUAL_FILES = \
+		algol68/ga68-internals.texi \
+		$(gcc_docdir)/include/fdl.texi \
+		$(gcc_docdir)/include/gcc-common.texi \
+		gcc-vers.texi
+
+A68_TEXI_FILES = $(A68_MANUAL_FILES) $(A68_INT_MANUAL_FILES)
+
+doc/ga68.info: $(A68_MANUAL_FILES)
+	if test "x$(BUILD_INFO)" = xinfo; then \
+	  rm -f doc/ga68.info*; \
+	  $(MAKEINFO) $(MAKEINFOFLAGS) -I $(gcc_docdir) \
+		-I $(gcc_docdir)/include -o $@ $<; \
+	else true; fi
+
+doc/ga68-internals.info: $(A68_INT_MANUAL_FILES)
+	if test "x$(BUILD_INFO)" = xinfo; then \
+	  rm -f doc/ga68-internals.info*; \
+	  $(MAKEINFO) $(MAKEINFOFLAGS) -I $(gcc_docdir) \
+		-I $(gcc_docdir)/include -o $@ $<; \
+	else true; fi
+
+doc/ga68.dvi: $(A68_MANUAL_FILES)
+	$(TEXI2DVI) -I $(abs_docdir)/include -o $@ $<
+
+doc/ga68-internals.dvi: $(A68_INT_MANUAL_FILES)
+	$(TEXI2DVI) -I $(abs_docdir)/include -o $@ $<
+
+doc/ga68.pdf: $(A68_MANUAL_FILES)
+	$(TEXI2PDF) -I $(abs_docdir)/include -o $@ $<
+
+doc/ga68-internals.pdf: $(A68_INT_MANUAL_FILES)
+	$(TEXI2PDF) -I $(abs_docdir)/include -o $@ $<
+
+$(build_htmldir)/ga68/index.html: $(A68_MANUAL_FILES)
+	$(mkinstalldirs) $(@D)
+	rm -f $(@D)/*
+	$(TEXI2HTML) $(MAKEINFO_TOC_INLINE_FLAG) \
+		-I $(gcc_docdir)/include -I $(srcdir)/d -o $(@D) $<
+
+$(build_htmldir)/ga68-internals/index.html: $(A68_INT_MANUAL_FILES)
+	$(mkinstalldirs) $(@D)
+	rm -f $(@D)/*
+	$(TEXI2HTML) $(MAKEINFO_TOC_INLINE_FLAG) \
+		-I $(gcc_docdir)/include -I $(srcdir)/d -o $(@D) $<
+
+.INTERMEDIATE: ga68.pod
+
+ga68.pod: algol68/ga68.texi
+	-$(TEXI2POD) -D ga68 < $< > $@
+
+# Build hooks.
+
+algol68.srcextra:
+
+algol68.all.cross: ga68$(exeext)
+algol68.start.encap: ga68$(exeect)
+algol68.rest.encap:
+algol68.info: doc/ga68.info doc/ga68-internals.info
+algol68.dvi: doc/ga68.dvi doc/ga68-internals.dvi
+algol68.pdf: doc/ga68.pdf doc/ga68-internals.pdf
+algol68.install-pdf:
+algol68.html: $(build_htmldir)/ga68/index.html $(build_htmldir)/ga68-internals/index.html
+algol68.man: doc/ga68.1
+algol68.srcinfo: doc/ga68.info doc/ga68-internals.info
+	-cp -p $^ $(srcdir)/doc
+algol68.srcinfo:
+algol68.srcman:
+algol68.srcman: doc/ga68.1
+	-cp -p $^ $(srcdir)/doc
+algol68.install-plugin:
+
+algol68.tags: force
+	cd $(srcdir)/algol68; etags -o TAGS.sub *.c *.h; \
+	etags --include TAGS.sub --include ../TAGS.sub
+
+lang_checks += check-algol68
+lang_checks_parallelized += check-algol68
+check_algol68_parallelize = 10
+
+selftest-algol68:
+
+#\f
+# Install hooks:
+
+algol68.install-common: installdirs
+	-rm -f $(DESTDIR)$(bindir)/$(A68_INSTALL_NAME)$(exeext)
+	$(INSTALL_PROGRAM) ga68$(exeext) $(DESTDIR)$(bindir)/$(A68_INSTALL_NAME)$(exeext)
+
+algol68.install-man: $(DESTDIR)$(man1dir)/$(A68_INSTALL_NAME)$(man1ext)
+
+$(DESTDIR)$(man1dir)/$(A68_INSTALL_NAME)$(man1ext): doc/ga68.1 installdirs
+	-rm -f $@
+	-$(INSTALL_DATA) $< $@
+	-chmod a-x $@
+
+$(DESTDIR)$(man7dir)/%.7algol: doc/%.7algol installdirs
+	-rm -f $@
+	-$(INSTALL_DATA) $< $@
+	-chmod a-x $@
+
+algol68.install-info: $(DESTDIR)$(infodir)/ga68.info $(DESTDIR)$(infodir)/ga68-internals.info
+
+algol68.install-html: $(build_htmldir)/ga68 $(build_htmldir)/ga68-internals
+	@$(NORMAL_INSTALL)
+	test -z "$(htmldir)" || $(mkinstalldirs) "$(DESTDIR)$(htmldir)"
+	@for p in $(build_htmldir)/ga68; do \
+	  if test -f "$$p" || test -d "$$p"; then d=""; else d="$(srcdir)/"; fi; \
+	  f=$(html__strip_dir) \
+	  if test -d "$$d$$p"; then \
+	    echo " $(mkinstalldirs) '$(DESTDIR)$(htmldir)/$$f'"; \
+	    $(mkinstalldirs) "$(DESTDIR)$(htmldir)/$$f" || exit 1; \
+	    echo " $(INSTALL_DATA) '$$d$$p'/* '$(DESTDIR)$(htmldir)/$$f'"; \
+	    $(INSTALL_DATA) "$$d$$p"/* "$(DESTDIR)$(htmldir)/$$f"; \
+	  else \
+	    echo " $(INSTALL_DATA) '$$d$$p' '$(DESTDIR)$(htmldir)/$$f'"; \
+	    $(INSTALL_DATA) "$$d$$p" "$(DESTDIR)$(htmldir)/$$f"; \
+	  fi; \
+	done
+
+algol68.uninstall:
+#\f
+# Clean hooks:
+# A lot of the ancillary files are deleted by the main makefile.
+# We just have to delete files specific to us.
+algol68.mostlyclean:
+	-rm -f algol68/*$(objext) algol68/xforward algol68/fflags
+	-rm -f algol68/*$(coverageexts)
+algol68.clean: algol68.mostlyclean
+algol68.distclean:
+	-rm -f algol68/Makefile algol68/Make-host algol68/Make-target
+	-rm -f algol68/config.status algol68/config.cache
+algol68.maintainer-clean:
+	-rm -f $(gcc_docdir)/*.7algol
+
+#\f
+# Stage hooks:
+
+algol68.stage1: stage1-start
+	-mv algol68/*$(objext) stage1/algol68
+algol68.stage2: stage2-start
+	-mv algol68/*$(objext) stage2/algol68
+algol68.stage3: stage3-start
+	-mv algol68/*$(objext) stage3/algol68
+algol68.stage4: stage4-start
+	-mv algol68/*$(objext) stage4/algol68
+algol68.stageprofile: stageprofile-start
+	-mv algol68/*$(objext) stageprofile/algol68
+algol68.stagefeedback: stagefeedback-start
+	-mv algol68/*$(objext) stagefeedback/algol68
diff --git a/gcc/algol68/config-lang.in b/gcc/algol68/config-lang.in
new file mode 100644
index 00000000000..88370b06cad
--- /dev/null
+++ b/gcc/algol68/config-lang.in
@@ -0,0 +1,29 @@
+# config-lang.in -- Top level configure fragment for gcc Algol 68 frontend.
+
+# Copyright (C) 2025 Free Software Foundation, Inc.
+
+# 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/>.
+
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+#
+# language	- name of language as it would appear in $(LANGUAGES)
+# compilers	- value to add to $(COMPILERS)
+
+language="algol68"
+compilers="a681\$(exeext)"
+gtfiles="\$(srcdir)/algol68/a68-lang.cc"
+
+target_libs="target-libga68"
diff --git a/gcc/config.gcc b/gcc/config.gcc
index 2f478e2a493..d755232aafd 100644
--- a/gcc/config.gcc
+++ b/gcc/config.gcc
@@ -93,6 +93,9 @@
 #  tm_rust_file		list of headers with definitions of target hook
 #			macros for the Rust compiler.
 #
+#  tm_algol68_file	list of headers with definitions of target hook
+#			macros for the Algol68 compiler.
+#
 #  out_file		The name of the machine description C support
 #			file, if different from "$cpu_type/$cpu_type.c".
 #
@@ -158,6 +161,9 @@
 #  rust_target_objs	List of extra target-dependent objects that be
 #			linked into the Rust compiler only.
 #
+#  algol68_target_objs	List of extra target-dependent objects that be
+#			linked into the Algol68 compiler only.
+#
 #  target_gtfiles       List of extra source files with type information.
 #
 #  xm_defines		List of macros to define when compiling for the
@@ -216,6 +222,9 @@
 #
 #  target_has_targetjitm	Set to yes or no depending on whether the target
 #			has its own definition of targetjitm.
+#  target_has_targetalgol68m
+#			Set to yes or no depending on whether the target
+#			has its own deinition of targetdm.
 
 out_file=
 common_out_file=
@@ -235,11 +244,13 @@ d_target_objs=
 jit_target_objs=
 fortran_target_objs=
 rust_target_objs=
+algol68_target_objs=
 target_has_targetcm=no
 target_has_targetm_common=yes
 target_has_targetdm=no
 target_has_targetrustm=no
 target_has_targetjitm=no
+target_has_targetalgol68m=no
 tm_defines=
 xm_defines=
 # Set this to force installation and use of collect2.
@@ -635,6 +646,16 @@ then
 	tm_jit_file="${tm_jit_file} ${cpu_type}/${cpu_type}-jit.h"
 fi
 
+tm_algol68_file=
+if test -f ${srcdir}/config/${cpu_type}/${cpu_type}-algol68.h
+then
+	tm_algol68_file="${cpu_type}/${cpu_type}-algol68.h"
+fi
+if test -f ${srcdir}/config/${cpu_type}/${cpu_type}-algol68.cc
+then
+	algol68_target_objs="${algol68_target_objs} ${cpu_type}-algol68.o"
+fi
+
 extra_modes=
 if test -f ${srcdir}/config/${cpu_type}/${cpu_type}-modes.def
 then
@@ -804,9 +825,11 @@ case ${target} in
   d_target_objs="${d_target_objs} darwin-d.o"
   fortran_target_objs="darwin-f.o"
   rust_target_objs="${rust_target_objs} darwin-rust.o"
+  algol68_target_objs="${algol68_target_objs} darwin-algol68.o"
   target_has_targetcm=yes
   target_has_targetdm=yes
   target_has_targetrustm=yes
+  target_has_targetalgol68m=no
   extra_objs="${extra_objs} darwin.o"
   extra_gcc_objs="darwin-driver.o"
   default_use_cxa_atexit=yes
@@ -839,6 +862,8 @@ case ${target} in
   target_has_targetdm=yes
   rust_target_objs="${rust_target_objs} dragonfly-rust.o"
   target_has_targetrustm=yes
+  algol68_target_objs="${algol68_target_objs} dragonfly-algol68.o"
+  target_has_targetalgol68m=yes
   ;;
 *-*-freebsd*)
   # This is the generic ELF configuration of FreeBSD.  Later
@@ -892,12 +917,16 @@ case ${target} in
   target_has_targetdm=yes
   rust_target_objs="${rust_target_objs} freebsd-rust.o"
   target_has_targetrustm=yes
+  algol68_target_objs="${algol68_target_objs} freebsd-algol68.o"
+  target_has_targetalgol68m=yes
   ;;
 *-*-fuchsia*)
   native_system_header_dir=/include
   tmake_file="t-fuchsia"
   rust_target_objs="${rust_target_objs} fuchsia-rust.o"
   target_has_targetrustm=yes
+  algol68_target_objs="${algol68_target_objs} fuchsia-algol68.o"
+  target_has_targetalgol68m=yes
   ;;
 *-*-linux* | frv-*-*linux* | *-*-kfreebsd*-gnu | *-*-gnu* | *-*-kopensolaris*-gnu | *-*-uclinuxfdpiceabi)
   extra_options="$extra_options gnu-user.opt"
@@ -1006,6 +1035,8 @@ case ${target} in
   esac
   rust_target_objs="${rust_target_objs} netbsd-rust.o"
   target_has_targetrustm=yes
+  algol68_target_objs="${algol68_target_objs} netbsd-algol68.o"
+  target_has_targetalgol68m=yes
   ;;
 *-*-openbsd*)
   tmake_file="t-openbsd"
@@ -1023,6 +1054,8 @@ case ${target} in
   target_has_targetdm=yes
   rust_target_objs="${rust_target_objs} openbsd-rust.o"
   target_has_targetrustm=yes
+  algol68_target_objs="${algol68_target_objs} openbsd-algol68.o"
+  target_has_targetalgol68m=yes
   ;;
 *-*-phoenix*)
   gas=yes
@@ -1085,6 +1118,8 @@ case ${target} in
   target_has_targetdm=yes
   rust_target_objs="${rust_target_objs} sol2-rust.o"
   target_has_targetrustm=yes
+  algol68_target_objs="${algol68_target_objs} sol2-algol68.o"
+  target_has_targetalgol68m=yes
   ;;
 *-*-*vms*)
   extra_options="${extra_options} vms/vms.opt"
@@ -1120,6 +1155,9 @@ case ${target} in
   rust_target_objs="${rust_target_objs} vxworks-rust.o"
   target_has_targetrustm=yes
 
+  algol68_target_objs="${algol68_target_objs} vxworks-algol68.o"
+  target_has_targetalgol68m=yes
+
   extra_gcc_objs="vxworks-driver.o"
 
   # This private header exposes a consistent interface for checks on
@@ -2246,6 +2284,8 @@ i[34567]86-*-mingw* | x86_64-*-mingw*)
 	target_has_targetdm="yes"
 	rust_target_objs="${rust_target_objs} winnt-rust.o"
 	target_has_targetrustm="yes"
+        algol68_target_objs="${algol68_target_objs} winnt-algol68.o"
+        target_has_targetalgol68m=yes
 	case ${target} in
 		x86_64-*-* | *-w64-*)
 			need_64bit_isa=yes
@@ -3733,6 +3773,10 @@ if [ "$target_has_targetjitm" = "no" ]; then
   jit_target_objs="$jit_target_objs default-jit.o"
 fi
 
+if [ "$target_has_targetalgol68" = "no" ]; then
+  algol68_target_objs="$algol68_target_objs default-algol68.o"
+fi
+
 # Support for --with-cpu and related options (and a few unrelated options,
 # too).
 case ${with_cpu} in
diff --git a/gcc/configure.ac b/gcc/configure.ac
index 1e5f7c3c4d0..41430c5b475 100644
--- a/gcc/configure.ac
+++ b/gcc/configure.ac
@@ -2450,6 +2450,16 @@ for f in $tm_jit_file; do
     * )
        tm_jit_file_list="${tm_jit_file_list} \$(srcdir)/config/$f"
        tm_jit_include_list="${tm_jit_include_list} config/$f"
+  esac
+done
+
+tm_algol68_file_list=
+tm_algol68_include_list=
+for f in $tm_algol68_file; do
+  case $f in
+    * )
+       tm_algol68_file_list="${tm_algol68_file_list} \$(srcdir)/config/$f"
+       tm_algol68_include_list="${tm_algol68_include_list} config/$f"
        ;;
   esac
 done
@@ -7614,6 +7624,8 @@ AC_SUBST(tm_rust_file_list)
 AC_SUBST(tm_rust_include_list)
 AC_SUBST(tm_jit_file_list)
 AC_SUBST(tm_jit_include_list)
+AC_SUBST(tm_algol68_file_list)
+AC_SUBST(tm_algol68_include_list)
 AC_SUBST(xm_file_list)
 AC_SUBST(xm_include_list)
 AC_SUBST(xm_defines)
@@ -7624,6 +7636,7 @@ AC_SUBST(fortran_target_objs)
 AC_SUBST(d_target_objs)
 AC_SUBST(rust_target_objs)
 AC_SUBST(jit_target_objs)
+AC_SUBST(algol68_target_objs)
 AC_SUBST(target_cpu_default)
 
 AC_SUBST_FILE(language_hooks)
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 03/47] a68: build system (regenerated files)
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 01/47] a68: top-level misc files Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 02/47] a68: build system Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 04/47] a68: documentation Jose E. Marchesi
                   ` (44 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds the regenerated configure scripts regenerated by
autoconf that reflect the changes to configure.ac.

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

ChangeLog

	* configure: Regenerate.
	* Makefile.in: Likewise.

gcc/ChangeLog

	* configure: Regenerate.
---
 Makefile.in   | 737 +++++++++++++++++++++++++++++++++++++++++++++++++-
 configure     | 355 +++++++++++++++++++++++-
 gcc/configure |  20 +-
 3 files changed, 1098 insertions(+), 14 deletions(-)

diff --git a/Makefile.in b/Makefile.in
index e95d3107d7b..60610d1b6c1 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -278,6 +278,11 @@ POSTSTAGE1_HOST_EXPORTS = \
 	CC_FOR_BUILD="$$CC"; export CC_FOR_BUILD; \
 	$(POSTSTAGE1_CXX_EXPORT) \
 	$(LTO_EXPORTS) \
+	GA68="$$r/$(HOST_SUBDIR)/prev-gcc/ga68$(exeext) -B$$r/$(HOST_SUBDIR)/prev-gcc/ \
+	  -B$(build_tooldir)/bin/ $(GA68FLAGS_FOR_TARGET) \
+	  -B$$r/prev-$(TARGET_SUBDIR)/libga68/.libs"; \
+	export GA68; \
+	GA68_FOR_BUILD="$$GA68"; export GA68_FOR_BUILD; \
 	GDC="$$r/$(HOST_SUBDIR)/prev-gcc/gdc$(exeext) -B$$r/$(HOST_SUBDIR)/prev-gcc/ \
 	  -B$(build_tooldir)/bin/ $(GDCFLAGS_FOR_TARGET) \
 	  -B$$r/prev-$(TARGET_SUBDIR)/libphobos/libdruntime/gcc \
@@ -310,6 +315,7 @@ BASE_TARGET_EXPORTS = \
 	CPPFLAGS="$(CPPFLAGS_FOR_TARGET)"; export CPPFLAGS; \
 	CXXFLAGS="$(CXXFLAGS_FOR_TARGET)"; export CXXFLAGS; \
 	GFORTRAN="$(GFORTRAN_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GFORTRAN; \
+	GA68="$(GA68_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GA68; \
 	GOC="$(GOC_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GOC; \
 	GDC="$(GDC_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GDC; \
 	GM2="$(GM2_FOR_TARGET) $(XGCC_FLAGS_FOR_TARGET) $$TFLAGS"; export GM2; \
@@ -380,6 +386,7 @@ CXX_FOR_BUILD = @CXX_FOR_BUILD@
 DLLTOOL_FOR_BUILD = @DLLTOOL_FOR_BUILD@
 DSYMUTIL_FOR_BUILD = @DSYMUTIL_FOR_BUILD@
 GFORTRAN_FOR_BUILD = @GFORTRAN_FOR_BUILD@
+GA68_FOR_BUILD = @GA68_FOR_BUILD@
 GOC_FOR_BUILD = @GOC_FOR_BUILD@
 GDC_FOR_BUILD = @GDC_FOR_BUILD@
 GM2_FOR_BUILD = @GM2_FOR_BUILD@
@@ -443,6 +450,7 @@ STRIP = @STRIP@
 WINDRES = @WINDRES@
 WINDMC = @WINDMC@
 
+GA68 = @GA68@
 GDC = @GDC@
 GNATBIND = @GNATBIND@
 GNATMAKE = @GNATMAKE@
@@ -453,6 +461,7 @@ LIBCFLAGS = $(CFLAGS)
 CXXFLAGS = @CXXFLAGS@
 LIBCXXFLAGS = $(CXXFLAGS) -fno-implicit-templates
 GOCFLAGS = $(CFLAGS)
+GA68FLAGS = @GA68FLAGS@
 GDCFLAGS = @GDCFLAGS@
 GM2FLAGS = $(CFLAGS)
 
@@ -678,6 +687,7 @@ CXX_FOR_TARGET=$(STAGE_CC_WRAPPER) @CXX_FOR_TARGET@
 RAW_CXX_FOR_TARGET=$(STAGE_CC_WRAPPER) @RAW_CXX_FOR_TARGET@
 GFORTRAN_FOR_TARGET=$(STAGE_CC_WRAPPER) @GFORTRAN_FOR_TARGET@
 GOC_FOR_TARGET=$(STAGE_CC_WRAPPER) @GOC_FOR_TARGET@
+GA68_FOR_TARGET=$(STAGE_CC_WRAPPER) @GA68_FOR_TARGET@
 GDC_FOR_TARGET=$(STAGE_CC_WRAPPER) @GDC_FOR_TARGET@
 GM2_FOR_TARGET=$(STAGE_CC_WRAPPER) @GM2_FOR_TARGET@
 DLLTOOL_FOR_TARGET=@DLLTOOL_FOR_TARGET@
@@ -707,6 +717,7 @@ LIBCXXFLAGS_FOR_TARGET = $(CXXFLAGS_FOR_TARGET) -fno-implicit-templates
 LDFLAGS_FOR_TARGET = @LDFLAGS_FOR_TARGET@
 GM2FLAGS_FOR_TARGET = -O2 -g
 GOCFLAGS_FOR_TARGET = -O2 -g
+GA68FLAGS_FOR_TARGET = -O2 -g
 GDCFLAGS_FOR_TARGET = -O2 -g
 
 FLAGS_FOR_TARGET = @FLAGS_FOR_TARGET@
@@ -732,7 +743,7 @@ all:
 
 # This is the list of directories that may be needed in RPATH_ENVVAR
 # so that programs built for the target machine work.
-TARGET_LIB_PATH = $(TARGET_LIB_PATH_libstdc++-v3)$(TARGET_LIB_PATH_libsanitizer)$(TARGET_LIB_PATH_libvtv)$(TARGET_LIB_PATH_libssp)$(TARGET_LIB_PATH_libphobos)$(TARGET_LIB_PATH_libgm2)$(TARGET_LIB_PATH_libgomp)$(TARGET_LIB_PATH_libitm)$(TARGET_LIB_PATH_libatomic)$(HOST_LIB_PATH_gcc)
+TARGET_LIB_PATH = $(TARGET_LIB_PATH_libstdc++-v3)$(TARGET_LIB_PATH_libsanitizer)$(TARGET_LIB_PATH_libvtv)$(TARGET_LIB_PATH_libssp)$(TARGET_LIB_PATH_libphobos)$(TARGET_LIB_PATH_libgm2)$(TARGET_LIB_PATH_libga68)$(TARGET_LIB_PATH_libgomp)$(TARGET_LIB_PATH_libitm)$(TARGET_LIB_PATH_libatomic)$(HOST_LIB_PATH_gcc)
 
 @if target-libstdc++-v3
 TARGET_LIB_PATH_libstdc++-v3 = $$r/$(TARGET_SUBDIR)/libstdc++-v3/src/.libs:
@@ -758,6 +769,10 @@ TARGET_LIB_PATH_libphobos = $$r/$(TARGET_SUBDIR)/libphobos/src/.libs:
 TARGET_LIB_PATH_libgm2 = $$r/$(TARGET_SUBDIR)/libgm2/.libs:
 @endif target-libgm2
 
+@if target-libga68
+TARGET_LIB_PATH_libga68 = $$r/$(TARGET_SUBDIR)/libga68/.libs:
+@endif target-libga68
+
 @if target-libgomp
 TARGET_LIB_PATH_libgomp = $$r/$(TARGET_SUBDIR)/libgomp/.libs:
 @endif target-libgomp
@@ -977,6 +992,7 @@ EXTRA_HOST_FLAGS = \
 	'DSYMUTIL=$(DSYMUTIL)' \
 	'GFORTRAN=$(GFORTRAN)' \
 	'GOC=$(GOC)' \
+	'GA68=$(GA68)' \
 	'GDC=$(GDC)' \
 	'GM2=$(GM2)' \
 	'LD=$(LD)' \
@@ -1005,6 +1021,7 @@ STAGE1_FLAGS_TO_PASS = \
 POSTSTAGE1_FLAGS_TO_PASS = \
 	CC="$${CC}" CC_FOR_BUILD="$${CC_FOR_BUILD}" \
 	CXX="$${CXX}" CXX_FOR_BUILD="$${CXX_FOR_BUILD}" \
+	GA68="$${GA68}" GA68_FOR_BUILD="$${GA68_FOR_BUILD}" \
 	GDC="$${GDC}" GDC_FOR_BUILD="$${GDC_FOR_BUILD}" \
 	GM2="$${GM2}" GM2_FOR_BUILD="$${GM2_FOR_BUILD}" \
 	GNATBIND="$${GNATBIND}" \
@@ -1040,6 +1057,7 @@ EXTRA_TARGET_FLAGS = \
 	'GFORTRAN=$$(GFORTRAN_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
 	'GOC=$$(GOC_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
 	'GOCFLAGS=$$(GOCFLAGS_FOR_TARGET)' \
+	'GA68=$$(GA68_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
 	'GDC=$$(GDC_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
 	'GDCFLAGS=$$(GDCFLAGS_FOR_TARGET)' \
 	'GM2=$$(GM2_FOR_TARGET) $$(XGCC_FLAGS_FOR_TARGET) $$(TFLAGS)' \
@@ -1161,6 +1179,7 @@ configure-target:  \
     maybe-configure-target-rda \
     maybe-configure-target-libada \
     maybe-configure-target-libgm2 \
+    maybe-configure-target-libga68 \
     maybe-configure-target-libgomp \
     maybe-configure-target-libitm \
     maybe-configure-target-libatomic \
@@ -1361,6 +1380,7 @@ all-target: maybe-all-target-zlib
 all-target: maybe-all-target-rda
 all-target: maybe-all-target-libada
 all-target: maybe-all-target-libgm2
+all-target: maybe-all-target-libga68
 @if target-libgomp-no-bootstrap
 all-target: maybe-all-target-libgomp
 @endif target-libgomp-no-bootstrap
@@ -1464,6 +1484,7 @@ info-target: maybe-info-target-zlib
 info-target: maybe-info-target-rda
 info-target: maybe-info-target-libada
 info-target: maybe-info-target-libgm2
+info-target: maybe-info-target-libga68
 info-target: maybe-info-target-libgomp
 info-target: maybe-info-target-libitm
 info-target: maybe-info-target-libatomic
@@ -1558,6 +1579,7 @@ dvi-target: maybe-dvi-target-zlib
 dvi-target: maybe-dvi-target-rda
 dvi-target: maybe-dvi-target-libada
 dvi-target: maybe-dvi-target-libgm2
+dvi-target: maybe-dvi-target-libga68
 dvi-target: maybe-dvi-target-libgomp
 dvi-target: maybe-dvi-target-libitm
 dvi-target: maybe-dvi-target-libatomic
@@ -1652,6 +1674,7 @@ pdf-target: maybe-pdf-target-zlib
 pdf-target: maybe-pdf-target-rda
 pdf-target: maybe-pdf-target-libada
 pdf-target: maybe-pdf-target-libgm2
+pdf-target: maybe-pdf-target-libga68
 pdf-target: maybe-pdf-target-libgomp
 pdf-target: maybe-pdf-target-libitm
 pdf-target: maybe-pdf-target-libatomic
@@ -1746,6 +1769,7 @@ html-target: maybe-html-target-zlib
 html-target: maybe-html-target-rda
 html-target: maybe-html-target-libada
 html-target: maybe-html-target-libgm2
+html-target: maybe-html-target-libga68
 html-target: maybe-html-target-libgomp
 html-target: maybe-html-target-libitm
 html-target: maybe-html-target-libatomic
@@ -1840,6 +1864,7 @@ TAGS-target: maybe-TAGS-target-zlib
 TAGS-target: maybe-TAGS-target-rda
 TAGS-target: maybe-TAGS-target-libada
 TAGS-target: maybe-TAGS-target-libgm2
+TAGS-target: maybe-TAGS-target-libga68
 TAGS-target: maybe-TAGS-target-libgomp
 TAGS-target: maybe-TAGS-target-libitm
 TAGS-target: maybe-TAGS-target-libatomic
@@ -1934,6 +1959,7 @@ install-info-target: maybe-install-info-target-zlib
 install-info-target: maybe-install-info-target-rda
 install-info-target: maybe-install-info-target-libada
 install-info-target: maybe-install-info-target-libgm2
+install-info-target: maybe-install-info-target-libga68
 install-info-target: maybe-install-info-target-libgomp
 install-info-target: maybe-install-info-target-libitm
 install-info-target: maybe-install-info-target-libatomic
@@ -2028,6 +2054,7 @@ install-dvi-target: maybe-install-dvi-target-zlib
 install-dvi-target: maybe-install-dvi-target-rda
 install-dvi-target: maybe-install-dvi-target-libada
 install-dvi-target: maybe-install-dvi-target-libgm2
+install-dvi-target: maybe-install-dvi-target-libga68
 install-dvi-target: maybe-install-dvi-target-libgomp
 install-dvi-target: maybe-install-dvi-target-libitm
 install-dvi-target: maybe-install-dvi-target-libatomic
@@ -2122,6 +2149,7 @@ install-pdf-target: maybe-install-pdf-target-zlib
 install-pdf-target: maybe-install-pdf-target-rda
 install-pdf-target: maybe-install-pdf-target-libada
 install-pdf-target: maybe-install-pdf-target-libgm2
+install-pdf-target: maybe-install-pdf-target-libga68
 install-pdf-target: maybe-install-pdf-target-libgomp
 install-pdf-target: maybe-install-pdf-target-libitm
 install-pdf-target: maybe-install-pdf-target-libatomic
@@ -2216,6 +2244,7 @@ install-html-target: maybe-install-html-target-zlib
 install-html-target: maybe-install-html-target-rda
 install-html-target: maybe-install-html-target-libada
 install-html-target: maybe-install-html-target-libgm2
+install-html-target: maybe-install-html-target-libga68
 install-html-target: maybe-install-html-target-libgomp
 install-html-target: maybe-install-html-target-libitm
 install-html-target: maybe-install-html-target-libatomic
@@ -2310,6 +2339,7 @@ installcheck-target: maybe-installcheck-target-zlib
 installcheck-target: maybe-installcheck-target-rda
 installcheck-target: maybe-installcheck-target-libada
 installcheck-target: maybe-installcheck-target-libgm2
+installcheck-target: maybe-installcheck-target-libga68
 installcheck-target: maybe-installcheck-target-libgomp
 installcheck-target: maybe-installcheck-target-libitm
 installcheck-target: maybe-installcheck-target-libatomic
@@ -2404,6 +2434,7 @@ mostlyclean-target: maybe-mostlyclean-target-zlib
 mostlyclean-target: maybe-mostlyclean-target-rda
 mostlyclean-target: maybe-mostlyclean-target-libada
 mostlyclean-target: maybe-mostlyclean-target-libgm2
+mostlyclean-target: maybe-mostlyclean-target-libga68
 mostlyclean-target: maybe-mostlyclean-target-libgomp
 mostlyclean-target: maybe-mostlyclean-target-libitm
 mostlyclean-target: maybe-mostlyclean-target-libatomic
@@ -2498,6 +2529,7 @@ clean-target: maybe-clean-target-zlib
 clean-target: maybe-clean-target-rda
 clean-target: maybe-clean-target-libada
 clean-target: maybe-clean-target-libgm2
+clean-target: maybe-clean-target-libga68
 clean-target: maybe-clean-target-libgomp
 clean-target: maybe-clean-target-libitm
 clean-target: maybe-clean-target-libatomic
@@ -2592,6 +2624,7 @@ distclean-target: maybe-distclean-target-zlib
 distclean-target: maybe-distclean-target-rda
 distclean-target: maybe-distclean-target-libada
 distclean-target: maybe-distclean-target-libgm2
+distclean-target: maybe-distclean-target-libga68
 distclean-target: maybe-distclean-target-libgomp
 distclean-target: maybe-distclean-target-libitm
 distclean-target: maybe-distclean-target-libatomic
@@ -2686,6 +2719,7 @@ maintainer-clean-target: maybe-maintainer-clean-target-zlib
 maintainer-clean-target: maybe-maintainer-clean-target-rda
 maintainer-clean-target: maybe-maintainer-clean-target-libada
 maintainer-clean-target: maybe-maintainer-clean-target-libgm2
+maintainer-clean-target: maybe-maintainer-clean-target-libga68
 maintainer-clean-target: maybe-maintainer-clean-target-libgomp
 maintainer-clean-target: maybe-maintainer-clean-target-libitm
 maintainer-clean-target: maybe-maintainer-clean-target-libatomic
@@ -2838,6 +2872,7 @@ check-target:  \
     maybe-check-target-rda \
     maybe-check-target-libada \
     maybe-check-target-libgm2 \
+    maybe-check-target-libga68 \
     maybe-check-target-libgomp \
     maybe-check-target-libitm \
     maybe-check-target-libatomic \
@@ -3036,6 +3071,7 @@ install-target:  \
     maybe-install-target-rda \
     maybe-install-target-libada \
     maybe-install-target-libgm2 \
+    maybe-install-target-libga68 \
     maybe-install-target-libgomp \
     maybe-install-target-libitm \
     maybe-install-target-libatomic \
@@ -3150,6 +3186,7 @@ install-strip-target:  \
     maybe-install-strip-target-rda \
     maybe-install-strip-target-libada \
     maybe-install-strip-target-libgm2 \
+    maybe-install-strip-target-libga68 \
     maybe-install-strip-target-libgomp \
     maybe-install-strip-target-libitm \
     maybe-install-strip-target-libatomic \
@@ -60201,6 +60238,491 @@ maintainer-clean-target-libgm2:
 
 
 
+.PHONY: configure-target-libga68 maybe-configure-target-libga68
+maybe-configure-target-libga68:
+@if gcc-bootstrap
+configure-target-libga68: stage_current
+@endif gcc-bootstrap
+@if target-libga68
+maybe-configure-target-libga68: configure-target-libga68
+configure-target-libga68: 
+	@: $(MAKE); $(unstage)
+	@r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	echo "Checking multilib configuration for libga68..."; \
+	$(SHELL) $(srcdir)/mkinstalldirs $(TARGET_SUBDIR)/libga68; \
+	$(CC_FOR_TARGET) --print-multi-lib > $(TARGET_SUBDIR)/libga68/multilib.tmp 2> /dev/null; \
+	if test -r $(TARGET_SUBDIR)/libga68/multilib.out; then \
+	  if cmp -s $(TARGET_SUBDIR)/libga68/multilib.tmp $(TARGET_SUBDIR)/libga68/multilib.out; then \
+	    rm -f $(TARGET_SUBDIR)/libga68/multilib.tmp; \
+	  else \
+	    rm -f $(TARGET_SUBDIR)/libga68/Makefile; \
+	    mv $(TARGET_SUBDIR)/libga68/multilib.tmp $(TARGET_SUBDIR)/libga68/multilib.out; \
+	  fi; \
+	else \
+	  mv $(TARGET_SUBDIR)/libga68/multilib.tmp $(TARGET_SUBDIR)/libga68/multilib.out; \
+	fi; \
+	test ! -f $(TARGET_SUBDIR)/libga68/Makefile || exit 0; \
+	$(SHELL) $(srcdir)/mkinstalldirs $(TARGET_SUBDIR)/libga68; \
+	$(NORMAL_TARGET_EXPORTS)  \
+	echo Configuring in $(TARGET_SUBDIR)/libga68; \
+	cd "$(TARGET_SUBDIR)/libga68" || exit 1; \
+	case $(srcdir) in \
+	  /* | [A-Za-z]:[\\/]*) topdir=$(srcdir) ;; \
+	  *) topdir=`echo $(TARGET_SUBDIR)/libga68/ | \
+		sed -e 's,\./,,g' -e 's,[^/]*/,../,g' `$(srcdir) ;; \
+	esac; \
+	module_srcdir=libga68; \
+	rm -f no-such-file || : ; \
+	CONFIG_SITE=no-such-file $(SHELL) \
+	  $$s/$$module_srcdir/configure \
+	  --srcdir=$${topdir}/$$module_srcdir \
+	  $(TARGET_CONFIGARGS) --build=${build_alias} --host=${target_alias} \
+	  --target=${target_alias}  \
+	  || exit 1
+@endif target-libga68
+
+
+
+
+
+.PHONY: all-target-libga68 maybe-all-target-libga68
+maybe-all-target-libga68:
+@if gcc-bootstrap
+all-target-libga68: stage_current
+@endif gcc-bootstrap
+@if target-libga68
+TARGET-target-libga68=all
+maybe-all-target-libga68: all-target-libga68
+all-target-libga68: configure-target-libga68
+	@: $(MAKE); $(unstage)
+	@r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS)  \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) $(EXTRA_TARGET_FLAGS)   \
+		$(TARGET-target-libga68))
+@endif target-libga68
+
+
+
+
+
+.PHONY: check-target-libga68 maybe-check-target-libga68
+maybe-check-target-libga68:
+@if target-libga68
+maybe-check-target-libga68: check-target-libga68
+
+check-target-libga68:
+	@: $(MAKE); $(unstage)
+	@r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(TARGET_FLAGS_TO_PASS)   check)
+
+@endif target-libga68
+
+.PHONY: install-target-libga68 maybe-install-target-libga68
+maybe-install-target-libga68:
+@if target-libga68
+maybe-install-target-libga68: install-target-libga68
+
+install-target-libga68: installdirs
+	@: $(MAKE); $(unstage)
+	@r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(TARGET_FLAGS_TO_PASS)  install)
+
+@endif target-libga68
+
+.PHONY: install-strip-target-libga68 maybe-install-strip-target-libga68
+maybe-install-strip-target-libga68:
+@if target-libga68
+maybe-install-strip-target-libga68: install-strip-target-libga68
+
+install-strip-target-libga68: installdirs
+	@: $(MAKE); $(unstage)
+	@r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(TARGET_FLAGS_TO_PASS)  install-strip)
+
+@endif target-libga68
+
+# Other targets (info, dvi, pdf, etc.)
+
+.PHONY: maybe-info-target-libga68 info-target-libga68
+maybe-info-target-libga68:
+@if target-libga68
+maybe-info-target-libga68: info-target-libga68
+
+info-target-libga68: \
+    configure-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing info in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           info) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-dvi-target-libga68 dvi-target-libga68
+maybe-dvi-target-libga68:
+@if target-libga68
+maybe-dvi-target-libga68: dvi-target-libga68
+
+dvi-target-libga68: \
+    configure-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing dvi in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           dvi) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-pdf-target-libga68 pdf-target-libga68
+maybe-pdf-target-libga68:
+@if target-libga68
+maybe-pdf-target-libga68: pdf-target-libga68
+
+pdf-target-libga68: \
+    configure-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing pdf in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           pdf) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-html-target-libga68 html-target-libga68
+maybe-html-target-libga68:
+@if target-libga68
+maybe-html-target-libga68: html-target-libga68
+
+html-target-libga68: \
+    configure-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing html in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           html) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-TAGS-target-libga68 TAGS-target-libga68
+maybe-TAGS-target-libga68:
+@if target-libga68
+maybe-TAGS-target-libga68: TAGS-target-libga68
+
+TAGS-target-libga68: \
+    configure-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing TAGS in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           TAGS) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-install-info-target-libga68 install-info-target-libga68
+maybe-install-info-target-libga68:
+@if target-libga68
+maybe-install-info-target-libga68: install-info-target-libga68
+
+install-info-target-libga68: \
+    configure-target-libga68 \
+    info-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing install-info in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           install-info) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-install-dvi-target-libga68 install-dvi-target-libga68
+maybe-install-dvi-target-libga68:
+@if target-libga68
+maybe-install-dvi-target-libga68: install-dvi-target-libga68
+
+install-dvi-target-libga68: \
+    configure-target-libga68 \
+    dvi-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing install-dvi in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           install-dvi) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-install-pdf-target-libga68 install-pdf-target-libga68
+maybe-install-pdf-target-libga68:
+@if target-libga68
+maybe-install-pdf-target-libga68: install-pdf-target-libga68
+
+install-pdf-target-libga68: \
+    configure-target-libga68 \
+    pdf-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing install-pdf in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           install-pdf) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-install-html-target-libga68 install-html-target-libga68
+maybe-install-html-target-libga68:
+@if target-libga68
+maybe-install-html-target-libga68: install-html-target-libga68
+
+install-html-target-libga68: \
+    configure-target-libga68 \
+    html-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing install-html in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           install-html) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-installcheck-target-libga68 installcheck-target-libga68
+maybe-installcheck-target-libga68:
+@if target-libga68
+maybe-installcheck-target-libga68: installcheck-target-libga68
+
+installcheck-target-libga68: \
+    configure-target-libga68 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing installcheck in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           installcheck) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-mostlyclean-target-libga68 mostlyclean-target-libga68
+maybe-mostlyclean-target-libga68:
+@if target-libga68
+maybe-mostlyclean-target-libga68: mostlyclean-target-libga68
+
+mostlyclean-target-libga68: 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing mostlyclean in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           mostlyclean) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-clean-target-libga68 clean-target-libga68
+maybe-clean-target-libga68:
+@if target-libga68
+maybe-clean-target-libga68: clean-target-libga68
+
+clean-target-libga68: 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing clean in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           clean) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-distclean-target-libga68 distclean-target-libga68
+maybe-distclean-target-libga68:
+@if target-libga68
+maybe-distclean-target-libga68: distclean-target-libga68
+
+distclean-target-libga68: 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing distclean in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           distclean) \
+	  || exit 1
+
+@endif target-libga68
+
+.PHONY: maybe-maintainer-clean-target-libga68 maintainer-clean-target-libga68
+maybe-maintainer-clean-target-libga68:
+@if target-libga68
+maybe-maintainer-clean-target-libga68: maintainer-clean-target-libga68
+
+maintainer-clean-target-libga68: 
+	@: $(MAKE); $(unstage)
+	@[ -f $(TARGET_SUBDIR)/libga68/Makefile ] || exit 0; \
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(NORMAL_TARGET_EXPORTS) \
+	echo "Doing maintainer-clean in $(TARGET_SUBDIR)/libga68"; \
+	for flag in $(EXTRA_TARGET_FLAGS); do \
+	  eval `echo "$$flag" | sed -e "s|^\([^=]*\)=\(.*\)|\1='\2'; export \1|"`; \
+	done; \
+	(cd $(TARGET_SUBDIR)/libga68 && \
+	  $(MAKE) $(BASE_FLAGS_TO_PASS) "AR=$${AR}" "AS=$${AS}" \
+	          "CC=$${CC}" "CXX=$${CXX}" "LD=$${LD}" "NM=$${NM}" \
+	          "RANLIB=$${RANLIB}" \
+	          "DLLTOOL=$${DLLTOOL}" "WINDRES=$${WINDRES}" "WINDMC=$${WINDMC}" \
+	           maintainer-clean) \
+	  || exit 1
+
+@endif target-libga68
+
+
+
+
+
 .PHONY: configure-target-libgomp maybe-configure-target-libgomp
 maybe-configure-target-libgomp:
 @if gcc-bootstrap
@@ -64336,6 +64858,14 @@ check-gcc-cobol: gcc-site.exp
 	(cd gcc && $(MAKE) $(GCC_FLAGS_TO_PASS) check-cobol);
 check-cobol: check-gcc-cobol check-target-libgcobol
 
+.PHONY: check-gcc-algol68 check-algol68
+check-gcc-algol68: gcc-site.exp
+	r=`${PWD_COMMAND}`; export r; \
+	s=`cd $(srcdir); ${PWD_COMMAND}`; export s; \
+	$(HOST_EXPORTS) \
+	(cd gcc && $(MAKE) $(GCC_FLAGS_TO_PASS) check-algol68);
+check-algol68: check-gcc-algol68 check-target-libga68
+
 
 # The gcc part of install-no-fixedincludes, which relies on an intimate
 # knowledge of how a number of gcc internal targets (inter)operate.  Delegate.
@@ -67877,6 +68407,7 @@ configure-stageautofeedback-target-zlib: maybe-all-stageautofeedback-gcc
 configure-target-rda: stage_last
 configure-target-libada: stage_last
 configure-target-libgm2: stage_last
+configure-target-libga68: stage_last
 configure-stage1-target-libgomp: maybe-all-stage1-gcc
 configure-stage2-target-libgomp: maybe-all-stage2-gcc
 configure-stage3-target-libgomp: maybe-all-stage3-gcc
@@ -67921,6 +68452,7 @@ configure-target-zlib: maybe-all-gcc
 configure-target-rda: maybe-all-gcc
 configure-target-libada: maybe-all-gcc
 configure-target-libgm2: maybe-all-gcc
+configure-target-libga68: maybe-all-gcc
 configure-target-libgomp: maybe-all-gcc
 configure-target-libitm: maybe-all-gcc
 configure-target-libatomic: maybe-all-gcc
@@ -69221,6 +69753,9 @@ all-target-libgm2: maybe-all-target-libatomic
 @unless target-libstdc++-v3-bootstrap
 configure-target-libgrust: maybe-all-target-libstdc++-v3
 @endunless target-libstdc++-v3-bootstrap
+@unless target-libstdc++-v3-bootstrap
+configure-target-libga68: maybe-all-target-libstdc++-v3
+@endunless target-libstdc++-v3-bootstrap
 @unless target-libbacktrace-bootstrap
 configure-target-libgfortran: maybe-all-target-libbacktrace
 @endunless target-libbacktrace-bootstrap
@@ -69284,6 +69819,7 @@ all-target-libgo: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libstdc++-v3
 all-target-libgm2: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libstdc++-v3
+configure-target-libga68: maybe-all-target-libstdc++-v3
 configure-target-newlib: maybe-all-binutils
 configure-target-newlib: maybe-all-ld
 configure-target-libgfortran: maybe-all-target-libbacktrace
@@ -69390,6 +69926,7 @@ configure-target-zlib: maybe-all-target-libgcc
 configure-target-rda: maybe-all-target-libgcc
 configure-target-libada: maybe-all-target-libgcc
 configure-target-libgm2: maybe-all-target-libgcc
+configure-target-libga68: maybe-all-target-libgcc
 configure-target-libgomp: maybe-all-target-libgcc
 configure-target-libitm: maybe-all-target-libgcc
 configure-target-libatomic: maybe-all-target-libgcc
@@ -69554,6 +70091,15 @@ configure-stagetrain-target-libgm2: maybe-all-stagetrain-target-libatomic
 configure-stagefeedback-target-libgm2: maybe-all-stagefeedback-target-libatomic
 configure-stageautoprofile-target-libgm2: maybe-all-stageautoprofile-target-libatomic
 configure-stageautofeedback-target-libgm2: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libga68: maybe-all-stage1-target-libatomic
+configure-stage2-target-libga68: maybe-all-stage2-target-libatomic
+configure-stage3-target-libga68: maybe-all-stage3-target-libatomic
+configure-stage4-target-libga68: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libga68: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libga68: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libga68: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libga68: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libga68: maybe-all-stageautofeedback-target-libatomic
 configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
 configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
 configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
@@ -69601,6 +70147,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -69762,6 +70309,15 @@ configure-stagetrain-target-libgm2: maybe-all-stagetrain-target-libatomic
 configure-stagefeedback-target-libgm2: maybe-all-stagefeedback-target-libatomic
 configure-stageautoprofile-target-libgm2: maybe-all-stageautoprofile-target-libatomic
 configure-stageautofeedback-target-libgm2: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libga68: maybe-all-stage1-target-libatomic
+configure-stage2-target-libga68: maybe-all-stage2-target-libatomic
+configure-stage3-target-libga68: maybe-all-stage3-target-libatomic
+configure-stage4-target-libga68: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libga68: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libga68: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libga68: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libga68: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libga68: maybe-all-stageautofeedback-target-libatomic
 configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
 configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
 configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
@@ -69809,6 +70365,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -69970,6 +70527,15 @@ configure-stagetrain-target-libgm2: maybe-all-stagetrain-target-libatomic
 configure-stagefeedback-target-libgm2: maybe-all-stagefeedback-target-libatomic
 configure-stageautoprofile-target-libgm2: maybe-all-stageautoprofile-target-libatomic
 configure-stageautofeedback-target-libgm2: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libga68: maybe-all-stage1-target-libatomic
+configure-stage2-target-libga68: maybe-all-stage2-target-libatomic
+configure-stage3-target-libga68: maybe-all-stage3-target-libatomic
+configure-stage4-target-libga68: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libga68: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libga68: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libga68: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libga68: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libga68: maybe-all-stageautofeedback-target-libatomic
 configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
 configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
 configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
@@ -70017,6 +70583,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -70108,6 +70675,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -70198,6 +70766,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -70358,6 +70927,15 @@ configure-stagetrain-target-libgm2: maybe-all-stagetrain-target-libatomic
 configure-stagefeedback-target-libgm2: maybe-all-stagefeedback-target-libatomic
 configure-stageautoprofile-target-libgm2: maybe-all-stageautoprofile-target-libatomic
 configure-stageautofeedback-target-libgm2: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libga68: maybe-all-stage1-target-libatomic
+configure-stage2-target-libga68: maybe-all-stage2-target-libatomic
+configure-stage3-target-libga68: maybe-all-stage3-target-libatomic
+configure-stage4-target-libga68: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libga68: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libga68: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libga68: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libga68: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libga68: maybe-all-stageautofeedback-target-libatomic
 configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
 configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
 configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
@@ -70405,6 +70983,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -70566,6 +71145,15 @@ configure-stagetrain-target-libgm2: maybe-all-stagetrain-target-libatomic
 configure-stagefeedback-target-libgm2: maybe-all-stagefeedback-target-libatomic
 configure-stageautoprofile-target-libgm2: maybe-all-stageautoprofile-target-libatomic
 configure-stageautofeedback-target-libgm2: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libga68: maybe-all-stage1-target-libatomic
+configure-stage2-target-libga68: maybe-all-stage2-target-libatomic
+configure-stage3-target-libga68: maybe-all-stage3-target-libatomic
+configure-stage4-target-libga68: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libga68: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libga68: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libga68: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libga68: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libga68: maybe-all-stageautofeedback-target-libatomic
 configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
 configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
 configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
@@ -70613,6 +71201,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -70704,6 +71293,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -70795,6 +71385,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -70886,6 +71477,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -70977,6 +71569,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -71138,6 +71731,15 @@ configure-stagetrain-target-libgm2: maybe-all-stagetrain-target-libatomic
 configure-stagefeedback-target-libgm2: maybe-all-stagefeedback-target-libatomic
 configure-stageautoprofile-target-libgm2: maybe-all-stageautoprofile-target-libatomic
 configure-stageautofeedback-target-libgm2: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libga68: maybe-all-stage1-target-libatomic
+configure-stage2-target-libga68: maybe-all-stage2-target-libatomic
+configure-stage3-target-libga68: maybe-all-stage3-target-libatomic
+configure-stage4-target-libga68: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libga68: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libga68: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libga68: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libga68: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libga68: maybe-all-stageautofeedback-target-libatomic
 configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
 configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
 configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
@@ -71185,6 +71787,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -71276,6 +71879,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -71367,6 +71971,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -71457,6 +72062,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -71549,6 +72155,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -71710,6 +72317,15 @@ configure-stagetrain-target-libgm2: maybe-all-stagetrain-target-libatomic
 configure-stagefeedback-target-libgm2: maybe-all-stagefeedback-target-libatomic
 configure-stageautoprofile-target-libgm2: maybe-all-stageautoprofile-target-libatomic
 configure-stageautofeedback-target-libgm2: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libga68: maybe-all-stage1-target-libatomic
+configure-stage2-target-libga68: maybe-all-stage2-target-libatomic
+configure-stage3-target-libga68: maybe-all-stage3-target-libatomic
+configure-stage4-target-libga68: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libga68: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libga68: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libga68: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libga68: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libga68: maybe-all-stageautofeedback-target-libatomic
 configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
 configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
 configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
@@ -71757,6 +72373,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -71848,6 +72465,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -71939,6 +72557,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -72030,6 +72649,99 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
+configure-target-libgomp: maybe-all-target-libatomic
+configure-target-libitm: maybe-all-target-libatomic
+configure-target-libgrust: maybe-all-target-libatomic
+@endif gcc-no-bootstrap
+
+configure-target-libga68: maybe-all-target-newlib maybe-all-target-libgloss
+
+@if gcc-bootstrap
+configure-stage1-target-libstdc++-v3: maybe-all-stage1-target-libatomic
+configure-stage2-target-libstdc++-v3: maybe-all-stage2-target-libatomic
+configure-stage3-target-libstdc++-v3: maybe-all-stage3-target-libatomic
+configure-stage4-target-libstdc++-v3: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libstdc++-v3: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libstdc++-v3: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libstdc++-v3: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libstdc++-v3: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libstdc++-v3: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libsanitizer: maybe-all-stage1-target-libatomic
+configure-stage2-target-libsanitizer: maybe-all-stage2-target-libatomic
+configure-stage3-target-libsanitizer: maybe-all-stage3-target-libatomic
+configure-stage4-target-libsanitizer: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libsanitizer: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libsanitizer: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libsanitizer: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libsanitizer: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libsanitizer: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libvtv: maybe-all-stage1-target-libatomic
+configure-stage2-target-libvtv: maybe-all-stage2-target-libatomic
+configure-stage3-target-libvtv: maybe-all-stage3-target-libatomic
+configure-stage4-target-libvtv: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libvtv: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libvtv: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libvtv: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libvtv: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libvtv: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libbacktrace: maybe-all-stage1-target-libatomic
+configure-stage2-target-libbacktrace: maybe-all-stage2-target-libatomic
+configure-stage3-target-libbacktrace: maybe-all-stage3-target-libatomic
+configure-stage4-target-libbacktrace: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libbacktrace: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libbacktrace: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libbacktrace: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libbacktrace: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libbacktrace: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libphobos: maybe-all-stage1-target-libatomic
+configure-stage2-target-libphobos: maybe-all-stage2-target-libatomic
+configure-stage3-target-libphobos: maybe-all-stage3-target-libatomic
+configure-stage4-target-libphobos: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libphobos: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libphobos: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libphobos: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libphobos: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libphobos: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-zlib: maybe-all-stage1-target-libatomic
+configure-stage2-target-zlib: maybe-all-stage2-target-libatomic
+configure-stage3-target-zlib: maybe-all-stage3-target-libatomic
+configure-stage4-target-zlib: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-zlib: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-zlib: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-zlib: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-zlib: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-zlib: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
+configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
+configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
+configure-stage4-target-libgomp: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libgomp: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libgomp: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libgomp: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libgomp: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libgomp: maybe-all-stageautofeedback-target-libatomic
+@endif gcc-bootstrap
+
+@if gcc-no-bootstrap
+configure-target-libstdc++-v3: maybe-all-target-libatomic
+configure-target-libsanitizer: maybe-all-target-libatomic
+configure-target-libvtv: maybe-all-target-libatomic
+configure-target-libssp: maybe-all-target-libatomic
+configure-target-libbacktrace: maybe-all-target-libatomic
+configure-target-libquadmath: maybe-all-target-libatomic
+configure-target-libgfortran: maybe-all-target-libatomic
+configure-target-libobjc: maybe-all-target-libatomic
+configure-target-libgo: maybe-all-target-libatomic
+configure-target-libphobos: maybe-all-target-libatomic
+configure-target-libtermcap: maybe-all-target-libatomic
+configure-target-winsup: maybe-all-target-libatomic
+configure-target-libffi: maybe-all-target-libatomic
+configure-target-zlib: maybe-all-target-libatomic
+configure-target-rda: maybe-all-target-libatomic
+configure-target-libada: maybe-all-target-libatomic
+configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -72191,6 +72903,15 @@ configure-stagetrain-target-libgm2: maybe-all-stagetrain-target-libatomic
 configure-stagefeedback-target-libgm2: maybe-all-stagefeedback-target-libatomic
 configure-stageautoprofile-target-libgm2: maybe-all-stageautoprofile-target-libatomic
 configure-stageautofeedback-target-libgm2: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libga68: maybe-all-stage1-target-libatomic
+configure-stage2-target-libga68: maybe-all-stage2-target-libatomic
+configure-stage3-target-libga68: maybe-all-stage3-target-libatomic
+configure-stage4-target-libga68: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libga68: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libga68: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libga68: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libga68: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libga68: maybe-all-stageautofeedback-target-libatomic
 configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
 configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
 configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
@@ -72238,6 +72959,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -72330,6 +73052,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -72491,6 +73214,15 @@ configure-stagetrain-target-libgm2: maybe-all-stagetrain-target-libatomic
 configure-stagefeedback-target-libgm2: maybe-all-stagefeedback-target-libatomic
 configure-stageautoprofile-target-libgm2: maybe-all-stageautoprofile-target-libatomic
 configure-stageautofeedback-target-libgm2: maybe-all-stageautofeedback-target-libatomic
+configure-stage1-target-libga68: maybe-all-stage1-target-libatomic
+configure-stage2-target-libga68: maybe-all-stage2-target-libatomic
+configure-stage3-target-libga68: maybe-all-stage3-target-libatomic
+configure-stage4-target-libga68: maybe-all-stage4-target-libatomic
+configure-stageprofile-target-libga68: maybe-all-stageprofile-target-libatomic
+configure-stagetrain-target-libga68: maybe-all-stagetrain-target-libatomic
+configure-stagefeedback-target-libga68: maybe-all-stagefeedback-target-libatomic
+configure-stageautoprofile-target-libga68: maybe-all-stageautoprofile-target-libatomic
+configure-stageautofeedback-target-libga68: maybe-all-stageautofeedback-target-libatomic
 configure-stage1-target-libgomp: maybe-all-stage1-target-libatomic
 configure-stage2-target-libgomp: maybe-all-stage2-target-libatomic
 configure-stage3-target-libgomp: maybe-all-stage3-target-libatomic
@@ -72538,6 +73270,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -72629,6 +73362,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
@@ -72721,6 +73455,7 @@ configure-target-zlib: maybe-all-target-libatomic
 configure-target-rda: maybe-all-target-libatomic
 configure-target-libada: maybe-all-target-libatomic
 configure-target-libgm2: maybe-all-target-libatomic
+configure-target-libga68: maybe-all-target-libatomic
 configure-target-libgomp: maybe-all-target-libatomic
 configure-target-libitm: maybe-all-target-libatomic
 configure-target-libgrust: maybe-all-target-libatomic
diff --git a/configure b/configure
index 4f2ba5e8a05..942bc23e435 100755
--- a/configure
+++ b/configure
@@ -620,6 +620,7 @@ AR_FOR_TARGET
 GM2_FOR_TARGET
 GDC_FOR_TARGET
 GOC_FOR_TARGET
+GA68_FOR_TARGET
 GFORTRAN_FOR_TARGET
 GCC_FOR_TARGET
 CXX_FOR_TARGET
@@ -633,6 +634,7 @@ GREP
 CPP
 PKG_CONFIG_PATH
 GDCFLAGS
+GA68FLAGS
 READELF
 OTOOL
 OBJDUMP
@@ -665,6 +667,7 @@ LDFLAGS_FOR_BUILD
 GNATMAKE_FOR_BUILD
 GDC_FOR_BUILD
 GOC_FOR_BUILD
+GA68_FOR_BUILD
 GFORTRAN_FOR_BUILD
 DSYMUTIL_FOR_BUILD
 DLLTOOL_FOR_BUILD
@@ -728,6 +731,7 @@ HAVE_CXX14
 do_compare
 CARGO
 GDC
+GA68
 GNATMAKE
 GNATBIND
 ac_ct_CXX
@@ -829,6 +833,7 @@ enable_libquadmath
 enable_libquadmath_support
 enable_libada
 enable_libgm2
+enable_libga68
 enable_libssp
 enable_libstdcxx
 enable_bootstrap
@@ -859,6 +864,7 @@ enable_host_shared
 enable_libgdiagnostics
 enable_stage1_languages
 enable_objc_gc
+enable_algol68_gc
 with_target_bdw_gc
 with_target_bdw_gc_include
 with_target_bdw_gc_lib
@@ -907,6 +913,7 @@ CC_FOR_TARGET
 CXX_FOR_TARGET
 GCC_FOR_TARGET
 GFORTRAN_FOR_TARGET
+GA68_FOR_TARGET
 GOC_FOR_TARGET
 GDC_FOR_TARGET
 GM2_FOR_TARGET
@@ -1576,6 +1583,7 @@ Optional Features:
                           disable libquadmath support for Fortran
   --enable-libada         build libada directory
   --enable-libgm2         build libgm2 directory
+  --enable-libga68        build libga68 directory
   --enable-libssp         build libssp directory
   --disable-libstdcxx     do not build libstdc++-v3 directory
   --enable-bootstrap      enable bootstrapping [yes if native build]
@@ -1599,6 +1607,8 @@ Optional Features:
                           Mostly useful for compiler development
   --enable-objc-gc        enable use of Boehm's garbage collector with the GNU
                           Objective-C runtime
+  --enable-algol68-gc     enable use of Boehm's garbage collector with the GNU
+                          Algol runtime
   --enable-vtable-verify  Enable vtable verification feature
   --enable-serial-[{host,target,build}-]configure
                           force sequential configuration of sub-packages for
@@ -1712,6 +1722,8 @@ Some influential environment variables:
               GCC for the target
   GFORTRAN_FOR_TARGET
               GFORTRAN for the target
+  GA68_FOR_TARGET
+              GA68 for the target
   GOC_FOR_TARGET
               GOC for the target
   GDC_FOR_TARGET
@@ -2916,6 +2928,7 @@ target_libraries="target-libgcc \
 		target-libgcobol \
 		target-libada \
 		target-libgm2 \
+                target-libga68 \
 		target-libgo \
 		target-libgrust \
 		target-libphobos \
@@ -3319,6 +3332,14 @@ if test "${ENABLE_LIBGM2}" != "yes" ; then
   noconfigdirs="$noconfigdirs gm2tools"
 fi
 
+# Check whether --enable-libga68 was given.
+if test "${enable_libga68+set}" = set; then :
+  enableval=$enable_libga68; ENABLE_LIBGA68=$enableval
+else
+  ENABLE_LIBGA68=yes
+fi
+
+
 # Check whether --enable-libssp was given.
 if test "${enable_libssp+set}" = set; then :
   enableval=$enable_libssp; ENABLE_LIBSSP=$enableval
@@ -4301,6 +4322,7 @@ if test "${build}" != "${host}" ; then
   DLLTOOL_FOR_BUILD=${DLLTOOL_FOR_BUILD-dlltool}
   DSYMUTIL_FOR_BUILD=${DSYMUTIL_FOR_BUILD-dsymutil}
   GFORTRAN_FOR_BUILD=${GFORTRAN_FOR_BUILD-gfortran}
+  GA68_FOR_BUILD=${GA68_FOR_BUILD-ga68}
   GOC_FOR_BUILD=${GOC_FOR_BUILD-gccgo}
   GDC_FOR_BUILD=${GDC_FOR_BUILD-gdc}
   GNATMAKE_FOR_BUILD=${GNATMAKE_FOR_BUILD-gnatmake}
@@ -4317,6 +4339,7 @@ else
   DLLTOOL_FOR_BUILD="\$(DLLTOOL)"
   DSYMUTIL_FOR_BUILD="\$(DSYMUTIL)"
   GFORTRAN_FOR_BUILD="\$(GFORTRAN)"
+  GA68_FOR_BUILD="\$(GA68)"
   GOC_FOR_BUILD="\$(GOC)"
   GDC_FOR_BUILD="\$(GDC)"
   GNATMAKE_FOR_BUILD="\$(GNATMAKE)"
@@ -5837,6 +5860,100 @@ fi
 
 
 
+if test -n "$ac_tool_prefix"; then
+  # Extract the first word of "${ac_tool_prefix}ga68", so it can be a program name with args.
+set dummy ${ac_tool_prefix}ga68; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_GA68+:} false; then :
+  $as_echo_n "(cached) " >&6
+else
+  if test -n "$GA68"; then
+  ac_cv_prog_GA68="$GA68" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+  IFS=$as_save_IFS
+  test -z "$as_dir" && as_dir=.
+    for ac_exec_ext in '' $ac_executable_extensions; do
+  if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+    ac_cv_prog_GA68="${ac_tool_prefix}ga68"
+    $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+    break 2
+  fi
+done
+  done
+IFS=$as_save_IFS
+
+fi
+fi
+GA68=$ac_cv_prog_GA68
+if test -n "$GA68"; then
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GA68" >&5
+$as_echo "$GA68" >&6; }
+else
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+fi
+if test -z "$ac_cv_prog_GA68"; then
+  ac_ct_GA68=$GA68
+  # Extract the first word of "ga68", so it can be a program name with args.
+set dummy ga68; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_ac_ct_GA68+:} false; then :
+  $as_echo_n "(cached) " >&6
+else
+  if test -n "$ac_ct_GA68"; then
+  ac_cv_prog_ac_ct_GA68="$ac_ct_GA68" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+  IFS=$as_save_IFS
+  test -z "$as_dir" && as_dir=.
+    for ac_exec_ext in '' $ac_executable_extensions; do
+  if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+    ac_cv_prog_ac_ct_GA68="ga68"
+    $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+    break 2
+  fi
+done
+  done
+IFS=$as_save_IFS
+
+fi
+fi
+ac_ct_GA68=$ac_cv_prog_ac_ct_GA68
+if test -n "$ac_ct_GA68"; then
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_GA68" >&5
+$as_echo "$ac_ct_GA68" >&6; }
+else
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+  if test "x$ac_ct_GA68" = x; then
+    GA68="no"
+  else
+    case $cross_compiling:$ac_tool_warned in
+yes:)
+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5
+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}
+ac_tool_warned=yes ;;
+esac
+    GA68=$ac_ct_GA68
+  fi
+else
+  GA68="$ac_cv_prog_GA68"
+fi
+
+
+
 if test -n "$ac_tool_prefix"; then
   # Extract the first word of "${ac_tool_prefix}gdc", so it can be a program name with args.
 set dummy ${ac_tool_prefix}gdc; ac_word=$2
@@ -10383,6 +10500,11 @@ if test "${enable_objc_gc+set}" = set; then :
   enableval=$enable_objc_gc;
 fi
 
+# Check whether --enable-algol68-gc was given.
+if test "${enable_algol68_gc+set}" = set; then :
+  enableval=$enable_algol68_gc;
+fi
+
 
 # Check whether --with-target-bdw-gc was given.
 if test "${with_target_bdw_gc+set}" = set; then :
@@ -10402,22 +10524,23 @@ if test "${with_target_bdw_gc_lib+set}" = set; then :
 fi
 
 
-case ,${enable_languages},:${enable_objc_gc} in *,objc,*:yes|*,objc,*:auto)
-  { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bdw garbage collector" >&5
+case ,${enable_languages},:${enable_objc_gc}:${enable_algol68_gc} in
+  *,objc,*:yes:*|*,objc,*:auto:*|*,algol68,*:*:yes|*,algol68,*:*:auto)
+    { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bdw garbage collector" >&5
 $as_echo_n "checking for bdw garbage collector... " >&6; }
-  if test "x$with_target_bdw_gc$with_target_bdw_gc_include$with_target_bdw_gc_lib" = x; then
-        { $as_echo "$as_me:${as_lineno-$LINENO}: result: using bdw-gc in default locations" >&5
+    if test "x$with_target_bdw_gc$with_target_bdw_gc_include$with_target_bdw_gc_lib" = x; then
+            { $as_echo "$as_me:${as_lineno-$LINENO}: result: using bdw-gc in default locations" >&5
 $as_echo "using bdw-gc in default locations" >&6; }
-  else
-        if test "x$with_target_bdw_gc_include" = x && test "x$with_target_bdw_gc_lib" != x; then
-      as_fn_error $? "found --with-target-bdw-gc-lib but --with-target-bdw-gc-include missing" "$LINENO" 5
-    elif test "x$with_target_bdw_gc_include" != x && test "x$with_target_bdw_gc_lib" = x; then
-      as_fn_error $? "found --with-target-bdw-gc-include but --with-target-bdw-gc-lib missing" "$LINENO" 5
     else
-      { $as_echo "$as_me:${as_lineno-$LINENO}: result: using paths configured with --with-target-bdw-gc options" >&5
+            if test "x$with_target_bdw_gc_include" = x && test "x$with_target_bdw_gc_lib" != x; then
+        as_fn_error $? "found --with-target-bdw-gc-lib but --with-target-bdw-gc-include missing" "$LINENO" 5
+      elif test "x$with_target_bdw_gc_include" != x && test "x$with_target_bdw_gc_lib" = x; then
+        as_fn_error $? "found --with-target-bdw-gc-include but --with-target-bdw-gc-lib missing" "$LINENO" 5
+      else
+        { $as_echo "$as_me:${as_lineno-$LINENO}: result: using paths configured with --with-target-bdw-gc options" >&5
 $as_echo "using paths configured with --with-target-bdw-gc options" >&6; }
+      fi
     fi
-  fi
 esac
 
 # Disable libitm, libsanitizer, libvtv if we're not building C++
@@ -11747,6 +11870,7 @@ done
 
 
 
+
 
 
 # Generate default definitions for YACC, M4, LEX and other programs that run
@@ -14267,6 +14391,9 @@ fi
 
 
 
+GA68FLAGS=${GA68FLAGS-${CFLAGS}}
+
+
 GDCFLAGS=${GDCFLAGS-${CFLAGS}}
 
 
@@ -15596,6 +15723,167 @@ fi
 
 
 
+if test -n "$GA68_FOR_TARGET"; then
+  ac_cv_prog_GA68_FOR_TARGET=$GA68_FOR_TARGET
+elif test -n "$ac_cv_prog_GA68_FOR_TARGET"; then
+  GA68_FOR_TARGET=$ac_cv_prog_GA68_FOR_TARGET
+fi
+
+if test -n "$ac_cv_prog_GA68_FOR_TARGET"; then
+  for ncn_progname in ga68; do
+    # Extract the first word of "${ncn_progname}", so it can be a program name with args.
+set dummy ${ncn_progname}; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_GA68_FOR_TARGET+:} false; then :
+  $as_echo_n "(cached) " >&6
+else
+  if test -n "$GA68_FOR_TARGET"; then
+  ac_cv_prog_GA68_FOR_TARGET="$GA68_FOR_TARGET" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+  IFS=$as_save_IFS
+  test -z "$as_dir" && as_dir=.
+    for ac_exec_ext in '' $ac_executable_extensions; do
+  if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+    ac_cv_prog_GA68_FOR_TARGET="${ncn_progname}"
+    $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+    break 2
+  fi
+done
+  done
+IFS=$as_save_IFS
+
+fi
+fi
+GA68_FOR_TARGET=$ac_cv_prog_GA68_FOR_TARGET
+if test -n "$GA68_FOR_TARGET"; then
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GA68_FOR_TARGET" >&5
+$as_echo "$GA68_FOR_TARGET" >&6; }
+else
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+  done
+fi
+
+if test -z "$ac_cv_prog_GA68_FOR_TARGET" && test -n "$with_build_time_tools"; then
+  for ncn_progname in ga68; do
+    { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ${ncn_progname} in $with_build_time_tools" >&5
+$as_echo_n "checking for ${ncn_progname} in $with_build_time_tools... " >&6; }
+    if test -x $with_build_time_tools/${ncn_progname}; then
+      ac_cv_prog_GA68_FOR_TARGET=$with_build_time_tools/${ncn_progname}
+      { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
+      break
+    else
+      { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+    fi
+  done
+fi
+
+if test -z "$ac_cv_prog_GA68_FOR_TARGET"; then
+  for ncn_progname in ga68; do
+    if test -n "$ncn_target_tool_prefix"; then
+      # Extract the first word of "${ncn_target_tool_prefix}${ncn_progname}", so it can be a program name with args.
+set dummy ${ncn_target_tool_prefix}${ncn_progname}; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_GA68_FOR_TARGET+:} false; then :
+  $as_echo_n "(cached) " >&6
+else
+  if test -n "$GA68_FOR_TARGET"; then
+  ac_cv_prog_GA68_FOR_TARGET="$GA68_FOR_TARGET" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+  IFS=$as_save_IFS
+  test -z "$as_dir" && as_dir=.
+    for ac_exec_ext in '' $ac_executable_extensions; do
+  if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+    ac_cv_prog_GA68_FOR_TARGET="${ncn_target_tool_prefix}${ncn_progname}"
+    $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+    break 2
+  fi
+done
+  done
+IFS=$as_save_IFS
+
+fi
+fi
+GA68_FOR_TARGET=$ac_cv_prog_GA68_FOR_TARGET
+if test -n "$GA68_FOR_TARGET"; then
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GA68_FOR_TARGET" >&5
+$as_echo "$GA68_FOR_TARGET" >&6; }
+else
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+    fi
+    if test -z "$ac_cv_prog_GA68_FOR_TARGET" && test $build = $target ; then
+      # Extract the first word of "${ncn_progname}", so it can be a program name with args.
+set dummy ${ncn_progname}; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if ${ac_cv_prog_GA68_FOR_TARGET+:} false; then :
+  $as_echo_n "(cached) " >&6
+else
+  if test -n "$GA68_FOR_TARGET"; then
+  ac_cv_prog_GA68_FOR_TARGET="$GA68_FOR_TARGET" # Let the user override the test.
+else
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+  IFS=$as_save_IFS
+  test -z "$as_dir" && as_dir=.
+    for ac_exec_ext in '' $ac_executable_extensions; do
+  if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
+    ac_cv_prog_GA68_FOR_TARGET="${ncn_progname}"
+    $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+    break 2
+  fi
+done
+  done
+IFS=$as_save_IFS
+
+fi
+fi
+GA68_FOR_TARGET=$ac_cv_prog_GA68_FOR_TARGET
+if test -n "$GA68_FOR_TARGET"; then
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GA68_FOR_TARGET" >&5
+$as_echo "$GA68_FOR_TARGET" >&6; }
+else
+  { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+    fi
+    test -n "$ac_cv_prog_GA68_FOR_TARGET" && break
+  done
+fi
+
+if test -z "$ac_cv_prog_GA68_FOR_TARGET" ; then
+  set dummy ga68
+  if test $build = $target ; then
+    GA68_FOR_TARGET="$2"
+  else
+    GA68_FOR_TARGET="${ncn_target_tool_prefix}$2"
+  fi
+else
+  GA68_FOR_TARGET="$ac_cv_prog_GA68_FOR_TARGET"
+fi
+
+
+
 if test -n "$GOC_FOR_TARGET"; then
   ac_cv_prog_GOC_FOR_TARGET=$GOC_FOR_TARGET
 elif test -n "$ac_cv_prog_GOC_FOR_TARGET"; then
@@ -20062,6 +20350,51 @@ $as_echo "pre-installed" >&6; }
   fi
 fi
 
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking where to find the target ga68" >&5
+$as_echo_n "checking where to find the target ga68... " >&6; }
+if test "x${build}" != "x${host}" ; then
+  if expr "x$GA68_FOR_TARGET" : "x/" > /dev/null; then
+    # We already found the complete path
+    ac_dir=`dirname $GA68_FOR_TARGET`
+    { $as_echo "$as_me:${as_lineno-$LINENO}: result: pre-installed in $ac_dir" >&5
+$as_echo "pre-installed in $ac_dir" >&6; }
+  else
+    # Canadian cross, just use what we found
+    { $as_echo "$as_me:${as_lineno-$LINENO}: result: pre-installed" >&5
+$as_echo "pre-installed" >&6; }
+  fi
+else
+  ok=yes
+  case " ${configdirs} " in
+    *" gcc "*) ;;
+    *) ok=no ;;
+  esac
+  case ,${enable_languages}, in
+    *,algol68,*) ;;
+    *) ok=no ;;
+  esac
+  if test $ok = yes; then
+    # An in-tree tool is available and we can use it
+    GA68_FOR_TARGET='$$r/$(HOST_SUBDIR)/gcc/ga68 -B$$r/$(HOST_SUBDIR)/gcc/'
+    { $as_echo "$as_me:${as_lineno-$LINENO}: result: just compiled" >&5
+$as_echo "just compiled" >&6; }
+  elif expr "x$GA68_FOR_TARGET" : "x/" > /dev/null; then
+    # We already found the complete path
+    ac_dir=`dirname $GA68_FOR_TARGET`
+    { $as_echo "$as_me:${as_lineno-$LINENO}: result: pre-installed in $ac_dir" >&5
+$as_echo "pre-installed in $ac_dir" >&6; }
+  elif test "x$target" = "x$host"; then
+    # We can use an host tool
+    GA68_FOR_TARGET='$(GA68)'
+    { $as_echo "$as_me:${as_lineno-$LINENO}: result: host tool" >&5
+$as_echo "host tool" >&6; }
+  else
+    # We need a cross tool
+    { $as_echo "$as_me:${as_lineno-$LINENO}: result: pre-installed" >&5
+$as_echo "pre-installed" >&6; }
+  fi
+fi
+
 { $as_echo "$as_me:${as_lineno-$LINENO}: checking where to find the target gdc" >&5
 $as_echo_n "checking where to find the target gdc... " >&6; }
 if test "x${build}" != "x${host}" ; then
diff --git a/gcc/configure b/gcc/configure
index 962511f666c..301a7720f31 100755
--- a/gcc/configure
+++ b/gcc/configure
@@ -649,6 +649,7 @@ ISLLIBS
 GMPINC
 GMPLIBS
 target_cpu_default
+algol68_target_objs
 jit_target_objs
 rust_target_objs
 d_target_objs
@@ -659,6 +660,8 @@ use_gcc_stdint
 xm_defines
 xm_include_list
 xm_file_list
+tm_algol68_include_list
+tm_algol68_file_list
 tm_jit_include_list
 tm_jit_file_list
 tm_rust_include_list
@@ -15124,6 +15127,16 @@ for f in $tm_jit_file; do
     * )
        tm_jit_file_list="${tm_jit_file_list} \$(srcdir)/config/$f"
        tm_jit_include_list="${tm_jit_include_list} config/$f"
+  esac
+done
+
+tm_algol68_file_list=
+tm_algol68_include_list=
+for f in $tm_algol68_file; do
+  case $f in
+    * )
+       tm_algol68_file_list="${tm_algol68_file_list} \$(srcdir)/config/$f"
+       tm_algol68_include_list="${tm_algol68_include_list} config/$f"
        ;;
   esac
 done
@@ -21873,7 +21886,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 21876 "configure"
+#line 21889 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
@@ -21979,7 +21992,7 @@ else
   lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2
   lt_status=$lt_dlunknown
   cat > conftest.$ac_ext <<_LT_EOF
-#line 21982 "configure"
+#line 21995 "configure"
 #include "confdefs.h"
 
 #if HAVE_DLFCN_H
@@ -34557,6 +34570,9 @@ fi
 
 
 
+
+
+
 
 
 
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 04/47] a68: documentation
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (2 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 03/47] a68: build system (regenerated files) Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 05/47] a68: command-line options Jose E. Marchesi
                   ` (43 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds a new section to the GCC Internals Manual and also
adds two new manuals.

ga68.texi is The GNU Algol 68 Compiler user manual.  It describes how
to use the compiler and all the GNU extensions implemented on top of
the Algol 68 programming language.

ga68-internals.texi is The GNU algol68 Compiler Internals manual.  It
describes the implementation of the front-end and it is of interest
primarily for developers.

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

gcc/ChangeLog

	* algol68/ga68-internals.texi: New file.
	* algol68/ga68.texi: Likewise.
	* doc/tm.texi.in: New section ALGOL 68 language and ABI.
	* doc/tm.texi: Regenerate.
---
 gcc/algol68/ga68-internals.texi |  383 ++++
 gcc/algol68/ga68.texi           | 3121 +++++++++++++++++++++++++++++++
 gcc/doc/tm.texi                 |   18 +
 gcc/doc/tm.texi.in              |    9 +
 4 files changed, 3531 insertions(+)
 create mode 100644 gcc/algol68/ga68-internals.texi
 create mode 100644 gcc/algol68/ga68.texi

diff --git a/gcc/algol68/ga68-internals.texi b/gcc/algol68/ga68-internals.texi
new file mode 100644
index 00000000000..1c0bad85f5e
--- /dev/null
+++ b/gcc/algol68/ga68-internals.texi
@@ -0,0 +1,383 @@
+\input texinfo  @c -*-texinfo-*-
+@c %**start of header
+@setfilename ga68-internals.info
+
+@include gcc-common.texi
+
+@synindex tp cp
+
+@settitle GNU Algol 68 Compiler Internals
+
+@c %**end of header
+
+@c %** start of document
+
+@copying
+Copyright @copyright{} 2025 Jose E. Marchesi.
+
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.  A
+copy of the license is included in the section entitled ``GNU Free
+Documentation License''.
+@end copying
+
+@ifinfo
+@dircategory Software development
+@direntry
+* ga68-internals: (ga68-internals).           The GNU Algol 68 Compiler Internals.
+@end direntry
+This file documents the internals of the GNU Algol 68
+compiler, (@command{ga68}).
+
+@insertcopying
+@end ifinfo
+
+@c Macro for bold-tags.  In TeX and HTML they expand to proper bold words,
+@c in other formats it resorts to upper stropping.
+@iftex
+@macro B{tag}
+@strong{\tag\}
+@end macro
+@end iftex
+
+@ifhtml
+@macro B{tag}
+@strong{\tag\}
+@end macro
+@end ifhtml
+
+@ifnottex
+@ifnothtml
+@macro B{tag}
+@sc{\tag\}
+@end macro
+@end ifnothtml
+@end ifnottex
+
+@setchapternewpage odd
+@titlepage
+@title GNU Algol 68 Internals
+@versionsubtitle
+@author Jose E. Marchesi
+@page
+@vskip 0pt plus 1filll
+@sp 1
+@insertcopying
+@end titlepage
+
+@summarycontents
+@contents
+
+@page
+
+@ifnottex
+@node Top
+@top Introduction
+@cindex Introduction
+
+This manual documents (some of) the internals of @command{ga68}, the
+GNU Algol 68 compiler.
+
+@menu
+* Scope Checking::         Scope checking in assignation.
+* Storage Management::     Management of run-time storage.
+* Lowering Declarations::  Mapping external objects to internal objects.
+* Lowering Assignations::  Superceding the value referred by a name.
+* GNU Free Documentation License::
+                           How you can copy and share this manual.
+* Index::                  Index of this documentation.
+@end menu
+@end ifnottex
+
+@c ---------------------------------------------------------------------
+@c Scope Checking
+@c ---------------------------------------------------------------------
+
+@node Scope Checking
+@chapter Scope Checking
+
+Static scope checking: pass.
+Dynamic scope checking: run-time call.
+
+@c ---------------------------------------------------------------------
+@c Storage Management
+@c ---------------------------------------------------------------------
+
+@node Storage Management
+@chapter Storage Management
+
+This chapter discusses the run-time management of internal objects in
+Algol 68.
+
+First, a conceptual model is presented that describes the restrictions
+as mandated by the Report.  The storage implied by the lowered GENERIC
+entities, as described in the previous chapter, shall match the
+storage of the conceptual model.
+
+@menu
+* Storage Structure of Objects::
+* Copying of Objects::
+* The Stack::
+* The Heap::
+@end menu
+
+@node Storage Structure of Objects
+@section Storage Structure of Objects
+
+The internal objects which are the values in an Algol 68 program may
+consist on a hierarchy of memory locations, which may not be
+contiguous.  This hierarchy of memory locations is the storage
+structure of the object, and is not concerned by the particular
+bit-patterns stored.
+
+Simple values.
+
+Names.
+
+Multiple values.
+
+Structured values.
+
+Values of united modes.
+
+@node Copying of Objects
+@section Copying of Objects
+
+@node The Stack
+@section The Stack
+
+XXX
+
+@node The Heap
+@section The Heap
+
+@itemize @minus
+@item
+A value that has rows and gets returned by a procedure shall be
+allocated on the stack.
+@item
+A copy of the right hand side is made before assigning it to the left
+hand side.  This copy is always allocated in the heap, because the
+scope of the left hand side may be older than the scope of the right
+hand side.  This happens when assigning to a global variable.
+@item
+A trimmer of a name.  This is because the trimmed multiple may be
+allocated on the heap, and the trim shall have the same scope than the
+trimmed multiple.
+@end itemize
+
+@c ---------------------------------------------------------------------
+@c Internal Objects
+@c ---------------------------------------------------------------------
+
+@node Lowering Declarations
+@chapter Lowering Declarations
+
+This chapter describes the mapping between external objects declared
+in identity and variable declarations and the internal objects that
+are the result of lowering the external objects in the parse tree into
+GENERIC entities.
+
+@menu
+* Identity Declarations::             @code{@B{amode} xxx = init value}
+* Variable Declarations::             @code{@B{amode} xxx [:= init value]}
+* Procedure Identity Declarations::   @code{@B{proc} xxx = routine text}
+* Procedure Variable Declarations::   @code{@B{proc} xxx := routine text}
+* Operator Brief Declarations::       @code{@B{op} @B{xxx} = routine text}
+* Operator Declarations::             @code{@B{op}(...)@B{amode} @B{xxx} = routine text}
+* Applied Identifiers::
+@end menu
+
+@node Identity Declarations
+@section Identity Declarations
+
+An identity declaration with the form:
+
+@example
+@B{c} part 1 @B{c}
+@B{amode} defining_identifier = unit;
+@B{c} part 2 @B{c}
+@end example
+
+@noindent
+Introduces the identifier @code{defining_identifier} in the current
+range and ascribes a copy of the value yielded by @code{unit} to it.
+Once established, the relationship between an identifier and the value
+ascribed to it is constant and it cannot change during the reach of
+the identifier.  The ascribed unit can be any unitary clause, and its
+elaboration can be arbitrarily complicated.  In particular, it is not
+required to be a compile-time constant.  @code{@B{amode}} determines
+the mode of the value yielded by the unit, and the unit is elaborated
+in a strong context.
+
+An identity declaration like the above, where @code{@B{amode}} is not
+a procedure mode (@xref{Procedure Identity Declarations}) is lowered
+into:
+
+@itemize @bullet
+@item
+A @code{VAR_DECL} with name @code{defining_identifier}, type
+@code{CTYPE (@B{amode})} and initial value @code{@B{amode}(@B{skip})}
+that gets chained into the declarations list of the current block.
+@item
+A @code{DECL_EXPR} that gets prepended in the current statement's list.
+@item
+A @code{MODIFY_EXPR} setting the @code{VAR_DECL} to a copy of the
+lowering of @code{unit}, @code{a68_low_dup (unit)}.
+@end itemize
+
+@noindent
+Schematically:
+
+@example
+   BIND_EXPR (BLOCK (DECLS: ... -> VAR_DECL (defining_identifier, INITIAL=SKIP)))
+     STMT_LIST
+     |
+     +-- DECL_EXPR (defining_identifier)
+     |
+     |   @B{c} part 1 @B{c}
+     |
+     +-- MODIFY_EXPR (defining_identifier, unit)
+     |
+     |   @B{c} part 2 @B{c}
+     |
+@end example
+
+The reason why the @code{VAR_DECL} is initialized to @code{@B{skip}}
+and then set to the initial @code{unit} specified in the source line
+is that the Report specifies that Algol 68 identifiers can be used
+before they are defined provided we are in the right range, but in
+that case the value ascribed to the identifier is ``undefined''.
+Accessing an ``undefined'' value in traditional Algol 68
+implementations would lead to a run-time error (these implementations
+used a special value to denote undefined, such as @code{F00L}) but in
+GNU Algol 68 the ``undefined'' value is always @code{@B{skip}} which,
+if not terribly useful in most cases, is at least well defined in this
+implementation and doesn't lead to an error.
+
+Identity declarations are the Algol 68 way of defining constants, and
+one may wonder why we are not using @code{CONST_DECL} instead of
+@code{VAR_DECL}.  The reason is that @code{CONST_DECL} is really only
+intended for integral values in C enums, and the @code{@B{amode}} in
+the identity declaration can really be any mode, from simple integers
+or characters to fairly complicated structured modes, which may
+involve also rows and united modes.  Whether the @code{VAR_DECL} will
+lead to allocating storage on the stack depends on the nature of the
+mode and the way the identifier is used in the program: whether its
+address is taken, etc.
+
+@node Variable Declarations
+@section Variable Declarations
+
+A variable declaration with the form:
+
+@example
+[@B{loc}|@B{heap}] @B{amode} defining identifier [:= unit];
+@end example
+
+@noindent
+Is in principle equivalent to the identity declaration:
+
+@example
+@B{ref} @B{amode} defining identifier = [@B{loc}|@B{heap}] @B{amode};
+@end example
+
+@noindent
+In both cases the object ascribed to the defining identifier is of
+mode @code{@B{ref} @B{amode}}.  The ascribed object is a name which is
+created by a generator implied in the actual declarer in the variable
+declaration case, and an explicit generator in the initialization
+expression in the identity declaration case.
+
+However, in this compiler these two cases are handled differently in
+order to reduce the amount of both indirect addressing and of storage:
+
+@itemize @bullet
+@item
+The variable declaration @code{[@B{loc}|@B{heap}] @B{amode} foo}
+lowers into a @code{VAR_DECL} with type @code{CTYPE (amode)} provided
+that the generator is @code{@B{loc}} and that the type contains no
+rows.  Accessing the variable will then involve direct addressing, and
+when its address is required an @code{ADDR_EXPR} shall be used.
+@item
+The identity declaration @code{@B{ref} @B{amode} foo = @B{loc}
+@B{amode}} lowers into a @code{VAR_DECL} with type @code{*CTYPE
+(amode)}.  Accessing the variable will then involve indirect
+addressing: it is effectively a pointer.
+@end itemize
+
+This optimization introduces the complication that an expression (the
+@code{VAR_DECL}) whose type is TYPE can appear in a place where *TYPE
+is expected, depending on the context and the r-value and l-value
+interpretation of the @code{VAR_DECL}.  The function
+@code{a68_consolidate_ref} is used in several parts of the lowering
+pass to guarantee a given name is an address regardless of how it was
+initialized.
+
+@node Procedure Identity Declarations
+@section Procedure Identity Declarations
+
+XXX
+
+@node Procedure Variable Declarations
+@section Procedure Variable Declarations
+
+XXX
+
+@node Operator Brief Declarations
+@section Operator Brief Declarations
+
+XXX
+
+@node Operator Declarations
+@section Operator Declarations
+
+XXX
+
+@node Applied Identifiers
+@section Applied Identifiers
+
+XXX
+
+@c ---------------------------------------------------------------------
+@c Lowering Assignations
+@c ---------------------------------------------------------------------
+
+@node Lowering Assignations
+@chapter Lowering Assignations
+
+Scope checking:
+
+@itemize @bullet
+@item
+If static scope checking is relevant and OK, then just perform assignation.
+@item
+If static scope checking is relevant and not OK, a compile-time error
+will have already being emitted.
+@item
+If static scope checking is not relevant, perform dynamic scope
+checking: each time a name, a routine or a format of the data
+structure is assigned, its dynamic scope (scope%_si) is compared with
+the one of the destination (scope%_d).  A run-time error message is
+provided in case scope%_d < scope%_si.
+@end itemize
+
+@c ---------------------------------------------------------------------
+@c GNU Free Documentation License
+@c ---------------------------------------------------------------------
+
+@include fdl.texi
+
+
+@c ---------------------------------------------------------------------
+@c Index
+@c ---------------------------------------------------------------------
+
+@node Index
+@unnumbered Index
+
+@printindex cp
+
+@bye
diff --git a/gcc/algol68/ga68.texi b/gcc/algol68/ga68.texi
new file mode 100644
index 00000000000..d000e791e6d
--- /dev/null
+++ b/gcc/algol68/ga68.texi
@@ -0,0 +1,3121 @@
+\input texinfo @c -*-texinfo-*-
+@setfilename ga68.info
+@settitle The GNU Algol 68 Compiler
+
+@c Macro for bold-tags.  In TeX and HTML they expand to proper bold words,
+@c in other formats it resorts to upper stropping.
+@iftex
+@macro B{tag}
+@strong{\tag\}
+@end macro
+@end iftex
+
+@ifhtml
+@macro B{tag}
+@strong{\tag\}
+@end macro
+@end ifhtml
+
+@ifnottex
+@ifnothtml
+@macro B{tag}
+\tag\
+@end macro
+@end ifnothtml
+@end ifnottex
+
+@c Create a separate index for command line options
+@defcodeindex op
+@c Merge the standard indexes into a single one.
+@syncodeindex fn cp
+@syncodeindex vr cp
+@syncodeindex ky cp
+@syncodeindex pg cp
+@syncodeindex tp cp
+
+@include gcc-common.texi
+
+@c Copyright years for this manual.
+@set copyrights-ga68 2025
+
+@copying
+@c man begin COPYRIGHT
+Copyright @copyright{} @value{copyrights-ga68} Free Software Foundation, Inc.
+
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
+A copy of the license is included in the
+@c man end
+section entitled ``GNU Free Documentation License''.
+@ignore
+@c man begin COPYRIGHT
+man page gfdl(7).
+@c man end
+@end ignore
+@end copying
+
+@ifinfo
+@format
+@dircategory Software development
+@direntry
+* ga68: (ga68).               A GCC-based compiler for Algol 68
+@end direntry
+@end format
+
+@insertcopying
+@end ifinfo
+
+@titlepage
+@title The GNU Algol 68 Compiler
+@versionsubtitle
+@author Jose E. Marchesi
+
+@page
+@vskip 0pt plus 1filll
+@sp 1
+@insertcopying
+@end titlepage
+@summarycontents
+@contents
+@page
+
+@node Top
+@top Introduction
+
+This manual describes how to use @command{ga68}, the GNU compiler for
+Algol 68.  This manual is specifically about how to invoke
+@command{ga68}, as well as its features.  For more information about
+the Algol 68 language in general, the reader is referred to the
+bibliography.
+
+Note that the particular way of representing Algol 68 code snippets in
+this manual will depend on the media.  If you are reading this manual
+in a printed support or a PDF file rendered for publication then the
+bold words in programs will be rendered in actual bold typography and
+tags may have spaces within them.  If you are reading this manual in a
+terminal or other media not supporting rich typography the code
+examples will follow the modern stropping regime with is the default
+in ga68.
+
+Note also that we are making use of @dfn{pseudo-comments} in code
+examples, as it is traditional in Algol 68 related documentation.
+These appear surrounded by @code{@B{C}} marks and act as placeholders
+of some Algol 68 code.  For example, @code{@B{C} frob the input
+variable @B{C}} is a pseudo-comment.
+
+@menu
+* Invoking ga68::               How to run the compiler.
+* Composing programs::          Packets, modules, holes, particular programs.
+* Comments and pragmats::       Comments and pragmas.
+* Hardware representation::     Representation of programs.
+* Standard prelude::            Standard modes, operators, etc.
+* Extended prelude::            GNU extensions to the standard prelude.
+* POSIX prelude::               Simple I/O and system interaction facilities.
+* Language extensions::         GNU extensions to the Algol 68 language.
+* Copying::                     The GNU General Public License.
+* GNU Free Documentation License::
+                                How you can share and copy this manual.
+* Option Index::                Index of command line options.
+* General Index::               General index.
+@end menu
+
+@node Invoking ga68
+@chapter Invoking ga68
+
+@c man title ga68 A GCC-based compiler for Algol 68
+
+@ignore
+@c man begin SYNOPSIS ga68
+ga68 [@option{-c}|@option{-S}] [@option{-g}] [@option{-pg}]
+     [@option{-O}@var{level}] [@option{-W}@var{warn}@dots{}]
+     [@option{-I}@var{dir}@dots{}] [@option{-L}@var{dir}@dots{}]
+     [@option{-f}@var{option}@dots{}] [@option{-m}@var{machine-option}@dots{}]
+     [@option{-o} @var{outfile}] [@@@var{file}] @var{infile}@dots{}
+
+Only the most useful options are listed here; see below for the
+remainder.
+@c man end
+@c man begin SEEALSO
+gpl(7), gfdl(7), fsf-funding(7), gcc(1)
+and the Info entries for @file{ga68} and @file{gcc}.
+@c man end
+@end ignore
+
+@c man begin DESCRIPTION ga68
+
+The @command{ga68} command is the GNU compiler for the Algol 68 language and
+supports many of the same options as @command{gcc}.  @xref{Option Summary, ,
+Option Summary, gcc, Using the GNU Compiler Collection (GCC)}.
+This manual only documents the options specific to @command{ga68}.
+
+@c man end
+
+@menu
+* Dialect options::         Options controlling the accepted language.
+* Directory options::       Options influencing where to find source files.
+* Warnings options::        Options controlling warnings specific to ga68
+* Runtime options::         Options controlling runtime behavior
+* Linking options::         Options influencing the linking step
+* Developer options::       Options useful for developers of ga68
+@end menu
+
+@node Dialect options
+@section Dialect options
+@cindex options, dialect
+
+The following options control how the compiler handles certain dialect
+variations of the language.
+
+@table @gcctabopt
+@opindex std=@var{std}
+@item -std=@var{std}
+Specify the standard to which the program is expected to conform,
+which may be one of @samp{algol68} or @samp{gnu68}.  The default value
+for @var{std} is @samp{gnu68}, which specifies a strict super language
+of Algol 68 allowing GNU extensions.  The @samp{algol68} value
+specifies that the program strictly conform to the Revised Report.
+@opindex fstropping=@var{stropping_regime}
+@item -fstropping=@var{stropping_regime}
+Specify the stropping regime to expect in the input programs.  The
+default value for @var{stropping_regime} is @samp{supper}, which
+specifies the modern SUPPER stropping which is a GNU extension.  The
+@samp{upper} value specifies the classic UPPER stropping of Algol 68
+programs.  @xref{Stropping regimes}.
+@opindex fbrackets
+@opindex fno-brackets
+@item -fbrackets
+This option controls whether @code{[ .. ]} and @code{@{ .. @}} are
+considered equivalent to @code{( .. )}.  This syntactic variation is
+blessed by the Revised Report and is still strict Algol 68.
+
+This option is disabled by default.
+@end table
+
+@node Directory options
+@section Options for Directory Search
+@cindex directory options
+@cindex options, directory search
+@cindex search path
+
+These options specify directories to search for files, libraries, and
+other parts of the compiler:
+
+@table @gcctabopt
+
+@opindex I
+@item -I@var{dir}
+Add the directory @var{dir} to the list of directories to be searched
+for files when processing the @ref{pragmat include}. Multiple
+@option{-I} options can be used, and the directories specified are
+scanned in left-to-right order, as with @command{gcc}.
+
+@end table
+
+@node Warnings options
+@section Warnings options
+@cindex options, warnings
+@cindex options, errors
+@cindex warnings, suppressing
+@cindex messages, error
+@cindex messages, warning
+@cindex suppressing warnings
+
+Warnings are diagnostic messages that report constructions that
+are not inherently erroneous but that are risky or suggest there
+is likely to be a bug in the program.  Unless @option{-Werror} is
+specified, they do not prevent compilation of the program.
+
+@table @gcctabopt
+@opindex Wvoiding
+@opindex Wno-voiding
+@item -Wvoiding
+Warn on non-void units being voided due to a strong context.
+@opindex Wscope
+@opindex Wno-scope
+@item -Wscope
+Warn when a potential name scope violation is found.
+@opindex Whidden-declarations
+@opindex Wno-hidden-declarations
+@item -Whidden-declarations
+Warn when a declaration hides another declaration in a larger reach.
+This includes operators that hide firmly related operators defined in
+larger reach.
+@opindex Wextensions
+@opindex Wno-extensions
+@item -Wextensions
+Warn when a non-portable Algol 68 construct is used, like GNU
+extensions to Algol 68.
+@end table
+
+@node Runtime options
+@section Runtime options
+@cindex options, runtime
+
+These options affect the runtime behavior of programs compiled with
+@command{ga68}.
+
+@table @gcctabopt
+@opindex fassert
+@opindex fno-assert
+@item -fno-assert
+Turn off code generation for @code{ASSERT} contracts.
+
+@opindex fcheck
+@item -fcheck=@var{<keyword>}
+Enable the generation of run-time checks; the argument shall be a
+comma-delimited list of the following keywords.  Prefixing a check
+with @option{no-} disables it if it was activated by a previous
+specification.
+
+@table @asis
+@item @samp{all}
+Enable all run-time test of @option{-fcheck}.
+
+@item @samp{none}
+Disable all run-time test of @option{-fcheck}.
+
+@item @samp{nil}
+Check for nil while dereferencing.
+
+@item @samp{bounds}
+Enable generation of run-time checks when indexing and trimming
+multiple values.
+@end table
+@end table
+
+@node Linking options
+@section Linking options
+@cindex options, linking
+@cindex linking, static
+
+These options come into play when the compiler links object files into
+an executable output file.  They are meaningless if the compiler is
+not doing a link step.
+
+@table @gcctabopt
+
+@opindex shared-libga68
+@item -shared-libga68
+On systems that provide @file{libga68} as a shared and a static
+library, this option forces the use of the shared version.  If no
+shared version was built when the compiler was configured, this option
+has no effect.
+
+@opindex static-libga68
+@item -static-libga68
+On systems that provide @file{libga68} as a shared and a static
+library, this option forces the use of the static version.  If no
+static version was built when the compiler was configured, this option
+has no effect.  This is the default.
+@end table
+
+@node Developer options
+@section Developer options
+@cindex developer options
+@cindex debug dump options
+@cindex dump options
+
+This section describes command-line options that are primarily of
+interest to developers.
+
+@table @gcctabopt
+@opindex fa68-dump-modes
+@item -fa68-dump-modes
+Output a list of all the modes parsed by the front-end.
+
+@opindex fa68-dump-ast
+@item -fa68-dump-ast
+Dump a textual representation of the parse tree.
+@end table
+
+@node Composing programs
+@chapter Composing programs
+@cindex program
+@cindex separated compilation
+
+This chapter documents how to compose full Algol 68 programs using the
+modules and separated compilation support provided by this compiler.
+
+@menu
+* Packets::                  Compilation units.
+* Modules::                  Facilities for bottom-up programming.
+* Holes::                    Facilities for top-down programming.
+* Particular programs::      The main program.
+* The standard environment:: Environment conforming a full program.
+@end menu
+
+@node Packets
+@section Packets
+@cindex packet
+@cindex compilation unit
+
+Each Algol 68 source file contains a @dfn{packet}.  Packets therefore
+play the role of @dfn{compilation units}, and each packet can be
+compiled separately to an object file.  A set of compiled object files
+can then be linked in the usual fashion into an executable, archive or
+shared object by the system linker, without the need of any
+language-specific link editor or build system.
+
+@noindent
+This compiler supports three different kind of packets:
+
+@itemize @minus
+@item
+@dfn{Particular programs} constitute the entry point of a program.
+They correspond to the @code{main} function of other languages like C.
+
+@xref{Particular programs}.
+
+@item
+@dfn{Prelude packets} contain the definition of one or more modules,
+which @dfn{publicize} definitions of modes, procedures, variables,
+operators and even the publicized definitions of other modules.  The
+modules defined at the top-level of a prelude packet can be accessed
+by other packets via an @code{@B{access}} construct.  Prelude packets
+are so-called because their contents get stuffed in the
+@dfn{user-prelude} in the case of user-defined modules, or the
+@dfn{library-prelude} in the case of module packets provided by the
+compiler.  They are usually used to compose libraries that can be used
+in a bottom-up fashion.
+
+@xref{Modules}.
+
+@item
+@dfn{Stuffing packets} contain the definition of an @dfn{actual hole},
+an @code{@B{egg}} construct, that can be stuffed in a matching
+@dfn{formal hole} in another package via a @code{@B{nest}} construct.
+Formal holes are used in order to achieve separated compilation in a
+top-bottom fashion, and also to invoke procedures written in other
+languages, such as C functions or Fortran subroutines.
+
+@xref{Holes}.
+@end itemize
+
+A @dfn{collection of packets}, all of which must be compatible with
+each other, constitutes either a @dfn{program} or a @dfn{library}.
+Exactly one of the packets constituting a program shall be a
+particular program.  In libraries at least one packet must be a
+prelude packet.
+
+@node Modules
+@section Modules
+@cindex module
+
+@dfn{Definition modules}, often referred as just @dfn{modules} in the
+sequel, fulfill two different but related purposes.  On one side, they
+provide some degree of @dfn{protection} by preventing accessing
+indicators defined within the module but not explicitly publicized.
+On the other, they allow to define @dfn{interfaces}, allow separated
+compilation based on these interfaces, and conform libraries.
+
+Modules are usually associated with bottom-up development strategies,
+where several already written components are grouped and combined to
+conform bigger components.
+
+@menu
+* Writing modules::                Writing modules.
+* Accessing modules::              Using the definitions of a module.
+* Module activation::              How and when modules execute.
+* Modules and libraries::          Using modules to conform libraries.
+* Modules and protection::         When block structure is not enough.
+@end menu
+
+@node Writing modules
+@subsection Writing modules
+
+A @dfn{definition module} is a construct that provides access to a set
+of publicized definitions.  They can appear anywhere, but are
+typically found in the outer reach and compiled separately, in which
+case they conform a prelude packet (@pxref{Packets}).  They are
+composed of a prelude and a postlude.  The publicized definitions
+appear in the module's prelude.
+
+Consider for example the following definition module, which implements
+a very simple logging facility:
+
+@example
+@B{module} @B{Logger} =
+   @B{def} @B{int} fd = stderr;
+       @B{pub} @B{string} originator;
+       @B{pub} @B{proc} log = (@B{string} msg) @B{void}:
+              fputs (fd, (originator /= "" | ": ") + msg + "\n");
+
+       log ("beginning of log\n");
+   @B{postlude}
+       log ("end of log\n");
+   @B{fed}
+@end example
+
+@noindent
+The @dfn{module text} delimited by @code{@B{def}} and @code{@B{fed}}
+gets ascribed to the module indicator @code{@B{Logger}}.  Module
+indicators are bold tags.  Once defined, the module @code{@B{Logger}}
+is accessible anywhere within its reach.
+
+The @dfn{prelude} of the module spans from @code{@B{def}} to either
+@code{@B{postlude}}, or to @code{@B{fed}} in case of modules not
+featuring a postlude.  It consists on a restricted serial clause in a
+void strong context, which can contain units and declarations, but no
+labels or completers.  The declarations in the prelude may be either
+publicized or no publicized.  As we shall see, publicized indicators
+are accessible within the reach of the defining module publicizing
+them.  Publicized declarations are marked by preceding them with
+@code{@B{pub}}.
+
+In our example the module prelude consists on three declarations and
+one unit.  The indicator @code{fd} is not publicized and is to be used
+internally by the module.  The indicators @code{originator} and
+@code{log}, on the other hand, are publicized and conform the
+interface of the module.  Note how the range of the prelude also
+covers the postlude: the @code{log} procedure is reachable there, as
+it would be @code{fd} as well.
+
+The @dfn{postlude} of the module is optional and spans from
+@code{@B{postlude}} to @code{@B{fed}}.  It consists on a serial clause
+in a @code{@B{void}} strong context, where definitions, labels and
+module accesses are not allowed, just units.
+
+@node Accessing modules
+@subsection Accessing modules
+
+Once a module is defined (@pxref{Writing modules}) it can be accessed,
+provided it is within reach, using an @dfn{access clause}.  The access
+clause identifies the modules to access and then makes the publicized
+definitions of these modules visible within a @dfn{control clause}.
+
+For example, this is how we could use the logger definition module
+defined in a previous section to log the progress of some program that
+reads an input file and writes some output file:
+
+@example
+@B{access} @B{Logger}
+@B{begin} # Identify ourselves with the program name #
+      originator := argv (1);
+
+      # Read input file.  #
+      @B{if} @B{NOT} parse_input (argv (2))
+      @B{then} log ("error parsing input file"); stop @B{fi};
+
+      # Write output file.  #
+      @B{if} @B{NOT} write_output (argv (3))
+      @B{then} log ("error writing output file"); stop @B{fi};
+
+      log ("success")
+@B{end}
+@end example
+
+@noindent
+In this case the controlled clause is the closed clause conforming the
+particular program, and the definitions publicized by the logger
+module, in this case @code{originator} and @code{log}, can be used
+within it.
+
+@subsubsection Accessing several modules
+
+An access clause is not restricted to just provide access to a single
+module: any number of module indicators can be specified in an access
+clause.  Suppose that our example processing program has to read and
+write the data in JSON format, and that a suitable JSON library is
+available in the form of a reachable module.  We could then make both
+logger and json modules accessible like this:
+
+@example
+@B{access} @B{Logger}, @B{JSON}
+@B{begin} # Identify ourselves with the program name #
+      originator := argv (1);
+
+      @B{JSONVal} data;
+
+      # Read input file.  #
+      @B{if} data := json_from_file (argv (2));
+         data = json no val
+      @B{then} log ("error parsing input file"); stop @B{fi};
+
+      # Write output file.  #
+      @B{if} @B{not} json_to_file (argv (3), data)
+      @B{then} log ("error writing output file"); stop @B{fi};
+
+      log ("success")
+@B{end}
+@end example
+
+@noindent
+In this version of the program the access clause includes the module
+indicator @code{@B{json}}, and that makes the mode indicator
+@code{@B{jsonval}} and the tags @code{@B{json no val}}, @code{json
+from file} and @code{json to file} visible within the program's
+closed clause.
+
+Note that the following two access clauses are not equivalent:
+
+@example
+@B{access} @B{Logger}, @B{JSON} @B{C} ... @B{C};
+@B{access} @B{Logger} @B{access} @B{JSON} @B{C} ... @B{C};
+@end example
+
+@noindent
+In the first case, a compilation time error is emitted if there is a
+conflict among the publicized definitions of both modules; for
+example, if both modules were to publicize a procedure called
+@code{log}.  In the second case, the declaration of @code{log}
+publicized by @code{@B{Logger}} would hide the declaration of
+@code{log} publicized by @code{@B{JSON}}.  This also has implications
+related to activation, that we will be discussing in a later section.
+
+@subsubsection The controlled clause
+
+The controlled clause in an access clause doesn't have to be a serial
+clause, like in the examples above.  It can be any enclosed clause,
+like for example a loop clause:
+
+@example
+@B{proc} frobnicate frobs = ([]@B{Frob} frobs) @B{void}:
+   @B{access} @B{Logger} @B{to} @B{UPB} frobs
+                 @B{do} log ("frobnicating " + name @B{of} frob);
+                    frobnicate (frob)
+                 @B{od}
+@end example
+
+@subsubsection The value yielded by an access clause
+
+The elaboration of an access clause yields a value, which is the value
+yielded by the elaboration of the controlled clause.  Since the later
+is an enclosed clause, coercions get passed into them whenever
+required, the usual fashion.
+
+We can see an example of this in the following procedure, whose body
+is a controlled closed clause that yields a @code{@B{real}} value:
+
+@example
+@B{proc} incr factor = (@B{ref}[]@B{real} factors, @B{int} idx) @B{real}:
+   @B{access} @B{logger} (log ("factor increased"); factors[idx] +:= 1.0)
+@end example
+
+@noindent
+Note how the access clause above is in a strong context requiring a
+value of mode @code{@B{real}}.  The value yielded by the access clause
+is the value yielded by the controlled enclosed clause, which in this
+case is a closed clause.  The strong context and required mode gets
+passed to the last unit of the closed clause (the assignation) which
+in this case yields a value of mode @code{@B{ref} @B{real}}.  The unit
+is coerced to @code{@B{real}} by dereferencing, and the resulting
+value becomes the value yielded by the access clause.
+
+@subsubsection Modules accessing other modules
+
+A definition module may itself access other modules.  This is done by
+placing the module text as a controlled clause of an access clause.
+Suppose we rewrite our logger module so it uses JSON internally to log
+JSON objects rather than raw strings.  We could do it this way:
+
+@example
+@B{module} @B{logger} =
+   @B{access} @B{json}
+   @B{def} @B{int} fd = stderr;
+       @B{pub} @B{string} originator;
+       @B{pub} @B{proc} log = (@B{string} msg) @B{void}:
+              fputs (fd, json array (json string (originator),
+                                     json string (msg)));
+
+       log (json string ("beginning of log\n"));
+   @B{postlude}
+       log (json string ("end of log\n"));
+   @B{fed}
+@end example
+
+@noindent
+Note how this version of @code{@B{logger}} uses a few definitions
+publicized by the @code{@B{json}} module.
+
+A program accessing @code{@B{logger}} will not see the definitions
+publicized by the @code{@B{json}} module.  If that is what we
+intended, for example to allow the users of the logger to tweak their
+own JSON, we would need to specify it this way:
+
+@example
+@B{module} @B{logger} =
+   @B{access} @B{pub} @B{json}
+   @B{def} @B{c} ...as before... @B{c} @B{fed}
+@end example
+
+@noindent
+In this version the definitions publicized by @code{@B{json}} become
+visible to programs accessing @code{@B{logger}}.
+
+@node Module activation
+@subsection Module activation
+
+In all the examples seen so far the modules were accessed just once.
+In these cases, accessing the module via an access-clause caused the
+@dfn{activation} of the module.
+
+Activating a module involves elaborating all the declarations and
+units that conform its prelude.  Depending on the particular module
+definition that gets activated, this may involve all sort of side
+effects, such as allocating space for values and initializing them,
+opening files, @i{etc}.  Once the modules specified in the access
+clause are successfully activated, the controlled clause gets
+elaborated itself, within the reach of all the publicized definitions
+by the activated modules as we saw in the last section.  Finally, once
+the controlled clause has been elaborated, the module gets
+@dfn{revoked} by elaborating the serial clause in its postlude.
+
+However, nothing prevents some given definition module to be accessed
+more than once in the same program.  The following program, that makes
+use of the @code{@B{logger}} module, exemplifies this:
+
+@example
+@B{access} @B{logger}
+@B{begin} originator := argv (1);
+      log ("executing program");
+      @B{c} ... @B{c}
+      @B{access} @B{logger} (originator := argv (1) + ":subtask";
+                     log ("doing subtask")
+                     @B{c} ... @B{c})
+@B{end}
+@end example
+
+@noindent
+In this program the module @code{@B{logger}} is accessed twice.  The
+code is obviously written assuming that the inner access clause
+triggers a new activation of the @code{@B{logger}} module, allocating
+new storage and executing its prelude.  This would result in the
+following log contents:
+
+@example
+a.out: beginning of log
+a.out: executing program
+a.out:subtask: beginning of log
+a.out:subtask: doing subtask
+a.out:subtask: end of log
+a.out: end of log
+@end example
+
+@noindent
+However, this is not what happens.  The module gets only activated
+once, as the result of the outer access clause.  The inner access
+clause just makes the publicized indicators visible in its controlled
+clause.  The actual resulting log output is:
+
+@example
+a.out: beginning of log
+a.out: executing program
+a.out:subtask: doing subtask
+a.out:subtask: end of log
+@end example
+
+@noindent
+Which is not what we intended.  Modules are not classes.  If we wanted
+the logger to support several originators that can be nested, we would
+need to add support for it in the definition module.  Something like:
+
+@example
+@B{module} @B{logger} =
+   @B{def} @B{int} fd = stderr, max originators = 10;
+       @B{int} orig := 0;
+       [max originators]@B{string} originators;
+
+       @B{pub} @B{proc} push originator = (@B{string} str) @B{void}:
+              (@B{assert} (orig < max originators);
+               orig +:= 1;
+               originators[orig] := str);
+       @B{pub} @B{proc} pop originator = @B{void}:
+              (@B{assert} (max originators > 0);
+               orig -:= 1);
+       @B{pub} @B{proc} log = (@B{string} msg) @B{void}:
+              fputs (fd, (originator[orig] /= "" | ": ") + msg + "\n");
+
+       log ("beginning of log\n");
+   @B{postlude}
+       log ("end of log\n");
+   @B{fed}
+@end example
+
+@noindent
+Note how in this version of @code{@B{logger}} @code{originators} acts
+as a stack of originator strings, and it is not publicized.  The
+management of the stack is done via a pair of publicized procedures
+@code{push originator} and @code{pop originator}.  Our program will
+now look like:
+
+@example
+@B{access} @B{logger}
+@B{begin} push originator (argv (1));
+      log ("executing program");
+      @B{c} ... @B{c}
+      @B{access} @B{logger} (push originator ("subtask");
+                     log ("doing subtask")
+                     @B{c} ... @B{c};
+                     pop originator)
+@B{end}
+@end example
+
+@noindent
+And the log output is:
+
+@example
+a.out: beginning of log
+a.out: executing program
+a.out:subtask: doing subtask
+a.out: end of log
+@end example
+
+
+--------------------------------------------------------------
+
+module-indications are used to find interface-definitions of modules:
+
+  ACCESS FOO SKIP
+
+Looks for (in order):
+
+  foo.m68
+  foo.o
+  libfoo.so
+
+Should we use instead:
+
+  ACCESS "foo" SKIP
+
+That would use for module indicators the same syntax than hole
+indicators.
+
+Modules get accessed, invoked and revoked.
+
+Access clauses:
+
+: ACCESS A, B <enclosed clause>
+
+Where A and B are ``revelations''.
+
+In
+
+: MODULE A = ACCESS B DEF ... FED
+
+Doesn't reveals any contents of B.  Whereas in:
+
+: MODULE A = ACCESS PUB B DEF .. FED
+
+The module A is also revealing B's public declarations.  So accessing
+A provides access to B.
+
+User-defined preludes go to the user-prelude.
+
+Invocation and revocation:: How modules are executed.
+
+It is possible for a definition module to not publicize any
+definition.  Such modules would be used only for the side effects
+produced from executing the prelude and postlude when the module gets
+invoked and revoked. XXX: provide an example?
+
+XXX
+
+@node Modules and libraries
+@subsection Modules and libraries
+@cindex library
+@cindex prelude packet
+
+XXX
+
+@node Modules and protection
+@subsection Modules and protection
+@cindex protection
+@cindex publicized definition
+
+XXX
+
+@node Holes
+@section Holes
+@cindex hole
+
+XXX
+
+@node Particular programs
+@section Particular programs
+@cindex particular program
+
+An Algol 68 @dfn{particular program} consists on an enclosed clause in
+a strong context with target mode @code{@B{void}}, possibly preceded
+by a set of zero or more labels.  For example:
+
+@example
+hello:
+@B{begin} puts ("Hello, world!\n")
+@B{end}
+@end example
+
+@noindent
+Note that the enclosed clause conforming the particular program
+doesn't have to be a closed clause.  Consider for example the
+following program, that prints out its command line arguments:
+
+@example
+@B{for} i @B{to} argc
+@B{do} puts (argv (i) + "\n") @B{od}
+@end example
+
+@menu
+* Exit status::              How do programs communicate success or failure.
+* The @code{stop} label::    How to terminate a program at any time.
+@end menu
+
+@node Exit status
+@subsection Exit status
+@cindex exit status
+
+Some operating systems have the notion of @dfn{exit status} of a
+process.  In such systems, by default the execution of the particular
+program results in an exit status of success.  It is possible for the
+program to specify an explicit exit status by using the standard
+procedure @code{set exit status}, like:
+
+@example
+@b{begin} # ... program code ... #
+     @B{if} error found;
+     @B{then} set exit status (1) @B{fi}
+@b{end}
+@end example
+
+In POSIX systems the status is an integer, and the system interprets a
+value other than zero as a run-time error.  In other systems the
+status may be of some other type.  To support this, the @code{set
+error status} procedure accepts as an argument an united value that
+accommodates all the supported systems.
+
+The following example shows a very simple program that prints ``Hello
+world'' on the standard output and then returns to the operating
+system with a success status:
+
+@example
+@B{begin} puts ("Hello world\n")
+@B{end}
+@end example
+
+@node The @code{stop} label
+@subsection The @code{stop} label
+@cindex @code{stop}
+
+A predefined label named @code{stop} is defined in the standard
+postlude.  This label can be jumped to at any time by a program and it
+will cause it to terminate and exit.  For example:
+
+@example
+@B{begin} @B{if} argc /= 2
+      @B{then} puts ("Program requires exactly two arguments.");
+     goto stop
+      @B{fi}
+      @B{C} ... @B{C}
+@B{end}
+@end example
+
+@node The standard environment
+@section The standard environment
+@cindex standard environment
+
+The environment in which particular programs run is expressed here in
+the form of pseudo code:
+
+@example
+(@B{c} standard-prelude @B{c};
+ @B{c} library-prelude @B{c};
+ @B{c} system-prelude @B{c};
+ @B{par} @B{begin} @B{c} system-task-1 @B{c},
+           @B{c} system-task-2 @B{c},
+           @B{c} system-task-n @B{c},
+           @B{c} user-task-1 @B{c},
+           @B{c} user-task-2 @B{c},
+           @B{c} user-task-m @B{c}
+     @B{end})
+@end example
+
+@noindent
+Where each user task consists on:
+
+@example
+(@B{c} particular-prelude @B{c};
+ @B{c} user-prelude @B{c};
+ @B{c} particular-program @B{c};
+ @B{c} particular-postlude @B{c})
+@end example
+
+The only standard system task described in the report is expressed in
+pseudo-code as:
+
+@example
+@B{do} @B{down} gremlins; undefined; @B{up} bfileprotect @B{od}
+@end example
+
+@noindent
+Which denotes that, once a book (file) is closed, anything may happen.
+Other system tasks may exist, depending on the operating system.  In
+general these tasks in the parallel clause denote the fact that the
+operating system is running in parallel (intercalated) with the user's
+particular programs.
+
+@itemize @bullet
+@item
+The library-prelude contains, among other things, the prelude parts of
+the defining modules provided by library.
+
+@item
+The particular-prelude and particular-postlude are common to all the
+particular programs.
+
+@item
+The user-prelude is where the prelude parts of the defining modules
+involved in the compilation get stuffed.  If no defining module is
+involved then the user-prelude is empty.
+@end itemize
+
+Subsequent sections in this manual include a detailed description of
+the contents of these preludes.
+
+@node Comments and pragmats
+@chapter Comments and pragmats
+
+Comments and pragmats, also known collectively as @dfn{pragments}, can
+appear almost anywhere in an Algol 68 program.  Comments are usually
+used for documentation purposes, and pragmats contain annotations for
+the compiler.  Both are handled at the lexical level.
+
+@menu
+* Comments::                    Your typical friendly comments.
+* Pragmats::                    In-source directives for the compiler.
+@end menu
+
+@node Comments
+@section Comments
+
+In the default modern stropping regime supported by GCC comments are
+written between @code{@{} and @code{@}} delimiters, and can be nested
+to arbitrary depth.  For example:
+
+@example
+foo +:= 1; @{ Increment foo.  @}
+@end example
+
+If UPPER stropping is selected, this compiler additionally supports
+three classical Algol 68 comment styles, in which the symbols marking
+the beginning of comments are the same than the symbols marking the
+end of comments and therefore can't be nested: @code{@B{comment}
+... @B{comment}}, @code{@B{co} ... @B{co}} and @code{# .. #}.  For
+example:
+
+@example
+@B{comment}
+  This is a comment.
+@B{comment}
+
+foo := 10; @B{co} this is also a comment @B{co}
+foo +:= 1; # and so is this.  #
+@end example
+
+Unless @option{-std=algol68} is specified in the command line, two
+styles of nestable comments can be also used with UPPER stropping: the
+already explained @code{@{ ... @}} and a ``bold'' style that uses
+@code{@B{code} ... @B{edoc}}.  For example:
+
+@example
+foo := 10; @{ this is a nestable comment in brief style.  @}
+foo +:= 1; @B{note} this is a nestable comment in bold style.  @B{eton}.
+@end example
+
+@example
+@B{note}
+   "Bold" nestable comments.
+@B{eton}
+
+@{ "Brief" nestable comments. @}
+@end example
+
+In UPPER stropping all comment styles are available, both classic and
+nestable.  In modern SUPPER stropping, which is based on reserved
+words, only @code{@{ ... @}} is available.
+
+@node Pragmats
+@section Pragmats
+
+@cindex pragmat
+@dfn{Pragmats} (also known as @dfn{pragmas} in other programming
+languages) are directives and annotations for the compiler, and their
+usage impacts the compilation process in several ways.  A pragmat
+starts with either @code{@B{pragmat}} or @code{@B{pr}} and finished
+with either @code{@B{pragmat}} or @code{@B{pr}} respectively.
+Pragmats cannot be nested.  For example:
+
+@example
+@B{pr} include "foo.a68" @B{pr}
+@end example
+
+The interpretation of pragmats is compiler-specific.  This chapter
+documents the pragmats supported by GCC.
+
+@menu
+* pragmat include::         Include another source file.
+@end menu
+
+@node pragmat include
+@subsection pragmat include
+@cindex include
+
+An @dfn{include pragmat} has the form:
+
+@example
+@B{pr} include "PATH" @B{pr}
+@end example
+
+@noindent
+Where @code{PATH} is the path of the file whose contents are to be
+included at the location of the pragmat.  If the provided path is
+relative then it is interpreted as relative to the directory
+containing the source file that contains the pragmat.
+
+The @option{-I} command line option can be used in order to add
+additional search paths for @code{include}.
+
+@node Hardware representation
+@chapter Hardware representation
+
+The @dfn{reference language} specified by the Revised Report describes
+Algol 68 particular programs as composed by @dfn{symbols}.  However,
+the Report leaves the matter of the concrete representation of these
+symbols, the @dfn{representation language}, open to the several
+implementations.  This was motivated by the very heterogeneous
+computer systems in existence at the time the Report was written,
+which made flexibility in terms of representation a crucial matter.
+
+This flexibility was indeed exploited by the early implementations,
+and there was a price to pay for it.  A few years after the
+publication of the Revised Report the different implementations had
+already given rise to a plethora of many related languages that,
+albeit being strict Algol 68, differed considerably in appearance.
+This, and the fact that people were already engrossed in writing
+programs other than compilers that needed to process Algol 68
+programs, such as code formatters and macro processors, prompted the
+WG 2.1 to develop and publish a @dfn{Report on the Standard Hardware
+Representation for ALGOL 68}, which came out in 1975.
+
+This compiler generally follows the Standard Hardware Representation,
+but deviates from it in a few aspects.  This chapter provides an
+overview of the hardware representation and documents any deviation.
+
+@menu
+* Representation languages::  From symbols to syntactic marks.
+* Worthy characters::         Marks that can appear in a program.
+* Base characters::           Mapping of worthy characters to code points.
+* Stropping regimes::         Representation of bold words.
+* Monads and Nomads::         Characters that can appear in operator names.
+* String breaks::             String literals and escape sequences.
+@end menu
+
+@node Representation languages
+@section Representation languages
+
+A program in the strict Algol 68 language is composed by a series of
+symbols.  These symbols have names such as @code{letter-a-symbol} and
+@code{assigns-to-symbol} which are, well, purely symbolic. In fact,
+these are notions in the two-level grammar that defines the strict
+language.
+
+A @dfn{representation language} provides a mapping between symbols in
+the strict language and the representation of these symbols.  Each
+representation is a sequence of syntactic marks.  For example, the
+@code{completion symbol} may be represented by @strong{exit}, where
+the marks are the bold letters.  The @code{tilde symbol} may be
+represented by @code{~}, which is a single mark. The representation of
+@code{assigns to symbol} is @code{:=}, which is composed by the two
+marks @code{:} and @code{=}.  The representation of @code{letter-a}
+is, not surprising, the single mark @code{a}.
+
+The section 9.4 of the Report describes the recommended representation
+for all the symbols of the language.  The set of all recommendations
+constitutes the so-called @dfn{reference language}. Algol 68
+implementations are strongly encouraged to use representation
+languages which are similar enough to the reference language,
+recognizable ``without further elucidation'', but this is not
+strictly required.
+
+A representation language may specify more than one representation for
+a given symbol.  For example, in the reference language the @code{is
+not symbol} is represented by @strong{isnt}, @code{:/=:} and a variant
+of the later where the slash sign is superimposed on the equal sign.
+In this case, an implementation can choose to implement any number of
+the representations.
+
+Spaces, tabs and newlines are @dfn{typographical display features}
+that, when they appear between symbols, are of no significance and do
+not alter the meaning of the program.  However, when a space or a tab
+appear in string or character denotations, they represent the
+@code{space symbol} and the @code{tab symbol}
+respectively@footnote{The @code{tab symbol} is a GNU extension}.
+
+@node Worthy characters
+@section Worthy characters
+@cindex worthy characters
+
+The syntactic marks of a representation language, both symbols and
+typographical display features, are realized as a set of @dfn{worthy
+characters} and the newline. Effectively, an Algol 68 program is a
+sequence of @dfn{worthy characters} and newlines.  The worthy
+characters are:
+
+@example
+a b c d e f g h i j k l m n o p q r s t u v w x y z
+A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
+0 1 2 3 4 5 6 7 8 9
+space tab " # $ % & ' ( ) * + , - . / : ; < = >  @ [ \ ]
+^ _ | @ ! ? ~ @{ @}
+@end example
+
+Some of the characters above were considered unworthy by the original
+Standard Hardware Representation:
+
+@table @code
+@item !
+It was considered unworthy because many installations didn't have a
+vertical bar base character, and @code{!} was used as a base character
+for @code{|}.  Today every computer system features a vertical bar
+character, so @code{!} can qualify as a worthy character.
+@item &
+The Revised Report specifies that @code{&} is a monad, used as a
+symbol for the dyadic @code{@B{and}} operator.  The Standard Hardware
+representation decided to turn it into an unworthy character,
+motivated by the fact that no nomads existed for the other logical
+operators @code{@B{not}} and @code{@B{or}}, and also with the goal of
+maintaining the set of worthy characters as small as possible to
+improve portability.  Recognizing that the first motivation still
+holds, but not the second, this compiler re-instates @code{&} as a
+monad but doesn't use it as an alternative representation of the
+@code{@B{and}} operator.
+@item ~
+The Standard Hardware Representation vaguely cites some ``severe
+difficulties'' with the hardware representation of the tilde
+character.  Whatever these difficulties were at the time, they surely
+don't exist anymore.  This compiler therefore recognizes @code{~} as a
+worthy character, and is used as a monad.
+@item ?
+The question mark character was omitted as a worthy character to limit
+the size of the worthy set.  This compiler recognizes @code{?} as a
+worthy character, and is used as a monad.
+@item \
+Back-slash wasn't included as a worthy character because back in 1975
+it wasn't supported in EBCDIC (it is now).  This compiler recognizes
+@code{\} as a worthy character.
+@item tab
+This compiler recognizes the tabulator character as a worthy
+character, and it is used as a typographical display feature.
+@end table
+
+@node Base characters
+@section Base characters
+@cindex base characters
+
+The worthy characters described in the previous section are to be
+interpreted symbolically rather than visually.  The worthy character
+@code{|}, for example, is the vertical line character and generally
+looks the same in every system.  The worthy character @code{space} is
+obviously referred by a symbolic name.
+
+The actual visually distinguishable characters available in an
+installation are known as @dfn{base characters}.  The Standard
+Hardware Representation allows implementations the possibility of
+using two or more base characters to represent a single worthy
+character.  This was the case of the @code{|} character, which was
+represented in many implementations by either @code{|} or @code{!}.
+
+This compiler uses the set of base characters corresponding to the
+subset of the Unicode character set that maps one to one to the set of
+worthy characters described in the previous section:
+
+@example
+A-Z   65-90
+a-z   97-122
+space 32
+tab   9
+!     33
+"     34
+#     35
+$     36
+%     37
+&     38
+'     39
+(     40
+)     41
+*     42
++     43
+,     44
+-     45
+.     46
+/     47
+:     58
+;     59
+<     60
+=     61
+>     62
+?     63
+@@     64
+[     91
+\     92
+]     93
+^     94
+_     95
+|     124
+~     126
+@end example
+
+@node Stropping regimes
+@section Stropping regimes
+
+The Algol 68 reference language establishes that certain source
+constructs, namely mode indications and operator indications, consist
+in a sequence of @dfn{bold letters} and @dfn{bold digits}, known as a
+@dfn{bold word}.  In contrast, other constructs like identifiers,
+field selectors and labels, collectively known as @dfn{tags}, are
+composed of regular, non-bold letters and digits.
+
+What is precisely a bold letter or digit, and how they differ from
+non-bold letters and digits, is not specified by the Report.  This is
+no negligence, but a conscious effort at abstracting the definition of
+the so-called @dfn{strict language} from its representation.  This
+allows different representations of the same language.
+
+Some representations of Algol 68 are intended to be published in
+books, be it paper or electronic devices, and be consumed by persons.
+These are called @dfn{publication languages}.  In publication
+languages bold letters and digits are typically represented by actual
+bold alphanumeric typographic marks.  An Algol 68 program hand written
+on a napkin or a sheet of paper would typically represent bold letters
+and digits underlined, or stroked using a different color ink.
+
+Other representations of Algol 68 are intended to be automatically
+processed by a computer.  These representations are called
+@dfn{hardware languages}.  Sometimes the hardware languages are also
+intended to be written and read by programmers; these are called
+@dfn{programming languages}.
+
+Unfortunately, computer systems today usually do not yet provide
+readily usable and ergonomic bold or underline alphanumeric marks,
+despite the existence of Unicode and modern and sophisticated editing
+environments.  The lack of appropriate input methods surely plays a
+role to explain this.  Thus, the programming representation languages
+of Algol 68 should resort to a technique known as @dfn{stropping} in
+order to differentiate bold letters and digits from non-bold letters
+and digits.  The set of rules specifying the representation of these
+characters is called a @dfn{stropping regime}.
+
+There are three classical stropping regimes for Algol 68, which are
+standardized and specified in the Standard Hardware Representation
+normative document.  These are @dfn{POINT stropping}, @dfn{RES
+stropping} and @dfn{UPPER stropping}.  The following sections do a
+cursory tour over them; for more details the reader is referred to the
+Standard Hardware Representation.
+
+This compiler implements UPPER stropping and SUPPER stropping.
+
+@menu
+* POINT stropping::
+* RES stropping::
+* UPPER stropping::
+* SUPPER stropping::
+@end menu
+
+@node POINT stropping
+@subsection POINT stropping
+
+POINT stropping is in a way the most fundamental of the three standard
+regimes.  It was designed to work in installations with limited
+character sets that provide only one alphabet, one set of digits, and
+a very restricted set of other symbols.
+
+In POINT stropping a bold word is represented by its constituent
+letters and digits preceded by a point character.  For example, the
+symbol @code{bold begin symbol} in the strict language, which is
+represented as @strong{begin} in bold face in the reference language,
+would be represented as @code{.BEGIN} in POINT stropping.
+
+More examples are summarized in the following table.
+
+@multitable @columnfractions .33 .33 .33
+@headitem Strict language @tab Reference language @tab POINT stropping
+@item @code{true symbol} @tab @strong{true} @tab @code{.TRUE}
+@item @code{false symbol} @tab @strong{false} @tab @code{.FALSE}
+@item @code{integral symbol} @tab @strong{int} @tab @code{.INT}
+@item @code{completion symbol} @tab @strong{exit} @tab @code{.EXIT}
+@item @code{bold-letter-c-...} @tab @strong{crc32} @tab @code{.CRC32}
+@end multitable
+
+In POINT stropping a tag is represented by writing its constituent
+non-bold letters and digits in order.  But they are organized in
+several @dfn{taggles}.
+
+Each taggle is a sequence of one or more letters and digits,
+optionally followed by an underscore character.  For example, the tag
+@code{PRINT} is composed of a single taggle, but the tag
+@code{PRINT_TABLE} is composed of a first taggle @code{PRINT_}
+followed by a second taggle @code{TABLE}.
+
+To improve readability it is possible to insert zero or more white
+space characters between the taggles in a tag.  Therefore, the tag
+@code{PRINT_TABLE} could have been written @code{PRINT TABLE}, or even
+@code{PRINT_ TABLE}.  This is the reason why Algol 68 identifiers,
+labels and field selectors can and do usually feature white spaces in
+them.
+
+It is important to note that both the trailing underscore characters
+in taggles and the white spaces in a tag do not contribute anything to
+the denoted tag: these are just stropping artifacts aimed to improve
+readability.  Therefore @code{FOOBAR} @code{FOO BAR}, @code{FOO_BAR}
+and @code{FOO_BAR_} are all representations of the same tag, that
+represents the
+@code{letter-f-letter-o-letter-o-letter-b-letter-a-letter-r} language
+construct.
+
+Below is the text of an example Algol 68 procedure encoded in POINT
+stropping.
+
+@example
+.PROC RECSEL OUTPUT RECORDS = .VOID:
+.BEGIN .BITS FLAGS
+         := (INCLUDE DESCRIPTORS | REC F DESCRIPTOR | REC F NONE);
+       .RECRSET RES = REC DB QUERY (DB, RECUTL TYPE,
+                                    RECUTL QUICK, FLAGS);
+       .RECWRITER WRITER := REC WRITER FILE NEW (STDOUT);
+
+       SKIP COMMENTS .OF WRITER := .TRUE;
+       .IF RECUTL PRINT SEXPS
+       .THEN MODE .OF WRITER := REC WRITER SEXP .FI;
+       REC WRITE (WRITER, RES)
+.END
+@end example
+
+@node RES stropping
+@subsection RES stropping
+
+The early installations where Algol 68 ran not only featured a very
+restricted character set, but also suffered from limited storage and
+complex to use and time consuming input methods such as card punchers
+and readers.  It was important for the representation of programs to
+be as compact as possible.
+
+It is likely that is what motivated the introduction of the RES
+stropping regime.  As its name implies, it removes the need of
+stropping many bold words by introducing @dfn{reserved words}.
+
+A @dfn{reserved word} is one of the bold words specified in the
+section 9.4.1 of the Report as a representation of some symbol.
+Examples are @strong{at}, @strong{begin}, @strong{if}, @strong{int}
+and @strong{real}.
+
+RES stropping encodes bold words and tags like POINT stropping, but if
+a bold word is a reserved word then it can then be written without a
+preceding point, achieving this way a more compact, and easier to
+read, representation for programs.
+
+Introducing reserved words has the obvious disadvantage that some tags
+cannot be written the obvious way due to the possibility of conflicts.
+For example, to represent a tag @code{if} it is not possible to just
+write @code{IF}, because it conflicts with a reserved word, but this
+can be overcome easily (if not elegantly) by writing @code{IF_}
+instead.
+
+Below is the @code{recsel output records} procedure again, this time
+encoded in RES stropping.
+
+@example
+PROC RECSEL OUTPUT RECORDS = VOID:
+BEGIN BITS FLAGS
+         := (INCLUDE DESCRIPTORS | REC F DESCRIPTOR | REC F NONE);
+      .RECRSET RES = REC DB QUERY (DB, RECUTL TYPE,
+                                   RECUTL QUICK, FLAGS);
+      .RECWRITER WRITER := REC WRITER FILE NEW (STDOUT);
+
+      SKIP COMMENTS OF WRITER := TRUE;
+      IF RECUTL PRINT SEXPS
+      THEN MODE .OF WRITER := REC WRITER SEXP FI;
+      REC WRITE (WRITER, RES)
+END
+@end example
+
+Note how user-defined mode an operator indications still require
+explicit stropping.
+
+@node UPPER stropping
+@subsection UPPER stropping
+
+In time computers added support for more than one alphabet by
+introducing character sets with both upper and lower case letters,
+along with convenient ways to both input and display these.
+
+In UPPER stropping the bold letters in bold word are represented by
+upper-case letters, whereas the letters in tags are represented by
+lower-case letters.
+
+The notions of upper- and lower-case are not applicable to digits, but
+since the language syntax assures that it is not possible to have a
+bold word that starts with a digit, digits are considered to be bold
+if they follow a bold letter or another bold digit.
+
+Below is the @code{recsel output records} procedure again, this time
+encoded in UPPER stropping.
+
+@example
+PROC recsel output records = VOID:
+BEGIN BITS flags
+         := (include descriptors | rec f descriptor | rec f none);
+      RECRSET res = rec db query (db, recutl type,
+                                  recutl quick, flags);
+      RECWRITER writer := rec writer file new (stdout);
+
+      skip comments of writer := TRUE;
+      IF recutl print sexps
+      THEN mode OF writer := rec writer sexp FI;
+      rec write (writer, res)
+END
+@end example
+
+Note how in this regime it is almost never necessary to introduce bold
+tags with points.  All in all, it looks much more natural to
+contemporary readers.  UPPER stropping is in fact the stropping regime
+of choice today.  It is difficult to think of any reason why anyone
+would resort to use POINT or RES stropping.
+
+@node SUPPER stropping
+@subsection SUPPER stropping
+
+In the SUPPER stropping regime bold words are written by writing a
+sequence of one or more @dfn{taggles}. Each taggle is written by
+writing a letter followed by zero or more other letters and digits and
+is optionally followed by a trailing underscore character.  The first
+letter in a bold word shall be an upper-case letter.  The rest of the
+letters in the bold word may be either upper- or lower-case.
+
+For example, @code{RecRset}, @code{Rec_Rset} and @code{RECRset} are
+all different ways to represent the same mode indication.  This allows
+to recreate popular naming conventions such as @code{CamelCase}.
+
+As in the other stropping regimes, the casing of the letters and the
+underscore characters are not really part of the mode or operator
+indication.
+
+Operator indications are also bold words and are written in exactly
+the same way than mode indications, but it is usually better to always
+use upper-case letters in operator indications.  On one side, it looks
+better, especially in the case of dyadic operators where the asymmetry
+of, for example @code{Equal} would look odd, consider @code{m1 Equal
+m2} as opposed to @code{m1 EQUAL m2}.  On the other side, tools like
+editors can make use of this convention in order to highlight operator
+indications differently than mode indications.
+
+In the SUPPER stropping regime tags are written by writing a sequence
+of one or more @dfn{taggles}.  Each taggle is written by writing a
+letter followed by zero or more other letters and digits and is
+optionally followed by a trailing underscore character.  All letters
+in a tag shall be lower-case letters.
+
+For example, the identifier @code{list} is represented by a single
+taggle, and it is composed by the letters @code{l}, @code{i}, @code{s}
+and @code{t}, in order.  In the jargon of the strict language we would
+spell the tag as @code{letter-l-letter-i-letter-s-letter-t}.
+
+The label @code{found_zero} is represented by two taggles,
+@code{found_} and @code{zero}, and it is composed by the letters
+@code{f}, @code{o}, @code{u}, @code{n}, @code{d}, @code{z}, @code{e},
+@code{r} and @code{o}, in order.  In the jargon of the strict language
+we would spell the tag as @code{letter-f-letter-o-letter-u-letter-n
+-letter-d-letter-z-letter-e-letter-r-letter-o}.
+
+The identifier @code{crc_32} is likewise represented by two taggles,
+@code{crc_} and @code{32}.  Note how the second taggle contains only
+digits.  In the jargon of the strict language we would spell the tag
+as @code{letter-c-letter-r-letter-c-digit-three-digit-two}.
+
+The underscore characters are not really part of the tag, but part of
+the stropping.  For example, both @code{goto found_zero} and
+@code{goto foundzero} jump to the same label.
+
+The @code{recsel output records} procedure, encoded in SUPPER
+stropping, looks like below.
+
+@example
+proc recsel_output_records = void:
+begin bits flags
+        := (include_descriptors | rec_f_descriptor | rec_f_none);
+      RecRset res = rec_db_query (db, recutl_type,
+                                  recutl_uick, flags);
+      RecWriter writer := rec_writer_file_new (stdout);
+
+      skip_comments of writer := true;
+      if recutl_print_sexps
+      then mode_ of writer := rec_writer_sexp fi;
+      rec_write (writer, res)
+end
+@end example
+
+@node Monads and Nomads
+@section Monads and Nomads
+@cindex monads
+@cindex nomads
+
+Algol68 operators, be them predefined or defined by the programmer,
+can be referred via either bold tags or sequences of certain
+non-alphabetic symbols.  For example, the dyadic operator @code{+} is
+defined for many modes to perform addition, the monadic operator
+@code{@B{entier}} gets a real value and rounds it to an integral
+value, and the operator @code{:=:} is the identity relation.  Many
+operators provide both bold tag names and symbols names, like in the
+case of @code{:/=:} that can also be written as @code{@B{isnt}}.
+
+Bold tags are lexically well delimited, and if the same tag is used to
+refer to a monadic operator and to a dyadic operator, no ambiguity can
+arise.  For example, in the following program it is clear that the
+second instance of @code{@B{plus}} refers to the monadic operator, and
+the first instance refers to the dyadic operator@footnote{If one would
+write @code{@B{plusplus}}, it would be a third different bold tag.}.
+
+@example
+@B{op} @B{PLUS} = (@B{int} a, b) @B{int}: a + b,
+   @B{PLUS} = (@B{int} a): a;
+@B{int} val = 2 @B{PLUS} @B{PLUS} 3;
+@end example
+
+On the other hand, symbols are not lexically delimited as words, and
+one symbol can appear immediately following another symbol.  This can
+lead to ambiguities.  For example, if we were to define a C-like
+monadic operator @code{++} like:
+
+@example
+@B{op} ++ = (@B{ref} @B{int} a) @B{int}: (@B{int} t = a; a +:=1; t);
+@end example
+
+@noindent
+Then the expression @code{++a} would be ambiguous: is it @code{++a} or
+@code{+(+a)}?.  In a similar way, if we would use @code{++} as the
+name of a dyadic operator, an expression like @code{a++b} could be
+also interpreted as both @code{a++b} and @code{a+(+b)}.
+
+To avoid these problems Algol 68 divides the symbols which are
+suitable to appear in the name of an operator into two classes: monads
+and nomads.  @dfn{Monads} are symbols that can be used as monadic
+operators.  @dfn{Nomads} are symbols which can be used as both monadic
+or dyadic operators.  Given these two sets, the rules to conform a
+valid operator are:
+
+@itemize @minus
+@item A bold tag.
+@item Any monad.
+@item A monad followed by a nomad.
+@item A monad optionally followed by a nomad followed by either @code{:=} or @code{=:}, but not by both.
+@end itemize
+
+@noindent
+In the GNU Algol 68 compiler:
+
+@itemize @minus
+@item The set of monads is @code{%^&+-~!?}.
+@item The set of nomads is @code{></=*}.
+@end itemize
+
+@node String breaks
+@section String breaks
+
+The intrinsic value of each worthy character that appears inside a
+string denotation is itself.  The string @code{"/abc"}, therefore,
+contains a slash character followed by the three letters @code{a},
+@code{b} and @code{c}.
+
+Sometimes, however, it becomes necessary to represent some non-worthy
+character in a string denotation.  In these cases, an escape
+convention has to be used to represent these extra string-items.  It
+is up to the implementation to decide this convention, and the only
+requirement imposed by the Standard Hardware Representation on this
+regard is that the character used to introduce escapes, the
+@dfn{escape character}, shall be the apostrophe.  This section
+documents the escape conventions implemented by the GNU compiler.
+
+Two characters have special meaning inside string denotations: double
+quote (@code{"}) and apostrophe (@code{'}).  The first finishes the
+string denotation, and the second starts a @dfn{string break}, which
+is the Algol 68 term for what is known as an ``escape sequence'' in
+other programming languages.  Two consecutive double-quote characters
+specify a single double-quote character.
+
+The following string breaks are recognized by this compiler:
+
+@table @code
+@item ''
+Apostrophe character @code{'}.
+@item 'n
+Newline character.
+@item 'f
+Form feed character.
+@item 'r
+Carriage return (no line feed).
+@item 't
+Tab.
+@item '(list of character codes separated by commas)
+The indicated characters, where each code has the form @code{uhhhh} or
+@code{Uhhhhhhhh}, where @code{hhhh} and @code{hhhhhhhh} are integers
+expressing the character code in hexadecimal.  The list must contain
+at least one entry.
+@end table
+
+A string break can appear as the single string-item in a character
+denotation, subject to the following restrictions:
+
+@itemize @bullet
+@item
+List of characters string breaks @code{'(...)} that contain more than
+one character code are not allowed in character denotations.  If the
+specified code point is not a valid Unicode character then the value
+of the denotation is @code{invalid char}.
+@end itemize
+
+@node Standard prelude
+@chapter Standard prelude
+@cindex prelude, standard
+
+The Algol 68 Revised Report defines an extensive set of standard
+modes, operators, procedures and values, collectively known as the
+@dfn{standard prelude}.
+
+The standard prelude is available to Algol 68 programs without needing
+to import any module.
+
+For brevity, in this section the pseudo-mode @code{@B{L}} represents a
+@dfn{shortsety}, i.e. a sequence of either zero or more
+@code{@B{LONG}} or zero or more @code{@B{SHORT}}.
+
+@menu
+* Environment enquiries::              Information about the implementation.
+* Standard modes::                     Modes defined by the standard prelude.
+* Standard priorities::                Priorities of all standard operators.
+* Rows operators::                     Rows and associated operations.
+* Boolean operators::                  Operations on boolean operands.
+* Integral operators::                 Operations on integral operands.
+* Real operators::                     Operations on real operands.
+* Character operators::                Operations on character operands.
+* String operators::                   Strings and associated operations.
+* Complex operators::                  Operations on complex operands.
+* Bits operators::                     Bits and associated operations.
+* Bytes operators::                    Bytes and associated operations.
+* Semaphore operators::                Synchronization operations.
+* Math procedures::                    Standard mathematical constants and functions.
+@end menu
+
+@node Environment enquiries
+@section Environment enquiries
+
+An @dfn{environment enquiry} is a constant or a procedure, whose
+elaboration yields a value that may be useful to the programmer, that
+reflects some characteristic of the particular implementation.  The
+values of these enquiries are also determined by the architecture and
+operating system targeted by the compiler.
+
+@deftypevr Constant @B{int} {int lengths}
+1 plus the number of extra lenghts of integers which are meaningful.
+@end deftypevr
+
+@deftypevr Constant @B{int} {int shorths}
+1 plus the number of extra shorths of integers which are meaningful.
+@end deftypevr
+
+@deftypevr Constant {@B{l} @B{int}} {L max int}
+The largest integral value.
+@end deftypevr
+
+@deftypevr Constant @B{int} {real lengths}
+1 plus the number of extra lenghts of real numbers which are
+meaningful.
+@end deftypevr
+
+@deftypevr Constant @B{int} {real shorths}
+1 plus the number of extra shorths of real numbers which are
+meaningful.
+@end deftypevr
+
+@deftypevr Constant {@B{l} @B{real}} {L max real}
+The largest real value.
+@end deftypevr
+
+@deftypevr Constant {@B{l} @B{real}} {L small real}
+The smallest real value such that both @code{1 + small real > 1} and
+@code{1 - small real < 1}.
+@end deftypevr
+
+@deftypevr Constant @B{int} {bits lengths}
+1 plus the number of extra widths of bits which are meaningful.
+@end deftypevr
+
+@deftypevr Constant @B{int} {bits shorths}
+1 plus the number of extra shorths of bits which are meaningful.
+@end deftypevr
+
+@deftypevr Constant @B{int} {bits width}
+@deftypevrx Constant @B{int} {long bits width}
+@deftypevrx Constant @B{int} {long long bits width}
+The number of bits in a @code{@B{bits}} value.
+@end deftypevr
+
+@deftypevr Constant @B{int} {bytes lengths}
+1 plus the number of extra widths of bytes which are meaningful.
+@end deftypevr
+
+@deftypevr Constant @B{int} {bytes shorths}
+1 plus the number of extra shorths of bytes which are meaningful.
+@end deftypevr
+
+@deftypevr Constant @B{int} {bytes width}
+@deftypevrx Constant @B{int} {long bytes width}
+@deftypevrx Constant @B{int} {long long bytes width}
+The number of chars in a @code{@B{bytes}} value.
+@end deftypevr
+
+@deftypevr Constant @B{int} {max abs char}
+The largest value which @code{@B{abs}} of a @code{@B{char}} can yield.
+@end deftypevr
+
+@deftypevr Constant @B{char} {null character}
+Some character.
+@end deftypevr
+
+@deftypevr Constant @B{char} flip
+@deftypevrx Constant @B{char} flop
+Characters used to represent @code{@B{true}} and @code{@B{false}}
+boolean values in textual transput.
+@end deftypevr
+
+@deftypevr Constant @B{char} {error char}
+Character used to represent the digit of a value resulting from a
+conversion error in textual transput.
+@end deftypevr
+
+@deftypevr Constant @B{char} blank
+The space character.
+@end deftypevr
+
+@deftypevr Constant {@B{l} @B{real}} {L pi}
+The number pi.
+@end deftypevr
+
+@node Standard modes
+@section Standard modes
+
+@deftp Mode @B{void}
+The only value of this mode is @code{@B{empty}}.
+@end deftp
+
+@deftp Mode @B{bool}
+Mode for the boolean truth values @code{@B{true}} and @code{@B{false}}.
+@end deftp
+
+@deftp Mode {@B{l} @B{int}}
+Modes for signed integral values.  Each @code{@B{long}} or
+@code{@B{short}} may increase or decrease the range of the domain,
+depending on the characteristics of the current target.  Further
+@code{@B{long}}s and @code{@B{short}}s may be specified with no
+effect.
+@end deftp
+
+@deftp Mode {@B{l} @B{real}}
+Modes for signed real values.  Each @code{@B{long}} may increase the
+upper range of the domain, depending on the characteristics of the
+current target.  Further @code{@B{long}}s may be specified but with no
+effect.
+@end deftp
+
+@deftp Mode @B{char}
+Mode for character values.  The character values are mapped one-to-one
+to code points in the 21-bit space of Unicode.
+@end deftp
+
+@deftp Mode @B{string} {= @B{flex}[1:0]@B{char}}
+Mode for sequences of characters.  This is implemented as a flexible
+row of @code{@B{char}} values.
+@end deftp
+
+@deftp Mode {@B{l} @B{compl}} {= @B{struct} (@B{real} re,im)}
+Modes for complex values.  Each @code{@B{long}} may increase the
+precision of both the real and imaginary parts of the numbers,
+depending on the characteristics of the current target.  Further
+@code{@B{long}}s may be specified with no effect.
+@end deftp
+
+@deftp Mode {@B{l} @B{bits}}
+Compact and efficient representation of a row of boolean values.  Each
+@code{@B{long}} may increase the number of booleans that can be packed
+in a bits, depending on the characteristics of the current target.
+@end deftp
+
+@deftp Mode {@B{l} @B{bytes}}
+Compact and efficient representation of a row of character values.
+Each @code{@B{long}} may increase the number of characters that can be
+packed in a bytes, depending on the characteristics of the current
+target.
+@end deftp
+
+@node Standard priorities
+@section Standard priorities
+
+@table @code
+@item 1
+@itemize @bullet
+@item @code{plusab}, @code{+:=}
+@item @code{minusab}, @code{-:=}
+@item @code{timesab}, @code{*:=}
+@item @code{divab}, @code{/:=}
+@item @code{overab}, @code{%:=}
+@item @code{modab}, @code{%*:=}
+@item @code{plusto}, @code{+=:}
+@end itemize
+
+@item 2
+@itemize @bullet
+@item @code{or}
+@end itemize
+
+@item 3
+@itemize @bullet
+@item @code{and}
+@item @code{xor}
+@end itemize
+
+@item 4
+@itemize @bullet
+@item @code{@B{eq}}, @code{=}
+@item @code{@B{ne}}, @code{/=}
+@end itemize
+
+@item  5
+@itemize @bullet
+@item @code{@B{lt}}, @code{<},
+@item @code{@B{le}}, @code{<=}
+@item @code{@B{gt}}, @code{>}
+@item @code{@B{ge}}, @code{>=}
+@end itemize
+
+@item 6
+@itemize @bullet
+@item @code{+}
+@item @code{-}
+@end itemize
+
+@item 7
+@itemize @bullet
+@item @code{*}
+@item @code{/}
+@item @code{@B{over}}, @code{%}
+@item @code{@B{mod}}, @code{%*}
+@item @code{@B{elem}}
+@end itemize
+
+@item 8
+@itemize @bullet
+@item @code{**}
+@item @code{@B{shl}}, @code{@B{up}}
+@item @code{@B{shr}}, @code{@B{down}}
+@item @code{@B{up}}, @code{@B{down}}
+@item @code{^}
+@item @code{@B{lwb}}
+@item @code{@B{upb}}
+@end itemize
+
+@item 9
+@itemize @bullet
+@item @code{@B{i}}
+@item @code{+*}
+@end itemize
+@end table
+
+@node Rows operators
+@section Rows operators
+
+The following operators work on any row mode, denoted below using the
+pseudo-mode @code{@B{rows}}.
+
+@deftypefn Operator {} {@B{lwb}} {= (@B{rows} a) @B{int}}
+Monadic operator that yields the lower bound of the first bound pair
+of the descriptor of the value of @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{upb}} {= (@B{rows} a) @B{int}}
+Monadic operator that yields the upper bound of the first bound pair
+of the descriptor of the value of @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{lwb}} {= (@B{int} n, @B{rows} a) @B{int}}
+Dyadic operator that yields the lower bound in the n-th bound pair of
+the descriptor of the value of @code{a}, if that bound pair exists.
+Attempting to access a non-existing bound pair results in a run-time
+error.
+@end deftypefn
+
+@deftypefn Operator {} {@B{upb}} {= (@B{int} n, @B{rows} a) @B{int}}
+Dyadic operator that yields the upper bound in the n-th bound pair of
+the descriptor of the value of @code{a}, if that bound pair exists.
+Attempting to access a non-existing bound pair results in a run-time
+error.
+@end deftypefn
+
+@node Boolean operators
+@section Boolean operators
+
+@deftypefn Operator {} {@B{not}} {= (@B{bool} a) @B{bool}}
+@deftypefnx Operator {} {~} {= (@B{bool} a) @B{bool}}
+Monadic operator that yields the logical negation of its operand.
+@end deftypefn
+
+@deftypefn Operator {} {@B{or}} {= (@B{bool} a, b) @B{bool}}
+Dyadic operator that yields the logical ``or'' of its operands.
+@end deftypefn
+
+@deftypefn Operator {} {@B{and}} {= (@B{bool} a, b) @B{bool}}
+@deftypefnx Operator {} {@B{&}} {= (@B{bool} a, b) @B{bool}}
+Dyadic operator that yields the logical ``and'' of its operands.
+@end deftypefn
+
+@deftypefn Operator {} {@B{eq}} {= (@B{bool} a, b) @B{bool}}
+@deftypefnx Operator {} {=} {= (@B{bool} a, b) @B{bool}}
+Dyadic operator that yields @code{@B{true}} if its operands are the
+same truth value, @code{@B{false}} otherwise.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ne}} {= (@B{bool} a, b) @B{bool}}
+@deftypefnx Operator {} {/=} {= (@B{bool} a, b) @B{bool}}
+Dyadic operator that yields @code{@B{false}} if its operands are the
+same truth value, @code{@B{true}} otherwise.
+@end deftypefn
+
+@deftypefn Operator {} {@B{abs}} {= (@B{bool} a) @B{int}}
+Monadic operator that yields 1 if its operand is @code{@B{true}}, and
+0 if its operand is @code{@B{false}}.
+@end deftypefn
+
+@node Integral operators
+@section Integral operators
+
+@subsection Arithmetic
+
+@deftypefn Operator {} {+} {= (@B{l} @B{int} a) @B{l} @B{int}}
+Monadic operator that yields the affirmation of its operand.
+@end deftypefn
+
+@deftypefn Operator {} {-} {= (@B{l} @B{int} a) @B{l} @B{int}}
+Monadic operator that yields the negative of its operand.
+@end deftypefn
+
+@deftypefn Operator {} {@B{abs}} {= (@B{l} @B{int} a) @B{l} @B{int}}
+Monadic operator that yields the absolute value of its operand.
+@end deftypefn
+
+@deftypefn Operator {} {@B{sign}} {= (@B{l} @B{int} a) @B{int}}
+Monadic operator that yields -1 if @code{a} if negative, 0 if @code{a}
+is zero and 1 if @code{a} is positive.
+@end deftypefn
+
+@deftypefn Operator {} {@B{odd}} {= (@B{l} @B{int} a) @B{bool}}
+Monadic operator that yields @code{@B{true}} if its operand is odd,
+@code{@B{false}} otherwise.
+@end deftypefn
+
+@deftypefn Operator {} {+} {= (@B{l} @B{int} a, b) @B{l} @B{int}}
+Dyadic operator that yields the addition of its operands.
+@end deftypefn
+
+@deftypefn Operator {} {-} {= (@B{l} @B{int} a, b) @B{l} @B{int}}
+Dyadic operator that yields @code{b} subtracted from @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {*} {= (@B{l} @B{int} a, b) @B{l} @B{int}}
+Dyadic operator that yields the multiplication of its operands.
+@end deftypefn
+
+@deftypefn Operator {} {@B{over}} {= (@B{l} @B{int} a, b) @B{l} @B{int}}
+@deftypefnx Operator {} {%} {= (@B{l} @B{int} a, b) @B{l} @B{int}}
+Dyadic operator that yields the integer division of @code{a} by
+@code{b}, rounding the quotient toward zero.
+@end deftypefn
+
+@deftypefn Operator {} {@B{mod}} {= (@B{l} @B{int} a, b) @B{l} @B{int}}
+@deftypefnx Operator {} {%*} {= (@B{l} @B{int} a, b) @B{l} @B{int}}
+Dyadic operator that yields the remainder of the division of @code{a}
+by @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {/} {= (@B{l} @B{int} a, b) @B{l} @B{real}}
+Dyadic operator that yields the integer division with real result of
+@code{a} by @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {**} {= (@B{l} @B{int} a, b) @B{l} @B{int}}
+@deftypefnx Operator {} {^} {= (@B{l} @B{int} a, b) @B{l} @B{int}}
+Dyadic operator that yields @code{a} raised to the exponent @code{b}.
+@end deftypefn
+
+@subsection Arithmetic combined with assignation
+
+@deftypefn Operator {} {@B{plusab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+@deftypefnx Operator {} {+:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+@dfn{Plus and become}.  Dyadic operator that calculates @code{a + b},
+assigns the result of the operation to the name @code{a} and then
+yields @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{minusab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+@deftypefnx Operator {} {-:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+Dyadic operator that calculates @code{a - b}, assigns the result of
+the operation to the name @code{a} and then yields @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{timesab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+@deftypefnx Operator {} {*:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+Dyadic operator that calculates @code{a * b}, assigns the result of
+the operation to the name @code{a} and then yields @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{overab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+@deftypefnx Operator {} {%:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+Dyadic operator that calculates @code{a % b}, assigns the result of
+the operation to the name @code{a} and then yields @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{modab}} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+@deftypefnx Operator {} {%*:=} {= (@B{ref} @B{l} @B{int} a, @B{l} @B{int} b) @B{ref} @B{l} @B{int}}
+Dyadic operator that calculates @code{a %* b}, assigns the result of
+the operation to the name @code{a} and then yields @code{a}.
+@end deftypefn
+
+@subsection Relational
+
+@deftypefn Operator {} {@B{eq}} {= (@B{l} @B{int} a, b) @B{bool}}
+@deftypefnx Operator {} {=} {= (@B{l} @B{int} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are equal.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ne}} {= (@B{l} @B{int} a, b) @B{bool}}
+@deftypefnx Operator {} {/=} {= (@B{l} @B{int} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are not equal.
+@end deftypefn
+
+@deftypefn Operator {} {@B{lt}} {= (@B{l} @B{int} a, b) @B{bool}}
+@deftypefnx Operator {} {<} {= (@B{l} @B{int} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is less than @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{le}} {= (@B{l} @B{int} a, b) @B{bool}}
+@deftypefnx Operator {} {<=} {= (@B{l} @B{int} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is less than, or equal to
+@code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{gt}} {= (@B{l} @B{int} a, b) @B{bool}}
+@deftypefnx Operator {} {>} {= (@B{l} @B{int} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is greater than
+@code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ge}} {= (@B{l} @B{int} a, b) @B{bool}}
+@deftypefnx Operator {} {>=} {= (@B{l} @B{int} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is greater than, or equal
+to @code{b}.
+@end deftypefn
+
+@subsection Conversion
+
+@deftypefn Operator {} {@B{shorten}} {= (@B{short} @B{int} a) @B{short} @B{short} @B{int}}
+@deftypefnx Operator {} {@B{shorten}} {= (@B{int} a) @B{short} @B{int}}
+@deftypefnx Operator {} {@B{shorten}} {= (@B{long} @B{int} a) @B{int}}
+@deftypefnx Operator {} {@B{shorten}} {= (@B{long} @B{long} @B{int} a) @B{long} @B{int}}
+Monadic operator that yields, if it exists, the integral value that
+can be lengthened to the value of @code{a}.  If the value doesn't
+exist then the operator yields either the most positive integral value
+in the destination mode, if @code{a} is bigger than that value, or the
+most negative integral value in the destination mode, if @code{a} is
+smaller than that value.
+@end deftypefn
+
+@deftypefn Operator {} {@B{leng}} {= (@B{short} @B{short} @B{int} a) @B{short} @B{int}}
+@deftypefnx Operator {} {@B{leng}} {= (@B{short} @B{int} a) @B{int}}
+@deftypefnx Operator {} {@B{leng}} {= (@B{int} a) @B{long} @B{int}}
+@deftypefnx Operator {} {@B{leng}} {= (@B{long} @B{int} a) @B{long} @B{long} @B{int}}
+Monadic operator that yields the integral value lengthened from the
+value of @code{a}.
+@end deftypefn
+
+@node Real operators
+@section Real operators
+
+@subsection Arithmetic
+
+@deftypefn Operator {} {+} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Monadic operator that yields the affirmation of its operand.
+@end deftypefn
+
+@deftypefn Operator {} {-} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Monadic operator that yields the negative of its operand.
+@end deftypefn
+
+@deftypefn Operator {} {@B{abs}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Monadic operator that yields the absolute value of its operand.
+@end deftypefn
+
+@deftypefn Operator {} {@B{sign}} {= (@B{l} @B{real} a) @B{int}}
+Monadic operator that yields -1 if @code{a} if negative, 0 if @code{a}
+is zero and 1 if @code{a} is positive.
+@end deftypefn
+
+@deftypefn Operator {} {+} {= (@B{l} @B{real} a, b) @B{l} @B{real}}
+Dyadic operator that yields the addition of its operands.
+@end deftypefn
+
+@deftypefn Operator {} {-} {= (@B{l} @B{real} a, b) @B{l} @B{real}}
+Dyadic operator that yields @code{b} subtracted from @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {*} {= (@B{l} @B{real} a, b) @B{l} @B{real}}
+Dyadic operator that yields the multiplication of its operands.
+@end deftypefn
+
+@deftypefn Operator {} {/} {= (@B{l} @B{real} a, b) @B{l} @B{real}}
+Dyadic operator that yields the realeger division with real result of
+@code{a} by @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {**} {= (@B{l} @B{real} a, b) @B{l} @B{real}}
+@deftypefnx Operator {} {^} {= (@B{l} @B{real} a, b) @B{l} @B{real}}
+Dyadic operator that yields @code{a} raised to the real exponent @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {**} {= (@B{l} @B{real} a, @B{int} b) @B{l} @B{real}}
+@deftypefnx Operator {} {^} {= (@B{l} @B{real} a, @B{int} b) @B{l} @B{real}}
+Dyadic operator that yields @code{a} raised to the integral exponent
+@code{b}.
+@end deftypefn
+
+@subsection Arithmetic combined with assignation
+
+@deftypefn Operator {} {@B{plusab}} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}}
+@deftypefnx Operator {} {+:=} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}}
+@dfn{Plus and become}.  Dyadic operator that calculates @code{a + b},
+assigns the result of the operation to the name @code{a} and then
+yields @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{minusab}} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}}
+@deftypefnx Operator {} {-:=} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}}
+Dyadic operator that calculates @code{a - b}, assigns the result of
+the operation to the name @code{a} and then yields @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{timesab}} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}}
+@deftypefnx Operator {} {*:=} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}}
+Dyadic operator that calculates @code{a * b}, assigns the result of
+the operation to the name @code{a} and then yields @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{divab}} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}}
+@deftypefnx Operator {} {/:=} {= (@B{ref} @B{l} @B{real} a, @B{l} @B{real} b) @B{ref} @B{l} @B{real}}
+Dyadic operator that calculates @code{a / b}, assigns the result of
+the operation to the name @code{a} and then yields @code{a}.
+@end deftypefn
+
+@subsection Relational
+
+@deftypefn Operator {} {@B{eq}} {= (@B{l} @B{real} a, b) @B{bool}}
+@deftypefnx Operator {} {=} {= (@B{l} @B{real} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are equal.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ne}} {= (@B{l} @B{real} a, b) @B{bool}}
+@deftypefnx Operator {} {/=} {= (@B{l} @B{real} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are not equal.
+@end deftypefn
+
+@deftypefn Operator {} {@B{lt}} {= (@B{l} @B{real} a, b) @B{bool}}
+@deftypefnx Operator {} {<} {= (@B{l} @B{real} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is less than @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{le}} {= (@B{l} @B{real} a, b) @B{bool}}
+@deftypefnx Operator {} {<=} {= (@B{l} @B{real} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is less than, or equal to
+@code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{gt}} {= (@B{l} @B{real} a, b) @B{bool}}
+@deftypefnx Operator {} {>} {= (@B{l} @B{real} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is greater than
+@code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ge}} {= (@B{l} @B{real} a, b) @B{bool}}
+@deftypefnx Operator {} {>=} {= (@B{l} @B{real} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is greater than, or equal
+to @code{b}.
+@end deftypefn
+
+@subsection Conversions
+
+@deftypefn Operator {} {@B{round}} {= (@B{l} @B{real} a) @B{int}}
+Monadic operator that yields the nearest integer to its operand.
+@end deftypefn
+
+@deftypefn Operator {} {@B{entier}} {= (@B{l} @B{real} a) @B{int}}
+Monadic operator that yields the integer equal to @code{a}, or the
+next integer below (more negative than) @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{shorten}} {= (@B{long} @B{real} a) @B{real}}
+@deftypefnx Operator {} {@B{shorten}} {= (@B{long} @B{long} @B{real} a) @B{long} @B{real}}
+Monadic operator that yields, if it exists, the real value that
+can be lengthened to the value of @code{a}.  If the value doesn't
+exist then the operator yields either the most positive real value
+in the destination mode, if @code{a} is bigger than that value, or the
+most negative real value in the destination mode, if @code{a} is
+smaller than that value.
+@end deftypefn
+
+@deftypefn Operator {} {@B{leng}} {= (@B{real} a) @B{long} @B{real}}
+@deftypefnx Operator {} {@B{leng}} {= (@B{long} @B{real} a) @B{long} @B{long} @B{real}}
+Monadic operator that yields the real value lengthened from the
+value of @code{a}.
+@end deftypefn
+
+@node Character operators
+@section Character operators
+
+@subsection Relational
+
+@deftypefn Operator {} {@B{eq}} {= (@B{char} a, b) @B{bool}}
+@deftypefnx Operator {} {=} {= (@B{char} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are equal.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ne}} {= (@B{char} a, b) @B{bool}}
+@deftypefnx Operator {} {/=} {= (@B{char} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are not equal.
+@end deftypefn
+
+@deftypefn Operator {} {@B{lt}} {= (@B{char} a, b) @B{bool}}
+@deftypefnx Operator {} {<} {= (@B{char} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is less than @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{le}} {= (@B{char} a, b) @B{bool}}
+@deftypefnx Operator {} {<=} {= (@B{char} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is less than, or equal to
+@code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{gt}} {= (@B{char} a, b) @B{bool}}
+@deftypefnx Operator {} {>} {= (@B{char} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is greater than @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ge}} {= (@B{char} a, b) @B{bool}}
+@deftypefnx Operator {} {>=} {= (@B{char} a, b) @B{bool}}
+Dyadic operator that yields whether @code{a} is greater than, or equal
+to @code{b}.
+@end deftypefn
+
+@subsection Conversions
+
+@deftypefn Operator {} {@B{ABS}} {= (@B{char} a) @B{int}}
+Monadic operator that yields an unique integer for each permissable
+value of @code{@B{char}}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{REPR}} {= (@B{int} a) @B{char}}
+The opposite of @code{@B{abs}} of a character.
+@end deftypefn
+
+@node String operators
+@section String operators
+
+@subsection Relational
+
+@deftypefn Operator {} {@B{eq}} {= (@B{string} a, b) @B{bool}}
+@deftypefnx Operator {} {=} {= (@B{string} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are equal.  Two
+strings are equal if they contain the same sequence of characters.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ne}} {= (@B{string} a, b) @B{bool}}
+@deftypefnx Operator {} {/=} {= (@B{string} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are not equal.
+@end deftypefn
+
+@deftypefn Operator {} {@B{lt}} {= (@B{string} a, b) @B{bool}}
+@deftypefnx Operator {} {<} {= (@B{string} a, b) @B{bool}}
+Dyadic operator that yields whether the string @code{a} is less than
+the string @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{le}} {= (@B{string} a, b) @B{bool}}
+@deftypefnx Operator {} {<=} {= (@B{string} a, b) @B{bool}}
+Dyadic operator that yields whether the string @code{a} is less than,
+or equal to string @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{gt}} {= (@B{string} a, b) @B{bool}}
+@deftypefnx Operator {} {>} {= (@B{string} a, b) @B{bool}}
+Dyadic operator that yields whether the string @code{a} is greater
+than the string @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ge}} {= (@B{string} a, b) @B{bool}}
+@deftypefnx Operator {} {>=} {= (@B{string} a, b) @B{bool}}
+Dyadic operator that yields whether the string @code{a} is greater
+than, or equal to the string @code{b}.
+@end deftypefn
+
+@subsection Composition
+
+@deftypefn Operator {} {+} {= (@B{string} a, b) @B{string}}
+Dyadic operator that yields the concatenation of the two given
+strings as a new string.
+@end deftypefn
+
+@deftypefn Operator {} {+} {= (@B{string} a, @B{char} b) @B{string}}
+Dyadic operator that yields the concatenation of the given string
+@code{a} and a string whose contents are the character @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {*} (= (@B{int} a, @B{string} b) @B{string})
+@deftypefnx Operator {} {*} (= (@B{string} b, @B{int} a) @B{string})
+Dyadic operator that yields the string @code{a} concatenated @code{a}
+times to itself.  If @code{a} is less than zero then it is interpreted
+to be zero.
+@end deftypefn
+
+@subsection Composition combined with assignation
+
+@deftypefn Operator {} {@B{plusab}} {= (@B{ref} @B{string} a, @B{string} b) @B{ref} @B{string}}
+@deftypefnx Operator {} {+:=} {= (@B{ref} @B{string} a, @B{string} b) @B{ref} @B{string}}
+@dfn{Plus and become}.  Dyadic operator that calculates @code{a + b},
+assigns the result of the operation to the name @code{a} and then
+yields @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{plusto}} {= (@B{string} b, @B{ref} @B{string} a) @B{ref} @B{string}}
+@deftypefnx Operator {} {+=:} {= (@B{string} b, @B{ref} @B{string} b) @B{ref} @B{string}}
+Dyadic operator that calculates @code{a + b}, assigns the result of
+the operation to the name @code{a} and then yields @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{timesab}} {= (@B{ref} @B{string} a, @B{string} b) @B{ref} @B{string}}
+@deftypefnx Operator {} {*:=} {= (@B{ref} @B{string} a, @B{string} b) @B{ref} @B{stringl}}
+@dfn{Plus and become}.  Dyadic operator that calculates @code{a * b},
+assigns the result of the operation to the name @code{a} and then
+yields @code{a}.
+@end deftypefn
+
+@node Complex operators
+@section Complex operators
+
+@node Bits operators
+@section Bits operators
+
+@subsection Logical
+
+@deftypefn Operator {} {@B{NOT}} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}}
+@deftypefnx Operator {} {~} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}}
+Monadic operator that yields the element-wise not logical operation in
+the elements of the given bits operand.
+@end deftypefn
+
+@deftypefn Operator {} {@B{AND}} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}}
+@deftypefnx Operator {} {&} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}}
+Dyadic operator that yields the element-wise and logical operation in
+the elements of the given bits operands.
+@end deftypefn
+
+@deftypefn Operator {} {@B{OR}} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}}
+Dyadic operator that yields the element-wise ``or'' logical operation
+in the elements of the given bits operands.
+@end deftypefn
+
+@subsection Shifting
+
+@deftypefn Operator {} {@B{SHL}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}}
+@deftypefnx Operator {} {@B{UP}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}}
+Dyadic operator that yields the given bits operand shifted @code{n}
+positions to the left.  Extra elements introduced on the right are
+initialized to @code{@B{false}}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{SHR}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}}
+@deftypefnx Operator {} {@B{DOWN}} {= (@B{l} @B{bits} a, @B{int} n) @B{l} @B{bits}}
+Dyadic operator that yields the given bits operand shifted @code{n}
+positions to the right.  Extra elements introduced on the left are
+initialized to @code{@B{false}}.
+@end deftypefn
+
+@subsection Relational
+
+@deftypefn Operator {} {@B{eq}} {= (@B{l} @B{bits} a, b) @B{bool}}
+@deftypefnx Operator {} {=} {= (@B{l} @B{bits} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are equal.  Two
+bits are equal if they contain the same sequence of booleans.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ne}} {= (@B{l} @B{bits} a, b) @B{bool}}
+@deftypefnx Operator {} {/=} {= (@B{l} @B{bits} a, b) @B{bool}}
+Dyadic operator that yields whether its operands are not equal.
+@end deftypefn
+
+@deftypefn Operator {} {@B{lt}} {= (@B{l} @B{bits} a, b) @B{bool}}
+@deftypefnx Operator {} {<} {= (@B{l} @B{bits} a, b) @B{bool}}
+Dyadic operator that yields whether the bits @code{a} is less than
+the bits @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{le}} {= (@B{l} @B{bits} a, b) @B{bool}}
+@deftypefnx Operator {} {<=} {= (@B{l} @B{bits} a, b) @B{bool}}
+Dyadic operator that yields whether the bits @code{a} is less than,
+or equal to bits @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{gt}} {= (@B{l} @B{bits} a, b) @B{bool}}
+@deftypefnx Operator {} {>} {= (@B{l} @B{bits} a, b) @B{bool}}
+Dyadic operator that yields whether the bits @code{a} is greater than
+the bits @code{b}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{ge}} {= (@B{l} @B{bits} a, b) @B{bool}}
+@deftypefnx Operator {} {>=} {= (@B{l} @B{bits} a, b) @B{bool}}
+Dyadic operator that yields whether the bits @code{a} is greater
+than, or equal to the bits @code{b}.
+@end deftypefn
+
+@subsection Conversions
+
+@deftypefn Operator {} {@B{abs}} {= (@B{l} @B{bits} a) @B{l} @B{int}}
+Monadic operator that yields the integral value whose constituent bits
+correspond to the booleans stored in @code{a}. @xref{@code{@B{bin}}
+and @code{@B{abs}} of negative integral values}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{bin}} {= (@B{l} @B{int} a) @B{l} @B{bits}}
+Monadic operator that yields the bits value whose boolean elements map
+the bits in the given integral operand. @xref{@code{@B{bin}} and
+@code{@B{abs}} of negative integral values}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{shorten}} {= (@B{long} @B{bits} a) @B{bits}}
+@deftypefnx Operator {} {@B{shorten}} {= (@B{long} @B{long} @B{bits} a) @B{long} @B{bits}}
+Monadic operator that yields the bits value that can be lengthened to
+the value of @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{leng}} {= (@B{bits} a) @B{long} @B{bits}}
+@deftypefnx Operator {} {@B{leng}} {= (@B{long} @B{bits} a) @B{long} @B{long} @B{bits}}
+Monadic operator that yields the bits value lengthened from the value
+of @code{a}.  The lengthened value features @code{@B{false}} in the
+extra left positions added to match the lengthened size.
+@end deftypefn
+
+@node Bytes operators
+@section Bytes operators
+
+@node Semaphore operators
+@section Semaphore operators
+
+@node Math procedures
+@section Math procedures
+
+@subsection Arithmetic
+
+@deftypefn Procedure {} {@B{sqrt}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Procedure that yields the square root of the given real argument.
+@end deftypefn
+
+@subsection Logarithms
+
+@deftypefn Procedure {} {@B{ln}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Procedure that yields the base @code{e} logarithm of the given real
+argument.
+@end deftypefn
+
+@deftypefn Procedure {} {@B{exp}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Procedure that yields the exponential function of the given real
+argument.  This is the inverse of @code{@B{ln}}.
+@end deftypefn
+
+@subsection Trigonometric
+
+@deftypefn Procedure {} {@B{sin}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Procedure that yields the sin trigonometric function of the given real
+argument.
+@end deftypefn
+
+@deftypefn Procedure {} {@B{arcsin}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Procedure that yields the arc-sin trigonometric function of the given real
+argument.
+@end deftypefn
+
+@deftypefn Procedure {} {@B{cos}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Procedure that yields the cos trigonometric function of the given real
+argument.
+@end deftypefn
+
+@deftypefn Procedure {} {@B{arccos}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Procedure that yields the arc-cos trigonometric function of the given real
+argument.
+@end deftypefn
+
+@deftypefn Procedure {} {@B{tan}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Procedure that yields the tan trigonometric function of the given real
+argument.
+@end deftypefn
+
+@deftypefn Procedure {} {@B{arctan}} {= (@B{l} @B{real} a) @B{l} @B{real}}
+Procedure that yields the arc-tan trigonometric function of the given
+real argument.
+@end deftypefn
+
+@node Extended prelude
+@chapter Extended prelude
+@cindex prelude, extended
+
+This chapter documents the GNU extensions to the standard prelude.
+The facilities documented below are available to Algol 68 programs
+only if the @option{gnu68} language dialect is selected, which is the
+default.
+
+The extended prelude is available to Algol 68 programs without needing
+to import any module, provided they are compiled as @code{gnu68} code,
+which is the default.
+
+@menu
+* Extended priorities::                Priorities of extended operators.
+* Extended environment enquiries::     Information about the implementation.
+* Extended rows operators::            Rows and associated operations.
+* Extended boolean operators::         Operations on boolean operands.
+* Extended bits operators::            Bits and associated operations.
+* Extended math procedures::           Mathematical constants and functions.
+@end menu
+
+@node Extended priorities
+@section Extended priorities
+
+@table @code
+@item 3
+@itemize @bullet
+@item @code{@B{xor}}
+@end itemize
+
+@item 8
+@itemize @bullet
+@item @code{@B{elems}}
+@end itemize
+@end table
+
+@node Extended environment enquiries
+@section Extended environment enquiries
+
+An @dfn{environment enquiry} is a constant, whose value may be useful
+to the programmer, that reflects some characteristic of the particular
+implementation.  The values of these enquiries are also determined by
+the architecture and operating system targeted by the compiler.
+
+@deftypevr Constant {@B{l} @B{int}} {L min int}
+The most negative integral value.
+@end deftypevr
+
+@deftypevr Constant {@B{l} @B{real}} {L min real}
+The most negative real value.
+@end deftypevr
+
+@deftypevr Constant {@B{l} @B{real}} {L infinity}
+Positive infinity expressed in a real value.
+@end deftypevr
+
+@deftypevr Constant {@B{l} @B{real}} {L minus infinity}
+Negative infinity expressed in a real value.
+@end deftypevr
+
+@deftypevr Constant @B{char} {invalid char}
+A character that is unknown or unrepresentable in Unicode.
+@end deftypevr
+
+@node Extended rows operators
+@section Extended rows operators
+
+The following operators work on any row mode, denoted below using the
+pseudo-mode @code{@B{rows}}.
+
+@deftypefn Operator {} {@B{elems}} {= (@B{rows} a) @B{int}}
+Monadic operator that yields the number of elements implied by the
+first bound pair of the descriptor of the value of @code{a}.
+@end deftypefn
+
+@deftypefn Operator {} {@B{elems}} {= (@B{int} n, @B{rows} a) @B{int}}
+Dyadic operator that yields the number of elements implied by the n-th
+bound pair of the descriptor of the value of @code{a}.
+@end deftypefn
+
+@node Extended boolean operators
+@section Extended boolean operators
+
+@deftypefn Operator {} {@B{xor}} {= (@B{bool} a, b) @B{bool}}
+Dyadic operator that yields the exclusive-or operation of the given
+boolean arguments.
+@end deftypefn
+
+@node Extended bits operators
+@section Extended bits operators
+
+@deftypefn Operator {} {@B{xor}} {= (@B{l} @B{bits} a, b) @B{l} @B{bits}}
+Dyadic operator that yields the bit exclusive-or operation of the
+given bits arguments.
+@end deftypefn
+
+@node Extended math procedures
+@section Extended math procedures
+
+@subsection Logarithms
+
+@deftypefn Procedure {} {@B{log}} {= (@B{l} @B{real} a, b) @B{l} @B{real}}
+Procedure that calculates the base ten logarithm of the given arguments.
+@end deftypefn
+
+@node POSIX prelude
+@chapter POSIX prelude
+
+The POSIX prelude provides facilities to perform simple transput (I/O)
+based on POSIX file descriptors, accessing the file system,
+command-line arguments, environment variables, etc.
+
+This prelude is available to Algol 68 programs without needing to
+import any module, provided they are compiled as @code{gnu68} code,
+which is the default.
+
+@menu
+* POSIX process::           Process exit status.
+* POSIX command line::      Parsing command-line arguments.
+* POSIX environment::       Environment variables.
+* POSIX errors::            Error handling and error descriptions.
+* POSIX files::             Creating, opening and closing files.
+* POSIX sockets::           Communication endpoints.
+* POSIX string transput::   Reading and writing characters and strings.
+@end menu
+
+@node POSIX process
+@section POSIX process
+
+The Algol 68 program can report an exit status to the operating system
+once they stop running.  The exit status reported by default is zero,
+which corresponds to success.
+
+@deftypefn Procedure {} {set exit status} {= (@B{int} status)}
+Procedure that sets the exit status to report to the operating system
+once the program stop executing.  The default exit status is 0 which,
+by convention, is interpreted by POSIX systems as success.  A value
+different to zero is interpreted as an error status.  This procedure
+can be invoked more than one, the previous exit status being
+overwritten.
+@end deftypefn
+
+@node POSIX command line
+@section POSIX command line
+
+Algol 68 programs can access the command-line arguments passed to them
+by using the following procedures.
+
+@deftypefn Procedure {} {argc} {= @B{int}}
+Procedure that yields the number of arguments passed in the command
+line, including the name of the program.
+@end deftypefn
+
+@deftypefn Procedure {} {argv} {= (@B{int} n) @B{string}}
+Procedure that yields the @code{n}th argument passed in the command
+line.  The first argument is always the name used to invoke the
+program.  If @code{n} is out of range then this procedure returns the
+empty string.
+@end deftypefn
+
+@node POSIX environment
+@section POSIX environment
+
+@deftypefn Procedure {} {getenv} {= (@B{string} varname) @B{string}}
+Procedure that yields the value of the environment variable
+@code{varname} as a string.  If the specified environmental variable
+is not defined the this procedure returns an empty string.
+@end deftypefn
+
+@node POSIX errors
+@section POSIX errors
+
+When a call to a procedure in this prelude results in an error, the
+called procedure signals the error in some particular way and also
+sets a global @code{errno} to a code describing the error.  For
+example, trying to opening a file that doesn't exist will result in
+@code{fopen} returning -1, which signals an error.  The caller can
+then inspect the global @code{errno} to see what particular error
+prevented the operation to be completed: in this case, @code{errno}
+will contain the error code corresponding to ``file doesn't exist''.
+
+@deftypefn Procedure {} {errno} {= @B{int}}
+This procedure yields the current value of the global @code{errno}.
+The yielded value reflects the error status of the last executed POSIX
+prelude operation.
+@end deftypefn
+
+@deftypefn Procedure {} {strerror} {= (@B{int} ecode) @B{string}}
+This procedure gets an error code and yields a string containing an
+explanatory short description of the error.  It is typical to pass the
+output of @code{errno} to this procedure.
+@end deftypefn
+
+@deftypefn Procedure {} {perror} {= (@B{string} msg) @B{void}}
+This procedure prints the given string @code{msg} in the standard
+error output, followed by a colon character, a space character and
+finally the string error of the current value of @code{errno}.
+@end deftypefn
+
+@node POSIX files
+@section POSIX files
+
+File descriptors are @code{@B{int}} values that identify open files
+that can be accessed by the program.  The @code{fopen} procedure
+allocates file descriptors as it opens files, and the descriptor is
+used in subsequent transput calls to perform operations on the files.
+
+@subsection Standard file descriptors
+
+There are three descriptors, however, which are automatically opened
+when the program starts executing and automatically closed when the
+program finishes.  These are:
+
+@deftypevr Constant {@B{int}} {stdin}
+File descriptor associated with the standard input.  Its value is @code{0}.
+@end deftypevr
+
+@deftypevr Constant {@B{int}} {stdout}
+File descriptor associated with the standard output.  Its value is @code{1}.
+@end deftypevr
+
+@deftypevr Constant {@B{int}} {stderr}
+File descriptor associated with the standard error.  Its value is @code{2}.
+@end deftypevr
+
+@subsection Opening and closing files
+
+@deftypefn Procedure {} {fopen} {= (@B{string} pathname, @B{bits} flags) @B{int}}
+Open the file specified by @code{pathname}.  The argument @code{flags}
+is a combination of @code{file o} flags as defined below.  If the
+specified file is successfully opened while satisfying the constraints
+implied by @code{flags} then this procedure yields a file descriptor
+that is used in subsequent I/O calls to refer to the open
+file. Otherwise, this procedure yields -1.  The particular error can
+be inspected by calling the @code{errno} procedure.
+@end deftypefn
+
+@deftypefn Procedure {} {fclose} {= (@B{int} fd) @B{int}}
+Close the given file descriptor, which no longer refers to any file.
+This procedure yields zero on success, and -1 on error.  In the later
+case, the program can look at the particular error by calling the
+@code{errno} procedure.
+@end deftypefn
+
+@subsection Creating files
+
+@deftypefn Procedure {} {fcreate} {= (@B{string} pathname, @B{bits} mode) @B{int}}
+Create a file with name @code{pathname}.  The argument @code{mode} is
+a @code{@B{bits}} value containing a bit pattern that determines the
+permissions on the created file.  The bit pattern has the form
+@code{8rUGO}, where @code{U} reflects the permissions of the user who
+owns the file, @code{U} reflects the permissions of the users
+pertaining to the file's group, and @code{O} reflects the permissions
+of all other users.  The permission bits are 1 for execute, 2 for
+write and 4 for read.  If the file is successfully created then this
+procedure yields a file descriptor that is used in subsequent I/O
+calls to refer to the newly created file.  Otherwise, this procedure
+yields -1.  The particular error can be inspected by calling the
+@code{errno} procedure.
+@end deftypefn
+
+@subsection Flags for @code{fopen}
+
+The following flags can be combined using bit-wise operators.  Note
+that in POSIX systems the effective mode of the created file is the
+mode specified by the programmer masked with the process's
+@dfn{umask}.
+
+@deftypevr Constant {@B{bits}} {file o default}
+Flag for @code{fopen} indicating that the file shall be opened with
+whatever capabilities allowed by its permissions.
+@end deftypevr
+
+@deftypevr Constant {@B{bits}} {file o rdwr}
+Flag for @code{fopen} indicating that the file shall be opened for
+both reading and writing.
+@end deftypevr
+
+@deftypevr Constant {@B{bits}} {file o rdonly}
+Flag for @code{fopen} indicating that the file shall be opened for
+reading only.  This flag is not compatible with @code{file o rdwr} nor
+with @code{file o wronly}.
+@end deftypevr
+
+@deftypevr Constant {@B{bits}} {file o wronly}
+Flag for @code{fopen} indicating that the file shall be opened for
+write only.  This flag is not compatible with @code{file o rdwr} nor
+with @code{file o rdonly}.
+@end deftypevr
+
+@deftypevr Constant {@B{bits}} {file o trunc}
+Flag for @code{fopen} indicating that the opened file shall be
+truncated upon opening it.  The file must allow writing for this flag
+to take effect.  The effect of combining @code{file o trunc} and
+@code{file o rdonly} is undefined and varies among implementations.
+@end deftypevr
+
+@subsection Getting file properties
+
+@deftypefn Procedure {} {fsize} {= (@B{int} fd) @B{long} @B{long} @B{int}}
+Return the size in bytes of the file characterized by the file
+descriptor @code{fd}.  If the system entity characterized by the given
+file descriptor doesn't have a size, if the size of the file cannot be
+stored in a @code{@B{long} @B{long} @B{int}}, or if there is any other
+error condition, this procedure yields -1 and @code{errno} is set
+appropriately.
+@end deftypefn
+
+@node POSIX sockets
+@section POSIX sockets
+
+A program can communicate with other computers, or with other
+processes running in the same computer, via sockets.  The sockets are
+identified by file descriptors.
+
+@deftypefn Procedure {} {fconnect} {= (@B{string} host, @B{int} port) @B{int}}
+This procedure creates a stream socket and connects it to the given
+@code{host} using port @code{port}.  The established communication is
+full-duplex, and allows sending and receiving data using transput
+until it gets closed.  On success this procedure yields a file
+descriptor.  On error this procedure yields -1 and @code{errno} is set
+appropriately.
+@end deftypefn
+
+@node POSIX string transput
+@section POSIX string transput
+
+The following procedures read or write characters and strings from and
+to open files.  The external encoding of the files is assumed to be
+UTF-8.  Since Algol 68 @code{@B{char}}s are USC-4, this means that
+reading or writing a character may involve reading or writing more
+than one byte, depending on the particular Unicode code points
+involved.
+
+@subsection Output of strings and chars
+
+@deftypefn Procedure {} {putchar} {= (@B{char} c) @B{char}}
+Write the given character to the standard output.  This procedure
+yields @code{c} in case the character got successfully written, or
+@code{invalid char} otherwise.
+@end deftypefn
+
+@deftypefn Procedure {} {puts} {= (@B{string} str) @B{void}}
+Write the given string to the standard output.
+@end deftypefn
+
+@deftypefn Procedure {} {fputc} {= (@B{int} fd, @B{char} c) @B{int}}
+Write given character @code{c} to the file with descriptor @code{fd}.
+This procedure yields @code{c} on success, or @code{invalid char}
+on error.
+@end deftypefn
+
+@deftypefn Procedure {} {fputs} {= (@B{int} fd, @B{string} str) @B{int}}
+Write the given string @code{str} to the file with descriptor
+@code{fd}.  This procedure yields the number of bytes written on
+success, or 0 on error.
+@end deftypefn
+
+@subsection Input of strings and chars
+
+@deftypefn Procedure {} {getchar} {= @B{char}}
+Read a character from the standard input.  This procedure yields the
+read character in case the character got successfully read, or
+@code{invalid char} otherwise.
+@end deftypefn
+
+@deftypefn Procedure {} {gets} {= (@B{int} n) @B{ref} @B{string}}
+Read a string composed of @code{n} characters from the standard input
+and yield a reference to it.  If @code{n} is bigger than zero then
+characters get read until either @code{n} characters have been read or
+the end of line is reached.  If @code{n} is zero or negative then
+characters get read until either a new line character is read or the
+end of line is reached.
+@end deftypefn
+
+@deftypefn Procedure {} {fgetc} {= (@B{int} fd) @B{int}}
+Read a character from the file with descriptor @code{fd}.  This
+procedure yields the read character in case the character got
+successfully read, or @code{invalid char} otherwise.
+@end deftypefn
+
+@deftypefn Procedure {} {fgets} {= (@B{int} fd, @B{int} n) @B{ref} @B{string}}
+Read a string from the file with descriptor @code{fd} and yield a
+reference to it.  If @code{n} is bigger than zero then characters get
+read until either @code{n} characters have been read or the end of
+line is reached.  If @code{n} is zero or negative then characters get
+read until either a new line character is read or the end of line is
+reached.
+@end deftypefn
+
+@node Language extensions
+@chapter Language extensions
+
+This chapter documents the GNU extensions implemented by this compiler
+on top of the Algol 68 programming language.  These extensions
+collectively conform a strict @dfn{superlanguage} of Algol 68, and are
+enabled by default.  To disable them the user can select the strict
+Algol 68 standard by passing the option @option{-std=algol68} when
+invoking the compiler.
+
+@menu
+* @code{@B{bin}} and @code{@B{abs}} of negative integral values::
+* Bold taggles::              Using underscores in mode and operator indications.
+@end menu
+
+@node @code{@B{bin}} and @code{@B{abs}} of negative integral values
+@section @code{@B{bin}} and @code{@B{abs}} of negative integral values
+
+The @code{@B{bin}} operator gets an integral value and yields a
+@code{@B{bits}} value that reflects the internal bits of the integral
+value.  The semantics of this operator, as defined in the Algol 68
+standard prelude, are:
+
+@example
+@B{op} @B{bin} = (L @B{int} a) L @B{bits}:
+  @B{if} a >= L 0
+  @B{then} L @B{int} b := a; L @B{bits};
+       @B{for} i @B{from} L bits width @B{by} -1 @B{to} 1
+       @B{do} (L F @B{of} c)[i] := @B{odd} b; b := b % L 2 @B{od};
+       c
+  @B{fi};
+@end example
+
+The @code{@B{abs}} operator performs the inverse operation of
+@code{@B{bits}}.  Given a @code{L @B{bits}} value, it yields the
+@code{L @B{int}} value whose bits representation is the bits value.
+The semantics of this operator, as defined in the Algol 68 prelude,
+are:
+
+@example
+@B{op} @B{abs} = (L @B{bits} a) L @B{int}:
+@B{begin} L @B{int} c := L 0;
+      @B{for} i @B{to} L bits width
+      @B{do} c := L 2 * c + K @B{abs} (L F @B{of} a)[i] @B{od};
+      c
+@B{end}
+@end example
+
+@noindent
+Note how the @code{@B{bin}} of a negative integral value is not
+defined: the implicit else-part of the conditional yields
+@code{@B{skip}}, which is defined as any bits value in that context.
+Note also how @code{@B{abs}} doesn't make any provision to check
+whether the resulting value is positive: it assumes it is so.
+
+The GNU Algol 68 compiler, when working in strict Algol 68 mode
+(@option{-std=algol68}), makes @code{@B{bin}} to always yield @code{L
+@B{bits} (@B{skip})} when given a negative value, as mandated by the
+report.  But the skip value is always the bits representation of zero,
+@i{i.e.} 2r0.  Strict Algol 68 programs, however, must not rely on
+this.
+
+When GNU extensions are enabled (@option{-std=gnu68}) the
+@code{@B{bin}} of a negative value yields the two's complement bit
+pattern of the value rather than zero.  Therefore, @code{@B{bin} -
+@B{short} @B{short} 2} yields @code{2r11111110}.  And @code{@B{abs}
+@B{short} @B{short} 2r11111110} yields -2.
+
+@node Bold taggles
+@section Bold taggles
+
+This compiler supports the stropping regimes known as UPPER and
+SUPPER.  In both regimes bold words are written by writing their
+constituent bold letters and digits, in order.  In UPPER regime all
+the letters of a bold word are to be written using upper-case.  In
+SUPPER regime, only the first bold letter is required to be written
+using upper-case, and this only when the bold word is not a reserved
+word.
+
+When a bold word comprises several natural words, it may be a little
+difficult to distinguish them at first sight.  Consider for example
+the following code, written fist in UPPER stropping:
+
+@example
+MODE TREENODE = STRUCT (TREENODEPAYLOAD data, REF TREENODE next),
+     TREENODEPAYLOAD = STRUCT (INT code, REAL average, mean);
+@end example
+
+@noindent
+Then written in SUPPER stropping:
+
+@example
+mode TreeNode = struct (TreeNodePayload data, REF TreeNode next),
+     TreeNodePayload = struct (int code, real average, mean);
+@end example
+
+Particularly in UPPER stropping, it may be difficult to distinguish
+the constituent natural words at first sight.
+
+In order to improve this, this compiler implements a GNU extension
+called @dfn{bold taggles} that allows to use underscore characters
+(@code{_}) within mode and operator indications as a visual aid to
+improve readability.  When this extension is enabled, mode indications
+and operator indications consist in a sequence of the so-called
+@dfn{bold taggles}, which are themselves sequences of one or more bold
+letters or digits optionally terminated by an underscore character.
+
+With bold taggles enabled the program above could have been written
+using UPPER stropping as:
+
+@example
+MODE TREE_NODE = STRUCT (TREE_NODE_PAYLOAD data, REF TREE_NODE next),
+     TREE_NODE_PAYLOAD = STRUCT (INT code, REAL average, mean);
+@end example
+
+@noindent
+And using SUPPER stropping as:
+
+@example
+mode Tree_Node = struct (Tree_Node_Payload data, ref Tree_Node next),
+     Tree_Node_Payload = struct (int code, real average, mean);
+@end example
+
+@noindent
+Which is perhaps more readable for most people.  Note that the
+underscore characters are not really part of the mode or operator
+indication.  Both @code{TREE_NODE} and @code{TREENODE} denote the same
+mode indication.  Note also that, following the definition, constructs
+like @code{Foo__bar} and @code{_Baz} are not valid indications.
+
+Bold taggles are available when the gnu68 dialect of the language is
+selected.  @xref{Dialect options}.
+
+@include gpl_v3.texi
+@include fdl.texi
+
+@node Option Index
+@unnumbered Option Index
+
+@command{ga68}'s command line options are indexed here without any initial
+@samp{-} or @samp{--}.  Where an option has both positive and negative forms
+(such as @option{-f@var{option}} and @option{-fno-@var{option}}), relevant
+entries in the manual are indexed under the most appropriate form; it may
+sometimes be useful to look up both forms.
+
+@printindex op
+
+@node General Index
+@unnumbered Index
+
+@printindex cp
+
+@bye
diff --git a/gcc/doc/tm.texi b/gcc/doc/tm.texi
index fd208f53844..52eb7851001 100644
--- a/gcc/doc/tm.texi
+++ b/gcc/doc/tm.texi
@@ -57,6 +57,7 @@ through the macros defined in the @file{.h} file.
 * D Language and ABI::  Controlling D ABI changes.
 * Rust Language and ABI:: Controlling Rust ABI changes.
 * JIT Language and ABI:: JIT ABI parameters
+* ALGOL 68 Language and ABI:: Controlling ALGOL 68 ABI changes.
 * Named Address Spaces:: Adding support for named address spaces
 * Misc::                Everything else.
 @end menu
@@ -11416,6 +11417,23 @@ keys added by this hook are made available at compile time by calling
 get_target_info.
 @end deftypefn
 
+@node ALGOL 68 Language and ABI
+@section ALGOL 68 ABI parameters
+@cindex parameters, ALGOL 68 abi
+
+@deftypefn {Algol68 Target Hook} void TARGET_ALGOL68_CPU_INFO (void)
+Declare all environmental CPU info and features relating to the target CPU
+using the function @code{algol68_add_target_info}, which takes a string
+representing the feature key and a string representing the feature value.
+Configuration pairs predefined by this hook apply to all files that are being
+compiled.
+@end deftypefn
+
+@deftypefn {Algol68 Target Hook} void TARGET_ALGOL68_OS_INFO (void)
+Similar to @code{TARGET_ALGOL68_CPU_INFO}, but is used for configuration info
+relating to the target operating system.
+@end deftypefn
+
 @node Named Address Spaces
 @section Adding support for named address spaces
 @cindex named address spaces
diff --git a/gcc/doc/tm.texi.in b/gcc/doc/tm.texi.in
index 14315dd5080..de505a8550c 100644
--- a/gcc/doc/tm.texi.in
+++ b/gcc/doc/tm.texi.in
@@ -57,6 +57,7 @@ through the macros defined in the @file{.h} file.
 * D Language and ABI::  Controlling D ABI changes.
 * Rust Language and ABI:: Controlling Rust ABI changes.
 * JIT Language and ABI:: JIT ABI parameters
+* ALGOL 68 Language and ABI:: Controlling ALGOL 68 ABI changes.
 * Named Address Spaces:: Adding support for named address spaces
 * Misc::                Everything else.
 @end menu
@@ -7317,6 +7318,14 @@ floating-point support; they are not included in this mechanism.
 
 @hook TARGET_JIT_REGISTER_CPU_TARGET_INFO
 
+@node ALGOL 68 Language and ABI
+@section ALGOL 68 ABI parameters
+@cindex parameters, ALGOL 68 abi
+
+@hook TARGET_ALGOL68_CPU_INFO
+
+@hook TARGET_ALGOL68_OS_INFO
+
 @node Named Address Spaces
 @section Adding support for named address spaces
 @cindex named address spaces
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 05/47] a68: command-line options
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (3 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 04/47] a68: documentation Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 06/47] a68: DWARF language codes Jose E. Marchesi
                   ` (42 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds a new common command-line option to the compiler
driver (-static-libga68) as well as several other front-end specific
options.

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

gcc/ChangeLog

	* algol68/lang.opt: New file.
	* algol68/lang.opt.urls: Generate.
	* common.opt: New option -static-libga68.
	* common.opt.urls: Generate.
	* gcc.cc: Handle OPT_static_libga68.
	* regenerate-opt-urls.py (PER_LANGUAGE_OPTION_INDEXES): Add Algol68.
---
 gcc/algol68/lang.opt       | 102 +++++++++++++++++++++++++++++++++++++
 gcc/algol68/lang.opt.urls  |  41 +++++++++++++++
 gcc/common.opt             |   3 ++
 gcc/common.opt.urls        |   3 ++
 gcc/gcc.cc                 |   2 +
 gcc/regenerate-opt-urls.py |   3 +-
 6 files changed, 153 insertions(+), 1 deletion(-)
 create mode 100644 gcc/algol68/lang.opt
 create mode 100644 gcc/algol68/lang.opt.urls

diff --git a/gcc/algol68/lang.opt b/gcc/algol68/lang.opt
new file mode 100644
index 00000000000..cb13724ffb5
--- /dev/null
+++ b/gcc/algol68/lang.opt
@@ -0,0 +1,102 @@
+; Options for the Algol 68 front end.
+; Copyright (C) 2025 Free Software Foundation, Inc.
+;
+; 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/>.
+
+; See the GCC internals manual for a description of this file's format.
+
+; Please try to keep this file in ASCII collating order.
+
+; Describes command-line options used by this frontend
+
+Language
+Algol68
+
+I
+Algol68 Joined Separate
+; Documented in c-family/c.opt
+
+Wextensions
+Algol68 Warning Var(warn_algol68_extensions) LangEnabledBy(Algol68, Wextra)
+Warn for usage of non-portable extensions of Algol 68.
+
+Wvoiding
+Algol68 Warning Var(warn_algol68_voiding) LangEnabledBy(Algol68, Wextra)
+Warn when voiding occurs.
+
+Wextra
+Algol68 Warning
+; Documented in common.opt
+
+Wscope
+Algol68 Warning Var(warn_algol68_scope)
+Warn for potential name scope violations.
+
+Whidden-declarations
+Algol68 Warning Var(warn_algol68_hidden_declarations)
+Warn for hidden declarations in inner scopes.
+
+fbrackets
+Algol68 Var(flag_brackets)
+-fbrackets  	Consider [ .. ] and { .. } as being equivalent to ( .. ).
+
+fassert
+Algol68 Var(flag_assert)
+Generate code for assert contracts.
+
+fcheck=
+Algol68 RejectNegative JoinedOrMissing
+-fcheck=[...]	Specify which runtime checks are to be performed.
+
+fa68-dump-modes
+Algol68 Var(flag_a68_dump_modes)
+Dump Algol 68 modes after parsing.
+
+fa68-dump-ast
+Algol68 Var(flag_a68_dump_ast)
+Dump Algol 68 parse tree after parsing.
+
+static-libga68
+Driver
+Link the GNU Algol run-time library statically in the compilation.
+
+shared-libga68
+Driver
+Link the GNU Algol 68 run-time library dynamically in the compilation.
+
+std=algol68
+Algol68
+Compile strict Algol 68 as defined by the Revised Report
+
+std=gnu68
+Algol68
+Accept GNU extensions to Algol 68
+
+; Stropping regimes.
+
+fstropping=
+Algol68 Joined RejectNegative Enum(stropping_regime) Var(flag_stropping_regime)
+-fstropping=[upper|supper]              Stropping regime to expect in Algol 68 programs.
+
+Enum
+Name(stropping_regime) Type(int) UnknownError(unknown stropping_regime setting %qs)
+
+EnumValue
+Enum(stropping_regime) String(upper) Value(0)
+
+EnumValue
+Enum(stropping_regime) String(supper) Value(1)
+
+; This comment is to ensure we retain the blank line above.
diff --git a/gcc/algol68/lang.opt.urls b/gcc/algol68/lang.opt.urls
new file mode 100644
index 00000000000..df303b98f6a
--- /dev/null
+++ b/gcc/algol68/lang.opt.urls
@@ -0,0 +1,41 @@
+; Autogenerated by regenerate-opt-urls.py from gcc/algol68/lang.opt and generated HTML
+
+I
+UrlSuffix(gcc/Directory-Options.html#index-I) LangUrlSuffix_D(gdc/Directory-Options.html#index-I) LangUrlSuffix_Algol68(ga68/Directory-options.html#index-I)
+
+Wextensions
+LangUrlSuffix_Algol68(ga68/Warnings-options.html#index-Wextensions)
+
+Wvoiding
+LangUrlSuffix_Algol68(ga68/Warnings-options.html#index-Wno-voiding)
+
+Wextra
+UrlSuffix(gcc/Warning-Options.html#index-Wextra) LangUrlSuffix_D(gdc/Warnings.html#index-Wextra) LangUrlSuffix_Fortran(gfortran/Error-and-Warning-Options.html#index-Wextra)
+
+Wscope
+LangUrlSuffix_Algol68(ga68/Warnings-options.html#index-Wno-scope)
+
+Whidden-declarations
+LangUrlSuffix_Algol68(ga68/Warnings-options.html#index-Whidden-declarations)
+
+fbrackets
+LangUrlSuffix_Algol68(ga68/Dialect-options.html#index-fbrackets)
+
+fassert
+LangUrlSuffix_D(gdc/Runtime-Options.html#index-fassert) LangUrlSuffix_Algol68(ga68/Runtime-options.html#index-fassert)
+
+fcheck=
+LangUrlSuffix_Fortran(gfortran/Code-Gen-Options.html#index-fcheck) LangUrlSuffix_Algol68(ga68/Runtime-options.html#index-fcheck)
+
+fa68-dump-modes
+LangUrlSuffix_Algol68(ga68/Developer-options.html#index-fa68-dump-modes)
+
+fa68-dump-ast
+LangUrlSuffix_Algol68(ga68/Developer-options.html#index-fa68-dump-ast)
+
+static-libga68
+LangUrlSuffix_Algol68(ga68/Linking-options.html#index-static-libga68)
+
+shared-libga68
+LangUrlSuffix_Algol68(ga68/Linking-options.html#index-shared-libga68)
+
diff --git a/gcc/common.opt b/gcc/common.opt
index 9b8fbf6a684..c7440ba4623 100644
--- a/gcc/common.opt
+++ b/gcc/common.opt
@@ -3968,6 +3968,9 @@ Driver Joined
 static
 Driver
 
+static-libga68
+Driver
+
 static-libgcc
 Driver
 
diff --git a/gcc/common.opt.urls b/gcc/common.opt.urls
index ab6b4316df9..4619aac2855 100644
--- a/gcc/common.opt.urls
+++ b/gcc/common.opt.urls
@@ -1931,6 +1931,9 @@ UrlSuffix(gcc/Overall-Options.html#index-specs)
 ;   duplicate: 'gcc/Darwin-Options.html#index-static-1'
 ;   duplicate: 'gcc/Link-Options.html#index-static'
 
+static-libga68
+LangUrlSuffix_Algol68(ga68/Linking-options.html#index-static-libga68)
+
 static-libgcc
 UrlSuffix(gcc/Link-Options.html#index-static-libgcc)
 
diff --git a/gcc/gcc.cc b/gcc/gcc.cc
index eae7f07d962..540958de797 100644
--- a/gcc/gcc.cc
+++ b/gcc/gcc.cc
@@ -4645,11 +4645,13 @@ driver_handle_option (struct gcc_options *opts,
     case OPT_static_libgfortran:
     case OPT_static_libquadmath:
     case OPT_static_libphobos:
+    case OPT_static_libga68:
     case OPT_static_libgm2:
     case OPT_static_libstdc__:
       /* These are always valid; gcc.cc itself understands the first two
 	 gfortranspec.cc understands -static-libgfortran,
 	 libgfortran.spec handles -static-libquadmath,
+	 a68spec.cc understands -static-libga68,
 	 d-spec.cc understands -static-libphobos,
 	 gm2spec.cc understands -static-libgm2,
 	 and g++spec.cc understands -static-libstdc++.  */
diff --git a/gcc/regenerate-opt-urls.py b/gcc/regenerate-opt-urls.py
index 2daa1d603f0..bda91905ace 100755
--- a/gcc/regenerate-opt-urls.py
+++ b/gcc/regenerate-opt-urls.py
@@ -361,7 +361,8 @@ def write_url_file(index, optfile, dstfile):
 PER_LANGUAGE_OPTION_INDEXES = [
     ('gcc/Option-Index.html', None),
     ('gdc/Option-Index.html', 'D'),
-    ('gfortran/Option-Index.html', 'Fortran')
+    ('gfortran/Option-Index.html', 'Fortran'),
+    ('ga68/Option-Index.html', 'Algol68'),
 ]
 
 def main(args):
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 06/47] a68: DWARF language codes
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (4 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 05/47] a68: command-line options Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 07/47] a68: darwin specific support Jose E. Marchesi
                   ` (41 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit makes GCC aware of the DWARF numbers recently allocated
for Algol 68.

For DWARF 5, DW_LANG_Algol68 = 0x44.
For DWARF 6, DW_LNAME_Algol68 = 0x2e
    with versioning schema YYYY, starting with 1973 for the original
    Revised language. The language extensions we are working on will
    be encoded in subsequent versions, 2025 etc.

See https://dwarfstd.org/issues/250304.1.html for more information.

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

gcc/ChangeLog

	* dwarf2out.cc: Set DW_LANG_Algol68 an DW_LNAME_Algol68.

include/ChangeLog

	* dwarf2.h (DW_LANG_Algol68): Define.
	(DW_LNAME_Algol68): Likewise.
---
 gcc/dwarf2out.cc | 8 ++++++++
 include/dwarf2.h | 2 ++
 2 files changed, 10 insertions(+)

diff --git a/gcc/dwarf2out.cc b/gcc/dwarf2out.cc
index a817c69c95a..563f049e795 100644
--- a/gcc/dwarf2out.cc
+++ b/gcc/dwarf2out.cc
@@ -25799,6 +25799,14 @@ gen_compile_unit_die (const char *filename)
 	  else if (strcmp (language_string, "GNU Rust") == 0)
 	    language = DW_LANG_Rust;
 	}
+      else if (!dwarf_strict)
+        {
+          if (strcmp (language_string, "GNU Algol 68") == 0)
+	    {
+	      language = DW_LANG_Algol68;
+	      lname = DW_LNAME_Algol68;
+	    }
+        }
     }
   /* Use a degraded Fortran setting in strict DWARF2 so is_fortran works.  */
   else if (startswith (language_string, "GNU Fortran"))
diff --git a/include/dwarf2.h b/include/dwarf2.h
index 344447fbc36..638e131437e 100644
--- a/include/dwarf2.h
+++ b/include/dwarf2.h
@@ -409,6 +409,7 @@ enum dwarf_source_language
     DW_LANG_Ruby = 0x0040,
     DW_LANG_Move = 0x0041,
     DW_LANG_Hylo = 0x0042,
+    DW_LANG_Algol68 = 0x0044,
 
     DW_LANG_lo_user = 0x8000,	/* Implementation-defined range start.  */
     DW_LANG_hi_user = 0xffff,	/* Implementation-defined range end.  */
@@ -476,6 +477,7 @@ enum dwarf_source_language_name
     DW_LNAME_Odin = 0x002a,
     DW_LNAME_P4 = 0x002b,
     DW_LNAME_Metal = 0x002c,
+    DW_LNAME_Algol68 = 0x002e,
 
     DW_LNAME_lo_user = 0x8000,	/* Implementation-defined range start.  */
     DW_LNAME_hi_user = 0xffff	/* Implementation-defined range end.  */
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 07/47] a68: darwin specific support
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (5 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 06/47] a68: DWARF language codes Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 08/47] a68: powerpc " Jose E. Marchesi
                   ` (40 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Iain Sandoe <iains.gcc@gmail.com>

gcc/ChangeLog

	* config/darwin.h: Adapt specs for libga68.a.
---
 gcc/config/darwin.h | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gcc/config/darwin.h b/gcc/config/darwin.h
index e23414c00b6..4b45f4efbc1 100644
--- a/gcc/config/darwin.h
+++ b/gcc/config/darwin.h
@@ -523,6 +523,7 @@ extern GTY(()) int darwin_ms_struct;
    %{static|static-libgcc|static-libgcobol:%:replace-outfile(-lgcobol libgcobol.a%s)}\
    %{static|static-libgcc|static-libstdc++|static-libgfortran:%:replace-outfile(-lgomp libgomp.a%s)}\
    %{static|static-libgcc|static-libstdc++:%:replace-outfile(-lstdc++ libstdc++.a%s)}\
+   %{static|static-libga68:%:replace-outfile(-lga68 libga68.a%s)}\
    %{static|static-libgm2:%:replace-outfile(-lm2pim libm2pim.a%s)}\
    %{static|static-libgm2:%:replace-outfile(-lm2iso libm2iso.a%s)}\
    %{static|static-libgm2:%:replace-outfile(-lm2min libm2min.a%s)}\
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 08/47] a68: powerpc specific support
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (6 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 07/47] a68: darwin specific support Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 09/47] a68: gcc/algol68 misc files Jose E. Marchesi
                   ` (39 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Some code in the rs6000 port relies on parsing the language name.
This commit makes that code to recognize "GNU Algol 68".

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

gcc/ChangeLog

	* config/rs6000/rs6000-logue.cc (rs6000_output_function_epilogue):
	Handle "GNU Algol 68" in language_string.
---
 gcc/config/rs6000/rs6000-logue.cc | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/gcc/config/rs6000/rs6000-logue.cc b/gcc/config/rs6000/rs6000-logue.cc
index 5377ad6cee6..0005039733b 100644
--- a/gcc/config/rs6000/rs6000-logue.cc
+++ b/gcc/config/rs6000/rs6000-logue.cc
@@ -5332,18 +5332,18 @@ rs6000_output_function_epilogue (FILE *file)
       /* Tbtab format type.  Use format type 0.  */
       fputs ("\t.byte 0,", file);
 
-      /* Language type.  Unfortunately, there does not seem to be any
-	 official way to discover the language being compiled, so we
-	 use language_string.
-	 C is 0.  Fortran is 1.  Ada is 3.  Modula-2 is 8.  C++ is 9.
-	 Java is 13.  Objective-C is 14.  Objective-C++ isn't assigned
-	 a number, so for now use 9.  LTO, Go, D, and JIT aren't assigned
-	 numbers either, so for now use 0.  */
+      /* Language type.  Unfortunately, there does not seem to be any official
+	 way to discover the language being compiled, so we use
+	 language_string.  C is 0.  Fortran is 1.  Ada is 3.  Modula-2 is 8.
+	 C++ is 9.  Java is 13.  Objective-C is 14.  Objective-C++ isn't
+	 assigned a number, so for now use 9.  LTO, Go, D, Algol 68 and JIT
+	 aren't assigned numbers either, so for now use 0.  */
       if (lang_GNU_C ()
 	  || ! strcmp (language_string, "GNU GIMPLE")
 	  || ! strcmp (language_string, "GNU Go")
 	  || ! strcmp (language_string, "GNU D")
 	  || ! strcmp (language_string, "GNU Rust")
+	  || ! strcmp (language_string, "GNU Algol 68")
 	  || ! strcmp (language_string, "libgccjit"))
 	i = 0;
       else if (! strcmp (language_string, "GNU F77")
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 09/47] a68: gcc/algol68 misc files
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (7 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 08/47] a68: powerpc " Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 10/47] a68: ga68 compiler driver Jose E. Marchesi
                   ` (38 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

README contains a description of the front-end, and brief instructions
for developers.

At the moment the front-end doesn't define any custom tree node, as of
yet.  gcc/algol68/a68-tree.def is a placeholder where to have these
node codes.

a68-types.h and a68.h are the main header files used by the front-end.
Together they provide data definitions and prototypes of functions
defined in the .cc files.

ga68.vw contains a revised-report like formal description of the
language implemented by this compiler.  This includes GNU extensions.

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

gcc/ChangeLog

	* algol68/README: New file.
	* algol68/a68-tree.def: Likewise.
	* algol68/a68-types.h: Likewise.
	* algol68/a68.h: Likewise.
	* algol68/ga68.vw: Likewise.
---
 gcc/algol68/README       |  126 +++
 gcc/algol68/a68-tree.def |   24 +
 gcc/algol68/a68-types.h  |  964 ++++++++++++++++++++
 gcc/algol68/a68.h        | 1042 +++++++++++++++++++++
 gcc/algol68/ga68.vw      | 1837 ++++++++++++++++++++++++++++++++++++++
 5 files changed, 3993 insertions(+)
 create mode 100644 gcc/algol68/README
 create mode 100644 gcc/algol68/a68-tree.def
 create mode 100644 gcc/algol68/a68-types.h
 create mode 100644 gcc/algol68/a68.h
 create mode 100644 gcc/algol68/ga68.vw

diff --git a/gcc/algol68/README b/gcc/algol68/README
new file mode 100644
index 00000000000..67f11bf50ad
--- /dev/null
+++ b/gcc/algol68/README
@@ -0,0 +1,126 @@
+This is the GNU Algol 68 compiler.
+
+This compiler implements the Algol 68 programming language
+(https://www.algol68-lang.org) as defined in the Revised Report, along
+with several GNU extensions to the language which are oriented to
+enhance its application in systems programming and to achieve a good
+integration in POSIX systems.
+
+The parser component used in this front-end has been adapted from
+Algol 68 Genie, an Algol 68 interpreter written by Marcel van der
+Veer.  It is worth noting that this parser is not your typical garden
+variety parser, as it is capable of effectively parsing the two-level
+grammar of Algol 68, which is no small task.  Parsing Algol 68 is
+notoriously difficult, and without Marcel's careful work of many years
+this front-end would most probably not exist.  It is also a beautiful
+implementation that is a delight to both read and work with.
+
+The syntax tree built by the parser is lowered into a GENERIC tree by
+a lowering pass, which then invokes the gimplifier and hands the
+resulting gimple IR over to the rest of the compilation, down the
+rabbit hole all the way to optimized assembly code.
+
+The compiler driver is called `ga68'.
+The compiler proper is called `a681'.
+
+Programs built by this compiler make use of the libga68 run-time
+library.
+
+Building
+========
+
+Configure and build GCC with:
+
+  $ mkdir build-algol68
+  $ cd build-algol68
+  $ ../configure --enable-languages=algol68
+  $ make
+  $ make install
+
+Alternatively you can configure and build a non-bootstrapped compiler,
+which is much faster to build.  But note that in this case you better
+pass some flags so the compiler gets built optimized, or the resulting
+compiler will be rather slow:
+
+  $ mkdir build-algol68
+  $ cd build-algol68
+  $ ../configure --enable-languages=algol68 BOOT_CFLAGS="-O2 -g" \
+      BOOT_CXXFLAGS="-O2 -g" \
+      STAGE1_CFLAGS="-O2 -g" \
+      STAGE1_CXXFLAGS="-O2 -g"
+  $ make
+  $ make install
+
+Debugging
+=========
+
+A few front-end specific options useful for debugging are:
+
+  '-fdump-algol68-tree'
+  Emits a textual representation of the parse tree as produced by the parser.
+
+  '-fdump-algol68-modes'
+  Emits a list of all parsed modes.
+
+See the Developer Options section in the GNU Algol Compiler manual for
+more hacking related options.
+
+Testing
+=======
+
+Invoke the full testsuite from the build directory:
+
+  $ make check-algol68
+
+You can pass -jN to run tests in parallel:
+
+  $ make -jN check-algol68
+
+Invoke a subset of the testsuite.  For example, to only run tests that
+involve compilation but not running:
+
+  $ make check-algol68 RUNTESTFLAGS="compile.exp"
+
+There are the following sets of tests:
+
+  compile.exp - compilation tests
+
+Invoke only a specific test:
+
+  $ make check-algol68 RUNTESTFLAGS="--all compile.exp=bad-coercion-1.a68"
+
+Test in both 32-bit and 64-bit in multilib arches:
+
+  $ make check-algol68 RUNTESTFLAGS="--target_board=unix\{-m64,-m32\}"
+
+Logs (with corresponding commands) can be found in
+BUILD/gcc/testsuite/algol68/algol68.log.
+
+See https://gcc.gnu.org/install/test.html for more details.
+
+Useful Resources
+================
+
+- An Emacs mode for editing Algol 68 programs can be found at
+  https://git.sr.ht/~jemarch/a68-mode.  It supports automatic
+  indentation, pretty-printing of bold tags, an auto-stropping minor
+  mode and other features.
+
+- The Algol 68 Jargon File at https://jemarch.net/a68-jargon provides
+  a comprehensive list of definitions of many of the technical and
+  non-technical terms used in the context of Algol 68.
+
+- The very formal Revised Report on the Algorithmic Language ALGOL 68
+  can be found at [1].
+
+- The truly delightful Informal Introduction to ALGOL 68 by C.H
+  Lindsey and van der Meulen can be found at [2].
+
+Community
+=========
+
+mailing list: algol68@gcc.gnu.org
+irc: irc.oftc.net - #gnualgol
+
+[1] https://www.softwarepreservation.org/projects/ALGOL/report/Algol68_revised_report-AB-600dpi.pdf
+[2] https://inria.hal.science/hal-03027689/file/Lindsey_van_der_Meulen-IItA68-Revised.pdf
diff --git a/gcc/algol68/a68-tree.def b/gcc/algol68/a68-tree.def
new file mode 100644
index 00000000000..1d7c644988f
--- /dev/null
+++ b/gcc/algol68/a68-tree.def
@@ -0,0 +1,24 @@
+/* This file contains the definitions and documentation for the
+   additional tree codes used in the GNU Algol 68 compiler (see
+   tree.def for the standard codes).
+   Copyright (C) 2025 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/>.  */
+
+/* Tree nodes used in the Algol68 frontend only.  */
+
+/*
+Local variables:
+mode:c
+End:
+*/
diff --git a/gcc/algol68/a68-types.h b/gcc/algol68/a68-types.h
new file mode 100644
index 00000000000..9878e2ee57c
--- /dev/null
+++ b/gcc/algol68/a68-types.h
@@ -0,0 +1,964 @@
+/* Type definitions for the ALGOL 68 parser.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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_TYPES_H__
+#define __A68_TYPES_H__
+
+#include <setjmp.h>
+#include "vec.h"
+
+/* Enumerations.  */
+
+enum a68_stropping
+{
+  UPPER_STROPPING,
+  SUPPER_STROPPING
+};
+
+enum a68_attribute
+{
+  STOP = 0,
+#define A68_ATTR(ATTR) ATTR,
+#include "a68-parser-attrs.def"
+#undef A68_ATTR
+};
+
+/*
+ * Type definitions.
+ */
+
+typedef char BUFFER[BUFFER_SIZE + 1];
+
+typedef struct MODES_T MODES_T;
+typedef struct NODE_T NODE_T;
+typedef struct MODE_CACHE_T MODE_CACHE_T;
+typedef struct MOID_T MOID_T;
+typedef struct GINFO_T GINFO_T;
+typedef struct KEYWORD_T KEYWORD_T;
+typedef struct LINE_T LINE_T;
+typedef struct NODE_INFO_T NODE_INFO_T;
+typedef struct PACK_T PACK_T;
+typedef struct SOID_T SOID_T;
+typedef struct TABLE_T TABLE_T;
+typedef struct TAG_T TAG_T;
+typedef struct TOKEN_T TOKEN_T;
+typedef struct ORIGIN_T ORIGIN_T;
+typedef struct POSTULATE_T POSTULATE_T;
+typedef struct OPTIONS_T OPTIONS_T;
+typedef struct PARSER_T PARSER_T;
+typedef struct MODULE_T MODULE_T;
+typedef struct A68_T A68_T;
+
+#define NO_A68_REF ((A68_REF *) 0)
+#define NO_ARRAY ((A68_ARRAY *) 0)
+#define NO_BOOK ((BOOK_T *) 0)
+#define NO_BOOL ((bool *) 0)
+#define NO_BYTE ((BYTE_T *) 0)
+#define NO_CONSTANT ((void *) 0)
+#define NO_DEC ((DEC_T *) 0)
+#define NO_EDLIN ((EDLIN_T *) 0)
+#define NO_FILE ((FILE *) 0)
+#define NO_FORMAT ((A68_FORMAT *) 0)
+#define NO_GINFO ((GINFO_T *) 0)
+#define NO_GPROC ((void (*) (NODE_T *)) 0)
+#define NO_HANDLE ((A68_HANDLE *) 0)
+#define NO_INT ((int *) 0)
+#define NO_JMP_BUF ((jmp_buf *) 0)
+#define NO_KEYWORD ((KEYWORD_T *) 0)
+#define NO_NINFO ((NODE_INFO_T *) 0)
+#define NO_NOTE ((void (*) (NODE_T *)) 0)
+#define NO_OPTION_LIST ((OPTION_LIST_T *) 0)
+#define NO_PACK ((PACK_T *) 0)
+#define NO_PPROC ((PROP_T (*) (NODE_T *)) 0)
+#define NO_PROCEDURE ((A68_PROCEDURE *) 0)
+#define NO_REAL ((REAL_T *) 0)
+#define NO_REFINEMENT ((REFINEMENT_T *) 0)
+#define NO_REGMATCH ((regmatch_t *) 0)
+#define NO_SCOPE ((SCOPE_T *) 0)
+#define NO_SOID ((SOID_T *) 0)
+#define NO_STREAM NO_FILE
+#define NO_TEXT ((char *) 0)
+#define NO_TICK ((bool *) 0)
+#define NO_TOKEN ((TOKEN_T *) 0)
+#define NO_TUPLE ((A68_TUPLE *) 0)
+#define NO_VAR (0)
+
+/* A STATUS_MASK_T is a word of flags denoting states.
+
+   Status masks are used in parse tree nodes (NODE_T) and in entries in the
+   symbol table (TAG_T).
+
+
+   SCOPE_ERROR_MASK is used by the static scope checker in order to avoid
+   emitting duplicated scope warnings.  */
+
+typedef uint32_t STATUS_MASK_T;
+
+#define STATUS_CLEAR(p, q) {STATUS (p) &= (~(q));}
+#define STATUS_SET(p, q) {STATUS (p) |= (q);}
+#define STATUS_TEST(p, q) ((STATUS (p) & (q)) != (uint32_t) 0)
+
+#define NULL_MASK                 ((STATUS_MASK_T) 0x00000000)
+#define SCOPE_ERROR_MASK          ((STATUS_MASK_T) 0x00000200)
+
+/* Structure containing the lowering context which is propagated while calling
+   the lowering handlers.  */
+
+struct LOW_CTX_T
+{
+  /* The common declarer in a declaration list.  */
+  NODE_T **declarer;
+  /* The defining identifier of the procedure declaration being processed, or
+     NO_NODE.  This is set by a68_lower_procedure_declaration and used by
+     a68_lower_routine_text.  */
+  NODE_T *proc_decl_identifier;
+  /* For debugging purposes.  */
+  int level;
+};
+
+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
+
+struct KEYWORD_T
+{
+  enum a68_attribute attribute;
+  const char *text;
+  KEYWORD_T *less, *more;
+};
+
+/* A MOID_T represents a mode indicator.
+
+   NUMBER is an unique number assigned to the moid when it gets created.  A
+   renumber_moids function exists in a68-parser-modes.cc but it dosn't seem to
+   be used at all.
+
+   ATTRIBUTE characterizes the kind of mode and is one of the values defined in
+   a68-parser-attrs.def.  Valid values are:
+
+     PROC_SYMBOL for procecure modes.
+     ROWS_SYMBOL for row modes.
+     REF_SYMBOL for reference modes.
+     FLEX_SYMBOL for flexible reference modes.
+     STRUCT_SYMBOL for struct modes.
+     UNION_SYMBOL for union modes.
+     IN_TYPE_MODE for XXX modes.
+     OUT_TYPE_MODE for XXX modes.
+     SERIES_MODE for XXX modes.
+     INDICANT for XXX modes.
+     STANDARD for standard modes.
+
+   NODE is a parse tree node XXX.
+
+   HAS_ROWS is true if the mode contains rows somewhere in its internal
+   structure.
+
+   The interpretation of SUB depends on the kind of mode:
+   - For REF modes it is the referred mode.
+   - For FLEX modes it is the referred mode.
+   - For ROW modes it is the mode of the elements.
+   - For PROC modes it is the mode of the value yielded by the procedure.
+
+   The interpretation of DIM depends on the kind of mode:
+   - In VOID_SYMBOL, STANDARD or INDICANT mode, if DIM is positive it
+     specifies the size of the longsety of the mode.  If DIM is negative then
+     abs (DIM) is the size of hte shortsety of the mode.
+   - In ROW modes, DIM is the number of dimensions.
+   - In STRUCT modes, DIM is the number of fields.
+   - In UNION modes, DIM is the number of united modes.
+   - In PROC_SYMBOL modes, DIM is the number of arguments.
+   - In SERIES_MODE and STOWED_MODE modes, DIM is the number modes.
+
+   SLICE is the mode resulting from slicing a value of this mode.  For example,
+   slicing a M_ROW_INT yields a M_INT.
+
+   EQUIVALENT_MODE (referred as EQUIVALENT), for INDICANTs it is its declarer
+   mode (in MODE FOO = BAR FOO is the indicant and BAR is its declarer) and for
+   STANDARD modes it may be a mode that reflects its structure.
+
+   USE is used by the is_well_formed function, which detects whether a mode is
+   well formed, i.e. that the mode doesn't refer to itself nor it relates to
+   void.
+
+   DEFLEXED_MODE is like the current mode, but without FLEX.  Only defined for
+   modes that have a SUB, i.e. REF, FLEX, ROW and PROC.  In other modes this is
+   NO_MODE.
+
+   For refs to structs, rows or flex, NAME points to the corresponding name
+   mode.  For example, for a mode REF STRUCT (INT i, REAL x), NAME points to a
+   mode STRUCT (REF INT i, REF REAL x).  This is used for selections.
+
+   For rows of structs, rows or flex, MULTIPLE points to the corresponding row
+   mode.  For example, for a mode [] STRUCT (INT i, REAL x), MULTIPLE points to
+   a mode STRUCT ([]INT i, []REAL x).  This is used for selections.
+
+   PACK is a pack of moids.  For a STOWED_MODE, it contains the modes of the
+   arguments of a procedure, or the modes of the units in a collateral clause.
+   For a SERIES_MODE, it contains the modes of the completing units in a serial
+   clause, the alternatives in a conformity clause, the alternatives in a
+   CONDITIONAL_CLAUSE, the alternatives in a CASE_CLAUSE,
+
+   CTYPE is a GCC GENERIC tree corresponding to this mode.  It is computed and
+   installed by a68_lower_moid.  */
+
+#define NO_MOID ((MOID_T *) 0)
+
+struct MOID_T
+{
+  int number;
+  int attribute;
+  int dim;
+  bool has_rows, use, portable, derivate;
+  NODE_T *node;
+  PACK_T *pack;
+  MOID_T *sub, *equivalent_mode, *slice, *deflexed_mode, *name, *multiple_mode, *next, *rowed, *trim;
+  tree ctype;
+};
+
+/* A MODES_T struct contains a collection of particular pre-defined modes.
+
+   These modes are initialized by either stand_moids or make_special_mode.
+   They are commonly referred using the corresponding M_* macros.
+
+   ROWS is a mode to which any ROW mode can be strongly coerced.  It is used as
+   the mode of the second operand of the ELEMS, LWB and UPB operators.
+
+   HIP is the mode of NIL.  */
+
+struct MODES_T
+{
+  MOID_T *BITS, *BOOL, *BYTES, *CHANNEL, *CHAR, *COLLITEM, *COMPL, *COMPLEX,
+    *C_STRING, *ERROR, *FILE, *FORMAT, *HEX_NUMBER, *HIP, *INT, *LONG_BITS, *LONG_BYTES,
+    *LONG_COMPL, *LONG_COMPLEX, *LONG_INT, *LONG_LONG_BITS, *LONG_LONG_COMPL,
+    *LONG_LONG_COMPLEX, *LONG_LONG_INT, *LONG_LONG_REAL, *LONG_REAL, *NUMBER,
+    *PROC_REAL_REAL, *PROC_LONG_REAL_LONG_REAL, *PROC_REF_FILE_BOOL, *PROC_REF_FILE_VOID, *PROC_ROW_CHAR,
+    *PROC_STRING, *PROC_VOID, *REAL, *REF_BITS, *REF_BOOL, *REF_BYTES,
+    *REF_CHAR, *REF_COMPL, *REF_COMPLEX, *REF_FILE, *REF_INT,
+    *REF_LONG_BITS, *REF_LONG_BYTES, *REF_LONG_COMPL, *REF_LONG_COMPLEX,
+    *REF_LONG_INT, *REF_LONG_LONG_BITS, *REF_LONG_LONG_COMPL,
+    *REF_LONG_LONG_COMPLEX, *REF_LONG_LONG_INT, *REF_LONG_LONG_REAL, *REF_LONG_REAL,
+    *REF_REAL, *REF_REF_FILE, *REF_ROW_CHAR, *REF_ROW_COMPLEX, *REF_ROW_INT,
+    *REF_ROW_REAL, *REF_ROW_ROW_COMPLEX, *REF_ROW_ROW_REAL,
+    *REF_SHORT_BITS, *REF_SHORT_SHORT_BITS, *REF_SHORT_INT,
+    *REF_SHORT_SHORT_INT, *REF_STRING,
+    *ROW_BITS, *ROW_BOOL, *ROW_CHAR, *ROW_COMPLEX, *ROW_INT, *ROW_LONG_BITS, *ROW_LONG_LONG_BITS,
+    *ROW_REAL, *ROW_ROW_CHAR, *ROW_ROW_COMPLEX, *ROW_ROW_REAL, *ROWS, *ROW_SIMPLIN, *ROW_SIMPLOUT,
+    *ROW_STRING, *SEMA, *SHORT_BITS, *SHORT_SHORT_BITS, *SHORT_INT, *SHORT_SHORT_INT,
+    *SIMPLIN, *SIMPLOUT, *STRING, *FLEX_ROW_CHAR,
+    *FLEX_ROW_BOOL, *UNDEFINED, *VACUUM, *VOID;
+};
+
+/* The OPTIONS_T structure record which front-end options have been activated.
+   Each option OPTION has a corresponding GCC -f[no-]a68-OPTION command-line
+   switch that can be used to activate or deactivate it.
+
+   STROPPING indicates the stropping regime in use.  It can be UPPER_STROPPING
+   or SUPPER_STROPPING.
+
+   BRACKETS indicates whether [ .. ] and { .. } are equivalent to ( .. ).
+
+   STRICT indicates that no ALGOL 68 extension is allowed.
+
+   ASSERT indicates whether to generate code for assertions.
+
+   BOUNDS_CHECKING indicates whether to perform array bound checking at
+   run-time.
+
+   NIL_CHECKING indicates whether to check for NIL when dereferencing at
+   run-time.  */
+
+struct OPTIONS_T
+{
+  enum a68_stropping stropping;
+  bool brackets;
+  bool strict;
+  bool assert;
+  bool bounds_checking;
+  bool nil_checking;
+};
+
+/* The access class static property of a stored value determines how the value
+   can be reached at run-time.  It is used by the lowering pass in order to
+   minimize copies at run-time.
+
+   CONSTANT is for constant literals.  At run-time these literals will either
+   reside in operand instructions or in space allocated in CONSTAB%.
+
+   DIRIDEN (direct identifier) means that the value is stored on IDST% at some
+   static address.  This is the access class used for values ascribed to
+   identifiers as long as the block in hich they are declared has not been
+   left.  It is also used for values resulting from actions such as the
+   selection from a value possessed by an identifier or the dereferencing fo a
+   name corespodning to a variable.
+
+   VARIDEN (variable identifier) is used for values which are names/variables.
+   The name is stored on IDST%.  The static elaboration of the dereferencing of
+   a variable with access VARIDEN results in a value with access DIRIDEN, not
+   requiring any run-time action.  Same happens with selections of variables of
+   access VARIDEN.
+
+   INDIDEN (indirect identifier) is used for values that are stored in a memory
+   location in IDST%.  The static elaboration of a dereferencing applied to a
+   value of access DIRIDEN.
+
+   DIRWOST (direct working stack) is very much like DIRIDEN, except that the
+   value is stored in WOST% rathern than in IDST%.  This access is used for the
+   result of an action when this result does not preexist in memory and hence
+   has to be constructed in WOST%.
+
+   INDWOST (indirect working stack) is very similar to INDIDEN.  Such an access
+   can be obtained for example through the static elaboration of the
+   dereferencing of a name the access of which is DIRWOST.
+
+   NIHIL is used to characterize the absence of value.  This is used in the
+   static elaboration of a jump, a voiding and a call ith a void result.
+
+   Note that in all these classes we assume as run-time the intermediate
+   language level we are lowering to, i.e. GENERIC.  A DIRIDEN value, for
+   example, can very well stored in a register depending on further compiler
+   optimizations.  */
+
+#define ACCESS_NIHIL 0
+#define ACCESS_CONSTANT 1
+#define ACCESS_DIRIDEN 2
+#define ACCESS_INDIDEN 3
+#define ACCESS_DIRWOST 4
+
+/* A NODE_T is a node in the A68 Syntax tree produced by the lexer-scanner and
+   later expanded by the Mailloux parser.
+
+   NUMBER identifies the node uniquely in the syntax tree.
+
+   ATTRIBUTE is a code that specifies the kind of entity denoted by the node.
+   Valid attributes are defined in the enumeration a68_attribute above in
+   this file.  Examples of attributes are ELIF_PART, GOTO_SYMBOL or BOLD_TAG.
+
+   ANNOTATION provides a way to annotate a node with a reference to another
+   node attribute.  This is currently used by the mode checker to annotate
+   indexer nodes as slicer or as trimmers.
+
+   TYPE (accessed as MOID) is either NO_MOID if the entity denoted by the node
+   doesn't have a mode, or a suitable MOID_T reflecting the mode of the entity.
+   This attribute is calculated and set in all the nodes of the tree by the
+   mode collection and checker pass implemented by make_moid_list.
+
+   INFO contains additional attributes of the node.  See NODE_INFO_T below.
+
+   NEXT, PREVIOUS and SUB are links to other tree nodes.  They are used to link
+   the syntax tree structure from the top:
+
+        TOP <-> N <-> N <-> ...
+                |                      < is PREVIOUS
+		N <-> N <-> ...        > is NEXT
+                      |                | is SUB
+                      N <-> ...
+
+   SEQUENCE is a link to another tree node.  It is used by the tax collector
+   (symbol table builder) in order to handle DO .. OD ranges.
+
+   NEST is a link to another tree node, which is the NEST for the current node.
+   It is set by the tax collector (symbol table builder) and it is used for
+   diagnostics.
+
+   PACK (accessed as NODE_PACK) is either NO_PACK or an instance of the PACK_T
+   structure defined below.  It is used by the modes checker.
+
+   STATUS is a mask of flags, used by several passes that handle nodes.  Valid status flags are:
+
+   SYMBOL_TABLE (accessed as TABLE) is either NO_TABLE or a TABLE_T containing
+   a symbol table introduced by the entity denoted by the tree node.  These
+   nodes are the ones introducing ranges: BEGIN, DO, etc.
+
+   NON_LOCAL is either NO_TABLE, if the environ established by the node is
+   local, or a pointer to a TABLE_T identifying the non-local environment
+   associated with the tree node.  It is set by the static scope checker.  See
+   3.2.2 and 5.2.3.2.b in the report for its application in the handling of
+   local generators in serial clauses.
+
+   TAG (accessed as TAX) is either NO_TAG or a TAG_T used to bind identifier
+   nodes, routine texts and other indicants to their corresponding entry in a
+   symbol table.  This is set by the taxes collector.
+
+   The following fields are static properties managed an used in the lowering
+   pass.
+
+   ORIGIN is a static property that describes the history of the entity denoted
+   by the node.  This is only used in nodes denoting values.
+
+   DYNAMIC_STACK_ALLOCS is a flag used in serial clause nodes.  It determines
+   whether the elaboration of the phrases in the serial clause may involve
+   dynamic stack allocation.  This is used by the lower pass, along with
+   NON_LOCAL above, in order to properly manage the stack pointer while
+   lowering these clauses.
+
+   CDECL is a GCC GENERIC tree corresponding to a DECL_FIELD for FIELD
+   nodes.  */
+
+struct NODE_T
+{
+  GINFO_T *genie;
+  int number;
+  enum a68_attribute attribute;
+  enum a68_attribute annotation;
+  MOID_T *type;
+  NODE_INFO_T *info;
+  NODE_T *next, *previous, *sub;
+  NODE_T *sequence, *nest;
+  PACK_T *pack;
+  STATUS_MASK_T status;
+  TABLE_T *symbol_table;
+  TABLE_T *non_local;
+  TAG_T *tag;
+  tree cdecl;
+  bool dynamic_stack_allocs;
+};
+
+#define NO_NODE ((NODE_T *) 0)
+
+/* A NODE_INFO_T struct contains additional attributes of a NODE_T parse tree
+   node.
+
+   PROCEDURE_LEVEL indicates how lexically deep the tree node is in terms of
+   routine texts.  This attribute is set for all the nodes in the syntax tree
+   by the taxes collector and originally used by ALGOL 68 Genie's monitor.
+   Even if at the moment this is not used by GCC, this field and the
+   correponding machinery is still here in case it is useful in the future.
+
+   PRIORITY (accessed as PRIO) is used by operator tree nodes and specifies the
+   priority of the operator denoted by the node.  This is set tree wide by the
+   bottom-up parser.
+
+   SYMBOL (accessed indirectly as NSYMBOL) contains the symbol value, a string,
+   corresponding to the tree node.  This is used by tree nodes representing
+   tokens such as bold tags, keywords and identifiers.  The symbols are set by
+   the parser-scanner.
+
+   LINE is a pointer to the source line from which the tree node originates.
+   This is set for tree nodes representing tokens and is set by the
+   parser-scanner.  */
+
+struct NODE_INFO_T
+{
+  int procedure_level;
+  int priority;
+  char *char_in_line;
+  int pragment_type;
+  char *pragment;
+  const char *symbol;
+  LINE_T *line;
+};
+
+struct GINFO_T
+{
+  MOID_T *partial_proc, *partial_locale;
+};
+
+struct PACK_T
+{
+  MOID_T *type;
+  const char *text;
+  NODE_T *node;
+  PACK_T *next, *previous;
+};
+
+/* Postulates.  */
+
+struct POSTULATE_T
+{
+  MOID_T *a, *b;
+  POSTULATE_T *next;
+};
+
+#define NO_POSTULATE ((POSTULATE_T *) 0)
+
+struct SOID_T
+{
+  int attribute, sort, cast;
+  MOID_T *type;
+  NODE_T *node;
+  SOID_T *next;
+};
+
+struct LINE_T
+{
+  char marker[6], *string;
+  const char *filename;
+  int number;
+  LINE_T *next, *previous;
+};
+#define NO_LINE ((LINE_T *) 0)
+
+struct TABLE_T
+{
+  int num, level, nest, attribute;
+  bool initialise_frame, initialise_anon, proc_ops;
+  TABLE_T *previous, *outer;
+  TAG_T *identifiers, *operators, *priority, *indicants, *labels, *anonymous;
+  NODE_T *jump_to, *sequence;
+};
+#define NO_TABLE ((TABLE_T *) 0)
+
+/* A TAG_T structure denotes an entry in the symbol table.  Each entry
+   corresponds to an identity.
+
+   TAX: TAG; TAB; TAD; TAM;
+
+   TYPE is the mode of the entry.
+
+   NODE is the defining identifier associated to the declaration.
+
+   SCOPE is the lexical depth of the tag.  Zero corresponds to the primal
+   scope.  It is set by the static scope checker.
+
+   SCOPE_ASSIGNED determines whether a SCOPE has been actually assigned to the
+   tag.  It is set by the static scope checker.  The entities which get
+   assigned scopes are identities of format texts and routine texts.
+
+   PORTABLE determines whether the construction associated with the tag is
+   Algol 68 or some extension.
+
+   VARIABLE is set when the defining identifier in NODE is defined in a
+   variable declaration, as opposed to an identity declaration.  This is set by
+   extract_variables and is used by the lowering pass.
+
+   HEAP is used for defining identifier in NODE is defined in a variable
+   declaration.  It is HEAP_SYMBOL or LOC_SYMBOL.
+
+   IS_RECURSIVE is set for mode indicants whose definition is recursive,
+   i.e. they appear in actual declarers within its own definition.
+
+   ASCRIBED_ROUTINE_TEXT is set when the defining identifier is ascribed a
+   routine-text in an identity declaration.
+
+   IN_PROC is set when the defining identifier has been set in a
+   proc-identity-declaration or in a brief-op-declaration.
+
+   YOUNGEST_ENVIRON is used when NODE is either a ROUTINE_TEXT or a
+   FORMAT_TEXT, and contains the youngest (higher) lexical level of any object
+   directly declared in the routine or format body.  This is filled in and used
+   by the scope checker.
+
+   TREE_DECL is the GENERIC declaration for the definition of this symbol.
+   This is set and used by the lower pass.  For mode indicants, it contains a
+   function that generates a pointer to the given mode, and is used by
+   a68_low_generator to handle recursive modes.
+
+   LOWERER is a lowering routine defined in a68-low-prelude.cc.  These are used
+   in taxes that denote some pre-defined operator.  */
+
+struct TAG_T
+{
+  TABLE_T *symbol_table;
+  MOID_T *type;
+  NODE_T *node, *unit;
+  char *value;
+  bool scope_assigned, use, in_proc, loc_assigned, portable, variable;
+  bool ascribed_routine_text, is_recursive;
+  int priority, heap, scope, youngest_environ, number;
+  STATUS_MASK_T status;
+  tree tree_decl;
+  LOWERER_T lowerer;
+  TAG_T *next, *body;
+};
+#define NO_TAG ((TAG_T *) 0)
+
+struct TOKEN_T
+{
+  char *text;
+  TOKEN_T *less, *more;
+};
+#define NO_TOKEN ((TOKEN_T *) 0)
+
+struct MODULE_T
+{
+  bool tree_listing_safe, cross_reference_safe;
+  int error_count, warning_count, source_scan;
+  LINE_T *top_line;
+  MOID_T *top_moid, *standenv_moid;
+  NODE_T *top_node;
+  OPTIONS_T options;
+  FILE *file_source_fd;
+  const char *file_source_name;
+  struct
+  {
+    LINE_T *save_l;
+    char *save_s, save_c;
+  } scan_state;
+};
+
+struct MODE_CACHE_T
+{
+  MOID_T *proc_bool;
+  MOID_T *proc_char;
+  MOID_T *proc_complex_complex;
+  MOID_T *proc_int;
+  MOID_T *proc_int_int;
+  MOID_T *proc_int_int_real;
+  MOID_T *proc_int_real;
+  MOID_T *proc_int_real_real;
+  MOID_T *proc_int_real_real_real;
+  MOID_T *proc_real;
+  MOID_T *proc_real_int_real;
+  MOID_T *proc_real_real;
+  MOID_T *proc_real_real_int_real;
+  MOID_T *proc_real_real_real;
+  MOID_T *proc_real_real_real_int;
+  MOID_T *proc_real_real_real_real;
+  MOID_T *proc_real_real_real_real_real;
+  MOID_T *proc_real_real_real_real_real_real;
+  MOID_T *proc_real_ref_real_ref_int_void;
+  MOID_T *proc_void;
+};
+
+/* A PARSER_T struct contains all the global state that is kept by the parser.
+   This information is managed and used exclusively by a68_parser.
+
+   ERROR_TAG is a tag that signifies an error.  It is initialized in
+   a68_parser.
+
+   STOP_SCANNER is a control flag used exclusively by the main loop in
+   tokenise_source, which is recursive.
+
+   SCAN_BUF is a scratch buffer used by the scanner for several purposes.  This
+   buffer is known to be big enough to hold any substring from the source file.
+   It is initialized in read_source_file.
+
+   MAX_SCAN_BUF_LENGTH is the useable size of SCAN_BUF.  This is used by the
+   scanner to grow SCAN_BUF as it includes other files.
+
+   TAG_NUMBER is a global counter used by the parser to assign an unique number
+   to each tag it creates.  It is used in a68_new_tag.
+
+   BOTTOM_UP_CRASH_EXIT and TOP_DOWN_CRASH_EXIT are used to longjmp from deeply
+   nested errors in the bottom-up and top-down parsers respectively.  */
+
+struct PARSER_T
+{
+  TAG_T *error_tag;
+  bool stop_scanner;
+  size_t max_scan_buf_length;
+  char *scan_buf;
+  int tag_number;
+  jmp_buf bottom_up_crash_exit;
+  jmp_buf top_down_crash_exit;
+};
+
+/* A A68_T struct contains the global state used by the ALGOL 68 front-end.
+
+   OUTPUT_LINE is used by the diagnostics machinery in order to write out
+   message lines.
+
+   EDIT_LINE is used as a scratch buffer for composing error messages and the
+   like.
+
+   INPUT_LINE is used by the original ALGOL 68 Genie to read lines from the
+   tty.  But in this parser it is used uninitialized (!) by the
+   a68_phrase_to_text routine in the top-down parser.  XXX.
+
+   NEW_NODES is a global counter that keeps the number of parse tree nodes
+   created.  It is currently not used for anything, but still updated in
+   a68_new_node.
+
+   NEW_MODES is a global counter that keeps the number of moids created.  It is
+   currently not used for anything, but still updated in a68_new_moid.
+
+   NEW_POSTULATES is a global counter that keeps the number of postulates
+   created by the front-end.  It is currently not used for anything, but still
+   updated in a68_make_postulate.
+
+   NEW_NODE_INFOS is a global counter that keeps the number of NODE_INFO_T
+   structures created by the front-end.  It is currently not used for anything,
+   but still updated in a68_new_node_info.
+
+   NEW_GENIE_INFOS is a global counter that keeps the number of GINFO_T
+   structures created by the front-end.  It is currently no tused for anything,
+   but still updated in a68_new_genie_info.
+
+   SYMBOL_TABLE_COUNT is a global counter used by the parser.  XXX move to
+   parser global state when syntax tree finalisation is moved to a68_parser?
+
+   MODE_COUNT is the number of modes registered in the global modes table. XXX
+   which table.
+
+   TOP_KEYWORD is the top of the list of keywords known to the font-end.
+
+   MODE_CACHE XXX.
+
+   A68_MODES (accessed as MODE) is a collection of particular pre-defined
+   modes.  These modes are initialized by stand_moids.
+
+   JOB (accessed as A68_JOB) is the instance of MODULE_T with the global data
+   corresponding to the source file being compiled.
+
+   OPTIONS is the set of options currently set for the front-end.
+
+   TOP_POSTULATE and TOP_POSTULATE_LIST are lists of postulates maintained by
+   the front-end.
+
+   POSTULATES is a collection of postulates used by the moid pretty printer.
+
+   TOP_SOID_LIST is used by the moid machinery.
+
+   STANDENV XXX.
+
+   TOP_TOKEN XXX.
+
+   INCLUDE_PATHS is the list of paths where we search for files to include.
+   Directories are added to the list at the option handling language hook.
+   The list is searched in FIFO order.
+*/
+
+struct A68_T
+{
+  BUFFER output_line;
+  BUFFER edit_line;
+  BUFFER input_line;
+  int new_nodes;
+  int new_modes;
+  int new_postulates;
+  int new_node_infos;
+  int new_genie_infos;
+  int symbol_table_count;
+  int mode_count;
+  KEYWORD_T *top_keyword;
+  MODE_CACHE_T mode_cache;
+  MODES_T a68_modes;
+  MODULE_T job;
+  OPTIONS_T *options;
+  POSTULATE_T *postulates, *top_postulate, *top_postulate_list;
+  SOID_T *top_soid_list;
+  TABLE_T *standenv;
+  TOKEN_T *top_token;
+  vec<const char *, va_heap, vl_embed> *include_paths;
+};
+
+/*
+ * Access macros to fields in the struct types defined above.  These are used *
+ * in order to achieve a nice ALGOL-like field OF struct style.
+ */
+
+#define BACKWARD(p) (p = PREVIOUS (p))
+#define DEFLEX(p) (DEFLEXED (p) != NO_MOID ? DEFLEXED(p) : (p))
+#define FORWARD(p) ((p) = NEXT (p))
+#define A(p) ((p)->a)
+#define ANNOTATION(p) ((p)->annotation)
+#define ANONYMOUS(p) ((p)->anonymous)
+#define ATTRIBUTE(p) ((p)->attribute)
+#define ASCRIBED_ROUTINE_TEXT(p) ((p)->ascribed_routine_text)
+#define B(p) ((p)->b)
+#define BODY(p) ((p)->body)
+#define CAST(p) ((p)->cast)
+#define CHAR_IN_LINE(p) ((p)->char_in_line)
+#define CROSS_REFERENCE_SAFE(p) ((p)->cross_reference_safe)
+#define CDECL(p) ((p)->cdecl)
+#define CTYPE(p) ((p)->ctype)
+#define DEFLEXED(p) ((p)->deflexed_mode)
+#define DEREFO(p) ((p).derefo)
+#define DERIVATE(p) ((p)->derivate)
+#define DIM(p) ((p)->dim)
+#define DYNAMIC_STACK_ALLOCS(p) ((p)->dynamic_stack_allocs)
+#define EQUIVALENT(p) ((p)->equivalent_mode)
+#define EQUIVALENT_MODE(p) ((p)->equivalent_mode)
+#define ERROR_COUNT(p) ((p)->error_count)
+#define WARNING_COUNT(p) ((p)->warning_count)
+#define F(p) ((p)->f)
+#define FILENAME(p) ((p)->filename)
+#define FILE_SOURCE_FD(p) ((p)->file_source_fd)
+#define FILE_SOURCE_NAME(p) ((p)->file_source_name)
+#define FLEXO(p) ((p).flexo)
+#define FLEXO_KNOWN(p) ((p).flexo_known)
+#define G(p) ((p)->g)
+#define GINFO(p) ((p)->genie)
+#define GENO(p) ((p).geno)
+#define GET(p) ((p)->get)
+#define GPARENT(p) (PARENT (GINFO (p)))
+#define GREEN(p) ((p)->green)
+#define H(p) ((p)->h)
+#define HANDLE(p) ((p)->handle)
+#define HAS_ROWS(p) ((p)->has_rows)
+#define HEAP(p) ((p)->heap)
+#define ID(p) ((p)->id)
+#define IDENTIFICATION(p) ((p)->identification)
+#define IDENTIFIERS(p) ((p)->identifiers)
+#define IDF(p) ((p)->idf)
+#define IM(z) (VALUE (&(z)[1]))
+#define IN(p) ((p)->in)
+#define INDEX(p) ((p)->index)
+#define INDICANTS(p) ((p)->indicants)
+#define INFO(p) ((p)->info)
+#define INITIALISE_ANON(p) ((p)->initialise_anon)
+#define INITIALISE_FRAME(p) ((p)->initialise_frame)
+#define INI_PTR(p) ((p)->ini_ptr)
+#define INS_MODE(p) ((p)->ins_mode)
+#define IN_FORBIDDEN(p) ((p)->in_forbidden)
+#define IN_PREFIX(p) ((p)->in_prefix)
+#define IN_PROC(p) ((p)->in_proc)
+#define IN_TEXT(p) ((p)->in_text)
+#define IS_OPEN(p) ((p)->is_open)
+#define IS_RECURSIVE(p) ((p)->is_recursive)
+#define IS_TMP(p) ((p)->is_tmp)
+#define JUMP_STAT(p) ((p)->jump_stat)
+#define JUMP_TO(p) ((p)->jump_to)
+#define K(q) ((q)->k)
+#define LABELS(p) ((p)->labels)
+#define LAST(p) ((p)->last)
+#define LAST_LINE(p) ((p)->last_line)
+#define LESS(p) ((p)->less)
+#define LEVEL(p) ((p)->level)
+#define LEX_LEVEL(p) (LEVEL (TABLE (p)))
+#define LINBUF(p) ((p)->linbuf)
+#define LINE(p) ((p)->line)
+#define LINE_APPLIED(p) ((p)->line_applied)
+#define LINE_DEFINED(p) ((p)->line_defined)
+#define LINE_END_MENDED(p) ((p)->line_end_mended)
+#define LINE_NUMBER(p) (NUMBER (LINE (INFO (p))))
+#define LINSIZ(p) ((p)->linsiz)
+#define LIST(p) ((p)->list)
+#define ln(x) (log (x))
+#define LOCALE(p) ((p)->locale)
+#define LOC_ASSIGNED(p) ((p)->loc_assigned)
+#define LOWERER(p) ((p)->lowerer)
+#define LOWER_BOUND(p) ((p)->lower_bound)
+#define LWB(p) ((p)->lower_bound)
+#define MARKER(p) ((p)->marker)
+#define MATCH(p) ((p)->match)
+#define MODIFIED(p) ((p)->modified)
+#define MOID(p) ((p)->type)
+#define MORE(p) ((p)->more)
+#define MSGS(p) ((p)->msgs)
+#define MULTIPLE(p) ((p)->multiple_mode)
+#define MULTIPLE_MODE(p) ((p)->multiple_mode)
+#define NAME(p) ((p)->name)
+#define NEST(p) ((p)->nest)
+#define NEXT(p) ((p)->next)
+#define NEXT_NEXT(p) (NEXT (NEXT (p)))
+#define NEXT_NEXT_NEXT(p) (NEXT (NEXT_NEXT (p)))
+#define NEXT_SUB(p) (NEXT (SUB (p)))
+#define NF(p) ((p)->nf)
+#define NILO(p) ((p).nilo)
+#define NILO_KNOWN(p) ((p).nilo_known)
+#define NODE(p) ((p)->node)
+#define NODE_DEFINED(p) ((p)->node_defined)
+#define NODE_PACK(p) ((p)->pack)
+#define NON_LOCAL(p) ((p)->non_local)
+#define NCHAR_IN_LINE(p) (CHAR_IN_LINE (INFO (p)))
+#define NPRAGMENT(p) (PRAGMENT (INFO (p)))
+#define NPRAGMENT_TYPE(p) (PRAGMENT_TYPE (INFO (p)))
+#define NSYMBOL(p) (SYMBOL (INFO (p)))
+#define NUM(p) ((p)->num)
+#define NUMBER(p) ((p)->number)
+#define OPER(p) ((p)->oper)
+#define OPERATORS(p) ((p)->operators)
+#define OPT(p) ((p)->opt)
+#define OPTIONS(p) ((p)->options)
+#define OPTION_ASSERT(p) (OPTIONS (p).assert)
+#define OPTION_BOUNDS_CHECKING(p) (OPTIONS (p).bounds_checking)
+#define OPTION_BRACKETS(p) (OPTIONS (p).brackets)
+#define OPTION_NIL_CHECKING(p) (OPTIONS (p).nil_checking)
+#define OPTION_STRICT(p) (OPTIONS (p).strict)
+#define OPTION_STROPPING(p) (OPTIONS (p).stropping)
+#define OPTION_LIST(p) (OPTIONS (p).list)
+#define OPTION_LOCAL(p) (OPTIONS (p).local)
+#define OPTION_NODEMASK(p) (OPTIONS (p).nodemask)
+#define OUT(p) ((p)->out)
+#define OUTER(p) ((p)->outer)
+#define P(q) ((q)->p)
+#define PACK(p) ((p)->pack)
+#define PARTIAL_LOCALE(p) ((p)->partial_locale)
+#define PARTIAL_PROC(p) ((p)->partial_proc)
+#define PORTABLE(p) ((p)->portable)
+#define PRAGMENT(p) ((p)->pragment)
+#define PRAGMENT_TYPE(p) ((p)->pragment_type)
+#define PREVIOUS(p) ((p)->previous)
+#define PRIO(p) ((p)->priority)
+#define PROCEDURE_LEVEL(p) ((p)->procedure_level)
+#define PROC_OPS(p) ((p)->proc_ops)
+#define R(p) ((p)->r)
+#define RE(z) (VALUE (&(z)[0]))
+#define ROWED(p) ((p)->rowed)
+#define SCAN_STATE_C(p) ((p)->scan_state.save_c)
+#define SCAN_STATE_L(p) ((p)->scan_state.save_l)
+#define SCAN_STATE_S(p) ((p)->scan_state.save_s)
+#define SCOPE(p) ((p)->scope)
+#define SCOPE_ASSIGNED(p) ((p)->scope_assigned)
+#define SEQUENCE(p) ((p)->sequence)
+#define SEVERITY(p) ((p)->severity)
+#define SLICE(p) ((p)->slice)
+#define SORT(p) ((p)->sort)
+#define SOURCE_SCAN(p) ((p)->source_scan)
+#define STANDENV_MOID(p) ((p)->standenv_moid)
+#define STATUS(p) ((p)->status)
+#define STRING(p) ((p)->string)
+#define SUB(p) ((p)->sub)
+#define SUB_MOID(p) (SUB (MOID (p)))
+#define SUB_NEXT(p) (SUB (NEXT (p)))
+#define SUB_SUB(p) (SUB (SUB (p)))
+#define SYMBOL(p) ((p)->symbol)
+#define TABLE(p) ((p)->symbol_table)
+#define TAG_LEX_LEVEL(p) (LEVEL (TAG_TABLE (p)))
+#define TAG_TABLE(p) ((p)->symbol_table)
+#define TAX(p) ((p)->tag)
+#define TAX_TREE_DECL(p) ((p)->tree_decl)
+#define TEXT(p) ((p)->text)
+#define TOP_LINE(p) ((p)->top_line)
+#define TOP_MOID(p) ((p)->top_moid)
+#define TOP_NODE(p) ((p)->top_node)
+#define TRANSIENT(p) ((p)->transient)
+#define TREE_LISTING_SAFE(p) ((p)->tree_listing_safe)
+#define TRIM(p) ((p)->trim)
+#define TUPLE(p) ((p)->tuple)
+#define UNIT(p) ((p)->unit)
+#define USE(p) ((p)->use)
+#define VALUE(p) ((p)->value)
+#define VARIABLE(p) ((p)->variable)
+#define WHERE(p) ((p)->where)
+#define IS_FLEXETY_ROW(m) (IS_FLEX (m) || IS_ROW (m) || m == M_STRING)
+#define IS_FLEX(m) IS ((m), FLEX_SYMBOL)
+#define IS_LITERALLY(p, s) (strcmp (NSYMBOL (p), s) == 0)
+#define ISNT(p, s) (! IS (p, s))
+#define IS(p, s) (ATTRIBUTE (p) == (s))
+#define IS_REF_FLEX(m) (IS (m, REF_SYMBOL) && IS (SUB (m), FLEX_SYMBOL))
+#define IS_REF(m) IS ((m), REF_SYMBOL)
+#define IS_INTEGRAL(m)					  \
+  ((m) == M_INT						  \
+   || (m) == M_LONG_INT					  \
+   || (m) == M_LONG_LONG_INT				  \
+   || (m) == M_SHORT_INT				  \
+   || (m) == M_SHORT_SHORT_INT)
+#define IS_BITS(m)						  \
+  ((m) == M_BITS						  \
+   || (m) == M_LONG_BITS					  \
+   || (m) == M_LONG_LONG_BITS					  \
+   || (m) == M_SHORT_BITS					  \
+   || (m) == M_SHORT_SHORT_BITS)
+#define IS_REAL(m)				\
+  ((m) == M_REAL				\
+   || (m) == M_LONG_REAL			\
+   || (m) == M_LONG_LONG_REAL)
+#define IS_ROW(m) IS ((m), ROW_SYMBOL)
+#define IS_STRUCT(m) IS ((m), STRUCT_SYMBOL)
+#define IS_UNION(m) IS ((m), UNION_SYMBOL)
+#define YOUNGEST_ENVIRON(p) ((p)->youngest_environ)
+
+#endif /* ! __A68_TYPES_H */
diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
new file mode 100644
index 00000000000..298b4044dfa
--- /dev/null
+++ b/gcc/algol68/a68.h
@@ -0,0 +1,1042 @@
+/* Definitions for the Algol 68 GCC front end.
+   Copyright (C) 2025 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_H__
+#define __A68_H__
+
+/* Some common definitions first.  */
+
+#define BUFFER_SIZE 1024
+#define SMALL_BUFFER_SIZE 128
+#define SNPRINTF_SIZE ((size_t) (BUFFER_SIZE - 1))
+#define BUFCLR(z) {memset ((z), 0, BUFFER_SIZE + 1);}
+#define MOID_ERROR_WIDTH 80
+
+#define MONADS "%^&+-~!?"
+#define NOMADS "></=*"
+
+/* Maximum number of priorities supported for operators.  The Algol 68 RR
+   specifies 9.  */
+
+#define MAX_PRIORITY 9
+
+/* The primal scope is the top-level scope.  */
+
+#define PRIMAL_SCOPE 0
+
+/* Deflexing strategy.  See the moid checking routines in
+   a68-parser-moids-check for an explanation of these values.  */
+
+enum
+{
+  NO_DEFLEXING = 1, SAFE_DEFLEXING, ALIAS_DEFLEXING, FORCE_DEFLEXING,
+  SKIP_DEFLEXING
+};
+
+/* Then the types.  */
+
+#include "a68-types.h"
+
+/* Front-end global state.  */
+
+extern A68_T a68_common;
+#define A68(z)             (a68_common.z)
+#define A68_JOB            A68 (job)
+#define A68_STANDENV       A68 (standenv)
+#define A68_MCACHE(z)      A68 (mode_cache.z)
+#define A68_INCLUDE_PATHS  A68 (include_paths)
+
+/* Particular pre-defined modes.  */
+
+#define MODE(p)        A68 (a68_modes.p)
+#define M_BITS (MODE (BITS))
+#define M_BOOL (MODE (BOOL))
+#define M_BYTES (MODE (BYTES))
+#define M_CHANNEL (MODE (CHANNEL))
+#define M_CHAR (MODE (CHAR))
+#define M_COLLITEM (MODE (COLLITEM))
+#define M_COMPLEX (MODE (COMPLEX))
+#define M_C_STRING (MODE (C_STRING))
+#define M_ERROR (MODE (ERROR))
+#define M_FILE (MODE (FILE))
+#define M_FLEX_ROW_BOOL (MODE (FLEX_ROW_BOOL))
+#define M_FLEX_ROW_CHAR (MODE (FLEX_ROW_CHAR))
+#define M_FORMAT (MODE (FORMAT))
+#define M_HIP (MODE (HIP))
+#define M_INT (MODE (INT))
+#define M_LONG_BITS (MODE (LONG_BITS))
+#define M_LONG_BYTES (MODE (LONG_BYTES))
+#define M_LONG_COMPLEX (MODE (LONG_COMPLEX))
+#define M_LONG_INT (MODE (LONG_INT))
+#define M_LONG_LONG_INT (MODE (LONG_LONG_INT))
+#define M_LONG_LONG_BITS (MODE (LONG_LONG_BITS))
+#define M_LONG_LONG_COMPLEX (MODE (LONG_LONG_COMPLEX))
+#define M_LONG_LONG_INT (MODE (LONG_LONG_INT))
+#define M_LONG_LONG_REAL (MODE (LONG_LONG_REAL))
+#define M_LONG_REAL (MODE (LONG_REAL))
+#define M_NIL (MODE (NIL))
+#define M_NUMBER (MODE (NUMBER))
+#define M_PROC_LONG_REAL_LONG_REAL (MODE (PROC_LONG_REAL_LONG_REAL))
+#define M_PROC_REAL_REAL (MODE (PROC_REAL_REAL))
+#define M_PROC_REF_FILE_BOOL (MODE (PROC_REF_FILE_BOOL))
+#define M_PROC_REF_FILE_VOID (MODE (PROC_REF_FILE_VOID))
+#define M_PROC_ROW_CHAR (MODE (PROC_ROW_CHAR))
+#define M_PROC_STRING (MODE (PROC_STRING))
+#define M_PROC_VOID (MODE (PROC_VOID))
+#define M_REAL (MODE (REAL))
+#define M_REF_BITS (MODE (REF_BITS))
+#define M_REF_BOOL (MODE (REF_BOOL))
+#define M_REF_BYTES (MODE (REF_BYTES))
+#define M_REF_CHAR (MODE (REF_CHAR))
+#define M_REF_COMPLEX (MODE (REF_COMPLEX))
+#define M_REF_FILE (MODE (REF_FILE))
+#define M_REF_INT (MODE (REF_INT))
+#define M_REF_LONG_BITS (MODE (REF_LONG_BITS))
+#define M_REF_LONG_BYTES (MODE (REF_LONG_BYTES))
+#define M_REF_LONG_COMPLEX (MODE (REF_LONG_COMPLEX))
+#define M_REF_LONG_INT (MODE (REF_LONG_INT))
+#define M_REF_LONG_LONG_BITS (MODE (REF_LONG_LONG_BITS))
+#define M_REF_LONG_LONG_COMPLEX (MODE (REF_LONG_LONG_COMPLEX))
+#define M_REF_LONG_LONG_INT (MODE (REF_LONG_LONG_INT))
+#define M_REF_LONG_LONG_REAL (MODE (REF_LONG_LONG_REAL))
+#define M_REF_LONG_REAL (MODE (REF_LONG_REAL))
+#define M_REF_REAL (MODE (REF_REAL))
+#define M_REF_REF_FILE (MODE (REF_REF_FILE))
+#define M_REF_SHORT_BITS (MODE (REF_SHORT_BITS))
+#define M_REF_SHORT_SHORT_BITS (MODE (REF_SHORT_SHORT_BITS))
+#define M_REF_ROW_CHAR (MODE (REF_ROW_CHAR))
+#define M_REF_ROW_COMPLEX (MODE (REF_ROW_COMPLEX))
+#define M_REF_ROW_INT (MODE (REF_ROW_INT))
+#define M_REF_ROW_REAL (MODE (REF_ROW_REAL))
+#define M_REF_ROW_ROW_COMPLEX (MODE (REF_ROW_ROW_COMPLEX))
+#define M_REF_ROW_ROW_REAL (MODE (REF_ROW_ROW_REAL))
+#define M_REF_SHORT_INT (MODE (REF_SHORT_INT))
+#define M_REF_SHORT_SHORT_INT (MODE (REF_SHORT_SHORT_INT))
+#define M_REF_STRING (MODE (REF_STRING))
+#define M_ROW_BITS (MODE (ROW_BITS))
+#define M_ROW_BOOL (MODE (ROW_BOOL))
+#define M_ROW_CHAR (MODE (ROW_CHAR))
+#define M_ROW_COMPLEX (MODE (ROW_COMPLEX))
+#define M_ROW_INT (MODE (ROW_INT))
+#define M_ROW_REAL (MODE (ROW_REAL))
+#define M_ROW_ROW_CHAR (MODE (ROW_ROW_CHAR))
+#define M_ROW_ROW_COMPLEX (MODE (ROW_ROW_COMPLEX))
+#define M_ROW_ROW_REAL (MODE (ROW_ROW_REAL))
+#define M_ROW_SIMPLIN (MODE (ROW_SIMPLIN))
+#define M_ROW_SIMPLOUT (MODE (ROW_SIMPLOUT))
+#define M_ROWS (MODE (ROWS))
+#define M_ROW_STRING (MODE (ROW_STRING))
+#define M_SEMA (MODE (SEMA))
+#define M_SHORT_BITS (MODE (SHORT_BITS))
+#define M_SHORT_SHORT_BITS (MODE (SHORT_SHORT_BITS))
+#define M_SHORT_INT (MODE (SHORT_INT))
+#define M_SHORT_SHORT_INT (MODE (SHORT_SHORT_INT))
+#define M_SIMPLIN (MODE (SIMPLIN))
+#define M_SIMPLOUT (MODE (SIMPLOUT))
+#define M_STRING (MODE (STRING))
+#define M_UNDEFINED (MODE (UNDEFINED))
+#define M_VACUUM (MODE (VACUUM))
+#define M_VOID (MODE (VOID))
+
+/* Usage of TYPE_LANG_FLAG_* flags.  */
+
+#define A68_ROW_TYPE_P(NODE) TYPE_LANG_FLAG_0 (NODE)
+#define A68_UNION_TYPE_P(NODE) TYPE_LANG_FLAG_1 (NODE)
+#define A68_STRUCT_TYPE_P(NODE) TYPE_LANG_FLAG_2 (NODE)
+#define A68_ROWS_TYPE_P(NODE) TYPE_LANG_FLAG_3 (NODE)
+#define A68_TYPE_HAS_ROWS_P(NODE) TYPE_LANG_FLAG_4 (NODE)
+
+/* Language-specific tree checkers.  */
+
+#define STRUCT_OR_UNION_TYPE_CHECK(NODE) \
+  TREE_CHECK2 (NODE, RECORD_TYPE, UNION_TYPE)
+
+/* Usage of TYPE_LANG_SLOT_* fields.  */
+
+#define TYPE_FORWARD_REFERENCES(NODE) \
+  (TYPE_LANG_SLOT_1 (STRUCT_OR_UNION_TYPE_CHECK (NODE)))
+
+/* Parser global state.  */
+
+extern PARSER_T a68_parser_state;
+#define A68_PARSER(Z) (a68_parser_state.Z)
+
+/* a68-unistr.cc */
+
+int a68_u8_mbtouc (uint32_t *puc, const uint8_t *s, size_t n);
+int a68_u8_uctomb (uint8_t *s, uint32_t uc, ptrdiff_t n);
+
+uint32_t *a68_u8_to_u32 (const uint8_t *s, size_t n, uint32_t *resultbuf, size_t *lengthp);
+
+/* a68-lang.cc */
+
+enum a68_tree_index
+{
+  /* Type trees.  */
+  ATI_VOID_TYPE,
+  ATI_BOOL_TYPE,
+  ATI_CHAR_TYPE,
+  ATI_SHORT_SHORT_BITS_TYPE,
+  ATI_SHORT_BITS_TYPE,
+  ATI_BITS_TYPE,
+  ATI_LONG_BITS_TYPE,
+  ATI_LONG_LONG_BITS_TYPE,
+  ATI_BYTES_TYPE,
+  ATI_LONG_BYTES_TYPE,
+  ATI_SHORT_SHORT_INT_TYPE,
+  ATI_SHORT_INT_TYPE,
+  ATI_INT_TYPE,
+  ATI_LONG_INT_TYPE,
+  ATI_LONG_LONG_INT_TYPE,
+  ATI_REAL_TYPE,
+  ATI_LONG_REAL_TYPE,
+  ATI_LONG_LONG_REAL_TYPE,
+  /* Sentinel.  */
+  ATI_MAX
+};
+
+extern GTY(()) tree a68_global_trees[ATI_MAX];
+
+#define a68_void_type               a68_global_trees[ATI_VOID_TYPE]
+#define a68_bool_type               a68_global_trees[ATI_BOOL_TYPE]
+#define a68_char_type               a68_global_trees[ATI_CHAR_TYPE]
+#define a68_short_short_bits_type   a68_global_trees[ATI_SHORT_SHORT_BITS_TYPE]
+#define a68_short_bits_type         a68_global_trees[ATI_SHORT_BITS_TYPE]
+#define a68_bits_type               a68_global_trees[ATI_BITS_TYPE]
+#define a68_long_bits_type          a68_global_trees[ATI_LONG_BITS_TYPE]
+#define a68_long_long_bits_type     a68_global_trees[ATI_LONG_LONG_BITS_TYPE]
+#define a68_bytes_type              a68_global_trees[ATI_BYTES_TYPE]
+#define a68_long_bytes_type         a68_global_trees[ATI_LONG_BYTES_TYPE]
+#define a68_short_short_int_type    a68_global_trees[ATI_SHORT_SHORT_INT_TYPE]
+#define a68_short_int_type          a68_global_trees[ATI_SHORT_INT_TYPE]
+#define a68_int_type                a68_global_trees[ATI_INT_TYPE]
+#define a68_long_int_type           a68_global_trees[ATI_LONG_INT_TYPE]
+#define a68_long_long_int_type      a68_global_trees[ATI_LONG_LONG_INT_TYPE]
+#define a68_real_type               a68_global_trees[ATI_REAL_TYPE]
+#define a68_long_real_type          a68_global_trees[ATI_LONG_REAL_TYPE]
+#define a68_long_long_real_type     a68_global_trees[ATI_LONG_LONG_REAL_TYPE]
+
+struct lang_type *a68_build_lang_type (MOID_T *moid);
+struct lang_decl *a68_build_lang_decl (NODE_T *node);
+MOID_T *a68_type_moid (tree type);
+
+/* a68-diagnostics.cc  */
+
+void a68_error (NODE_T *p, const char *loc_str, ...);
+int 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, ...);
+
+/* a68-parser-scanner.cc  */
+
+bool a68_lexical_analyser (const char *filename);
+
+/* a68-parser.cc  */
+
+int a68_count_operands (NODE_T *p);
+int a68_count_formal_bounds (NODE_T *p);
+void a68_count_pictures (NODE_T *p, int *k);
+bool a68_is_ref_refety_flex (MOID_T *m);
+bool a68_is_semicolon_less (NODE_T *p);
+bool a68_is_formal_bounds (NODE_T *p);
+bool a68_is_unit_terminator (NODE_T *p);
+bool a68_is_loop_keyword (NODE_T *p);
+bool a68_is_new_lexical_level (NODE_T *p);
+bool a68_dont_mark_here (NODE_T *p);
+enum a68_attribute a68_get_good_attribute (NODE_T *p);
+void a68_parser (const char *filename);
+NODE_INFO_T *a68_new_node_info (void);
+GINFO_T *a68_new_genie_info (void);
+NODE_T *a68_new_node (void);
+NODE_T *a68_some_node (const char *t);
+TABLE_T *a68_new_symbol_table (TABLE_T *p);
+MOID_T *a68_new_moid (void);
+PACK_T *a68_new_pack (void);
+TAG_T *a68_new_tag (void);
+void a68_make_special_mode (MOID_T **, int m);
+void a68_make_sub (NODE_T *p, NODE_T *, enum a68_attribute t);
+bool a68_whether (NODE_T *, ...);
+bool a68_is_one_of (NODE_T *p, ...);
+void a68_bufcat (char *dst, const char *src, int len);
+void a68_bufcpy (char *dst, const char *src, int len);
+char *a68_new_string (const char *t, ...);
+const char *a68_attribute_name (enum a68_attribute attr);
+location_t a68_get_node_location (NODE_T *p);
+location_t a68_get_line_location (LINE_T *line, const char *pos);
+
+/* a68-parser-top-down.cc  */
+
+void a68_substitute_brackets (NODE_T *p);
+char *a68_phrase_to_text (NODE_T *p, NODE_T **w);
+void a68_top_down_parser (NODE_T *p);
+
+/* a68-parser-bottom-up.cc  */
+
+void a68_bottom_up_parser (NODE_T *p);
+void a68_bottom_up_error_check (NODE_T *p);
+void a68_rearrange_goto_less_jumps (NODE_T *p);
+
+/* a68-parser-extract.cc  */
+
+void a68_extract_indicants (NODE_T *p);
+void a68_extract_priorities (NODE_T *p);
+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);
+
+/* a68-parser-keywords.cc  */
+
+void a68_set_up_tables (void);
+TOKEN_T *a68_add_token (TOKEN_T **p, const char *t);
+KEYWORD_T *a68_find_keyword (KEYWORD_T *p, const char *t);
+KEYWORD_T *a68_find_keyword_from_attribute (KEYWORD_T *p, enum a68_attribute a);
+
+/* a68-postulates.cc  */
+
+void a68_init_postulates (void);
+void a68_free_postulate_list (POSTULATE_T *, POSTULATE_T *);
+void a68_make_postulate (POSTULATE_T **, MOID_T *, MOID_T *);
+POSTULATE_T *a68_is_postulated (POSTULATE_T *, MOID_T *);
+POSTULATE_T *a68_is_postulated_pair (POSTULATE_T *, MOID_T *, MOID_T *);
+
+/* a68-parser-moids-check.cc  */
+
+void a68_mode_checker (NODE_T *p);
+
+/* a68-parser-moids-coerce.cc */
+
+void a68_coercion_inserter (NODE_T *p);
+
+/* a68-parser-moids-equivalence.cc  */
+
+bool a68_prove_moid_equivalence (MOID_T *, MOID_T *);
+
+/* a68-parser-brackets.cc  */
+
+void a68_check_parenthesis (NODE_T *top);
+
+/* a68-parser-prelude.cc  */
+
+void a68_make_standard_environ (void);
+
+/* a68-parser-taxes.cc  */
+
+void a68_set_proc_level (NODE_T *p, int n);
+void a68_set_nest (NODE_T *p, NODE_T *s);
+int a68_first_tag_global (TABLE_T * table, const char *name);
+void a68_collect_taxes (NODE_T *p);
+TAG_T *a68_add_tag (TABLE_T *s, int a, NODE_T *n, MOID_T *m, int p);
+TAG_T *a68_find_tag_global (TABLE_T *table, int a, const char *name);
+int a68_is_identifier_or_label_global (TABLE_T *table, const char *name);
+void a68_reset_symbol_table_nest_count (NODE_T *p);
+void a68_bind_routine_tags_to_tree (NODE_T *p);
+void a68_fill_symbol_table_outer (NODE_T *p, TABLE_T *s);
+void a68_finalise_symbol_table_setup (NODE_T *p, int l);
+void a68_preliminary_symbol_table_setup (NODE_T *p);
+void a68_mark_moids (NODE_T *p);
+void a68_mark_auxilliary (NODE_T *p);
+void a68_warn_for_unused_tags (NODE_T *p);
+void a68_jumps_from_procs (NODE_T *p);
+
+/* a68-parser-victal.cc  */
+
+void a68_victal_checker (NODE_T *p);
+
+/* a68-parser-modes.cc  */
+
+int a68_count_pack_members (PACK_T *u);
+MOID_T *a68_register_extra_mode (MOID_T **z, MOID_T *u);
+MOID_T *a68_add_mode (MOID_T **z, int att, int dim, NODE_T *node, MOID_T *sub, PACK_T *pack);
+void a68_contract_union (MOID_T *u);
+PACK_T *a68_absorb_union_pack (PACK_T * u);
+void a68_add_mode_to_pack (PACK_T **p, MOID_T *m, const char *text, NODE_T *node);
+void a68_add_mode_to_pack_end (PACK_T **p, MOID_T *m, const char *text, NODE_T *node);
+void a68_make_moid_list (MODULE_T *mod);
+
+void a68_renumber_moids (MOID_T *p, int n);
+
+/* a68-moids-to-string.cc  */
+
+char *a68_moid_to_string (MOID_T *n, size_t w, NODE_T *idf,
+			  bool indicant_value = false);
+
+/* a68-moids-misc.cc  */
+
+bool a68_basic_coercions (MOID_T *p, MOID_T *q, int c, int deflex);
+bool a68_clause_allows_balancing (int att);
+bool a68_is_balanced (NODE_T *n, SOID_T *y, int sort);
+bool a68_is_coercible_in_context (SOID_T *p, SOID_T *q, int deflex);
+bool a68_is_coercible (MOID_T *p, MOID_T *q, int c, int deflex);
+bool a68_is_coercible_series (MOID_T *p, MOID_T *q, int c, int deflex);
+bool a68_is_coercible_stowed (MOID_T *p, MOID_T *q, int c, int deflex);
+bool a68_is_deprefable (MOID_T *p);
+bool a68_is_equal_modes (MOID_T *p, MOID_T *q, int deflex);
+bool a68_is_firmly_coercible (MOID_T *p, MOID_T *q, int deflex);
+bool a68_is_firm (MOID_T *p, MOID_T *q);
+bool a68_is_meekly_coercible (MOID_T *p, MOID_T *q, int deflex);
+bool a68_is_mode_isnt_well (MOID_T *p);
+bool a68_is_moid_in_pack (MOID_T *u, PACK_T *v, int deflex);
+bool a68_is_name_struct (MOID_T *p);
+bool a68_is_nonproc (MOID_T *p);
+bool a68_is_printable_mode (MOID_T *p);
+bool a68_is_proc_ref_file_void_or_format (MOID_T *p);
+bool a68_is_readable_mode (MOID_T *p);
+bool a68_is_ref_row (MOID_T *p);
+bool a68_is_rows_type (MOID_T *p);
+bool a68_is_softly_coercible (MOID_T *p, MOID_T *q, int deflex);
+bool a68_is_strongly_coercible (MOID_T *p, MOID_T *q, int deflex);
+bool a68_is_strong_name (MOID_T *p, MOID_T *q);
+bool a68_is_strong_slice (MOID_T *p, MOID_T *q);
+bool a68_is_subset (MOID_T *p, MOID_T *q, int deflex);
+bool a68_is_transput_mode (MOID_T *p, char rw);
+bool a68_is_unitable (MOID_T *p, MOID_T *q, int deflex);
+bool a68_is_weakly_coercible (MOID_T * p, MOID_T * q, int deflex);
+bool a68_is_widenable (MOID_T *p, MOID_T *q);
+MOID_T *a68_absorb_related_subsets (MOID_T *m);
+MOID_T *a68_depref_completely (MOID_T *p);
+MOID_T *a68_depref_once (MOID_T *p);
+MOID_T *a68_depref_rows (MOID_T *p, MOID_T *q);
+MOID_T *a68_deproc_completely (MOID_T *p);
+MOID_T *a68_derow (MOID_T *p);
+MOID_T *a68_determine_unique_mode (SOID_T *z, int deflex);
+MOID_T *a68_get_balanced_mode (MOID_T *m, int sort, bool return_depreffed, int deflex);
+MOID_T *a68_get_balanced_mode_or_no_mode (MOID_T *m, int sort, bool return_depreffed, int deflex);
+MOID_T *a68_make_series_from_moids (MOID_T *u, MOID_T *v);
+MOID_T *a68_make_united_mode (MOID_T *m);
+MOID_T *a68_pack_soids_in_moid (SOID_T *top_sl, int attribute);
+MOID_T *a68_unites_to (MOID_T *m, MOID_T *u);
+void a68_absorb_series_pack (MOID_T **p);
+void a68_absorb_series_union_pack (MOID_T **p);
+void a68_add_to_soid_list (SOID_T **root, NODE_T *where, SOID_T *soid);
+void a68_free_soid_list (SOID_T *root);
+void a68_investigate_firm_relations (PACK_T *u, PACK_T *v, bool *all, bool *some);
+void a68_make_coercion (NODE_T *l, enum a68_attribute a, MOID_T *m);
+void a68_make_depreffing_coercion (NODE_T *n, MOID_T *p, MOID_T *q);
+void a68_make_ref_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q);
+void a68_make_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q);
+void a68_make_soid (SOID_T *s, int sort, MOID_T *type, int attribute);
+void a68_make_strong (NODE_T *n, MOID_T *p, MOID_T *q);
+void a68_make_uniting_coercion (NODE_T *n, MOID_T *q);
+void a68_make_void (NODE_T *p, MOID_T *q);
+
+#define A68_DEPREF true
+#define A68_NO_DEPREF false
+
+#define A68_IF_MODE_IS_WELL(n) (! ((n) == M_ERROR || (n) == M_UNDEFINED))
+
+/* a68-parser-scope.cc  */
+
+void a68_scope_checker (NODE_T *p);
+
+/* a68-parser-serial-dsa.cc  */
+
+void a68_serial_dsa (NODE_T *p);
+
+/* a68-moids-diagnostics.cc  */
+
+char *a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, int depth);
+void a68_cannot_coerce (NODE_T *p, MOID_T *from, MOID_T *to, int context, int deflex, int att);
+void a68_warn_for_voiding (NODE_T *p, SOID_T *x, SOID_T *y, int c);
+void a68_semantic_pitfall (NODE_T *p, MOID_T *m, int c, int u);
+
+/* a68-low-misc.cc  */
+
+tree a68_lower_assertion (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_jump (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_parameter (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_parameter_list (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_parameter_pack (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_operator (NODE_T *p, LOW_CTX_T ctx);
+
+/* a68-low-moids.cc  */
+
+void a68_lower_moids (MOID_T *m);
+void a68_set_type_moid (tree type, MOID_T *m);
+tree a68_row_elements_pointer_type (tree type);
+tree a68_row_elements_type (tree type);
+tree a68_triplet_type (void);
+
+/* a68-low-bits.cc */
+
+tree a68_get_bits_skip_tree (MOID_T *m);
+tree a68_bits_width (tree type);
+tree a68_bits_maxbits (tree type);
+tree a68_bits_bin (MOID_T *m, tree val);
+tree a68_bits_abs (MOID_T *m, tree bits);
+tree a68_bits_leng (tree type, tree bits);
+tree a68_bits_shorten (tree type, tree bits);
+tree a68_bits_not (tree bits);
+tree a68_bits_and (tree bits1, tree bits2);
+tree a68_bits_ior (tree bits1, tree bits2);
+tree a68_bits_xor (tree bits1, tree bits2);
+tree a68_bits_elem (NODE_T *p, tree pos, tree bits);
+tree a68_bits_subset (tree bits1, tree bits2);
+tree a68_bits_shift (tree shift, tree bits);
+tree a68_bits_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_bits_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+
+/* a68-low_bools.cc  */
+
+tree a68_get_bool_skip_tree (void);
+tree a68_bool_abs (tree val);
+tree a68_bool_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_bool_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+
+/* a68-low-ints.cc  */
+
+tree a68_get_int_skip_tree (MOID_T *m);
+tree a68_int_maxval (tree type);
+tree a68_int_minval (tree type);
+tree a68_int_width (tree type);
+tree a68_int_sign (tree val);
+tree a68_int_abs (tree val);
+tree a68_int_shorten (MOID_T *to_mode, MOID_T *from_mode, tree val);
+tree a68_int_leng (MOID_T *to_mode, MOID_T *from_mode, tree val);
+
+tree a68_int_plus (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_minus (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_mult (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_div (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_mod (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_pow (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_lt (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_le (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_gt (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_int_ge (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+
+/* a68-low-complex.cc  */
+
+tree a68_complex_i (MOID_T *mode, tree re, tree im);
+tree a68_complex_re (tree z);
+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_setexitstatus (void);
+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_errno (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);
+tree a68_real_pi (tree type);
+tree a68_real_maxval (tree type);
+tree a68_real_minval (tree type);
+tree a68_real_smallval (tree type);
+tree a68_real_width (tree type);
+tree a68_real_exp_width (tree type);
+tree a68_real_sign (tree val);
+tree a68_real_abs (tree val);
+tree a68_real_sqrt (tree val);
+tree a68_real_tan (tree type);
+tree a68_real_sin (tree type);
+tree a68_real_cos (tree type);
+tree a68_real_acos (tree type);
+tree a68_real_asin (tree type);
+tree a68_real_atan (tree type);
+tree a68_real_ln (tree type);
+tree a68_real_log (tree type);
+tree a68_real_exp (tree type);
+tree a68_real_shorten (MOID_T *to_mode, MOID_T *from_mode, tree val);
+tree a68_real_leng (MOID_T *to_mode, MOID_T *from_mode, tree val);
+tree a68_real_entier (tree val, MOID_T *to_mode, MOID_T *from_mode);
+tree a68_real_round (tree val, MOID_T *to_mode, MOID_T *from_mode);
+
+tree a68_real_plus (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_minus (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_mult (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_div (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_mod (MOID_T *m, tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_pow (MOID_T *m, MOID_T *a_mode, MOID_T *b_mode,
+		   tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_lt (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_le (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_gt (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_real_ge (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+
+
+/* a68-low-strings.cc  */
+
+tree a68_get_string_skip_tree (void);
+tree a68_string_concat (tree str1, tree str2);
+tree a68_string_mult (tree str1, tree str2);
+tree a68_string_from_char (tree c);
+tree a68_string_cmp (tree s1, tree s2);
+char *a68_string_process_breaks (const char *str);
+
+/* a68-low-chars.cc */
+
+tree a68_get_char_skip_tree (void);
+tree a68_char_max (void);
+tree a68_char_repr (NODE_T *p, tree val);
+tree a68_char_abs (tree val);
+tree a68_char_eq (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_char_ne (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_char_lt (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_char_le (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_char_gt (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+tree a68_char_ge (tree a, tree b, location_t loc = UNKNOWN_LOCATION);
+
+/* a68-low-refs.cc  */
+
+tree a68_get_ref_skip_tree (MOID_T *m);
+
+/* a68-low-procs.cc  */
+
+tree a68_get_proc_skip_tree (MOID_T *m);
+
+/* a68-low-structs.cc  */
+
+tree a68_get_struct_skip_tree (MOID_T *m);
+
+/* a68-low-multiples.cc  */
+
+tree a68_get_multiple_skip_tree (MOID_T *m);
+tree a68_multiple_dimensions (tree exp);
+tree a68_multiple_num_elems (tree exp);
+tree a68_multiple_lower_bound (tree exp, tree dim);
+tree a68_multiple_upper_bound (tree exp, tree dim);
+tree a68_multiple_stride (tree exp, tree dim);
+tree a68_multiple_triplets (tree exp);
+tree a68_multiple_elements (tree exp);
+tree a68_multiple_elements_size (tree exp);
+tree a68_multiple_set_elements (tree exp, tree elements);
+tree a68_multiple_set_elements_size (tree exp, tree elements_size);
+void a68_multiple_compute_strides (tree type, size_t dim,
+				   tree *lower_bounds, tree *upper_bounds,
+				   tree *strides);
+tree a68_multiple_set_lower_bound (tree exp, tree dim, tree bound);
+tree a68_multiple_set_upper_bound (tree exp, tree dim, tree bound);
+tree a68_multiple_set_stride (tree exp, tree dim, tree stride);
+tree a68_row_value (tree type, size_t dim,
+		    tree elements, tree elements_size,
+		    tree *lower_bound, tree *upper_bound);
+tree a68_row_value_raw (tree type, tree descriptor,
+			tree elements, tree elements_size);
+tree a68_row_malloc (tree type, int dim,
+		    tree elements, tree elements_size,
+		    tree *lower_bound, tree *upper_bound);		     
+tree a68_multiple_slice (NODE_T *p, tree multiple, bool slicing_name,
+			 int num_indexes, tree *indexes);
+tree a68_multiple_copy_elems (MOID_T *to_mode, tree to, tree from);
+tree a68_rows_dim (tree exp);
+tree a68_rows_value (tree multiple);
+tree a68_rows_lower_bound (tree rows, tree dim);
+tree a68_rows_upper_bound (tree rows, tree dim);
+tree a68_rows_dim_check (NODE_T *p, tree rows, tree dim);
+tree a68_multiple_dim_check (NODE_T *p, tree multiple, tree dim);
+tree a68_multiple_single_bound_check (NODE_T *p, tree dim, tree multiple,
+				      tree index, bool upper_bound);
+tree a68_multiple_bounds_check (NODE_T *p, tree dim, tree multiple,
+				tree index);
+tree a68_multiple_bounds_check_equal (NODE_T *p, tree m1, tree m2);
+
+/* a68-low-ranges.cc  */
+
+bool a68_in_global_range (void);
+void a68_init_ranges (void);
+void a68_push_range (MOID_T *mode);
+tree a68_pop_range (void);
+tree a68_pop_range_with_finalizer (tree *finalizer);
+void a68_push_stmt_list (MOID_T *mode);
+tree a68_pop_stmt_list (void);
+void a68_push_function_range (tree fndel, tree result_type,
+			      bool top_level = false);
+void a68_pop_function_range (tree body);
+void a68_push_serial_clause_range (MOID_T *clause_mode,
+				   bool save_restore_stack = false);
+tree a68_pop_serial_clause_range (void);
+void a68_add_stmt (tree exp);
+void a68_add_decl (tree decl);
+void a68_add_decl_expr (tree decl_expr);
+void a68_add_completer (void);
+tree a68_range_context (void);
+tree a68_range_names (void);
+tree a68_range_stmt_list (void);
+
+/* a68-low-runtime.cc */
+
+enum a68_libcall_fn
+{
+#define DEF_A68_RUNTIME(CODE, N, T, P, F) A68_LIBCALL_ ## CODE,
+#include "a68-low-runtime.def"
+#undef DEF_A68_RUNTIME
+  A68_LIBCALL_LAST
+};
+
+tree a68_get_libcall (a68_libcall_fn libcall);
+tree a68_build_libcall (a68_libcall_fn libcall, tree type, int nargs, ...);
+
+/* a68-low-clauses.cc  */
+
+void a68_begin_serial_clause (LOW_CTX_T *ctx, MOID_T *clause_mode);
+tree a68_finish_serial_clause (LOW_CTX_T ctx, MOID_T *clause_mode, tree parent_block);
+tree a68_lower_label (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_labeled_unit (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_completer (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_initialiser_series (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_serial_clause (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_loop_clause (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_conformity_clause (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_case_clause (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_enquiry_clause (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_conditional_clause (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_unit_list (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_collateral_clause (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_parallel_clause (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_closed_clause (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_enclosed_clause (NODE_T *p, LOW_CTX_T ctx);
+
+/* a68-low-coercions.cc */
+
+tree a68_lower_dereferencing (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_rowing (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_widening (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_deproceduring (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_proceduring (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_voiding (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_uniting (NODE_T *p, LOW_CTX_T ctx);
+
+/* a68-low-decls.cc */
+
+tree a68_lower_mode_declaration (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_variable_declaration (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_identity_declaration (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_procedure_declaration (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_procedure_variable_declaration (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_declarer (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_declaration_list (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_priority_declaration (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_brief_operator_declaration (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_operator_declaration (NODE_T *p, LOW_CTX_T ctx);
+
+/* a68-low.cc  */
+
+tree a68_lower_top_tree (NODE_T *p);
+tree a68_lower_tree (NODE_T *p, LOW_CTX_T ctx);
+tree a68_make_identity_declaration_decl (NODE_T *identifier);
+tree a68_make_variable_declaration_decl (NODE_T *identifier);
+tree a68_make_proc_identity_declaration_decl (NODE_T *identifier);
+tree a68_make_anonymous_routine_decl (MOID_T *mode);
+tree a68_get_skip_tree (MOID_T *m);
+tree a68_get_empty (void);
+void a68_ref_counts (tree exp, MOID_T *m, int *num_refs, int *num_pointers);
+tree a68_consolidate_ref (MOID_T *m, tree expr);
+tree a68_lower_alloca (tree type, tree size);
+tree a68_lower_malloc (tree type, tree size);
+tree a68_checked_indirect_ref (NODE_T *p, tree exp, MOID_T *exp_mode);
+tree a68_low_deref (tree exp, NODE_T *p);
+tree a68_low_dup (tree exp, bool use_heap = false);
+tree a68_low_ascription (MOID_T *mode, tree lhs, tree rhs);
+tree a68_low_assignation (NODE_T *p, tree lhs, MOID_T *lhs_mode, tree rhs, MOID_T *rhs_mode);
+tree a68_lower_memcpy (tree dst, tree src, tree size);
+tree a68_lower_tmpvar (const char *name, tree type, tree init);
+tree a68_get_mangled_identifier (const char *name);
+tree a68_low_toplevel_func_decl (const char *name, tree fntype);
+tree a68_low_func_param (tree fndecl, const char *name, tree type);
+
+/* a68-low-builtins.cc */
+
+void a68_install_builtins ();
+
+/* a68-low-unions.c  */
+
+int a68_united_mode_index (MOID_T *p, MOID_T *q);
+tree a68_get_union_skip_tree (MOID_T *m);
+tree a68_union_overhead (tree exp);
+tree a68_union_set_overhead (tree exp, tree overhead);
+tree a68_union_cunion (tree exp);
+tree a68_union_alternative (tree exp, int index);
+tree a68_union_value (MOID_T *mode, tree exp, MOID_T *exp_mode);
+tree a68_union_translate_overhead (MOID_T *from, tree from_overhead, MOID_T *to);
+bool a68_union_contains_mode (MOID_T *p, MOID_T *q);
+
+/* a68-low-units.cc  */
+
+tree a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_denotation (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_denotation (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_skip (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_nihil (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_empty (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_identity_relation (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_logic_function (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_primary (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_cast (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_secondary (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_slice (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_selection (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_formula (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_monadic_formula (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_tertiary (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_assignation (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_routine_text (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_generator (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_call (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_unit (NODE_T *p, LOW_CTX_T ctx);
+
+/* a68-low-generator.c  */
+
+tree a68_low_generator (NODE_T *declarer, MOID_T *mode,
+			bool heap, LOW_CTX_T ctx);
+tree a68_low_gen (MOID_T *m, size_t nbuonds, tree *bounds,
+		  bool use_heap);
+
+/* a68-low-prelude.c  */
+
+tree a68_lower_unimplemented (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_assert (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_intabs2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_realabs2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_boolabs2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_charabs2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_not2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_and3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_or3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_xor3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_confirm2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_negate2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_sign2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_realsign2 (NODE_T *p, LOW_CTX_T ctx);
+
+tree a68_lower_plus_int (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_plus_real (NODE_T *p, LOW_CTX_T ctx);
+
+tree a68_lower_minus_int (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_minus_real (NODE_T *p, LOW_CTX_T ctx);
+
+tree a68_lower_mult_int (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_mult_real (NODE_T *p, LOW_CTX_T ctx);
+
+tree a68_lower_multab3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_div3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_divab3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_rdiv3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_over3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_mod3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_int_eq3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_int_ne3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_int_lt3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_int_le3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_int_gt3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_int_ge3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_real_eq3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_real_ne3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_real_lt3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_real_le3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_real_gt3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_real_ge3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_char_eq3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_char_ne3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_char_lt3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_char_le3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_char_gt3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_char_ge3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bool_eq3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bool_ne3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_plusab3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_minusab3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_overab3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_modab3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_upb2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_upb3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_lwb2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_lwb3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_elems2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_elems3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_entier2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_round2 (NODE_T *p, LOW_CTX_T ctx);
+
+tree a68_lower_pow_int (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_pow_real (NODE_T *p, LOW_CTX_T ctx);
+
+tree a68_lower_odd2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_eq3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_ne3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_lt3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_le3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_gt3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_ge3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_plus3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_char_plus3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_plusab3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_mult3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_char_mult3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_multab3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_string_plusto3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_repr2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitelem3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bin2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitabs2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitleng2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitshorten2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bit_eq3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bit_ne3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitnot2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitand3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitior3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitxor3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_shl3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_shr3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bit_eq3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bit_ne3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bit_le3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bit_ge3 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_maxint (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_minint (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_maxbits (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_maxreal (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_minreal (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_smallreal (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitswidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longbitswidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longlongbitswidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_shortbitswidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_shortshortbitswidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_intwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longintwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longlongintwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_shortintwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_shortshortintwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_realwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longrealwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longlongrealwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_expwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longexpwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longlongexpwidth (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_pi (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_nullcharacter (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_flip (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_flop (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_errorchar (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_blank (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_invalidchar (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_intlengths (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_intshorths (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitslengths (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_bitsshorths (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_reallengths (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_realshorths (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_infinity (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_minusinfinity (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_maxabschar (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_sqrt (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_sqrt (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_sqrt (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_tan (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_tan (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_tan (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_sin (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_sin (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_sin (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_cos (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_cos (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_cos (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_acos (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_acos (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_acos (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_asin (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_asin (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_asin (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_atan (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_atan (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_atan (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_ln (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_ln (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_ln (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_log (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_log (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_log (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_exp (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_exp (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_long_long_exp (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_reali (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longreali (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longlongreali (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_inti (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longinti (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longlonginti (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_re2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_im2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_conj2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_shortenint2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_lengint2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_lengreal2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_shortenreal2 (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_random (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longrandom (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_longlongrandom (NODE_T *p, LOW_CTX_T ctx);
+tree a68_lower_setexitstatus (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_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_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-parser-debug.cc  */
+
+void a68_dump_parse_tree (NODE_T *p);
+void a68_dump_modes (MOID_T *m);
+
+#endif /* ! __A68_H__ */
diff --git a/gcc/algol68/ga68.vw b/gcc/algol68/ga68.vw
new file mode 100644
index 00000000000..7f2c0eac9d9
--- /dev/null
+++ b/gcc/algol68/ga68.vw
@@ -0,0 +1,1837 @@
+{ ga68.vw - The GNU Algol 68 strict language -*- vw -*-
+
+  Copyright (C) 2025 Jose E. Marchesi <jemarch@gnu.org>
+
+  This program 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.
+
+  This program 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.  }
+
+{ This file contains an annotated description of the syntax of the GNU
+  Algol 68 strict language.  GNU Algol 68 aims to be a super-language
+  of Algol 68.
+
+  Extension to the strict Revised Report incorporated into GNU Algol
+  68 are:
+
+  [US] This is the GNU68-2025-001-unsafe GNU extension.  It adds an
+       unsafe clause that marks a controlled clause as containing
+       unsafe constructs which are known by the programmer, and makes
+       the compiler to avoid certain diagnostics.  See the GNU Algol
+       68 Compiler manual for more information.
+
+  [SC] This is the GNU68-2025-003-andth-orel GNU extension.  It adds
+       two units that act as pseudo-operators providing logical AND
+       and OR functions with short-circuited elaboration.  See the GNU
+       Algol 68 Compiler manual for more information.
+
+  [MR] A modules and separated compilation system based on the modules
+       system recomended by IFIP Working Group 2.1 Standing
+       Subcommittee on Algol 68 Support, described in:
+
+         A Modules and Separate Compilation Facility for Algol 68 by
+         Lindsey and Boom.
+
+  [NC] This is the GNU68-2025-005-nestable-comments GNU extension.  It
+       adds support for nestable block comments.
+
+  The metaproduction rules, hyper-rules and hyper-alternatives
+  introduced by each extension are clearly marked in the sections
+  below.  You can easily search for them using the extensions tags in
+  the list above.  For example, to look for the extensions introduced
+  by the modules and separated compilation system, search for [MR].
+
+  The few deviations to the RR Algol 68 are clearly marked as well in
+  this specification.
+
+  A complete description of the semantics of the Algol 68 subset of
+  the described language and the extensions is not included in this
+  file.  The reader is referred to the Revised Report and other
+  documentation corresponding to the extensions, like the GNU Algol 68
+  compiler manual.
+
+  The sectioning and the enumeration of metaproduction rules and of
+  hyper-rules, including cross-references, are the same than in the
+  Report.  The annotations and pragmatics added between curly brackets
+  explain the meaning of the rules and how they describe the syntax of
+  the language.  Note that thanks to the expressive power of VW
+  grammars the syntax expressed by this description covers much more
+  than what is usually expressed by context-free grammars in the
+  descriptions of other languages that typically use some variant of
+  the BNF notation.
+
+  Sample code in examples and pragmatics is expressed using the UPPER
+  stropping regime.
+
+  This file is better browsed using the Emacs vw-mode, which provides
+  automatic indentation, font-lock, and other facilities like the
+  hiding of annotations an the following of cross-references.  See the
+  vw-mode manual for more information, including a primer on VW
+  grammars and the formal description used in both the original Report
+  and this file.  }
+
+1 Language and metalanguage
+
+1.2 General metaproduction rules
+
+1.2.1 Metaproduction rules of modes
+
+A) MODE :: PLAIN ; STOWED ; REF to MODE ; PROCEDURE ;
+           UNITED ; MU definition of MODE ; MU application.
+B) PLAIN :: INTREAL ; boolean ; character.
+C) INTREAL :: SIZETY integral ; SIZETY real.
+D) SIZETY :: long LONGSETY ; short SHORTSETY ; EMPTY.
+E) LONGSETY :: long LONGSETY ; EMPTY.
+F) SHORTSETY :: short SHORTSETY ; EMPTY.
+G) EMPTY :: .
+H) STOWED :: structured with FIELDS mode ;
+             FLEXETY ROWS of MODE.
+I) FIELDS :: FIELD ; FIELDS FIELD.
+J) FIELD :: MODE field TAG{942A}.
+K) FLEXETY :: flexible ; EMPTY.
+L) ROWS :: row ; ROWS row.
+M) REF :: reference ; transient reference.
+N) PROCEDURE :: procedure PARAMETY yielding MOID.
+O) PARAMETY :: with PARAMETERS ; EMPTY.
+P) PARAMETERS :: PARAMETER ; PARAMETERS PARAMETER.
+Q) PARAMETER :: MODE parameter.
+R) MOID :: MODE ; void.
+S) UNITED :: union of MOODS mode.
+T) MOODS :: MOOD ; MOODS MOOD.
+U) MOOD :: PLAIN ; STOWED ; reference to MODE ; PROCEDURE ; void.
+V) MU :: muTALLY.
+W) TALLY :: i ; TALLY i.
+
+1.2.2 Metaproduction rules associated with phrases and coercion
+
+{ Extensions:
+  [MR] access
+  [US] unsafe }
+
+A) ENCLOSED :: closed ; collateral ; parallel ; CHOICE{34A} ;
+               loop ; access ; unsafe.
+B) SOME :: SORT MOID NEST.
+C) SORT :: strong ; firm ; meek ; weak ; soft.
+
+{ Modules are activated by means of access-clauses.  }
+
+1.2.3 Metaproduction rules associated with nests
+
+{ Extensions:
+  [MR] MODSETY, MOD, MODS, REVSETY, REVS, REV,
+       TAU, INKSETY, INKS, INK }
+
+A) NEST :: LAYER ; NEST LAYER.
+B) LAYER :: new DECSETY LABSETY INKSETY.
+C) DECSETY :: DECS ; EMPTY.
+D) DECS :: DEC ; DECS DEC.
+E) DEC :: MODE TAG{942A} ; priority PRIO TAD{942F} ;
+          MOID TALLY TAB{942D} ; DUO TAD{942F}  MONO TAM{492K} ;
+          MOD.
+F) PRIO :: i ; ii ; iii ;
+           iii i ; iii ii ; iii iii ;
+           iii iii i ; iii iii ii ; iii iii iii.
+G) MONO :: procedure with PARAMETER yielding MOID.
+H) DUO :: procedure with PARAMETER1 PARAMETER2 yielding MOID.
+I) LABSETY :: LABS ; EMPTY.
+J) LABS :: LAB ; LABS LAB.
+K) LAB :: label TAG{942A}.
+L) MODSETY :: MODS ; EMPTY.
+M) MODS :: MOD ; MODS MOD.
+N) MOD :: module REVS TAB.
+O) REVSETY :: REVS ; EMPTY.
+P) REVS :: REV ; REVS REV.
+Q) REV :: TAU reveals DECSETY INKS.
+R) TAU :: MU.
+S) INKSETY :: INKS ; EMPTY.
+T) INKS :: INK ; INKS INK.
+U) INK :: invoked TAU.
+
+{ The primal environment is just 'new'. }
+
+1.3 General hyper-rules
+
+1.3.1 Syntax of general predicates
+
+A) NOTION :: ALPHA ; NOTION ALPHA.
+B) ALPHA :: a ; b ; c ; d ; e ; f ; g ; h ; i ; j;
+            k ; l ; m ; n ; o ; p ; q ; r ; s ; t;
+            u ; v ; w ; x ; y ; z.
+C) NOTETY :: NOTION ; EMPTY.
+D) THING :: NOTION ;
+            (NOTETY1) NOTETY2 ;
+            THING (NOTETY1) NOTETY2.
+E) WHETHER :: where ; unless.
+
+a) where true : EMPTY.
+b) unless false : EMPTY.
+c) where THING1 and THING2 : where THING1, where THING2.
+d) where THING1 or THING2 : where THING1 ; where THING2.
+e) unless THING1 and THING2 : unless THING1; unless THING2.
+f) unless THING1 or THING2 : unless THING1, unless THING2.
+g) WHETHER (NOTETY1) is (NOTETY2) :
+     WHETHER (NOTETY1) begins with (NOTETY2){h,i,j}
+             and (NOTETY2) begins with (NOTETY1){h,i,j}.
+h) WHETHER (EMPTY) begins with (NOTION){g,j} :
+     WHETHER false{b,-}.
+i) WHETHER (NOTETY1) begins with (EMPTY){g,j} :
+     WHETHER true{a,-}.
+j) WHETHER (ALPHA1 NOTETY1) begins with
+           (ALPHA2 NOTETY2){g,j,m} :
+     WHETHER (ALPHA1) coincides with (ALPHA2) in
+             (abcdefghijklmnopqrstuvwxyz){k,l,-}
+             and (NOTETY1) begins with (NOTETY2){h,i,j}.
+k) where (ALPHA) coincides with (ALPHA) in (NOTION){j} :
+     where true{a}.
+l) unless (ALPHA1) coincides with (ALPHA2) in (NOTION){j} :
+     where (NOTION) contains (ALPHA1 NOTETY ALPHA2){m}
+           or (NOTION) contains (ALPHA2 NOTETY ALPHA1){m}.
+m) WHETHER (ALPHA NOTETY) contains (NOTION){l,m} :
+     WHETHER (ALPHA NOTETY) begins with (NOTION){j}
+             or (NOTETY) contains (NOTION){m,n}.
+n) WHETHER (EMPTY) contains (NOTION){m} : WHETHER false{b,-}.
+
+1.3.3 Syntax of general constructions
+
+A) STYLE :: brief ; bold ; style TALLY.
+
+a) NOTION option : NOTION ; EMPTY.
+b) NOTION sequence{b} : NOTION ; NOTION, NOTION sequence{b}.
+c) NOTION list{c} :
+     NOTION ; NOTION, and also{94f} token, NOTION list{c}.
+d) NOTETY STYLE pack :
+     STYLE begin{94f,-} token, NOTETY, STYLE end{94f,-} token.
+e) NOTION STYLE bracket :
+     STYLE sub{94f,-} token, NOTION, STYLE bus{94f,-} token.
+f) THING1 or alternatively THING2 : THING1 ; THING2.
+
+2 The computer and the program
+
+2.2 The program
+
+2.2.1 Syntax
+
+a) program : program token, strong integral new closed clause{31a}.
+
+{ The value yielded by the elaboration of the program is the exit
+  status returned by the process to the operating system upon
+  termination.  This is a slight deviation from the Report, which
+  instead specifies:
+
+  a) program : strong void new closed clause.
+
+  and mandates that the production tree of a particular program should
+  be akin to the production of the program in the strict language. }
+
+3 Clauses
+
+3.0.1 Syntax
+
+{ Extensions:
+  [MR] "NEST module text publishing REVS defining LAYER",
+       "NEST LAYER1 LAYER2 module series with DECSETY
+          without DECSETY",
+       "SOID NEST access clause"  }
+
+a) *phrase : SOME unit{32d} ; NEST declaration of DECS{41a}.
+b) *SORT MODE expression : SORT MODE NEST UNIT{5A}.
+c) *statement : strong void NEST UNIT{5A}.
+d) *MOID constant : MOID NEST DEFIED identifier with TAG{48a,b} ;
+                    MOID NEST denoter{80a}.
+e) *MODE variable :
+     reference to MODE NEST DEFIED identifier with TAG{48a,b}.
+f) *NEST range :
+     SOID NEST serial clause defining LAYER{32a} ;
+     SOID NEST chooser CHOICE STYLE clause{34b} ;
+     SOID NEST case part of choice using UNITED{34i} ;
+     NEST STYLE repeating part with DEC{35e} ;
+     NEST STYLE while do part{35f} ;
+     PROCEDURE NEST routine text{541a,b} ;
+     NEST module text publishing REVS defining LAYER{49c,-} ;
+     NEST LAYER1 LAYER2 module series
+          with DECSETY without DECSETY1{49d} ;
+     SOID NEST access clause{36a}.
+
+{ The rules b and c establish a precise definition of "expressions"
+  and "statements".  The former are units yielding values of a mode
+  other than VOID in any context.  The later are units in a strong
+  context with a-posteriori mode of VOID, that get voided. }
+
+{ The rules d and e establish a precise definition of "constants" and
+  "variables".  The former are either a denotation or an identifier of
+  some mode.  The second are identifiers of a "reference to" mode. }
+
+{ The rule f introduces a paranotion for all the constructs that
+  introduce new ranges.  }
+
+3.1 Closed clauses
+
+3.1.1 Syntax
+
+A) SOID :: SORT MOID.
+B) PACK :: STYLE pack.
+
+a) SOID NEST closed clause{22a,5D,551a,A341h,A349a} :
+     SOID NEST serial clause defining LAYER{32a} PACK.
+
+{ Examples:
+  a) BEGIN x := 1; y := 2 END }
+
+3.2 Serial clauses
+
+3.2.1 Syntax
+
+{ Extensions:
+  [MR] "establishing clause"  }
+
+a) SOID NEST serial clause defining new PROPSETY{31a,34f,1,35h} :
+     SOID NEST new PROPSETY series with PROPSETY{b}.
+b) SOID NEST series with PROPSETY{a,b,35c} :
+     strong void NEST unit{d}, go on{94f} token,
+       SOID NEST series with PROPSETY{b} ;
+     where (PROPSETY) is (DECS DECSETY LABSETY),
+       NEST declaration of DECS{41a}, go on{94f} token,
+       SOID NEST series with DECSETY LABSETY{b} ;
+     where (PROPSETY) is (LAB LABSETY),
+       NEST label definition of LAB{c},
+       SOID NEST series with LABSETY{b} ;
+     where (PROPSETY) is (LAB LABSETY)
+           and SOID balances SOID1 and SOID2{3}, SOID1 NEST unit{d},
+       completion{94f} token, NEST label definition of LAB{c},
+       SOID2 NEST series with LABSETY{b} ;
+     where (PROPSETY) is (EMPTY),
+       SOID NEST unit{d}.
+c) NEST label definition of label TAG{b} :
+     label NEST defining identifier with TAG{48a}, label{94f} token.
+d) SOME unit{b,33b,g,34i,35d,46m,n,521c,532e,541a,b,543c,A34Ab,c,d} :
+     SOME UNIT{5A,-}.
+e) WHETHER SORT MOID balances
+           SORT1 MOID1 an SORT2 MOID2{b,33b,34d,h} :
+     WHETHER SORT balances SORT1 and SORT2{f}
+             and MOID balances MOID1 and MOID2{g}.
+f) WHETHER SORT balances SORT1 and SORT2{e,522a} :
+     where (SORT1) is (strong), WHETHER (SORT2) is (SORT) ;
+     where (SORT2) is (strong), WHETHER (SORT1) is (SORT).
+g) WHETHER MOID balances MOID1 and MOID2{3} :
+     where (MOID1) is (MOID2), WHETHER (MOID) is (MOID1) ;
+     where (MOID1) is (transient MOID2),
+       WHETHER (MOID) is (MOID1) ;
+     where (MOID2) is (transient MOID1),
+       WHETHER (MOID) is (MOID2).
+
+h) *SOID unitary clause : SOID NEST unit{d}.
+i) *establishing clause :
+     SOID NEST serial clause defining LAYER{32a} ;
+     MODE NEST enquiry clause defining LAYER{34c}.
+
+{ The paranotion establishing-clause encompasses both module-texts and
+  revelations.  }
+
+{ Examples:
+  b) read (x1); REAL s:= 0;
+     sum: FOR i TO n DO (x1[i] > 0 | s :+= x1[i] | nonpos) OD EXIT
+     nonpos: print (s)
+
+     REAL s := 0;
+     sum: FOR i TO n DO (x1[i] > 0 | s :+= x1[i] | nonpos) OD EXIT
+     nonpos: print (s)
+
+     sum: FOR i TO n DO (x1[i] > 0 | s :+= x1[i] | nonpos) OD EXIT
+     nonpos: print (s)
+
+     FOR i TO n DO (x1[i] > 0 | s :+= x1[i] | nonpos) OD EXIT
+     nonpos: print (s)
+  c) sum:
+  d) print (s) }
+
+3.3 Collateral and parallel clauses
+
+3.3.1 Syntax
+
+a) strong void NEST collateral clause{5D,551a} :
+     strong void NEST joined portrait{b} PACK.
+b) SOID NEST joined portrait{a,b,c,d,34g} :
+     were SOID balances SOID1 and SOID2{32e},
+       SOID1 NEST unit{32d}, and also{94f} token,
+       SOID2 NEST unit{32d}
+             or alternatively SOID2 NEST joined portrait{b}.
+c) strong void NEST parallel clause{5D,551a} :
+     parallel{94f} token, strong void NEST joined portrait{b} PACK.
+d) strong ROWS of MODE NEST collateral clause{5D,551a} :
+     where (ROWS) is (row),
+       strong MODE NEST joined portrait{b} PACK ;
+     where (ROWS) is (row ROWS1),
+       strong ROWS1 of MODE NEST joined portrait{b} PACK ;
+     EMPTY PACK.
+e) strong structured with
+          FIELDS FIELD mode NEST collateral clause{5D,551a} :
+     NEST FIELDS FIELD portrait{f} PACK.
+f) NEST FIELDS FIELD portrait{3,f} :
+     NEST FIELDS portrait{f,g}, an also{94f} token,
+       NEST FIELD portrait{g}.
+g) NEST MODE field TAG portrait{f} : strong MODE NEST unit{32d}.
+
+h) *structure display :
+     strong structured with FIELDS FIELD mode NEST collateral clause{e}.
+i) *row display :
+     strong ROWS of MODE NEST collateral clause{d}.
+j) *display : strong STOWED NEST collateral clause{d,e}.
+k) *vacuum : EMPTY PACK.
+
+3.4 Choice clauses
+
+3.4.1 Syntax
+
+A) CHOICE :: choice using boolean ; CASE.
+B) CASE :: choice using intgral ; choice using UNITED.
+
+a) SOID NEST1 CHOICE clause{5D,551a,A341h,A349a} :
+     CHOICE STYLE start{91a,-},
+       SOID NEST1 chooser CHOICE STYLE clause{b},
+       CHOICE STYLE finish{91e,-}.
+b) SOID NEST1 chooser choice using MODE STYLE clause{a,l} :
+     MODE NEST1 enquiry clause defining LAYER2{c,-},
+       SOID NEST1 LAYER2 alternate choice using MODE STYLE clause{d}.
+c) MODE NEST1 enquiry clause defining new DECSETY2{b,35g} :
+     meek MODE NEST1 new DESETY2 series with DECSETY2{32b}.
+d) SOID NEST2 alternate CHOICE STYLE clause{b} :
+     SOID NEST2 in CHOICE STYLE clause{e} ;
+     where SOID balances SOID1 and SOID2{32e},
+       SOID1 NEST2 in CHOICE STYLE clause{3},
+       SOID2 NEST2 out CHOICE STYLE clause{l}.
+e) SOID NEST2 in CHOICE STYLE clause{d} :
+     CHOICE STYLE in{91b,-}, SOID NEST2 in part of CHOICE{f,g,h}.
+f) SOID NEST2 in part of choice using boolean{e} :
+     SOID NEST2 serial clause defining LAYER3{32a}.
+g) SOID NEST2 in part of choice using integral{e} :
+     SOID NEST2 joined portrait{33b}.
+h) SOID NEST2 in part of choice using UNITED{e,h} :
+     SOID NEST2 case part of choice using UNITED{i} ;
+     where SOID balances SOID1 and SOID2{32e},
+       SOID1 NEST2 case part of choice using UNITED{i},
+       and also{94f} token,
+       SOID2 NEST2 in part of choice using UNITED{h}.
+i) SOID NEST2 case part of choice using UNITED{h} :
+     MOID NEST2 LAYER3 specification defining LAYER3{jk,-},
+       where MOID unites to UNITED{64b},
+       SOID NEST2 LAYER3 unit{32d}.
+j) MODE NEST3 specification defining new MODE TAG3{i} :
+     NEST3 declarative defining new MODE TAG3{541e} brief pack,
+       colon{94f} token.
+k) MOID NEST3 specification defining new EMPTY{i} :
+     formal MOID NEST3 declarer{46b} brief pack, colon{94f} token.
+l) SOID NEST2 out CHOICE STYLE clause{d} :
+     CHOICE STYLE out{91d,-},
+       SOID NEST2 serial lause defining LAYER3{32a} ;
+     CHOICE STYLE again{91c,-},
+       SOID NEST2 chooser CHOICE2 STYLE clause{b},
+       where CHOICE2 may follow CHOICE{m}.
+m) WHETHER choice using MODE2 may follow choice using MODE1{l} :
+     where (MODE1) is (MOOD), WHETHER (MODE2) is (MODE1) ;
+     where (MODE1) begins with (union of),
+       WHETHER (MODE2) begins with (union of).
+
+n) *SOME choice clause : SOME CHOICE clause{a}.
+o) *SOME conditional clause : SOME choice using boolean clause{a}.
+p) *SOME case clause : SOME choice using integral clause{a}.
+q) *SOME conformity clause : SOME choice using UNITED clause{a}.
+
+3.5 Loop clauses
+
+3.5.1 Syntax
+
+A) FROBYT :: from ; by ; to.
+
+a) strong void NEST1 loop clause{5D,551a} :
+     NEST1 STYLE for part defining new integral TAG2{b},
+       NEST1 STYLE intervals{c},
+       NEST1 STYLE repeating part with integral TAG2{e}.
+b) NEST1 STYLE for part defining new integral TAG2{a} :
+     STYLE for{94g,-} token,
+       integral NEST1 new integral TAG2 defining identifier
+                with TAG2{48a} ;
+     where (TAG2) is (letter aleph), EMPTY.
+c) NEST1 STYLE intervals{a} :
+     NEST1 STYLE from part{d} option,
+       NEST1 STYLE by part{d} option,
+       NEST1 STYLE to part{d} option.
+d) NEST1 STYLE FROBYT part{c} :
+     STYLE FROBYT{94g,-} token, meek integral NEST1 unit{32d}.
+e) NEST1 STYLE repeating part with DEC2{a} :
+     NEST1 new DEC2 STYLE while do part{f} ;
+     NEST1 new DEC2 STYLE do part{h}.
+f) NEST2 STYLE while do part{e} :
+     NEST2 STYLE while part defining LAYER3{g},
+       NEST2 LAYER3 STYLE do part{h}.
+g) NEST2 STYLE while part defining LAYER3{f} :
+     STYLE while{94g,-} token,
+       boolean NEST2 enquiry clause defining LAYER3{34c,-}.
+h) NEST3 STYLE do part{3,f} :
+     STYLE do{94g,-} token,
+       strong void NEST3 serial clause defining LAYER4{32a},
+       STYLE od{94g,-} token.
+
+3.6 Access clauses
+
+{ Extensions:
+  [MR] GMR }
+
+{ Access clauses contain a controlled-clause, which is an
+  enclosed-clause. }
+
+3.6.1 Syntax
+
+a) SOID NEST access clause{5D,551a,A341h,A349a} :
+     NEST revelation publishing EMPTY defining LAYER{b},
+       SOID NEST LAYER ENCLOSED clause{a,31a,33a,c,d,e,34a,35a,-}.
+b) NEST revelation publishing REVSETY
+        defining new DECSETY INKSETY{a,49c} :
+     access{94d} token,
+       NEST joined module call publishing REVSETY revealing REVS{c},
+       where DECSETY INKS revealed by REVS{e,f}
+             and NEST filters INKSETY out of INKS{h}.
+c) NEST joined module call publishing REVSETY revealing RES{b,c} :
+     NEST moule call publishing REVSETY revealing REVS{d,-} ;
+     where (REVSETY) is (REVSETY1 REVSETY2)
+           an (REVS) is (REVS1 REVS2),
+       NEST module call publishing REVSETY1 revealing REVS1{d,-},
+       and also{94f} token,
+       NEST joined module call publishing REVSETY2 revealing REVS2{c}.
+d) NEST module call publishing REVSETY revealing REVS{c} :
+     where (REVSETY) is (EMPTY),
+       module REVS NEST applied module indication with TAB{48b} ;
+     where (REVSETY) is (REVS),
+       public{94d} token,
+       module REVS NEST applied module indication with TAB{48b}.
+e) WHETHER DECSETY1 DECSETY2 INKS1 INKSETY2 revealed by
+           TAU reveals DECSETY1 INKS1 REVSETY3
+           TAU reveals DECSETY1 INKS1 REVSETY4{b,e,f} :
+     WHETHER DECSETY DECSETY2 INKS1 INKSETY2 revealed by
+             TAU reveals DECSETY1 INKS1 REVSETY3 REVSETY4{e,f}.
+f) WHETHER DECSETY1 DECSETY2 INKS1 INKSETY2 revealed by
+           TAU reveals DECSETY1 INKS1 REVSETY2{b,e,f} :
+     WHETHER DECSETY2 INKSETY2 revealed by REVSETY2
+             and DECSETY1 independent DECSETY2{71a,b,c}.
+g) WHETHER EMPTY revealed by EmPTY{e,f} : WHETHER true.
+h) WHETHER NEST filters INKSETY1 out of INKSETY INK{b} :
+     unless INK ientified in NEST{72a},
+       WHETHER (INKSETY) is (INKSETY2 INK)
+               and NEST INK filers INKSETY2 out of INKSETY{h,i} ;
+     where INK identified in NEST{72a},
+       WHETHER NEST filters INKSETY1 out of INKSETY{h,i}.
+i) WHETHER NEST filters EMPTY out of EMPTY{h} : WHETHER true.
+
+{ Examples:
+    a) ACCESS A, B (gets (f, a); puts (a))
+    b) ACCESS A, B
+    c) A, B
+    d) A
+       PUB B  }
+
+{ In rule b, the 'invoke TAU's enveloped by 'INKS' represent those
+  modules which might need to be invoked at any module-call whose
+  applied-module-indication identified a particular
+  defining-module-indication, whereas those enveloped by 'INKSETY'
+  represent only those which need invocation in the particular
+  context, the remainder having already being elaborated, as can be
+  determined statically from the 'NEST'.  The presence of 'INKSETY' in
+  the nest of all descendent constructs of the access-clause ensures
+  that all modules now invoked will never be invoked again within
+  those descendents.  }
+
+{ Rule f ensures the independence of declarations revealed by one
+  revelation; thus
+
+    MODULE A = DEF PUB REAL x FED, B = DEF PUB REAL x FED;
+    ACCESS A, B (x)
+
+  is not produced.  However, rule e allows a given declaration to be
+  revealed by two public accesses of the same module, as in
+
+    MODULE A = DEF PUB REAL x FED;
+    MODULE B = ACCESS PUB A DEF REAL y FED,
+           C = ACCESS PUB A DEF REAL z FED;
+    ACCESS B C (x + y + z)
+
+  in which the module-definitions for both B and C reveal x, by virtue
+  of the PUB A in their constituent revelations.  }
+
+{ Note that a particular-program may now consist of a
+  joined-label-definition followed by an access-clause.  The
+  defining-module- indications identified thereby would be in the
+  library-prelude or the user-prelude.  }
+
+3.7 Unsafe clauses
+
+{ Extensions: [US] }
+
+{ Unsafe clauses contain a controlled-clause, which is an enclosed-clause. }
+
+3.7.1 Syntax
+
+a) SOID NEST unsafe clause :
+     unsafe{94f} token, SOID NEST ENCLOSED clause{a,31a,33a,c,d,e,34a,35a,-}.
+
+{ Examples:
+    a) UNSAFE (ptr := dst)  }
+
+4 Declarations, declarers and indicators
+
+4.1 Declarations
+
+4.1.1 Syntax
+
+{ Extensions:
+  [MR] module
+       "declaration with DECSETY without DECSETY1" }
+
+A) COMMON :: mode ; priority ; MODINE identity ;
+             reference to MODINE variable ; MODINE operation ;
+             PARAMETER ; MODE FIELDS ; module.
+             { MODINE :: MODE ; routine. }
+
+a) NEST declaration of DECS{a,32b} :
+     NEST COMMON declaration of DECS{42a,43a,44a,e,45a,-} ;
+     where (DECS) is (DECS1 DECS2),
+       NEST COMMON declaration of DECS1{42a,43a,44a,e,45a,-},
+       and also{94f} token, NEST declaration of DECS2{a}.
+b) NEST COMMON joined definition of PROPS PROP{b,42a,43a,44a,e,45a,46e,541e} :
+     NEST COMON joined definition of PROPS{b,c},
+       and also{94f} token,
+       NEST COMMON joined definition of PROP{c}.
+c) NEST COMMON joined definition of PROP{b,42a,43a,44a,e,45a,46e,541e} :
+     NEST COMMON definition of PROP{42b,43b,44c,f,45c,46f,541f,-}.
+
+d) *definition of PROP :
+     NEST COMMON definition of PROP{42b,43b,44c,f,45c,46f,541f} ;
+     NEST label definition of PROP{32}.
+e) NEST declaration with DECSETY without DECSETY1{49e} :
+     where (DECSETY without DECSETY1) is (EMPTY without DECS1),
+       NEST COMMON declaration of DECS1{42a,43a,44a,e,45a,49a,-} ;
+     where (DECSETY without DECSETY1) is (DECS without EMPTY),
+       public{94d} token,
+       NEST COMMON declaration of DECS{42a,43a,44a,e,45a,49a,-} ;
+     where (DECSETY without DECSETY1) is
+           (DECSETY without DECS1 DECSETY2),
+       NEST COMMON declaration of DECS1{42a,43a,44a,e,45a,49a,-},
+       and also{94f} token,
+       NEST declaration with DECSETY without DECSETY2{e} ;
+     where (DECSETY without DECSETY1) is
+           (DECS DECSETY3 without DECSETY1),
+       public{94d} token,
+       NEST COMMON declaration of DECS{42a,43a,44a,e,45a,49a,-},
+       and also{94f} token,
+       NEST declaration with DECSETY3 without DECSETY1{e}.
+
+{ Rule e determines how a "NEST declaration with DECSETY without
+  DECSETY1" results into two groups of declarations.  The declarations
+  in 'DECSETY' are public and syntactically preceded by PUB.  The
+  declarations in 'DECSETY1 are non-public and are not marked by
+  PUB.  }
+
+4.2 Mode declarations
+
+4.2.1 Syntax
+
+a) NEST mode declaration of DECS{41a} :
+     mode{94d} token, NEST mode joined definition of DECS{41b,c}.
+b) NEST mode definition of MOID TALLY TAB{41c} :
+     where (TAB) is (bold TAG) or (NEST) is (new LAYER),
+       MOID TALLY NEST defining mode indication with TAB{48a},
+       is defined as{94d} token,
+       actual MOI TALLY NEST declarer{c}.
+c) actual MOID TALLY1 NEST declarer{b} :
+     where (TALLY1) is (i),
+       actual MOID NEST declarator{46c,d,g,h,o,s,-} ;
+     where (TALLY1) is (TALLY2 i),
+       MOID TALLY2 NEST applied mode indication with TAB2{48b}.
+
+{ The use of TALLY excludes circular chains of mode-definitions such
+  as `mode a = b, b = a'. }
+
+4.3 Priority declarations
+
+4.3.1 Syntax
+
+a) NEST priority declaration of DECS{41a} :
+     priority{94d} token, NEST priority joined definition of DECS{41b,c}.
+b) NEST priority definition of priority PRIO TAD{41c} :
+     priority PRIO NEST definining operator with TAD{48a},
+       is defined as{94d} token, DIGIT{94b} token,
+       where DIGIT counts DIGIT{94b} token,
+       where DIGIT counts PRIO{c,d}.
+   {DIGIT :: digit zero ; digit one ; digit two ; digit three ;
+             digit four ; digit five ; digit six ; digit seven ;
+             digit eight ; digit nine.}
+c) WHETHER DIGIT1 counts PRIO i{b,c} :
+     WHETHER DIGIT2 counts PRIO{c,d},
+       where (digit one igit two digit three digit four
+              digit five digit six digit seven digit eight digit nine)
+              contains (DIGIT2 DIGIT1).
+d) WHETHER digit one counts i{b,c} : WHETHER true.
+
+4.4 Identifier declarations
+
+4.4.1 Syntax
+
+A) MODINE :: MODE ; routine.
+B) LEAP :: local ; heap ; primal.
+
+a) NEST MODINE identity declaration of DECS{41a} :
+     formal MODINE NEST declarer{b,46b},
+       NEST MODINE identity joined definition of DECS{41b,c}.
+b) VICTAL routine NEST declarer{a,523b} : procedure{94d} token.
+c) NEST MODINE identity definition of MODE TAG{41c} :
+     MODE NEST defining identifier with TAG{48a},
+       is defined as{94d} token, MODE NEST source for MODINE{d}.
+d) MODE NEST source for MODINE{c,f,45c} :
+     where (MODINE) is (MODE), MODE NEST source{521c} ;
+     where (MODINE) is (routine), MODE NEST routine text{541a,b,-}.
+e) NEST reference to MODINE variable declaration of DECS{41a} :
+     reference to MODINE NEST LEAP sample generator{523b},
+       NEST reference to MODINE variable joined definition of DECS{41b,c}.
+f) NEST reference to MODINE variable definition
+        of reference to MODE TAG{41c} :
+     reference to MODE NEST defining identifier with TAG{48a},
+       becomes{94c} token, MODE NEST soure for MODINE{d} ;
+     where (MODINE) is (MODE),
+       reference to MODE NEST defining identifier with TAG{48a}.
+
+g) *identifier declaration :
+     NEST MODINE identity declaration of DECS{a} ;
+     NEST reference to MODINE variable declaration of DECS{e}.
+
+4.5 Operation declarations
+
+4.5.1 Syntax
+
+A) PRAM :: DUO ; MONO.
+B) TAO :: TAD ; TAM.
+
+a) NEST MODINE operation delarations of DECS{41a} :
+     operator{94d} token, formal MODINE NEST plan{b,46p,-},
+       NEST MODINE operation joined definition of DECS{41b,c}.
+b) formal routine NEST plan{a} : EMPTY.
+c) NEST MODINE operation definition of PRAM TAO{41c} :
+     PRAM NEST defining operator with TAO{48a},
+       is defined as{94d} token, PRAM NEST source for MODINE{44d}.
+
+4.6 Declarers
+
+4.6.1 Syntax
+
+A) VICTAL :: VIRACT ; formal.
+B) VIRACT :: virtual ; actual.
+C) MOIDS :: MOID ; MOIDS MOID.
+
+a) VIRACT MOID NEST declarer{c,e,g,h,523a,b} :
+     VIRACT MOID NEST declarator{c,d,g,h,o,s,-} ;
+     MOID TALLY NEST applied mode indication with TAB{48b,-}.
+b) formal MOID NEST declarer{e,h,p,r,u,34k,44a,541a,b,e,551a} :
+     where MOID deflexes to MOID{47a,b,c,-},
+       formal MOID NEST declarator{c,d,h,o,s,-} ;
+     MOID1 TALLY NEST applied mode indication with TAB{48b,-},
+       where MOID1 deflexes to MOID{47a,b,c,-}.
+c) VICTAL reference to MODE NEST declarator{a,b,42c} :
+     reference to{94d} token, virtual MODE NEST declarer{a}.
+d) VICTAL structured with FIELDS mode NEST declarator{a,b,42c} :
+     structure{94d} token,
+       VICTAL FIELDS NEST portrayer of FIELDS{e} brief pack.
+e) VICTAL FIELDS NEST portrayer of FIELDS1{d,e} :
+     VICTAL MODE NEST declarer{a,b},
+       NEST MODE FIELDS joined definition of FIELDS1{41b,c} ;
+     where (FIELDS1) is (FIELDS2 FIELDS3),
+       VICTAL MODE NEST declarer{a,b},
+       NEST MODE FIELDS joined definition of FIELDS2{41b,c},
+       and also{94f} token,
+       VICTAL FIELDS NEST portrayer of FIELDS3{e}.
+f) NEST MODE FIELDS definition of MODE field TAG{41c} :
+     MODE field FIELDS defining field selector with TAG{48c}.
+g) VIRACT flexible ROWS of MODE NEST declarator{a,42c} :
+     flexible{94d} token, VIRACT ROWS of MODE NEST declarer{a}.
+h) VICTAL ROWS of MODE NEST declarator{a,b,42c} :
+     VICTAL ROWS NEST rower{i,j,k,l} STYLE bracket,
+       VICTAL MODE NEST declarer{a,b,}.
+i) VICTAL row ROWS NEST rower{h,i} :
+     VICTAL row NEST rower{j,k,l}, and also{94f} token,
+       VICTAL ROWS NEST rower{i,j,k,l}.
+j) actual row NEST rower{h,i} :
+     NEST lower bound{m}, up to{94f} token, NEST upper bound{n} ;
+     NEST upper bound{n}.
+k) virtual row NEST rower{h,i} : up to{94f} token option.
+l) formal row NEST rower{h,i} : up to{94f} token option.
+m) NEST lower bound{j,532f,g} : meek integral NEST unit{32d}.
+n) NEST upper bound{j,532f} : meek integral NEST unit{32d}.
+o) VICTAL PROCEDURE NEST declarator{a,b,42c} :
+     procedure{94d} token, formal PROCEDURE NEST plan{p}.
+p) formal procedure PARAMETY yieling MOID NEST plan{o,45a} :
+     where (PARAMETY) is (EMPTY), formal MOID NEST declarer{b} ;
+     PARAMETERS NEST joined declarer{q,r} brief pack,
+       formal MOID NEST declarer{b}.
+q) PARAMETERS PARAMETER NEST joined declarer{p,q} :
+     PARAMETERS NEST joined declarer{q,r}, and also{94f} token,
+       PARAMETER NEST joined declarer{r}.
+r) MODE parameter NEST joined declarer{p,q} :
+     formal MODE NEST declarer{b}.
+s) VICTAL union of MOODS1 MOOD1 mode NEST declarator{a,b,42c} :
+     unless EMPTY with MOODS1 MOOD1 incestuous{47f},
+       union of{94d} token,
+       MOIDS NEST joined declarer{t,u} brief pack,
+       where MOIDS ravels to MOODS2{47g}
+             and safe MOODS1 MOOD1 subset of safe MOODS2{73l}
+             and safe MOODS2 subset of safe MOODS1 MOOD1{731,m}.
+t) MOIDS MOID NEST joined declarer{s,t} :
+     MOIDS NEST joined declarer{t,u}, an also{94f} token,
+       MOID NEST joined declarer{u}.
+u) MOID NEST joined declarer{s,t} : formal MOID NEST declarer{b}.
+
+4.7 Relationships between modes
+
+4.7.1 Syntax
+
+A) NONSTOWED :: PLAIN ; REF to MODE ; PROCEDURE ; UNITED ; void.
+B) MOODSETY :: MOODS ; EMPTY.
+C) MOIDSETY :: MOIDS ; EMPTY.
+
+a) WHETHER NONSTOWED deflexes to NONSTOWED{b,e,46b,521c,62a,71n} :
+     WHETHER true.
+b) WHETHER FLEXETY ROWS of MODE1 deflexes to ROWS of MODE2{b,e,46b,521c,62a,71n} :
+     WHETHER MODE1 deflexes to MODE2{a,b,c,-}.
+c) WHETHER structured with FIELDS1 mode deflexes to
+           structured with FIELDS2 mode{b,e,46b,521c,62a,71n} :
+     WHETHER FIELDS1 deflexes to FIELDS2{d,e,-}.
+d) WHETHER FIELDS1 FIELD1 deflexes to FIELDS2 FIELD2{c,d} :
+     WHETHER FIELDS1 deflexes to FIELDS2{d,e,-}
+             and FIELD1 deflexes to FIELD2{e,-}.
+e) WHETHER MODE1 field TAG deflexes to MODE2 field TAG{c,d} :
+     WHETHER MODE1 deflexes to MODE2{a,b,c,-}.
+
+f) WHETHER MOODSETY1 with MOODSETY2 inestuous{f,46s} :
+     where (MOODSETY2) is (MOOD MOODSETY3),
+       WHETHER MOODSETY1 MOOD with MOODSETY3 incestuous{f}
+               or MOOD is firm union of MOODSETY1 MOODSETY3 mode{71m} ;
+     where (MOODSETY2) is (EMPTY), WHETHER false.
+
+g) WHETHER MOIDS ravels to MOODS{g,46s} :
+     where (MOIDS) is (MOODS), WHETHER true ;
+     where (MOIDS) is
+           (MOODSETY union of MOODS1 mode MOIDSETY),
+       WHETHER MOODSETY MOODS1 MOIDSETY ravels to MOODS{g}.
+
+{ The hyperrules from a) to e) implement a predicate deflexes-to that
+  determines whether a given mode deflexes to another mode.  Any
+  non-stowed mode deflexes to any other non-stowed mode.  A row mode
+  deflexes to another row mode if the ranks of the modes are the same
+  and the mode of the former's elements deflexes to the mode of the
+  later's elements.  A structured mode deflexes to another structured
+  mode if they have the same number of fields with the same tags and
+  their modes deflex.  }
+
+{ The hyperrule f) implements a predicate that determines whether two
+  provided sets of moods are incestuous, i.e. whether they contain
+  modes which are firmly related.  }
+
+{ The hyperrule g) determines whether a set of moods and
+  united modes may be ravelled.  }
+
+4.8 Indicators and field selectors
+
+4.8.1 Syntax
+
+{ Extensions:
+  [MR] INK, "module indication", "module REVS", "invoked", TAU }
+
+A) INDICATOR :: identifier ; mode indication ; operator ;
+                module indication.
+B) DEFIED :: defining ; applied.
+C) PROPSETY :: PROPS ; EMPTY.
+D) PROPS :: PROP ; PROPS PROP.
+E) PROP :: DEC ; LAB ; FIELD ; INK.
+F) QUALITY :: MODE ; MOID TALLY ; DYADIC ; label ; MODE field ;
+              module REVS ; invoked.
+G) TAX :: TAG ; TAB ; TAD ; TAM ; TAU.
+
+a) QUALITY NEST new PROPSETY1 QUALITY TAX PROPSETY2
+           defining INDICATOR with TAX{32c,35b,42b,43b,44c,f,45c,541f} :
+     where QUALITY TAX independent PROPSETY1 PROPSETY2{71a,b,c},
+       TAX{942A,D,F,K} token.
+b) QUALITY NEST applied INDICATOR with TAX{42c,46a,b,5D,542a,b,544a} :
+     where QUALITY TAX identified in NEST{72a},
+       TAX{942A,D,F,K} token.
+c) MODE field PROPSETY1 MODE field TAG PROPSETY2 defining
+        field selector with TAG{46f} :
+     where MODE field TAG independent PROPSETY1 PrOPSETY2{71a,b,c},
+       TAX{942A} token.
+d) MODE field FIELDS applied field selector with TAG{531a} :
+     where MODE field TAG resides in FIELDS{72b,c,-},
+       TAG{942A} token.
+
+e) *QUALITY NEST DEFIED indicator with TAX :
+     QUALITY NEST DEFIED INDICATOR with TAX{a,b}.
+f) *MODE DEFIED field seletor with TAG :
+     MODE field FIELDS DEFIED field selector with TAG{c,d}.
+
+{ MODs are introduced into a nest by module-declarations.
+  INKs are introduced into a nest by module-calls. }
+
+{ Modules are ascribed to module-indications by means of
+  module-declarations.  }
+
+4.9 Module declarations
+
+4.9.1 Syntax
+
+a) NEST1 module declaration of MODS{41a,e} :
+     module{94d} token,
+       NEST1 module joined definition of MODS{41b,c}.
+b) NEST1 module definition of module RESETY REV TAB{41c} :
+     where (REV) is (TAU reveals DECSETY invoked TAU)
+           and (TAB) is (bold TAG),
+       where (NEST1) is (NOTION1 invoked TAU NOTETY2),
+       unless (NOTION1 NOTETY2) contains (invoked TAU),
+       module REVSETY REV NEST1 defining module indication with TAB{48a},
+       is define as{94d} token,
+       NEST1 module text publishing REVSETY REV defining LAYER{c,-}.
+c) NEST1 module text
+         publishing REVSETY TAU reveals DECSETY INKSETY INK
+         defining new DECSETY1 DECSETY INK{b} :
+     where (INKSETY) is (EMPTY) and (REVSETY) is (EMPTY),
+       def{94d} token,
+       NEST1 new new DECSETY1 DECSETY INK module series
+             with DECSETY without DECSETY1{d},
+       fed{94d} token ;
+     NEST1 revelation publishing REVSETY defining LAYER{36b},
+       def{94d} token,
+       NEST1 LAYER new DECSETY1 DECSETY INK module series
+             with DECSETY without DECSETY1{d},
+       fed{94d} token,
+       where (LAYER) is (new DECSETY2 INKSETY).
+d) NEST3 module series with DECSETY without DECSETY1{c} :
+     NEST3 module prelude with DECSETY without DECSETY1{e},
+       NEST3 module postlude{f} option.
+e) NEST3 module prelude with DECSETY1 without DECSETY2{d,e} :
+     strong void NEST3 unit{32d}, go on{94f} token,
+       NEST3 module prelude with DECSETY1 without DECSETY2{e} ;
+     where (DECSETY1 without DECSETY2) is
+           (DECSETY3 DECSETY4 without DECSETY5 DECSETY6>,
+       NEST3 declaration with DECSETY3 without DECSETY5{41e},
+       go on{94f} token,
+       NEST3 module prelude with DECSETY4 without DECSETY6{e} ;
+     where (DECSETY1 without DECSETY2) is (EMPTY without EMPTY),
+       strong void NEST3 unit{32d} ;
+     NEST3 declaration with DECSETY1 without DECSETY2{41e}.
+f) NEST3 module postlude{d} :
+     postlude{94d} token, strong void NEST3 series with EMPTY{32b}.
+
+g) *module text :
+     NEST module text publishing REVS defining LAYER{c}.
+
+{ Examples:
+    a) MODULE A = DEF STRING s; gets (s);
+                      PUB STRING t = "file"+s, PUB REAL a FED,
+              B = ACCESS A DEF PUB INT fd;
+                               fopen (fd, file o rdonly)
+                           POSTLUDE close (f) FED
+
+    b) A = DEF STRING s; gets (s);
+               PUB STRING t = "file"+s, PUB REAL a FED
+
+       B = ACCESS A DEF PUB FILE f;
+                        fopen (fd, file o rdonly)
+                        POSTLUDE close (f) FED
+
+    c) DEF STRING s; gets (s);
+           PUB STRING t = "file"+s, PUB REAL a FED
+
+       ACCESS A DEF PUB FILE f;
+                        fopen (fd, file o rdonly)
+                        POSTLUDE close (f) FED
+
+    d) STRING s; gets (s); PUB STRING t = "file"+s, PUB real a
+
+       PUB FILE f; fopen (fd, file o rdonly) POSTLUDE close (f)
+
+    e) STRING s; gets (s); PUB STRING t = "file"+s, PUB real a
+
+       PUB FILE f; fopen (fd, file o rdonly)
+
+    f) POSTLUDE close (f) }
+
+{ Note that the EMPTY (for PROPSETY) in rule f enforces that a module
+  postlude cannot contain declarations, labels or module accesses.
+  Only units are allowed.  }
+
+{ Rule b ensures that a unique 'TAU' is associated with each
+  module-text accessible from any given point in the program.  This is
+  used to ensure that an invoke ATU' can be identified in the nest of
+  all descendent constructs of any access-clause or module-text which
+  invokes that module-text.
+
+  In general, a module-text-publishing-REVS-defining-LAYER T makes
+  'LAYER' visible within itself, and makes the properties revealed by
+  'REVS' visible wherever T is accessed.  'LAYER' includes both a
+  'DECSETY' corresponding to its public declarations and an INK' which
+  links T to its unique associated 'TAU' and signifies in the nest
+  that T is now known to be invoked.  REVS' always reveals 'DECSETY
+  INKSETY INK' (but not 'DECSETY1'), where INKSETY' signifies the
+  invocation of any other modules accessed by T.  'REVS' may also
+  reveal the publications of the other modules accessed by T if their
+  module-calls within T contained a public-token. }
+
+5 Units
+
+5.1 Syntax
+
+{ Extensions:
+  [MR] formal hole, virtual hole }
+
+A) UNIT{32d} ::
+     assignation{521a} coercee ; identity relation{522a} coercee ;
+     routine text{541a,b} coercee ; jump{544a} ; skip{552a} ;
+     and function{57a} ; or function{57b} ;
+     formal hole{561b} ; virtual hole{561a} ;
+     TERTIARY{B}.
+B) TERTIARY{A,521b,522a} ::
+     ADIC formula{542a,b} coercee ; nihil ;
+     SECONDARY{C}.
+C) SECONDARY{B,531a,542c} ::
+     LEAP generator{523a} coercee ; selection{531a} coercee ;
+     PRIMARY{D}.
+D) PRIMARY{C,532a,543a} ::
+     slice{532a} coercee ; call{543a} coercee ;
+     format text{A341a} coercee ;
+     applied identifier with TAG{48b} coercee ;
+     ENCLOSED clause{31a,33a,c,d,e,34a,35a}.
+
+a) *SOME hip :
+     SOME jump{544a} : SOME skip{552a} ; SOME nihil{524a}.
+
+5.2 Units associated with names
+
+5.2.1 Assignations
+
+5.2.1.1 Syntax
+
+a) REF to MODE NEST assignation{5A} :
+     REF to MODE NEST destination{b}, becomes{94c} token,
+       MODE NEST source{c}.
+b) REF to MODE NEST destination{a} :
+     soft REF to MODE NEST TERTIARY{5B}.
+c) MODE1 NEST source{a,44d} :
+     strong MODE2 NEST unit{32d},
+       where MODE1 deflexes to MODE2{47a,b,c,-}.
+
+5.2.2 Identity relations
+
+5.2.2.1 Syntax
+
+a) boolean NEST identity relation{5A} :
+     where soft balances SORT1 and SORT2{32f},
+       SORT1 reference to MODE NEST TERTIARY1{5B},
+       identity relator{b},
+       SORT2 reference to MODE NEST TERTIARY2{5B}.
+b) identity relator{a} : is{94f} token ; is not{94f} token.
+
+5.2.3 Generators
+
+5.2.3.1 Syntax
+
+a) reference to MODE NEST LEAP generator{5C} :
+     LEAP{94d,-} token, actual MODE NEST declarer{46a}.
+b) reference to MODINE NEST LEAP sample generator{44e} :
+     LEAP{94d,-} token, actual MODINE NEST declarer{44b,46a} ;
+     where (LEAP) is (local), actual MODINE NEST declarer{44b,46a}.
+
+5.2.4 Nihils
+
+5.2.4.1 Syntax
+
+a) strong reference to MODE NEST nihil{5B} :
+     nil{94f} token.
+
+5.3 Units associated with stowed values
+
+5.3.1 Selections
+
+5.3.1.1 Syntax
+
+A) REFETY :: REF to ; EMPTY.
+B) REFLEXETY :: REF to ; REF to flexible ; EMPTY.
+
+a) REFETY MODE1 NEST selection{5C} :
+     MODE1 field FIELDS applied field selector with TAG{48d},
+       of{94f} token, weak REFLEXETY ROWS of structured with
+                           FIELDS mode NEST SECONDARY{5C},
+       where (REFETY) is derived from (REFLEXETY){b,c,-}.
+b) WHETHER (transient reference to) is derived from
+           (REF to flexible){a,532,66a} :
+     WHETHER true.
+c) WHETHER (REFETY) is derived from (REFETY){a,532a,66a} :
+     WHETHER true.
+
+5.3.2 Slices
+
+5.3.2.1 Syntax
+
+A) ROWSETY :: ROWS ; EMPTY.
+
+a) REFETY MODE1 NEST slice{5D} :
+     weak REFLEXETY ROWS1 of MODE1 NEST PRIMARY{5D},
+       ROWS1 leaving EMPTY NEST indexer{b,c,-} STYLE bracket,
+       where (REFETY) is derived from (REFLEXETY){531b,c,-} ;
+     where (MODE1) is (ROWS2 of MODE2),
+       weak REFLEXETY ROWS1 of MODE2 NEST PRIMARY{5D},
+       ROWS1 leaving ROWS2 NEST indexer{b,d,-} STYLE bracket,
+       where (REFETY) is derived from (REFLEXETY){531b,c,-}.
+b) row ROWS leaving ROWSETY1 ROWSETY2 NEST indexer{a,b} :
+     row leaing ROWSETY1 NEST indexer{c,d,-}, and also{94f} token,
+       ROWS leaving ROWSETY2 NEST indexer{b,c,d,-}.
+c) row leaving EMPTY NEST indexer{a,b} : NEST subscript{3}.
+d) row leaving row NEST indexer{a,b} :
+     NEST trimmer{f} ; NEST revised lower bound{g} option.
+e) NEST subscript{c} : meek integral NEST unit{32d}.
+f) NEST trimmer{d} :
+     NEST lower bound{46m} option, up to{94f} token,
+       NEST upper bound{46n} option,
+       NEST revised lower bound{g} option.
+g) NEST revised lower bound{d,f} :
+     at{94f} token, NEST lower bound{46m}.
+
+h) *trimscript :
+     NEST subscript{e} ; NEST trimmer{f};
+     NEST revised lower bound{g} option.
+i) *indexer :
+     ROWS leaving ROWSETY NEST indexer{b,c,d}.
+j) *boundscript :
+     NEST subscript{e} ; NEST lower bound{46m} ;
+     NEST upper bound{46n} ; NEST revised lowe bound{g}.
+
+5.4 Units associated with routines
+
+5.4.1 Routine texts
+
+5.4.1.1 Syntax
+
+a) procedure yielding MOID NEST1 routine text{44d,5A} :
+     formal MOID NEST1 declarer{46b}, routine{94f} token,
+       strong MOID NEST1 unit{32d}.
+b) procedure with PARAMETERS yielding
+             MOID NEST1 routine text{44d,5A} :
+     NEST1 new DECS2 declarative defining
+           new DECS2{e} brief pack,
+       where DECS2 like PARAMETERS{c,d,-},
+       formal MOID NEST1 declarer{46b}, routine{94f} token,
+       strong MOID NEST1 new DECS2 unit{32d}.
+c) WHETHER DECS DEC like PARAMETERS PARAMETER{b,c} :
+     WHETHER DECS like PARAMETERS{c,d-}
+             and DEC like PARAMETER{d,-}.
+d) WHETHER MODE TAG like MODE parameters{b,c} :
+     WHETHER true.
+e) NEST2 declarative defining new DECS2{b,e,34j} :
+     formal MODE NEST2 declarer{46b},
+       NEST2 MODE parameter joined definition of DECS2{41b,c} ;
+     where (DECS2) is (DECS3 DECS4),
+       formal MODE NEST2 declarer{46b},
+       NEST2 MODE parameter joind definition of DECS3{41b,c},
+       and also{94f} token, NEST2 declarative defining new DECS4{3}.
+f) NEST2 MODE parameter efinition of MODE TAG2{41c} :
+     MDOE NEST2 defining identifier with TAG2{48a}.
+
+g) *formal MODE parameter :
+     NEST MODE parameter definition of MODE TAG{f}.
+
+5.4.2 Formulas
+
+5.4.2.1 Syntax
+
+A) DYADIC :: priority PRIO.
+B) MONADIC :: priority iii iii iii i.
+C) ADIC :: DYADIC ; MONADIC.
+D) TALLETY :: TALLY ; EMPTY.
+
+a) MOID NEST DYADIC formula{c,5B} :
+     MODE1 NEST DYADIC TALLETY operand{c,-},
+       procedure with MODE1 parameter MODE2 parameter
+                 yielding MOID NEST applied operator with TAD{48b},
+       where DYADIC TAD identified in NEST{72a},
+       MODE2 NEST DYADIC TALLY operand{c,-}.
+b) MOID NEST MONADIC formula{c,5B} :
+     procedure with MODE parameter yielding MOID
+               NEST applied operator ith TAM{48b},
+       MODE NEST MONADIC operand{c}.
+c) MODE NEST ADIC operand{a,b} :
+     firm MODE NEST ADIC formula{a,b} coercee{61b} ;
+     where (ADIC) is (MONADIC), firm MODE NEST SECONDARY{5C}.
+
+d) *MOID formula : MOID NEST ADIC formula{a,b}.
+e) *DUO dyadic operator with TAD :
+     DUO NEST DEFIED operator with TAD{48a,b}.
+f) *MONO monadic operator with TAM :
+     MONO NEST DEFIED operator with TAM{48a,b}.
+g) *MODE operand : MODE NEST ADIC operand{c}.
+
+5.4.3 Calls
+
+5.4.3.1 Syntax
+
+a) MOID NEST call{5D} :
+     meek procedure with PARAMETERS yielding MOID NEST PRIMARY{5D},
+       actual NEST PARAMETERS{b,c} brief pack.
+b) actual NEST PARAMETERS PARAMETER{a,b} :
+     actual NEST PARAMETERS{b,c}, and also{94f} token,
+       actual NEST PARAMETER{c}.
+c) actual NEST MODE parameter{a,b} : strong MODE NEST unit{32d}.
+
+5.4.4 Jumps
+
+5.4.4.1 Syntax
+
+a) strong MOID NEST jump{5A} :
+     go to{b} option,
+       label NEST applied identifier with TAG{48b}.
+b) go to{a} : STYLE go to{94f,-} token ;
+              STYLE go{94f,-} token, STYLE to symbol{94g,-}.
+
+5.5 Units associated with values of any mode
+
+5.5.1 Casts
+
+5.5.1.1 Syntax
+
+a) MOID NEST cast{5D} :
+     formal MOID NEST declarer{46b},
+       strong MOID NEST ENCLOSED clause{31a,33c,d,e,34a,35a,-}.
+
+5.5.2 Skips
+
+5.5.2.1 Syntax
+
+a) strong MOID NEST skip{5A} : skip{94f} token.
+
+5.6 Holes
+
+5.6.1 Syntax
+
+A) LANGUAGE :: algol sixty eight ; fortran ; c language ; cpp language.
+B) ALGOL68 :: algol sixty eight.
+C) FORTRAM :: fortran.
+D) CLANG :: c language.
+E) CPPLANG :: cpp language.
+F) DLANG :: d language.
+
+a) strong MOID NEST virtual hole{5A} :
+     virtual nest symbol, strong MOID NEST closed clause{31a}.
+b) strong MOID NEST formal hole{5A} :
+     formal nest{94d} token, MOID LANGUAGE indication{e,f,-},
+       hole indication{d}.
+c) MOID NEST actual hole{A6a} :
+     strong MOID NEST ENCLOSED clause{31a,33a,c,34a,35a,36a,-}.
+d) hole indication{b} :
+     character denotation{814a} ; row of character denotation{83a}.
+e) MOID ALGOL68 indication{b} : EMPTY.
+f) MOID FORTRAN indication{b} : bold letter f letter o letter r letter t
+                                     letter r letter a letter n token.
+g) MOID CLANG indication{b} : bold letter c letter l letter a letter n
+                                   letter g.
+e) MOID CPPLANG indication{b} : bold letter c letter p letter p letter l
+                                     letter a letter n letter g.
+f) MOID DLANG indication{b} : bold letter d letter l letter a letter n
+                                   letter g.
+
+{ Since no representation is provided for the virtual-nest-symbol, the
+  user is unable to construct virtual-holes for himself, but a
+  mechanism is provided (10.6.2.a) for constructing them out of
+  formal- and actual-holes. }
+
+5.7 Short-circuit logical functions
+
+{ Extensions: [SC] }
+
+{ The short-circuit logical functions are pseudo-operators providing
+  logical AND and OR functions with short-circuited elaboration.  }
+
+5.7.1 Syntax
+
+a) boolean NEST and function{5A} :
+     meek boolean NEST TERTIARY1, andth{94c} token, meek boolean NEST TERTIARY2.
+
+b) boolean NEST or function{5A} :
+     meek boolean NEST TERTIARY1, orel{94c} token, meek boolean NEST TERTIARY2.
+
+c) *boolean NEST short circuit function :
+     boolean NEST and function{a} ; boolean NEST or function{b}.
+
+{ Examples:
+    a) UPB str > 2 ANDTH str[3] /= "x"
+    b) error = 0 OREL (print ("error"); stop; SKIP) }
+
+6 Coercion
+
+6.1 Coercees
+
+6.1.1 Syntax
+
+A) STRONG{a,66a} ::
+     FIRM{B} ; widened to{65a,b,c,d} ; rowed to{66a} ;
+     voided for{67a,b}.
+B) FIRM{A,b} :: MEEK{C} ; united to{64a}.
+C) MEEK{B,c,d,64a,63a,64a,65a,b,c,d} ::
+     unchanged from{f} ; dereferenced to{62a} ; deprocedured to{63a}.
+D) SOFT{e,63b} ::
+     unchanged from{f} ; softly deprocedured to{63b}.
+E) FORM :: MORF ; COMORF.
+F) MORF ::
+     NEST selection ; NEST slice ; NEST routine text ;
+     NEST ADIC formula ; NEST call ;
+     NEST applied identifier with TAG.
+G) COMORF ::
+     NEST assignation ; NEST identity relation ;
+     NEST LEAP generator ; NEST cast ; NEST denoter ;
+     NEST format text.
+
+a) strong MOID FORM coercee{5A,B,C,D,A341i} :
+     where (FORM) is (MORF), STRONG{A} MOID MORF ;
+     where (FORM) is (COMORF), STRONG{A} MOID COMORF,
+       unless (STRONG MOID) is (deprocedured to void).
+b) firm MODE FORM coercee{5A,B,C,D,542c} : FIRM{B} MODE FORM.
+c) meek MODE FORM coercee{5A,B,C,D} : MEEK{C} MOID FORM.
+d) weak REFETY STOWED FORM coercee{5A,B,C,D} :
+     MEEK{C} REFETY STOWED FORM,
+       unless (MEEK) is (dereferenced to)
+              and (REFETY) is (EMPTY).
+e) soft MODE FORM coercee{5A,B,C,D} : SOFT{D} MODE FORM.
+f) unchanged from MOID FORM{C,D,67a,b} : MOID FORM.
+
+g) *SORT MOID coercee : SORT MOID FORM coercee{a,b,c,d,e}.
+h) *MOID coercend : MOID FORM.
+
+{ Examples:
+    a) 3.14 (in x := 3.14)
+    b) 3.14 (in x + 3.14)
+    c) sin (in sin (x))
+    d) x1 (in x1[2] := 3.14)
+    e) x (in x := 3.14)  }
+
+6.2 Dereferencing
+
+6.2.1 Syntax
+
+a) dereferenced to{61C} MODE1 FORM :
+     MEEK{61C} REF to MODE2 FORM,
+       where MODE2 deflexes to MODE1{47a,b,c,-}.
+
+{ Examples:
+    a) x in (real (x)) }
+
+6.3 Deproceduring
+
+6.3.1 Syntax
+
+a) deprocedured to{61C,67a} MOID FORM :
+     MEEK{61C} procedure yielding MOID FORM.
+b) softly deprocedured to{61D} MODE FORM :
+     SOFT{61D} procedure yielding MODE FORM.
+
+{ Examples:
+    a) random (in real (random))
+    b) x or y (in x or y := 3.14, given
+               PROC x or y = REF REAL: (random < .5 | x | y)) }
+
+6.4 Uniting
+
+6.4.1 Syntax
+
+a) united to{64B} UNITED FORM :
+     MEEK{61C} MOID FORM,
+       where MOID unites to UNITED{b}.
+b) WHETHER MOID1 unites to MOID2{a,34i,71m} :
+     where MOID1 equivalent MOID2{73a}, WHETHER false ;
+     unless MOID1 equivalent MOID2{73a},
+       WHETHER safe MOODS1 subset of safe MOODS2{73l,m,n},
+       where (MOODS1) is (MOID1)
+             or (union of MOODS1 mode) is (MOID1),
+       where (MOODS2) is (MOIDS2)
+             or (union of MOODS2 mode) is (MOIDS2).
+
+{ Examples:
+    a) x (in uir := x)
+       u (in UNION(CHAR,INT,VOID)(u), in a reach containing
+          UNION(INt,VOID) u := EMPTY) }
+
+6.5 Widening
+
+6.5.1 Syntax
+
+A) BITS :: structured with
+                      row of boolean field SITHETY letter aleph mode.
+B) BYTES :: structured with
+                       row of character field SITHETY letter aleph mode.
+C) SITHETY :: LENGTH LENGTHETY ; SHORT SHORTHETY ; EMPTY.
+D) LENGTH :: letter l letter o letter n letter g.
+E) SHORT :: letter s letter h letter o letter r letter t.
+F) LENGTHETY :: LENGTH LENGTHETY ; EMPTY.
+G) SHORTHETY :: SHORT SHORTHETY ; EMPTY.
+
+a) widened to{b,61A} SIZETY real FORM :
+     MEEK{61C} SIZETY integral FORM.
+b) widened to{61A} structured with SIZETY real field letter r letter e
+           SIZETY real field letter i letter m mode FORM :
+     MEEK{61C} SIZETY real FORM ;
+     widened to{a} SIZETY real FORM.
+c) widened to{61A} row of boolean FORM : MEEK{61C} BIT FORM.
+d) widened to{61A} row of character FORM : MEEK{61C} BYTES FORM.
+
+{ Examples:
+    a) 1 (in x := 1)
+    b) 1.0 (in z := 1.0)
+       1 (in z := 1)
+    c) 2r101 (in []BOOL(2r101))
+    d) r (in []CHAR(r)) }
+
+6.6 Rowing
+
+6.6.1 Syntax
+
+a) rowed to{61A} REFETY ROWS1 of MODE FORM :
+     where (ROWS1) is (row),
+       STRONG{61A} REFLEXETY MODE FORM,
+       where (REFETY) is derived from (REFLEXETY){531b,c,-} ;
+     where (ROWS1) is (row ROWS2),
+       STRONG{61A} REFLEXETY ROWS2 of MODE FORM,
+       where (REFETY) is derived from (REFLEXETY){531b,c,-}.
+
+{ Examples:
+    a) 4.13 (in [1:1]REAL b1 := 4.13)
+       x1 (in [1:1,1:n]REAL b2 := x1) }
+
+6.7 Voiding
+
+6.7.1 Syntax
+
+A) NONPROC :: PLAIN ; STOWED ; REF to NONPROC ;
+              procedure with PARAMETERS yielding MOID ; UNITED.
+
+a) voided to{61A} void MORF :
+     deprocedured to{63a} NONPROC MORF ;
+     unchanged from{61f} NONPROC MORF.
+b) voided to{61A} void COMORF :
+     unchanged from{61f} MODE COMORF.
+
+{ Examples:
+    a) random (in SKIP; random;)
+       next random (last random)
+         (in SKIP; next random (lat random);)
+    b) PROC VOID (pp) (in PROC PROC VOID pp = PROC VOID : (print (1);
+            VOID : print (2)); PROC VOID (pp);) }
+
+8 Denotations
+
+8.1 Plain denotations
+
+8.1.0.1 Syntax
+
+A) SIZE:: long ; short.
+B) *NUMERAL :: fixed point numeral ; variable point numeral ;
+               floating point numeral.
+
+a) SIZE INTREAL denotation{a,80a} :
+     SIZE symbol{94d}, INTREAL, denotation{a,811a,812a}.
+
+b) *plain denotation :
+     PLAIN denotation{a,811a,812a,813a,814a} ; void denotation{815a}.
+
+{ Example:
+    a) LONG 0 }
+
+8.1.1 Integral denotations
+
+8.1.1.1 Syntax
+
+a) integral denotation{80a,810a} : fixed point numeral{b}.
+b) fixed point numeral{a,812c,d,f,i,A341h} : digit cypher{c} sequence.
+c) digit cypher{b} : DIGIT symbol{94b}.
+
+{ Examples:
+    a) 4096
+    b) 4096
+    c) 4 }
+
+8.1.2 Real denotations
+
+8.1.2.1 Syntax
+
+a) real denotation{80a,810a} :
+     variable point numeral{b} ; floating point numeral{e}.
+b) variable point numeral{a,f} :
+     integral part{c} option, fractional part{d}.
+c) integral part{b} : fixed point numeral{811b}.
+d) fractional part{b} : point symbol{94b}, fixed point numeral{811b}.
+e) floating point numeral{a} : stagnant part{f}, exponent part{g}.
+f) stagnant part{e} :
+     fixed point numeral{811b} : variable point numeral{b}.
+g) exponent part{e} :
+     times ten to the power choice{h}, power of then{i}.
+h) times ten to the power choice{g} :
+     times ten to the power symbol{94b} ; letter e symbol{94a}.
+i) power of ten{g}: plusminus{j} option, fixed point numeral{811b}.
+j) plusminus{i} : plus symbol{94c} ; mius symbol{94c}.
+
+{ Examples:
+    a) 0.00123
+       1.23e-3
+    b) 0.00123
+    c) 0
+    d) .00123
+    e) 1.23e-3
+    f) 123
+       1.23
+    g) E-3
+    h) E
+    i) -3
+    j) +
+       - }
+
+8.1.3 Boolean denotations
+
+8.1.3.1 Syntax
+
+a) boolean denotation{80a} : true{94b} symbol ; false{94b} smbol.
+
+{ Examples:
+    a) TRUE
+       FALSE }
+
+8.1.4 Character denotations
+
+8.1.4.1 Syntax
+
+a) character denotation{80a} :
+     quote{94b} symbol, string item{b}, quote sybol{94b}.
+b) string item{a,83b} :
+     character glyph{c} ; quote image symbol{94f} ; other string item{d}.
+c) character glyph{b,92c} :
+     LETTER symbol{94a} ; DIGIT symbol{94b} ;
+     point sybol{94b} ; open symbol{94f} ; close symbol{94f} ;
+     comma symbol{94b} ; space symbol{94b} ;
+     plus symbol{94c} ; minus symbol{94c}.
+
+{ A production rule may be added for the notion 'other string item'
+  each of whose alternatives is a symbol 1.1.3.1.f which is different
+  from any terminal production of 'character glyph' and which is not
+  'quote symbol' }
+
+{ Examples:
+    a) "a"
+    b) a
+       ""
+       ?
+    c) a 1 . ( ) , . space + - }
+
+8.1.5 Void denotation
+
+5.1.5.1 Syntax
+
+a) void denotation{80a} : empty{94b} symbol.
+
+{ Example:
+    a) EMPTY }
+
+8.2 Bits denotations
+
+8.2.1 Syntax
+
+A) RADIX :: radix two ; radix four ; radix eight ; radix sixteen.
+
+a) structured with row of boolean field
+              LENGTH LENGTHETY letter aleph mode denotation{a,80a} :
+     long{94d} symbol, structured with row of boolean field
+                                  LENGTHETY letter aleph mode denotation{a,c}.
+b) structured with row of boolean field
+              SHORT SHORTHTETY letter aleph mode denotation{b,80a} :
+     short{94d} symbol,
+       structured with row of boolean field SHORTHETY letter aleph mode denotation{b,c}.
+c) structured wih row of boolean field
+              letter aleph mode denotation{a,b,80a} :
+     RADIX{d,e,f,g}, letter r symbol{94a}, RADIX digit{h,i,j,k} sequence.
+d) radix two{c,A347b} : digit two{94b} symbol.
+e) radix four{c,A347b} : digit four{94b} symbol.
+f) radix eight{c,A347b} : digit eight{94b} symbol.
+g) radix sixteen{c,A347b} : digit one symbol{94b}, digit six symbol{94b}.
+h) radix two digit{c,i} : digit zero symbol{94b} ; digit one symbol{94b}.
+i) radix four digit{c,j} :
+     radix two digit{h} ; digit two symbol{94b} ;
+     digit three symbol{94b}.
+j) raidx eight digit{c,k} :
+     radix four digit{i} ; digit four symbol{94b} ;
+     digit five symbol{94b} ; digit six symbol{94b} ;
+     digit seven symbol{94b}.
+k) radix sixteen digit{c} :
+     radix eight digit{j} ; digit eight symbol{94b} ;
+     digit nine symbol{94b} ; letter a symbol{94a} ;
+     letter b symbol{94a} ; letter e symbol{94a} ; letter d symbol{94a} ;
+     letter e symbol{94a} ; letter f symbol{94a}.
+
+l) *bits denotation : BITS denotation{a,b,c}.
+m) *radix digit : RADIX digit{h,i,j,k}.
+
+{ Examples:
+    a) LONG 2r101
+    b) SHORT 16rffff
+    c) 8r231 }
+
+8.3 String denotations
+
+8.3.1 Syntax
+
+a) row of character denotation{80a} :
+     quote{94b} symbol, string{b} option, quote symbol{94b}.
+b) string{a} : string item{814b}, string item{814b} sequence.
+
+c) *string denotation : row of charater denotation{a}.
+
+{ Examples:
+    a) "abc"
+    b) abc }
+
+9 Tokens and symbols
+
+9.1 Tokens
+
+{ Tokens are symbols possibly preceded by pragments.  }
+
+9.1.1 Syntax
+
+a) CHOICE STYLE start{34a} :
+     where (CHOICE) is (choice using boolean),
+       STYLE if{94f,-} token ;
+     where (CHOICE) is (CASE), STYLE case{94f,-} token.
+b) CHOICE STYLE in{34e} :
+     where (CHOICE) is (choice using boolean),
+       STYLE then{94f,-} token ;
+     where (CHOICE) is (CASE), STYLE in{94f,-} token.
+c) CHOICE STYLE again{34l} :
+     where (CHOICE) is (choice using boolean),
+       STYLE else if{94f,-} token ;
+     where (CHOICE) is (CASE), STYLE ouse{94f,-} token.
+d) CHOICE STYLE out{34l} :
+     where (CHOICE) is (choice using boolean),
+       STYLE else{94f,-} token ;
+     where (CHOICE) is (CASE), STYLE out{94f,-} token.
+e) CHOICE STYLE finish{34a} :
+     whre (CHOICE) is (choice using boolean),
+       STYLE fi{94f,-} token ;
+     where (CHOICE) is (CASE), STYLE esac{94f,-} token.
+f) NOTION token :
+     pragment{92a} sequence option,
+       NOTION symbol{94a,b,c,d,e,f,g,h}.
+
+g) *token : NOTION token{f}.
+h) *symbol : NOTION symbol{94a,b,c,d,e,f,g,h}.
+
+9.2 Comments and pragmats
+
+9.2.1 Syntax
+
+{ Extensions:
+  [NC] nestable comments.  }
+
+A) PRAGMENT :: pragmat ; comment.
+
+a) pragment{80a,91f,A341b,h,A348a,b,c,A349a,A34Ab} : PRAGMENT{b}.
+b) PRAGMENT{a} :
+     STYLE PRAGMENT symbol{94h,-},
+       STYLE PRAGMENT item{c} sequence option,
+       STYLE PRAGMENT symbol{94h,-} ;
+     STYLE nestable comment{d}.
+c) STYLE PRAGMENT item{b} :
+     character glyph{814c} ; STYLE other PRAGMENT item{d}.
+d) STYLE nestable comment{b} :
+     STYLE comment begin symbol{94h,-},
+       STYLE nestable comment contents{e} sequence,
+       STYLE comment end symbol{94h,-}.
+e) STYLE nestable comment contents{d} :
+     STYLE nestable comment item{c} sequence option,
+       STYLE nestable comment{d} option.
+f) STYLE nestable comment item{e} :
+     character glyph{814c} ; STYLE other nestable comment item{d}.
+
+{ A production rule may be added for each notion designated by 'STYLE
+  other PRAGMENT item' each of whose alternatives is a symbol
+  different from any terminal production of 'character glyph', and
+  such that no terminal production of any 'STYLE other PRAGMENT item'
+  is the corresponding 'STYLE PRAGMENT symbol'.  This allows to nest
+  different comment or pragmat for example.  }
+
+9.4 The reference language
+
+9.4.1 Representations of symbols
+
+{ Extensions:
+  [CS] andth symbol, orel symbol
+  [MR] access symbol
+  [US] unsafe symbol }
+
+{ This section of the Report doesn't describe syntax, but lists all
+  the different symbols along with their representation in the
+  reference language.  We only include here symbols corresponding to
+  the GNU extensions implemented by this compiler.  }
+
+        symbol                         representation
+
+c) andth symbol{57a}                    ANDTH
+   orel symbol{57b}                     OREL
+d) access symbol{36b}                   ACCESS
+f) unsafe symbol{37a}                   UNSAFE
+h) bold comment begin symbol{92a}       NOTE
+   bold comment end symbol{92a}         ETON
+   brief comment begin symbol{92a}      {
+   brief comment end symbol{92a}        }
+
+10.1.1 Syntax
+
+{ Extensions:
+  [MR] user, user task }
+
+A) EXTERNAL :: user.
+
+f) NEST1 user task{d} :
+     NEST2 particular prelude with DECS{c},
+       NEST2 user prelude with MODSETY{c},
+       NEST2 particular program{g} PACK, go on{94f} token,
+       NEST2 particualr poslude{i},
+       where (NEST2) is (NEST1 new DECS MODSETY STOP).
+
+10.6 Packets
+
+10.6.1 Syntax
+
+a) MOID NEST new MODSETY ALGOL68 stuffing packet{A7a} :
+     egg{94d} token, hole indication{56d}, is defined as{94d} token,
+       MOID NEST new MODSETY actual hole{56c}.
+
+{ b) Note that the rules for "MOID NEST new MODSETY LANGUAGE stuffing
+  packets" for other languages are not explicitly included in the
+  syntax.  These rules conceptually transform all such
+  LANGUAGE-stuffing-packets into ALGOL68-stuffing-packets with the
+  same meaning. }
+
+c) NEST new MODSETY1 MODS definition module packet of MODS{A7a} :
+     egg{94d} token, hole indication{56d}, is defined as{94d} token,
+       NEST new MODSETY1 MODS module declaration of MODS{49a},
+       where MODS absent from NEST{e}.
+d) new LAYER1 new DECS MODSETY1 MODS STOP
+       prelude packet of MODS{A7a} :
+     new LAYER1 new DECS MODSETY1 MODS STOP
+         module declaration of MODS{4a},
+       where MODS absent from new LAYER1{e}.
+e) WHETHER MODSETY MOD absent from NEST{c,d} :
+     WHETEHR MODSETY absent from NEST{e,f}
+             and MOD independent PROPSETY{71a,b,c},
+       where PROPSETY collected properties from NEST{g,h}.
+f) WHETHER EMPTY absent from NEST{e} :
+     WHETHER true.
+g) WHETHER PROPSETY1 PROPSETY2 collected properties from
+           NEST new PROPSETY2{e,g} :
+     WHETHER PROPSETY1 collected properties from NEST {g,h}.
+h) WHETHER EMPTY collected properties from new EMPTY{e,g} :
+     WHETHER true.
+
+i) *NEST new PROPSETY packet :
+     MOID NEST new PROPSETY LANGUAGE stuffing packet{a,b} ;
+     NEST new PROPSETY definition module packet of MODS{c} ;
+     NEST new PROPSETY particular program{A1g} ;
+     NEST new PROPSETY prelude packet of MODS{d}.
+j) *letter symbol : LETTER symbol{94a}.
+k) *digit symbol : DIGIT symbol{94b}.
+
+{ Examples:
+
+    a) EGG "abc" = ACCESS A,B (x := 1; y := 2; print (x+y))
+    c) EGG "abc" = MODULE A = DEF PUB REAL x FED
+    d) MODULE B = DEF PUB REAL y FED
+
+  The thre examples above would form a compatible collection of
+  packets when taken in conjunction with the particular-program BEGIN
+  NEST "abc" END }
+
+{ In rule a above, 'MODSETY' envelops the 'MOD's defined by al the
+  definition-module-packets that are being stuffed along with the
+  stuffing-packet.
+
+  In rules c and d, 'MODSETY1' need only envelop the 'MOD's for those
+  modules actually accessed from within that packet.
+
+  The semantics related to packets are only defined if, for a
+  collection of packets being stuffed together, all the 'MOD's
+  enveloped by the various 'MODSETY1's are enveloped by 'MODSETY'.  }
+
+{ A stuffing packet contains the definition of an actual-hole.  For
+  Algol 68 this consists on an enclosed-clause.  For other values of
+  the metanotion 'LANGUAGE' it is different, and it is expected to be
+  translated somehow to an equivalent Algol 68 definition,
+  conceptually naturally.
+
+  A definition module packet contains the definition of an actual-hole
+  which consists in one or more joined module declarations, with the
+  restriction that none of the declared modules shall exist in the
+  static environment at the formal-hole.
+
+  A prelude packet contains one or more joined module declarations.  }
+
+10.7 Compilation systems
+
+{ An implementtion of Algol 68 in which packets of a collection are
+  compiled into a collection of object-modules should conform to the
+  provisions of this section.  }
+
+10.7.1 Syntax
+
+{ Note that we use the notion "compilation unit" rather than the
+  original "compilation input" used in the IFIP modules definition.  }
+
+A) *LAYERS :: LAYER ; LAYERS LAYER.
+
+a) compilation unit :
+     MOID NEST new MODSETY LANGUAGE stuffing packet{A6a,b},
+       MOID NEST hole interface{d},
+       joined module interface with MODSETY{b,c} ;
+     NEST new MODSETY1 MODS definition module packet of MODS{A6c},
+       MOID NEST hole interface{d},
+       joined module interface with MODSETY1{b,c},
+       module interface with MODS{d} option ;
+     new LAYER1 new DECS MODSETY STOP particular program{A1g},
+       { void new LAYER1 new DECS STOP hole interface,}
+       unless (DECS) contains (MODULE),
+       joined module interface with MODSETY{b,c} ;
+     new LAYER1 new DECS MODSETY1 MODS STOP
+         prelude packet of MODS{A6d},
+       { void new LAYER1 new DECS STOP hole interface,}
+       unless (DECS) contains (module),
+       joined module interface with MODSETY1{b,c},
+       module interface with MODS{d} option.
+b) joined module interface with MODS MODSETY{a,b} :
+     module interface with MODS{d},
+       joined module interface with MODSETY{b,c}.
+c) joined module inteface with EMPTY{a,b} : EMPTY.
+
+{ A compilation-unit is either a stuffing packet, a definition module
+  packet, a particular program, or a prelude packet.  The packets
+  shall be accompanied by the required hole and module interface
+  information.  }
+
+{ d) Hyper-rules for "MOID NEST hole interface", "module interface
+     with MODS" and "MOID NEST object module".  The terminal
+     productions will most likely be in some cryptic notation
+     understood only by the compiler, i.e. the interface data. }
+
+{ The inclusion of the hypernotions "void new LAYER1 new DECS STOP
+  hole interface" within pragmatic remarks in rule a is intended to
+  signify that this information (which describes the standard
+  environment) must clearly be available to the compiler, but that it
+  may well not be provided in the form of an explicit
+  hole-interface. }
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 10/47] a68: ga68 compiler driver
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (8 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 09/47] a68: gcc/algol68 misc files Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 11/47] a68: a681 compiler proper Jose E. Marchesi
                   ` (37 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds the main sources for the ga68 compiler driver.

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

gcc/ChangeLog:

	* algol68/a68spec.cc: New file.
	* algol68/lang-specs.h: Likewise.
---
 gcc/algol68/a68spec.cc   | 222 +++++++++++++++++++++++++++++++++++++++
 gcc/algol68/lang-specs.h |  24 +++++
 2 files changed, 246 insertions(+)
 create mode 100644 gcc/algol68/a68spec.cc
 create mode 100644 gcc/algol68/lang-specs.h

diff --git a/gcc/algol68/a68spec.cc b/gcc/algol68/a68spec.cc
new file mode 100644
index 00000000000..bc11abde76e
--- /dev/null
+++ b/gcc/algol68/a68spec.cc
@@ -0,0 +1,222 @@
+/* a68spec.c -- Specific flags and argument handling of the Algol 68 front end.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "opt-suggestions.h"
+#include "gcc.h"
+#include "tm.h"
+#include "opts.h"
+
+/* satisfy intellisense  */
+#include "options.h"
+
+/* How to link with libga68.  */
+enum libga68_link_mode
+{
+  LIBGA68_NOLINK,
+  LIBGA68_STATIC,
+  LIBGA68_DYNAMIC
+};
+
+static enum libga68_link_mode libga68_link = LIBGA68_STATIC;
+
+/* This bit is set if we saw a `-xfoo' language specification.  */
+#define LANGSPEC (1 << 1)
+/* This bit is set if they did `-lc'.  */
+#define WITHLIBC (1 << 2)
+/* Skip this option.  */
+#define SKIPOPT (1 << 3)
+
+void
+lang_specific_driver (struct cl_decoded_option **in_decoded_options,
+		      unsigned int *in_decoded_options_count,
+		      int *in_added_libraries)
+{
+  unsigned int i, j;
+
+  /* The new argument list will be contained in this.  */
+  struct cl_decoded_option *new_decoded_options;
+
+  /* "-lc" if it appears on the command line.  */
+  const struct cl_decoded_option *saw_libc = 0;
+
+  /* An array used to flag each argument that needs a bit set for
+     LANGSPEC or WITHLIBC.  */
+  int *args;
+
+  /* True if we saw -static.  */
+  int static_link = 0;
+
+  /* True if we should add -shared-libgcc to the command-line.  */
+  int shared_libgcc = 1;
+
+  /* The total number of arguments with the new stuff.  */
+  unsigned int argc;
+
+  /* The argument list.  */
+  struct cl_decoded_option *decoded_options;
+
+  /* The number of libraries added in.  */
+  int added_libraries;
+
+  /* The total number of arguments with the new stuff.  */
+  int num_args = 1;
+
+  /* Whether the -o option was used.  */
+  //  bool saw_opt_o = false;
+
+  argc = *in_decoded_options_count;
+  decoded_options = *in_decoded_options;
+  added_libraries = *in_added_libraries;
+
+  args = XCNEWVEC (int, argc);
+
+  for (i = 1; i < argc; i++)
+    {
+      const char *arg = decoded_options[i].arg;
+
+      switch (decoded_options[i].opt_index)
+	{
+	case OPT__help:
+	case OPT__help_:
+	  /* Let gcc.cc handle this.  */
+	  *in_added_libraries = 0;
+	  return;
+	case OPT_c:
+	case OPT_E:
+	case OPT_M:
+	case OPT_MM:
+	case OPT_fsyntax_only:
+	case OPT_S:
+	  libga68_link = LIBGA68_NOLINK;
+	  break;
+
+	case OPT_l:
+	  if (strcmp (arg, "c") == 0)
+	    args[i] |= WITHLIBC;
+	  break;
+
+	case OPT_o:
+	  //saw_opt_o = true;
+	  break;
+
+	case OPT_static:
+	  static_link = 1;
+	  break;
+
+	case OPT_static_libgcc:
+	  shared_libgcc = 0;
+	  break;
+
+	case OPT_static_libga68:
+	  libga68_link = LIBGA68_STATIC;
+#ifdef HAVE_LD_STATIC_DYNAMIC
+	  /* Remove -static-libga68 from the command only if target supports
+	     LD_STATIC_DYNAMIC.  When not supported, it is left in so that a
+	     back-end target can use outfile substitution.  */
+	  args[i] |= SKIPOPT;
+#endif
+	  break;
+
+	case OPT_shared_libga68:
+	  libga68_link = LIBGA68_DYNAMIC;
+	  args[i] |= SKIPOPT;
+	  break;
+
+	case OPT_SPECIAL_input_file:
+	  break;
+	}
+    }
+
+    /* There's no point adding -shared-libgcc if we don't have a shared
+       libgcc.  */
+#ifndef ENABLE_SHARED_LIBGCC
+  shared_libgcc = 0;
+#endif
+
+  /* Make sure to have room for the trailing NULL argument.
+     - libga68 adds `-Bstatic -lga68 -Bdynamic' */
+  num_args = argc + shared_libgcc + 1 * 5 + 10;
+  new_decoded_options = XNEWVEC (struct cl_decoded_option, num_args);
+
+  i = 0;
+  j = 0;
+
+  /* Copy the 0th argument, i.e., the name of the program itself.  */
+  new_decoded_options[j++] = decoded_options[i++];
+
+  /* NOTE: We start at 1 now, not 0.  */
+  while (i < argc)
+    {
+      new_decoded_options[j] = decoded_options[i];
+
+      if (!saw_libc && (args[i] & WITHLIBC))
+	{
+	  --j;
+	  saw_libc = &decoded_options[i];
+	}
+
+      if ((args[i] & SKIPOPT) != 0)
+	--j;
+
+      i++;
+      j++;
+    }
+
+  if (saw_libc)
+    new_decoded_options[j++] = *saw_libc;
+  if (shared_libgcc && !static_link)
+    generate_option (OPT_shared_libgcc, NULL, 1, CL_DRIVER,
+		     &new_decoded_options[j++]);
+
+  /* Add `-lga68 -lm' if we haven't already done so.  */
+#ifdef HAVE_LD_STATIC_DYNAMIC
+  if (libga68_link == LIBGA68_STATIC && !static_link)
+    {
+      generate_option (OPT_Wl_, LD_STATIC_OPTION, 1, CL_DRIVER,
+		       &new_decoded_options[j++]);
+      added_libraries++; /* The driver calls add_infile while handling -Wl */
+    }
+#endif
+  generate_option (OPT_l,
+		   "ga68", 1,
+		   CL_DRIVER, &new_decoded_options[j++]);
+  added_libraries++;
+#ifdef HAVE_LD_STATIC_DYNAMIC
+  if (libga68_link == LIBGA68_STATIC && !static_link)
+    {
+      generate_option (OPT_Wl_, LD_DYNAMIC_OPTION, 1, CL_DRIVER,
+		       &new_decoded_options[j++]);
+      added_libraries++; /* The driver calls add_infile while handling -Wl */
+    }
+#endif
+  *in_decoded_options_count = j;
+  *in_decoded_options = new_decoded_options;
+  *in_added_libraries = added_libraries;
+}
+
+/* Called before linking.  Returns 0 on success and -1 on failure.  */
+int
+lang_specific_pre_link (void)
+{
+  if (libga68_link != LIBGA68_NOLINK)
+    do_spec ("%:include(libga68.spec)");
+  return 0;
+}
+
+/* Number of extra output files that lang_specific_pre_link may generate.  */
+int lang_specific_extra_outfiles = 0; /* Not used for Algol68.  */
diff --git a/gcc/algol68/lang-specs.h b/gcc/algol68/lang-specs.h
new file mode 100644
index 00000000000..737270c41f7
--- /dev/null
+++ b/gcc/algol68/lang-specs.h
@@ -0,0 +1,24 @@
+/* lang-specs.h -- gcc driver specs for Algol 68 frontend.
+   Copyright (C) 2025 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/>.  */
+
+/* This is the contribution to the `default_compilers' array in gcc.cc for the
+   Algol 68 language.  */
+
+{".a68", "@algol68", 0, 1, 0},
+  {"@algol68",
+   "a681 %i %(cc1_options) %{I*} %{L*} %D %{!fsyntax-only:%(invoke_as)}", 0, 1,
+   0},   
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 11/47] a68: a681 compiler proper
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (9 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 10/47] a68: ga68 compiler driver Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 12/47] a68: unicode support routines Jose E. Marchesi
                   ` (36 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds the language hooks and the target hooks for the Algol
68 front-end, which implement the a681 compiler proper.

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

gcc/ChangeLog

	* algol68/a68-lang.cc: New file.
	* algol68/algol68-target.def: Likewise.
	* genhooks.cc (hook_array): Include algol68/algol68-target.def.
---
 gcc/algol68/a68-lang.cc        | 751 +++++++++++++++++++++++++++++++++
 gcc/algol68/algol68-target.def |  52 +++
 gcc/genhooks.cc                |   1 +
 3 files changed, 804 insertions(+)
 create mode 100644 gcc/algol68/a68-lang.cc
 create mode 100644 gcc/algol68/algol68-target.def

diff --git a/gcc/algol68/a68-lang.cc b/gcc/algol68/a68-lang.cc
new file mode 100644
index 00000000000..ac2ba7c0b67
--- /dev/null
+++ b/gcc/algol68/a68-lang.cc
@@ -0,0 +1,751 @@
+/* Language-dependent hooks for Algol 68.
+   Copyright (C) 2025 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 "toplev.h"
+#include "langhooks.h"
+#include "langhooks-def.h"
+#include "target.h"
+#include "stringpool.h"
+#include "debug.h"
+#include "diagnostic.h"
+#include "opts.h"
+#include "machmode.h"
+#include "stor-layout.h" /* For layout_type */
+#include "vec.h"
+
+#include "a68.h"
+
+/* Global state for the Algol 68 front end.  */
+
+A68_T a68_common;
+
+/* The context to be used for global declarations.  */
+static GTY(()) tree global_context;
+
+/* Array of all global declarations to pass back to the middle-end.  */
+static GTY(()) vec <tree, va_gc> *global_declarations;
+
+/* Array of global type/decl nodes used by this front-end.  */
+
+tree a68_global_trees[ATI_MAX];
+
+/* Types expected by gcc's garbage collector.
+   These types exist to allow language front-ends to
+   add extra information in gcc's parse tree data structure. */
+
+struct GTY(()) lang_type
+{
+  MOID_T * GTY((skip)) moid;
+};
+
+struct GTY(()) lang_decl
+{
+  NODE_T * GTY((skip)) node;
+};
+
+/* Language-specific identifier information.  This must include a
+   tree_identifier.  */
+struct GTY(()) lang_identifier
+{
+  struct tree_identifier common;
+};
+
+
+struct GTY(()) language_function
+{
+  int dummy;
+};
+
+/* The Algol68 frontend Type AST for GCC type NODE.  */
+#define TYPE_LANG_FRONTEND(NODE) \
+  (TYPE_LANG_SPECIFIC (NODE) \
+   ? TYPE_LANG_SPECIFIC (NODE)->type : NULL)
+
+/* The resulting tree type.  */
+
+union GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
+            chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), "
+                        "TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN "
+                        "(&%h.generic)) : NULL"))) lang_tree_node
+{
+  union tree_node GTY((tag ("0"),
+		       desc ("tree_node_structure (&%h)"))) generic;
+  struct lang_identifier GTY ((tag ("1"))) identifier;
+};
+
+/* Allocate and return a lang specific structure for type tree nodes.  */
+
+struct lang_type *
+a68_build_lang_type (MOID_T *moid)
+{
+  tree ctype = CTYPE (moid);
+  struct lang_type *lt = ctype ? TYPE_LANG_SPECIFIC (ctype) : NULL;
+
+  if (lt == NULL)
+    lt = (struct lang_type *) ggc_cleared_alloc <struct lang_type> ();
+  if (lt->moid == NULL)
+    lt->moid = moid;
+  return lt;
+}
+
+/* Allocate and return a lang specific structure for decl tree nodes.  */
+
+struct lang_decl *
+a68_build_lang_decl (NODE_T *node)
+{
+  tree cdecl = CDECL (node);
+  struct lang_decl *ld = cdecl ? DECL_LANG_SPECIFIC (cdecl) : NULL;
+
+  if (ld == NULL)
+    ld = (struct lang_decl *) ggc_cleared_alloc <struct lang_decl> ();
+  if (ld->node == NULL)
+    ld->node = node;
+  return ld;
+}
+
+/* Get the front-end mode associated with the given TYPE.  If no mode is
+   associated then this function returns NO_MODE.  */
+
+MOID_T *
+a68_type_moid (tree type)
+{
+  gcc_assert (TYPE_LANG_SPECIFIC (type) != NULL
+	      && TYPE_LANG_SPECIFIC (type)->moid != NO_MOID);
+  return TYPE_LANG_SPECIFIC (type)->moid;
+}
+
+/* Build the type trees in a68_global_trees.  */
+
+static void
+a68_build_a68_type_nodes (void)
+{
+  /* VOID */
+  a68_void_type = make_node (RECORD_TYPE);
+  TYPE_NAME (a68_void_type) = get_identifier ("void%");
+  TYPE_FIELDS (a68_void_type) = NULL_TREE;
+  TYPE_READONLY (a68_void_type) = 1;
+  TYPE_CXX_ODR_P (a68_void_type) = 1;
+  layout_type (a68_void_type);
+
+  /* BOOL */
+  a68_bool_type = boolean_type_node;
+
+  /* CHAR */
+  a68_char_type = uint32_type_node;
+
+  /* SHORT SHORT INT
+     SHORT INT
+     INT */
+  a68_short_short_int_type = signed_char_type_node;
+  a68_short_int_type = short_integer_type_node;
+  a68_int_type = integer_type_node;
+
+  /* LONG INT */
+  if (int_size_in_bytes (long_integer_type_node)
+      > int_size_in_bytes (a68_int_type))
+    a68_long_int_type = long_integer_type_node;
+  else if (int_size_in_bytes (long_long_integer_type_node)
+	   > int_size_in_bytes (a68_int_type))
+    a68_long_int_type = long_long_integer_type_node;
+  else
+    a68_long_int_type = a68_int_type;
+
+  /* LONG LONG INT */
+  if (int_size_in_bytes (long_integer_type_node)
+      > int_size_in_bytes (a68_long_int_type))
+    a68_long_long_int_type = long_integer_type_node;
+  else if (int_size_in_bytes (long_long_integer_type_node)
+	   > int_size_in_bytes (a68_long_int_type))
+    a68_long_long_int_type = long_long_integer_type_node;
+  else
+    a68_long_long_int_type = a68_long_int_type;
+
+  /* SHORT SHORT BITS
+     SHORT BITS
+     BITS */
+  a68_short_short_bits_type = unsigned_char_type_node;
+  a68_short_bits_type = short_unsigned_type_node;
+  a68_bits_type = unsigned_type_node;
+
+  /* LONG BITS */
+  if (int_size_in_bytes (long_unsigned_type_node)
+      > int_size_in_bytes (a68_bits_type))
+    a68_long_bits_type = long_unsigned_type_node;
+  else if (int_size_in_bytes (long_long_unsigned_type_node)
+	   > int_size_in_bytes (a68_bits_type))
+    a68_long_bits_type = long_long_unsigned_type_node;
+  else
+    a68_long_bits_type = a68_bits_type;
+
+  /* LONG LONG BITS */
+  if (int_size_in_bytes (long_unsigned_type_node)
+      > int_size_in_bytes (a68_long_bits_type))
+    a68_long_long_bits_type = long_unsigned_type_node;
+  else if (int_size_in_bytes (long_long_unsigned_type_node)
+	   > int_size_in_bytes (a68_long_bits_type))
+    a68_long_long_bits_type = long_long_unsigned_type_node;
+  else
+    a68_long_long_bits_type = a68_long_bits_type;
+
+  /* BYTES
+     LONG BYTES */
+  a68_bytes_type = unsigned_type_node;
+  a68_long_bytes_type = long_unsigned_type_node;
+
+  /* REAL
+     LONG REAL
+     LONG LONG REAL */
+  a68_real_type = float_type_node;
+  a68_long_real_type = double_type_node;
+  a68_long_long_real_type = long_double_type_node;
+}
+
+/* Language hooks data structures.  This is the main interface between
+   the GCC front-end and the GCC middle-end/back-end.  A list of
+   language hooks can be found in langhooks.h.  */
+
+#undef LANG_HOOKS_NAME
+#define LANG_HOOKS_NAME "GNU Algol 68"
+
+/* LANG_HOOKS_INIT gets called to initialize the front-end.
+   Invoked after option handling.  */
+
+static bool
+a68_init (void)
+{
+  build_common_tree_nodes (false);
+  targetm.init_builtins ();
+  a68_build_a68_type_nodes ();
+  build_common_builtin_nodes ();
+  a68_install_builtins ();
+
+  /* Initialize binding contexts.  */
+  a68_init_ranges ();
+
+  /* Set the type of size_t.  */
+  if (TYPE_MODE (long_unsigned_type_node) == ptr_mode)
+    size_type_node = long_unsigned_type_node;
+  else if (TYPE_MODE (long_long_unsigned_type_node) == ptr_mode)
+    size_type_node = long_long_unsigned_type_node;
+  else
+    size_type_node = long_unsigned_type_node;
+
+  return true;
+}
+
+#undef LANG_HOOKS_INIT
+#define LANG_HOOKS_INIT a68_init
+
+/* LANG_HOOKS_OPTION_LANG_MASK  */
+
+static unsigned int
+a68_option_lang_mask (void)
+{
+  return CL_Algol68;
+}
+
+#undef LANG_HOOKS_OPTION_LANG_MASK
+#define LANG_HOOKS_OPTION_LANG_MASK a68_option_lang_mask
+
+
+/* Return a data type that has machine mode MODE.  If the mode is an
+   integer, then UNSIGNEDP selects between signed and unsigned types.  */
+
+static tree
+a68_type_for_mode (enum machine_mode mode, int unsignedp)
+{
+  if (mode == QImode)
+    return unsignedp ? a68_short_short_bits_type :a68_short_short_int_type;
+
+  if (mode == HImode)
+    return unsignedp ? a68_short_bits_type : a68_short_int_type;
+
+  if (mode == SImode)
+    return unsignedp ? a68_bits_type : a68_int_type;
+
+  if (mode == DImode)
+    return unsignedp ? a68_long_bits_type : a68_long_int_type;
+
+  if (mode == TYPE_MODE (a68_long_long_bits_type))
+    return unsignedp ? a68_long_long_bits_type : a68_long_long_int_type;
+
+  if (mode == TYPE_MODE (a68_real_type))
+    return a68_real_type;
+
+  if (mode == TYPE_MODE (a68_long_real_type))
+    return a68_long_real_type;
+
+  if (mode == TYPE_MODE (a68_long_long_real_type))
+    return a68_long_long_real_type;
+
+  if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
+    return build_pointer_type (char_type_node);
+
+  if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
+    return build_pointer_type (integer_type_node);
+
+  for (int i = 0; i < NUM_INT_N_ENTS; i ++)
+    {
+      if (int_n_enabled_p[i] && mode == int_n_data[i].m)
+	{
+	  if (unsignedp)
+	    return int_n_trees[i].unsigned_type;
+	  else
+	    return int_n_trees[i].signed_type;
+	}
+    }
+
+  return 0;
+}
+
+#undef LANG_HOOKS_TYPE_FOR_MODE
+#define LANG_HOOKS_TYPE_FOR_MODE a68_type_for_mode
+
+
+/* Return an integer type with BITS bits of precision,
+   that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
+
+static tree
+a68_type_for_size (unsigned int bits, int unsignedp)
+{
+  if (unsignedp)
+    {
+      if (bits <= TYPE_PRECISION (a68_short_short_bits_type))
+	return a68_short_short_bits_type;
+      if (bits <= TYPE_PRECISION (a68_short_bits_type))
+	return a68_short_bits_type;
+      if (bits <= TYPE_PRECISION (a68_bits_type))
+	return a68_bits_type;
+      if (bits <= TYPE_PRECISION (a68_long_bits_type))
+	return a68_long_bits_type;
+      if (bits <= TYPE_PRECISION (a68_long_long_bits_type))
+	return a68_long_long_bits_type;
+    }
+  else
+    {
+      if (bits <= TYPE_PRECISION (a68_short_short_int_type))
+	return a68_short_short_int_type;
+      if (bits <= TYPE_PRECISION (a68_short_int_type))
+	return a68_short_int_type;
+      if (bits <= TYPE_PRECISION (a68_int_type))
+	return a68_int_type;
+      if (bits <= TYPE_PRECISION (a68_long_int_type))
+	return a68_long_int_type;
+      if (bits <= TYPE_PRECISION (a68_long_long_int_type))
+	return a68_long_long_int_type;
+    }
+
+  for (int i = 0; i < NUM_INT_N_ENTS; ++i)
+    {
+      if (int_n_enabled_p[i] && bits == int_n_data[i].bitsize)
+	{
+	  if (unsignedp)
+	    return int_n_trees[i].unsigned_type;
+	  else
+	    return int_n_trees[i].signed_type;
+	}
+    }
+
+  return 0;
+}
+
+#undef LANG_HOOKS_TYPE_FOR_SIZE
+#define LANG_HOOKS_TYPE_FOR_SIZE a68_type_for_size
+
+
+/* Implements the lang_hooks.decls.global_bindings_p routine for Algol 68.
+   Return true if we are in the global binding level.  */
+
+static bool
+a68_global_bindings_p (void)
+{
+  return (current_function_decl == NULL_TREE);
+}
+
+#undef LANG_HOOKS_GLOBAL_BINDINGS_P
+#define LANG_HOOKS_GLOBAL_BINDINGS_P a68_global_bindings_p
+
+/* Implements the lang_hooks.decls.getdecls routine.
+   Return the list of declarations of the current level.  */
+
+static tree
+a68_getdecls (void)
+{
+  return a68_range_names ();
+}
+
+#undef LANG_HOOKS_GETDECLS
+#define LANG_HOOKS_GETDECLS a68_getdecls
+
+/* Return global_context, but create it first if need be.  */
+
+static tree
+get_global_context (void)
+{
+  if (!global_context)
+    {
+      global_context = build_translation_unit_decl (NULL_TREE);
+      debug_hooks->register_main_translation_unit (global_context);
+    }
+
+  return global_context;
+}
+
+/* Implements the lang_hooks.decls.pushdecl routine.
+   Record DECL as belonging to the current lexical scope.  */
+
+static tree
+pushdecl (tree decl)
+{
+  /* Set the context of the decl.  If current_function_decl did not help in
+     determining the context, use global scope.  */
+  if (!DECL_CONTEXT (decl))
+    {
+      if (current_function_decl)
+	DECL_CONTEXT (decl) = current_function_decl;
+      else
+	DECL_CONTEXT (decl) = get_global_context ();
+    }
+
+  /* Put decls on list in reverse order.  */
+  if (TREE_STATIC (decl) || a68_global_bindings_p ())
+    vec_safe_push (global_declarations, decl);
+  else
+    a68_add_decl (decl);
+
+  return decl;
+}
+
+#undef LANG_HOOKS_PUSHDECL
+#define LANG_HOOKS_PUSHDECL pushdecl
+
+/* Implements the lang_hooks.init_options routine for language Algol 68.  This
+   initializes the global state for the frontend before calling the option
+   handlers.  */
+
+static void
+a68_init_options (unsigned int argc ATTRIBUTE_UNUSED,
+		  cl_decoded_option *decoded_options ATTRIBUTE_UNUSED)
+{
+  /* Nothing to do here for now.  */
+}
+
+#undef LANG_HOOKS_INIT_OPTIONS
+#define LANG_HOOKS_INIT_OPTIONS	a68_init_options
+
+
+/* Handle -fcheck= option.  */
+
+static void
+a68_handle_runtime_check_option (const char *arg)
+{
+  int pos = 0;
+
+  while (*arg)
+    {
+      /* We accept entries like -fcheck=nil,,bounds and -fcheck=,all.  */
+      while (*arg == ',')
+	arg++;
+
+      while (arg[pos] && arg[pos] != ',')
+	pos++;
+
+      /* Process an option flag in the -fcheck= specification.
+
+	 "all" means enable all run-time checks.
+	 "none" means disable all run-time checks.
+
+	 Options are processed from left to right, with increase
+	 precedende.  */
+
+      if (strncmp (arg, "all", pos) == 0)
+	{
+	  OPTION_NIL_CHECKING (&A68_JOB) = true;
+	  OPTION_BOUNDS_CHECKING (&A68_JOB) = true;
+	}
+      else if (strncmp (arg, "none", pos) == 0)
+	{
+	  OPTION_NIL_CHECKING (&A68_JOB) = false;
+	  OPTION_BOUNDS_CHECKING (&A68_JOB) = false;
+	}
+      else if (strncmp (arg, "nil", pos) == 0)
+	OPTION_NIL_CHECKING (&A68_JOB) = true;
+      else if (strncmp (arg, "no-nil", pos) == 0)
+	OPTION_NIL_CHECKING (&A68_JOB) = false;
+      else if (strncmp (arg, "bounds", pos) == 0)
+	OPTION_BOUNDS_CHECKING (&A68_JOB) = true;
+      else if (strncmp (arg, "no-bounds", pos) == 0)
+	OPTION_BOUNDS_CHECKING (&A68_JOB) = false;
+      else
+	fatal_error (UNKNOWN_LOCATION,
+		     "Argument to %<-fcheck%> is not valid: %s", arg);
+
+      /* Process next flag.  */
+      arg += pos;
+      pos = 0;
+    }
+}
+
+/* Handle Algol 68 specific options.  Return false if we didn't do
+   anything.  */
+
+static bool
+a68_handle_option (size_t scode,
+		   const char *arg,
+		   HOST_WIDE_INT value ATTRIBUTE_UNUSED,
+		   int kind ATTRIBUTE_UNUSED,
+		   location_t loc ATTRIBUTE_UNUSED,
+		   const cl_option_handlers *handlers ATTRIBUTE_UNUSED)
+{
+  opt_code code = (opt_code) scode;
+
+  switch (code)
+    {
+    case OPT_std_algol68:
+      OPTION_STRICT (&A68_JOB) = 1;
+      break;
+    case OPT_fbrackets:
+      OPTION_BRACKETS (&A68_JOB) = flag_brackets;
+      break;
+    case OPT_fassert:
+      OPTION_ASSERT (&A68_JOB) = flag_assert;
+      break;
+    case OPT_fcheck_:
+      a68_handle_runtime_check_option (arg);
+      break;
+    case OPT_fstropping_:
+      if (value == 0)
+	OPTION_STROPPING (&A68_JOB) = UPPER_STROPPING;
+      else
+	OPTION_STROPPING (&A68_JOB) = SUPPER_STROPPING;
+      break;
+    case OPT_I:
+      vec_safe_push (A68_INCLUDE_PATHS, arg);
+      break;
+    default:
+      break;
+    }
+
+  return true;
+}
+
+#undef LANG_HOOKS_HANDLE_OPTION
+#define LANG_HOOKS_HANDLE_OPTION a68_handle_option
+
+/* LANG_HOOKS_INIT_OPTIONS_STRUCT is called so the front-end can
+   change some default values in the compiler's option structure.  */
+
+static void
+a68_init_options_struct (struct gcc_options *opts)
+{
+  /* Operations are always wrapping in algol68, even on signed
+     integer.  */
+  opts->x_flag_wrapv = 1;
+  /* Do not warn for voiding by default.  */
+  opts->x_warn_algol68_voiding = 0;
+  /* Do not warn for usage of Algol 68 extensions by default.  */
+  opts->x_warn_algol68_extensions = 0;
+  /* Do not warn for potential scope violations by default.  */
+  opts->x_warn_algol68_scope = 0;
+  /* Do not warn for hidden declarations by default.  */
+  opts->x_warn_algol68_hidden_declarations = 0;
+  /* Enable assertions by default.  */
+  OPTION_ASSERT (&A68_JOB) = 1;
+  /* Disable run-time nil checking by default.  */
+  OPTION_NIL_CHECKING (&A68_JOB) = 0;
+  /* Enable run-time bounds checking by default.  */
+  OPTION_BOUNDS_CHECKING (&A68_JOB) = 1;
+  opts->x_flag_assert = 1;
+  /* Allow GNU extensions by default.  */
+  OPTION_STRICT (&A68_JOB) = 0;
+  /* The default stropping regime is SUPPER.  */
+  OPTION_STROPPING (&A68_JOB) = SUPPER_STROPPING;
+}
+
+#undef LANG_HOOKS_INIT_OPTIONS_STRUCT
+#define LANG_HOOKS_INIT_OPTIONS_STRUCT a68_init_options_struct
+
+/* Deal with any options that imply the turning on/off of features.  FILENAME
+   is the main input file passed on the command line.  */
+
+static bool
+a68_post_options (const char **filename ATTRIBUTE_UNUSED)
+{
+  /* -fbounds-check is equivalent to -fcheck=bounds  */
+  if (flag_bounds_check)
+    OPTION_BOUNDS_CHECKING (&A68_JOB) = true;
+
+  return false;
+}
+
+#undef LANG_HOOKS_POST_OPTIONS
+#define LANG_HOOKS_POST_OPTIONS	a68_post_options
+
+/* LANG_HOOKS_PARSE_FILE is called to parse the input files.
+
+   The input file names are available in the global variables
+   in_fnames and num_in_fnames, and this function is required to
+   create a complete parse tree from them in a global var, then
+   return.  */
+
+static void
+a68_parse_file (void)
+{
+  if (num_in_fnames != 1)
+    fatal_error (UNKNOWN_LOCATION,
+		 "exactly one source file must be specified on the command line");
+
+  /* Run the Mailloux parser.  */
+  a68_parser (in_fnames[0]);
+
+  if (ERROR_COUNT (&A68_JOB) > 0)
+    goto had_errors;
+
+  /* Generate dumps if so requested.  */
+  if (flag_a68_dump_modes)
+    a68_dump_modes (TOP_MOID (&A68_JOB));
+  if (flag_a68_dump_ast)
+    a68_dump_parse_tree (TOP_NODE (&A68_JOB));
+
+  /* Lower modes to GENERIC.  */
+  a68_lower_moids (TOP_MOID (&A68_JOB));
+  /* Lower the particular program.  */
+  a68_lower_top_tree (TOP_NODE (&A68_JOB));
+
+  if (ERROR_COUNT (&A68_JOB) > 0)
+    goto had_errors;
+
+  /* Process all file scopes in this compilation, and the external_scope,
+     through wrapup_global_declarations.  */
+  for (unsigned int i = 0; i < vec_safe_length (global_declarations); i++)
+    {
+      tree decl = vec_safe_address (global_declarations)[i];
+      wrapup_global_declarations (&decl, 1);
+    }
+
+ had_errors:
+  errorcount += ERROR_COUNT (&A68_JOB);
+}
+
+#undef LANG_HOOKS_PARSE_FILE
+#define LANG_HOOKS_PARSE_FILE a68_parse_file
+
+/* This hook is called for every GENERIC tree that gets gimplified.
+   Its purpose is to gimplify language specific trees.
+
+   At the moment we are not supporting any Algol 68 specific tree, so
+   we just return FALSE.  */
+
+static int
+a68_gimplify_expr (tree *expr_p ATTRIBUTE_UNUSED,
+                   gimple_seq *pre_p ATTRIBUTE_UNUSED,
+                   gimple_seq *post_p ATTRIBUTE_UNUSED)
+{
+  return false;
+}
+
+#undef LANG_HOOKS_GIMPLIFY_EXPR
+#define LANG_HOOKS_GIMPLIFY_EXPR a68_gimplify_expr
+
+/* This function shall return the printable name of the language.  */
+
+static const char *
+a68_printable_name (tree decl, int kind ATTRIBUTE_UNUSED)
+{
+  tree decl_name = DECL_NAME (decl);
+
+  if (decl_name == NULL_TREE)
+    return "<unnamed>";
+  else
+    return IDENTIFIER_POINTER (decl_name);
+}
+
+#undef LANG_HOOKS_DECL_PRINTABLE_NAME
+#define LANG_HOOKS_DECL_PRINTABLE_NAME a68_printable_name
+
+
+/* Return true if a warning should be given about option OPTION, which is for
+   the wrong language, false if it should be quietly ignored.  */
+
+static bool
+a68_complain_wrong_lang_p (const struct cl_option *option ATTRIBUTE_UNUSED)
+{
+  return false;
+}
+
+#undef LANG_HOOKS_COMPLAIN_WRONG_LANG_P
+#define LANG_HOOKS_COMPLAIN_WRONG_LANG_P a68_complain_wrong_lang_p
+
+/* Create an expression whose value is that of EXPR,
+   converted to type TYPE.  The TREE_TYPE of the value
+   is always TYPE.  This function implements all reasonable
+   conversions; callers should filter out those that are
+   not permitted by the language being compiled.
+
+   Note that this function is not used outside the front-end.  This front-end
+   doesn't currently use it at all.  */
+
+tree convert (tree type ATTRIBUTE_UNUSED,
+	      tree expr ATTRIBUTE_UNUSED)
+{
+  gcc_unreachable ();
+}
+
+/* Implements the lang_hooks.types_compatible_p routine for Algol 68.
+   Compares two types for equivalence in Algol 68.
+   This routine should only return 1 if it is sure, even though the frontend
+   should have already ensured that all types are compatible before handing
+   over the parsed ASTs to the code generator.  */
+
+static int
+a68_types_compatible_p (tree x, tree y)
+{
+  MOID_T *mode_x = a68_type_moid (x);
+  MOID_T *mode_y = a68_type_moid (y);
+
+  if (mode_x != NO_MOID && mode_y != NO_MOID)
+    return a68_is_equal_modes (mode_x, mode_y, SAFE_DEFLEXING);
+
+  return false;
+}
+
+#undef LANG_HOOKS_TYPES_COMPATIBLE_P
+#define LANG_HOOKS_TYPES_COMPATIBLE_P a68_types_compatible_p
+
+/* Get a value for the SARIF v2.1.0 "artifact.sourceLanguage" property.  Algol
+   68 is not yet listed in SARIF v2.1.0 Appendix J, but if/when it does, it
+   will likely use this string.  */
+
+const char *
+a68_get_sarif_source_language (const char *)
+{
+  return "algol68";
+}
+
+#undef LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE
+#define LANG_HOOKS_GET_SARIF_SOURCE_LANGUAGE a68_get_sarif_source_language
+
+/* Expands all LANG_HOOKS_x o GCC.  */
+struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
+
+#include "gt-algol68-a68-lang.h"
+#include "gtype-algol68.h"
diff --git a/gcc/algol68/algol68-target.def b/gcc/algol68/algol68-target.def
new file mode 100644
index 00000000000..3e865176084
--- /dev/null
+++ b/gcc/algol68/algol68-target.def
@@ -0,0 +1,52 @@
+/* Target hook definitions for the Algol68 front end.
+   Copyright (C) 2025 Jose E. Marchesi.
+
+   This program 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.
+
+   This program 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 this program; see the file COPYING3.  If not see
+   <http://www.gnu.org/licenses/>.  */
+
+/* See target-hooks-macros.h for details of macros that should be
+   provided by the including file, and how to use them here.  */
+
+#include "target-hooks-macros.h"
+
+#undef HOOK_TYPE
+#define HOOK_TYPE "Algol68 Target Hook"
+
+HOOK_VECTOR (TARGETALGOL68M_INITIALIZER, gcc_targetalgol68m)
+
+#undef HOOK_PREFIX
+#define HOOK_PREFIX "TARGET_"
+
+/* Environmental CPU info and features (e.g. endianness, pointer size) relating
+   to the target CPU.  */
+DEFHOOK
+(algol68_cpu_info,
+ "Declare all environmental CPU info and features relating to the target CPU\n\
+using the function @code{algol68_add_target_info}, which takes a string\n\
+representing the feature key and a string representing the feature value.\n\
+Configuration pairs predefined by this hook apply to all files that are being\n\
+compiled.",
+ void, (void),
+ hook_void_void)
+
+/* Environmental OS info relating to the target OS.  */
+DEFHOOK
+(algol68_os_info,
+ "Similar to @code{TARGET_ALGOL68_CPU_INFO}, but is used for configuration info\n\
+relating to the target operating system.",
+ void, (void),
+ hook_void_void)
+
+/* Close the 'struct gcc_targetalgol68m' definition.  */
+HOOK_VECTOR_END (C90_EMPTY_HACK)
diff --git a/gcc/genhooks.cc b/gcc/genhooks.cc
index 529417b50f2..56a150e78d4 100644
--- a/gcc/genhooks.cc
+++ b/gcc/genhooks.cc
@@ -37,6 +37,7 @@ static struct hook_desc hook_array[] = {
 #include "d/d-target.def"
 #include "rust/rust-target.def"
 #include "jit/jit-target.def"
+#include "algol68/algol68-target.def"
 #undef DEFHOOK
 };
 
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 12/47] a68: unicode support routines
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (10 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 11/47] a68: a681 compiler proper Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 13/47] a68: front-end diagnostics Jose E. Marchesi
                   ` (35 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds several utility functions to deal with Unicode
strings.

These functions have been adapted from the libunistring gnulib module.

gcc/ChangeLog

	* algol68/a68-unistr.c: New file.
---
 gcc/algol68/a68-unistr.c | 453 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 453 insertions(+)
 create mode 100644 gcc/algol68/a68-unistr.c

diff --git a/gcc/algol68/a68-unistr.c b/gcc/algol68/a68-unistr.c
new file mode 100644
index 00000000000..ee7a6d7831f
--- /dev/null
+++ b/gcc/algol68/a68-unistr.c
@@ -0,0 +1,453 @@
+/* Character conversion functions for the Algol 68 front-end.
+   Copyright (C) 1999-2002, 2006-2007, 2009-2024 Free Software Foundation, Inc.
+   Copyright (C) 2025 Jose E. Marchesi.
+
+   The code in this file has been adapted from the unistr gnulib module,
+   written by Bruno Haible.
+  
+   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 "a68.h"
+
+static int
+u8_mbtoucr (uint32_t *puc, const uint8_t *s, size_t n)
+{
+  uint8_t c = *s;
+
+  if (c < 0x80)
+    {
+      *puc = c;
+      return 1;
+    }
+  else if (c >= 0xc2)
+    {
+      if (c < 0xe0)
+        {
+          if (n >= 2)
+            {
+              if ((s[1] ^ 0x80) < 0x40)
+                {
+                  *puc = ((unsigned int) (c & 0x1f) << 6)
+                         | (unsigned int) (s[1] ^ 0x80);
+                  return 2;
+                }
+              /* invalid multibyte character */
+            }
+          else
+            {
+              /* incomplete multibyte character */
+              *puc = 0xfffd;
+              return -2;
+            }
+        }
+      else if (c < 0xf0)
+        {
+          if (n >= 2)
+            {
+              if ((s[1] ^ 0x80) < 0x40
+                  && (c >= 0xe1 || s[1] >= 0xa0)
+                  && (c != 0xed || s[1] < 0xa0))
+                {
+                  if (n >= 3)
+                    {
+                      if ((s[2] ^ 0x80) < 0x40)
+                        {
+                          *puc = ((unsigned int) (c & 0x0f) << 12)
+                                 | ((unsigned int) (s[1] ^ 0x80) << 6)
+                                 | (unsigned int) (s[2] ^ 0x80);
+                          return 3;
+                        }
+                      /* invalid multibyte character */
+                    }
+                  else
+                    {
+                      /* incomplete multibyte character */
+                      *puc = 0xfffd;
+                      return -2;
+                    }
+                }
+              /* invalid multibyte character */
+            }
+          else
+            {
+              /* incomplete multibyte character */
+              *puc = 0xfffd;
+              return -2;
+            }
+        }
+      else if (c <= 0xf4)
+        {
+          if (n >= 2)
+            {
+              if ((s[1] ^ 0x80) < 0x40
+                  && (c >= 0xf1 || s[1] >= 0x90)
+                  && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90)))
+                {
+                  if (n >= 3)
+                    {
+                      if ((s[2] ^ 0x80) < 0x40)
+                        {
+                          if (n >= 4)
+                            {
+                              if ((s[3] ^ 0x80) < 0x40)
+                                {
+                                  *puc = ((unsigned int) (c & 0x07) << 18)
+                                         | ((unsigned int) (s[1] ^ 0x80) << 12)
+                                         | ((unsigned int) (s[2] ^ 0x80) << 6)
+                                         | (unsigned int) (s[3] ^ 0x80);
+                                  return 4;
+                                }
+                              /* invalid multibyte character */
+                            }
+                          else
+                            {
+                              /* incomplete multibyte character */
+                              *puc = 0xfffd;
+                              return -2;
+                            }
+                        }
+                      /* invalid multibyte character */
+                    }
+                  else
+                    {
+                      /* incomplete multibyte character */
+                      *puc = 0xfffd;
+                      return -2;
+                    }
+                }
+              /* invalid multibyte character */
+            }
+          else
+            {
+              /* incomplete multibyte character */
+              *puc = 0xfffd;
+              return -2;
+            }
+        }
+    }
+  /* invalid multibyte character */
+  *puc = 0xfffd;
+  return -1;
+}
+
+/* Get the UCS code for the first character of a given UTF-8 string.  */
+
+int
+a68_u8_mbtouc (uint32_t *puc, const uint8_t *s, size_t n)
+{
+  uint8_t c = *s;
+
+  if (c < 0x80)
+    {
+      *puc = c;
+      return 1;
+    }
+  else if (c >= 0xc2)
+    {
+      if (c < 0xe0)
+        {
+          if (n >= 2)
+            {
+              if ((s[1] ^ 0x80) < 0x40)
+                {
+                  *puc = ((unsigned int) (c & 0x1f) << 6)
+                         | (unsigned int) (s[1] ^ 0x80);
+                  return 2;
+                }
+              /* invalid multibyte character */
+            }
+          else
+            {
+              /* incomplete multibyte character */
+              *puc = 0xfffd;
+              return 1;
+            }
+        }
+      else if (c < 0xf0)
+        {
+          if (n >= 3)
+            {
+              if ((s[1] ^ 0x80) < 0x40
+                  && (c >= 0xe1 || s[1] >= 0xa0)
+                  && (c != 0xed || s[1] < 0xa0))
+                {
+                  if ((s[2] ^ 0x80) < 0x40)
+                    {
+                      *puc = ((unsigned int) (c & 0x0f) << 12)
+                             | ((unsigned int) (s[1] ^ 0x80) << 6)
+                             | (unsigned int) (s[2] ^ 0x80);
+                      return 3;
+                    }
+                  /* invalid multibyte character */
+                  *puc = 0xfffd;
+                  return 2;
+                }
+              /* invalid multibyte character */
+              *puc = 0xfffd;
+              return 1;
+            }
+          else
+            {
+              *puc = 0xfffd;
+              if (n == 1)
+                {
+                  /* incomplete multibyte character */
+                  return 1;
+                }
+              else
+                {
+                  if ((s[1] ^ 0x80) < 0x40
+                      && (c >= 0xe1 || s[1] >= 0xa0)
+                      && (c != 0xed || s[1] < 0xa0))
+                    {
+                      /* incomplete multibyte character */
+                      return 2;
+                    }
+                  else
+                    {
+                      /* invalid multibyte character */
+                      return 1;
+                    }
+                }
+            }
+        }
+      else if (c <= 0xf4)
+        {
+          if (n >= 4)
+            {
+              if ((s[1] ^ 0x80) < 0x40
+                  && (c >= 0xf1 || s[1] >= 0x90)
+                  && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90)))
+                {
+                  if ((s[2] ^ 0x80) < 0x40)
+                    {
+                      if ((s[3] ^ 0x80) < 0x40)
+                        {
+                          *puc = ((unsigned int) (c & 0x07) << 18)
+                                 | ((unsigned int) (s[1] ^ 0x80) << 12)
+                                 | ((unsigned int) (s[2] ^ 0x80) << 6)
+                                 | (unsigned int) (s[3] ^ 0x80);
+                          return 4;
+                        }
+                      /* invalid multibyte character */
+                      *puc = 0xfffd;
+                      return 3;
+                    }
+                  /* invalid multibyte character */
+                  *puc = 0xfffd;
+                  return 2;
+                }
+              /* invalid multibyte character */
+              *puc = 0xfffd;
+              return 1;
+            }
+          else
+            {
+              *puc = 0xfffd;
+              if (n == 1)
+                {
+                  /* incomplete multibyte character */
+                  return 1;
+                }
+              else
+                {
+                  if ((s[1] ^ 0x80) < 0x40
+                      && (c >= 0xf1 || s[1] >= 0x90)
+                      && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90)))
+                    {
+                      if (n == 2)
+                        {
+                          /* incomplete multibyte character */
+                          return 2;
+                        }
+                      else
+                        {
+                          if ((s[2] ^ 0x80) < 0x40)
+                            {
+                              /* incomplete multibyte character */
+                              return 3;
+                            }
+                          else
+                            {
+                              /* invalid multibyte character */
+                              return 2;
+                            }
+                        }
+                    }
+                  else
+                    {
+                      /* invalid multibyte character */
+                      return 1;
+                    }
+                }
+            }
+        }
+    }
+  /* invalid multibyte character */
+  *puc = 0xfffd;
+  return 1;
+}
+
+/* Encode a given UCS code in UTF-8.  */
+
+int
+a68_u8_uctomb (uint8_t *s, uint32_t uc, ptrdiff_t n)
+{
+  if (uc < 0x80)
+    {
+      if (n > 0)
+        {
+          s[0] = uc;
+          return 1;
+        }
+      /* else return -2, below.  */
+    }
+  else
+    {
+      int count;
+
+      if (uc < 0x800)
+        count = 2;
+      else if (uc < 0x10000)
+        {
+          if (uc < 0xd800 || uc >= 0xe000)
+            count = 3;
+          else
+            return -1;
+        }
+      else if (uc < 0x110000)
+        count = 4;
+      else
+        return -1;
+
+      if (n >= count)
+        {
+          switch (count) /* note: code falls through cases! */
+            {
+            case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000;
+              gcc_fallthrough ();
+            case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800;
+              gcc_fallthrough ();
+            case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0;
+          /*case 1:*/ s[0] = uc;
+            }
+          return count;
+        }
+    }
+  return -2;
+}
+
+/* Convert UTF-8 to UTF-32/UCS-4  */
+
+uint32_t *
+a68_u8_to_u32 (const uint8_t *s, size_t n, uint32_t *resultbuf, size_t *lengthp)
+{
+  const uint8_t *s_end = s + n;
+  /* Output string accumulator.  */
+  uint32_t *result;
+  size_t allocated;
+  size_t length;
+
+  if (resultbuf != NULL)
+    {
+      result = resultbuf;
+      allocated = *lengthp;
+    }
+  else
+    {
+      result = NULL;
+      allocated = 0;
+    }
+  length = 0;
+  /* Invariants:
+     result is either == resultbuf or == NULL or malloc-allocated.
+     If length > 0, then result != NULL.  */
+
+  while (s < s_end)
+    {
+      uint32_t uc;
+      int count;
+
+      /* Fetch a Unicode character from the input string.  */
+      count = u8_mbtoucr (&uc, s, s_end - s);
+      if (count < 0)
+        {
+          if (!(result == resultbuf || result == NULL))
+            free (result);
+          errno = EILSEQ;
+          return NULL;
+        }
+      s += count;
+
+      /* Store it in the output string.  */
+      if (length + 1 > allocated)
+        {
+          uint32_t *memory;
+
+          allocated = (allocated > 0 ? 2 * allocated : 12);
+          if (length + 1 > allocated)
+            allocated = length + 1;
+          if (result == resultbuf || result == NULL)
+            memory = (uint32_t *) xmalloc (allocated * sizeof (uint32_t));
+          else
+            memory =
+              (uint32_t *) xrealloc (result, allocated * sizeof (uint32_t));
+
+          if (memory == NULL)
+            {
+              if (!(result == resultbuf || result == NULL))
+                free (result);
+              errno = ENOMEM;
+              return NULL;
+            }
+          if (result == resultbuf && length > 0)
+            memcpy ((char *) memory, (char *) result,
+                    length * sizeof (uint32_t));
+          result = memory;
+        }
+      result[length++] = uc;
+    }
+
+  if (length == 0)
+    {
+      if (result == NULL)
+        {
+          /* Return a non-NULL value.  NULL means error.  */
+          result = (uint32_t *) xmalloc (sizeof (uint32_t));
+          if (result == NULL)
+            {
+              errno = ENOMEM;
+              return NULL;
+            }
+        }
+    }
+  else if (result != resultbuf && length < allocated)
+    {
+      /* Shrink the allocated memory if possible.  */
+      uint32_t *memory;
+
+      memory = (uint32_t *) xrealloc (result, length * sizeof (uint32_t));
+      if (memory != NULL)
+        result = memory;
+    }
+
+  *lengthp = length;
+  return result;
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 13/47] a68: front-end diagnostics
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (11 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 12/47] a68: unicode support routines Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 14/47] a68: parser: entry point Jose E. Marchesi
                   ` (34 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds the diagnostics infrastructure for the Algol 68
front-end.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>

gcc/ChangeLog

	* algol68/a68-diagnostics.cc: New file.
---
 gcc/algol68/a68-diagnostics.cc | 360 +++++++++++++++++++++++++++++++++
 1 file changed, 360 insertions(+)
 create mode 100644 gcc/algol68/a68-diagnostics.cc

diff --git a/gcc/algol68/a68-diagnostics.cc b/gcc/algol68/a68-diagnostics.cc
new file mode 100644
index 00000000000..f1b0513dc38
--- /dev/null
+++ b/gcc/algol68/a68-diagnostics.cc
@@ -0,0 +1,360 @@
+/* Error and warning routines.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#define INCLUDE_MEMORY
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "diagnostic.h"
+
+#include "a68.h"
+
+/*
+ * Error handling routines.
+ */
+
+#define TABULATE(n) (8 * (n / 8 + 1) - n)
+
+/* Severities handled by the DIAGNOSTIC function defined below.  */
+
+#define A68_ERROR 0
+#define A68_WARNING 1
+#define A68_FATAL 2
+#define A68_SCAN_ERROR 3
+#define A68_INFORM 4
+
+/* Give a diagnostic message.  */
+
+static int
+diagnostic (int sev, int opt,
+	    NODE_T *p,
+	    LINE_T *line,
+	    char *pos,
+	    const char *loc_str, va_list args)
+{
+  int res = 0;
+  MOID_T *moid = NO_MOID;
+  const char *t = loc_str;
+  char b[BUFFER_SIZE];
+
+  b[0] = '\0';
+
+  /*
+   * Synthesize diagnostic message.
+   *
+   * Legend for special symbols:
+   * * as first character, copy rest of string literally
+   * @ non terminal
+   * A non terminal
+   * B keyword
+   * C context
+   * D argument in decimal
+   * H char argument
+   * K 'LONG'
+   * L line number
+   * M moid - if error mode return without giving a message
+   * N mode - M_NIL
+   * O moid - operand
+   * S quoted symbol, when possible with typographical display features
+   * X expected attribute
+   * Y string literal.
+   * Z quoted string literal.  */
+
+  if (t[0] == '*')
+    a68_bufcat (b, &t[1], BUFFER_SIZE);
+  else
+    while (t[0] != '\0')
+      {
+	if (t[0] == '@')
+	  {
+            const char *nt = a68_attribute_name (ATTRIBUTE (p));
+            if (t != NO_TEXT)
+              a68_bufcat (b, nt, BUFFER_SIZE);
+	    else
+              a68_bufcat (b, "construct", BUFFER_SIZE);
+          }
+	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)
+              a68_bufcat (b, nt, BUFFER_SIZE);
+	    else
+              a68_bufcat (b, "construct", BUFFER_SIZE);
+          }
+	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)
+	      {
+		a68_bufcat (b, "\"", BUFFER_SIZE);
+		a68_bufcat (b, TEXT (nt), BUFFER_SIZE);
+		a68_bufcat (b, "\"", BUFFER_SIZE);
+	      }
+	    else
+              a68_bufcat (b, "keyword", BUFFER_SIZE);
+          }
+	else if (t[0] == 'C')
+	  {
+            int att = va_arg (args, int);
+            if (att == NO_SORT)
+              a68_bufcat (b, "this", BUFFER_SIZE);
+            if (att == SOFT)
+              a68_bufcat (b, "a soft", BUFFER_SIZE);
+	    else if (att == WEAK)
+              a68_bufcat (b, "a weak", BUFFER_SIZE);
+	    else if (att == MEEK)
+              a68_bufcat (b, "a meek", BUFFER_SIZE);
+	    else if (att == FIRM)
+              a68_bufcat (b, "a firm", BUFFER_SIZE);
+	    else if (att == STRONG)
+              a68_bufcat (b, "a strong", BUFFER_SIZE);
+          }
+	else if (t[0] == 'D')
+	  {
+            int a = va_arg (args, int);
+            BUFFER d;
+            BUFCLR (d);
+            if (snprintf (d, SNPRINTF_SIZE, "%d", a) < 0)
+	      gcc_unreachable ();
+            a68_bufcat (b, d, BUFFER_SIZE);
+          }
+	else if (t[0] == 'H')
+	  {
+            char *a = va_arg (args, char *);
+            char d[SMALL_BUFFER_SIZE];
+            if (snprintf (d, (size_t) SMALL_BUFFER_SIZE, "\"%c\"", a[0]) < 0)
+	      gcc_unreachable ();
+            a68_bufcat (b, d, BUFFER_SIZE);
+          }
+	else if (t[0] == 'K')
+	  a68_bufcat (b, "LONG", BUFFER_SIZE);
+	else if (t[0] == 'L')
+	  {
+	    LINE_T *a = va_arg (args, LINE_T *);
+            char d[SMALL_BUFFER_SIZE];
+            gcc_assert (a != NO_LINE);
+            if (NUMBER (a) == 0)
+              a68_bufcat (b, "in standard environment", BUFFER_SIZE);
+	    else
+	      {
+		if (p != NO_NODE && NUMBER (a) == LINE_NUMBER (p))
+		  {
+		    if (snprintf (d, (size_t) SMALL_BUFFER_SIZE, "in this line") < 0)
+		      gcc_unreachable ();
+		  }
+		else
+		  {
+		    if (snprintf (d, (size_t) SMALL_BUFFER_SIZE, "in line %d", NUMBER (a)) < 0)
+		      gcc_unreachable ();
+		  }
+              a68_bufcat (b, d, BUFFER_SIZE);
+            }
+          }
+	else if (t[0] == 'M')
+	  {
+            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)
+		  a68_bufcat (b, a68_moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p),
+			  BUFFER_SIZE);
+		else
+		  a68_bufcat (b, a68_moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
+	      }
+	    else
+              a68_bufcat (b, a68_moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
+          }
+	else if (t[0] == 'N')
+	  {
+            a68_bufcat (b, "NIL name of mode ", BUFFER_SIZE);
+            moid = va_arg (args, MOID_T *);
+            if (moid != NO_MOID)
+              a68_bufcat (b, a68_moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
+          }
+	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)
+              a68_bufcat (b, "UNION (VOID, ..)", BUFFER_SIZE);
+	    else if (IS (moid, SERIES_MODE))
+	      {
+		if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK)
+		  a68_bufcat (b, a68_moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p), BUFFER_SIZE);
+		else
+		  a68_bufcat (b, a68_moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
+	      }
+	    else
+              a68_bufcat (b, a68_moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
+          }
+	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);
+
+		a68_bufcat (b, "\"", BUFFER_SIZE);
+		if (txt[0] != sym[0] || (int) strlen (sym) < size)
+		  a68_bufcat (b, txt, BUFFER_SIZE);
+		else
+		  {
+		    while (n < size)
+		      {
+			if (ISPRINT (sym[0]))
+			  {
+			    char str[2];
+			    str[0] = sym[0];
+			    str[1] = '\0';
+			    a68_bufcat (b, str, BUFFER_SIZE);
+			  }
+			if (TOLOWER (txt[0]) == TOLOWER (sym[0]))
+			  {
+			    txt++;
+			    n++;
+			  }
+			sym++;
+		      }
+		  }
+		a68_bufcat (b, "\"", BUFFER_SIZE);
+	      }
+	    else
+              a68_bufcat (b, "symbol", BUFFER_SIZE);
+          }
+	else if (t[0] == 'V')
+	  a68_bufcat (b, PACKAGE_STRING, BUFFER_SIZE);
+	else if (t[0] == 'X')
+	  {
+            enum a68_attribute att = (enum a68_attribute) (va_arg (args, int));
+	    const char *att_name = a68_attribute_name (att);
+            a68_bufcat (b, att_name, BUFFER_SIZE);
+          }
+	else if (t[0] == 'Y')
+	  {
+            char *loc_string = va_arg (args, char *);
+            a68_bufcat (b, loc_string, BUFFER_SIZE);
+          }
+	else if (t[0] == 'Z')
+	  {
+            char *loc_string = va_arg (args, char *);
+            a68_bufcat (b, "\"", BUFFER_SIZE);
+            a68_bufcat (b, loc_string, BUFFER_SIZE);
+            a68_bufcat (b, "\"", BUFFER_SIZE);
+          }
+	else
+	  {
+	    char q[2];
+            q[0] = t[0];
+            q[1] = '\0';
+            a68_bufcat (b, q, BUFFER_SIZE);
+          }
+	t++;
+      }
+
+  /* Construct a diagnostic message.  */
+  if (sev == A68_WARNING)
+    WARNING_COUNT (&A68_JOB)++;
+  else
+    ERROR_COUNT (&A68_JOB)++;
+
+  /* Emit the corresponding GCC diagnostic at the proper location.  */
+  location_t loc = UNKNOWN_LOCATION;
+
+  if (p != NO_NODE)
+    loc = a68_get_node_location (p);
+  else if (line != NO_LINE)
+    {
+      if (pos == NO_TEXT)
+	pos = STRING (line);
+      loc = a68_get_line_location (line, pos);
+    }
+
+  switch (sev)
+    {
+    case A68_SCAN_ERROR: error_at (loc, "%s", b); exit (FATAL_EXIT_CODE);
+    case A68_FATAL: fatal_error (loc, "%s", b); break;
+    case A68_INFORM: inform (loc, b); break;
+    case A68_WARNING: res = warning_at (loc, opt, "%s", b); break;
+    case A68_ERROR: error_at (loc, "%s", b); break;
+    default:
+      gcc_unreachable ();
+    }
+
+  return res;
+}
+
+/* Give an intelligible error and exit.  A line is provided rather than a
+   node so this can be used at scanning time.  */
+
+void
+a68_scan_error (LINE_T * u, char *v, const char *txt, ...)
+{
+  va_list args;
+
+  va_start (args, txt);
+  diagnostic (A68_SCAN_ERROR, 0, NO_NODE, u, v, txt, args);
+  va_end (args);
+}
+
+/* Report a compilation error.  */
+
+void
+a68_error (NODE_T *p, const char *loc_str, ...)
+{
+  va_list args;
+
+  va_start (args, loc_str);
+  diagnostic (A68_ERROR, 0, p, NO_LINE, NO_TEXT, loc_str, args); va_end (args);
+}
+
+/* Report a compilation warning.  */
+
+int
+a68_warning (NODE_T *p, int opt,
+	     const char *loc_str, ...)
+{
+  int res;
+  va_list args;
+
+  va_start (args, loc_str);
+  res = diagnostic (A68_WARNING, opt, p, NO_LINE, NO_TEXT, loc_str, args);
+  va_end (args);
+  return res;
+}
+
+/* Report a compilation note.  */
+
+void
+a68_inform (NODE_T *p, const char *loc_str, ...)
+{
+  va_list args;
+
+  va_start (args, loc_str);
+  diagnostic (A68_INFORM, 0, p, NO_LINE, NO_TEXT, loc_str, args);
+  va_end (args);
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 14/47] a68: parser: entry point
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (12 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 13/47] a68: front-end diagnostics Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 15/47] a68: parser: AST nodes attributes/types Jose E. Marchesi
                   ` (33 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds the parsing support code and the entry point to the
parser.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser.cc | 1134 +++++++++++++++++++++++++++++++++++++
 1 file changed, 1134 insertions(+)
 create mode 100644 gcc/algol68/a68-parser.cc

diff --git a/gcc/algol68/a68-parser.cc b/gcc/algol68/a68-parser.cc
new file mode 100644
index 00000000000..83e79a8d101
--- /dev/null
+++ b/gcc/algol68/a68-parser.cc
@@ -0,0 +1,1134 @@
+/* ALGOL 68 parser.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+/*
+   This is a Mailloux-type parser driver.
+
+   The Algol 68 grammar is a two level (Van Wijngaarden, "VW") grammar
+   that incorporates, as syntactical rules, the semantical rules in
+   other languages. Examples are correct use of symbols, modes and
+   scope.
+
+   This code constitutes an effective "VW Algol 68 parser". A
+   pragmatic approach was chosen since in the early days of Algol 68,
+   many "ab initio" implementations failed, probably because
+   techniques to parse a language like Algol 68 had yet to be
+   invented.
+
+   This is a Mailloux-type parser, in the sense that it scans a
+   "phrase" for definitions needed for parsing. Algol 68 allows for
+   tags to be used before they are defined, which gives freedom in
+   top-down programming.
+
+     B. J. Mailloux. On the implementation of Algol 68.
+     Thesis, Universiteit van Amsterdam (Mathematisch Centrum) [1968].
+
+   Technically, Mailloux's approach renders the two-level grammar
+   LALR.
+
+   First part of the parser is the scanner. The source file is read, is
+   tokenised.  The result is a linear list of tokens that is input for the
+   parser, that will transform the linear list into a syntax tree.
+
+   This front-end tokenises all symbols before the bottom-up parser is invoked.
+   This means that scanning does not use information from the parser.  The
+   scanner does of course some rudimentary parsing.
+
+   The scanner supports two stropping regimes: "bold" (or "upper") and
+   "quote".  Examples of both:
+
+    bold stropping: BEGIN INT i = 1, j = 1; print (i + j) END
+
+    quote stropping: 'BEGIN' 'INT' I = 1, J = 1; PRINT (I + J) 'END'
+
+   Quote stropping was used frequently in the (excusez-le-mot)
+   punch-card age.  Hence, bold stropping is the default. There also
+   existed point stropping, but that has not been implemented here.
+
+   Next part of the parser is a recursive-descent type to check
+   parenthesis.  Also a first set-up is made of symbol tables, needed
+   by the bottom-up parser.  Next part is the bottom-up parser, that
+   parses without knowing modes while parsing and reducing. It can
+   therefore not exchange "[]" with "()" as was blessed by the Revised
+   Report. This is solved by treating CALL and SLICE as equivalent for
+   the moment and letting the mode checker sort it out later.
+
+   Parsing progresses in various phases to avoid spurious diagnostics
+   from a recovering parser. Every phase "tightens" the grammar more.
+   An error in any phase makes the parser quit when that phase ends.
+   The parser is forgiving in case of superfluous semicolons.
+
+   These are the parser phases:
+
+   (1) Parenthesis are checked to see whether they match. Then, a top-down
+       parser determines the basic-block structure of the program
+       so symbol tables can be set up that the bottom-up parser will consult
+       as you can define things before they are applied.
+
+   (2) A bottom-up parser resolves the structure of the program.
+
+   (3) After the symbol tables have been finalised, a small rearrangement of the
+       tree may be required where JUMPs have no GOTO. This leads to the
+       non-standard situation that JUMPs without GOTO can have the syntactic
+       position of a PRIMARY, SECONDARY or TERTIARY. The bottom-up parser also
+       does not check VICTAL correctness of declarers. This is done separately.
+
+  The parser sets up symbol tables and populates them as far as needed to parse
+  the source. After the bottom-up parser terminates succesfully, the symbol tables
+  are completed.
+
+   (4) Next, modes are collected and rules for well-formedness and structural
+       equivalence are applied. Then the symbol-table is completed now moids are
+       all known.
+
+   (5) Next phases are the mode checker and coercion inserter. The syntax tree is
+       traversed to determine and check all modes, and to select operators. Then
+       the tree is traversed again to insert coercions.
+
+   (6) A static scope checker detects where objects are transported out of scope.
+       At run time, a dynamic scope checker will check that what the static scope
+       checker cannot see.
+
+   (7) A serial-clause dynamic stack allocation (DSA) phase annotates the
+       serial clauses that contain phrases whose elaboration may result in
+       dynamic stack adjustments.
+*/
+
+#define INCLUDE_MEMORY
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "diagnostic.h"
+#include "tree.h"
+
+#include "a68.h"
+
+/* Global state kept by the parser.  */
+
+PARSER_T a68_parser_state;
+
+/* A few forward declarations of functions defined below.  */
+
+static void make_special_mode (MOID_T ** n, int m);
+static void tie_label_to_serial (NODE_T *p);
+static void tie_label_to_unit (NODE_T *p);
+
+/* Is_ref_refety_flex.  */
+
+bool
+a68_is_ref_refety_flex (MOID_T *m)
+{
+  if (IS_REF_FLEX (m))
+    return true;
+  else if (IS_REF (m))
+    return a68_is_ref_refety_flex (SUB (m));
+  else
+    return false;
+}
+
+/* Count number of operands in operator parameter list.  */
+
+int
+a68_count_operands (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, DECLARER))
+	return a68_count_operands (NEXT (p));
+      else if (IS (p, COMMA_SYMBOL))
+	return 1 + a68_count_operands (NEXT (p));
+      else
+	return a68_count_operands (NEXT (p)) + a68_count_operands (SUB (p));
+    }
+  else
+    return 0;
+}
+
+/* Count formal bounds in declarer in tree.  */
+
+int
+a68_count_formal_bounds (NODE_T * p)
+{
+  if (p == NO_NODE)
+    return 0;
+  else
+    {
+      if (IS (p, COMMA_SYMBOL))
+	return 1;
+      else
+	return a68_count_formal_bounds (NEXT (p)) + a68_count_formal_bounds (SUB (p));
+    }
+}
+
+/* Count pictures.  */
+
+void
+a68_count_pictures (NODE_T *p, int *k)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, PICTURE))
+	(*k)++;
+      a68_count_pictures (SUB (p), k);
+    }
+}
+
+/* Whether token cannot follow semicolon or EXIT.  */
+
+bool
+a68_is_semicolon_less (NODE_T *p)
+{
+  switch (ATTRIBUTE (p))
+    {
+    case BUS_SYMBOL:
+    case CLOSE_SYMBOL:
+    case END_SYMBOL:
+    case SEMI_SYMBOL:
+    case EXIT_SYMBOL:
+    case THEN_BAR_SYMBOL:
+    case ELSE_BAR_SYMBOL:
+    case THEN_SYMBOL:
+    case ELIF_SYMBOL:
+    case ELSE_SYMBOL:
+    case FI_SYMBOL:
+    case IN_SYMBOL:
+    case OUT_SYMBOL:
+    case OUSE_SYMBOL:
+    case ESAC_SYMBOL:
+    case OD_SYMBOL:
+      return true;
+    default:
+      return false;
+    }
+}
+
+/* Whether formal bounds.  */
+
+bool
+a68_is_formal_bounds (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return true;
+
+  switch (ATTRIBUTE (p))
+    {
+    case OPEN_SYMBOL:
+    case CLOSE_SYMBOL:
+    case SUB_SYMBOL:
+    case BUS_SYMBOL:
+    case COMMA_SYMBOL:
+    case COLON_SYMBOL:
+    case INT_DENOTATION:
+    case IDENTIFIER:
+    case OPERATOR:
+      return (a68_is_formal_bounds (SUB (p))
+	      && a68_is_formal_bounds (NEXT (p)));
+    default:
+        return false;
+    }
+}
+
+/* Whether token terminates a unit.  */
+
+bool
+a68_is_unit_terminator (NODE_T *p)
+{
+  switch (ATTRIBUTE (p))
+    {
+    case BUS_SYMBOL:
+    case CLOSE_SYMBOL:
+    case END_SYMBOL:
+    case SEMI_SYMBOL:
+    case EXIT_SYMBOL:
+    case COMMA_SYMBOL:
+    case THEN_BAR_SYMBOL:
+    case ELSE_BAR_SYMBOL:
+    case THEN_SYMBOL:
+    case ELIF_SYMBOL:
+    case ELSE_SYMBOL:
+    case FI_SYMBOL:
+    case IN_SYMBOL:
+    case OUT_SYMBOL:
+    case OUSE_SYMBOL:
+    case ESAC_SYMBOL:
+      return true;
+    default:
+      return false;
+    }
+}
+
+/* Whether token is a unit-terminator in a loop clause.  */
+
+bool
+a68_is_loop_keyword (NODE_T *p)
+{
+  switch (ATTRIBUTE (p))
+    {
+    case FOR_SYMBOL:
+    case FROM_SYMBOL:
+    case BY_SYMBOL:
+    case TO_SYMBOL:
+    case WHILE_SYMBOL:
+    case DO_SYMBOL:
+      return true;
+    default:
+      return false;
+    }
+}
+
+/* Get good attribute.  */
+
+enum a68_attribute
+a68_get_good_attribute (NODE_T *p)
+{
+  switch (ATTRIBUTE (p))
+    {
+    case UNIT:
+    case TERTIARY:
+    case SECONDARY:
+    case PRIMARY:
+      return a68_get_good_attribute (SUB (p));
+    default:
+      return ATTRIBUTE (p);
+    }
+}
+
+/* Preferably don't put intelligible diagnostic here.  */
+
+bool
+a68_dont_mark_here (NODE_T *p)
+{
+  switch (ATTRIBUTE (p))
+    {
+    case ALT_DO_SYMBOL:
+    case ALT_EQUALS_SYMBOL:
+    case ANDF_SYMBOL:
+    case ASSERT_SYMBOL:
+    case ASSIGN_SYMBOL:
+    case ASSIGN_TO_SYMBOL:
+    case AT_SYMBOL:
+    case BEGIN_SYMBOL:
+    case BITS_SYMBOL:
+    case BOLD_COMMENT_SYMBOL:
+    case BOLD_PRAGMAT_SYMBOL:
+    case BOLD_COMMENT_BEGIN_SYMBOL:
+    case BOLD_COMMENT_END_SYMBOL:
+    case BOOL_SYMBOL:
+    case BUS_SYMBOL:
+    case BY_SYMBOL:
+    case BYTES_SYMBOL:
+    case CASE_SYMBOL:
+    case CHANNEL_SYMBOL:
+    case CHAR_SYMBOL:
+    case CLOSE_SYMBOL:
+    case COLON_SYMBOL:
+    case COMMA_SYMBOL:
+    case COMPLEX_SYMBOL:
+    case COMPL_SYMBOL:
+    case DO_SYMBOL:
+    case ELIF_SYMBOL:
+    case ELSE_BAR_SYMBOL:
+    case ELSE_SYMBOL:
+    case EMPTY_SYMBOL:
+    case END_SYMBOL:
+    case EQUALS_SYMBOL:
+    case ESAC_SYMBOL:
+    case EXIT_SYMBOL:
+    case FALSE_SYMBOL:
+    case FILE_SYMBOL:
+    case FI_SYMBOL:
+    case FLEX_SYMBOL:
+    case FOR_SYMBOL:
+    case FROM_SYMBOL:
+    case GO_SYMBOL:
+    case GOTO_SYMBOL:
+    case HEAP_SYMBOL:
+    case IF_SYMBOL:
+    case IN_SYMBOL:
+    case INT_SYMBOL:
+    case ISNT_SYMBOL:
+    case IS_SYMBOL:
+    case LOC_SYMBOL:
+    case LONG_SYMBOL:
+    case MAIN_SYMBOL:
+    case MODE_SYMBOL:
+    case NIL_SYMBOL:
+    case OD_SYMBOL:
+    case OF_SYMBOL:
+    case OPEN_SYMBOL:
+    case OP_SYMBOL:
+    case ORF_SYMBOL:
+    case OUSE_SYMBOL:
+    case OUT_SYMBOL:
+    case PAR_SYMBOL:
+    case POINT_SYMBOL:
+    case PRIO_SYMBOL:
+    case PROC_SYMBOL:
+    case REAL_SYMBOL:
+    case REF_SYMBOL:
+    case ROWS_SYMBOL:
+    case ROW_SYMBOL:
+    case SEMA_SYMBOL:
+    case SEMI_SYMBOL:
+    case SHORT_SYMBOL:
+    case SKIP_SYMBOL:
+    case STRING_SYMBOL:
+    case STRUCT_SYMBOL:
+    case STYLE_I_COMMENT_SYMBOL:
+    case STYLE_II_COMMENT_SYMBOL:
+    case STYLE_I_PRAGMAT_SYMBOL:
+    case SUB_SYMBOL:
+    case THEN_BAR_SYMBOL:
+    case THEN_SYMBOL:
+    case TO_SYMBOL:
+    case TRUE_SYMBOL:
+    case UNION_SYMBOL:
+    case VOID_SYMBOL:
+    case WHILE_SYMBOL:
+    case SERIAL_CLAUSE:
+    case ENQUIRY_CLAUSE:
+    case INITIALISER_SERIES:
+    case DECLARATION_LIST:
+      return true;
+    default:
+      return false;
+    }
+}
+
+/* Renumber nodes in the given subtree P, starting with number N.  */
+
+static void
+renumber_nodes (NODE_T *p, int *n)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      NUMBER (p) = (*n)++;
+      renumber_nodes (SUB (p), n);
+    }
+}
+
+/* Parse an ALGOL 68 source file.  */
+
+void
+a68_parser (const char *filename)
+{
+  int renum = 0;
+
+  /* Initialisation.  */
+  A68 (top_keyword) = NO_KEYWORD;
+  A68 (top_token) = NO_TOKEN;
+  A68_PARSER (error_tag) = (TAG_T *) a68_new_tag ();
+  TOP_NODE (&A68_JOB) = NO_NODE;
+  TOP_MOID (&A68_JOB) = NO_MOID;
+  TOP_LINE (&A68_JOB) = NO_LINE;
+  STANDENV_MOID (&A68_JOB) = NO_MOID;
+  a68_set_up_tables ();
+  ERROR_COUNT (&A68_JOB) = WARNING_COUNT (&A68_JOB) = 0;
+
+  /* Tokeniser.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      bool ok = a68_lexical_analyser (filename);
+
+      if (!ok)
+	return;
+
+      /* An empty file is not a valid program.  */
+      if (TOP_NODE (&A68_JOB) == NO_NODE)
+	{
+	  a68_error (NO_NODE, "file is empty, expected a program");
+	  return;
+	}
+
+      TREE_LISTING_SAFE (&A68_JOB) = true;
+      renum = 0;
+      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
+    }
+
+  /* Final initialisations.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      A68_STANDENV = NO_TABLE;
+      a68_init_postulates ();
+      A68 (mode_count) = 0;
+      make_special_mode (&M_HIP, A68 (mode_count)++);
+      make_special_mode (&M_UNDEFINED, A68 (mode_count)++);
+      make_special_mode (&M_ERROR, A68 (mode_count)++);
+      make_special_mode (&M_VACUUM, A68 (mode_count)++);
+      make_special_mode (&M_C_STRING, A68 (mode_count)++);
+      make_special_mode (&M_COLLITEM, A68 (mode_count)++);
+    }
+
+  /* Top-down parser.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      a68_check_parenthesis (TOP_NODE (&A68_JOB));
+      if (ERROR_COUNT (&A68_JOB) == 0)
+	{
+	  if (OPTION_BRACKETS (&A68_JOB))
+	    a68_substitute_brackets (TOP_NODE (&A68_JOB));
+	  A68 (symbol_table_count) = 0;
+	  A68_STANDENV = a68_new_symbol_table (NO_TABLE);
+	  LEVEL (A68_STANDENV) = 0;
+	  a68_top_down_parser (TOP_NODE (&A68_JOB));
+	}
+
+      renum = 0;
+      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
+    }
+
+  /* Standard environment builder.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      TABLE (TOP_NODE (&A68_JOB)) = a68_new_symbol_table (A68_STANDENV);
+      a68_make_standard_environ ();
+      STANDENV_MOID (&A68_JOB) = TOP_MOID (&A68_JOB);
+    }
+
+  /* Bottom-up parser.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      a68_preliminary_symbol_table_setup (TOP_NODE (&A68_JOB));
+      a68_bottom_up_parser (TOP_NODE (&A68_JOB));
+      renum = 0;
+      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
+    }
+
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      a68_bottom_up_error_check (TOP_NODE (&A68_JOB));
+      a68_victal_checker (TOP_NODE (&A68_JOB));
+      if (ERROR_COUNT (&A68_JOB) == 0)
+	{
+	  a68_finalise_symbol_table_setup (TOP_NODE (&A68_JOB), 2);
+	  NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3;
+	  a68_reset_symbol_table_nest_count (TOP_NODE (&A68_JOB));
+	  a68_fill_symbol_table_outer (TOP_NODE (&A68_JOB), TABLE (TOP_NODE (&A68_JOB)));
+	  a68_set_nest (TOP_NODE (&A68_JOB), NO_NODE);
+	  a68_set_proc_level (TOP_NODE (&A68_JOB), 1);
+	}
+      renum = 0;
+      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
+    }
+
+  /* Mode table builder.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    a68_make_moid_list (&A68_JOB);
+  CROSS_REFERENCE_SAFE (&A68_JOB) = true;
+
+  /* Symbol table builder.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    a68_collect_taxes (TOP_NODE (&A68_JOB));
+
+  /* Post parser.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    a68_rearrange_goto_less_jumps (TOP_NODE (&A68_JOB));
+
+  /* Mode checker.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    a68_mode_checker (TOP_NODE (&A68_JOB));
+
+  /* Coercion inserter.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      a68_coercion_inserter (TOP_NODE (&A68_JOB));
+      renum = 0;
+      renumber_nodes (TOP_NODE (&A68_JOB), &renum);
+    }
+
+  /* Application checker.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      a68_mark_moids (TOP_NODE (&A68_JOB));
+      a68_mark_auxilliary (TOP_NODE (&A68_JOB));
+      a68_jumps_from_procs (TOP_NODE (&A68_JOB));
+      a68_warn_for_unused_tags (TOP_NODE (&A68_JOB));
+    }
+
+  /* Static scope checker.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      tie_label_to_serial (TOP_NODE (&A68_JOB));
+      tie_label_to_unit (TOP_NODE (&A68_JOB));
+      a68_bind_routine_tags_to_tree (TOP_NODE (&A68_JOB));
+      a68_scope_checker (TOP_NODE (&A68_JOB));
+    }
+
+  /* Serial dynamic stack allocation checker.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      a68_serial_dsa (TOP_NODE (&A68_JOB));
+    }
+
+  /* Finalise syntax tree.  */
+  if (ERROR_COUNT (&A68_JOB) == 0)
+    {
+      int num = 0;
+      renumber_nodes (TOP_NODE (&A68_JOB), &num);
+      NEST (TABLE (TOP_NODE (&A68_JOB))) = A68 (symbol_table_count) = 3;
+      a68_reset_symbol_table_nest_count (TOP_NODE (&A68_JOB));
+    }
+}
+
+/* New_node_info.  */
+
+NODE_INFO_T *
+a68_new_node_info (void)
+{
+  NODE_INFO_T *z = (NODE_INFO_T *) xmalloc (sizeof (NODE_INFO_T));
+
+  A68 (new_node_infos)++;
+  PROCEDURE_LEVEL (z) = 0;
+  CHAR_IN_LINE (z) = NO_TEXT;
+  SYMBOL (z) = NO_TEXT;
+  PRAGMENT (z) = NO_TEXT;
+  PRAGMENT_TYPE (z) = 0;
+  LINE (z) = NO_LINE;
+  return z;
+}
+
+/* New_genie_info.  */
+
+GINFO_T *
+a68_new_genie_info (void)
+{
+  GINFO_T *z = (GINFO_T *) xmalloc (sizeof (GINFO_T));
+
+  A68 (new_genie_infos)++;
+  PARTIAL_PROC (z) = NO_MOID;
+  PARTIAL_LOCALE (z) = NO_MOID;
+  return z;
+}
+
+/* Allocate and return a new parse tree node with proper defaults.  */
+
+NODE_T *
+a68_new_node (void)
+{
+  NODE_T *z = (NODE_T *) xmalloc (sizeof (NODE_T));
+
+  A68 (new_nodes)++;
+  TABLE (z) = NO_TABLE;
+  INFO (z) = NO_NINFO;
+  GINFO (z) = NO_GINFO;
+  ATTRIBUTE (z) = STOP;
+  ANNOTATION (z) = STOP;
+  MOID (z) = NO_MOID;
+  NEXT (z) = NO_NODE;
+  PREVIOUS (z) = NO_NODE;
+  SUB (z) = NO_NODE;
+  NEST (z) = NO_NODE;
+  NON_LOCAL (z) = NO_TABLE;
+  TAX (z) = NO_TAG;
+  SEQUENCE (z) = NO_NODE;
+  PACK (z) = NO_PACK;
+  CDECL (z) = NULL_TREE;
+  DYNAMIC_STACK_ALLOCS (z) = false;
+  return z;
+}
+
+/* Some_node.  */
+
+NODE_T *
+a68_some_node (const char *t)
+{
+  NODE_T *z = a68_new_node ();
+  INFO (z) = a68_new_node_info ();
+  GINFO (z) = a68_new_genie_info ();
+  NSYMBOL (z) = t;
+  return z;
+}
+
+/* New_symbol_table.  */
+
+TABLE_T *
+a68_new_symbol_table (TABLE_T *p)
+{
+  TABLE_T *z = (TABLE_T *) xmalloc (sizeof (TABLE_T));
+
+  NUM (z) = A68 (symbol_table_count);
+  LEVEL (z) = A68 (symbol_table_count)++;
+  NEST (z) = A68 (symbol_table_count);
+  ATTRIBUTE (z) = 0;
+  INITIALISE_FRAME (z) = true;
+  PROC_OPS (z) = true;
+  INITIALISE_ANON (z) = true;
+  PREVIOUS (z) = p;
+  OUTER (z) = NO_TABLE;
+  IDENTIFIERS (z) = NO_TAG;
+  OPERATORS (z) = NO_TAG;
+  PRIO (z) = NO_TAG;
+  INDICANTS (z) = NO_TAG;
+  LABELS (z) = NO_TAG;
+  ANONYMOUS (z) = NO_TAG;
+  JUMP_TO (z) = NO_NODE;
+  SEQUENCE (z) = NO_NODE;
+  return z;
+}
+
+/* New_moid.  */
+
+MOID_T *
+a68_new_moid (void)
+{
+  MOID_T *z = (MOID_T *) xmalloc (sizeof (MOID_T));
+
+  A68 (new_modes)++;
+  ATTRIBUTE (z) = 0;
+  NUMBER (z) = 0;
+  DIM (z) = 0;
+  USE (z) = false;
+  HAS_ROWS (z) = false;
+  PORTABLE (z) = true;
+  DERIVATE (z) = false;
+  NODE (z) = NO_NODE;
+  PACK (z) = NO_PACK;
+  SUB (z) = NO_MOID;
+  EQUIVALENT_MODE (z) = NO_MOID;
+  SLICE (z) = NO_MOID;
+  TRIM (z) = NO_MOID;
+  DEFLEXED (z) = NO_MOID;
+  NAME (z) = NO_MOID;
+  MULTIPLE_MODE (z) = NO_MOID;
+  NEXT (z) = NO_MOID;
+  CTYPE (z) = NULL_TREE;
+  return z;
+}
+
+/* New_pack.  */
+
+PACK_T *
+a68_new_pack (void)
+{
+  PACK_T *z = (PACK_T *) xmalloc (sizeof (PACK_T));
+
+  MOID (z) = NO_MOID;
+  TEXT (z) = NO_TEXT;
+  NODE (z) = NO_NODE;
+  NEXT (z) = NO_PACK;
+  PREVIOUS (z) = NO_PACK;
+  return z;
+}
+
+/* New_tag.  */
+
+TAG_T *
+a68_new_tag (void)
+{
+  TAG_T *z = (TAG_T *) xmalloc (sizeof (TAG_T));
+
+  STATUS (z) = NULL_MASK;
+  TAG_TABLE (z) = NO_TABLE;
+  MOID (z) = NO_MOID;
+  NODE (z) = NO_NODE;
+  UNIT (z) = NO_NODE;
+  VALUE (z) = NO_TEXT;
+  SCOPE (z) = PRIMAL_SCOPE;
+  SCOPE_ASSIGNED (z) = false;
+  PRIO (z) = 0;
+  USE (z) = false;
+  IN_PROC (z) = false;
+  HEAP (z) = false;
+  YOUNGEST_ENVIRON (z) = PRIMAL_SCOPE;
+  LOC_ASSIGNED (z) = false;
+  NEXT (z) = NO_TAG;
+  BODY (z) = NO_TAG;
+  PORTABLE (z) = true;
+  VARIABLE (z) = false;
+  IS_RECURSIVE (z) = false;
+  ASCRIBED_ROUTINE_TEXT (z) = false;
+  LOWERER (z) = NO_LOWERER;
+  TAX_TREE_DECL (z) = NULL_TREE;
+  NUMBER (z) = ++A68_PARSER (tag_number);
+  return z;
+}
+
+/* Make special, internal mode.  */
+
+static void
+make_special_mode (MOID_T ** n, int m)
+{
+  (*n) = a68_new_moid ();
+  ATTRIBUTE (*n) = 0;
+  NUMBER (*n) = m;
+  PACK (*n) = NO_PACK;
+  SUB (*n) = NO_MOID;
+  EQUIVALENT (*n) = NO_MOID;
+  DEFLEXED (*n) = NO_MOID;
+  NAME (*n) = NO_MOID;
+  SLICE (*n) = NO_MOID;
+  TRIM (*n) = NO_MOID;
+  ROWED (*n) = NO_MOID;
+}
+
+/* Whether attributes match in subsequent nodes.  */
+
+bool
+a68_whether (NODE_T * p, ...)
+{
+  va_list vl;
+  va_start (vl, p);
+  int a;
+  while ((a = va_arg (vl, int)) != STOP)
+  {
+    if (p != NO_NODE && a == WILDCARD)
+      FORWARD (p);
+    else if (p != NO_NODE && (a == KEYWORD))
+      {
+	if (a68_find_keyword_from_attribute (A68 (top_keyword), ATTRIBUTE (p)) != NO_KEYWORD)
+	  FORWARD (p);
+	else
+	  {
+	    va_end (vl);
+	    return false;
+	  }
+      }
+    else if (p != NO_NODE && (a >= 0 ? a == ATTRIBUTE (p) : (-a) != ATTRIBUTE (p)))
+      FORWARD (p);
+    else
+      {
+	va_end (vl);
+	return false;
+      }
+  }
+  va_end (vl);
+  return true;
+}
+
+/* Whether one of a series of attributes matches a node.  */
+
+bool
+a68_is_one_of (NODE_T *p, ...)
+{
+  if (p != NO_NODE)
+    {
+      bool match = false;
+      int a;
+
+      va_list vl;
+      va_start (vl, p);
+      while ((a = va_arg (vl, int)) != STOP)
+	match = (match | IS (p, a));
+      va_end (vl);
+      return match;
+    }
+  else
+    return false;
+}
+
+
+/* Isolate nodes p-q making p a branch to p-q
+
+   From x - p - a - b - c - q - y
+   To   x - t - y
+            |
+            p - a - b - c - q
+*/
+
+void
+a68_make_sub (NODE_T *p, NODE_T *q, enum a68_attribute t)
+{
+  NODE_T *z = a68_new_node ();
+
+  gcc_assert (p != NO_NODE && q != NO_NODE);
+  *z = *p;
+
+  if (GINFO (p) != NO_GINFO)
+    GINFO (z) = a68_new_genie_info ();
+
+  PREVIOUS (z) = NO_NODE;
+
+  if (p == q)
+    NEXT (z) = NO_NODE;
+  else
+    {
+      if (NEXT (p) != NO_NODE)
+	PREVIOUS (NEXT (p)) = z;
+      NEXT (p) = NEXT (q);
+      if (NEXT (p) != NO_NODE)
+	PREVIOUS (NEXT (p)) = p;
+      NEXT (q) = NO_NODE;
+    }
+
+  SUB (p) = z;
+  ATTRIBUTE (p) = t;
+}
+
+/* Find symbol table at level I.  */
+
+static TABLE_T *
+find_level (NODE_T *n, int i)
+{
+  if (n == NO_NODE)
+    return NO_TABLE;
+  else
+    {
+      TABLE_T *s = TABLE (n);
+
+      if (s != NO_TABLE && LEVEL (s) == i)
+	return s;
+      else if ((s = find_level (SUB (n), i)) != NO_TABLE)
+	return s;
+      else if ((s = find_level (NEXT (n), i)) != NO_TABLE)
+	return s;
+      else
+	return NO_TABLE;
+    }
+}
+
+/* Whether P is top of lexical level.  */
+
+bool
+a68_is_new_lexical_level (NODE_T *p)
+{
+  switch (ATTRIBUTE (p))
+    {
+    case ALT_DO_PART:
+    case BRIEF_ELIF_PART:
+    case BRIEF_OUSE_PART:
+    case BRIEF_CONFORMITY_OUSE_PART:
+    case CHOICE:
+    case CLOSED_CLAUSE:
+    case CONDITIONAL_CLAUSE:
+    case DO_PART:
+    case ELIF_PART:
+    case ELSE_PART:
+    case CASE_CLAUSE:
+    case CASE_CHOICE_CLAUSE:
+    case CASE_IN_PART:
+    case CASE_OUSE_PART:
+    case OUT_PART:
+    case ROUTINE_TEXT:
+    case SPECIFIED_UNIT:
+    case THEN_PART:
+    case CONFORMITY_CLAUSE:
+    case CONFORMITY_CHOICE:
+    case CONFORMITY_IN_PART:
+    case CONFORMITY_OUSE_PART:
+    case WHILE_PART:
+      return true;
+    default:
+      return false;
+    }
+}
+
+/*
+ * Couple of utility functions.
+ */
+
+/* Safely append to buffer.  */
+
+void
+a68_bufcat (char *dst, const char *src, int len)
+{
+  if (src != NO_TEXT) {
+    char *d = dst;
+    const char *s = src;
+    int n = len;
+// Find end of dst and left-adjust; do not go past end
+    for (; n-- != 0 && d[0] != '\0'; d++) {
+      ;
+    }
+    int dlen = (int) (d - dst);
+    n = len - dlen;
+    if (n > 0) {
+      while (s[0] != '\0') {
+        if (n != 1) {
+          (d++)[0] = s[0];
+          n--;
+        }
+        s++;
+      }
+      d[0] = '\0';
+    }
+// Better sure than sorry
+    dst[len - 1] = '\0';
+  }
+}
+
+/* Safely copy to buffer.  */
+
+void
+a68_bufcpy (char *dst, const char *src, int len)
+{
+  if (src != NO_TEXT) {
+    char *d = dst;
+    const char *s = src;
+    int n = len;
+// Copy as many as fit
+    if (n > 0 && --n > 0) {
+      do {
+        if (((d++)[0] = (s++)[0]) == '\0') {
+          break;
+        }
+      } while (--n > 0);
+    }
+    if (n == 0 && len > 0) {
+// Not enough room in dst, so terminate
+      d[0] = '\0';
+    }
+// Better sure than sorry
+    dst[len - 1] = '\0';
+  }
+}
+
+/* Make a new copy of concatenated strings.  */
+
+char *
+a68_new_string (const char *t, ...)
+{
+  va_list vl;
+  va_start (vl, t);
+  const char *q = t;
+  if (q == NO_TEXT) {
+    va_end (vl);
+    return NO_TEXT;
+  }
+  int len = 0;
+  while (q != NO_TEXT) {
+    len += (int) strlen (q);
+    q = va_arg (vl, char *);
+  }
+  va_end (vl);
+  len++;
+  char *z = (char *) xmalloc ((size_t) len);
+  z[0] = '\0';
+  q = t;
+  va_start (vl, t);
+  while (q != NO_TEXT) {
+    a68_bufcat (z, q, len);
+    q = va_arg (vl, char *);
+  }
+  va_end (vl);
+  return z;
+}
+
+/*  Tie label to the clause it is defined in.  */
+
+static void
+tie_label_to_serial (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, SERIAL_CLAUSE))
+	{
+	  bool valid_follow;
+
+	  if (NEXT (p) == NO_NODE)
+	    valid_follow = true;
+	  else if (IS (NEXT (p), CLOSE_SYMBOL))
+	    valid_follow = true;
+	  else if (IS (NEXT (p), END_SYMBOL))
+	    valid_follow = true;
+	  else if (IS (NEXT (p), OD_SYMBOL))
+	    valid_follow = true;
+	  else
+	    valid_follow = false;
+
+	  if (valid_follow)
+	    JUMP_TO (TABLE (SUB (p))) = NO_NODE;
+	}
+
+      tie_label_to_serial (SUB (p));
+    }
+}
+
+/* Tie label to the clause it is defined in.  */
+
+static void
+tie_label (NODE_T *p, NODE_T *unit)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, DEFINING_IDENTIFIER))
+	UNIT (TAX (p)) = unit;
+      tie_label (SUB (p), unit);
+    }
+}
+
+/* Tie label to the clause it is defined in.  */
+
+static void
+tie_label_to_unit (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, LABELED_UNIT))
+	tie_label (SUB_SUB (p), NEXT_SUB (p));
+      tie_label_to_unit (SUB (p));
+    }
+}
+
+/* Table with attribute names.  */
+
+static const char *attribute_names[] =
+{
+  "STOP",
+#define A68_ATTR(ATTR) #ATTR,
+#include "a68-parser-attrs.def"
+#undef A68_ATTR
+};
+
+/* Get the name of an attribute.  */
+
+const char *
+a68_attribute_name (enum a68_attribute attr)
+{
+  return attribute_names[attr];
+}
+
+/* Get the location of node P as a GCC location.  */
+
+location_t
+a68_get_node_location (NODE_T *p)
+{
+  LINE_T *line = LINE (INFO (p));
+
+  if (line == NO_LINE)
+    return UNKNOWN_LOCATION;
+
+  unsigned line_number = NUMBER (line);
+  unsigned column_number = CHAR_IN_LINE (INFO (p)) - STRING (line) + 1;
+  const char *filename = FILENAME (line);
+
+  location_t gcc_location;
+
+  linemap_add (line_table, LC_ENTER, 0, filename, line_number);
+  linemap_line_start (line_table, line_number, 0);
+  gcc_location = linemap_position_for_column (line_table, column_number);
+  linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
+
+  return gcc_location;
+}
+
+/* Get the location of POS inside LINE as a GCC location.  */
+
+location_t
+a68_get_line_location (LINE_T *line, const char *pos)
+{
+  location_t loc;
+
+  linemap_add (line_table, LC_ENTER, 0, FILENAME (line), NUMBER (line));
+  linemap_line_start (line_table, NUMBER (line), 0);
+  loc = linemap_position_for_column (line_table, pos - STRING (line) + 1);
+  linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
+  return loc;
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 15/47] a68: parser: AST nodes attributes/types
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (13 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 14/47] a68: parser: entry point Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 16/47] a68: parser: scanner Jose E. Marchesi
                   ` (32 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-parser-attrs.def: New file.
---
 gcc/algol68/a68-parser-attrs.def | 362 +++++++++++++++++++++++++++++++
 1 file changed, 362 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-attrs.def

diff --git a/gcc/algol68/a68-parser-attrs.def b/gcc/algol68/a68-parser-attrs.def
new file mode 100644
index 00000000000..6ccade45a57
--- /dev/null
+++ b/gcc/algol68/a68-parser-attrs.def
@@ -0,0 +1,362 @@
+/* This file contains the definitions and documentation for all the different
+   kind/attributes of Algol 68 parse tree nodes.
+   Copyright (C) 2025 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/>.  */
+
+/* Please keep the entries in this file sorted alphabetically.  */
+
+A68_ATTR(A68_PATTERN)
+A68_ATTR(ACTUAL_DECLARER_MARK)
+A68_ATTR(ALT_DO_PART)
+A68_ATTR(ALT_DO_SYMBOL)
+A68_ATTR(ALT_EQUALS_SYMBOL)
+A68_ATTR(ALT_FORMAL_BOUNDS_LIST)
+A68_ATTR(ANDF_SYMBOL)
+A68_ATTR(AND_FUNCTION)
+A68_ATTR(ANONYMOUS)
+A68_ATTR(ARGUMENT)
+A68_ATTR(ARGUMENT_LIST)
+A68_ATTR(ASSERTION)
+A68_ATTR(ASSERT_SYMBOL)
+A68_ATTR(ASSIGNATION)
+A68_ATTR(ASSIGN_SYMBOL)
+A68_ATTR(ASSIGN_TO_SYMBOL)
+A68_ATTR(AT_SYMBOL)
+A68_ATTR(BEGIN_SYMBOL)
+A68_ATTR(BITS_C_PATTERN)
+A68_ATTR(BITS_DENOTATION)
+A68_ATTR(BITS_PATTERN)
+A68_ATTR(BITS_SYMBOL)
+A68_ATTR(BOLD_COMMENT_SYMBOL)
+A68_ATTR(BOLD_COMMENT_BEGIN_SYMBOL)
+A68_ATTR(BOLD_COMMENT_END_SYMBOL)
+A68_ATTR(BOLD_PRAGMAT_SYMBOL)
+A68_ATTR(BOLD_TAG)
+A68_ATTR(BOOLEAN_PATTERN)
+A68_ATTR(BOOL_SYMBOL)
+A68_ATTR(BOUND)
+A68_ATTR(BOUNDS)
+A68_ATTR(BOUNDS_LIST)
+A68_ATTR(BRIEF_COMMENT_BEGIN_SYMBOL)
+A68_ATTR(BRIEF_COMMENT_END_SYMBOL)
+A68_ATTR(BRIEF_OUSE_PART)
+A68_ATTR(BRIEF_CONFORMITY_OUSE_PART)
+A68_ATTR(BRIEF_ELIF_PART)
+A68_ATTR(BRIEF_OPERATOR_DECLARATION)
+A68_ATTR(BUS_SYMBOL)
+A68_ATTR(BYTES_SYMBOL)
+A68_ATTR(BY_PART)
+A68_ATTR(BY_SYMBOL)
+A68_ATTR(CALL)
+A68_ATTR(CASE_CHOICE_CLAUSE)
+A68_ATTR(CASE_CLAUSE)
+A68_ATTR(CASE_IN_PART)
+A68_ATTR(CASE_OUSE_PART)
+A68_ATTR(CASE_PART)
+A68_ATTR(CASE_SYMBOL)
+A68_ATTR(CAST)
+A68_ATTR(CHANNEL_SYMBOL)
+A68_ATTR(CHAR_C_PATTERN)
+A68_ATTR(CHAR_SYMBOL)
+A68_ATTR(CHOICE)
+A68_ATTR(CHOICE_PATTERN)
+A68_ATTR(CLOSED_CLAUSE)
+A68_ATTR(CLOSE_SYMBOL)
+A68_ATTR(COLLATERAL_CLAUSE)
+A68_ATTR(COLLECTION)
+A68_ATTR(COLON_SYMBOL)
+A68_ATTR(COMMA_SYMBOL)
+A68_ATTR(COMPLEX_PATTERN)
+A68_ATTR(COMPLEX_SYMBOL)
+A68_ATTR(COMPL_SYMBOL)
+A68_ATTR(CONDITIONAL_CLAUSE)
+A68_ATTR(CONFORMITY_CHOICE)
+A68_ATTR(CONFORMITY_CLAUSE)
+A68_ATTR(CONFORMITY_IN_PART)
+A68_ATTR(CONFORMITY_OUSE_PART)
+A68_ATTR(CONSTRUCT)
+A68_ATTR(DECLARATION_LIST)
+A68_ATTR(DECLARER)
+A68_ATTR(DEFINING_IDENTIFIER)
+A68_ATTR(DEFINING_INDICANT)
+A68_ATTR(DEFINING_OPERATOR)
+A68_ATTR(DENOTATION)
+A68_ATTR(DEPROCEDURING)
+A68_ATTR(DEREFERENCING)
+A68_ATTR(DO_PART)
+A68_ATTR(DO_SYMBOL)
+A68_ATTR(DYNAMIC_REPLICATOR)
+A68_ATTR(ELIF_IF_PART)
+A68_ATTR(ELIF_PART)
+A68_ATTR(ELIF_SYMBOL)
+A68_ATTR(ELSE_BAR_SYMBOL)
+A68_ATTR(ELSE_OPEN_PART)
+A68_ATTR(ELSE_PART)
+A68_ATTR(ELSE_SYMBOL)
+A68_ATTR(EMPTY_SYMBOL)
+A68_ATTR(ENCLOSED_CLAUSE)
+A68_ATTR(END_SYMBOL)
+A68_ATTR(ENQUIRY_CLAUSE)
+A68_ATTR(EQUALS_SYMBOL)
+A68_ATTR(ERROR)
+A68_ATTR(ERROR_IDENTIFIER)
+A68_ATTR(ESAC_SYMBOL)
+A68_ATTR(EXIT_SYMBOL)
+A68_ATTR(EXPONENT_FRAME)
+A68_ATTR(FALSE_SYMBOL)
+A68_ATTR(FIELD)
+A68_ATTR(FIELD_IDENTIFIER)
+A68_ATTR(FILE_SYMBOL)
+A68_ATTR(FIRM)
+A68_ATTR(FIXED_C_PATTERN)
+A68_ATTR(FI_SYMBOL)
+A68_ATTR(FLEX_SYMBOL)
+A68_ATTR(FLOAT_C_PATTERN)
+A68_ATTR(FORMAL_BOUNDS)
+A68_ATTR(FORMAL_BOUNDS_LIST)
+A68_ATTR(FORMAL_DECLARERS)
+A68_ATTR(FORMAL_DECLARERS_LIST)
+A68_ATTR(FORMAL_DECLARER_MARK)
+A68_ATTR(FORMULA)
+A68_ATTR(FOR_PART)
+A68_ATTR(FOR_SYMBOL)
+A68_ATTR(FORMAT_CLOSE_SYMBOL)
+A68_ATTR(FORMAT_DELIMITER_SYMBOL)
+A68_ATTR(FORMAT_IDENTIFIER)
+A68_ATTR(FORMAT_A_FRAME)
+A68_ATTR(FORMAT_D_FRAME)
+A68_ATTR(FORMAT_E_FRAME)
+A68_ATTR(FORMAT_I_FRAME)
+A68_ATTR(FORMAT_ITEM_A)
+A68_ATTR(FORMAT_ITEM_B)
+A68_ATTR(FORMAT_ITEM_C)
+A68_ATTR(FORMAT_ITEM_D)
+A68_ATTR(FORMAT_ITEM_E)
+A68_ATTR(FORMAT_ITEM_F)
+A68_ATTR(FORMAT_ITEM_G)
+A68_ATTR(FORMAT_ITEM_H)
+A68_ATTR(FORMAT_ITEM_I)
+A68_ATTR(FORMAT_ITEM_J)
+A68_ATTR(FORMAT_ITEM_K)
+A68_ATTR(FORMAT_ITEM_L)
+A68_ATTR(FORMAT_ITEM_M)
+A68_ATTR(FORMAT_ITEM_N)
+A68_ATTR(FORMAT_ITEM_O)
+A68_ATTR(FORMAT_ITEM_P)
+A68_ATTR(FORMAT_ITEM_Q)
+A68_ATTR(FORMAT_ITEM_R)
+A68_ATTR(FORMAT_ITEM_S)
+A68_ATTR(FORMAT_ITEM_T)
+A68_ATTR(FORMAT_ITEM_U)
+A68_ATTR(FORMAT_ITEM_V)
+A68_ATTR(FORMAT_ITEM_W)
+A68_ATTR(FORMAT_ITEM_X)
+A68_ATTR(FORMAT_ITEM_Y)
+A68_ATTR(FORMAT_ITEM_Z)
+A68_ATTR(FORMAT_ITEM_ESCAPE)
+A68_ATTR(FORMAT_ITEM_MINUS)
+A68_ATTR(FORMAT_ITEM_PLUS)
+A68_ATTR(FORMAT_ITEM_POINT)
+A68_ATTR(FORMAT_OPEN_SYMBOL)
+A68_ATTR(FORMAT_PATTERN)
+A68_ATTR(FORMAT_POINT_FRAME)
+A68_ATTR(FORMAT_SYMBOL)
+A68_ATTR(FORMAT_TEXT)
+A68_ATTR(FORMAT_Z_FRAME)
+A68_ATTR(FROM_PART)
+A68_ATTR(FROM_SYMBOL)
+A68_ATTR(GENERAL_C_PATTERN)
+A68_ATTR(GENERAL_PATTERN)
+A68_ATTR(GENERATOR)
+A68_ATTR(GENERIC_ARGUMENT)
+A68_ATTR(GENERIC_ARGUMENT_LIST)
+A68_ATTR(GOTO_SYMBOL)
+A68_ATTR(GO_SYMBOL)
+A68_ATTR(GUARDED_CONDITIONAL_CLAUSE)
+A68_ATTR(GUARDED_LOOP_CLAUSE)
+A68_ATTR(HEAP_SYMBOL)
+A68_ATTR(IDENTIFIER)
+A68_ATTR(IDENTIFIER_WITH_UNDERSCORES)
+A68_ATTR(IDENTITY_DECLARATION)
+A68_ATTR(IDENTITY_RELATION)
+A68_ATTR(IF_PART)
+A68_ATTR(IF_SYMBOL)
+A68_ATTR(INDICANT)
+A68_ATTR(INITIALISER_SERIES)
+A68_ATTR(INSERTION)
+A68_ATTR(INTEGRAL_C_PATTERN)
+A68_ATTR(INTEGRAL_MOULD)
+A68_ATTR(INTEGRAL_PATTERN)
+A68_ATTR(INT_DENOTATION)
+A68_ATTR(INT_SYMBOL)
+A68_ATTR(IN_SYMBOL)
+A68_ATTR(IN_TYPE_MODE)
+A68_ATTR(ISNT_SYMBOL)
+A68_ATTR(IS_SYMBOL)
+A68_ATTR(JUMP)
+A68_ATTR(KEYWORD)
+A68_ATTR(LABEL)
+A68_ATTR(LABELED_UNIT)
+A68_ATTR(LABEL_IDENTIFIER)
+A68_ATTR(LABEL_SEQUENCE)
+A68_ATTR(LITERAL)
+A68_ATTR(LOCAL_LABEL)
+A68_ATTR(LOC_SYMBOL)
+A68_ATTR(LONGETY)
+A68_ATTR(LONG_SYMBOL)
+A68_ATTR(LOOP_CLAUSE)
+A68_ATTR(LOOP_IDENTIFIER)
+A68_ATTR(MAIN_SYMBOL)
+A68_ATTR(MEEK)
+A68_ATTR(MODE_BITS)
+A68_ATTR(MODE_BOOL)
+A68_ATTR(MODE_BYTES)
+A68_ATTR(MODE_CHAR)
+A68_ATTR(MODE_COMPLEX)
+A68_ATTR(MODE_DECLARATION)
+A68_ATTR(MODE_FILE)
+A68_ATTR(MODE_FORMAT)
+A68_ATTR(A68_MODE_INT)
+A68_ATTR(MODE_LONG_LONG_BITS)
+A68_ATTR(MODE_LONG_LONG_COMPLEX)
+A68_ATTR(MODE_LONG_LONG_INT)
+A68_ATTR(MODE_LONG_LONG_REAL)
+A68_ATTR(MODE_LONG_BITS)
+A68_ATTR(MODE_LONG_BYTES)
+A68_ATTR(MODE_LONG_COMPLEX)
+A68_ATTR(MODE_LONG_INT)
+A68_ATTR(MODE_LONG_REAL)
+A68_ATTR(MODE_NO_CHECK)
+A68_ATTR(MODE_REAL)
+A68_ATTR(MODE_SYMBOL)
+A68_ATTR(MONADIC_FORMULA)
+A68_ATTR(MONAD_SEQUENCE)
+A68_ATTR(NIHIL)
+A68_ATTR(NIL_SYMBOL)
+A68_ATTR(NORMAL_IDENTIFIER)
+A68_ATTR(NO_SORT)
+A68_ATTR(OD_SYMBOL)
+A68_ATTR(OF_SYMBOL)
+A68_ATTR(OPEN_PART)
+A68_ATTR(OPEN_SYMBOL)
+A68_ATTR(OPERATOR)
+A68_ATTR(OPERATOR_DECLARATION)
+A68_ATTR(OPERATOR_PLAN)
+A68_ATTR(OP_SYMBOL)
+A68_ATTR(ORF_SYMBOL)
+A68_ATTR(OR_FUNCTION)
+A68_ATTR(OUSE_PART)
+A68_ATTR(OUSE_SYMBOL)
+A68_ATTR(OUT_PART)
+A68_ATTR(OUT_SYMBOL)
+A68_ATTR(OUT_TYPE_MODE)
+A68_ATTR(PARALLEL_CLAUSE)
+A68_ATTR(PARAMETER)
+A68_ATTR(PARAMETER_IDENTIFIER)
+A68_ATTR(PARAMETER_LIST)
+A68_ATTR(PARAMETER_PACK)
+A68_ATTR(PARTICULAR_PROGRAM)
+A68_ATTR(PAR_SYMBOL)
+A68_ATTR(PICTURE)
+A68_ATTR(PICTURE_LIST)
+A68_ATTR(PIPE_SYMBOL)
+A68_ATTR(POINT_SYMBOL)
+A68_ATTR(PRIMARY)
+A68_ATTR(PRIORITY)
+A68_ATTR(PRIORITY_DECLARATION)
+A68_ATTR(PRIO_SYMBOL)
+A68_ATTR(PROCEDURE_DECLARATION)
+A68_ATTR(PROCEDURE_VARIABLE_DECLARATION)
+A68_ATTR(PROCEDURING)
+A68_ATTR(PROC_SYMBOL)
+A68_ATTR(QUALIFIER)
+A68_ATTR(RADIX_FRAME)
+A68_ATTR(REAL_DENOTATION)
+A68_ATTR(REAL_PATTERN)
+A68_ATTR(REAL_SYMBOL)
+A68_ATTR(REF_SYMBOL)
+A68_ATTR(REPLICATOR)
+A68_ATTR(ROUTINE_TEXT)
+A68_ATTR(ROUTINE_UNIT)
+A68_ATTR(ROWING)
+A68_ATTR(ROWS_SYMBOL)
+A68_ATTR(ROW_CHAR_DENOTATION)
+A68_ATTR(ROW_SYMBOL)
+A68_ATTR(SECONDARY)
+A68_ATTR(SELECTION)
+A68_ATTR(SELECTOR)
+A68_ATTR(SEMA_SYMBOL)
+A68_ATTR(SEMI_SYMBOL)
+A68_ATTR(SERIAL_CLAUSE)
+A68_ATTR(SERIES_MODE)
+A68_ATTR(SHORTETY)
+A68_ATTR(SHORT_SYMBOL)
+A68_ATTR(SIGN_MOULD)
+A68_ATTR(SKIP)
+A68_ATTR(SKIP_SYMBOL)
+A68_ATTR(SLICE)
+A68_ATTR(SOFT)
+A68_ATTR(SOME_CLAUSE)
+A68_ATTR(SPECIFICATION)
+A68_ATTR(SPECIFIED_UNIT)
+A68_ATTR(SPECIFIED_UNIT_LIST)
+A68_ATTR(SPECIFIED_UNIT_UNIT)
+A68_ATTR(SPECIFIER)
+A68_ATTR(SPECIFIER_IDENTIFIER)
+A68_ATTR(STANDARD)
+A68_ATTR(STATIC_REPLICATOR)
+A68_ATTR(STOWED_MODE)
+A68_ATTR(STRING_C_PATTERN)
+A68_ATTR(STRING_PATTERN)
+A68_ATTR(STRING_SYMBOL)
+A68_ATTR(STRONG)
+A68_ATTR(STRUCTURED_FIELD)
+A68_ATTR(STRUCTURED_FIELD_LIST)
+A68_ATTR(STRUCTURE_PACK)
+A68_ATTR(STRUCT_SYMBOL)
+A68_ATTR(STYLE_II_COMMENT_SYMBOL)
+A68_ATTR(STYLE_I_COMMENT_SYMBOL)
+A68_ATTR(STYLE_I_PRAGMAT_SYMBOL)
+A68_ATTR(SUB_SYMBOL)
+A68_ATTR(SUB_UNIT)
+A68_ATTR(TERTIARY)
+A68_ATTR(THEN_BAR_SYMBOL)
+A68_ATTR(THEN_PART)
+A68_ATTR(THEN_SYMBOL)
+A68_ATTR(TO_PART)
+A68_ATTR(TO_SYMBOL)
+A68_ATTR(TRIMMER)
+A68_ATTR(TRUE_SYMBOL)
+A68_ATTR(UNION_DECLARER_LIST)
+A68_ATTR(UNION_PACK)
+A68_ATTR(UNION_SYMBOL)
+A68_ATTR(UNIT)
+A68_ATTR(UNITING)
+A68_ATTR(UNIT_LIST)
+A68_ATTR(UNIT_SERIES)
+A68_ATTR(VARIABLE_DECLARATION)
+A68_ATTR(VIRTUAL_DECLARER_MARK)
+A68_ATTR(VOIDING)
+A68_ATTR(VOID_SYMBOL)
+A68_ATTR(WEAK)
+A68_ATTR(WHILE_PART)
+A68_ATTR(WHILE_SYMBOL)
+A68_ATTR(WIDENING)
+A68_ATTR(WILDCARD)
+
+/*
+Local variables:
+mode:c
+End:
+*/
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 16/47] a68: parser: scanner
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (14 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 15/47] a68: parser: AST nodes attributes/types Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 17/47] a68: parser: keyword tables management Jose E. Marchesi
                   ` (31 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Lexer for the Algol 68 front-end.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-scanner.cc | 2277 +++++++++++++++++++++++++++++
 1 file changed, 2277 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-scanner.cc

diff --git a/gcc/algol68/a68-parser-scanner.cc b/gcc/algol68/a68-parser-scanner.cc
new file mode 100644
index 00000000000..d3f7a93abe3
--- /dev/null
+++ b/gcc/algol68/a68-parser-scanner.cc
@@ -0,0 +1,2277 @@
+/* Context-dependent ALGOL 68 tokeniser.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+/* Context-dependent ALGOL 68 tokeniser.  */
+
+
+#define INCLUDE_MEMORY
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "diagnostic.h"
+#include "options.h"
+#include "vec.h"
+
+#include "a68.h"
+
+/* A few forward references of static functions defined in this file.  */
+
+static void include_files (LINE_T *top);
+
+/* Standard prelude and postlude for source files.
+
+   We need several versions for the several supported stropping regimes.  */
+
+static const char *
+upper_prelude_start[] = {
+  "BEGIN",
+  "      BEGIN",
+  NO_TEXT
+};
+
+static const char *
+upper_postlude[] = {
+  "      END;",
+  "      stop: SKIP",
+  "END",
+  NO_TEXT
+};
+
+static const char *
+supper_prelude_start[] = {
+  "begin",
+  "     begin",
+  NO_TEXT
+};
+
+static const char *
+supper_postlude[] = {
+  "      end;",
+  "      stop: skip",
+  "end",
+  NO_TEXT
+};
+
+/* Macros.  */
+
+#define NULL_CHAR '\0'
+#define STOP_CHAR 127
+#define FORMFEED_CHAR '\f'
+#define CR_CHAR '\r'
+#define QUOTE_CHAR '"'
+#define APOSTROPHE_CHAR '\''
+#define BACKSLASH_CHAR '\\'
+#define NEWLINE_CHAR '\n'
+#define EXPONENT_CHAR 'e'
+#define RADIX_CHAR 'r'
+#define POINT_CHAR '.'
+#define TAB_CHAR '\t'
+
+#define MAX_RESTART 256
+
+#define EOL(c) ((c) == NEWLINE_CHAR || (c) == NULL_CHAR)
+#define SCAN_ERROR(c, u, v, txt) if (c)		\
+    do						\
+      {						\
+	a68_scan_error (u, v, txt);		\
+      }						\
+    while (0)
+
+
+#define SCAN_DIGITS(c)				\
+  while (ISDIGIT (c))				\
+    {						\
+      (sym++)[0] = (c);				\
+      (c) = next_char (ref_l, ref_s, true);	\
+    }
+
+#define SCAN_EXPONENT_PART(c)						\
+  do									\
+    {									\
+      (sym++)[0] = EXPONENT_CHAR;					\
+      (c) = next_char (ref_l, ref_s, true);				\
+      if ((c) == '+' || (c) == '-') {					\
+	(sym++)[0] = (c);						\
+	(c) = next_char (ref_l, ref_s, true);				\
+      }									\
+      SCAN_ERROR (!ISDIGIT (c), *start_l, *start_c,			\
+		  "invalid exponent digit");				\
+      SCAN_DIGITS (c);							\
+    }									\
+  while (0)
+
+/* Read bytes from file into buffer.  */
+
+static ssize_t
+io_read (FILE *file, void *buf, size_t n)
+{
+  int fd = fileno (file);
+  size_t to_do = n;
+  int restarts = 0;
+  char *z = (char *) buf;
+  while (to_do > 0)
+    {
+      ssize_t bytes_read;
+
+      errno = 0;
+      bytes_read = read (fd, z, to_do);
+      if (bytes_read < 0)
+	{
+	  if (errno == EINTR)
+	    {
+	      /* interrupt, retry.  */
+	      bytes_read = 0;
+	      if (restarts++ > MAX_RESTART)
+		{
+		  return -1;
+		}
+	    }
+	  else
+	    {
+	      /* read error.  */
+	      return -1;
+	    }
+	}
+      else if (bytes_read == 0)
+	{
+	  /* EOF_CHAR */
+	  break;
+	}
+      to_do -= (size_t) bytes_read;
+      z += bytes_read;
+    }
+
+  /* return >= 0  */
+  return (ssize_t) n - (ssize_t) to_do;
+}
+
+/* Save scanner state, for character look-ahead.  */
+
+static void
+save_state (LINE_T *ref_l, char *ref_s, char ch)
+{
+  SCAN_STATE_L (&A68_JOB) = ref_l;
+  SCAN_STATE_S (&A68_JOB) = ref_s;
+  SCAN_STATE_C (&A68_JOB) = ch;
+}
+
+/* Restore scanner state, for character look-ahead.  */
+
+static void
+restore_state (LINE_T **ref_l, char **ref_s, char *ch)
+{
+  *ref_l = SCAN_STATE_L (&A68_JOB);
+  *ref_s = SCAN_STATE_S (&A68_JOB);
+  *ch = SCAN_STATE_C (&A68_JOB);
+}
+
+/* New_source_line.  */
+
+static LINE_T *
+new_source_line (void)
+{
+  LINE_T *z = (LINE_T *) xmalloc (sizeof (LINE_T));
+
+  MARKER (z)[0] = '\0';
+  STRING (z) = NO_TEXT;
+  FILENAME (z) = NO_TEXT;
+  NUMBER (z) = 0;
+  NEXT (z) = NO_LINE;
+  PREVIOUS (z) = NO_LINE;
+  return z;
+}
+
+/* Append a source line to the internal source file.  */
+
+static void
+append_source_line (const char *str, LINE_T **ref_l, int *line_num,
+		    const char *filename)
+{
+  LINE_T *z = new_source_line ();
+
+  /* Link line into the chain.  */
+  STRING (z) = xstrdup (str);
+  FILENAME (z) = filename;
+  NUMBER (z) = (*line_num)++;
+  NEXT (z) = NO_LINE;
+  PREVIOUS (z) = *ref_l;
+  if (TOP_LINE (&A68_JOB) == NO_LINE)
+    TOP_LINE (&A68_JOB) = z;
+  if (*ref_l != NO_LINE)
+    NEXT (*ref_l) = z;
+  *ref_l = z;
+}
+
+/* Append environment source lines.  */
+
+static void
+append_environ (const char *str[], LINE_T **ref_l, int *line_num, const char *name)
+{
+  for (int k = 0; str[k] != NO_TEXT; k++)
+    {
+      int zero_line_num = 0;
+      (*line_num)++;
+      append_source_line (str[k], ref_l, &zero_line_num, name);
+    }
+}
+
+/*
+ * Scanner, tokenises the source code.
+ */
+
+/* Emit a diagnostic if CH is an unworthy character.  */
+
+static void
+unworthy (LINE_T *u, char *v, char ch)
+{
+  if (ISPRINT (ch))
+    {
+      if (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*%s",
+		    "unworthy character") < 0)
+	gcc_unreachable ();
+    }
+  else
+    {
+      if (snprintf (A68 (edit_line), SNPRINTF_SIZE, "*%s %c",
+		    "unworthy character", ch) < 0)
+	gcc_unreachable ();
+    }
+
+  a68_scan_error (u, v, A68 (edit_line));
+}
+
+/* Concatenate lines that terminate in '\' with next line.  */
+
+static void
+concatenate_lines (LINE_T * top)
+{
+  LINE_T *q;
+  /* Work from bottom backwards.  */
+  for (q = top; q != NO_LINE && NEXT (q) != NO_LINE; FORWARD (q))
+    ;
+
+  for (; q != NO_LINE; BACKWARD (q))
+    {
+      char *z = STRING (q);
+      size_t len = strlen (z);
+
+      if (len >= 2
+	  && z[len - 2] == BACKSLASH_CHAR
+	  && z[len - 1] == NEWLINE_CHAR
+	  && NEXT (q) != NO_LINE
+	  && STRING (NEXT (q)) != NO_TEXT)
+	{
+	  z[len - 2] = '\0';
+	  len += (int) strlen (STRING (NEXT (q)));
+	  z = (char *) xmalloc (len + 1);
+	  a68_bufcpy (z, STRING (q), len + 1);
+	  a68_bufcat (z, STRING (NEXT (q)), len + 1);
+	  STRING (NEXT (q))[0] = '\0';
+	  STRING (q) = z;
+	}
+    }
+}
+
+/* Size of source file.  */
+
+static int
+get_source_size (void)
+{
+  FILE *f = FILE_SOURCE_FD (&A68_JOB);
+  return (int) lseek (fileno (f), 0, SEEK_END);
+}
+
+/* Read source file FILENAME and make internal copy.  */
+
+static bool
+read_source_file (const char *filename)
+{
+  struct stat statbuf;
+  LINE_T *ref_l = NO_LINE;
+  int line_num = 0;
+  size_t k;
+  size_t bytes_read;
+  ssize_t l;
+  size_t source_file_size;
+  char *buffer;
+  FILE *f;
+  bool ret = true;
+
+  /* First open the given file.  */
+  if (!(FILE_SOURCE_FD (&A68_JOB) = fopen (filename, "r")))
+    fatal_error (UNKNOWN_LOCATION, "could not open source file %s",
+		 filename);
+  FILE_SOURCE_NAME (&A68_JOB) = xstrdup (filename);
+  f = FILE_SOURCE_FD (&A68_JOB);
+
+  if (fstat (fileno (f), &statbuf)
+      || !(S_ISREG (statbuf.st_mode) || S_ISCHR (statbuf.st_mode)))
+    fatal_error (UNKNOWN_LOCATION, "specified file %s is a directory",
+		 filename);
+
+  if ((source_file_size = get_source_size ()) == 0)
+    {
+      /* The source file is empty.  */
+      ret = false;
+      goto done;
+    }
+
+  /* Allocate A68_PARSER (scan_buf), which is an auxiliary buffer used by the
+     scanner known to be big enough to hold any string contained in the source
+     file.  */
+  A68_PARSER (max_scan_buf_length) = source_file_size + 1;
+  A68_PARSER (max_scan_buf_length) += 1024; /* For the environment.  */
+  A68_PARSER (scan_buf) = (char *) xmalloc (A68_PARSER (max_scan_buf_length));
+
+  /* Prelude.  */
+  append_environ (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING
+		  ? upper_prelude_start : supper_prelude_start,
+		  &ref_l, &line_num, "prelude");
+
+  /* Read the file into a single buffer, so we save on system calls.  */
+  line_num = 1;
+  errno = 0;
+  buffer = (char *) xmalloc (8 + source_file_size);
+  if (lseek (fileno (f), 0, SEEK_SET) < 0)
+    gcc_unreachable ();
+  errno = 0;
+  bytes_read = io_read (f, buffer, source_file_size);
+  gcc_assert (errno == 0 && bytes_read == source_file_size);
+
+  /* Link all lines into the list.  */
+  k = 0;
+  while (k < source_file_size)
+    {
+      l = 0;
+      A68_PARSER (scan_buf)[0] = '\0';
+      while (k < source_file_size  && buffer[k] != NEWLINE_CHAR)
+	{
+	  if (k < source_file_size - 1
+	      && buffer[k] == CR_CHAR && buffer[k + 1] == NEWLINE_CHAR)
+	    k++;
+	  else
+	    {
+	      A68_PARSER (scan_buf)[l++] = buffer[k++];
+	      A68_PARSER (scan_buf)[l] = '\0';
+	    }
+	}
+      A68_PARSER (scan_buf)[l++] = NEWLINE_CHAR;
+      A68_PARSER (scan_buf)[l] = '\0';
+      if (k < source_file_size)
+	k++;
+      append_source_line (A68_PARSER (scan_buf), &ref_l, &line_num,
+			  FILE_SOURCE_NAME (&A68_JOB));
+      SCAN_ERROR (l != (ssize_t) strlen (A68_PARSER (scan_buf)),
+		  NO_LINE, NO_TEXT, "invalid characters in source file");
+    }
+
+  /* Postlude.  */
+  append_environ (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING
+		  ? upper_postlude : supper_postlude,
+		  &ref_l, &line_num, "postlude");
+
+  /* Concatenate lines that end with \.  */
+  concatenate_lines (TOP_LINE (&A68_JOB));
+
+  /* Include files.  */
+  include_files (TOP_LINE (&A68_JOB));
+
+ done:
+  if (fclose (FILE_SOURCE_FD (&A68_JOB)) != 0)
+    gcc_unreachable ();
+  return ret;
+}
+
+/* Get next character from internal copy of source file.
+
+   If ALLOW_TYPO is true then typographical display features are skipped.
+
+   If ALLOW_ONE_UNDER is true then a single underscore character is
+   skipped.  */
+
+static char
+next_char (LINE_T **ref_l, char **ref_s, bool allow_typo,
+	   bool allow_one_under = false, bool *found_under = NULL)
+{
+  char ch;
+
+  /* Empty source.  */
+  if (*ref_l == NO_LINE)
+    return STOP_CHAR;
+
+  if ((*ref_s)[0] == NEWLINE_CHAR || (*ref_s)[0] == '\0')
+    {
+      /* Go to new line.  */
+      *ref_l = NEXT (*ref_l);
+      if (*ref_l == NO_LINE)
+        return STOP_CHAR;
+      *ref_s = STRING (*ref_l);
+    }
+  else
+    (*ref_s)++;
+
+  /* Deliver next char.  */
+  ch = (*ref_s)[0];
+  if ((allow_typo && (ISSPACE (ch) || ch == FORMFEED_CHAR))
+      || (allow_one_under && ch == '_'))
+    {
+      if (ch == '_' && found_under != NULL)
+	*found_under = true;
+      ch = next_char (ref_l, ref_s, allow_typo);
+    }
+  return ch;
+}
+
+/* Find first character that can start a valid symbol.  */
+
+static void
+get_good_char (char *ref_c, LINE_T **ref_l, char **ref_s)
+{
+  while (*ref_c != STOP_CHAR && (ISSPACE (*ref_c) || (*ref_c == '\0')))
+    *ref_c = next_char (ref_l, ref_s, false);
+}
+
+/* Case insensitive strncmp for at most the number of chars in V.  */
+
+static int
+streq (const char *u, const char *v)
+{
+  int diff;
+  for (diff = 0; diff == 0 && u[0] != NULL_CHAR && v[0] != NULL_CHAR; u++, v++)
+    diff = ((int) TOLOWER (u[0])) - ((int) TOLOWER (v[0]));
+  return diff;
+}
+
+/* Case insensitive strncmp for at most N chars.  */
+
+static int
+strneq (const char *u, const char *v, size_t n)
+{
+  int diff;
+  size_t pos = 0;
+  for (diff = 0;
+       diff == 0 && u[0] != NULL_CHAR && v[0] != NULL_CHAR && pos < n;
+       u++, v++, pos++)
+    diff = ((int) TOLOWER (u[0])) - ((int) TOLOWER (v[0]));
+  return diff;
+}
+
+
+/* Determine whether u is bold tag v, independent of stropping regime.  */
+
+static bool
+is_bold (char *u, const char *v)
+{
+  size_t len = strlen (v);
+
+  if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING)
+    /* UPPER stropping.  */
+    return strncmp (u, v, len) == 0 && !ISUPPER (u[len]);
+  else
+    /* SUPPER stropping.  */
+    return (strlen (u) >= len
+	    && ISLOWER (u[0])
+	    && strneq (u, v, len) == 0
+	    && !ISALPHA (u[len])
+	    && !ISDIGIT (u[len]));
+}
+
+/* Skip a string denotation.
+
+   This function returns true if the end of the string denotation is found.
+   Returns false otherwise.  */
+
+static bool
+skip_string (LINE_T **top, char **ch)
+{
+  LINE_T *u = *top;
+  char *v = *ch;
+  v++;
+  while (u != NO_LINE)
+    {
+      while (v[0] != NULL_CHAR)
+	{
+	  if (v[0] == QUOTE_CHAR && v[1] != QUOTE_CHAR)
+	    {
+	      *top = u;
+	      *ch = &v[1];
+	      return true;
+	    }
+	  else if (v[0] == QUOTE_CHAR && v[1] == QUOTE_CHAR)
+	    {
+	      v += 2;
+	    }
+	  else
+	    {
+	      v++;
+	    }
+	}
+      FORWARD (u);
+      if (u != NO_LINE) {
+	v = &(STRING (u)[0]);
+      } else {
+	v = NO_TEXT;
+      }
+    }
+  return false;
+}
+
+/* Skip a comment.
+
+   This function returns true if the end of the comment is found.  Returns
+   false otherwise.  */
+
+static bool
+skip_comment (LINE_T **top, char **ch, int delim)
+{
+  LINE_T *u = *top;
+  char *v = *ch;
+  int nesting_level = 1;
+  v++;
+  while (u != NO_LINE)
+    {
+      while (v[0] != NULL_CHAR)
+	{
+	  LINE_T *l = u;
+	  char *c = v;
+
+	  if (v[0] == QUOTE_CHAR && skip_string (&l, &c)
+	      && (delim == BOLD_COMMENT_BEGIN_SYMBOL || delim == BRIEF_COMMENT_BEGIN_SYMBOL))
+	    {
+	      u = l;
+	      v = c;
+	    }
+	  else if (is_bold (v, "COMMENT") && delim == BOLD_COMMENT_SYMBOL)
+	    {
+	      *top = u;
+	      *ch = &v[1];
+	      return true;
+	    }
+	  else if (is_bold (v, "CO") && delim == STYLE_I_COMMENT_SYMBOL)
+	    {
+	      *top = u;
+	      *ch = &v[1];
+	      return true;
+	    }
+	  else if (v[0] == '#' && delim == STYLE_II_COMMENT_SYMBOL)
+	    {
+	      *top = u;
+	      *ch = &v[1];
+	      return true;
+	    }
+	  else if (is_bold (v, "ETON") && delim == BOLD_COMMENT_BEGIN_SYMBOL)
+	    {
+	      gcc_assert (nesting_level > 0);
+	      nesting_level -= 1;
+	      if (nesting_level == 0)
+		{
+		  *top = u;
+		  *ch = &v[1];
+		  return true;
+		}
+	    }
+	  else if (v[0] == '}' && delim == BRIEF_COMMENT_BEGIN_SYMBOL)
+	    {
+	      gcc_assert (nesting_level > 0);
+	      nesting_level -= 1;
+	      if (nesting_level == 0)
+		{
+		  *top = u;
+		  *ch = &v[1];
+		  return true;
+		}
+	    }
+	  else
+	    {
+	      if ((is_bold (v, "NOTE") && delim == BOLD_COMMENT_BEGIN_SYMBOL)
+		  || (v[0] == '{' && delim == BRIEF_COMMENT_BEGIN_SYMBOL))
+		{
+		  nesting_level += 1;
+		}
+
+	      v++;
+	    }
+	}
+      FORWARD (u);
+      if (u != NO_LINE)
+	v = &(STRING (u)[0]);
+      else
+	v = NO_TEXT;
+    }
+
+  return false;
+}
+
+/* Skip rest of pragmat.
+
+   This function returns true if the end of the pragmat is found, false
+   otherwise.  */
+
+static bool
+skip_pragmat (LINE_T **top, char **ch, int delim, bool whitespace)
+{
+  LINE_T *u = *top;
+  char *v = *ch;
+  while (u != NO_LINE)
+    {
+      while (v[0] != NULL_CHAR)
+	{
+	  if (is_bold (v, "PRAGMAT") && delim == BOLD_PRAGMAT_SYMBOL)
+	    {
+	      *top = u;
+	      *ch = &v[1];
+	      return true;
+	    }
+	  else if (is_bold (v, "PR") && delim == STYLE_I_PRAGMAT_SYMBOL)
+	    {
+	      *top = u;
+	      *ch = &v[1];
+	      return true;
+	    }
+	  else
+	    {
+	      if (whitespace && !ISSPACE (v[0]) && v[0] != NEWLINE_CHAR)
+		{
+		  SCAN_ERROR (true, u, v, "error in pragment");
+		}
+	      else if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING && ISUPPER (v[0]))
+		{
+		  /* Skip a bold word as you may trigger on REPR, for
+		     instance.  */
+		  while (ISUPPER (v[0]))
+		    v++;
+		}
+	      else if (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING && ISLOWER (v[0]))
+		{
+		  /* Skip a tag as you may trigger on expr, for instance.  */
+		  while (ISLOWER (v[0]) || ISDIGIT (v[0]) || v[0] == '_')
+		    v++;
+		}
+	      else
+		{
+		  v++;
+		}
+	    }
+	}
+
+      FORWARD (u);
+      if (u != NO_LINE)
+	v = &(STRING (u)[0]);
+      else
+	v = NO_TEXT;
+    }
+
+  return false;
+}
+
+/* Return pointer to next token within pragmat.  */
+
+static char *
+get_pragmat_item (LINE_T **top, char **ch)
+{
+  LINE_T *u = *top;
+  char *v = *ch;
+  while (u != NO_LINE)
+    {
+      while (v[0] != NULL_CHAR)
+	{
+	  if (!ISSPACE (v[0]) && v[0] != NEWLINE_CHAR)
+	    {
+	      *top = u;
+	      *ch = v;
+	      return v;
+	    }
+	  else
+	    {
+	      v++;
+	    }
+	}
+      FORWARD (u);
+      if (u != NO_LINE)
+	v = &(STRING (u)[0]);
+      else
+	v = NO_TEXT;
+  }
+
+  return NO_TEXT;
+}
+
+/* Scan for the next pragmat and yield the first item within it.  */
+
+static char *
+next_preprocessor_item (LINE_T **top, char **ch, int *delim)
+{
+  LINE_T *u = *top;
+  char *v = *ch;
+  *delim = 0;
+  while (u != NO_LINE)
+    {
+      while (v[0] != NULL_CHAR)
+	{
+	  LINE_T *start_l = u;
+	  char *start_c = v;
+
+	  if (v[0] == QUOTE_CHAR)
+	    {
+	      /* Skip string denotation.  */
+	      SCAN_ERROR (!skip_string (&u, &v), start_l, start_c,
+			  "unterminated string");
+	    }
+	  else if (a68_find_keyword (A68 (top_keyword), "COMMENT") != NO_KEYWORD
+		   && is_bold (v, "COMMENT"))
+	    {
+	      /* Skip comment.  */
+	      SCAN_ERROR (!skip_comment (&u, &v, BOLD_COMMENT_SYMBOL), start_l, start_c,
+			  "unterminated comment");
+	    }
+	  else if (a68_find_keyword (A68 (top_keyword), "CO") != NO_KEYWORD
+		   && is_bold (v, "CO"))
+	    {
+	      /* skip comment.  */
+	      SCAN_ERROR (!skip_comment (&u, &v, STYLE_I_COMMENT_SYMBOL), start_l, start_c,
+			  "unterminated comment");
+	    }
+	  else if (a68_find_keyword (A68 (top_keyword), "#") != NO_KEYWORD
+		   && v[0] == '#')
+	    {
+	      SCAN_ERROR (!skip_comment (&u, &v, STYLE_II_COMMENT_SYMBOL), start_l, start_c,
+			  "unterminated comment");
+	    }
+	  else if (a68_find_keyword (A68 (top_keyword), "NOTE") != NO_KEYWORD
+		   && is_bold (v, "NOTE"))
+	    {
+	      SCAN_ERROR (!skip_comment (&u, &v, BOLD_COMMENT_BEGIN_SYMBOL), start_l, start_c,
+			  "unterminated comment");
+	    }
+	  else if (a68_find_keyword (A68 (top_keyword), "{") != NO_KEYWORD
+		   && v[0] == '{')
+	    {
+	      SCAN_ERROR (!skip_comment (&u, &v, BRIEF_COMMENT_BEGIN_SYMBOL), start_l, start_c,
+			  "unterminated comment");
+	    }
+	  else if (is_bold (v, "PRAGMAT") || is_bold (v, "PR"))
+	    {
+	      /* We caught a PRAGMAT.  */
+	      char *item;
+	      if (is_bold (v, "PRAGMAT"))
+		{
+		  *delim = BOLD_PRAGMAT_SYMBOL;
+		  v = &v[strlen ("PRAGMAT")];
+		}
+	      else if (is_bold (v, "PR"))
+		{
+		  *delim = STYLE_I_PRAGMAT_SYMBOL;
+		  v = &v[strlen ("PR")];
+		}
+	      item = get_pragmat_item (&u, &v);
+	      SCAN_ERROR (item == NO_TEXT, start_l, start_c,
+			  "unterminated pragmat");
+
+	      if (streq (item, "INCLUDE") == 0)
+		{
+		  /* Item "INCLUDE" includes a file.  */
+		  *top = u;
+		  *ch = v;
+		  return item;
+		}
+	      else
+		{
+		  /* Unrecognised item - probably options handled later by the
+		     tokeniser.  */
+		  SCAN_ERROR (!skip_pragmat (&u, &v, *delim, false), start_l, start_c,
+			      "unterminated pragmat");
+		}
+	    }
+	  else if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING && ISUPPER (v[0]))
+	    {
+	      /* Skip a bold word as you may trigger on REPR, for instance.  */
+	      while (ISUPPER (v[0]))
+		v++;
+	    }
+	  else if (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING && ISLOWER (v[0]))
+	    {
+	      /* Skip a tag as you may trigger on expr, for instance.  */
+	      while (ISLOWER (v[0]) || ISDIGIT (v[0]) || v[0] == '_')
+		v++;
+	    }
+	  else
+	    {
+	      v++;
+	    }
+	}
+
+      FORWARD (u);
+      if (u != NO_LINE)
+	v = &(STRING (u)[0]);
+      else
+	v = NO_TEXT;
+    }
+
+  *top = u;
+  *ch = v;
+  return NO_TEXT;
+}
+
+/* Concatenate the two paths P1 and P2.  */
+
+static char *
+a68_relpath (const char *p1, const char *p2, const char *fn)
+{
+#if defined(__GNU__)
+  /* The Hurd doesn't define PATH_MAX.  */
+# define PATH_MAX 4096
+#endif
+
+  char q[PATH_MAX + 1];
+  a68_bufcpy (q, p1, PATH_MAX);
+  a68_bufcat (q, "/", PATH_MAX);
+  a68_bufcat (q, p2, PATH_MAX);
+  a68_bufcat (q, "/", PATH_MAX);
+  a68_bufcat (q, fn, PATH_MAX);
+  /* Home directory shortcut ~ is a shell extension.  */
+  if (strchr (q, '~') != NO_TEXT) {
+    return NO_TEXT;
+  }
+  char *r = (char *) xmalloc (PATH_MAX + 1);
+  gcc_assert (r != NULL);
+  /*  Error handling in the caller!  */
+  errno = 0;
+  r = lrealpath (q);
+  return r;
+}
+
+/* Return true if we can open the file for reading.  False otherwise.  */
+
+static bool
+file_read_p (const char *filename)
+{
+  return access (filename, R_OK) == 0 ? true : false;
+}
+
+/* Find a file to include into the current source being parsed.  Search the file
+   system for FILENAME and return a string with the file path.  If the file is
+   not found, return NULL.
+
+   When FILENAME is not an absolute path we first try to find it relative to the
+   current file being parsed (CURFILE). Failing to do that we use the search
+   paths provided by the -I option.  */
+
+static char *
+find_include_file (const char *curfile, const char *filename)
+{
+  char *filepath = NO_TEXT;
+  char *tmpfpath = NO_TEXT;
+  char *fnbdir = ldirname (filename);
+  const char *incfile = lbasename (filename);
+
+  if (fnbdir == NULL || incfile == NULL)
+    gcc_unreachable ();
+
+  if (!IS_ABSOLUTE_PATH (filename))
+    {
+      char *sourcedir = ldirname (curfile);
+
+      if (sourcedir == NULL || fnbdir == NULL)
+	gcc_unreachable ();
+
+      if (strlen (sourcedir) == 0 && strlen (fnbdir) == 0)
+	{
+	  free (sourcedir);
+	  sourcedir = (char *) xmalloc (2);
+	  a68_bufcpy (sourcedir, ".", 2);
+	}
+
+      tmpfpath = a68_relpath (sourcedir, fnbdir, incfile);
+      if (file_read_p (tmpfpath))
+	{
+	  filepath = tmpfpath;
+	  goto cleanup;
+	}
+
+      for (unsigned ix = 0; ix != vec_safe_length (A68_INCLUDE_PATHS); ix++)
+	{
+	  const char *include_dir = (*(A68_INCLUDE_PATHS))[ix];
+	  tmpfpath = a68_relpath (include_dir, fnbdir, incfile);
+	  if (!IS_ABSOLUTE_PATH (tmpfpath))
+	    tmpfpath = a68_relpath (sourcedir, fnbdir, incfile);
+	  if (file_read_p (tmpfpath))
+	    {
+	      filepath = tmpfpath;
+	      goto cleanup;
+	    }
+	}
+
+    cleanup:
+      free (sourcedir);
+      goto end;
+    }
+  else
+    {
+      size_t fnwid = (int) strlen (filename) + 1;
+      tmpfpath = (char *) xmalloc ((size_t) fnwid);
+      a68_bufcpy (tmpfpath, filename, fnwid);
+
+      if (file_read_p (tmpfpath))
+	{
+	  filepath = tmpfpath;
+	  goto end;
+	}
+    }
+
+end:
+  free (fnbdir);
+  return filepath;
+}
+
+/* Include files.
+   This function handles the INCLUDE pragmat in the source file.  */
+
+static void
+include_files (LINE_T *top)
+{
+  /* syntax: PR include "filename" PR
+
+     The file gets inserted before the line containing the pragmat. In this way
+     correct line numbers are preserved which helps diagnostics. A file that
+     has been included will not be included a second time - it will be ignored.
+     A rigorous fail-safe, but there is no mechanism to prevent recursive
+     includes in A68 source code. User reports do not indicate sophisticated
+     use of INCLUDE, so this is fine for now.
+  */
+
+  bool make_pass = true;
+  while (make_pass)
+    {
+      LINE_T *s, *t, *u = top;
+      char *v = &(STRING (u)[0]);
+      make_pass = false;
+      errno = 0;
+      while (u != NO_LINE)
+	{
+	  int pr_lim;
+	  char *item = next_preprocessor_item (&u, &v, &pr_lim);
+	  LINE_T *start_l = u;
+	  char *start_c = v;
+	  /* Search for PR include "filename" PR.  */
+	  if (item != NO_TEXT && streq (item, "INCLUDE") == 0)
+	    {
+	      FILE *fp;
+	      int fd;
+	      size_t fsize, k;
+	      int n, linum, bytes_read;
+	      char *fbuf, delim;
+	      BUFFER fnb;
+	      char *fn = NO_TEXT;
+	      /* Skip to filename.  */
+	      while (ISALPHA (v[0]))
+		v++;
+	      while (ISSPACE (v[0]))
+		v++;
+	      /* Scan quoted filename.  */
+	      SCAN_ERROR ((v[0] != QUOTE_CHAR && v[0] != '\''), start_l, start_c,
+			  "incorrect filename");
+	      delim = (v++)[0];
+	      n = 0;
+	      fnb[0] = NULL_CHAR;
+	      /* Scan Algol 68 string (note: "" denotes a ", while in C it
+		 concatenates).  */
+	      do
+		{
+		  SCAN_ERROR (EOL (v[0]), start_l, start_c,
+			      "incorrect filename");
+		  SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c,
+			      "incorrect filename");
+		  if (v[0] == delim)
+		    {
+		      while (v[0] == delim && v[1] == delim)
+			{
+			  SCAN_ERROR (n == BUFFER_SIZE - 1, start_l, start_c,
+				      "incorrect filename");
+			  fnb[n++] = delim;
+			  fnb[n] = NULL_CHAR;
+			  v += 2;
+			}
+		    }
+		  else if (ISPRINT (v[0]))
+		    {
+		      fnb[n++] = *(v++);
+		      fnb[n] = NULL_CHAR;
+		    }
+		  else
+		    {
+		      SCAN_ERROR (true, start_l, start_c,
+				  "incorrect filename");
+		    }
+		}
+	      while (v[0] != delim);
+
+	      /* Insist that the pragmat is closed properly.  */
+	      v = &v[1];
+	      SCAN_ERROR (!skip_pragmat (&u, &v, pr_lim, true), start_l, start_c,
+			  "unterminated pragmat");
+	      SCAN_ERROR (n == 0, start_l, start_c,
+			  "incorrect filename");
+
+	      char *sourcefile = NO_TEXT;
+	      if (FILENAME (u) != NO_TEXT)
+		{
+		  sourcefile = xstrdup (FILENAME (u));
+		}
+	      else
+		{
+		  sourcefile = (char *) xmalloc (2);
+		  a68_bufcpy (sourcefile, ".", 1);
+		}
+	      fn = find_include_file (sourcefile, fnb);
+	      free (sourcefile);
+
+	      /* Do not check errno, since errno may be undefined here
+		 after a successful call.  */
+	      if (fn != NO_TEXT)
+		a68_bufcpy (fnb, fn, BUFFER_SIZE);
+	      else
+		{
+		  SCAN_ERROR (true, start_l, start_c,
+			      "included file not found");
+		}
+	      size_t fnwid = (int) strlen (fnb) + 1;
+	      fn = (char *) xmalloc ((size_t) fnwid);
+	      a68_bufcpy (fn, fnb, fnwid);
+
+	      /* Ignore the file when included more than once.  */
+	      for (t = top; t != NO_LINE; t = NEXT (t))
+		{
+		  if (strcmp (FILENAME (t), fn) == 0)
+		    goto search_next_pragmat;
+		}
+	      t = NO_LINE;
+
+	      /* Access the file.  */
+	      errno = 0;
+	      fp = fopen (fn, "r");
+	      SCAN_ERROR (fp == NULL, start_l, start_c,
+			  "error opening included file");
+	      fd = fileno (fp);
+	      errno = 0;
+	      off_t off = lseek (fd, 0, SEEK_END);
+	      gcc_assert (off >= 0);
+	      fsize = (size_t) off;
+	      SCAN_ERROR (errno != 0, start_l, start_c,
+			  "error while reading file");
+	      fbuf = (char *) xmalloc (8 + fsize);
+	      errno = 0;
+	      if (lseek (fd, 0, SEEK_SET) < 0)
+		gcc_unreachable ();
+	      SCAN_ERROR (errno != 0, start_l, start_c,
+			  "error while reading file");
+	      errno = 0;
+	      bytes_read = (int) io_read (fp, fbuf, (size_t) fsize);
+	      SCAN_ERROR (errno != 0 || (size_t) bytes_read != fsize, start_l, start_c,
+			  "error while reading file");
+
+	      /* Buffer still usable?.  */
+	      if (fsize > A68_PARSER (max_scan_buf_length))
+		{
+		  A68_PARSER (max_scan_buf_length) = fsize;
+		  A68_PARSER (scan_buf) = (char *) xmalloc (8 + A68_PARSER (max_scan_buf_length));
+		}
+
+	      /* Link all lines into the list.  */
+	      linum = 1;
+	      s = u;
+	      t = PREVIOUS (u);
+	      k = 0;
+	      if (fsize == 0)
+		{
+		  /* If file is empty, insert single empty line.  */
+		  A68_PARSER (scan_buf)[0] = NEWLINE_CHAR;
+		  A68_PARSER (scan_buf)[1] = NULL_CHAR;
+		  append_source_line (A68_PARSER (scan_buf), &t, &linum, fn);
+		}
+	      else
+		{
+		  while (k < fsize)
+		    {
+		      n = 0;
+		      A68_PARSER (scan_buf)[0] = NULL_CHAR;
+		      while (k < fsize && fbuf[k] != NEWLINE_CHAR)
+			{
+			  SCAN_ERROR ((ISCNTRL (fbuf[k]) && !ISSPACE (fbuf[k]))
+				      || fbuf[k] == STOP_CHAR,
+				      start_l, start_c,
+				      "invalid characters in included file");
+			  A68_PARSER (scan_buf)[n++] = fbuf[k++];
+			  A68_PARSER (scan_buf)[n] = NULL_CHAR;
+			}
+		      A68_PARSER (scan_buf)[n++] = NEWLINE_CHAR;
+		      A68_PARSER (scan_buf)[n] = NULL_CHAR;
+		      if (k < fsize)
+			k++;
+		      append_source_line (A68_PARSER (scan_buf), &t, &linum, fn);
+		    }
+		}
+
+	      /* Conclude and go find another include directive, if any.  */
+	      NEXT (t) = s;
+	      PREVIOUS (s) = t;
+	      concatenate_lines (top);
+	      if (fclose (fp) != 0)
+		gcc_unreachable ();
+	      make_pass = true;
+	    }
+	search_next_pragmat:
+	  { (void) 0; };
+	}
+    }
+}
+
+/* Handle a pragment (pragmat or comment).  */
+
+static char *
+pragment (int type, LINE_T **ref_l, char **ref_c)
+{
+#define INIT_BUFFER					\
+  do							\
+    {							\
+      chars_in_buf = 0;					\
+      A68_PARSER (scan_buf)[chars_in_buf] = '\0';	\
+    }							\
+  while (0)
+
+#define ADD_ONE_CHAR(CH)						\
+  do									\
+    {									\
+      A68_PARSER (scan_buf)[chars_in_buf ++] = (CH);			\
+      A68_PARSER (scan_buf)[chars_in_buf] = '\0';			\
+    }									\
+  while (0)
+
+  const char *term_s = NO_TEXT;
+  const char *beg_s = NO_TEXT;
+  char c = **ref_c, *start_c = *ref_c;
+  char *z = NO_TEXT;
+  LINE_T *start_l = *ref_l;
+  int beg_s_length, term_s_length, chars_in_buf;
+  bool stop, pragmat = false;
+
+  /* Set terminator to look for.  */
+  if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING)
+    {
+      if (type == STYLE_I_COMMENT_SYMBOL)
+	term_s = "CO";
+      else if (type == STYLE_II_COMMENT_SYMBOL)
+	term_s = "#";
+      else if (type == BOLD_COMMENT_SYMBOL)
+	term_s = "COMMENT";
+      else if (type == BOLD_COMMENT_BEGIN_SYMBOL)
+	{
+	  beg_s = "NOTE";
+	  term_s = "ETON";
+	}
+      else if (type == BRIEF_COMMENT_BEGIN_SYMBOL)
+	{
+	  beg_s = "{";
+	  term_s = "}";
+	}
+      else if (type == STYLE_I_PRAGMAT_SYMBOL)
+	{
+	  term_s = "PR";
+	  pragmat = true;
+	}
+      else if (type == BOLD_PRAGMAT_SYMBOL)
+	{
+	  term_s = "PRAGMAT";
+	  pragmat = true;
+	}
+    }
+  else
+    {
+      /* SUPPER stropping.  */
+      if (type == STYLE_I_COMMENT_SYMBOL)
+	term_s = "co";
+      else if (type == STYLE_II_COMMENT_SYMBOL)
+	term_s = "#";
+      else if (type == BOLD_COMMENT_SYMBOL)
+	term_s = "comment";
+      else if (type == BOLD_COMMENT_BEGIN_SYMBOL)
+	{
+	  beg_s = "note";
+	  term_s = "eton";
+	}
+      else if (type == BRIEF_COMMENT_BEGIN_SYMBOL)
+	{
+	  beg_s = "{";
+	  term_s = "}";
+	}
+      else if (type == STYLE_I_PRAGMAT_SYMBOL)
+	{
+	  term_s = "pr";
+	  pragmat = true;
+	}
+      else if (type == BOLD_PRAGMAT_SYMBOL)
+	{
+	  term_s = "pragmat";
+	  pragmat = true;
+	}
+    }
+
+  beg_s_length = (beg_s != NO_TEXT ? (int) strlen (beg_s) : 0);
+  term_s_length = (int) strlen (term_s);
+
+  /* Scan for terminator.  */
+  bool nestable_comment = (beg_s != NO_TEXT);
+  int nesting_level = 1;
+  INIT_BUFFER;
+  stop = false;
+  while (stop == false)
+    {
+      SCAN_ERROR (c == STOP_CHAR, start_l, start_c,
+		  "unterminated pragment");
+
+      /* A ".." or '..' delimited string in a PRAGMAT, or
+	 a ".." in a nestable comment.  */
+      if ((pragmat && (c == QUOTE_CHAR || c == '\''))
+	  || (nestable_comment && c == QUOTE_CHAR))
+	{
+	  char delim = c;
+	  bool eos = false;
+	  ADD_ONE_CHAR (c);
+	  c = next_char (ref_l, ref_c, false);
+	  while (!eos)
+	    {
+	      SCAN_ERROR (EOL (c), start_l, start_c,
+			  "string within pragment exceeds end of line");
+
+	      if (c == delim)
+		{
+		  ADD_ONE_CHAR (delim);
+		  save_state (*ref_l, *ref_c, c);
+		  c = next_char (ref_l, ref_c, false);
+		  if (c == delim)
+		    c = next_char (ref_l, ref_c, false);
+		  else
+		    {
+		      restore_state (ref_l, ref_c, &c);
+		      eos = true;
+		    }
+		}
+	      else if (ISPRINT (c))
+		{
+		  ADD_ONE_CHAR (c);
+		  c = next_char (ref_l, ref_c, false);
+		}
+	      else
+		unworthy (start_l, start_c, c);
+	    }
+	}
+      else if (EOL (c))
+	ADD_ONE_CHAR (NEWLINE_CHAR);
+      else if (ISPRINT (c) || ISSPACE (c))
+	ADD_ONE_CHAR (c);
+
+      if (nestable_comment && chars_in_buf >= beg_s_length)
+	{
+	  /* If we find another instance of the nestable begin mark, bump the
+	     nesting level and continue scanning.  */
+	  if (strcmp (beg_s,
+		      &(A68_PARSER (scan_buf)[chars_in_buf - beg_s_length])) == 0)
+	    {
+	      nesting_level += 1;
+	      goto nextchar;
+	    }
+	}
+
+      if (chars_in_buf >= term_s_length)
+	{
+	  /* Check whether we encountered the terminator.  Mind nesting if
+	     necessary.  */
+	  if (strcmp (term_s,
+		      &(A68_PARSER (scan_buf)[chars_in_buf - term_s_length])) == 0)
+	    {
+	      if (nestable_comment)
+		{
+		  gcc_assert (nesting_level > 0);
+		  nesting_level -= 1;
+		  stop = (nesting_level == 0);
+		}
+	      else
+		stop = true;
+	    }
+	}
+
+    nextchar:
+      c = next_char (ref_l, ref_c, false);
+    }
+
+  A68_PARSER (scan_buf)[chars_in_buf - term_s_length] = '\0';
+  z = a68_new_string (term_s, A68_PARSER (scan_buf), term_s, NO_TEXT);
+  return z;
+#undef ADD_ONE_CHAR
+#undef INIT_BUFFER
+}
+
+/* Whether input shows exponent character.  */
+
+static bool
+is_exp_char (LINE_T **ref_l, char **ref_s, char *ch)
+{
+  bool ret = false;
+
+  char exp_syms[3];
+
+  /* Note that this works for both UPPER and SUPPER stropping regimes.  */
+  exp_syms[0] = EXPONENT_CHAR;
+  exp_syms[1] = TOUPPER (EXPONENT_CHAR);
+  exp_syms[2] = '\0';
+
+  save_state (*ref_l, *ref_s, *ch);
+  if (strchr (exp_syms, *ch) != NO_TEXT)
+    {
+      *ch = next_char (ref_l, ref_s, true);
+      ret = (strchr ("+-0123456789", *ch) != NO_TEXT);
+    }
+  restore_state (ref_l, ref_s, ch);
+  return ret;
+}
+
+/* Whether input shows radix character.  */
+
+static bool
+is_radix_char (LINE_T **ref_l, char **ref_s, char *ch)
+{
+  bool ret = false;
+
+  save_state (*ref_l, *ref_s, *ch);
+  /* Note that this works for both UPPER and SUPPER stropping regimes.  */
+  if (*ch == RADIX_CHAR)
+    {
+      *ch = next_char (ref_l, ref_s, true);
+      ret = (strchr ("0123456789abcdef", *ch) != NO_TEXT);
+    }
+  restore_state (ref_l, ref_s, ch);
+  return ret;
+}
+
+/* Whether input shows decimal point.  */
+
+static bool
+is_decimal_point (LINE_T **ref_l, char **ref_s, char *ch)
+{
+  bool ret = false;
+
+  save_state (*ref_l, *ref_s, *ch);
+  if (*ch == POINT_CHAR)
+    {
+      char exp_syms[3];
+
+      /* Note that this works for both UPPER and SUPPER stropping regimes.  */
+      exp_syms[0] = EXPONENT_CHAR;
+      exp_syms[1] = TOUPPER (EXPONENT_CHAR);
+      exp_syms[2] = '\0';
+
+      *ch = next_char (ref_l, ref_s, true);
+      if (strchr (exp_syms, *ch) != NO_TEXT)
+	{
+	  *ch = next_char (ref_l, ref_s, true);
+	  ret = (strchr ("+-0123456789", *ch) != NO_TEXT);
+	}
+      else
+	ret = (strchr ("0123456789", *ch) != NO_TEXT);
+    }
+  restore_state (ref_l, ref_s, ch);
+  return ret;
+}
+
+/* Attribute for format item.  */
+
+static enum a68_attribute
+get_format_item (char ch)
+{
+  switch (TOLOWER (ch))
+    {
+    case 'a':
+      return FORMAT_ITEM_A;
+    case 'b':
+      return FORMAT_ITEM_B;
+    case 'c':
+      return FORMAT_ITEM_C;
+    case 'd':
+      return FORMAT_ITEM_D;
+    case 'e':
+      return FORMAT_ITEM_E;
+    case 'f':
+      return FORMAT_ITEM_F;
+    case 'g':
+      return FORMAT_ITEM_G;
+    case 'h':
+      return FORMAT_ITEM_H;
+    case 'i':
+      return FORMAT_ITEM_I;
+    case 'j':
+      return FORMAT_ITEM_J;
+    case 'k':
+      return FORMAT_ITEM_K;
+    case 'l':
+    case '/':
+      return FORMAT_ITEM_L;
+    case 'm':
+      return FORMAT_ITEM_M;
+    case 'n':
+      return FORMAT_ITEM_N;
+    case 'o':
+      return FORMAT_ITEM_O;
+    case 'p':
+      return FORMAT_ITEM_P;
+    case 'q':
+      return FORMAT_ITEM_Q;
+    case 'r':
+      return FORMAT_ITEM_R;
+    case 's':
+      return FORMAT_ITEM_S;
+    case 't':
+      return FORMAT_ITEM_T;
+    case 'u':
+      return FORMAT_ITEM_U;
+    case 'v':
+      return FORMAT_ITEM_V;
+    case 'w':
+      return FORMAT_ITEM_W;
+    case 'x':
+      return FORMAT_ITEM_X;
+    case 'y':
+      return FORMAT_ITEM_Y;
+    case 'z':
+      return FORMAT_ITEM_Z;
+    case '+':
+      return FORMAT_ITEM_PLUS;
+    case '-':
+      return FORMAT_ITEM_MINUS;
+    case POINT_CHAR:
+      return FORMAT_ITEM_POINT;
+    case '%':
+      return FORMAT_ITEM_ESCAPE;
+    default:
+      return STOP;
+    }
+}
+
+/* Get next token from internal copy of source file.
+
+   The kind of token is set via the passed pointer ATTR.
+   The contents of token is set in the scan_buf via SYM.
+
+   The recognized tokens are, by reported ATTR:
+
+   <unset>
+     End of file.
+   FORMAT_ITEM_*
+     Item in a format.
+   STATIC_REPLICATOR
+     INT denotation for a static replicator in a format.
+   BOLD_TAG
+     Bold tag.
+   IDENTIFIER
+     A "lower case" identifier.
+   IDENTIFIER_WITH_UNDERSCORES
+     A "lower case" identifier whose's at least one taggle
+     was found adjacent to an underscore.
+   REAL_DENOTATION
+     A REAL denotation.
+   POINT_SYMBOL
+     .
+   BITS_DENOTATION
+     A BITS denotation like 16rffff
+   INT_DENOTATION
+     An INT denotation.
+   ROW_CHAR_DENOTATION
+     A STRING denotation.
+   LITERAL
+     A literal denotation in a format.
+   STOP
+     Single-character symbols #$()[]{},;@|:
+     := /= :=: :/=:
+     The character is placed in SYM.
+   EQUALS_SYMBOL
+     The equality symbol.
+   OPERATOR
+     A predefined operator.
+*/
+
+static void
+get_next_token (bool in_format,
+		LINE_T **ref_l, char **ref_s,
+		LINE_T **start_l, char **start_c, enum a68_attribute *att)
+{
+  char c = **ref_s;
+  char *sym = A68_PARSER (scan_buf);
+
+  sym[0] = '\0';
+  get_good_char (&c, ref_l, ref_s);
+  *start_l = *ref_l;
+  *start_c = *ref_s;
+  if (c == STOP_CHAR)
+    {
+      /* We are at EOF.  */
+      (sym++)[0] = STOP_CHAR;
+      sym[0] = '\0';
+      return;
+    }
+
+  if (in_format)
+    {
+      /* In a format.  */
+      const char *format_items = "/%\\+-.abcdefghijklmnopqrstuvwxyz";
+      if (strchr (format_items, c) != NO_TEXT)
+	{
+	  /* General format items.  */
+	  (sym++)[0] = c;
+	  sym[0] = NULL_CHAR;
+	  *att = get_format_item (c);
+	  (void) next_char (ref_l, ref_s, false);
+	  return;
+	}
+      if (ISDIGIT (c))
+	{
+	  /* INT denotation for static replicator.  */
+	  SCAN_DIGITS (c);
+	  sym[0] = NULL_CHAR;
+	  *att = STATIC_REPLICATOR;
+	  return;
+	}
+    }
+
+  if (ISUPPER (c))
+    {
+      /* Bold taggles are enabled only in gnu68.  */
+      bool allow_one_under = !OPTION_STRICT (&A68_JOB);
+
+      if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING)
+	{
+	  /* In UPPER stropping a bold tag is an upper case word.  */
+	  while (ISUPPER (c))
+	    {
+	      (sym++)[0] = c;
+	      c = next_char (ref_l, ref_s, false, allow_one_under);
+	    }
+	  sym[0] = '\0';
+	  *att = BOLD_TAG;
+	}
+      else
+	{
+	  /* In SUPPER stropping a bold tag is a capitalized word that may
+	     contain letters and digits.  */
+	  while (ISALPHA (c) || ISDIGIT (c))
+	    {
+	      (sym++)[0] = c;
+	      c = next_char (ref_l, ref_s, false, allow_one_under);
+	    }
+	  sym[0] = '\0';
+	  *att = BOLD_TAG;
+	}
+    }
+  else if (ISLOWER (c))
+    {
+      /* In both UPPER and SUPPER stropping regimes a tag is a lower case word
+	 which may contain letters and digits.
+
+	 In SUPPER stropping, however, it is not allowed to have blanks
+	 separating the taggles within tags.  */
+
+      bool allow_one_under = true;
+      bool found_under = false;
+      bool allow_typo = OPTION_STROPPING (&A68_JOB) != SUPPER_STROPPING;
+
+      /* Lower case word - identifier.  */
+      while (ISLOWER (c) || ISDIGIT (c))
+	{
+	  (sym++)[0] = c;
+	  c = next_char (ref_l, ref_s, allow_typo, allow_one_under,
+			 &found_under);
+	}
+
+      sym[0] = '\0';
+      *att = found_under ? IDENTIFIER_WITH_UNDERSCORES : IDENTIFIER;
+    }
+  else if (c == POINT_CHAR)
+    {
+      /* Begins with a point symbol - point, L REAL denotation.  */
+      if (is_decimal_point (ref_l, ref_s, &c))
+	{
+	  (sym++)[0] = '0';
+	  (sym++)[0] = POINT_CHAR;
+	  c = next_char (ref_l, ref_s, true);
+	  SCAN_DIGITS (c);
+	  if (is_exp_char (ref_l, ref_s, &c))
+	    SCAN_EXPONENT_PART (c);
+	  sym[0] = '\0';
+	  *att = REAL_DENOTATION;
+	}
+      else
+	{
+	  c = next_char (ref_l, ref_s, true);
+	  (sym++)[0] = POINT_CHAR;
+	  sym[0] = '\0';
+	  *att = POINT_SYMBOL;
+	}
+    }
+  else if (ISDIGIT (c))
+    {
+      /* Something that begins with a digit:
+	 L INT denotation, L REAL denotation.  */
+      SCAN_DIGITS (c);
+
+      if (is_decimal_point (ref_l, ref_s, &c))
+	{
+	  c = next_char (ref_l, ref_s, true);
+	  if (is_exp_char (ref_l, ref_s, &c))
+	    {
+	      (sym++)[0] = POINT_CHAR;
+	      (sym++)[0] = '0';
+	      SCAN_EXPONENT_PART (c);
+	      *att = REAL_DENOTATION;
+	    }
+	  else
+	    {
+	      (sym++)[0] = POINT_CHAR;
+	      SCAN_DIGITS (c);
+	      if (is_exp_char (ref_l, ref_s, &c))
+		SCAN_EXPONENT_PART (c);
+	      *att = REAL_DENOTATION;
+	    }
+	}
+      else if (is_exp_char (ref_l, ref_s, &c))
+	{
+	  SCAN_EXPONENT_PART (c);
+	  *att = REAL_DENOTATION;
+	}
+      else if (is_radix_char (ref_l, ref_s, &c))
+	{
+	  (sym++)[0] = c;
+	  c = next_char (ref_l, ref_s, true);
+	  /* This is valid for both UPPER and SUPPER stropping.  */
+	  while (ISDIGIT (c) || strchr ("abcdef", c) != NO_TEXT)
+	    {
+	      (sym++)[0] = c;
+	      c = next_char (ref_l, ref_s, true);
+	    }
+	  *att = BITS_DENOTATION;
+	}
+      else
+	{
+	  *att = INT_DENOTATION;
+	}
+      sym[0] = '\0';
+    }
+  else if (c == QUOTE_CHAR)
+    {
+      /* STRING denotation.  */
+      bool stop = false;
+
+      while (!stop)
+	{
+	  c = next_char (ref_l, ref_s, false);
+	  while (c != QUOTE_CHAR && c != STOP_CHAR)
+	    {
+	      if (c == APOSTROPHE_CHAR)
+		{
+		  (sym++)[0] = c;
+		  c = next_char (ref_l, ref_s, false);
+		  switch (c)
+		    {
+		    case APOSTROPHE_CHAR:
+		    case 'n':
+		    case 'f':
+		    case 'r':
+		    case 't':
+		      (sym++)[0] = c;
+		      break;
+		    case '(':
+		      {
+			unsigned int num_code_points = 0;
+
+			(sym++)[0] = c;
+			/* Process code points.  */
+			while (1)
+			  {
+			    /* Skip white spaces.  */
+			    while (1)
+			      {
+				c = next_char (ref_l, ref_s, false);
+				if (!ISSPACE (c))
+				  break;
+			      }
+
+			    /* See if we are done.  */
+			    if (c == ')')
+			      {
+				SCAN_ERROR (num_code_points == 0, *start_l, *ref_s,
+					    "expected at least one character point in string break");
+				(sym++)[0] = c;
+				break;
+			      }
+			    else if (c == 'u' || c == 'U')
+			      {
+				(sym++)[0] = c;
+				/* Process a code point.  */
+				char u = c;
+				int numdigits = (u == 'u' ? 4 : 8);
+				char *startpos = *ref_s;
+				int i = 0;
+				do
+				  {
+				    c = next_char (ref_l, ref_s, false);
+				    if (!(ISDIGIT (c)
+					  || ((c >= 'a') && (c <= 'f'))
+					  || ((c >= 'A') && (c <= 'F'))))
+				      {
+					SCAN_ERROR (true, *start_l, startpos,
+						    (u == 'u'
+						     ? "expected four hex digits in \
+string break character point"
+						     : "expected eight hex digits in \
+string break character point"));
+				      }
+				    (sym++)[0] = c;
+				    i += 1;
+				  }
+				while (i < numdigits);
+
+				/* Skip white spaces.  */
+				while (1)
+				  {
+				    c = next_char (ref_l, ref_s, false);
+				    if (!ISSPACE (c))
+				      break;
+				  }
+
+				/* Comma or end of list.  */
+				if (c == ')')
+				  {
+				    (sym++)[0] = c;
+				    break;
+				  }
+
+				SCAN_ERROR (c != ',', *start_l, *ref_s,
+					    "expected , or ) in string break");
+			      }
+			    else
+			      {
+				SCAN_ERROR (true, *start_l, *ref_s,
+					    "unterminated list of character codes");
+			      }
+			  }
+			break;
+		      }
+		    default:
+		      SCAN_ERROR (true, *start_l, *ref_s, "invalid string break sequence");
+		    }
+		}
+	      else
+		{
+		  SCAN_ERROR (EOL (c), *start_l, *start_c, "string exceeds end of line");
+		  (sym++)[0] = c;
+		}
+	      c = next_char (ref_l, ref_s, false);
+	    }
+	  SCAN_ERROR (*ref_l == NO_LINE, *start_l, *start_c, "unterminated string");
+	  c = next_char (ref_l, ref_s, false);
+	  if (c == QUOTE_CHAR)
+	    (sym++)[0] = QUOTE_CHAR;
+	  else
+	    stop = true;
+	}
+      sym[0] = '\0';
+      *att = (in_format ? LITERAL : ROW_CHAR_DENOTATION);
+    }
+  else if (strchr ("#$()[]{},;@", c) != NO_TEXT)
+    {
+      /* Single character symbols.  */
+      (sym++)[0] = c;
+      (void) next_char (ref_l, ref_s, false);
+      sym[0] = '\0';
+      *att = STOP;
+    }
+  else if (c == '|')
+    {
+      /* Bar.  */
+      (sym++)[0] = c;
+      c = next_char (ref_l, ref_s, false);
+      if (c == ':')
+	{
+	  (sym++)[0] = c;
+	  (void) next_char (ref_l, ref_s, false);
+	}
+      sym[0] = '\0';
+      *att = STOP;
+    }
+  else if (c == ':')
+    {
+      /* Colon, semicolon, IS, ISNT.  */
+      (sym++)[0] = c;
+      c = next_char (ref_l, ref_s, false);
+      if (c == '=')
+	{
+	  (sym++)[0] = c;
+	  if ((c = next_char (ref_l, ref_s, false)) == ':')
+	    {
+	      (sym++)[0] = c;
+	      c = next_char (ref_l, ref_s, false);
+	    }
+	}
+      else if (c == '/')
+	{
+	  (sym++)[0] = c;
+	  if ((c = next_char (ref_l, ref_s, false)) == '=')
+	    {
+	      (sym++)[0] = c;
+	      if ((c = next_char (ref_l, ref_s, false)) == ':')
+		{
+		  (sym++)[0] = c;
+		  c = next_char (ref_l, ref_s, false);
+		}
+	    }
+	}
+      else if (c == ':')
+	{
+	  (sym++)[0] = c;
+	  if ((c = next_char (ref_l, ref_s, false)) == '=')
+	    (sym++)[0] = c;
+	}
+
+      sym[0] = '\0';
+      *att = STOP;
+
+    }
+  else if (c == '=')
+    {
+      /* Operator starting with "=".  */
+      char *scanned = sym;
+      (sym++)[0] = c;
+      c = next_char (ref_l, ref_s, false);
+      if (strchr (NOMADS, c) != NO_TEXT)
+	{
+	  (sym++)[0] = c;
+	  c = next_char (ref_l, ref_s, false);
+	}
+      if (c == '=')
+	{
+	  (sym++)[0] = c;
+	  if (next_char (ref_l, ref_s, false) == ':')
+	    {
+	      (sym++)[0] = ':';
+	      c = next_char (ref_l, ref_s, false);
+	      if (strlen (sym) < 4 && c == '=')
+		{
+		  (sym++)[0] = '=';
+		  (void) next_char (ref_l, ref_s, false);
+		}
+	    }
+	}
+      else if (c == ':')
+	{
+	  (sym++)[0] = c;
+	  sym[0] = '\0';
+	  if (next_char (ref_l, ref_s, false) == '=')
+	    {
+	      (sym++)[0] = '=';
+	      (void) next_char (ref_l, ref_s, false);
+	    }
+	  else
+	    {
+	      SCAN_ERROR (!(strcmp (scanned, "=:") == 0 || strcmp (scanned, "==:") == 0),
+			  *start_l, *start_c, "invalid operator tag");
+	    }
+	}
+      sym[0] = '\0';
+      if (strcmp (scanned, "=") == 0)
+	*att = EQUALS_SYMBOL;
+      else
+	*att = OPERATOR;
+    }
+  else if (strchr (MONADS, c) != NO_TEXT || strchr (NOMADS, c) != NO_TEXT)
+    {
+      /* Operator.  */
+      char *scanned = sym;
+      (sym++)[0] = c;
+      c = next_char (ref_l, ref_s, false);
+      if (strchr (NOMADS, c) != NO_TEXT)
+	{
+	  (sym++)[0] = c;
+	  c = next_char (ref_l, ref_s, false);
+	}
+      if (c == '=')
+	{
+	  (sym++)[0] = c;
+	  if (next_char (ref_l, ref_s, false) == ':')
+	    {
+	      (sym++)[0] = ':';
+	      c = next_char (ref_l, ref_s, false);
+	      if (strlen (scanned) < 4 && c == '=')
+		{
+		  (sym++)[0] = '=';
+		  (void) next_char (ref_l, ref_s, false);
+		}
+	    }
+	}
+      else if (c == ':')
+	{
+	  (sym++)[0] = c;
+	  sym[0] = '\0';
+	  if (next_char (ref_l, ref_s, false) == '=')
+	    {
+	      (sym++)[0] = '=';
+	      sym[0] = '\0';
+	      (void) next_char (ref_l, ref_s, false);
+	    }
+	  else
+	    {
+	      SCAN_ERROR (strcmp (&(scanned[1]), "=:") != 0,
+			  *start_l, *start_c, "invalid operator tag");
+	    }
+	}
+      sym[0] = '\0';
+      *att = OPERATOR;
+    }
+  else
+    {
+      /* Afuuus ... strange characters!.  */
+      unworthy (*start_l, *start_c, (int) c);
+    }
+}
+
+/* Whether att opens an embedded clause.  */
+
+static bool
+open_nested_clause (int att)
+{
+  switch (att)
+    {
+    case OPEN_SYMBOL:
+    case BEGIN_SYMBOL:
+    case PAR_SYMBOL:
+    case IF_SYMBOL:
+    case CASE_SYMBOL:
+    case FOR_SYMBOL:
+    case FROM_SYMBOL:
+    case BY_SYMBOL:
+    case TO_SYMBOL:
+    case WHILE_SYMBOL:
+    case DO_SYMBOL:
+    case SUB_SYMBOL:
+      return true;
+    }
+  return false;
+}
+
+/* Whether att closes an embedded clause.  */
+
+static bool
+close_nested_clause (int att)
+{
+  switch (att)
+    {
+    case CLOSE_SYMBOL:
+    case END_SYMBOL:
+    case FI_SYMBOL:
+    case ESAC_SYMBOL:
+    case OD_SYMBOL:
+    case BUS_SYMBOL:
+      return true;
+    }
+  return false;
+}
+
+/* Cast a string to lower case.  */
+
+static void
+make_lower_case (char *p)
+{
+  for (; p != NO_TEXT && p[0] != '\0'; p++)
+    p[0] = TOLOWER (p[0]);
+}
+
+/* Cast a string to upper case.  */
+
+static void
+make_upper_case (char *p)
+{
+  for (; p != NO_TEXT && p[0] != '\0'; p++)
+    p[0] = TOUPPER (p[0]);
+}
+
+/* Construct a linear list of tokens.  */
+
+static void
+tokenise_source (NODE_T **root, int level, bool in_format,
+		 LINE_T **l, char **s, LINE_T **start_l,
+		 char **start_c)
+{
+  char *lpr = NO_TEXT;
+  int lprt = 0;
+
+  while (l != NO_VAR && !A68_PARSER (stop_scanner))
+    {
+      enum a68_attribute att = STOP;
+      get_next_token (in_format, l, s, start_l, start_c, &att);
+
+      if (A68_PARSER (scan_buf)[0] == STOP_CHAR)
+	A68_PARSER (stop_scanner) = true;
+      else if (strlen (A68_PARSER (scan_buf)) > 0 || att == ROW_CHAR_DENOTATION || att == LITERAL)
+	{
+	  KEYWORD_T *kw;
+	  const char *c = NO_TEXT;
+	  bool make_node = true;
+	  const char *trailing = NO_TEXT;
+
+	  if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING)
+	    {
+	      /* In UPPER stropping all symbols in R9.4.1 are expressed as bold
+		 tags like "BEGIN", or symbols like "@".  */
+
+	      /* In this stropping regime there is no need to handle
+		 identifiers for which taggles were adjacent to underscores
+		 specially.  */
+	      if (att != IDENTIFIER && att != IDENTIFIER_WITH_UNDERSCORES)
+		kw = a68_find_keyword (A68 (top_keyword), A68_PARSER (scan_buf));
+	      else
+		kw = NO_KEYWORD;
+	    }
+	  else
+	    {
+	      /* In SUPPER stropping all symbols in R9.4.1 are expressed as
+		 tags like "begin", or symbols like "@".  */
+
+	      /* Normalize bold tags to all upper-case letters.  */
+	      if (att == BOLD_TAG)
+		make_upper_case (A68_PARSER (scan_buf));
+
+	      /* If any of the taggles of the scanned identifier were adjacent
+		 to an underscore, that inhibits interpreting it as a
+		 keyword.  */
+	      if (att != BOLD_TAG && att != IDENTIFIER_WITH_UNDERSCORES)
+		kw = a68_find_keyword (A68 (top_keyword), A68_PARSER (scan_buf));
+	      else
+		kw = NO_KEYWORD;
+	    }
+
+	  /* Beyond this point it is irrelevant whether an identifier had
+	     taggles adjacent to an underscore.  */
+	  if (att == IDENTIFIER_WITH_UNDERSCORES)
+	    att = IDENTIFIER;
+
+	  if (kw == NO_KEYWORD || att == ROW_CHAR_DENOTATION)
+	    {
+	      if (att == IDENTIFIER)
+		make_lower_case (A68_PARSER (scan_buf));
+	      if (att != ROW_CHAR_DENOTATION && att != LITERAL)
+		{
+		  size_t len = strlen (A68_PARSER (scan_buf));
+		  while (len >= 1 && A68_PARSER (scan_buf)[len - 1] == '_')
+		    {
+		      trailing = "_";
+		      A68_PARSER (scan_buf)[len - 1] = NULL_CHAR;
+		      len--;
+		    }
+		}
+	      c = TEXT (a68_add_token (&A68 (top_token), A68_PARSER (scan_buf)));
+	    }
+	  else
+	    {
+	      if (IS (kw, TO_SYMBOL))
+		{
+		  /* Merge GO and TO to GOTO.  */
+		  if (*root != NO_NODE && IS (*root, GO_SYMBOL))
+		    {
+		      ATTRIBUTE (*root) = GOTO_SYMBOL;
+		      NSYMBOL (*root) = TEXT (a68_find_keyword (A68 (top_keyword), "GOTO"));
+		      make_node = false;
+		    }
+		  else
+		    {
+		      att = ATTRIBUTE (kw);
+		      c = TEXT (kw);
+		    }
+		}
+	      else
+		{
+		  if (OPTION_STROPPING (&A68_JOB) == UPPER_STROPPING)
+		    {
+		      if (att == 0 || att == BOLD_TAG)
+			att = ATTRIBUTE (kw);
+		    }
+		  else
+		    {
+		      if (att == 0 || att == IDENTIFIER)
+			att = ATTRIBUTE (kw);
+		    }
+
+		  c = TEXT (kw);
+		  /* Handle pragments.  */
+		  if (att == STYLE_II_COMMENT_SYMBOL
+		      || att == STYLE_I_COMMENT_SYMBOL
+		      || att == BOLD_COMMENT_SYMBOL
+		      || att == BOLD_COMMENT_BEGIN_SYMBOL
+		      || att == BRIEF_COMMENT_BEGIN_SYMBOL)
+		    {
+		      char *nlpr = pragment (ATTRIBUTE (kw), l, s);
+
+		      if (lpr == NO_TEXT || (int) strlen (lpr) == 0)
+			lpr = nlpr;
+		      else
+			{
+			  char *stale = lpr;
+			  lpr = a68_new_string (lpr, "\n\n", nlpr, NO_TEXT);
+			  free (stale);
+			}
+		      lprt = att;
+		      make_node = false;
+		    }
+		  else if (att == STYLE_I_PRAGMAT_SYMBOL
+			   || att == BOLD_PRAGMAT_SYMBOL)
+		    {
+		      char *nlpr = pragment (ATTRIBUTE (kw), l, s);
+		      if (lpr == NO_TEXT || (int) strlen (lpr) == 0)
+			lpr = nlpr;
+		      else
+			{
+			  char *stale = lpr;
+			  lpr = a68_new_string (lpr, "\n\n", nlpr, NO_TEXT);
+			  free (stale);
+			}
+		      lprt = att;
+		      if (!A68_PARSER (stop_scanner))
+			make_node = false;
+		    }
+		}
+	    }
+	  /* Add token to the tree.  */
+	  if (make_node)
+	    {
+	      NODE_T *q = a68_new_node ();
+	      INFO (q) = a68_new_node_info ();
+
+	      switch (att)
+		{
+		case ASSIGN_SYMBOL:
+		case END_SYMBOL:
+		case ESAC_SYMBOL:
+		case OD_SYMBOL:
+		case OF_SYMBOL:
+		case FI_SYMBOL:
+		case CLOSE_SYMBOL:
+		case BUS_SYMBOL:
+		case COLON_SYMBOL:
+		case COMMA_SYMBOL:
+		case SEMI_SYMBOL:
+		  GINFO (q) = NO_GINFO;
+		  break;
+		default:
+		  GINFO (q) = a68_new_genie_info ();
+		  break;
+		}
+
+	      STATUS (q) = (STATUS_MASK_T) 0;
+	      LINE (INFO (q)) = *start_l;
+	      CHAR_IN_LINE (INFO (q)) = *start_c;
+	      PRIO (INFO (q)) = 0;
+	      PROCEDURE_LEVEL (INFO (q)) = 0;
+	      ATTRIBUTE (q) = att;
+	      NSYMBOL (q) = c;
+	      PREVIOUS (q) = *root;
+	      SUB (q) = NEXT (q) = NO_NODE;
+	      TABLE (q) = NO_TABLE;
+	      MOID (q) = NO_MOID;
+	      TAX (q) = NO_TAG;
+	      if (lpr != NO_TEXT)
+		{
+		  NPRAGMENT (q) = lpr;
+		  NPRAGMENT_TYPE (q) = lprt;
+		  lpr = NO_TEXT;
+		  lprt = 0;
+		}
+	      if (*root != NO_NODE)
+		NEXT (*root) = q;
+	      if (TOP_NODE (&A68_JOB) == NO_NODE)
+		TOP_NODE (&A68_JOB) = q;
+	      *root = q;
+	      if (trailing != NO_TEXT)
+		a68_warning (q, 0,
+			     "ignoring trailing character H in A",
+			     trailing, att);
+	    }
+	  /* Redirection in tokenising formats. The scanner is a recursive-descent type as
+	     to know when it scans a format text and when not.  */
+	  if (in_format && att == FORMAT_DELIMITER_SYMBOL)
+	    return;
+	  else if (!in_format && att == FORMAT_DELIMITER_SYMBOL)
+	    tokenise_source (root, level + 1, true, l, s, start_l, start_c);
+	  else if (in_format && open_nested_clause (att))
+	    {
+	      NODE_T *z = PREVIOUS (*root);
+
+	      if (z != NO_NODE && a68_is_one_of (z, FORMAT_ITEM_N, FORMAT_ITEM_G, FORMAT_ITEM_H,
+						 FORMAT_ITEM_F, STOP))
+		{
+		  tokenise_source (root, level, false, l, s, start_l, start_c);
+		}
+	      else if (att == OPEN_SYMBOL)
+		ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL;
+	      else if (OPTION_BRACKETS (&A68_JOB) && att == SUB_SYMBOL)
+		ATTRIBUTE (*root) = FORMAT_OPEN_SYMBOL;
+	    }
+	  else if (!in_format && level > 0 && open_nested_clause (att))
+	    tokenise_source (root, level + 1, false, l, s, start_l, start_c);
+	  else if (!in_format && level > 0 && close_nested_clause (att))
+	    return;
+	  else if (in_format && att == CLOSE_SYMBOL)
+	    ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL;
+	  else if (OPTION_BRACKETS (&A68_JOB) && in_format && att == BUS_SYMBOL)
+	    ATTRIBUTE (*root) = FORMAT_CLOSE_SYMBOL;
+	}
+    }
+}
+
+/* Tokenise source file, build initial syntax tree.  */
+
+bool
+a68_lexical_analyser (const char *filename)
+{
+  LINE_T *l = NO_LINE, *start_l = NO_LINE;
+  char *s = NO_TEXT, *start_c = NO_TEXT;
+  NODE_T *root = NO_NODE;
+
+  /* Read the source file into lines.  */
+  if (!read_source_file (filename))
+    return false;
+
+  /* Start tokenising.  */
+  A68_PARSER (stop_scanner) = false;
+  if ((l = TOP_LINE (&A68_JOB)) != NO_LINE)
+    s = STRING (l);
+  tokenise_source (&root, 0, false, &l, &s, &start_l, &start_c);
+
+  /* Note that A68_PARSER (scan_buf) and A68_PARSER (max_scan_buf_length) are
+     allocated by read_source_line.  */
+  free (A68_PARSER (scan_buf));
+  A68_PARSER (scan_buf) = NULL;
+  A68_PARSER (max_scan_buf_length) = 0;
+  return true;
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 17/47] a68: parser: keyword tables management
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (15 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 16/47] a68: parser: scanner Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 18/47] a68: parser: top-down parser Jose E. Marchesi
                   ` (30 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This commit adds code to manage the table of keywords (bold words) in
the Algol 68 front-end.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-keywords.cc | 226 +++++++++++++++++++++++++++++
 1 file changed, 226 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-keywords.cc

diff --git a/gcc/algol68/a68-parser-keywords.cc b/gcc/algol68/a68-parser-keywords.cc
new file mode 100644
index 00000000000..d1ee12bb3b8
--- /dev/null
+++ b/gcc/algol68/a68-parser-keywords.cc
@@ -0,0 +1,226 @@
+/* Keyword tables.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/* Add token to the token tree.  */
+
+TOKEN_T *
+a68_add_token (TOKEN_T **p, const char *t)
+{
+  char *z = xstrdup (t);
+  while (*p != NO_TOKEN)
+    {
+      int k = strcmp (z, TEXT (*p));
+
+      if (k < 0)
+	p = &LESS (*p);
+      else if (k > 0)
+	p = &MORE (*p);
+      else
+	return *p;
+    }
+
+  *p = (TOKEN_T *) xmalloc (sizeof (TOKEN_T));
+  TEXT (*p) = z;
+  LESS (*p) = MORE (*p) = NO_TOKEN;
+  return *p;
+}
+
+/*  Find keyword, from token name.  */
+
+KEYWORD_T *
+a68_find_keyword (KEYWORD_T *p, const char *t)
+{
+  while (p != NO_KEYWORD)
+    {
+      bool case_insensitive = (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING);
+      int k = (case_insensitive
+	       ? strcasecmp (t, TEXT (p))
+	       : strcmp (t, TEXT (p)));
+
+      if (k < 0)
+	p = LESS (p);
+      else if (k > 0)
+	p = MORE (p);
+      else
+	return p;
+    }
+
+  return NO_KEYWORD;
+}
+
+/* Find keyword, from attribute.  */
+
+KEYWORD_T *
+a68_find_keyword_from_attribute (KEYWORD_T *p, enum a68_attribute a)
+{
+  if (p == NO_KEYWORD)
+    return NO_KEYWORD;
+  else if (a == ATTRIBUTE (p))
+    return p;
+  else
+    {
+      KEYWORD_T *z;
+
+      if ((z = a68_find_keyword_from_attribute (LESS (p), a)) != NO_KEYWORD)
+	return z;
+      else if ((z = a68_find_keyword_from_attribute (MORE (p), a)) != NO_KEYWORD)
+	return z;
+    }
+
+  return NO_KEYWORD;
+}
+
+/* Add keyword to the tree.  */
+
+static void
+add_keyword (KEYWORD_T **p, enum a68_attribute a, const char *t)
+{
+  while (*p != NO_KEYWORD)
+    {
+      bool case_insensitive = (OPTION_STROPPING (&A68_JOB) == SUPPER_STROPPING);
+      int k = (case_insensitive
+	       ? strcasecmp (t, TEXT (*p))
+	       : strcmp (t, TEXT (*p)));
+      if (k < 0)
+	p = &LESS (*p);
+      else
+	p = &MORE (*p);
+    }
+
+  *p = (KEYWORD_T *) xmalloc (sizeof (KEYWORD_T));
+  ATTRIBUTE (*p) = a;
+  TEXT (*p) = t;
+  LESS (*p) = MORE (*p) = NO_KEYWORD;
+}
+
+/* Make tables of keywords and non-terminals.  */
+
+void
+a68_set_up_tables (void)
+{
+  /* Entries are randomised to balance the tree.  */
+  if (OPTION_STRICT (&A68_JOB) == false)
+    {
+      add_keyword (&A68 (top_keyword), ANDF_SYMBOL, "ANDTH");
+      add_keyword (&A68 (top_keyword), ORF_SYMBOL, "OREL");
+      add_keyword (&A68 (top_keyword), BRIEF_COMMENT_BEGIN_SYMBOL, "{");
+      add_keyword (&A68 (top_keyword), BRIEF_COMMENT_END_SYMBOL, "}");
+
+      if (OPTION_STROPPING (&A68_JOB) != SUPPER_STROPPING)
+	{
+	  add_keyword (&A68 (top_keyword), BOLD_COMMENT_BEGIN_SYMBOL, "NOTE");
+	  add_keyword (&A68 (top_keyword), BOLD_COMMENT_END_SYMBOL, "ETON");
+	}
+    }
+
+  if (OPTION_STROPPING (&A68_JOB) != SUPPER_STROPPING)
+    {
+      /* The following representations do not work well with stropping regimes
+	 in which reserved words live in the same namespace than
+	 tags/identifiers.  The alternative "brief" representations for these
+	 symbols shall be used instead.  */
+      add_keyword (&A68 (top_keyword), STYLE_I_COMMENT_SYMBOL, "CO");
+      add_keyword (&A68 (top_keyword), BOLD_COMMENT_SYMBOL, "COMMENT");
+      add_keyword (&A68 (top_keyword), STYLE_II_COMMENT_SYMBOL, "#");
+    }
+
+  add_keyword (&A68 (top_keyword), POINT_SYMBOL, ".");
+  add_keyword (&A68 (top_keyword), COLON_SYMBOL, ":");
+  add_keyword (&A68 (top_keyword), THEN_BAR_SYMBOL, "|");
+  add_keyword (&A68 (top_keyword), SUB_SYMBOL, "[");
+  add_keyword (&A68 (top_keyword), BY_SYMBOL, "BY");
+  add_keyword (&A68 (top_keyword), OP_SYMBOL, "OP");
+  add_keyword (&A68 (top_keyword), COMMA_SYMBOL, ",");
+  add_keyword (&A68 (top_keyword), AT_SYMBOL, "AT");
+  add_keyword (&A68 (top_keyword), PRIO_SYMBOL, "PRIO");
+  add_keyword (&A68 (top_keyword), END_SYMBOL, "END");
+  add_keyword (&A68 (top_keyword), GO_SYMBOL, "GO");
+  add_keyword (&A68 (top_keyword), TO_SYMBOL, "TO");
+  add_keyword (&A68 (top_keyword), ELSE_BAR_SYMBOL, "|:");
+  add_keyword (&A68 (top_keyword), THEN_SYMBOL, "THEN");
+  add_keyword (&A68 (top_keyword), TRUE_SYMBOL, "TRUE");
+  add_keyword (&A68 (top_keyword), PROC_SYMBOL, "PROC");
+  add_keyword (&A68 (top_keyword), FOR_SYMBOL, "FOR");
+  add_keyword (&A68 (top_keyword), GOTO_SYMBOL, "GOTO");
+  add_keyword (&A68 (top_keyword), WHILE_SYMBOL, "WHILE");
+  add_keyword (&A68 (top_keyword), IS_SYMBOL, ":=:");
+  add_keyword (&A68 (top_keyword), ASSIGN_TO_SYMBOL, "=:");
+  add_keyword (&A68 (top_keyword), COMPL_SYMBOL, "COMPL");
+  add_keyword (&A68 (top_keyword), FROM_SYMBOL, "FROM");
+  add_keyword (&A68 (top_keyword), BOLD_PRAGMAT_SYMBOL, "PRAGMAT");
+  add_keyword (&A68 (top_keyword), DO_SYMBOL, "DO");
+  add_keyword (&A68 (top_keyword), CASE_SYMBOL, "CASE");
+  add_keyword (&A68 (top_keyword), LOC_SYMBOL, "LOC");
+  add_keyword (&A68 (top_keyword), CHAR_SYMBOL, "CHAR");
+  add_keyword (&A68 (top_keyword), ISNT_SYMBOL, ":/=:");
+  add_keyword (&A68 (top_keyword), REF_SYMBOL, "REF");
+  add_keyword (&A68 (top_keyword), NIL_SYMBOL, "NIL");
+  add_keyword (&A68 (top_keyword), ASSIGN_SYMBOL, ":=");
+  add_keyword (&A68 (top_keyword), FI_SYMBOL, "FI");
+  add_keyword (&A68 (top_keyword), FILE_SYMBOL, "FILE");
+  add_keyword (&A68 (top_keyword), PAR_SYMBOL, "PAR");
+  add_keyword (&A68 (top_keyword), ASSERT_SYMBOL, "ASSERT");
+  add_keyword (&A68 (top_keyword), OUSE_SYMBOL, "OUSE");
+  add_keyword (&A68 (top_keyword), IN_SYMBOL, "IN");
+  add_keyword (&A68 (top_keyword), LONG_SYMBOL, "LONG");
+  add_keyword (&A68 (top_keyword), SEMI_SYMBOL, ";");
+  add_keyword (&A68 (top_keyword), EMPTY_SYMBOL, "EMPTY");
+  add_keyword (&A68 (top_keyword), MODE_SYMBOL, "MODE");
+  add_keyword (&A68 (top_keyword), IF_SYMBOL, "IF");
+  add_keyword (&A68 (top_keyword), OD_SYMBOL, "OD");
+  add_keyword (&A68 (top_keyword), OF_SYMBOL, "OF");
+  add_keyword (&A68 (top_keyword), STRUCT_SYMBOL, "STRUCT");
+  add_keyword (&A68 (top_keyword), STYLE_I_PRAGMAT_SYMBOL, "PR");
+  add_keyword (&A68 (top_keyword), BUS_SYMBOL, "]");
+  add_keyword (&A68 (top_keyword), SKIP_SYMBOL, "SKIP");
+  add_keyword (&A68 (top_keyword), SHORT_SYMBOL, "SHORT");
+  add_keyword (&A68 (top_keyword), IS_SYMBOL, "IS");
+  add_keyword (&A68 (top_keyword), ESAC_SYMBOL, "ESAC");
+  add_keyword (&A68 (top_keyword), CHANNEL_SYMBOL, "CHANNEL");
+  add_keyword (&A68 (top_keyword), REAL_SYMBOL, "REAL");
+  add_keyword (&A68 (top_keyword), STRING_SYMBOL, "STRING");
+  add_keyword (&A68 (top_keyword), BOOL_SYMBOL, "BOOL");
+  add_keyword (&A68 (top_keyword), ISNT_SYMBOL, "ISNT");
+  add_keyword (&A68 (top_keyword), FALSE_SYMBOL, "FALSE");
+  add_keyword (&A68 (top_keyword), UNION_SYMBOL, "UNION");
+  add_keyword (&A68 (top_keyword), OUT_SYMBOL, "OUT");
+  add_keyword (&A68 (top_keyword), BRIEF_COMMENT_END_SYMBOL, "{");
+  add_keyword (&A68 (top_keyword), OPEN_SYMBOL, "(");
+  add_keyword (&A68 (top_keyword), BEGIN_SYMBOL, "BEGIN");
+  add_keyword (&A68 (top_keyword), FLEX_SYMBOL, "FLEX");
+  add_keyword (&A68 (top_keyword), VOID_SYMBOL, "VOID");
+  add_keyword (&A68 (top_keyword), BITS_SYMBOL, "BITS");
+  add_keyword (&A68 (top_keyword), ELSE_SYMBOL, "ELSE");
+  add_keyword (&A68 (top_keyword), EXIT_SYMBOL, "EXIT");
+  add_keyword (&A68 (top_keyword), HEAP_SYMBOL, "HEAP");
+  add_keyword (&A68 (top_keyword), INT_SYMBOL, "INT");
+  add_keyword (&A68 (top_keyword), BYTES_SYMBOL, "BYTES");
+  add_keyword (&A68 (top_keyword), SEMA_SYMBOL, "SEMA");
+  add_keyword (&A68 (top_keyword), CLOSE_SYMBOL, ")");
+  add_keyword (&A68 (top_keyword), AT_SYMBOL, "@");
+  add_keyword (&A68 (top_keyword), ELIF_SYMBOL, "ELIF");
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 18/47] a68: parser: top-down parser
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (16 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 17/47] a68: parser: keyword tables management Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 19/47] a68: parser: parenthesis checker Jose E. Marchesi
                   ` (29 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Top-down parser for the Algol 68 front-end.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-top-down.cc | 785 +++++++++++++++++++++++++++++
 1 file changed, 785 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-top-down.cc

diff --git a/gcc/algol68/a68-parser-top-down.cc b/gcc/algol68/a68-parser-top-down.cc
new file mode 100644
index 00000000000..7a39b3fcad5
--- /dev/null
+++ b/gcc/algol68/a68-parser-top-down.cc
@@ -0,0 +1,785 @@
+/* Top-down parser for control structure.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/* A few forward prototypes of functions defined below.  */
+
+static NODE_T *top_down_loop (NODE_T *p);
+static NODE_T *top_down_skip_unit (NODE_T *p);
+
+/* Substitute brackets.
+
+   Traditional ALGOL 68 syntax allows ( .. ) to replace [ .. ] in bounds and
+   slices.  This top-down pass substitutes [ .. ] occurrences into ( .. ).  */
+
+void
+a68_substitute_brackets (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      a68_substitute_brackets (SUB (p));
+
+      switch (ATTRIBUTE (p))
+	{
+	case SUB_SYMBOL:
+	  ATTRIBUTE (p) = OPEN_SYMBOL;
+	  break;
+	case BUS_SYMBOL:
+	  ATTRIBUTE (p) = CLOSE_SYMBOL;
+	  break;
+	default:
+	  break;
+	}
+    }
+}
+
+/* Intelligible diagnostic from syntax tree branch.  */
+
+char *
+a68_phrase_to_text (NODE_T * p, NODE_T ** w)
+{
+#define MAX_TERMINALS 8
+  int count = 0, line = -1;
+  static BUFFER buffer;
+
+  for (buffer[0] = '\0'; p != NO_NODE && count < MAX_TERMINALS; FORWARD (p))
+    {
+      if (LINE_NUMBER (p) == 0)
+	continue;
+
+      enum a68_attribute gatt = a68_get_good_attribute (p);
+      const char *z = a68_attribute_name (gatt);
+
+      /* Where to put the error message? Bob Uzgalis noted that actual
+	 content of a diagnostic is not as important as accurately
+	 indicating *were* the problem is!  */
+      if (w != NO_VAR)
+	{
+	  if (count == 0 || (*w) == NO_NODE)
+	    *w = p;
+	  else if (a68_dont_mark_here (*w))
+	    *w = p;
+	}
+
+      /* Add initiation.  */
+      if (count == 0)
+	{
+	  if (w != NO_VAR)
+	    a68_bufcat (buffer, "construct beginning with", BUFFER_SIZE);
+	}
+      else if (count == 1)
+	a68_bufcat (buffer, " followed by", BUFFER_SIZE);
+      else if (count == 2)
+	a68_bufcat (buffer, " and then", BUFFER_SIZE);
+      else if (count >= 3)
+	a68_bufcat (buffer, " and", BUFFER_SIZE);
+
+      /* Attribute or symbol.  */
+      if (z != NO_TEXT && SUB (p) != NO_NODE)
+	{
+	  if (gatt == IDENTIFIER || gatt == OPERATOR || gatt == DENOTATION)
+	    {
+	      if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) < 0)
+		gcc_unreachable ();
+	      a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE);
+	    }
+	  else
+	    {
+	      if (strchr ("aeio", z[0]) != NO_TEXT)
+		a68_bufcat (buffer, " an", BUFFER_SIZE);
+	      else
+		a68_bufcat (buffer, " a", BUFFER_SIZE);
+
+	      if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " %s", z) < 0)
+		gcc_unreachable ();
+	      a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE);
+	    }
+	}
+      else if (z != NO_TEXT && SUB (p) == NO_NODE)
+	{
+	  if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) < 0)
+	    gcc_unreachable ();
+	  a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE);
+	}
+      else if (NSYMBOL (p) != NO_TEXT)
+	{
+	  if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " \"%s\"", NSYMBOL (p)) < 0)
+	    gcc_unreachable ();
+	  a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE);
+	}
+      /* Add "starting in line nn".  */
+      if (z != NO_TEXT && line != LINE_NUMBER (p))
+	{
+	  line = LINE_NUMBER (p);
+	  if (gatt == SERIAL_CLAUSE || gatt == ENQUIRY_CLAUSE || gatt == INITIALISER_SERIES)
+	    a68_bufcat (buffer, " starting", BUFFER_SIZE);
+	  if (snprintf (A68 (edit_line), SNPRINTF_SIZE, " in line %d", line) < 0)
+	    gcc_unreachable ();
+	  a68_bufcat (buffer, A68 (edit_line), BUFFER_SIZE);
+	}
+      count++;
+    }
+
+  if (p != NO_NODE && count == MAX_TERMINALS)
+    a68_bufcat (buffer, " etcetera", BUFFER_SIZE);
+  return buffer;
+}
+
+/* Next is a top-down parser that branches out the basic blocks.
+   After this we can assign symbol tables to basic blocks.
+   This renders the two-level grammar LALR.  */
+
+/* Give diagnose from top-down parser.  */
+
+static void
+top_down_diagnose (NODE_T *start, NODE_T *p, int clause, int expected)
+{
+  NODE_T *issue = (p != NO_NODE ? p : start);
+
+  if (expected != 0)
+    a68_error (issue, "B expected in A, near Z L",
+	       expected, clause, NSYMBOL (start), LINE (INFO (start)));
+  else
+    a68_error (issue, "missing or unbalanced keyword in A, near Z L",
+	       clause, NSYMBOL (start), LINE (INFO (start)));
+}
+
+/* Check for premature exhaustion of tokens.  */
+
+static void
+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");
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+    }
+}
+
+/*
+ * This part specifically branches out loop clauses.
+ */
+
+/* Whether in cast or formula with loop clause.  */
+
+static int
+is_loop_cast_formula (NODE_T *p)
+{
+  /* Accept declarers that can appear in such casts but not much more.  */
+  if (IS (p, VOID_SYMBOL))
+    return 1;
+  else if (IS (p, INT_SYMBOL))
+    return 1;
+  else if (IS_REF (p))
+    return 1;
+  else if (a68_is_one_of (p, OPERATOR, BOLD_TAG, STOP))
+    return 1;
+  else if (a68_whether (p, UNION_SYMBOL, OPEN_SYMBOL, STOP))
+    return 2;
+  else if (a68_is_one_of (p, OPEN_SYMBOL, SUB_SYMBOL, STOP))
+    {
+      int k = 0;
+      for (; p != NO_NODE && (a68_is_one_of (p, OPEN_SYMBOL, SUB_SYMBOL, STOP)); FORWARD (p), k++)
+	;
+      return p != NO_NODE && (a68_whether (p, UNION_SYMBOL, OPEN_SYMBOL, STOP) ? k : 0);
+    }
+  return 0;
+}
+
+/* Skip a unit in a loop clause (FROM u BY u TO u).  */
+
+static NODE_T *
+top_down_skip_loop_unit (NODE_T *p)
+{
+  /* Unit may start with, or consist of, a loop.  */
+  if (a68_is_loop_keyword (p))
+    p = top_down_loop (p);
+
+  /* Skip rest of unit.  */
+  while (p != NO_NODE)
+    {
+      int k = is_loop_cast_formula (p);
+
+      if (k != 0)
+	{
+	  /* operator-cast series ...  */
+	  while (p != NO_NODE && k != 0)
+	    {
+	      while (k != 0)
+		{
+		  FORWARD (p);
+		  k--;
+		}
+	      k = is_loop_cast_formula (p);
+	    }
+
+	  /* ... may be followed by a loop clause.  */
+	  if (a68_is_loop_keyword (p))
+	    p = top_down_loop (p);
+	}
+      else if (a68_is_loop_keyword (p) || IS (p, OD_SYMBOL))
+	/* new loop or end-of-loop.  */
+	return p;
+      else if (IS (p, COLON_SYMBOL))
+	{
+	  FORWARD (p);
+	  /* skip routine header: loop clause.  */
+	  if (p != NO_NODE && a68_is_loop_keyword (p))
+	    p = top_down_loop (p);
+	}
+      else if (a68_is_one_of (p, SEMI_SYMBOL, COMMA_SYMBOL, STOP) || IS (p, EXIT_SYMBOL))
+	/* Statement separators.  */
+	return p;
+      else
+	FORWARD (p);
+    }
+  return NO_NODE;
+}
+
+/* Skip a loop clause.  */
+
+static NODE_T *
+top_down_skip_loop_series (NODE_T *p)
+{
+  bool siga;
+
+  do
+    {
+      p = top_down_skip_loop_unit (p);
+      siga = (p != NO_NODE && (a68_is_one_of (p, SEMI_SYMBOL, EXIT_SYMBOL,
+					      COMMA_SYMBOL, COLON_SYMBOL,
+					      STOP)));
+    if (siga)
+      FORWARD (p);
+    }
+  while (!(p == NO_NODE || !siga));
+
+  return p;
+}
+
+/* Make branch of loop parts.  */
+
+static NODE_T *
+top_down_loop (NODE_T *p)
+{
+  NODE_T *start = p, *q = p;
+
+  if (IS (q, FOR_SYMBOL))
+    {
+      tokens_exhausted (FORWARD (q), start);
+
+      if (IS (q, IDENTIFIER))
+	ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+      else
+	{
+	  top_down_diagnose (start, q, LOOP_CLAUSE, IDENTIFIER);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+
+      tokens_exhausted (FORWARD (q), start);
+
+      if (a68_is_one_of (q, FROM_SYMBOL, BY_SYMBOL, TO_SYMBOL,
+			 WHILE_SYMBOL, STOP))
+	;
+      else if (IS (q, DO_SYMBOL))
+	ATTRIBUTE (q) = ALT_DO_SYMBOL;
+      else
+	{
+	  top_down_diagnose (start, q, LOOP_CLAUSE, STOP);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+    }
+
+  if (IS (q, FROM_SYMBOL))
+    {
+      start = q;
+      q = top_down_skip_loop_unit (NEXT (q));
+      tokens_exhausted (q, start);
+      if (a68_is_one_of (q, BY_SYMBOL, TO_SYMBOL, WHILE_SYMBOL, STOP))
+	;
+      else if (IS (q, DO_SYMBOL))
+	ATTRIBUTE (q) = ALT_DO_SYMBOL;
+      else
+	{
+	  top_down_diagnose (start, q, LOOP_CLAUSE, STOP);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+
+      a68_make_sub (start, PREVIOUS (q), FROM_SYMBOL);
+    }
+
+  if (IS (q, BY_SYMBOL))
+    {
+      start = q;
+      q = top_down_skip_loop_series (NEXT (q));
+      tokens_exhausted (q, start);
+
+      if (a68_is_one_of (q, TO_SYMBOL, WHILE_SYMBOL, STOP))
+	;
+      else if (IS (q, DO_SYMBOL))
+	ATTRIBUTE (q) = ALT_DO_SYMBOL;
+      else
+	{
+	  top_down_diagnose (start, q, LOOP_CLAUSE, STOP);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+
+      a68_make_sub (start, PREVIOUS (q), BY_SYMBOL);
+    }
+
+  if (a68_is_one_of (q, TO_SYMBOL, STOP))
+    {
+      start = q;
+      q = top_down_skip_loop_series (NEXT (q));
+      tokens_exhausted (q, start);
+
+      if (IS (q, WHILE_SYMBOL))
+	;
+      else if (IS (q, DO_SYMBOL))
+	ATTRIBUTE (q) = ALT_DO_SYMBOL;
+      else
+	{
+	  top_down_diagnose (start, q, LOOP_CLAUSE, STOP);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+
+      a68_make_sub (start, PREVIOUS (q), TO_SYMBOL);
+    }
+
+  if (IS (q, WHILE_SYMBOL))
+    {
+      start = q;
+      q = top_down_skip_loop_series (NEXT (q));
+      tokens_exhausted (q, start);
+
+      if (IS (q, DO_SYMBOL))
+	ATTRIBUTE (q) = ALT_DO_SYMBOL;
+      else
+	{
+	  top_down_diagnose (start, q, LOOP_CLAUSE, DO_SYMBOL);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+
+      a68_make_sub (start, PREVIOUS (q), WHILE_SYMBOL);
+    }
+
+  if (a68_is_one_of (q, DO_SYMBOL, ALT_DO_SYMBOL, STOP))
+    {
+      enum a68_attribute k = ATTRIBUTE (q);
+
+      start = q;
+      q = top_down_skip_loop_series (NEXT (q));
+      tokens_exhausted (q, start);
+
+      if (!IS (q, OD_SYMBOL))
+	{
+	  top_down_diagnose (start, q, LOOP_CLAUSE, OD_SYMBOL);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+
+      a68_make_sub (start, q, k);
+    }
+
+  NODE_T *save = NEXT (start);
+  a68_make_sub (p, start, LOOP_CLAUSE);
+  return save;
+}
+
+/* Driver for making branches of loop parts.  */
+
+static void
+top_down_loops (NODE_T *p)
+{
+  NODE_T *q = p;
+
+  for (; q != NO_NODE; FORWARD (q))
+    {
+      if (SUB (q) != NO_NODE)
+	top_down_loops (SUB (q));
+    }
+
+  q = p;
+  while (q != NO_NODE)
+    {
+      if (a68_is_loop_keyword (q) != STOP)
+	q = top_down_loop (q);
+      else
+	FORWARD (q);
+    }
+}
+
+/*
+ * Branch anything except parts of a loop.
+ */
+
+/* Skip serial/enquiry clause (unit series).  */
+
+static NODE_T *
+top_down_series (NODE_T *p)
+{
+  bool siga = true;
+  while (siga)
+    {
+      siga = false;
+      p = top_down_skip_unit (p);
+      if (p != NO_NODE)
+	{
+	  if (a68_is_one_of (p, SEMI_SYMBOL, EXIT_SYMBOL, COMMA_SYMBOL, STOP))
+	    {
+	      siga = true;
+	      FORWARD (p);
+	    }
+	}
+    }
+  return p;
+}
+
+/* Make branch of BEGIN .. END.  */
+
+static NODE_T *
+top_down_begin (NODE_T *begin_p)
+{
+  NODE_T *end_p = top_down_series (NEXT (begin_p));
+
+  if (end_p == NO_NODE || !IS (end_p, END_SYMBOL))
+    {
+      top_down_diagnose (begin_p, end_p, ENCLOSED_CLAUSE, END_SYMBOL);
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+      return NO_NODE;
+    }
+  else
+    {
+      a68_make_sub (begin_p, end_p, BEGIN_SYMBOL);
+      return NEXT (begin_p);
+    }
+}
+
+/* Make branch of ( .. ).  */
+
+static NODE_T *
+top_down_open (NODE_T *open_p)
+{
+  NODE_T *then_bar_p = top_down_series (NEXT (open_p)), *elif_bar_p;
+
+  if (then_bar_p != NO_NODE && IS (then_bar_p, CLOSE_SYMBOL))
+    {
+      a68_make_sub (open_p, then_bar_p, OPEN_SYMBOL);
+      return NEXT (open_p);
+    }
+
+  if (then_bar_p == NO_NODE || !IS (then_bar_p, THEN_BAR_SYMBOL))
+    {
+      top_down_diagnose (open_p, then_bar_p, ENCLOSED_CLAUSE, STOP);
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+    }
+
+  a68_make_sub (open_p, PREVIOUS (then_bar_p), OPEN_SYMBOL);
+  elif_bar_p = top_down_series (NEXT (then_bar_p));
+  if (elif_bar_p != NO_NODE && IS (elif_bar_p, CLOSE_SYMBOL))
+    {
+      a68_make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL);
+      a68_make_sub (open_p, elif_bar_p, OPEN_SYMBOL);
+      return NEXT (open_p);
+    }
+
+  if (elif_bar_p != NO_NODE && IS (elif_bar_p, THEN_BAR_SYMBOL))
+    {
+      NODE_T *close_p = top_down_series (NEXT (elif_bar_p));
+
+      if (close_p == NO_NODE || !IS (close_p, CLOSE_SYMBOL))
+	{
+	  top_down_diagnose (open_p, elif_bar_p, ENCLOSED_CLAUSE, CLOSE_SYMBOL);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+
+      a68_make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL);
+      a68_make_sub (elif_bar_p, PREVIOUS (close_p), THEN_BAR_SYMBOL);
+      a68_make_sub (open_p, close_p, OPEN_SYMBOL);
+      return NEXT (open_p);
+    }
+
+  if (elif_bar_p != NO_NODE && IS (elif_bar_p, ELSE_BAR_SYMBOL))
+    {
+      NODE_T *close_p = top_down_open (elif_bar_p);
+      a68_make_sub (then_bar_p, PREVIOUS (elif_bar_p), THEN_BAR_SYMBOL);
+      a68_make_sub (open_p, elif_bar_p, OPEN_SYMBOL);
+      return close_p;
+    }
+  else
+    {
+      top_down_diagnose (open_p, elif_bar_p, ENCLOSED_CLAUSE, CLOSE_SYMBOL);
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+      return NO_NODE;
+    }
+}
+
+/* Make branch of [ .. ].  */
+
+static NODE_T *
+top_down_sub (NODE_T *sub_p)
+{
+  NODE_T *bus_p = top_down_series (NEXT (sub_p));
+
+  if (bus_p != NO_NODE && IS (bus_p, BUS_SYMBOL))
+    {
+      a68_make_sub (sub_p, bus_p, SUB_SYMBOL);
+      return NEXT (sub_p);
+    }
+  else
+    {
+      top_down_diagnose (sub_p, bus_p, 0, BUS_SYMBOL);
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+      return NO_NODE;
+    }
+}
+
+/* Make branch of IF .. THEN .. ELSE .. FI.  */
+
+static NODE_T *
+top_down_if (NODE_T * if_p)
+{
+  NODE_T *then_p = top_down_series (NEXT (if_p)), *elif_p;
+
+  if (then_p == NO_NODE || !IS (then_p, THEN_SYMBOL))
+    {
+      top_down_diagnose (if_p, then_p, CONDITIONAL_CLAUSE, THEN_SYMBOL);
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+    }
+
+  a68_make_sub (if_p, PREVIOUS (then_p), IF_SYMBOL);
+
+  elif_p = top_down_series (NEXT (then_p));
+  if (elif_p != NO_NODE && IS (elif_p, FI_SYMBOL))
+    {
+      a68_make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL);
+      a68_make_sub (if_p, elif_p, IF_SYMBOL);
+      return NEXT (if_p);
+    }
+
+  if (elif_p != NO_NODE && IS (elif_p, ELSE_SYMBOL))
+    {
+      NODE_T *fi_p = top_down_series (NEXT (elif_p));
+
+      if (fi_p == NO_NODE || !IS (fi_p, FI_SYMBOL))
+	{
+	  top_down_diagnose (if_p, fi_p, CONDITIONAL_CLAUSE, FI_SYMBOL);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+      else
+	{
+	  a68_make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL);
+	  a68_make_sub (elif_p, PREVIOUS (fi_p), ELSE_SYMBOL);
+	  a68_make_sub (if_p, fi_p, IF_SYMBOL);
+	  return NEXT (if_p);
+	}
+    }
+
+  if (elif_p != NO_NODE && IS (elif_p, ELIF_SYMBOL))
+    {
+      NODE_T *fi_p = top_down_if (elif_p);
+
+      a68_make_sub (then_p, PREVIOUS (elif_p), THEN_SYMBOL);
+      a68_make_sub (if_p, elif_p, IF_SYMBOL);
+      return fi_p;
+    }
+  else
+    {
+      top_down_diagnose (if_p, elif_p, CONDITIONAL_CLAUSE, FI_SYMBOL);
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+      return NO_NODE;
+    }
+}
+
+/* Make branch of CASE .. IN .. OUT .. ESAC.  */
+
+static NODE_T *
+top_down_case (NODE_T *case_p)
+{
+  NODE_T *in_p = top_down_series (NEXT (case_p)), *ouse_p;
+
+  if (in_p == NO_NODE || !IS (in_p, IN_SYMBOL))
+    {
+      top_down_diagnose (case_p, in_p, ENCLOSED_CLAUSE, IN_SYMBOL);
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+    }
+
+  a68_make_sub (case_p, PREVIOUS (in_p), CASE_SYMBOL);
+
+  ouse_p = top_down_series (NEXT (in_p));
+  if (ouse_p != NO_NODE && IS (ouse_p, ESAC_SYMBOL))
+    {
+      a68_make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL);
+      a68_make_sub (case_p, ouse_p, CASE_SYMBOL);
+      return NEXT (case_p);
+    }
+
+  if (ouse_p != NO_NODE && IS (ouse_p, OUT_SYMBOL))
+    {
+      NODE_T *esac_p = top_down_series (NEXT (ouse_p));
+
+      if (esac_p == NO_NODE || !IS (esac_p, ESAC_SYMBOL))
+	{
+	  top_down_diagnose (case_p, esac_p, ENCLOSED_CLAUSE, ESAC_SYMBOL);
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+      else
+	{
+	  a68_make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL);
+	  a68_make_sub (ouse_p, PREVIOUS (esac_p), OUT_SYMBOL);
+	  a68_make_sub (case_p, esac_p, CASE_SYMBOL);
+	  return NEXT (case_p);
+	}
+    }
+  
+  if (ouse_p != NO_NODE && IS (ouse_p, OUSE_SYMBOL))
+    {
+      NODE_T *esac_p = top_down_case (ouse_p);
+
+      a68_make_sub (in_p, PREVIOUS (ouse_p), IN_SYMBOL);
+      a68_make_sub (case_p, ouse_p, CASE_SYMBOL);
+      return esac_p;
+    }
+  else
+    {
+      top_down_diagnose (case_p, ouse_p, ENCLOSED_CLAUSE, ESAC_SYMBOL);
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+      return NO_NODE;
+    }
+}
+
+/* Skip a unit.  */
+
+static NODE_T *
+top_down_skip_unit (NODE_T *p)
+{
+  while (p != NO_NODE && !a68_is_unit_terminator (p))
+    {
+      if (IS (p, BEGIN_SYMBOL))
+	p = top_down_begin (p);
+      else if (IS (p, SUB_SYMBOL))
+	p = top_down_sub (p);
+      else if (IS (p, OPEN_SYMBOL))
+	p = top_down_open (p);
+      else if (IS (p, IF_SYMBOL))
+	p = top_down_if (p);
+      else if (IS (p, CASE_SYMBOL))
+	p = top_down_case (p);
+      else
+      FORWARD (p);
+    }
+  return p;
+}
+
+static NODE_T *top_down_skip_format (NODE_T *);
+
+/* Make branch of ( .. ) in a format.  */
+
+static NODE_T *
+top_down_format_open (NODE_T *open_p)
+{
+  NODE_T *close_p = top_down_skip_format (NEXT (open_p));
+
+  if (close_p != NO_NODE && IS (close_p, FORMAT_CLOSE_SYMBOL))
+    {
+      a68_make_sub (open_p, close_p, FORMAT_OPEN_SYMBOL);
+      return NEXT (open_p);
+    }
+  else
+    {
+      top_down_diagnose (open_p, close_p, 0, FORMAT_CLOSE_SYMBOL);
+      longjmp (A68_PARSER (top_down_crash_exit), 1);
+      return NO_NODE;
+    }
+}
+
+/* Skip a format text.  */
+
+static NODE_T *
+top_down_skip_format (NODE_T *p)
+{
+  while (p != NO_NODE)
+    {
+      if (IS (p, FORMAT_OPEN_SYMBOL))
+	p = top_down_format_open (p);
+      else if (a68_is_one_of (p, FORMAT_CLOSE_SYMBOL, FORMAT_DELIMITER_SYMBOL, STOP))
+	return p;
+      else
+	FORWARD (p);
+  }
+  return NO_NODE;
+}
+
+/* Make branch of $ .. $.  */
+
+static void
+top_down_formats (NODE_T * p)
+{
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (SUB (q) != NO_NODE)
+	top_down_formats (SUB (q));
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, FORMAT_DELIMITER_SYMBOL))
+	{
+	  NODE_T *f = NEXT (q);
+
+	  while (f != NO_NODE && !IS (f, FORMAT_DELIMITER_SYMBOL))
+	    {
+	      if (IS (f, FORMAT_OPEN_SYMBOL))
+		f = top_down_format_open (f);
+	      else
+		f = NEXT (f);
+	    }
+
+	  if (f == NO_NODE)
+	    {
+	      top_down_diagnose (p, f, FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL);
+	      longjmp (A68_PARSER (top_down_crash_exit), 1);
+	    }
+	  else
+	    a68_make_sub (q, f, FORMAT_DELIMITER_SYMBOL);
+	}
+    }
+}
+
+/* Make branches of phrases for the bottom-up parser.  */
+
+void
+a68_top_down_parser (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+
+  if (!setjmp (A68_PARSER (top_down_crash_exit)))
+    {
+      (void) top_down_series (p);
+      top_down_loops (p);
+      top_down_formats (p);
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 19/47] a68: parser: parenthesis checker
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (17 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 18/47] a68: parser: top-down parser Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 20/47] a68: parser: bottom-up parser Jose E. Marchesi
                   ` (28 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

This pass makes sure all brackets (parenthesis) are matched in the
source program.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-brackets.cc | 220 +++++++++++++++++++++++++++++
 1 file changed, 220 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-brackets.cc

diff --git a/gcc/algol68/a68-parser-brackets.cc b/gcc/algol68/a68-parser-brackets.cc
new file mode 100644
index 00000000000..cd13e0c8a42
--- /dev/null
+++ b/gcc/algol68/a68-parser-brackets.cc
@@ -0,0 +1,220 @@
+/* Recursive-descent parenthesis checker.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/* After this checker, we know that at least brackets are matched.  This
+   stabilises later parser phases.
+
+   Note that this checker operates on a linear list of nodes.
+   
+   Error diagnostics are placed near offending lines.  */
+
+/* Intelligible diagnostics for the bracket checker.  */
+
+static void
+bracket_check_error (char *txt, int n, const char *bra, const char *ket)
+{
+  BUFFER buf;
+
+  if (n == 0)
+    return;
+
+  BUFCLR (buf);
+  if (snprintf (buf, SNPRINTF_SIZE, "\"%s\" without matching \"%s\"",
+		(n > 0 ? bra : ket), (n > 0 ? ket : bra)) < 0)
+    gcc_unreachable ();
+
+  if (strlen (txt) > 0)
+    a68_bufcat (txt, " or ", BUFFER_SIZE);
+  a68_bufcat (txt, buf, BUFFER_SIZE);
+}
+
+/* Diagnose brackets in local branch of the tree.  */
+
+static char *
+bracket_check_diagnose (NODE_T *p)
+{
+  int begins = 0, opens = 0, format_delims = 0, format_opens = 0;
+  int subs = 0, ifs = 0, cases = 0, dos = 0;
+
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case BEGIN_SYMBOL:
+	  begins++;
+	  break;
+	case END_SYMBOL:
+	  begins--;
+	  break;
+	case OPEN_SYMBOL:
+	  opens++;
+	  break;
+	case CLOSE_SYMBOL:
+	  opens--;
+	  break;
+	case FORMAT_DELIMITER_SYMBOL:
+	  if (format_delims == 0)
+	    format_delims = 1;
+	  else
+	    format_delims = 0;
+	  break;
+	case FORMAT_OPEN_SYMBOL:
+	  format_opens++;
+	  break;
+	case FORMAT_CLOSE_SYMBOL:
+	  format_opens--;
+	  break;
+	case SUB_SYMBOL:
+	  subs++;
+	  break;
+	case BUS_SYMBOL:
+	  subs--;
+	  break;
+	case IF_SYMBOL:
+	  ifs++;
+	  break;
+	case FI_SYMBOL:
+	  ifs--;
+	  break;
+	case CASE_SYMBOL:
+	  cases++;
+	  break;
+	case ESAC_SYMBOL:
+	  cases--;
+	  break;
+	case DO_SYMBOL:
+	  dos++;
+	  break;
+	case OD_SYMBOL:
+	  dos--;
+	  break;
+	default:
+	  break;
+	}
+    }
+
+  A68 (edit_line)[0] = '\0';
+  bracket_check_error (A68 (edit_line), begins, "BEGIN", "END");
+  bracket_check_error (A68 (edit_line), opens, "(", ")");
+  bracket_check_error (A68 (edit_line), format_opens, "(", ")");
+  bracket_check_error (A68 (edit_line), format_delims, "$", "$");
+  bracket_check_error (A68 (edit_line), subs, "[", "]");
+  bracket_check_error (A68 (edit_line), ifs, "IF", "FI");
+  bracket_check_error (A68 (edit_line), cases, "CASE", "ESAC");
+  bracket_check_error (A68 (edit_line), dos, "DO", "OD");
+  return A68 (edit_line);
+}
+
+/* Driver for locally diagnosing non-matching tokens.  */
+
+static NODE_T *
+bracket_check_parse (NODE_T *top, NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      int ket = STOP;
+      NODE_T *q = NO_NODE;
+      bool ignore_token = false;
+
+      switch (ATTRIBUTE (p))
+	{
+	case BEGIN_SYMBOL:
+	  ket = END_SYMBOL;
+	  q = bracket_check_parse (top, NEXT (p));
+	  break;
+	case OPEN_SYMBOL:
+	  ket = CLOSE_SYMBOL;
+	  q = bracket_check_parse (top, NEXT (p));
+	  break;
+	case FORMAT_OPEN_SYMBOL:
+	  ket = FORMAT_CLOSE_SYMBOL;
+	  q = bracket_check_parse (top, NEXT (p));
+	  break;
+	case SUB_SYMBOL:
+	  ket = BUS_SYMBOL;
+	  q = bracket_check_parse (top, NEXT (p));
+	  break;
+	case IF_SYMBOL:
+	  ket = FI_SYMBOL;
+	  q = bracket_check_parse (top, NEXT (p));
+	  break;
+	case CASE_SYMBOL:
+	  ket = ESAC_SYMBOL;
+	  q = bracket_check_parse (top, NEXT (p));
+	  break;
+	case DO_SYMBOL:
+	  ket = OD_SYMBOL;
+	  q = bracket_check_parse (top, NEXT (p));
+	  break;
+	case END_SYMBOL:
+	case CLOSE_SYMBOL:
+	case FORMAT_CLOSE_SYMBOL:
+	case BUS_SYMBOL:
+	case FI_SYMBOL:
+	case ESAC_SYMBOL:
+	case OD_SYMBOL:
+	  return p;
+	default:
+	  ignore_token = true;
+	}
+
+      if (ignore_token)
+	;
+      else if (q != NO_NODE && IS (q, ket))
+	p = q;
+      else if (q == NO_NODE)
+	{
+	  char *diag = bracket_check_diagnose (top);
+	  a68_error (p, "incorrect nesting, check for Y",
+		     (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 (p, "encountered X L but expected X, check for Y",
+		     ATTRIBUTE (q), LINE (INFO (q)),
+		     ket, (strlen (diag) > 0 ? diag : "missing or unmatched keyword"));
+	  longjmp (A68_PARSER (top_down_crash_exit), 1);
+	}
+    }
+  return NO_NODE;
+}
+
+/* Driver for globally diagnosing non-matching tokens.  */
+
+void
+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");
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 20/47] a68: parser: bottom-up parser
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (18 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 19/47] a68: parser: parenthesis checker Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 21/47] a68: parser: syntax check for declarers Jose E. Marchesi
                   ` (27 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Bottom-up parser for the Algol 68 front-end.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-bottom-up.cc | 2542 +++++++++++++++++++++++++++
 1 file changed, 2542 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-bottom-up.cc

diff --git a/gcc/algol68/a68-parser-bottom-up.cc b/gcc/algol68/a68-parser-bottom-up.cc
new file mode 100644
index 00000000000..9a914dd2c52
--- /dev/null
+++ b/gcc/algol68/a68-parser-bottom-up.cc
@@ -0,0 +1,2542 @@
+/* Hand-coded bottom-up parser for Algol 68.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+/* This code constitutes an effective "Algol 68 VW parser"; a pragmatic
+   approach was chosen since in the early days of Algol 68, many "ab initio"
+   implementations failed.
+
+   This is a Mailloux-type parser, in the sense that it scans a "phrase" for
+   definitions needed for parsing, and therefore allows for tags to be used
+   before they are defined, which gives some freedom in top-down programming.
+
+      B. J. Mailloux. On the implementation of Algol 68.
+      Thesis, Universiteit van Amsterdam (Mathematisch Centrum) [1968].
+
+   Technically, Mailloux's approach renders the two-level grammar LALR.  This
+   is the bottom-up parser that resolves the structure of the program.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/* Bottom-up parser, reduces all constructs.  */
+
+
+/* Maximum number of errors the bottom-up parser will try to recover from and
+   save diagnostics for.  */
+
+#define MAX_ERRORS 5
+
+/* Forward declarations of some of the functions defined below.  */
+
+static void reduce_branch (NODE_T *q, a68_attribute expect);
+static void recover_from_error (NODE_T * p, enum a68_attribute expect, bool suppress);
+static void reduce_declarers (NODE_T *p, enum a68_attribute expect);
+static void reduce_primary_parts (NODE_T *p, enum a68_attribute expect);
+static void reduce_primaries (NODE_T *p, enum a68_attribute expect);
+static void reduce_format_texts (NODE_T *p);
+static void reduce_secondaries (NODE_T *p);
+static void reduce_formulae (NODE_T * p);
+static void reduce_tertiaries (NODE_T *p);
+static void reduce_right_to_left_constructs (NODE_T *p);
+static void reduce_units (NODE_T * p);
+static void reduce_erroneous_units (NODE_T *p);
+static void reduce_generic_arguments (NODE_T *p);
+static void reduce_bounds (NODE_T *p);
+static void reduce_serial_clauses (NODE_T *p);
+static void reduce_enquiry_clauses (NODE_T *p);
+static void reduce_collateral_clauses (NODE_T *p);
+static void reduce_arguments (NODE_T *p);
+static void reduce_enclosed_clauses (NODE_T *q, enum a68_attribute expect);
+static void reduce_basic_declarations (NODE_T *p);
+static void reduce_declaration_lists (NODE_T *p);
+static NODE_T *reduce_dyadic (NODE_T *p, int u);
+
+/* Whether a series is serial or collateral.  */
+
+static enum a68_attribute
+serial_or_collateral (NODE_T *p)
+{
+  int semis = 0, commas = 0, exits = 0;
+  for (NODE_T *q = p; q != NO_NODE; q = NEXT (q))
+    {
+      if (IS (q, COMMA_SYMBOL))
+	commas++;
+      else if (IS (q, SEMI_SYMBOL))
+	semis++;
+      else if (IS (q, EXIT_SYMBOL))
+	exits++;
+    }
+
+  if (semis == 0 && exits == 0 && commas > 0)
+    return COLLATERAL_CLAUSE;
+  else if ((semis > 0 || exits > 0) && commas == 0)
+    return SERIAL_CLAUSE;
+  else if (semis == 0 && exits == 0 && commas == 0)
+    return SERIAL_CLAUSE;
+  else
+    /* Heuristic guess to give intelligible error message.  */
+    return (semis + exits >= commas) ? SERIAL_CLAUSE : COLLATERAL_CLAUSE;
+}
+
+/* Insert a node with attribute "a" after "p".  */
+
+static void
+pad_node (NODE_T *p, enum a68_attribute a)
+{
+  /* This is used to fill information that Algol 68 does not require to be
+     present.  Filling in gives one format for such construct; this helps later
+     passes.  */
+  NODE_T *z = a68_new_node ();
+  *z = *p;
+  if (GINFO (p) != NO_GINFO)
+    GINFO (z) = a68_new_genie_info ();
+  PREVIOUS (z) = p;
+  SUB (z) = NO_NODE;
+  ATTRIBUTE (z) = a;
+  MOID (z) = NO_MOID;
+  if (NEXT (z) != NO_NODE)
+    PREVIOUS (NEXT (z)) = z;
+  NEXT (p) = z;
+}
+
+/* Diagnose extensions.  */
+
+static void
+a68_extension (NODE_T *p)
+{
+  a68_warning (p, OPT_Wextensions, "AST node is an extension");
+}
+
+/* Diagnose for clauses not yielding a value.  */
+
+static void
+empty_clause (NODE_T *p)
+{
+  a68_error (p, "clause does not yield a value");
+}
+
+/* Diagnose for missing symbol.  */
+
+static void
+strange_tokens (NODE_T *p)
+{
+  NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p);
+  a68_error (q, "possibly a missing or erroneous symbol nearby");
+}
+
+/* Diagnose for strange separator.  */
+
+static void
+strange_separator (NODE_T *p)
+{
+  NODE_T *q = ((p != NO_NODE && NEXT (p) != NO_NODE) ? NEXT (p) : p);
+  a68_error (q, "possibly a missing or erroneous separator nearby");
+}
+
+/* If match then reduce a sentence, the core bottom-up parser routine.  */
+
+static void
+reduce (NODE_T *p, void (*a) (NODE_T *), bool *z, ...)
+{
+  va_list list;
+  va_start (list, z);
+  enum a68_attribute expect;
+  enum a68_attribute result = (enum a68_attribute) va_arg (list, int);
+  NODE_T *head = p, *tail = NO_NODE;
+
+  while ((expect = (enum a68_attribute) va_arg (list, int)) != STOP)
+  {
+    bool keep_matching;
+
+    if (p == NO_NODE)
+      keep_matching = false;
+    else if (expect == WILDCARD)
+      /* WILDCARD matches any Algol68G non terminal, but no keyword.  */
+      keep_matching = (a68_attribute_name (ATTRIBUTE (p)) != NO_TEXT);
+    else
+      {
+	if (expect == SKIP)
+	  {
+	    /* Stray "~" matches expected SKIP.  */
+	    if (IS (p, OPERATOR) && IS_LITERALLY (p, "~"))
+	      ATTRIBUTE (p) = SKIP;
+	  }
+
+	if (expect >= 0)
+	  keep_matching = (expect == ATTRIBUTE (p));
+	else
+	  keep_matching = (expect != ATTRIBUTE (p));
+      }
+
+    if (keep_matching)
+      {
+	tail = p;
+	FORWARD (p);
+      }
+    else
+      {
+	va_end (list);
+	return;
+      }
+  }
+
+  /* Make reduction.  */
+  if (a != NO_NOTE)
+    a (head);
+
+  a68_make_sub (head, tail, result);
+  va_end (list);
+  if (z != NO_TICK)
+    *z = true;
+}
+
+/* Graciously ignore extra semicolons.  */
+
+static void
+ignore_superfluous_semicolons (NODE_T *p)
+{
+  /* This routine relaxes the parser a bit with respect to superfluous
+     semicolons, for instance "FI; OD". These provoke only a warning.  */
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      ignore_superfluous_semicolons (SUB (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)));
+	  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));
+	  if (PREVIOUS (p) != NO_NODE)
+	    NEXT (PREVIOUS (p)) = NEXT (p);
+	  PREVIOUS (NEXT (p)) = PREVIOUS (p);
+	}
+    }
+}
+
+/* Driver for the bottom-up parser.  */
+
+void
+a68_bottom_up_parser (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (!setjmp (A68_PARSER (bottom_up_crash_exit)))
+	{
+	  NODE_T *q;
+	  int error_count_0 = ERROR_COUNT (&A68_JOB);
+
+	  ignore_superfluous_semicolons (p);
+	  /* A program is "label sequence; particular program".  */
+	  a68_extract_labels (p, SERIAL_CLAUSE);
+	  /* Parse the program itself.  */
+	  for (q = p; q != NO_NODE; FORWARD (q))
+	    {
+	      bool siga = true;
+
+	      if (SUB (q) != NO_NODE)
+		reduce_branch (q, SOME_CLAUSE);
+	      while (siga)
+		{
+		  siga = false;
+		  reduce (q, NO_NOTE, &siga, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP);
+		  reduce (q, NO_NOTE, &siga, LABEL, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP);
+		}
+	    }
+	  /* Determine the encompassing enclosed clause.  */
+	  for (q = p; q != NO_NODE; FORWARD (q))
+	    {
+	      reduce (q, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP);
+	      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, PARALLEL_CLAUSE, STOP);
+	      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP);
+	      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP);
+	      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP);
+	      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP);
+	      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP);
+	      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, LOOP_CLAUSE, STOP);
+	    }
+	  /* Try reducing the particular program.  */
+	  q = p;
+	  reduce (q, NO_NOTE, NO_TICK, PARTICULAR_PROGRAM, LABEL, ENCLOSED_CLAUSE, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, PARTICULAR_PROGRAM, ENCLOSED_CLAUSE, STOP);
+	  if (SUB (p) == NO_NODE || NEXT (p) != NO_NODE)
+	    recover_from_error (p, PARTICULAR_PROGRAM,
+				((ERROR_COUNT (&A68_JOB) - error_count_0) > MAX_ERRORS));
+	}
+    }
+}
+
+/* Reduce the sub-phrase that starts one level down.  */
+
+static void
+reduce_branch (NODE_T *q, enum a68_attribute expect)
+{
+  /* If unsuccessful then the routine will at least copy the resulting
+     attribute as the parser can repair some faults. This gives less spurious
+     diagnostics.  */
+  if (q != NO_NODE && SUB (q) != NO_NODE)
+    {
+      NODE_T *p = SUB (q), *u = NO_NODE;
+      int error_count_0 = ERROR_COUNT (&A68_JOB), error_count_02;
+      bool declarer_pack = false, no_error;
+
+      switch (expect)
+	{
+	case STRUCTURE_PACK:
+	case PARAMETER_PACK:
+	case FORMAL_DECLARERS:
+	case UNION_PACK:
+	case SPECIFIER:
+	  declarer_pack = true;
+	  break;
+	default:
+	  declarer_pack = false;
+	}
+
+      /* Sample all info needed to decide whether a bold tag is operator or
+	 indicant.  Find the meaning of bold tags and quit in case of extra
+	 errors.  */
+      a68_extract_indicants (p);
+      if (!declarer_pack)
+	{
+	  a68_extract_priorities (p);
+	  a68_extract_operators (p);
+	}
+
+      error_count_02 = ERROR_COUNT (&A68_JOB);
+      a68_elaborate_bold_tags (p);
+      if ((ERROR_COUNT (&A68_JOB) - error_count_02) > 0)
+	longjmp (A68_PARSER (bottom_up_crash_exit), 1);
+
+      /* Now we can reduce declarers, knowing which bold tags are indicants.  */
+      reduce_declarers (p, expect);
+      /* Parse the phrase, as appropriate.  */
+      if (declarer_pack == false)
+	{
+	  error_count_02 = ERROR_COUNT (&A68_JOB);
+	  a68_extract_declarations (p);
+	  if ((ERROR_COUNT (&A68_JOB) - error_count_02) > 0)
+	    longjmp (A68_PARSER (bottom_up_crash_exit), 1);
+	  a68_extract_labels (p, expect);
+	  for (u = p; u != NO_NODE; FORWARD (u))
+	    {
+	      if (SUB (u) != NO_NODE)
+		{
+		  if (IS (u, FORMAT_DELIMITER_SYMBOL))
+		    reduce_branch (u, FORMAT_TEXT);
+		  else if (IS (u, FORMAT_OPEN_SYMBOL))
+		    reduce_branch (u, FORMAT_TEXT);
+		  else if (IS (u, OPEN_SYMBOL))
+		    {
+		      if (NEXT (u) != NO_NODE && IS (NEXT (u), THEN_BAR_SYMBOL))
+			reduce_branch (u, ENQUIRY_CLAUSE);
+		      else if (PREVIOUS (u) != NO_NODE && IS (PREVIOUS (u), PAR_SYMBOL))
+			reduce_branch (u, COLLATERAL_CLAUSE);
+		    }
+		  else if (a68_is_one_of (u, IF_SYMBOL, ELIF_SYMBOL, CASE_SYMBOL,
+					  OUSE_SYMBOL, WHILE_SYMBOL,
+					  ELSE_BAR_SYMBOL, STOP))
+		    reduce_branch (u, ENQUIRY_CLAUSE);
+		  else if (IS (u, BEGIN_SYMBOL))
+		    reduce_branch (u, SOME_CLAUSE);
+		  else if (a68_is_one_of (u, THEN_SYMBOL, ELSE_SYMBOL, OUT_SYMBOL,
+					  DO_SYMBOL, ALT_DO_SYMBOL, STOP))
+		    reduce_branch (u, SERIAL_CLAUSE);
+		  else if (IS (u, IN_SYMBOL))
+		    reduce_branch (u, COLLATERAL_CLAUSE);
+		  else if (IS (u, THEN_BAR_SYMBOL))
+		    reduce_branch (u, SOME_CLAUSE);
+		 else if (IS (u, LOOP_CLAUSE))
+		   reduce_branch (u, ENCLOSED_CLAUSE);
+		 else if (a68_is_one_of (u, FOR_SYMBOL, FROM_SYMBOL, BY_SYMBOL, TO_SYMBOL,
+					 STOP))
+		   reduce_branch (u, UNIT);
+		}
+	    }
+
+	  reduce_primary_parts (p, expect);
+	  if (expect != ENCLOSED_CLAUSE) {
+	    reduce_primaries (p, expect);
+	    if (expect == FORMAT_TEXT)
+	      reduce_format_texts (p);
+	    else
+	      {
+		reduce_secondaries (p);
+		reduce_formulae (p);
+		reduce_tertiaries (p);
+	      }
+	  }
+
+	  reduce_right_to_left_constructs (p);
+	  /* Reduce units and declarations.  */
+	  reduce_basic_declarations (p);
+	  reduce_units (p);
+	  reduce_erroneous_units (p);
+	  if (expect != UNIT)
+	    {
+	      if (expect == GENERIC_ARGUMENT)
+		reduce_generic_arguments (p);
+	      else if (expect == BOUNDS)
+		reduce_bounds (p);
+	      else
+		{
+		  reduce_declaration_lists (p);
+		  if (expect != DECLARATION_LIST)
+		    {
+		      for (u = p; u != NO_NODE; FORWARD (u))
+			{
+			  reduce (u, NO_NOTE, NO_TICK, LABELED_UNIT, LABEL, UNIT, STOP);
+			  reduce (u, NO_NOTE, NO_TICK, SPECIFIED_UNIT, SPECIFIER,
+				  COLON_SYMBOL, UNIT, STOP);
+			}
+		      if (expect == SOME_CLAUSE)
+			expect = serial_or_collateral (p);
+		      if (expect == SERIAL_CLAUSE)
+			reduce_serial_clauses (p);
+		      else if (expect == ENQUIRY_CLAUSE)
+			reduce_enquiry_clauses (p);
+		      else if (expect == COLLATERAL_CLAUSE)
+			reduce_collateral_clauses (p);
+		      else if (expect == ARGUMENT)
+			reduce_arguments (p);
+		    }
+		}
+	    }
+	  reduce_enclosed_clauses (p, expect);
+	}
+
+      /* Do something if parsing failed.  */
+      if (SUB (p) == NO_NODE || NEXT (p) != NO_NODE)
+	{
+	  recover_from_error (p, expect,
+			      ((ERROR_COUNT (&A68_JOB) - error_count_0) > MAX_ERRORS));
+	  no_error = false;
+	}
+      else
+	no_error = true;
+      ATTRIBUTE (q) = ATTRIBUTE (p);
+      if (no_error)
+	SUB (q) = SUB (p);
+    }
+}
+
+/* Driver for reducing declarers.  */
+
+static void
+reduce_declarers (NODE_T *p, enum a68_attribute expect)
+{
+  NODE_T *q; bool siga; /* Must be in this scope.  */
+
+  /* Reduce lengtheties.  */
+  for (q = p; q != NO_NODE; FORWARD (q))
+    {
+      siga = true;
+      reduce (q, NO_NOTE, NO_TICK, LONGETY, LONG_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, SHORTETY, SHORT_SYMBOL, STOP);
+      while (siga)
+	{
+	  siga = false;
+	  reduce (q, NO_NOTE, &siga, LONGETY, LONGETY, LONG_SYMBOL, STOP);
+	  reduce (q, NO_NOTE, &siga, SHORTETY, SHORTETY, SHORT_SYMBOL, STOP);
+	}
+    }
+
+  /* Reduce indicants.  */
+  for (q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, INT_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, REAL_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, BITS_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, BYTES_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, COMPLEX_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, COMPL_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, BOOL_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, CHAR_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, FORMAT_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, STRING_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, FILE_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, CHANNEL_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INDICANT, SEMA_SYMBOL, STOP);
+    }
+
+  /* Reduce standard stuff.  */
+  for (q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (a68_whether (q, LONGETY, INDICANT, STOP))
+	{
+	  int a;
+
+	  if (SUB_NEXT (q) == NO_NODE)
+	    {
+	      a68_error (NEXT (q),
+			 "Y expected", "appropriate declarer");
+	      reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP);
+	    }
+	  else
+	    {
+	      a = ATTRIBUTE (SUB_NEXT (q));
+
+	      if (a == INT_SYMBOL || a == REAL_SYMBOL || a == BITS_SYMBOL
+		  || a == BYTES_SYMBOL || a == COMPLEX_SYMBOL
+		  || a == COMPL_SYMBOL)
+		{
+		  reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP);
+		}
+	      else
+		{
+		  a68_error (NEXT (q),
+			     "Y expected", "appropriate declarer");
+		  reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP);
+		}
+	    }
+	}
+      else if (a68_whether (q, SHORTETY, INDICANT, STOP))
+	{
+	  int a;
+
+	  if (SUB_NEXT (q) == NO_NODE)
+	    {
+	      a68_error (NEXT (q),
+			 "Y expected", "appropriate declarer");
+	      reduce (q, NO_NOTE, NO_TICK, DECLARER, SHORTETY, INDICANT, STOP);
+	    }
+	  else
+	    {
+	      a = ATTRIBUTE (SUB_NEXT (q));
+	      if (a == INT_SYMBOL || a == REAL_SYMBOL || a == BITS_SYMBOL
+		  || a == BYTES_SYMBOL || a == COMPLEX_SYMBOL || a == COMPL_SYMBOL)
+		{
+		  reduce (q, NO_NOTE, NO_TICK, DECLARER, SHORTETY, INDICANT, STOP);
+		}
+	      else
+		{
+		  a68_error (NEXT (q),
+			     "Y expected", "appropriate declarer");
+		  reduce (q, NO_NOTE, NO_TICK, DECLARER, LONGETY, INDICANT, STOP);
+		}
+	    }
+	}
+    }
+
+  for (q = p; q != NO_NODE; FORWARD (q))
+    reduce (q, NO_NOTE, NO_TICK, DECLARER, INDICANT, STOP);
+
+  /* Reduce declarer lists.  */
+  for (q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (NEXT (q) != NO_NODE && SUB_NEXT (q) != NO_NODE)
+	{
+	  if (IS (q, STRUCT_SYMBOL))
+	    {
+	      reduce_branch (NEXT (q), STRUCTURE_PACK);
+	      reduce (q, NO_NOTE, NO_TICK, DECLARER, STRUCT_SYMBOL, STRUCTURE_PACK, STOP);
+	    }
+	  else if (IS (q, UNION_SYMBOL))
+	    {
+	      reduce_branch (NEXT (q), UNION_PACK);
+	      reduce (q, NO_NOTE, NO_TICK, DECLARER, UNION_SYMBOL, UNION_PACK, STOP);
+	    }
+	  else if (IS (q, PROC_SYMBOL))
+	    {
+	      if (a68_whether (q, PROC_SYMBOL, OPEN_SYMBOL, STOP))
+		{
+		  if (!a68_is_formal_bounds (SUB_NEXT (q)))
+		    reduce_branch (NEXT (q), FORMAL_DECLARERS);
+		}
+	    }
+	  else if (IS (q, OP_SYMBOL))
+	    {
+	      if (a68_whether (q, OP_SYMBOL, OPEN_SYMBOL, STOP))
+		{
+		  if (!a68_is_formal_bounds (SUB_NEXT (q)))
+		    reduce_branch (NEXT (q), FORMAL_DECLARERS);
+		}
+	    }
+	}
+    }
+
+  /* Reduce row, proc or op declarers.  */
+  siga = true;
+  while (siga)
+    {
+    siga = false;
+
+    for (q = p; q != NO_NODE; FORWARD (q))
+      {
+	/* FLEX DECL.  */
+	if (a68_whether (q, FLEX_SYMBOL, DECLARER, STOP))
+	  reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, DECLARER, STOP);
+
+	/* FLEX [] DECL.  */
+	if (a68_whether (q, FLEX_SYMBOL, SUB_SYMBOL, DECLARER, STOP) && SUB_NEXT (q) != NO_NODE)
+	  {
+	    reduce_branch (NEXT (q), BOUNDS);
+	    reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, BOUNDS, DECLARER, STOP);
+	    reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, FORMAL_BOUNDS, DECLARER, STOP);
+	  }
+
+	/* FLEX () DECL.  */
+	if (a68_whether (q, FLEX_SYMBOL, OPEN_SYMBOL, DECLARER, STOP) && SUB_NEXT (q) != NO_NODE)
+	  {
+	    if (!a68_whether (q, FLEX_SYMBOL, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP))
+	      {
+		reduce_branch (NEXT (q), BOUNDS);
+		reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, BOUNDS, DECLARER, STOP);
+		reduce (q, NO_NOTE, &siga, DECLARER, FLEX_SYMBOL, FORMAL_BOUNDS, DECLARER, STOP);
+	      }
+	  }
+
+	/* [] DECL.  */
+	if (a68_whether (q, SUB_SYMBOL, DECLARER, STOP) && SUB (q) != NO_NODE)
+	  {
+	    reduce_branch (q, BOUNDS);
+	    reduce (q, NO_NOTE, &siga, DECLARER, BOUNDS, DECLARER, STOP);
+	    reduce (q, NO_NOTE, &siga, DECLARER, FORMAL_BOUNDS, DECLARER, STOP);
+	  }
+
+	/* () DECL.  */
+	if (a68_whether (q, OPEN_SYMBOL, DECLARER, STOP) && SUB (q) != NO_NODE)
+	  {
+	    if (a68_whether (q, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP))
+	      {
+		/* Catch e.g. (INT i) () INT:.  */
+		if (a68_is_formal_bounds (SUB (q)))
+		  {
+		    reduce_branch (q, BOUNDS);
+		    reduce (q, NO_NOTE, &siga, DECLARER, BOUNDS, DECLARER, STOP);
+		    reduce (q, NO_NOTE, &siga, DECLARER, FORMAL_BOUNDS, DECLARER, STOP);
+		  }
+	      }
+	    else
+	      {
+		reduce_branch (q, BOUNDS);
+		reduce (q, NO_NOTE, &siga, DECLARER, BOUNDS, DECLARER, STOP);
+		reduce (q, NO_NOTE, &siga, DECLARER, FORMAL_BOUNDS, DECLARER, STOP);
+	      }
+	  }
+      }
+
+    /* PROC DECL, PROC () DECL, OP () DECL.  */
+    for (q = p; q != NO_NODE; FORWARD (q))
+      {
+	int a = ATTRIBUTE (q);
+	if (a == REF_SYMBOL)
+	  reduce (q, NO_NOTE, &siga, DECLARER, REF_SYMBOL, DECLARER, STOP);
+	else if (a == PROC_SYMBOL)
+	  {
+	    reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, DECLARER, STOP);
+	    reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, FORMAL_DECLARERS, DECLARER, STOP);
+	    reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, VOID_SYMBOL, STOP);
+	    reduce (q, NO_NOTE, &siga, DECLARER, PROC_SYMBOL, FORMAL_DECLARERS, VOID_SYMBOL, STOP);
+	  }
+	else if (a == OP_SYMBOL)
+	  {
+	    reduce (q, NO_NOTE, &siga, OPERATOR_PLAN, OP_SYMBOL, FORMAL_DECLARERS, DECLARER, STOP);
+	    reduce (q, NO_NOTE, &siga, OPERATOR_PLAN, OP_SYMBOL, FORMAL_DECLARERS, VOID_SYMBOL, STOP);
+	  }
+      }
+    }
+
+  /* Reduce packs etcetera.  */
+  if (expect == STRUCTURE_PACK)
+    {
+      for (q = p; q != NO_NODE; FORWARD (q))
+	{
+	  siga = true;
+	  while (siga)
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD, DECLARER, IDENTIFIER, STOP);
+	      reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD, STRUCTURED_FIELD, COMMA_SYMBOL, IDENTIFIER, STOP);
+	    }
+	}
+
+      for (q = p; q != NO_NODE; FORWARD (q))
+	{
+	  siga = true;
+	  while (siga)
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD, STOP);
+	      reduce (q, NO_NOTE, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD_LIST,
+		      COMMA_SYMBOL, STRUCTURED_FIELD, STOP);
+	      reduce (q, strange_separator, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD_LIST,
+		      STRUCTURED_FIELD, STOP);
+	      reduce (q, strange_separator, &siga, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD_LIST,
+		      SEMI_SYMBOL, STRUCTURED_FIELD, STOP);
+	    }
+	}
+    q = p;
+    reduce (q, NO_NOTE, NO_TICK, STRUCTURE_PACK, OPEN_SYMBOL, STRUCTURED_FIELD_LIST,
+	    CLOSE_SYMBOL, STOP);
+    }
+  else if (expect == PARAMETER_PACK)
+    {
+      for (q = p; q != NO_NODE; FORWARD (q))
+	{
+	  siga = true;
+	  while (siga)
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga, PARAMETER, DECLARER, IDENTIFIER, STOP);
+	      reduce (q, NO_NOTE, &siga, PARAMETER, PARAMETER, COMMA_SYMBOL, IDENTIFIER, STOP);
+	    }
+	}
+
+      for (q = p; q != NO_NODE; FORWARD (q))
+	{
+	  siga = true;
+	  while (siga)
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga, PARAMETER_LIST, PARAMETER, STOP);
+	      reduce (q, NO_NOTE, &siga, PARAMETER_LIST, PARAMETER_LIST, COMMA_SYMBOL, PARAMETER, STOP);
+	    }
+	}
+      q = p;
+      reduce (q, NO_NOTE, NO_TICK, PARAMETER_PACK, OPEN_SYMBOL, PARAMETER_LIST,
+	      CLOSE_SYMBOL, STOP);
+    }
+  else if (expect == FORMAL_DECLARERS)
+    {
+      for (q = p; q != NO_NODE; FORWARD (q))
+	{
+	  siga = true;
+	  while (siga)
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga, FORMAL_DECLARERS_LIST, DECLARER, STOP);
+	      reduce (q, NO_NOTE, &siga, FORMAL_DECLARERS_LIST, FORMAL_DECLARERS_LIST,
+		      COMMA_SYMBOL, DECLARER, STOP);
+	      reduce (q, strange_separator, &siga, FORMAL_DECLARERS_LIST, FORMAL_DECLARERS_LIST,
+		      SEMI_SYMBOL, DECLARER, STOP);
+	      reduce (q, strange_separator, &siga, FORMAL_DECLARERS_LIST, FORMAL_DECLARERS_LIST,
+		      DECLARER, STOP);
+	    }
+	}
+      q = p;
+      reduce (q, NO_NOTE, NO_TICK, FORMAL_DECLARERS, OPEN_SYMBOL, FORMAL_DECLARERS_LIST,
+	      CLOSE_SYMBOL, STOP);
+    }
+  else if (expect == UNION_PACK)
+    {
+      for (q = p; q != NO_NODE; FORWARD (q))
+	{
+	  siga = true;
+	  while (siga)
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, DECLARER, STOP);
+	      reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, VOID_SYMBOL, STOP);
+	      reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST,
+		      COMMA_SYMBOL, DECLARER, STOP);
+	      reduce (q, NO_NOTE, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST,
+		      COMMA_SYMBOL, VOID_SYMBOL, STOP);
+	      reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST,
+		      SEMI_SYMBOL, DECLARER, STOP);
+	      reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST,
+		      SEMI_SYMBOL, VOID_SYMBOL, STOP);
+	      reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST,
+		      DECLARER, STOP);
+	      reduce (q, strange_separator, &siga, UNION_DECLARER_LIST, UNION_DECLARER_LIST,
+		      VOID_SYMBOL, STOP);
+	    }
+	}
+      q = p;
+      reduce (q, NO_NOTE, NO_TICK, UNION_PACK, OPEN_SYMBOL, UNION_DECLARER_LIST,
+	      CLOSE_SYMBOL, STOP);
+    }
+  else if (expect == SPECIFIER)
+    {
+      reduce (p, NO_NOTE, NO_TICK, SPECIFIER, OPEN_SYMBOL, DECLARER, IDENTIFIER, CLOSE_SYMBOL, STOP);
+      reduce (p, NO_NOTE, NO_TICK, SPECIFIER, OPEN_SYMBOL, DECLARER, CLOSE_SYMBOL, STOP);
+      reduce (p, NO_NOTE, NO_TICK, SPECIFIER, OPEN_SYMBOL, VOID_SYMBOL, CLOSE_SYMBOL, STOP);
+    }
+  else
+    {
+      for (q = p; q != NO_NODE; FORWARD (q))
+	{
+	  if (a68_whether (q, OPEN_SYMBOL, COLON_SYMBOL, STOP)
+	      && !(expect == GENERIC_ARGUMENT || expect == BOUNDS))
+	    {
+	      if (a68_is_one_of (p, IN_SYMBOL, THEN_BAR_SYMBOL, STOP))
+		reduce_branch (q, SPECIFIER);
+	    }
+	  if (a68_whether (q, OPEN_SYMBOL, DECLARER, COLON_SYMBOL, STOP))
+	    reduce_branch (q, PARAMETER_PACK);
+	  if (a68_whether (q, OPEN_SYMBOL, VOID_SYMBOL, COLON_SYMBOL, STOP))
+	    reduce_branch (q, PARAMETER_PACK);
+	}
+    }
+}
+
+/* Handle cases that need reducing from right-to-left.  */
+
+static void
+reduce_right_to_left_constructs (NODE_T *p)
+{
+  /* Here are cases that need reducing from right-to-left whereas many things
+     can be reduced left-to-right. Assignations are a notable example; one
+     could discuss whether it would not be more natural to write 1 =: k instead
+     of k := 1. (jemarch: MARY did just that.)  The latter is said to be more
+     natural, or it could be just computing history. Meanwhile we use this
+     routine.  */
+
+  if (p != NO_NODE)
+    {
+      reduce_right_to_left_constructs (NEXT (p));
+      /* Assignations.  */
+      if (IS (p, TERTIARY))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, TERTIARY, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, IDENTITY_RELATION, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, AND_FUNCTION, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, OR_FUNCTION, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, ROUTINE_TEXT, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, JUMP, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, SKIP, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, ASSIGNATION, TERTIARY, ASSIGN_SYMBOL, ASSIGNATION, STOP);
+	}
+
+      /* Routine texts with parameter pack.  */
+    else if (IS (p, PARAMETER_PACK))
+      {
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, ASSIGNATION, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, IDENTITY_RELATION, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL,AND_FUNCTION, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, OR_FUNCTION, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, JUMP, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, SKIP, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, TERTIARY, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, DECLARER, COLON_SYMBOL, ROUTINE_TEXT, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, ASSIGNATION, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, IDENTITY_RELATION, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, AND_FUNCTION, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, OR_FUNCTION, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, JUMP, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, SKIP, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, TERTIARY, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		ROUTINE_TEXT, PARAMETER_PACK, VOID_SYMBOL, COLON_SYMBOL, ROUTINE_TEXT, STOP);
+      }
+      /* Routine texts without parameter pack. */
+    else if (IS (p, DECLARER))
+      {
+	if (!(PREVIOUS (p) != NO_NODE && IS (PREVIOUS (p), PARAMETER_PACK)))
+	  {
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, ASSIGNATION, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, IDENTITY_RELATION, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, AND_FUNCTION, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, OR_FUNCTION, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, JUMP, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, SKIP, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, TERTIARY, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, DECLARER, COLON_SYMBOL, ROUTINE_TEXT, STOP);
+	  }
+      }
+    else if (IS (p, VOID_SYMBOL))
+      {
+	if (!(PREVIOUS (p) != NO_NODE && IS (PREVIOUS (p), PARAMETER_PACK)))
+	  {
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, ASSIGNATION, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, IDENTITY_RELATION, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, AND_FUNCTION, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, OR_FUNCTION, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, JUMP, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, SKIP, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, TERTIARY, STOP);
+	    reduce (p, NO_NOTE, NO_TICK, ROUTINE_TEXT, VOID_SYMBOL, COLON_SYMBOL, ROUTINE_TEXT, STOP);
+	  }
+      }
+    }
+}
+
+/* Reduce primary elements.  */
+
+static void
+reduce_primary_parts (NODE_T *p, enum a68_attribute expect)
+{
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (a68_whether (q, IDENTIFIER, OF_SYMBOL, STOP))
+	ATTRIBUTE (q) = FIELD_IDENTIFIER;
+
+      reduce (q, NO_NOTE, NO_TICK, NIHIL, NIL_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, SKIP, SKIP_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, SELECTOR, FIELD_IDENTIFIER, OF_SYMBOL, STOP);
+      /* JUMPs without GOTO are resolved later.  */
+      reduce (q, NO_NOTE, NO_TICK, JUMP, GOTO_SYMBOL, IDENTIFIER, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, LONGETY, INT_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, LONGETY, REAL_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, LONGETY, BITS_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, SHORTETY, INT_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, SHORTETY, REAL_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, SHORTETY, BITS_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, INT_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, REAL_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, BITS_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, ROW_CHAR_DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, TRUE_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, FALSE_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DENOTATION, EMPTY_SYMBOL, STOP);
+      if (expect == SERIAL_CLAUSE || expect == ENQUIRY_CLAUSE || expect == SOME_CLAUSE)
+	{
+	  bool siga = true;
+	  while (siga)
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP);
+	      reduce (q, NO_NOTE, &siga, LABEL, LABEL, DEFINING_IDENTIFIER, COLON_SYMBOL, STOP);
+	    }
+	}
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, PARALLEL_CLAUSE, PAR_SYMBOL, COLLATERAL_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, PARALLEL_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, LOOP_CLAUSE, STOP);
+    }
+}
+
+/* Reduce primaries completely.  */
+
+static void
+reduce_primaries (NODE_T *p, enum a68_attribute expect)
+{
+  NODE_T *q = p;
+  while (q != NO_NODE)
+    {
+      bool fwd = true, siga;
+      /* Primaries excepts call and slice.  */
+      reduce (q, NO_NOTE, NO_TICK, PRIMARY, IDENTIFIER, STOP);
+      reduce (q, NO_NOTE, NO_TICK, PRIMARY, DENOTATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, CAST, DECLARER, ENCLOSED_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, CAST, VOID_SYMBOL, ENCLOSED_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, ASSERTION, ASSERT_SYMBOL, ENCLOSED_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, PRIMARY, CAST, STOP);
+      reduce (q, NO_NOTE, NO_TICK, PRIMARY, ENCLOSED_CLAUSE, STOP);
+      reduce (q, NO_NOTE, NO_TICK, PRIMARY, FORMAT_TEXT, STOP);
+      /* Call and slice.  */
+      siga = true;
+      while (siga)
+	{
+	  NODE_T *x = NEXT (q);
+
+	  siga = false;
+	  if (IS (q, PRIMARY) && x != NO_NODE)
+	    {
+	      if (IS (x, OPEN_SYMBOL))
+		{
+		  reduce_branch (NEXT (q), GENERIC_ARGUMENT);
+		  reduce (q, NO_NOTE, &siga, SPECIFICATION, PRIMARY, GENERIC_ARGUMENT, STOP);
+		  reduce (q, NO_NOTE, &siga, PRIMARY, SPECIFICATION, STOP);
+		}
+	      else if (IS (x, SUB_SYMBOL))
+		{
+		  reduce_branch (NEXT (q), GENERIC_ARGUMENT);
+		  reduce (q, NO_NOTE, &siga, SPECIFICATION, PRIMARY, GENERIC_ARGUMENT, STOP);
+		  reduce (q, NO_NOTE, &siga, PRIMARY, SPECIFICATION, STOP);
+		}
+	    }
+	}
+
+      /* Now that call and slice are known, reduce remaining ( .. ).  */
+      if (IS (q, OPEN_SYMBOL) && SUB (q) != NO_NODE)
+	{
+	  reduce_branch (q, SOME_CLAUSE);
+	  reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CLOSED_CLAUSE, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, COLLATERAL_CLAUSE, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONDITIONAL_CLAUSE, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CASE_CLAUSE, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, ENCLOSED_CLAUSE, CONFORMITY_CLAUSE, STOP);
+	  if (PREVIOUS (q) != NO_NODE)
+	    {
+	      BACKWARD (q);
+	      fwd = false;
+	    }
+	}
+
+      /* Format text items.  */
+      if (expect == FORMAT_TEXT)
+	{
+	  NODE_T *r;
+
+	  for (r = p; r != NO_NODE; FORWARD (r))
+	    {
+	      reduce (r, NO_NOTE, NO_TICK, DYNAMIC_REPLICATOR, FORMAT_ITEM_N, ENCLOSED_CLAUSE, STOP);
+	      reduce (r, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_G, ENCLOSED_CLAUSE, STOP);
+	      reduce (r, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_H, ENCLOSED_CLAUSE, STOP);
+	      reduce (r, NO_NOTE, NO_TICK, FORMAT_PATTERN, FORMAT_ITEM_F, ENCLOSED_CLAUSE, STOP);
+	    }
+	}
+      if (fwd)
+	FORWARD (q);
+    }
+}
+
+/* Enforce that ambiguous patterns are separated by commas.  */
+
+static void
+ambiguous_patterns (NODE_T *p)
+{
+  /* Example: printf (($+d.2d +d.2d$, 1, 2)) can produce either "+1.00 +2.00"
+     or "+1+002.00". A comma must be supplied to resolve the ambiguity.
+
+     The obvious thing would be to weave this into the syntax, letting the BU
+     parser sort it out. But the C-style patterns do not suffer from Algol 68
+     pattern ambiguity, so by solving it this way we maximise freedom in
+     writing the patterns as we want without introducing two "kinds" of
+     patterns, and so we have shorter routines for implementing formatted
+     transput. This is a pragmatic system.  */
+  NODE_T *q, *last_pat = NO_NODE;
+
+  for (q = p; q != NO_NODE; FORWARD (q))
+    {
+      switch (ATTRIBUTE (q))
+	{
+	  /* These are the potentially ambiguous patterns.  */
+	case INTEGRAL_PATTERN:
+	case REAL_PATTERN:
+	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));
+	  last_pat = q;
+	  break;
+	case COMMA_SYMBOL:
+	  last_pat = NO_NODE;
+	  break;
+	default:
+	  break;
+	}
+    }
+}
+
+/* Reduce C format texts completely.  */
+
+static void
+reduce_c_pattern (NODE_T *p, int pr, int let)
+{
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_POINT, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, FORMAT_ITEM_POINT, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_PLUS, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_POINT, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, REPLICATOR, FORMAT_ITEM_POINT, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, FORMAT_ITEM_POINT, REPLICATOR,
+	      let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, REPLICATOR, let, STOP);
+      reduce (q, NO_NOTE, NO_TICK, pr,
+	      FORMAT_ITEM_ESCAPE, FORMAT_ITEM_MINUS, FORMAT_ITEM_PLUS, REPLICATOR, FORMAT_ITEM_POINT,
+	      REPLICATOR, let, STOP);
+  }
+}
+
+/* Reduce format texts completely.  */
+
+static void
+reduce_format_texts (NODE_T *p)
+{
+  /* Replicators.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, REPLICATOR, STATIC_REPLICATOR, STOP);
+      reduce (q, NO_NOTE, NO_TICK, REPLICATOR, DYNAMIC_REPLICATOR, STOP);
+    }
+
+  /* "OTHER" patterns.  */
+  reduce_c_pattern (p, BITS_C_PATTERN, FORMAT_ITEM_B);
+  reduce_c_pattern (p, BITS_C_PATTERN, FORMAT_ITEM_O);
+  reduce_c_pattern (p, BITS_C_PATTERN, FORMAT_ITEM_X);
+  reduce_c_pattern (p, CHAR_C_PATTERN, FORMAT_ITEM_C);
+  reduce_c_pattern (p, FIXED_C_PATTERN, FORMAT_ITEM_F);
+  reduce_c_pattern (p, FLOAT_C_PATTERN, FORMAT_ITEM_E);
+  reduce_c_pattern (p, GENERAL_C_PATTERN, FORMAT_ITEM_G);
+  reduce_c_pattern (p, INTEGRAL_C_PATTERN, FORMAT_ITEM_D);
+  reduce_c_pattern (p, INTEGRAL_C_PATTERN, FORMAT_ITEM_I);
+  reduce_c_pattern (p, STRING_C_PATTERN, FORMAT_ITEM_S);
+  /* Radix frames.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    reduce (q, NO_NOTE, NO_TICK, RADIX_FRAME, REPLICATOR, FORMAT_ITEM_R, STOP);
+
+  /* Insertions.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_X, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_Y, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_L, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_P, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_Q, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INSERTION, FORMAT_ITEM_K, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INSERTION, LITERAL, STOP);
+    }
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, INSERTION, REPLICATOR, INSERTION, STOP);
+    }
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      bool siga = true;
+      while (siga)
+	{
+	  siga = false;
+	  reduce (q, NO_NOTE, &siga, INSERTION, INSERTION, INSERTION, STOP);
+	}
+    }
+
+  /* Replicated suppressible frames.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, REPLICATOR, FORMAT_ITEM_S, FORMAT_ITEM_A, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, REPLICATOR, FORMAT_ITEM_S, FORMAT_ITEM_Z, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, REPLICATOR, FORMAT_ITEM_S, FORMAT_ITEM_D, STOP);
+    }
+
+  /* Suppressible frames.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_A, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_Z, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_D, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_E_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_E, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_POINT_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_POINT, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_I_FRAME, FORMAT_ITEM_S, FORMAT_ITEM_I, STOP);
+    }
+
+  /* Replicated frames.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, REPLICATOR, FORMAT_ITEM_A, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, REPLICATOR, FORMAT_ITEM_Z, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, REPLICATOR, FORMAT_ITEM_D, STOP);
+    }
+
+  /* Frames.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, FORMAT_ITEM_A, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, FORMAT_ITEM_Z, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, FORMAT_ITEM_D, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_E_FRAME, FORMAT_ITEM_E, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_POINT_FRAME, FORMAT_ITEM_POINT, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_I_FRAME, FORMAT_ITEM_I, STOP);
+    }
+
+  /* Frames with an insertion.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_A_FRAME, INSERTION, FORMAT_A_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_Z_FRAME, INSERTION, FORMAT_Z_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_D_FRAME, INSERTION, FORMAT_D_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_E_FRAME, INSERTION, FORMAT_E_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_POINT_FRAME, INSERTION, FORMAT_POINT_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMAT_I_FRAME, INSERTION, FORMAT_I_FRAME, STOP);
+    }
+
+  /* String patterns.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    reduce (q, NO_NOTE, NO_TICK, STRING_PATTERN, REPLICATOR, FORMAT_A_FRAME, STOP);
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    reduce (q, NO_NOTE, NO_TICK, STRING_PATTERN, FORMAT_A_FRAME, STOP);
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      bool siga = true;
+      while (siga)
+	{
+	  siga = false;
+	  reduce (q, NO_NOTE, &siga, STRING_PATTERN, STRING_PATTERN, STRING_PATTERN, STOP);
+	  reduce (q, NO_NOTE, &siga, STRING_PATTERN, STRING_PATTERN, INSERTION, STRING_PATTERN, STOP);
+	}
+    }
+
+  /* Integral moulds.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, INTEGRAL_MOULD, FORMAT_Z_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INTEGRAL_MOULD, FORMAT_D_FRAME, STOP);
+    }
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      bool siga = true;
+      while (siga)
+	{
+	  siga = false;
+	  reduce (q, NO_NOTE, &siga, INTEGRAL_MOULD, INTEGRAL_MOULD, INTEGRAL_MOULD, STOP);
+	  reduce (q, NO_NOTE, &siga, INTEGRAL_MOULD, INTEGRAL_MOULD, INSERTION, STOP);
+	}
+    }
+
+  /* Sign moulds.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_ITEM_PLUS, STOP);
+      reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_ITEM_MINUS, STOP);
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, FORMAT_ITEM_PLUS, STOP);
+      reduce (q, NO_NOTE, NO_TICK, SIGN_MOULD, FORMAT_ITEM_MINUS, STOP);
+    }
+
+  /* Exponent frames.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, EXPONENT_FRAME, FORMAT_E_FRAME, SIGN_MOULD, INTEGRAL_MOULD, STOP);
+      reduce (q, NO_NOTE, NO_TICK, EXPONENT_FRAME, FORMAT_E_FRAME, INTEGRAL_MOULD, STOP);
+    }
+
+  /* Real patterns.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME,
+	      STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, EXPONENT_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, FORMAT_POINT_FRAME, STOP);
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP);
+      reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, EXPONENT_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, FORMAT_POINT_FRAME, STOP);
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, EXPONENT_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, INTEGRAL_MOULD, FORMAT_POINT_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, FORMAT_POINT_FRAME, INTEGRAL_MOULD, EXPONENT_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      REAL_PATTERN, FORMAT_POINT_FRAME, INTEGRAL_MOULD, STOP);
+  }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, EXPONENT_FRAME, STOP);
+      reduce (q, NO_NOTE, NO_TICK, REAL_PATTERN, INTEGRAL_MOULD, EXPONENT_FRAME, STOP);
+    }
+
+  /* Complex patterns.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    reduce (q, NO_NOTE, NO_TICK, COMPLEX_PATTERN, REAL_PATTERN, FORMAT_I_FRAME, REAL_PATTERN, STOP);
+
+  /* Bits patterns.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    reduce (q, NO_NOTE, NO_TICK, BITS_PATTERN, RADIX_FRAME, INTEGRAL_MOULD, STOP);
+
+  /* Integral patterns.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, INTEGRAL_PATTERN, SIGN_MOULD, INTEGRAL_MOULD, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INTEGRAL_PATTERN, INTEGRAL_MOULD, STOP);
+    }
+
+  /* Patterns.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, BOOLEAN_PATTERN, FORMAT_ITEM_B, COLLECTION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, CHOICE_PATTERN, FORMAT_ITEM_C, COLLECTION, STOP);
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, BOOLEAN_PATTERN, FORMAT_ITEM_B, STOP);
+      reduce (q, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_G, STOP);
+      reduce (q, NO_NOTE, NO_TICK, GENERAL_PATTERN, FORMAT_ITEM_H, STOP);
+    }
+
+  ambiguous_patterns (p);
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, a68_extension, NO_TICK, A68_PATTERN, BITS_C_PATTERN, STOP);
+      reduce (q, a68_extension, NO_TICK, A68_PATTERN, CHAR_C_PATTERN, STOP);
+      reduce (q, a68_extension, NO_TICK, A68_PATTERN, FIXED_C_PATTERN, STOP);
+      reduce (q, a68_extension, NO_TICK, A68_PATTERN, FLOAT_C_PATTERN, STOP);
+      reduce (q, a68_extension, NO_TICK, A68_PATTERN, GENERAL_C_PATTERN, STOP);
+      reduce (q, a68_extension, NO_TICK, A68_PATTERN, INTEGRAL_C_PATTERN, STOP);
+      reduce (q, a68_extension, NO_TICK, A68_PATTERN, STRING_C_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, BITS_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, BOOLEAN_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, CHOICE_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, COMPLEX_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, FORMAT_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, GENERAL_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, INTEGRAL_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, REAL_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, A68_PATTERN, STRING_PATTERN, STOP);
+    }
+
+  /* Pictures.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, PICTURE, INSERTION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, PICTURE, A68_PATTERN, STOP);
+      reduce (q, NO_NOTE, NO_TICK, PICTURE, COLLECTION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, PICTURE, REPLICATOR, COLLECTION, STOP);
+    }
+
+  /* Picture lists.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, PICTURE))
+	{
+	  bool siga = true;
+	  reduce (q, NO_NOTE, NO_TICK, PICTURE_LIST, PICTURE, STOP);
+	  while (siga)
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga, PICTURE_LIST, PICTURE_LIST, COMMA_SYMBOL, PICTURE, STOP);
+	      /* We filtered ambiguous patterns, so commas may be omitted  */
+	      reduce (q, NO_NOTE, &siga, PICTURE_LIST, PICTURE_LIST, PICTURE, STOP);
+	    }
+	}
+    }
+}
+
+/* Reduce secondaries completely.  */
+
+static void
+reduce_secondaries (NODE_T *p)
+{
+  NODE_T *q; bool siga;
+
+  for (q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, SECONDARY, PRIMARY, STOP);
+      reduce (q, NO_NOTE, NO_TICK, GENERATOR, LOC_SYMBOL, DECLARER, STOP);
+      reduce (q, NO_NOTE, NO_TICK, GENERATOR, HEAP_SYMBOL, DECLARER, STOP);
+      reduce (q, NO_NOTE, NO_TICK, SECONDARY, GENERATOR, STOP);
+    }
+  siga = true;
+  while (siga)
+    {
+      siga = false;
+      for (q = p; NEXT (q) != NO_NODE; FORWARD (q))
+	;
+      for (; q != NO_NODE; BACKWARD (q))
+	{
+	  reduce (q, NO_NOTE, &siga, SELECTION, SELECTOR, SECONDARY, STOP);
+	  reduce (q, NO_NOTE, &siga, SECONDARY, SELECTION, STOP);
+	}
+    }
+}
+
+/* Whether Q is an operator with priority K.  */
+
+static int
+operator_with_priority (NODE_T *q, int k)
+{
+  return NEXT (q) != NO_NODE
+    && ATTRIBUTE (NEXT (q)) == OPERATOR && PRIO (INFO (NEXT (q))) == k;
+}
+
+/* Reduce formulae.  */
+
+static void
+reduce_formulae (NODE_T * p)
+{
+  NODE_T *q = p;
+
+  while (q != NO_NODE)
+    {
+      if (a68_is_one_of (q, OPERATOR, SECONDARY, STOP))
+	q = reduce_dyadic (q, STOP);
+      else
+	FORWARD (q);
+    }
+
+  /* Reduce the expression.  */
+  for (int prio = MAX_PRIORITY; prio >= 0; prio--)
+    {
+      for (q = p; q != NO_NODE; FORWARD (q))
+	{
+	  if (operator_with_priority (q, prio))
+	    {
+	      bool siga = false;
+	      NODE_T *op = NEXT (q);
+	      if (IS (q, SECONDARY))
+		{
+		  reduce (q, NO_NOTE, &siga, FORMULA, SECONDARY, OPERATOR, SECONDARY, STOP);
+		  reduce (q, NO_NOTE, &siga, FORMULA, SECONDARY, OPERATOR, MONADIC_FORMULA, STOP);
+		  reduce (q, NO_NOTE, &siga, FORMULA, SECONDARY, OPERATOR, FORMULA, STOP);
+		}
+	      else if (IS (q, MONADIC_FORMULA))
+		{
+		  reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, SECONDARY, STOP);
+		  reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, MONADIC_FORMULA, STOP);
+		  reduce (q, NO_NOTE, &siga, FORMULA, MONADIC_FORMULA, OPERATOR, FORMULA, STOP);
+		}
+	      if (prio == 0 && siga)
+		a68_error (op, "S has no priority declaration");
+	      siga = true;
+	      while (siga)
+		{
+		  NODE_T *op2 = NEXT (q);
+		  siga = false;
+		  if (operator_with_priority (q, prio))
+		    reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, SECONDARY, STOP);
+		  if (operator_with_priority (q, prio))
+		    reduce (q, NO_NOTE, &siga, FORMULA, FORMULA, OPERATOR, MONADIC_FORMULA, STOP);
+		  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");
+		}
+	    }
+	}
+    }
+}
+
+/* Reduce dyadic expressions.  */
+
+static NODE_T *
+reduce_dyadic (NODE_T *p, int u)
+{
+  /* We work inside out - higher priority expressions get reduced first.  */
+  if (u > MAX_PRIORITY)
+    {
+      if (p == NO_NODE)
+	return NO_NODE;
+      else if (IS (p, OPERATOR))
+	{
+	  /* Reduce monadic formulas.  */
+	  NODE_T *q = p;
+	  bool siga;
+	  do
+	    {
+	      PRIO (INFO (q)) = 10;
+	      siga = ((NEXT (q) != NO_NODE) && (IS (NEXT (q), OPERATOR)));
+	      if (siga)
+		FORWARD (q);
+	    }
+	  while (siga);
+	  reduce (q, NO_NOTE, NO_TICK, MONADIC_FORMULA, OPERATOR, SECONDARY, STOP);
+	  while (q != p)
+	    {
+	      BACKWARD (q);
+	      reduce (q, NO_NOTE, NO_TICK, MONADIC_FORMULA, OPERATOR, MONADIC_FORMULA, STOP);
+	    }
+	}
+      FORWARD (p);
+    }
+  else
+    {
+      p = reduce_dyadic (p, u + 1);
+      while (p != NO_NODE && IS (p, OPERATOR) && PRIO (INFO (p)) == u)
+	{
+	  FORWARD (p);
+	  p = reduce_dyadic (p, u + 1);
+	}
+    }
+  return p;
+}
+
+/* Reduce tertiaries completely.  */
+
+static void
+reduce_tertiaries (NODE_T *p)
+{
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, TERTIARY, NIHIL, STOP);
+      reduce (q, NO_NOTE, NO_TICK, FORMULA, MONADIC_FORMULA, STOP);
+      reduce (q, NO_NOTE, NO_TICK, TERTIARY, FORMULA, STOP);
+      reduce (q, NO_NOTE, NO_TICK, TERTIARY, SECONDARY, STOP);
+    }
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, IDENTITY_RELATION, TERTIARY, IS_SYMBOL, TERTIARY, STOP);
+      reduce (q, NO_NOTE, NO_TICK, IDENTITY_RELATION, TERTIARY, ISNT_SYMBOL, TERTIARY, STOP);
+    }
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, AND_FUNCTION, TERTIARY, ANDF_SYMBOL, TERTIARY, STOP);
+      reduce (q, NO_NOTE, NO_TICK, OR_FUNCTION, TERTIARY, ORF_SYMBOL, TERTIARY, STOP);
+    }
+}
+
+/* Reduce units. */
+
+static void
+reduce_units (NODE_T * p)
+{
+  /* Stray ~ is a SKIP.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, OPERATOR) && IS_LITERALLY (q, "~"))
+	ATTRIBUTE (q) = SKIP;
+    }
+
+  /* Reduce units.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, UNIT, ASSIGNATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, UNIT, IDENTITY_RELATION, STOP);
+      reduce (q, a68_extension, NO_TICK, UNIT, AND_FUNCTION, STOP);
+      reduce (q, a68_extension, NO_TICK, UNIT, OR_FUNCTION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, UNIT, ROUTINE_TEXT, STOP);
+      reduce (q, NO_NOTE, NO_TICK, UNIT, JUMP, STOP);
+      reduce (q, NO_NOTE, NO_TICK, UNIT, SKIP, STOP);
+      reduce (q, NO_NOTE, NO_TICK, UNIT, TERTIARY, STOP);
+      reduce (q, NO_NOTE, NO_TICK, UNIT, ASSERTION, STOP);
+    }
+}
+
+/* Reduce_generic arguments.  */
+
+static void
+reduce_generic_arguments (NODE_T *p)
+{
+  NODE_T *q; bool siga; /* In this scope.  */
+
+  for (q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, UNIT))
+	{
+	  reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, UNIT, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, AT_SYMBOL, UNIT, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, COLON_SYMBOL, STOP);
+	}
+      else if (IS (q, COLON_SYMBOL))
+	{
+	  reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, UNIT, AT_SYMBOL, UNIT, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, UNIT, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, AT_SYMBOL, UNIT, STOP);
+	  reduce (q, NO_NOTE, NO_TICK, TRIMMER, COLON_SYMBOL, STOP);
+	}
+    }
+
+  for (q = p; q != NO_NODE; FORWARD (q))
+    reduce (q, NO_NOTE, NO_TICK, TRIMMER, UNIT, AT_SYMBOL, UNIT, STOP);
+  for (q = p; q != NO_NODE; FORWARD (q))
+    reduce (q, NO_NOTE, NO_TICK, TRIMMER, AT_SYMBOL, UNIT, STOP);
+  for (q = p; q && NEXT (q); FORWARD (q))
+    {
+      if (IS (q, COMMA_SYMBOL))
+	{
+	  if (!(ATTRIBUTE (NEXT (q)) == UNIT || ATTRIBUTE (NEXT (q)) == TRIMMER))
+	    pad_node (q, TRIMMER);
+	}
+      else
+	{
+	  if (IS (NEXT (q), COMMA_SYMBOL))
+	    {
+	      if (!IS (q, UNIT) && !IS (q, TRIMMER))
+		pad_node (q, TRIMMER);
+	    }
+	}
+    }
+
+  q = NEXT (p);
+  if (q == NO_NODE)
+    gcc_unreachable ();
+  reduce (q, NO_NOTE, NO_TICK, GENERIC_ARGUMENT_LIST, UNIT, STOP);
+  reduce (q, NO_NOTE, NO_TICK, GENERIC_ARGUMENT_LIST, TRIMMER, STOP);
+  do
+    {
+      siga = false;
+      reduce (q, NO_NOTE, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, COMMA_SYMBOL, UNIT, STOP);
+      reduce (q, NO_NOTE, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, COMMA_SYMBOL, TRIMMER, STOP);
+      reduce (q, strange_separator, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, UNIT, STOP);
+      reduce (q, strange_separator, &siga, GENERIC_ARGUMENT_LIST, GENERIC_ARGUMENT_LIST, TRIMMER, STOP);
+    }
+  while (siga);
+}
+
+/* Reduce bounds.  */
+
+static void
+reduce_bounds (NODE_T *p)
+{
+  NODE_T *q; bool siga;
+
+  for (q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, BOUND, UNIT, COLON_SYMBOL, UNIT, STOP);
+      reduce (q, NO_NOTE, NO_TICK, BOUND, UNIT, STOP);
+    }
+  q = NEXT (p);
+  reduce (q, NO_NOTE, NO_TICK, BOUNDS_LIST, BOUND, STOP);
+  reduce (q, NO_NOTE, NO_TICK, FORMAL_BOUNDS_LIST, COMMA_SYMBOL, STOP);
+  reduce (q, NO_NOTE, NO_TICK, ALT_FORMAL_BOUNDS_LIST, COLON_SYMBOL, STOP);
+  do
+    {
+      siga = false;
+      reduce (q, NO_NOTE, &siga, BOUNDS_LIST, BOUNDS_LIST, COMMA_SYMBOL, BOUND, STOP);
+      reduce (q, NO_NOTE, &siga, FORMAL_BOUNDS_LIST, FORMAL_BOUNDS_LIST, COMMA_SYMBOL, STOP);
+      reduce (q, NO_NOTE, &siga, ALT_FORMAL_BOUNDS_LIST, FORMAL_BOUNDS_LIST, COLON_SYMBOL, STOP);
+      reduce (q, NO_NOTE, &siga, FORMAL_BOUNDS_LIST, ALT_FORMAL_BOUNDS_LIST, COMMA_SYMBOL, STOP);
+      reduce (q, strange_separator, &siga, BOUNDS_LIST, BOUNDS_LIST, BOUND, STOP);
+    }
+  while (siga);
+}
+
+/* Reduce argument packs.  */
+
+static void
+reduce_arguments (NODE_T *p)
+{
+  if (NEXT (p) != NO_NODE)
+    {
+      NODE_T *q = NEXT (p);
+      bool siga;
+      reduce (q, NO_NOTE, NO_TICK, ARGUMENT_LIST, UNIT, STOP);
+      do
+	{
+	  siga = false;
+	  reduce (q, NO_NOTE, &siga, ARGUMENT_LIST, ARGUMENT_LIST, COMMA_SYMBOL, UNIT, STOP);
+	  reduce (q, strange_separator, &siga, ARGUMENT_LIST, ARGUMENT_LIST, UNIT, STOP);
+	}
+      while (siga);
+    }
+}
+
+/* Reduce declarations.  */
+
+static void
+reduce_basic_declarations (NODE_T *p)
+{
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK,
+	      PRIORITY_DECLARATION, PRIO_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, PRIORITY, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      MODE_DECLARATION, MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, DECLARER, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      MODE_DECLARATION, MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, VOID_SYMBOL, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      PROCEDURE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, EQUALS_SYMBOL, ROUTINE_TEXT, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      PROCEDURE_VARIABLE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, ROUTINE_TEXT,
+	      STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      PROCEDURE_VARIABLE_DECLARATION, QUALIFIER, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL,
+	      ROUTINE_TEXT, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      BRIEF_OPERATOR_DECLARATION, OP_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, ROUTINE_TEXT, STOP);
+      /* Errors.  */
+      reduce (q, strange_tokens, NO_TICK,
+	      PRIORITY_DECLARATION, PRIO_SYMBOL, -DEFINING_OPERATOR, -EQUALS_SYMBOL, -PRIORITY, STOP);
+      reduce (q, strange_tokens, NO_TICK,
+	      MODE_DECLARATION, MODE_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL, -DECLARER, STOP);
+      reduce (q, strange_tokens, NO_TICK,
+	      PROCEDURE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, EQUALS_SYMBOL, -ROUTINE_TEXT, STOP);
+      reduce (q, strange_tokens, NO_TICK,
+	      PROCEDURE_VARIABLE_DECLARATION, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, -ROUTINE_TEXT,
+	      STOP);
+      reduce (q, strange_tokens, NO_TICK,
+	      PROCEDURE_VARIABLE_DECLARATION, QUALIFIER, PROC_SYMBOL, DEFINING_IDENTIFIER, ASSIGN_SYMBOL,
+	      -ROUTINE_TEXT, STOP);
+      reduce (q, strange_tokens, NO_TICK,
+	      BRIEF_OPERATOR_DECLARATION, OP_SYMBOL, DEFINING_OPERATOR, EQUALS_SYMBOL, -ROUTINE_TEXT, STOP);
+      /* Errors. WILDCARD catches TERTIARY which catches IDENTIFIER.  */
+      reduce (q, strange_tokens, NO_TICK, PROCEDURE_DECLARATION, PROC_SYMBOL, WILDCARD, ROUTINE_TEXT, STOP);
+    }
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      bool siga;
+      do
+	{
+	  siga = false;
+	  reduce (q, NO_NOTE, &siga,
+		  PRIORITY_DECLARATION, PRIORITY_DECLARATION, COMMA_SYMBOL, DEFINING_OPERATOR,
+		  EQUALS_SYMBOL, PRIORITY, STOP);
+	  reduce (q, NO_NOTE, &siga,
+		  MODE_DECLARATION, MODE_DECLARATION, COMMA_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL,
+		  DECLARER, STOP);
+	  reduce (q, NO_NOTE, &siga,
+		  MODE_DECLARATION, MODE_DECLARATION, COMMA_SYMBOL, DEFINING_INDICANT, EQUALS_SYMBOL,
+		  VOID_SYMBOL, STOP);
+	  reduce (q, NO_NOTE, &siga,
+		  PROCEDURE_DECLARATION, PROCEDURE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER,
+		  EQUALS_SYMBOL, ROUTINE_TEXT, STOP);
+	  reduce (q, NO_NOTE, &siga,
+		  PROCEDURE_VARIABLE_DECLARATION, PROCEDURE_VARIABLE_DECLARATION, COMMA_SYMBOL,
+		  DEFINING_IDENTIFIER, ASSIGN_SYMBOL, ROUTINE_TEXT, STOP);
+	  reduce (q, NO_NOTE, &siga,
+		  BRIEF_OPERATOR_DECLARATION, BRIEF_OPERATOR_DECLARATION, COMMA_SYMBOL,
+		  DEFINING_OPERATOR, EQUALS_SYMBOL, ROUTINE_TEXT, STOP);
+	  /* Errors. WILDCARD catches TERTIARY which catches IDENTIFIER.  */
+	  reduce (q, strange_tokens, &siga,
+		  PROCEDURE_DECLARATION, PROCEDURE_DECLARATION, COMMA_SYMBOL, WILDCARD, ROUTINE_TEXT, STOP);
+	}
+      while (siga);
+    }
+}
+
+/* Reduce declaration lists.  */
+
+static void
+reduce_declaration_lists (NODE_T *p)
+{
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK,
+	      IDENTITY_DECLARATION, DECLARER, DEFINING_IDENTIFIER, EQUALS_SYMBOL, UNIT, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      VARIABLE_DECLARATION, QUALIFIER, DECLARER, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      VARIABLE_DECLARATION, QUALIFIER, DECLARER, DEFINING_IDENTIFIER, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      VARIABLE_DECLARATION, DECLARER, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP);
+      reduce (q, NO_NOTE, NO_TICK,
+	      VARIABLE_DECLARATION, DECLARER, DEFINING_IDENTIFIER, STOP);
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      bool siga;
+      do
+	{
+	  siga = false;
+	  reduce (q, NO_NOTE, &siga,
+		  IDENTITY_DECLARATION, IDENTITY_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER,
+		  EQUALS_SYMBOL, UNIT, STOP);
+	  reduce (q, NO_NOTE, &siga,
+		  VARIABLE_DECLARATION, VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER,
+		  ASSIGN_SYMBOL, UNIT, STOP);
+	  if (!a68_whether (q, VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER,
+			    ASSIGN_SYMBOL, UNIT, STOP))
+	    reduce (q, NO_NOTE, &siga,
+		    VARIABLE_DECLARATION, VARIABLE_DECLARATION, COMMA_SYMBOL, DEFINING_IDENTIFIER, STOP);
+	}
+      while (siga);
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK,
+	      OPERATOR_DECLARATION, OPERATOR_PLAN, DEFINING_OPERATOR, EQUALS_SYMBOL, UNIT, STOP);
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      bool siga;
+      do
+	{
+	  siga = false;
+	  reduce (q, NO_NOTE, &siga,
+		  OPERATOR_DECLARATION, OPERATOR_DECLARATION, COMMA_SYMBOL, DEFINING_OPERATOR,
+		  EQUALS_SYMBOL, UNIT, STOP);
+	}
+      while (siga);
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, MODE_DECLARATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, PRIORITY_DECLARATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, BRIEF_OPERATOR_DECLARATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, OPERATOR_DECLARATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, IDENTITY_DECLARATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, PROCEDURE_DECLARATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, PROCEDURE_VARIABLE_DECLARATION, STOP);
+      reduce (q, NO_NOTE, NO_TICK, DECLARATION_LIST, VARIABLE_DECLARATION, STOP);
+    }
+
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      bool siga;
+      do
+	{
+	  siga = false;
+	  reduce (q, NO_NOTE, &siga,
+		  DECLARATION_LIST, DECLARATION_LIST, COMMA_SYMBOL, DECLARATION_LIST, STOP);
+	}
+      while (siga);
+    }
+}
+
+/* Reduce serial clauses.  */
+
+static void
+reduce_serial_clauses (NODE_T *p)
+{
+  if (NEXT (p) != NO_NODE)
+    {
+      NODE_T *q = NEXT (p), *u;
+      bool siga, label_seen;
+      /* Check wrong exits.  */
+      for (u = q; u != NO_NODE; FORWARD (u))
+	{
+	  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");
+	    }
+	}
+
+      /* Check wrong jumps and declarations.  */
+      for (u = q, label_seen = false; u != NO_NODE; FORWARD (u))
+	{
+	  if (IS (u, LABELED_UNIT))
+	    label_seen = true;
+	  else if (IS (u, DECLARATION_LIST))
+	    {
+	      if (label_seen)
+		a68_error (u, "declaration cannot follow a labeled unit");
+	    }
+	}
+
+      /* Reduce serial clauses.  */
+      reduce (q, NO_NOTE, NO_TICK, SERIAL_CLAUSE, LABELED_UNIT, STOP);
+      reduce (q, NO_NOTE, NO_TICK, SERIAL_CLAUSE, UNIT, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INITIALISER_SERIES, DECLARATION_LIST, STOP);
+      do
+	{
+	  siga = false;
+	  if (IS (q, SERIAL_CLAUSE))
+	    {
+	      reduce (q, NO_NOTE, &siga,
+		      SERIAL_CLAUSE, SERIAL_CLAUSE, SEMI_SYMBOL, UNIT, STOP);
+	      reduce (q, NO_NOTE, &siga,
+		      SERIAL_CLAUSE, SERIAL_CLAUSE, EXIT_SYMBOL, LABELED_UNIT, STOP);
+	      reduce (q, NO_NOTE, &siga,
+		      SERIAL_CLAUSE, SERIAL_CLAUSE, SEMI_SYMBOL, LABELED_UNIT, STOP);
+	      reduce (q, NO_NOTE, &siga,
+		      INITIALISER_SERIES, SERIAL_CLAUSE, SEMI_SYMBOL, DECLARATION_LIST, STOP);
+	      /* Errors  */
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, SERIAL_CLAUSE, COMMA_SYMBOL, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, SERIAL_CLAUSE, COMMA_SYMBOL, LABELED_UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, SERIAL_CLAUSE, COMMA_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, SERIAL_CLAUSE, COLON_SYMBOL, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, SERIAL_CLAUSE, COLON_SYMBOL, LABELED_UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, SERIAL_CLAUSE, COLON_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, SERIAL_CLAUSE, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, SERIAL_CLAUSE, LABELED_UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, SERIAL_CLAUSE, DECLARATION_LIST, STOP);
+	    }
+	  else if (IS (q, INITIALISER_SERIES))
+	    {
+	      reduce (q, NO_NOTE, &siga,
+		      SERIAL_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, UNIT, STOP);
+	      reduce (q, NO_NOTE, &siga,
+		      SERIAL_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, LABELED_UNIT, STOP);
+	      reduce (q, NO_NOTE, &siga,
+		      INITIALISER_SERIES, INITIALISER_SERIES, SEMI_SYMBOL, DECLARATION_LIST, STOP);
+	      /* Errors  */
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, LABELED_UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, INITIALISER_SERIES, COMMA_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, INITIALISER_SERIES, COLON_SYMBOL, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, INITIALISER_SERIES, COLON_SYMBOL, LABELED_UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, INITIALISER_SERIES, COLON_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, INITIALISER_SERIES, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SERIAL_CLAUSE, INITIALISER_SERIES, LABELED_UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, INITIALISER_SERIES, DECLARATION_LIST, STOP);
+	    }
+	}
+      while (siga);
+    }
+}
+
+/* Reduce enquiry clauses.  */
+
+static void
+reduce_enquiry_clauses (NODE_T *p)
+{
+  if (NEXT (p) != NO_NODE)
+    {
+      NODE_T *q = NEXT (p);
+      bool siga;
+      reduce (q, NO_NOTE, NO_TICK, ENQUIRY_CLAUSE, UNIT, STOP);
+      reduce (q, NO_NOTE, NO_TICK, INITIALISER_SERIES, DECLARATION_LIST, STOP);
+      do
+	{
+	  siga = false;
+	  if (IS (q, ENQUIRY_CLAUSE))
+	    {
+	      reduce (q, NO_NOTE, &siga,
+		      ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, SEMI_SYMBOL, UNIT, STOP);
+	      reduce (q, NO_NOTE, &siga,
+		      INITIALISER_SERIES, ENQUIRY_CLAUSE, SEMI_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, COMMA_SYMBOL, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, ENQUIRY_CLAUSE, COMMA_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, COLON_SYMBOL, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, ENQUIRY_CLAUSE, COLON_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      ENQUIRY_CLAUSE, ENQUIRY_CLAUSE, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, ENQUIRY_CLAUSE, DECLARATION_LIST, STOP);
+	    }
+	  else if (IS (q, INITIALISER_SERIES))
+	    {
+	      reduce (q, NO_NOTE, &siga,
+		      ENQUIRY_CLAUSE, INITIALISER_SERIES, SEMI_SYMBOL, UNIT, STOP);
+	      reduce (q, NO_NOTE, &siga,
+		      INITIALISER_SERIES, INITIALISER_SERIES, SEMI_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      ENQUIRY_CLAUSE, INITIALISER_SERIES, COMMA_SYMBOL, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, INITIALISER_SERIES, COMMA_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      ENQUIRY_CLAUSE, INITIALISER_SERIES, COLON_SYMBOL, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, INITIALISER_SERIES, COLON_SYMBOL, DECLARATION_LIST, STOP);
+	      reduce (q, strange_separator, &siga,
+		      ENQUIRY_CLAUSE, INITIALISER_SERIES, UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      INITIALISER_SERIES, INITIALISER_SERIES, DECLARATION_LIST, STOP);
+	    }
+	}
+      while (siga);
+    }
+}
+
+/* Reduce collateral clauses.  */
+
+static void
+reduce_collateral_clauses (NODE_T *p)
+{
+  if (NEXT (p) != NO_NODE)
+    {
+      NODE_T *q = NEXT (p);
+      if (IS (q, UNIT))
+	{
+	  bool siga;
+	  reduce (q, NO_NOTE, NO_TICK, UNIT_LIST, UNIT, STOP);
+	  do
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga, UNIT_LIST, UNIT_LIST, COMMA_SYMBOL, UNIT, STOP);
+	      reduce (q, strange_separator, &siga, UNIT_LIST, UNIT_LIST, UNIT, STOP);
+	    }
+	  while (siga);
+	}
+      else if (IS (q, SPECIFIED_UNIT))
+	{
+	  bool siga;
+	  reduce (q, NO_NOTE, NO_TICK, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP);
+	  do
+	    {
+	      siga = false;
+	      reduce (q, NO_NOTE, &siga,
+		      SPECIFIED_UNIT_LIST, SPECIFIED_UNIT_LIST, COMMA_SYMBOL, SPECIFIED_UNIT, STOP);
+	      reduce (q, strange_separator, &siga,
+		      SPECIFIED_UNIT_LIST, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP);
+	    }
+	  while (siga);
+	}
+    }
+}
+
+/* Reduces enclosed clauses.  */
+
+static void
+reduce_enclosed_clauses (NODE_T *q, enum a68_attribute expect)
+{
+  NODE_T *p = q;
+
+  if (SUB (p) == NO_NODE)
+    {
+      if (IS (p, FOR_SYMBOL))
+	reduce (p, NO_NOTE, NO_TICK, FOR_PART, FOR_SYMBOL, DEFINING_IDENTIFIER, STOP);
+      else if (IS (p, OPEN_SYMBOL))
+	{
+	  if (expect == ENQUIRY_CLAUSE)
+	    reduce (p, NO_NOTE, NO_TICK, OPEN_PART, OPEN_SYMBOL, ENQUIRY_CLAUSE, STOP);
+	  else if (expect == ARGUMENT)
+	    {
+	      reduce (p, NO_NOTE, NO_TICK, ARGUMENT, OPEN_SYMBOL, CLOSE_SYMBOL, STOP);
+	      reduce (p, NO_NOTE, NO_TICK, ARGUMENT, OPEN_SYMBOL, ARGUMENT_LIST, CLOSE_SYMBOL, STOP);
+	      reduce (p, empty_clause, NO_TICK, ARGUMENT, OPEN_SYMBOL, INITIALISER_SERIES, CLOSE_SYMBOL, STOP);
+	    }
+	  else if (expect == GENERIC_ARGUMENT)
+	    {
+	      if (a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))
+		{
+		  pad_node (p, TRIMMER);
+		  reduce (p, NO_NOTE, NO_TICK, GENERIC_ARGUMENT, OPEN_SYMBOL, TRIMMER, CLOSE_SYMBOL, STOP);
+		}
+	      reduce (p, NO_NOTE, NO_TICK,
+		      GENERIC_ARGUMENT, OPEN_SYMBOL, GENERIC_ARGUMENT_LIST, CLOSE_SYMBOL, STOP);
+	    }
+	  else if (expect == BOUNDS)
+	    {
+	      reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, OPEN_SYMBOL, CLOSE_SYMBOL, STOP);
+	      reduce (p, NO_NOTE, NO_TICK, BOUNDS, OPEN_SYMBOL, BOUNDS_LIST, CLOSE_SYMBOL, STOP);
+	      reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, OPEN_SYMBOL, FORMAL_BOUNDS_LIST, CLOSE_SYMBOL, STOP);
+	      reduce (p, NO_NOTE, NO_TICK,
+		      FORMAL_BOUNDS, OPEN_SYMBOL, ALT_FORMAL_BOUNDS_LIST, CLOSE_SYMBOL, STOP);
+	    }
+	  else
+	    {
+	      reduce (p, NO_NOTE, NO_TICK, CLOSED_CLAUSE, OPEN_SYMBOL, SERIAL_CLAUSE, CLOSE_SYMBOL, STOP);
+	      reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, OPEN_SYMBOL, UNIT_LIST, CLOSE_SYMBOL, STOP);
+	      reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, OPEN_SYMBOL, CLOSE_SYMBOL, STOP);
+	      reduce (p, empty_clause, NO_TICK,
+		      CLOSED_CLAUSE, OPEN_SYMBOL, INITIALISER_SERIES, CLOSE_SYMBOL, STOP);
+	    }
+	}
+      else if (IS (p, SUB_SYMBOL))
+	{
+	  if (expect == GENERIC_ARGUMENT)
+	    {
+	      if (a68_whether (p, SUB_SYMBOL, BUS_SYMBOL, STOP))
+		{
+		  pad_node (p, TRIMMER);
+		  reduce (p, NO_NOTE, NO_TICK, GENERIC_ARGUMENT, SUB_SYMBOL, TRIMMER, BUS_SYMBOL, STOP);
+		}
+	      reduce (p, NO_NOTE, NO_TICK,
+		      GENERIC_ARGUMENT, SUB_SYMBOL, GENERIC_ARGUMENT_LIST, BUS_SYMBOL, STOP);
+	    }
+	  else if (expect == BOUNDS)
+	    {
+	      reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, SUB_SYMBOL, BUS_SYMBOL, STOP);
+	      reduce (p, NO_NOTE, NO_TICK, BOUNDS, SUB_SYMBOL, BOUNDS_LIST, BUS_SYMBOL, STOP);
+	      reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, SUB_SYMBOL, FORMAL_BOUNDS_LIST, BUS_SYMBOL, STOP);
+	      reduce (p, NO_NOTE, NO_TICK, FORMAL_BOUNDS, SUB_SYMBOL, ALT_FORMAL_BOUNDS_LIST, BUS_SYMBOL, STOP);
+	    }
+	}
+      else if (IS (p, BEGIN_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, BEGIN_SYMBOL, UNIT_LIST, END_SYMBOL, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, COLLATERAL_CLAUSE, BEGIN_SYMBOL, END_SYMBOL, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, CLOSED_CLAUSE, BEGIN_SYMBOL, SERIAL_CLAUSE, END_SYMBOL, STOP);
+	  reduce (p, empty_clause, NO_TICK, CLOSED_CLAUSE, BEGIN_SYMBOL, INITIALISER_SERIES, END_SYMBOL, STOP);
+	}
+      else if (IS (p, FORMAT_DELIMITER_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK,
+		  FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL, PICTURE_LIST, FORMAT_DELIMITER_SYMBOL, STOP);
+	  reduce (p, NO_NOTE, NO_TICK,
+		  FORMAT_TEXT, FORMAT_DELIMITER_SYMBOL, FORMAT_DELIMITER_SYMBOL, STOP);
+	}
+      else if (IS (p, FORMAT_OPEN_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK,
+		  COLLECTION, FORMAT_OPEN_SYMBOL, PICTURE_LIST, FORMAT_CLOSE_SYMBOL, STOP);
+	}
+      else if (IS (p, IF_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, IF_PART, IF_SYMBOL, ENQUIRY_CLAUSE, STOP);
+	  reduce (p, empty_clause, NO_TICK, IF_PART, IF_SYMBOL, INITIALISER_SERIES, STOP);
+	}
+      else if (IS (p, THEN_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, THEN_PART, THEN_SYMBOL, SERIAL_CLAUSE, STOP);
+	  reduce (p, empty_clause, NO_TICK, THEN_PART, THEN_SYMBOL, INITIALISER_SERIES, STOP);
+	}
+      else if (IS (p, ELSE_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, ELSE_PART, ELSE_SYMBOL, SERIAL_CLAUSE, STOP);
+	  reduce (p, empty_clause, NO_TICK, ELSE_PART, ELSE_SYMBOL, INITIALISER_SERIES, STOP);
+	}
+      else if (IS (p, ELIF_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, ELIF_IF_PART, ELIF_SYMBOL, ENQUIRY_CLAUSE, STOP);
+	}
+      else if (IS (p, CASE_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, CASE_PART, CASE_SYMBOL, ENQUIRY_CLAUSE, STOP);
+	  reduce (p, empty_clause, NO_TICK, CASE_PART, CASE_SYMBOL, INITIALISER_SERIES, STOP);
+	}
+      else if (IS (p, IN_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, CASE_IN_PART, IN_SYMBOL, UNIT_LIST, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, CONFORMITY_IN_PART, IN_SYMBOL, SPECIFIED_UNIT_LIST, STOP);
+	}
+      else if (IS (p, OUT_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, OUT_PART, OUT_SYMBOL, SERIAL_CLAUSE, STOP);
+	  reduce (p, empty_clause, NO_TICK, OUT_PART, OUT_SYMBOL, INITIALISER_SERIES, STOP);
+	}
+      else if (IS (p, OUSE_SYMBOL))
+	reduce (p, NO_NOTE, NO_TICK, OUSE_PART, OUSE_SYMBOL, ENQUIRY_CLAUSE, STOP);
+      else if (IS (p, THEN_BAR_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, CHOICE, THEN_BAR_SYMBOL, SERIAL_CLAUSE, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, CASE_CHOICE_CLAUSE, THEN_BAR_SYMBOL, UNIT_LIST, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CHOICE, THEN_BAR_SYMBOL, SPECIFIED_UNIT_LIST, STOP);
+	  reduce (p, NO_NOTE, NO_TICK, CONFORMITY_CHOICE, THEN_BAR_SYMBOL, SPECIFIED_UNIT, STOP);
+	  reduce (p, empty_clause, NO_TICK, CHOICE, THEN_BAR_SYMBOL, INITIALISER_SERIES, STOP);
+	}
+      else if (IS (p, ELSE_BAR_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, ELSE_OPEN_PART, ELSE_BAR_SYMBOL, ENQUIRY_CLAUSE, STOP);
+	  reduce (p, empty_clause, NO_TICK, ELSE_OPEN_PART, ELSE_BAR_SYMBOL, INITIALISER_SERIES, STOP);
+	}
+      else if (IS (p, FROM_SYMBOL))
+	reduce (p, NO_NOTE, NO_TICK, FROM_PART, FROM_SYMBOL, UNIT, STOP);
+      else if (IS (p, BY_SYMBOL))
+	reduce (p, NO_NOTE, NO_TICK, BY_PART, BY_SYMBOL, UNIT, STOP);
+      else if (IS (p, TO_SYMBOL))
+	reduce (p, NO_NOTE, NO_TICK, TO_PART, TO_SYMBOL, UNIT, STOP);
+      else if (IS (p, WHILE_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, WHILE_PART, WHILE_SYMBOL, ENQUIRY_CLAUSE, STOP);
+	  reduce (p, empty_clause, NO_TICK, WHILE_PART, WHILE_SYMBOL, INITIALISER_SERIES, STOP);
+	}
+      else if (IS (p, DO_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, DO_PART, DO_SYMBOL, SERIAL_CLAUSE, OD_SYMBOL, STOP);
+	}
+      else if (IS (p, ALT_DO_SYMBOL))
+	{
+	  reduce (p, NO_NOTE, NO_TICK, ALT_DO_PART, ALT_DO_SYMBOL, SERIAL_CLAUSE, OD_SYMBOL, STOP);
+	}
+    }
+  p = q;
+  if (SUB (p) != NO_NODE)
+    {
+    if (IS (p, OPEN_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, OPEN_PART, CHOICE, CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, OPEN_PART, CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, OPEN_PART, CHOICE, BRIEF_ELIF_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, OPEN_PART, CASE_CHOICE_CLAUSE, CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, OPEN_PART, CASE_CHOICE_CLAUSE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, OPEN_PART, CASE_CHOICE_CLAUSE, BRIEF_OUSE_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		CONFORMITY_CLAUSE, OPEN_PART, CONFORMITY_CHOICE, CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		CONFORMITY_CLAUSE, OPEN_PART, CONFORMITY_CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		CONFORMITY_CLAUSE, OPEN_PART, CONFORMITY_CHOICE, BRIEF_CONFORMITY_OUSE_PART, STOP);
+      }
+    else if (IS (p, ELSE_OPEN_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK, BRIEF_ELIF_PART, ELSE_OPEN_PART, CHOICE, CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, BRIEF_ELIF_PART, ELSE_OPEN_PART, CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, BRIEF_ELIF_PART, ELSE_OPEN_PART, CHOICE, BRIEF_ELIF_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		BRIEF_OUSE_PART, ELSE_OPEN_PART, CASE_CHOICE_CLAUSE, CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, BRIEF_OUSE_PART, ELSE_OPEN_PART, CASE_CHOICE_CLAUSE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		BRIEF_OUSE_PART, ELSE_OPEN_PART, CASE_CHOICE_CLAUSE, BRIEF_OUSE_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		BRIEF_CONFORMITY_OUSE_PART, ELSE_OPEN_PART, CONFORMITY_CHOICE, CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		BRIEF_CONFORMITY_OUSE_PART, ELSE_OPEN_PART, CONFORMITY_CHOICE, CLOSE_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		BRIEF_CONFORMITY_OUSE_PART, ELSE_OPEN_PART, CONFORMITY_CHOICE, BRIEF_CONFORMITY_OUSE_PART,
+		STOP);
+      }
+    else if (IS (p, IF_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, IF_PART, THEN_PART, ELSE_PART, FI_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, IF_PART, THEN_PART, ELIF_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CONDITIONAL_CLAUSE, IF_PART, THEN_PART, FI_SYMBOL, STOP);
+      }
+    else if (IS (p, ELIF_IF_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK, ELIF_PART, ELIF_IF_PART, THEN_PART, ELSE_PART, FI_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, ELIF_PART, ELIF_IF_PART, THEN_PART, FI_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, ELIF_PART, ELIF_IF_PART, THEN_PART, ELIF_PART, STOP);
+      }
+    else if (IS (p, CASE_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, CASE_PART, CASE_IN_PART, OUT_PART, ESAC_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, CASE_PART, CASE_IN_PART, ESAC_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CASE_CLAUSE, CASE_PART, CASE_IN_PART, CASE_OUSE_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		CONFORMITY_CLAUSE, CASE_PART, CONFORMITY_IN_PART, OUT_PART, ESAC_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		CONFORMITY_CLAUSE, CASE_PART, CONFORMITY_IN_PART, ESAC_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		CONFORMITY_CLAUSE, CASE_PART, CONFORMITY_IN_PART, CONFORMITY_OUSE_PART, STOP);
+      }
+    else if (IS (p, OUSE_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK, CASE_OUSE_PART, OUSE_PART, CASE_IN_PART, OUT_PART, ESAC_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CASE_OUSE_PART, OUSE_PART, CASE_IN_PART, ESAC_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK, CASE_OUSE_PART, OUSE_PART, CASE_IN_PART, CASE_OUSE_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		CONFORMITY_OUSE_PART, OUSE_PART, CONFORMITY_IN_PART, OUT_PART, ESAC_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		CONFORMITY_OUSE_PART, OUSE_PART, CONFORMITY_IN_PART, ESAC_SYMBOL, STOP);
+	reduce (p, NO_NOTE, NO_TICK,
+		CONFORMITY_OUSE_PART, OUSE_PART, CONFORMITY_IN_PART, CONFORMITY_OUSE_PART, STOP);
+      }
+    else if (IS (p, FOR_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK,
+		LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, TO_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, BY_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, TO_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, FROM_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, TO_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, BY_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, TO_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FOR_PART, ALT_DO_PART, STOP);
+      }
+    else if (IS (p, FROM_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, TO_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, BY_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, TO_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, FROM_PART, ALT_DO_PART, STOP);
+      }
+    else if (IS (p, BY_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, TO_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, TO_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, BY_PART, ALT_DO_PART, STOP);
+      }
+    else if (IS (p, TO_PART))
+      {
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, TO_PART, WHILE_PART, ALT_DO_PART, STOP);
+	reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, TO_PART, ALT_DO_PART, STOP);
+      }
+    else if (IS (p, WHILE_PART))
+      reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, WHILE_PART, ALT_DO_PART, STOP);
+    else if (IS (p, DO_PART))
+      reduce (p, NO_NOTE, NO_TICK, LOOP_CLAUSE, DO_PART, STOP);
+    }
+}
+
+/* Substitute reduction when a phrase could not be parsed.  */
+
+static void
+recover_from_error (NODE_T * p, enum a68_attribute expect, bool suppress)
+{
+  /* This routine does not do fancy things as that might introduce more
+     errors.  */
+  NODE_T *q = p;
+  if (p == NO_NODE)
+    return;
+
+  if (expect == SOME_CLAUSE)
+    expect = serial_or_collateral (p);
+
+  if (!suppress)
+    {
+      /* Give an error message.  */
+      NODE_T *w = p;
+      char *seq = a68_phrase_to_text (p, &w);
+      if (strlen (seq) == 0)
+	{
+	  if (ERROR_COUNT (&A68_JOB) == 0)
+	    a68_error (w, "expected A", expect);
+	}
+      else
+	a68_error (w, "Y is an invalid A", seq, expect);
+
+    if (ERROR_COUNT (&A68_JOB) >= MAX_ERRORS)
+      longjmp (A68_PARSER (bottom_up_crash_exit), 1);
+  }
+
+  /* Try to prevent spurious diagnostics by guessing what was expected.  */
+  while (NEXT (q) != NO_NODE)
+    FORWARD (q);
+
+  if (a68_is_one_of (p, BEGIN_SYMBOL, OPEN_SYMBOL, STOP))
+    {
+      if (expect == ARGUMENT || expect == COLLATERAL_CLAUSE
+	  || expect == PARAMETER_PACK || expect == STRUCTURE_PACK
+	  || expect == UNION_PACK)
+	a68_make_sub (p, q, expect);
+      else if (expect == ENQUIRY_CLAUSE)
+	a68_make_sub (p, q, OPEN_PART);
+      else if (expect == FORMAL_DECLARERS)
+	a68_make_sub (p, q, FORMAL_DECLARERS);
+      else
+	a68_make_sub (p, q, CLOSED_CLAUSE);
+    }
+  else if (IS (p, FORMAT_DELIMITER_SYMBOL) && expect == FORMAT_TEXT)
+    a68_make_sub (p, q, FORMAT_TEXT);
+  else if (a68_is_one_of (p, THEN_BAR_SYMBOL, CHOICE, STOP))
+    a68_make_sub (p, q, CHOICE);
+  else if (a68_is_one_of (p, IF_SYMBOL, IF_PART, STOP))
+    a68_make_sub (p, q, IF_PART);
+  else if (a68_is_one_of (p, THEN_SYMBOL, THEN_PART, STOP))
+    a68_make_sub (p, q, THEN_PART);
+  else if (a68_is_one_of (p, ELSE_SYMBOL, ELSE_PART, STOP))
+    a68_make_sub (p, q, ELSE_PART);
+  else if (a68_is_one_of (p, ELIF_SYMBOL, ELIF_IF_PART, STOP))
+    a68_make_sub (p, q, ELIF_IF_PART);
+  else if (a68_is_one_of (p, CASE_SYMBOL, CASE_PART, STOP))
+    a68_make_sub (p, q, CASE_PART);
+  else if (a68_is_one_of (p, OUT_SYMBOL, OUT_PART, STOP))
+    a68_make_sub (p, q, OUT_PART);
+  else if (a68_is_one_of (p, OUSE_SYMBOL, OUSE_PART, STOP))
+    a68_make_sub (p, q, OUSE_PART);
+  else if (a68_is_one_of (p, FOR_SYMBOL, FOR_PART, STOP))
+    a68_make_sub (p, q, FOR_PART);
+  else if (a68_is_one_of (p, FROM_SYMBOL, FROM_PART, STOP))
+    a68_make_sub (p, q, FROM_PART);
+  else if (a68_is_one_of (p, BY_SYMBOL, BY_PART, STOP))
+    a68_make_sub (p, q, BY_PART);
+  else if (a68_is_one_of (p, TO_SYMBOL, TO_PART, STOP))
+    a68_make_sub (p, q, TO_PART);
+  else if (a68_is_one_of (p, WHILE_SYMBOL, WHILE_PART, STOP))
+    a68_make_sub (p, q, WHILE_PART);
+  else if (a68_is_one_of (p, DO_SYMBOL, DO_PART, STOP))
+    a68_make_sub (p, q, DO_PART);
+  else if (a68_is_one_of (p, ALT_DO_SYMBOL, ALT_DO_PART, STOP))
+    a68_make_sub (p, q, ALT_DO_PART);
+  else if (a68_attribute_name (expect) != NO_TEXT)
+    a68_make_sub (p, q, expect);
+}
+
+/* Heuristic aid in pinpointing errors.  */
+
+static void
+reduce_erroneous_units (NODE_T *p)
+{
+  /* Constructs are reduced to units in an attempt to limit spurious
+     diagnostics.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      /* Some implementations allow selection from a tertiary, when there is no
+	 risk of ambiguity. GCC follows RR, so some extra attention here to
+	 guide an unsuspecting user.  */
+    if (a68_whether (q, SELECTOR, -SECONDARY, STOP))
+      {
+	a68_error (NEXT (q), "expected A", SECONDARY);
+	reduce (q, NO_NOTE, NO_TICK, UNIT, SELECTOR, WILDCARD, STOP);
+      }
+
+    /* Attention for identity relations that require tertiaries.  */
+    if (a68_whether (q, -TERTIARY, IS_SYMBOL, TERTIARY, STOP)
+	|| a68_whether (q, TERTIARY, IS_SYMBOL, -TERTIARY, STOP)
+	|| a68_whether (q, -TERTIARY, IS_SYMBOL, -TERTIARY, STOP))
+      {
+	a68_error (NEXT (q), "expected A", TERTIARY);
+	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);
+	reduce (q, NO_NOTE, NO_TICK, UNIT, WILDCARD, ISNT_SYMBOL, WILDCARD, STOP);
+      }
+    }
+}
+
+/*
+ * A posteriori checks of the syntax tree built by the BU parser.
+ */
+
+/* Driver for a posteriori error checking.  */
+
+void
+a68_bottom_up_error_check (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, BOOLEAN_PATTERN))
+	{
+	  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));
+	}
+      else
+	a68_bottom_up_error_check (SUB (p));
+    }
+}
+
+/*
+ * Next part rearranges and checks the tree after the symbol tables are finished.
+ */
+
+/* Transfer IDENTIFIER to JUMP where appropriate.  */
+
+void
+a68_rearrange_goto_less_jumps (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, UNIT))
+	{
+	  NODE_T *q = SUB (p);
+	  if (IS (q, TERTIARY))
+	    {
+	      NODE_T *tertiary = q;
+	      q = SUB (q);
+	      if (q != NO_NODE && IS (q, SECONDARY))
+		{
+		  q = SUB (q);
+		  if (q != NO_NODE && IS (q, PRIMARY))
+		    {
+		      q = SUB (q);
+		      if (q != NO_NODE && IS (q, IDENTIFIER))
+			{
+			  if (a68_is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL)
+			    {
+			      ATTRIBUTE (tertiary) = JUMP;
+			      SUB (tertiary) = q;
+			    }
+			}
+		    }
+		}
+	    }
+	}
+      else if (IS (p, TERTIARY))
+	{
+	  NODE_T *q = SUB (p);
+	  if (q != NO_NODE && IS (q, SECONDARY))
+	    {
+	      NODE_T *secondary = q;
+	      q = SUB (q);
+	      if (q != NO_NODE && IS (q, PRIMARY))
+		{
+		  q = SUB (q);
+		  if (q != NO_NODE && IS (q, IDENTIFIER))
+		    {
+		      if (a68_is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL)
+			{
+			  ATTRIBUTE (secondary) = JUMP;
+			  SUB (secondary) = q;
+			}
+		    }
+		}
+	    }
+	}
+      else if (IS (p, SECONDARY))
+	{
+	  NODE_T *q = SUB (p);
+	  if (q != NO_NODE && IS (q, PRIMARY))
+	    {
+	      NODE_T *primary = q;
+	      q = SUB (q);
+	      if (q != NO_NODE && IS (q, IDENTIFIER))
+		{
+		  if (a68_is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL)
+		    {
+		      ATTRIBUTE (primary) = JUMP;
+		      SUB (primary) = q;
+		    }
+		}
+	    }
+	}
+      else if (IS (p, PRIMARY))
+	{
+	  NODE_T *q = SUB (p);
+	  if (q != NO_NODE && IS (q, IDENTIFIER))
+	    {
+	      if (a68_is_identifier_or_label_global (TABLE (q), NSYMBOL (q)) == LABEL)
+		a68_make_sub (q, q, JUMP);
+	    }
+	}
+      a68_rearrange_goto_less_jumps (SUB (p));
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 21/47] a68: parser: syntax check for declarers
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (19 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 20/47] a68: parser: bottom-up parser Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 22/47] a68: parser: standard prelude definitions Jose E. Marchesi
                   ` (26 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Thi pass checks the syntax of formal, actual and virtual declarers.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-victal.cc | 362 +++++++++++++++++++++++++++++++
 1 file changed, 362 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-victal.cc

diff --git a/gcc/algol68/a68-parser-victal.cc b/gcc/algol68/a68-parser-victal.cc
new file mode 100644
index 00000000000..b4162fc3982
--- /dev/null
+++ b/gcc/algol68/a68-parser-victal.cc
@@ -0,0 +1,362 @@
+/* Syntax check for formal, actual and virtual declarers.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+static bool victal_check_declarer (NODE_T *, int);
+
+/* Check generator.  */
+
+static void
+victal_check_generator (NODE_T * p)
+{
+  if (!victal_check_declarer (NEXT (p), ACTUAL_DECLARER_MARK))
+    a68_error (p, "Y expected", "actual declarer");
+}
+
+/* Check formal pack.  */
+
+static void
+victal_check_formal_pack (NODE_T *p, int x, bool *z)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, FORMAL_DECLARERS))
+	victal_check_formal_pack (SUB (p), x, z);
+      else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP))
+	victal_check_formal_pack (NEXT (p), x, z);
+      else if (IS (p, FORMAL_DECLARERS_LIST))
+	{
+	  victal_check_formal_pack (NEXT (p), x, z);
+	  victal_check_formal_pack (SUB (p), x, z);
+	}
+      else if (IS (p, DECLARER))
+	{
+	  victal_check_formal_pack (NEXT (p), x, z);
+	  (*z) &= victal_check_declarer (SUB (p), x);
+	}
+    }
+}
+
+/* Check operator declaration.  */
+
+static void
+victal_check_operator_dec (NODE_T *p)
+{
+  if (IS (NEXT (p), FORMAL_DECLARERS))
+    {
+      bool z = true;
+      victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z);
+      if (!z)
+	a68_error (p, "Y expected", "formal declarers");
+      FORWARD (p);
+  }
+  if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK))
+    a68_error (p, "Y expected", "formal declarer");
+}
+
+/* Check mode declaration.  */
+
+static void
+victal_check_mode_dec (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, MODE_DECLARATION))
+	{
+	  victal_check_mode_dec (SUB (p));
+	  victal_check_mode_dec (NEXT (p));
+	}
+      else if (a68_is_one_of (p, MODE_SYMBOL, DEFINING_INDICANT, STOP)
+               || a68_is_one_of (p, EQUALS_SYMBOL, COMMA_SYMBOL, STOP))
+	{
+	  victal_check_mode_dec (NEXT (p));
+	}
+      else if (IS (p, DECLARER))
+	{
+	  if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK))
+	    a68_error (p, "Y expected", "actual declarer");
+	}
+    }
+}
+
+/* Check variable declaration. */
+
+static void
+victal_check_variable_dec (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, VARIABLE_DECLARATION))
+	{
+	  victal_check_variable_dec (SUB (p));
+	  victal_check_variable_dec (NEXT (p));
+	}
+      else
+	{
+	  if (IS (p, QUALIFIER))
+	    FORWARD (p);
+
+	  if (a68_is_one_of (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, STOP)
+	      || IS (p, COMMA_SYMBOL))
+	    victal_check_variable_dec (NEXT (p));
+	  else if (IS (p, UNIT))
+	    a68_victal_checker (SUB (p));
+	  else if (IS (p, DECLARER))
+	    {
+	      if (!victal_check_declarer (p, ACTUAL_DECLARER_MARK))
+		a68_error (p, "Y expected", "actual declarer");
+	      victal_check_variable_dec (NEXT (p));
+	    }
+	}
+    }
+}
+
+/* Check identity declaration.  */
+
+static void
+victal_check_identity_dec (NODE_T * p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, IDENTITY_DECLARATION))
+	{
+	  victal_check_identity_dec (SUB (p));
+	  victal_check_identity_dec (NEXT (p));
+	}
+      else if (a68_is_one_of (p, DEFINING_IDENTIFIER, EQUALS_SYMBOL, COMMA_SYMBOL, STOP))
+	victal_check_identity_dec (NEXT (p));
+      else if (IS (p, UNIT))
+	a68_victal_checker (SUB (p));
+      else if (IS (p, DECLARER))
+	{
+	  if (!victal_check_declarer (p, FORMAL_DECLARER_MARK))
+	    a68_error (p, "Y expected", "formal declarer");
+	  victal_check_identity_dec (NEXT (p));
+	}
+    }
+}
+
+/* Check routine pack.  */
+
+static void
+victal_check_routine_pack (NODE_T *p, int x, bool *z)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, PARAMETER_PACK))
+	victal_check_routine_pack (SUB (p), x, z);
+      else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP))
+	victal_check_routine_pack (NEXT (p), x, z);
+      else if (a68_is_one_of (p, PARAMETER_LIST, PARAMETER, STOP))
+	{
+	  victal_check_routine_pack (NEXT (p), x, z);
+	  victal_check_routine_pack (SUB (p), x, z);
+	}
+      else if (IS (p, DECLARER))
+	*z &= victal_check_declarer (SUB (p), x);
+    }
+}
+
+/* Check routine text.  */
+
+static void
+victal_check_routine_text (NODE_T *p)
+{
+  if (IS (p, PARAMETER_PACK))
+    {
+      bool z = true;
+      victal_check_routine_pack (p, FORMAL_DECLARER_MARK, &z);
+      if (!z)
+	a68_error (p, "Y expected", "formal declarers");
+      FORWARD (p);
+    }
+  if (!victal_check_declarer (p, FORMAL_DECLARER_MARK))
+    a68_error (p, "Y expected", "formal declarer");
+  a68_victal_checker (NEXT (p));
+}
+
+/* Check structure pack.  */
+
+static void
+victal_check_structure_pack (NODE_T *p, int x, bool *z)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, STRUCTURE_PACK))
+	victal_check_structure_pack (SUB (p), x, z);
+      else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP))
+	victal_check_structure_pack (NEXT (p), x, z);
+      else if (a68_is_one_of (p, STRUCTURED_FIELD_LIST, STRUCTURED_FIELD, STOP))
+	{
+	  victal_check_structure_pack (NEXT (p), x, z);
+	  victal_check_structure_pack (SUB (p), x, z);
+	}
+      else if (IS (p, DECLARER))
+	(*z) &= victal_check_declarer (SUB (p), x);
+    }
+}
+
+/* Check union pack.  */
+
+static void
+victal_check_union_pack (NODE_T * p, int x, bool * z)
+{
+  if (p != NO_NODE)
+    {
+    if (IS (p, UNION_PACK))
+      victal_check_union_pack (SUB (p), x, z);
+    else if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, VOID_SYMBOL, STOP))
+      victal_check_union_pack (NEXT (p), x, z);
+    else if (IS (p, UNION_DECLARER_LIST))
+      {
+	victal_check_union_pack (NEXT (p), x, z);
+	victal_check_union_pack (SUB (p), x, z);
+      }
+    else if (IS (p, DECLARER))
+      {
+	victal_check_union_pack (NEXT (p), x, z);
+	(*z) &= victal_check_declarer (SUB (p), FORMAL_DECLARER_MARK);
+      }
+    }
+}
+
+/* Check declarer.  */
+
+static bool
+victal_check_declarer (NODE_T *p, int x)
+{
+  if (p == NO_NODE)
+    return false;
+  else if (IS (p, DECLARER))
+    return victal_check_declarer (SUB (p), x);
+  else if (a68_is_one_of (p, LONGETY, SHORTETY, STOP))
+    return true;
+  else if (a68_is_one_of (p, VOID_SYMBOL, INDICANT, STANDARD, STOP))
+    return true;
+  else if (IS_REF (p))
+    return victal_check_declarer (NEXT (p), VIRTUAL_DECLARER_MARK);
+  else if (IS_FLEX (p))
+    return victal_check_declarer (NEXT (p), x);
+  else if (IS (p, BOUNDS))
+    {
+      a68_victal_checker (SUB (p));
+      if (x == FORMAL_DECLARER_MARK)
+	{
+	  a68_error (p, "Y expected", "formal bounds");
+	  (void) victal_check_declarer (NEXT (p), x);
+	  return true;
+	}
+      else if (x == VIRTUAL_DECLARER_MARK)
+	{
+	  a68_error (p, "Y expected", "virtual bounds");
+	  (void) victal_check_declarer (NEXT (p), x);
+	  return true;
+	}
+      else
+	return victal_check_declarer (NEXT (p), x);
+    }
+  else if (IS (p, FORMAL_BOUNDS))
+    {
+      a68_victal_checker (SUB (p));
+      if (x == ACTUAL_DECLARER_MARK)
+	{
+	  a68_error (p, "Y expected", "actual bounds");
+	  (void) victal_check_declarer (NEXT (p), x);
+	  return true;
+	}
+      else
+	return victal_check_declarer (NEXT (p), x);
+    }
+  else if (IS (p, STRUCT_SYMBOL))
+    {
+      bool z = true;
+      victal_check_structure_pack (NEXT (p), x, &z);
+      return z;
+    }
+  else if (IS (p, UNION_SYMBOL))
+    {
+      bool z = true;
+      victal_check_union_pack (NEXT (p), FORMAL_DECLARER_MARK, &z);
+      if (!z)
+	a68_error (p, "Y expected", "formal declarer pack");
+      return true;
+    }
+  else if (IS (p, PROC_SYMBOL))
+    {
+      if (IS (NEXT (p), FORMAL_DECLARERS))
+	{
+	  bool z = true;
+	  victal_check_formal_pack (NEXT (p), FORMAL_DECLARER_MARK, &z);
+	  if (!z)
+	    a68_error (p, "Y expected", "formal declarer");
+	  FORWARD (p);
+	}
+      if (!victal_check_declarer (NEXT (p), FORMAL_DECLARER_MARK))
+	a68_error (p, "Y expected", "formal declarer");
+      return true;
+    }
+  else
+    return false;
+}
+
+/* Check cast.  */
+
+static void
+victal_check_cast (NODE_T *p)
+{
+  if (!victal_check_declarer (p, FORMAL_DECLARER_MARK))
+    {
+      a68_error (p, "Y expected", "formal declarer");
+      a68_victal_checker (NEXT (p));
+    }
+}
+
+/* Driver for checking VICTALITY of declarers.  */
+
+void
+a68_victal_checker (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, MODE_DECLARATION))
+	victal_check_mode_dec (SUB (p));
+      else if (IS (p, VARIABLE_DECLARATION))
+	victal_check_variable_dec (SUB (p));
+      else if (IS (p, IDENTITY_DECLARATION))
+	victal_check_identity_dec (SUB (p));
+      else if (IS (p, GENERATOR))
+	victal_check_generator (SUB (p));
+      else if (IS (p, ROUTINE_TEXT))
+	victal_check_routine_text (SUB (p));
+      else if (IS (p, OPERATOR_PLAN))
+	victal_check_operator_dec (SUB (p));
+      else if (IS (p, CAST))
+	victal_check_cast (SUB (p));
+      else
+	a68_victal_checker (SUB (p));
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 22/47] a68: parser: standard prelude definitions
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (20 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 21/47] a68: parser: syntax check for declarers Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 23/47] a68: parser: parsing of modes Jose E. Marchesi
                   ` (25 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Definitions of standard identifiers, procedures and modes.

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-prelude.cc | 1493 +++++++++++++++++++++++++++++
 1 file changed, 1493 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-prelude.cc

diff --git a/gcc/algol68/a68-parser-prelude.cc b/gcc/algol68/a68-parser-prelude.cc
new file mode 100644
index 00000000000..46c61c2ee19
--- /dev/null
+++ b/gcc/algol68/a68-parser-prelude.cc
@@ -0,0 +1,1493 @@
+/* Standard prelude definitions.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+#define A68_STD true
+#define A68_EXT false
+
+/* ALGOL68C type procs. */
+
+#define A68C_DEFIO(name, mode)					\
+  do								\
+    {								\
+      m = a68_proc (MODE (mode), M_REF_FILE, NO_MOID);		\
+      a68_idf (A68_EXT, "get" #name, m);			\
+      m = a68_proc (M_VOID, M_REF_FILE, MODE (mode), NO_MOID);	\
+      a68_idf (A68_EXT, "put" #name, m);			\
+      m = a68_proc (MODE (mode), NO_MOID);			\
+      a68_idf (A68_EXT, "read" #name, m);			\
+      m = a68_proc (M_VOID, MODE (mode), NO_MOID);		\
+      a68_idf (A68_EXT, "print" #name, m);			\
+    }								\
+  while (0)
+
+/* Enter tag in standenv symbol table.  */
+
+static void
+add_a68_standenv (bool portable, int a, NODE_T* n, char *c, MOID_T *m,
+		  int p, LOWERER_T l = NO_LOWERER)
+{
+#define INSERT_TAG(l, n) \
+  do {			 \
+    NEXT (n) = *(l);	 \
+    *(l) = (n);		 \
+  } while (0)
+
+  TAG_T *new_one = a68_new_tag ();
+
+  PROCEDURE_LEVEL (INFO (n)) = 0;
+  USE (new_one) = false;
+  HEAP (new_one) = HEAP_SYMBOL;
+  TAG_TABLE (new_one) = A68_STANDENV;
+  NODE (new_one) = n;
+  VALUE (new_one) = (c != NO_TEXT ? TEXT (a68_add_token (&A68 (top_token), c)) : NO_TEXT);
+  PRIO (new_one) = p;
+  TAX_TREE_DECL (new_one) = NULL;
+  LOWERER (new_one) = l;
+  UNIT (new_one) = NULL;
+  PORTABLE (new_one) = portable;
+  MOID (new_one) = m;
+  NEXT (new_one) = NO_TAG;
+  if (a == IDENTIFIER)
+    INSERT_TAG (&IDENTIFIERS (A68_STANDENV), new_one);
+  else if (a == OP_SYMBOL)
+    INSERT_TAG (&OPERATORS (A68_STANDENV), new_one);
+  else if (a == PRIO_SYMBOL)
+    INSERT_TAG (&PRIO (A68_STANDENV), new_one);
+  else if (a == INDICANT)
+    INSERT_TAG (&INDICANTS (A68_STANDENV), new_one);
+  else if (a == LABEL)
+    INSERT_TAG (&LABELS (A68_STANDENV), new_one);
+#undef INSERT_TAG
+}
+
+/* Compose PROC moid from arguments - first result, than arguments.  */
+
+static MOID_T *
+a68_proc (MOID_T *m, ...)
+{
+  PACK_T *p = NO_PACK, *q = NO_PACK;
+  MOID_T *y;
+
+  va_list attribute;
+  va_start (attribute, m);
+  while ((y = va_arg (attribute, MOID_T *)) != NO_MOID)
+    {
+      PACK_T *new_one = a68_new_pack ();
+
+      MOID (new_one) = y;
+      TEXT (new_one) = NO_TEXT;
+      NEXT (new_one) = NO_PACK;
+      if (q != NO_PACK)
+	NEXT (q) = new_one;
+      else
+	p = new_one;
+      q = new_one;
+    }
+
+  va_end (attribute);
+  return a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL,
+		   a68_count_pack_members (p), NO_NODE, m, p);
+}
+
+/* Enter an identifier in standenv.  */
+
+static void
+a68_idf (bool portable, const char *n, MOID_T *m, LOWERER_T l = NO_LOWERER)
+{
+  add_a68_standenv (portable, IDENTIFIER,
+		    a68_some_node (TEXT (a68_add_token (&A68 (top_token), n))),
+		    NO_TEXT, m, 0, l);
+}
+
+/* Enter a moid in standenv.  */
+
+static void
+a68_mode (int p, const char *t, MOID_T **m)
+{
+  (*m) = a68_add_mode (&TOP_MOID (&A68_JOB),
+		   STANDARD, p,
+		   a68_some_node (TEXT (a68_find_keyword (A68 (top_keyword), t))),
+		   NO_MOID, NO_PACK);
+}
+
+/* Enter a priority in standenv.  */
+
+static void
+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);
+}
+
+/* Enter operator in standenv.  */
+
+static void
+a68_op (bool portable, const char *n, MOID_T *m, LOWERER_T l = NO_LOWERER)
+{
+  add_a68_standenv (portable, OP_SYMBOL,
+		    a68_some_node (TEXT (a68_add_token (&A68 (top_token), n))),
+		    NO_TEXT, m, 0, l);
+}
+
+/* Enter standard modes in standenv.  */
+
+static void
+stand_moids (void)
+{
+  /* Primitive A68 moids.  */
+  a68_mode (0, "VOID", &M_VOID);
+  /* Standard precision.  */
+  a68_mode (0, "INT", &M_INT);
+  a68_mode (0, "REAL", &M_REAL);
+  a68_mode (0, "COMPL", &M_COMPLEX);
+  a68_mode (0, "BITS", &M_BITS);
+  a68_mode (0, "BYTES", &M_BYTES);
+  /* Multiple precision.  */
+  a68_mode (-2, "INT", &M_SHORT_SHORT_INT);
+  a68_mode (-2, "BITS", &M_SHORT_SHORT_BITS);
+  a68_mode (-1, "INT", &M_SHORT_INT);
+  a68_mode (-1, "BITS", &M_SHORT_BITS);
+  a68_mode (1, "INT", &M_LONG_INT);
+  a68_mode (1, "REAL", &M_LONG_REAL);
+  a68_mode (1, "COMPL", &M_LONG_COMPLEX);
+  a68_mode (1, "BITS", &M_LONG_BITS);
+  a68_mode (1, "BYTES", &M_LONG_BYTES);
+  a68_mode (2, "REAL", &M_LONG_LONG_REAL);
+  a68_mode (2, "INT", &M_LONG_LONG_INT);
+  a68_mode (2, "BITS", &M_LONG_LONG_BITS);
+  a68_mode (2, "COMPL", &M_LONG_LONG_COMPLEX);
+  /* Other.  */
+  a68_mode (0, "BOOL", &M_BOOL);
+  a68_mode (0, "CHAR", &M_CHAR);
+  a68_mode (0, "STRING", &M_STRING);
+  a68_mode (0, "FILE", &M_FILE);
+  a68_mode (0, "CHANNEL", &M_CHANNEL);
+  a68_mode (0, "SEMA", &M_SEMA);
+  /* Rows.  */
+  M_ROWS = a68_add_mode (&TOP_MOID (&A68_JOB), ROWS_SYMBOL, 0, NO_NODE, NO_MOID, NO_PACK);
+  /* REFs.  */
+  M_REF_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_INT, NO_PACK);
+  M_REF_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_REAL, NO_PACK);
+  M_REF_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_COMPLEX, NO_PACK);
+  M_REF_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_BITS, NO_PACK);
+  M_REF_BYTES = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_BYTES, NO_PACK);
+  /* Multiple precision.  */
+  M_REF_LONG_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_INT, NO_PACK);
+  M_REF_LONG_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_REAL, NO_PACK);
+  M_REF_LONG_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_COMPLEX, NO_PACK);
+  M_REF_LONG_LONG_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_INT, NO_PACK);
+  M_REF_LONG_LONG_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_REAL, NO_PACK);
+  M_REF_LONG_LONG_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_COMPLEX, NO_PACK);
+  M_REF_LONG_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_BITS, NO_PACK);
+  M_REF_LONG_LONG_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_LONG_BITS, NO_PACK);
+  M_REF_LONG_BYTES = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_LONG_BYTES, NO_PACK);
+  M_REF_SHORT_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_SHORT_INT, NO_PACK);
+  M_REF_SHORT_SHORT_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_SHORT_SHORT_INT, NO_PACK
+);
+  M_REF_SHORT_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_SHORT_BITS, NO_PACK);
+  M_REF_SHORT_SHORT_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_SHORT_SHORT_BITS, NO_PACK);
+  /* Other.  */
+  M_REF_BOOL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_BOOL, NO_PACK);
+  M_REF_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_CHAR, NO_PACK);
+  M_REF_FILE = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_FILE, NO_PACK);
+  M_REF_REF_FILE = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_REF_FILE, NO_PACK);
+  /* [] INT.  */
+  M_ROW_INT = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_INT, NO_PACK);
+  HAS_ROWS (M_ROW_INT) = true;
+  SLICE (M_ROW_INT) = M_INT;
+  M_REF_ROW_INT = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_INT, NO_PACK);
+  NAME (M_REF_ROW_INT) = M_REF_INT;
+  /* [] REAL.  */
+  M_ROW_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_REAL, NO_PACK);
+  HAS_ROWS (M_ROW_REAL) = true;
+  SLICE (M_ROW_REAL) = M_REAL;
+  M_REF_ROW_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_REAL, NO_PACK);
+  NAME (M_REF_ROW_REAL) = M_REF_REAL;
+  /* [,] REAL.  */
+  M_ROW_ROW_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 2, NO_NODE, M_REAL, NO_PACK);
+  HAS_ROWS (M_ROW_ROW_REAL) = true;
+  SLICE (M_ROW_ROW_REAL) = M_ROW_REAL;
+  M_REF_ROW_ROW_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_ROW_REAL, NO_PACK);
+  NAME (M_REF_ROW_ROW_REAL) = M_REF_ROW_REAL;
+  /* [] COMPLEX.  */
+  M_ROW_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_COMPLEX, NO_PACK);
+  HAS_ROWS (M_ROW_COMPLEX) = true;
+  SLICE (M_ROW_COMPLEX) = M_COMPLEX;
+  M_REF_ROW_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_COMPLEX, NO_PACK);
+  NAME (M_REF_ROW_COMPLEX) = M_REF_COMPLEX;
+  /* [,] COMPLEX.  */
+  M_ROW_ROW_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 2, NO_NODE, M_COMPLEX, NO_PACK);
+  HAS_ROWS (M_ROW_ROW_COMPLEX) = true;
+  SLICE (M_ROW_ROW_COMPLEX) = M_ROW_COMPLEX;
+  M_REF_ROW_ROW_COMPLEX = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_ROW_COMPLEX, NO_PACK);
+  NAME (M_REF_ROW_ROW_COMPLEX) = M_REF_ROW_COMPLEX;
+  /* [] BOOL.  */
+  M_ROW_BOOL = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_BOOL, NO_PACK);
+  HAS_ROWS (M_ROW_BOOL) = true;
+  SLICE (M_ROW_BOOL) = M_BOOL;
+  /* FLEX [] BOOL.  */
+  MOID_T *m = a68_add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, NO_NODE, M_ROW_BOOL, NO_PACK);
+  HAS_ROWS (m) = true;
+  M_FLEX_ROW_BOOL = m;
+  /* [] BITS.  */
+  M_ROW_BITS = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_BITS, NO_PACK);
+  HAS_ROWS (M_ROW_BITS) = true;
+  SLICE (M_ROW_BITS) = M_BITS;
+  /* [] CHAR.  */
+  M_ROW_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_CHAR, NO_PACK);
+  HAS_ROWS (M_ROW_CHAR) = true;
+  SLICE (M_ROW_CHAR) = M_CHAR;
+  /* [][] CHAR.  */
+  M_ROW_ROW_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_ROW_CHAR, NO_PACK);
+  HAS_ROWS (M_ROW_ROW_CHAR) = true;
+  SLICE (M_ROW_ROW_CHAR) = M_ROW_CHAR;
+  /* MODE STRING = FLEX [] CHAR.  */
+  m = a68_add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, NO_NODE, M_ROW_CHAR, NO_PACK);
+  HAS_ROWS (m) = true;
+  M_FLEX_ROW_CHAR = m;
+  EQUIVALENT (M_STRING) = m;
+  /* REF [] CHAR.  */
+  M_REF_ROW_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, M_ROW_CHAR, NO_PACK);
+  NAME (M_REF_ROW_CHAR) = M_REF_CHAR;
+  /* PROC [] CHAR.  */
+  M_PROC_ROW_CHAR = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, 0, NO_NODE, M_ROW_CHAR, NO_PACK);
+  /* REF STRING = REF FLEX [] CHAR.  */
+  M_REF_STRING = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, EQUIVALENT (M_STRING), NO_PACK);
+  NAME (M_REF_STRING) = M_REF_CHAR;
+  DEFLEXED (M_REF_STRING) = M_REF_ROW_CHAR;
+  /* [] STRING.  */
+  M_ROW_STRING = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_STRING, NO_PACK);
+  HAS_ROWS (M_ROW_STRING) = true;
+  SLICE (M_ROW_STRING) = M_STRING;
+  DEFLEXED (M_ROW_STRING) = M_ROW_ROW_CHAR;
+  /* PROC STRING.  */
+  M_PROC_STRING = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, 0, NO_NODE, M_STRING, NO_PACK);
+  DEFLEXED (M_PROC_STRING) = M_PROC_ROW_CHAR;
+  /* COMPLEX.  */
+  PACK_T *z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE);
+  m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z);
+  EQUIVALENT (M_COMPLEX) = m;
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_REF_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_REF_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE);
+  m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z);
+  NAME (M_REF_COMPLEX) = m;
+  /* LONG COMPLEX.  */
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE);
+  m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z);
+  EQUIVALENT (M_LONG_COMPLEX) = m;
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_REF_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_REF_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE);
+  m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z);
+  NAME (M_REF_LONG_COMPLEX) = m;
+  /* LONG_LONG COMPLEX.  */
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_LONG_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_LONG_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE);
+  m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z);
+  EQUIVALENT (M_LONG_LONG_COMPLEX) = m;
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_REF_LONG_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "im")), NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_REF_LONG_LONG_REAL, TEXT (a68_add_token (&A68 (top_token), "re")), NO_NODE);
+  m = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z);
+  NAME (M_REF_LONG_LONG_COMPLEX) = m;
+  /* SEMA.  */
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_REF_INT, NO_TEXT, NO_NODE);
+  EQUIVALENT (M_SEMA) = a68_add_mode (&TOP_MOID (&A68_JOB), STRUCT_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z);
+  /* PROC VOID.  */
+  z = NO_PACK;
+  M_PROC_VOID = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_VOID, z);
+  /* PROC (REAL) REAL.  */
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_REAL, NO_TEXT, NO_NODE);
+  M_PROC_REAL_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_REAL, z);
+  /* PROC (LONG_REAL) LONG_REAL.  */
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_LONG_REAL, NO_TEXT, NO_NODE);
+  M_PROC_LONG_REAL_LONG_REAL = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_LONG_REAL, z);
+  /* IO: PROC (REF FILE) BOOL.  */
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_REF_FILE, NO_TEXT, NO_NODE);
+  M_PROC_REF_FILE_BOOL = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_BOOL, z);
+  /* IO: PROC (REF FILE) VOID.  */
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_REF_FILE, NO_TEXT, NO_NODE);
+  M_PROC_REF_FILE_VOID = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (z), NO_NODE, M_VOID, z);
+  /* IO: SIMPLIN and SIMPLOUT.  */
+  M_SIMPLIN = a68_add_mode (&TOP_MOID (&A68_JOB), IN_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK);
+  M_ROW_SIMPLIN = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_SIMPLIN, NO_PACK);
+  SLICE (M_ROW_SIMPLIN) = M_SIMPLIN;
+  M_SIMPLOUT = a68_add_mode (&TOP_MOID (&A68_JOB), OUT_TYPE_MODE, 0, NO_NODE, NO_MOID, NO_PACK);
+  M_ROW_SIMPLOUT = a68_add_mode (&TOP_MOID (&A68_JOB), ROW_SYMBOL, 1, NO_NODE, M_SIMPLOUT, NO_PACK);
+  SLICE (M_ROW_SIMPLOUT) = M_SIMPLOUT;
+}
+
+/* Set up standenv - general RR but not transput.  */
+
+static void
+stand_prelude (void)
+{
+  /* Identifiers.  */
+  a68_idf (A68_STD, "intlengths", M_INT, a68_lower_intlengths);
+  a68_idf (A68_STD, "intshorths", M_INT, a68_lower_intshorths);
+  a68_idf (A68_STD, "maxint", M_INT, a68_lower_maxint);
+  a68_idf (A68_STD, "longmaxint", M_LONG_INT, a68_lower_maxint);
+  a68_idf (A68_STD, "longlongmaxint", M_LONG_LONG_INT, a68_lower_maxint);
+  a68_idf (A68_STD, "shortmaxint", M_SHORT_INT, a68_lower_maxint);
+  a68_idf (A68_STD, "shortshortmaxint", M_SHORT_SHORT_INT, a68_lower_maxint);
+  a68_idf (A68_STD, "maxreal", M_REAL, a68_lower_maxreal);
+  a68_idf (A68_STD, "longmaxreal", M_LONG_REAL, a68_lower_maxreal);
+  a68_idf (A68_STD, "longlongmaxreal", M_LONG_LONG_REAL, a68_lower_maxreal);
+  a68_idf (A68_STD, "smallreal", M_REAL, a68_lower_smallreal);
+  a68_idf (A68_STD, "longsmallreal", M_LONG_REAL, a68_lower_smallreal);
+  a68_idf (A68_STD, "longlongsmallreal", M_LONG_LONG_REAL, a68_lower_smallreal);
+  a68_idf (A68_STD, "reallengths", M_INT, a68_lower_reallengths);
+  a68_idf (A68_STD, "realshorths", M_INT, a68_lower_realshorths);
+  a68_idf (A68_STD, "bitslengths", M_INT, a68_lower_bitslengths);
+  a68_idf (A68_STD, "bitsshorths", M_INT, a68_lower_bitsshorths);
+  a68_idf (A68_STD, "bitswidth", M_INT, a68_lower_bitswidth);
+  a68_idf (A68_STD, "longbitswidth", M_INT, a68_lower_longbitswidth);
+  a68_idf (A68_STD, "longlongbitswidth", M_INT, a68_lower_longlongbitswidth);
+  a68_idf (A68_STD, "shortbitswidth", M_INT, a68_lower_shortbitswidth);
+  a68_idf (A68_STD, "shortshortbitswidth", M_INT, a68_lower_shortshortbitswidth);
+  a68_idf (A68_STD, "maxbits", M_BITS, a68_lower_maxbits);
+  a68_idf (A68_STD, "longmaxbits", M_LONG_BITS, a68_lower_maxbits);
+  a68_idf (A68_STD, "longlongmaxbits", M_LONG_LONG_BITS, a68_lower_maxbits);
+  a68_idf (A68_STD, "maxabschar", M_INT, a68_lower_maxabschar);
+  a68_idf (A68_STD, "intwidth", M_INT, a68_lower_intwidth);
+  a68_idf (A68_STD, "longintwidth", M_INT, a68_lower_longintwidth);
+  a68_idf (A68_STD, "longlongintwidth", M_INT, a68_lower_longlongintwidth);
+  a68_idf (A68_STD, "shortintwidth", M_INT, a68_lower_shortintwidth);
+  a68_idf (A68_STD, "shortshortintwidth", M_INT, a68_lower_shortshortintwidth);
+  a68_idf (A68_STD, "realwidth", M_INT, a68_lower_realwidth);
+  a68_idf (A68_STD, "longrealwidth", M_INT, a68_lower_longrealwidth);
+  a68_idf (A68_STD, "longlongrealwidth", M_INT, a68_lower_longlongrealwidth);
+  a68_idf (A68_STD, "expwidth", M_INT, a68_lower_expwidth);
+  a68_idf (A68_STD, "longexpwidth", M_INT, a68_lower_longexpwidth);
+  a68_idf (A68_STD, "longlongexpwidth", M_INT, a68_lower_longlongexpwidth);
+  a68_idf (A68_STD, "pi", M_REAL, a68_lower_pi);
+  a68_idf (A68_STD, "longpi", M_LONG_REAL, a68_lower_pi);
+  a68_idf (A68_STD, "longlongpi", M_LONG_LONG_REAL, a68_lower_pi);
+  a68_idf (A68_STD, "compllengths", M_INT);
+  a68_idf (A68_STD, "complshorths", M_INT);
+  a68_idf (A68_STD, "byteslengths", M_INT);
+  a68_idf (A68_STD, "bytesshorths", M_INT);
+  a68_idf (A68_STD, "byteswidth", M_INT);
+  a68_idf (A68_STD, "longbyteswidth", M_INT);
+  a68_idf (A68_STD, "flip", M_CHAR, a68_lower_flip);
+  a68_idf (A68_STD, "flop", M_CHAR, a68_lower_flop);
+  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);
+  a68_idf (A68_STD, "firstrandom", m);
+  /* REAL procedures.  */
+  m = A68_MCACHE (proc_real);
+  a68_idf (A68_STD, "nextrandom", m);
+  a68_idf (A68_STD, "random", m, a68_lower_random);
+  a68_idf (A68_STD, "rnd", m);
+  m = A68_MCACHE (proc_real_real);
+  a68_idf (A68_STD, "arccos", m, a68_lower_acos);
+  a68_idf (A68_STD, "arcsin", m, a68_lower_asin);
+  a68_idf (A68_STD, "arctan", m, a68_lower_atan);
+  a68_idf (A68_STD, "cos", m, a68_lower_cos);
+  a68_idf (A68_STD, "exp", m, a68_lower_exp);
+  a68_idf (A68_STD, "ln", m, a68_lower_ln);
+  a68_idf (A68_STD, "sin", m, a68_lower_sin);
+  a68_idf (A68_STD, "sqrt", m, a68_lower_sqrt);
+  a68_idf (A68_STD, "tan", m, a68_lower_tan);
+  /* LONG REAL procedures.  */
+  m = a68_proc (M_LONG_REAL, NO_MOID);
+  a68_idf (A68_STD, "longnextrandom", m);
+  a68_idf (A68_STD, "longrandom", m, a68_lower_longrandom);
+  m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID);
+  a68_idf (A68_STD, "longarccos", m, a68_lower_long_acos);
+  a68_idf (A68_STD, "longarcsin", m, a68_lower_long_asin);
+  a68_idf (A68_STD, "longarctan", m, a68_lower_long_atan);
+  a68_idf (A68_STD, "longcos", m, a68_lower_long_cos);
+  a68_idf (A68_STD, "longexp", m, a68_lower_long_exp);
+  a68_idf (A68_STD, "longln", m, a68_lower_long_ln);
+  a68_idf (A68_STD, "longsin", m, a68_lower_long_sin);
+  a68_idf (A68_STD, "longsqrt", m, a68_lower_long_sqrt);
+  a68_idf (A68_STD, "longtan", m, a68_lower_long_tan);
+  /* LONG LONG REAL procedures.  */
+  m = a68_proc (M_LONG_LONG_REAL, NO_MOID);
+  a68_idf (A68_STD, "longlongnextrandom", m);
+  a68_idf (A68_STD, "longlongrandom", m, a68_lower_longlongrandom);
+  m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID);
+  a68_idf (A68_STD, "longlongarccos", m, a68_lower_long_long_acos);
+  a68_idf (A68_STD, "longlongarcsin", m, a68_lower_long_long_asin);
+  a68_idf (A68_STD, "longlongarctan", m, a68_lower_long_long_atan);
+  a68_idf (A68_STD, "longlongcos", m, a68_lower_long_long_cos);
+  a68_idf (A68_STD, "longlongexp", m, a68_lower_long_long_exp);
+  a68_idf (A68_STD, "longlongln", m, a68_lower_long_long_ln);
+  a68_idf (A68_STD, "longlongsin", m, a68_lower_long_long_sin);
+  a68_idf (A68_STD, "longlongsqrt", m, a68_lower_long_long_sqrt);
+  a68_idf (A68_STD, "longlongtan", m, a68_lower_long_long_tan);
+  /* Priorities.  */
+  a68_prio ("+:=", 1);
+  a68_prio ("-:=", 1);
+  a68_prio ("*:=", 1);
+  a68_prio ("/:=", 1);
+  a68_prio ("%:=", 1);
+  a68_prio ("%*:=", 1);
+  a68_prio ("+=:", 1);
+  a68_prio ("PLUSAB", 1);
+  a68_prio ("MINUSAB", 1);
+  a68_prio ("TIMESAB", 1);
+  a68_prio ("DIVAB", 1);
+  a68_prio ("OVERAB", 1);
+  a68_prio ("MODAB", 1);
+  a68_prio ("PLUSTO", 1);
+  a68_prio ("OR", 2);
+  a68_prio ("AND", 3);
+  a68_prio ("XOR", 3);
+  a68_prio ("=", 4);
+  a68_prio ("/=", 4);
+  a68_prio ("<", 5);
+  a68_prio ("<=", 5);
+  a68_prio (">", 5);
+  a68_prio (">=", 5);
+  a68_prio ("EQ", 4);
+  a68_prio ("NE", 4);
+  a68_prio ("LT", 5);
+  a68_prio ("LE", 5);
+  a68_prio ("GT", 5);
+  a68_prio ("GE", 5);
+  a68_prio ("+", 6);
+  a68_prio ("-", 6);
+  a68_prio ("*", 7);
+  a68_prio ("/", 7);
+  a68_prio ("OVER", 7);
+  a68_prio ("%", 7);
+  a68_prio ("MOD", 7);
+  a68_prio ("%*", 7);
+  a68_prio ("ELEM", 7);
+  a68_prio ("**", 8);
+  a68_prio ("SHL", 8);
+  a68_prio ("SHR", 8);
+  a68_prio ("UP", 8);
+  a68_prio ("DOWN", 8);
+  a68_prio ("^", 8);
+  a68_prio ("LWB", 8);
+  a68_prio ("UPB", 8);
+  a68_prio ("I", 9);
+  a68_prio ("+*", 9);
+  /* BOOL operators.  */
+  m = a68_proc (M_BOOL, M_BOOL, NO_MOID);
+  a68_op (A68_STD, "NOT", m, a68_lower_not2);
+  a68_op (A68_STD, "~", m, a68_lower_not2);
+  m = a68_proc (M_INT, M_BOOL, NO_MOID);
+  a68_op (A68_STD, "ABS", m, a68_lower_boolabs2);
+  m = a68_proc (M_BOOL, M_BOOL, M_BOOL, NO_MOID);
+  a68_op (A68_STD, "OR", m, a68_lower_or3);
+  a68_op (A68_STD, "AND", m, a68_lower_and3);
+  a68_op (A68_STD, "=", m, a68_lower_bool_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_bool_ne3);
+  a68_op (A68_STD, "EQ", m, a68_lower_bool_eq3);
+  a68_op (A68_STD, "NE", m, a68_lower_bool_ne3);
+  /* CHAR operators.  */
+  m = a68_proc (M_BOOL, M_CHAR, M_CHAR, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_char_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_char_ne3);
+  a68_op (A68_STD, "<", m, a68_lower_char_lt3);
+  a68_op (A68_STD, "<=", m, a68_lower_char_le3);
+  a68_op (A68_STD, ">", m, a68_lower_char_gt3);
+  a68_op (A68_STD, ">=", m, a68_lower_char_ge3);
+  a68_op (A68_STD, "EQ", m, a68_lower_char_eq3);
+  a68_op (A68_STD, "NE", m, a68_lower_char_ne3);
+  a68_op (A68_STD, "LT", m, a68_lower_char_lt3);
+  a68_op (A68_STD, "LE", m, a68_lower_char_le3);
+  a68_op (A68_STD, "GT", m, a68_lower_char_gt3);
+  a68_op (A68_STD, "GE", m, a68_lower_char_ge3);
+  m = a68_proc (M_INT, M_CHAR, NO_MOID);
+  a68_op (A68_STD, "ABS", m, a68_lower_charabs2);
+  m = a68_proc (M_CHAR, M_INT, NO_MOID);
+  a68_op (A68_STD, "REPR", m, a68_lower_repr2);
+  /* STRING operators.  */
+  m = a68_proc (M_BOOL, M_STRING, M_STRING, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_string_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_string_ne3);
+  a68_op (A68_STD, "<", m, a68_lower_string_lt3);
+  a68_op (A68_STD, "<=", m, a68_lower_string_le3);
+  a68_op (A68_STD, ">=", m, a68_lower_string_ge3);
+  a68_op (A68_STD, ">", m, a68_lower_string_gt3);
+  a68_op (A68_STD, "EQ", m, a68_lower_string_eq3);
+  a68_op (A68_STD, "NE", m, a68_lower_string_ne3);
+  a68_op (A68_STD, "LT", m, a68_lower_string_lt3);
+  a68_op (A68_STD, "LE", m, a68_lower_string_le3);
+  a68_op (A68_STD, "GE", m, a68_lower_string_ge3);
+  a68_op (A68_STD, "GT", m, a68_lower_string_gt3);
+  m = a68_proc (M_STRING, M_CHAR, M_CHAR, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_char_plus3);
+  m = a68_proc (M_STRING, M_STRING, M_STRING, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_string_plus3);
+  m = a68_proc (M_REF_STRING, M_REF_STRING, M_STRING, NO_MOID);
+  a68_op (A68_STD, "+:=", m, a68_lower_string_plusab3);
+  a68_op (A68_STD, "PLUSAB", m, a68_lower_string_plusab3);
+  m = a68_proc (M_REF_STRING, M_REF_STRING, M_INT, NO_MOID);
+  a68_op (A68_STD, "*:=", m, a68_lower_string_multab3);
+  a68_op (A68_STD, "TIMESAB", m, a68_lower_string_multab3);
+  m = a68_proc (M_REF_STRING, M_STRING, M_REF_STRING, NO_MOID);
+  a68_op (A68_STD, "+=:", m, a68_lower_string_plusto3);
+  a68_op (A68_STD, "PLUSTO", m, a68_lower_string_plusto3);
+  m = a68_proc (M_STRING, M_STRING, M_INT, NO_MOID);
+  a68_op (A68_STD, "*", m, a68_lower_string_mult3);
+  m = a68_proc (M_STRING, M_INT, M_STRING, NO_MOID);
+  a68_op (A68_STD, "*", m, a68_lower_string_mult3);
+  m = a68_proc (M_STRING, M_INT, M_CHAR, NO_MOID);
+  a68_op (A68_STD, "*", m, a68_lower_char_mult3);
+  m = a68_proc (M_STRING, M_CHAR, M_INT, NO_MOID);
+  a68_op (A68_STD, "*", m, a68_lower_char_mult3);
+  /* SHORT SHORT INT operators.  */
+  m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_confirm2);
+  a68_op (A68_STD, "-", m, a68_lower_negate2);
+  a68_op (A68_STD, "ABS", m, a68_lower_intabs2);
+  m = a68_proc (M_INT, M_SHORT_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "SIGN", m, a68_lower_sign2);
+  m = a68_proc (M_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "LENG", m, a68_lower_lengint2);
+  m = a68_proc (M_BOOL, M_SHORT_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "ODD", m, a68_lower_odd2);
+  m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_plus_int);
+  a68_op (A68_STD, "-", m, a68_lower_minus_int);
+  a68_op (A68_STD, "*", m, a68_lower_mult_int);
+  a68_op (A68_STD, "OVER", m, a68_lower_over3);
+  a68_op (A68_STD, "%", m, a68_lower_over3);
+  a68_op (A68_STD, "MOD", m, a68_lower_mod3);
+  a68_op (A68_STD, "%*", m, a68_lower_mod3);
+  m = a68_proc (M_REF_SHORT_SHORT_INT, M_REF_SHORT_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "+:=", m, a68_lower_plusab3);
+  a68_op (A68_STD, "-:=", m, a68_lower_minusab3);
+  a68_op (A68_STD, "*:=", m, a68_lower_multab3);
+  a68_op (A68_STD, "%:=", m, a68_lower_overab3);
+  a68_op (A68_STD, "%*:=", m, a68_lower_modab3);
+  a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3);
+  a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3);
+  a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3);
+  a68_op (A68_STD, "OVERAB", m, a68_lower_overab3);
+  a68_op (A68_STD, "MODAB", m, a68_lower_modab3);
+  m = a68_proc (M_BOOL, M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "EQ", m, a68_lower_int_eq3);
+  a68_op (A68_STD, "NE", m, a68_lower_int_ne3);
+  a68_op (A68_STD, "GE", m, a68_lower_int_ge3);
+  a68_op (A68_STD, "GT", m, a68_lower_int_gt3);
+  a68_op (A68_STD, "LE", m, a68_lower_int_le3);
+  a68_op (A68_STD, "LT", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "=", m, a68_lower_int_eq3);
+  a68_op (A68_STD, ">=", m, a68_lower_int_ge3);
+  a68_op (A68_STD, ">", m, a68_lower_int_gt3);
+  a68_op (A68_STD, "<=", m, a68_lower_int_le3);
+  a68_op (A68_STD, "<", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "/=", m, a68_lower_int_ne3);
+  m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_SHORT_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m, a68_lower_pow_int);
+  a68_op (A68_STD, "^", m, a68_lower_pow_int);
+  /* SHORT INT operators.  */
+  m = a68_proc (M_SHORT_INT, M_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_confirm2);
+  a68_op (A68_STD, "-", m, a68_lower_negate2);
+  a68_op (A68_STD, "ABS", m, a68_lower_intabs2);
+  m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenint2);
+  m = a68_proc (M_INT, M_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "LENG", m, a68_lower_lengint2);
+  a68_op (A68_STD, "SIGN", m, a68_lower_sign2);
+  m = a68_proc (M_BOOL, M_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "ODD", m, a68_lower_odd2);
+  m = a68_proc (M_SHORT_INT, M_SHORT_INT, M_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_plus_int);
+  a68_op (A68_STD, "-", m, a68_lower_minus_int);
+  a68_op (A68_STD, "*", m, a68_lower_mult_int);
+  a68_op (A68_STD, "OVER", m, a68_lower_over3);
+  a68_op (A68_STD, "%", m, a68_lower_over3);
+  a68_op (A68_STD, "MOD", m, a68_lower_mod3);
+  a68_op (A68_STD, "%*", m, a68_lower_mod3);
+  m = a68_proc (M_REF_SHORT_INT, M_REF_SHORT_INT, M_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "+:=", m, a68_lower_plusab3);
+  a68_op (A68_STD, "-:=", m, a68_lower_minusab3);
+  a68_op (A68_STD, "*:=", m, a68_lower_multab3);
+  a68_op (A68_STD, "%:=", m, a68_lower_overab3);
+  a68_op (A68_STD, "%*:=", m, a68_lower_modab3);
+  a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3);
+  a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3);
+  a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3);
+  a68_op (A68_STD, "OVERAB", m, a68_lower_overab3);
+  a68_op (A68_STD, "MODAB", m, a68_lower_modab3);
+  m = a68_proc (M_BOOL, M_SHORT_INT, M_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_int_eq3);
+  a68_op (A68_STD, "EQ", m, a68_lower_int_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_int_ne3);
+  a68_op (A68_STD, "NE", m, a68_lower_int_ne3);
+  a68_op (A68_STD, "<", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "LT", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "<=", m, a68_lower_int_le3);
+  a68_op (A68_STD, "LE", m, a68_lower_int_le3);
+  a68_op (A68_STD, ">", m, a68_lower_int_gt3);
+  a68_op (A68_STD, "GT", m, a68_lower_int_gt3);
+  a68_op (A68_STD, ">=", m, a68_lower_int_ge3);
+  a68_op (A68_STD, "GE", m, a68_lower_int_ge3);
+  m = a68_proc (M_SHORT_INT, M_SHORT_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m, a68_lower_pow_int);
+  a68_op (A68_STD, "^", m, a68_lower_pow_int);
+  /* INT operators. */
+  m = a68_proc (M_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_confirm2);
+  a68_op (A68_STD, "-", m, a68_lower_negate2);
+  a68_op (A68_STD, "ABS", m, a68_lower_intabs2);
+  a68_op (A68_STD, "SIGN", m, a68_lower_sign2);
+  m = a68_proc (M_SHORT_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenint2);
+  m = a68_proc (M_LONG_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "LENG", m, a68_lower_lengint2);
+  m = a68_proc (M_BOOL, M_INT, NO_MOID);
+  a68_op (A68_STD, "ODD", m, a68_lower_odd2);
+  m = a68_proc (M_BOOL, M_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_int_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_int_ne3);
+  a68_op (A68_STD, "<", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "<=", m, a68_lower_int_le3);
+  a68_op (A68_STD, ">", m, a68_lower_int_gt3);
+  a68_op (A68_STD, ">=", m, a68_lower_int_ge3);
+  a68_op (A68_STD, "EQ", m, a68_lower_int_eq3);
+  a68_op (A68_STD, "NE", m, a68_lower_int_ne3);
+  a68_op (A68_STD, "LT", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "LE", m, a68_lower_int_le3);
+  a68_op (A68_STD, "GT", m, a68_lower_int_gt3);
+  a68_op (A68_STD, "GE", m, a68_lower_int_ge3);
+  m = a68_proc (M_INT, M_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_plus_int);
+  a68_op (A68_STD, "-", m, a68_lower_minus_int);
+  a68_op (A68_STD, "*", m, a68_lower_mult_int);
+  a68_op (A68_STD, "OVER", m, a68_lower_over3);
+  a68_op (A68_STD, "%", m, a68_lower_over3);
+  a68_op (A68_STD, "MOD", m, a68_lower_mod3);
+  a68_op (A68_STD, "%*", m, a68_lower_mod3);
+  a68_op (A68_STD, "**", m, a68_lower_pow_int);
+  a68_op (A68_STD, "^", m, a68_lower_pow_int);
+  m = a68_proc (M_REAL, M_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "/", m, a68_lower_rdiv3);
+  m = a68_proc (M_REF_INT, M_REF_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "+:=", m, a68_lower_plusab3);
+  a68_op (A68_STD, "-:=", m, a68_lower_minusab3);
+  a68_op (A68_STD, "*:=", m, a68_lower_multab3);
+  a68_op (A68_STD, "%:=", m, a68_lower_overab3);
+  a68_op (A68_STD, "%*:=", m, a68_lower_modab3);
+  a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3);
+  a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3);
+  a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3);
+  a68_op (A68_STD, "OVERAB", m, a68_lower_overab3);
+  a68_op (A68_STD, "MODAB", m, a68_lower_modab3);
+  /* LONG INT operators */
+  m = a68_proc (M_LONG_INT, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_confirm2);
+  a68_op (A68_STD, "-", m, a68_lower_negate2);
+  a68_op (A68_STD, "ABS", m, a68_lower_intabs2);
+  m = a68_proc (M_INT, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenint2);
+  a68_op (A68_STD, "SIGN", m, a68_lower_sign2);
+  m = a68_proc (M_LONG_LONG_INT, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "LENG", m, a68_lower_lengint2);
+  m = a68_proc (M_BOOL, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "ODD", m, a68_lower_odd2);
+  m = a68_proc (M_LONG_INT, M_LONG_INT, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_plus_int);
+  a68_op (A68_STD, "-", m, a68_lower_minus_int);
+  a68_op (A68_STD, "*", m, a68_lower_mult_int);
+  a68_op (A68_STD, "OVER", m, a68_lower_over3);
+  a68_op (A68_STD, "%", m, a68_lower_over3);
+  a68_op (A68_STD, "MOD", m, a68_lower_mod3);
+  a68_op (A68_STD, "%*", m, a68_lower_mod3);
+  m = a68_proc (M_REF_LONG_INT, M_REF_LONG_INT, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "+:=", m, a68_lower_plusab3);
+  a68_op (A68_STD, "-:=", m, a68_lower_minusab3);
+  a68_op (A68_STD, "*:=", m, a68_lower_multab3);
+  a68_op (A68_STD, "%:=", m, a68_lower_overab3);
+  a68_op (A68_STD, "%*:=", m, a68_lower_modab3);
+  a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3);
+  a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3);
+  a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3);
+  a68_op (A68_STD, "OVERAB", m, a68_lower_overab3);
+  a68_op (A68_STD, "MODAB", m, a68_lower_modab3);
+  m = a68_proc (M_BOOL, M_LONG_INT, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_int_eq3);
+  a68_op (A68_STD, "EQ", m, a68_lower_int_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_int_ne3);
+  a68_op (A68_STD, "NE", m, a68_lower_int_ne3);
+  a68_op (A68_STD, "<", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "LT", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "<=", m, a68_lower_int_le3);
+  a68_op (A68_STD, "LE", m, a68_lower_int_le3);
+  a68_op (A68_STD, ">", m, a68_lower_int_gt3);
+  a68_op (A68_STD, "GT", m, a68_lower_int_gt3);
+  a68_op (A68_STD, ">=", m, a68_lower_int_ge3);
+  a68_op (A68_STD, "GE", m, a68_lower_int_ge3);
+  m = a68_proc (M_LONG_REAL, M_LONG_INT, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "/", m, a68_lower_rdiv3);
+  m = a68_proc (M_LONG_INT, M_LONG_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m, a68_lower_pow_int);
+  a68_op (A68_STD, "^", m, a68_lower_pow_int);
+  /* LONG LONG INT operators. */
+  m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_confirm2);
+  a68_op (A68_STD, "-", m, a68_lower_negate2);
+  a68_op (A68_STD, "ABS", m, a68_lower_intabs2);
+  m = a68_proc (M_INT, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "SIGN", m, a68_lower_sign2);
+  m = a68_proc (M_LONG_INT, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenint2);
+  m = a68_proc (M_BOOL, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "ODD", m, a68_lower_odd2);
+  m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_plus_int);
+  a68_op (A68_STD, "-", m, a68_lower_minus_int);
+  a68_op (A68_STD, "*", m, a68_lower_mult_int);
+  a68_op (A68_STD, "OVER", m, a68_lower_over3);
+  a68_op (A68_STD, "%", m, a68_lower_over3);
+  a68_op (A68_STD, "MOD", m, a68_lower_mod3);
+  a68_op (A68_STD, "%*", m, a68_lower_mod3);
+  m = a68_proc (M_REF_LONG_LONG_INT, M_REF_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "+:=", m, a68_lower_plusab3);
+  a68_op (A68_STD, "-:=", m, a68_lower_minusab3);
+  a68_op (A68_STD, "*:=", m, a68_lower_multab3);
+  a68_op (A68_STD, "%:=", m, a68_lower_overab3);
+  a68_op (A68_STD, "%*:=", m, a68_lower_modab3);
+  a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3);
+  a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3);
+  a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3);
+  a68_op (A68_STD, "OVERAB", m, a68_lower_overab3);
+  a68_op (A68_STD, "MODAB", m, a68_lower_modab3);
+  m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "/", m, a68_lower_rdiv3);
+  m = a68_proc (M_BOOL, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "EQ", m, a68_lower_int_eq3);
+  a68_op (A68_STD, "NE", m, a68_lower_int_ne3);
+  a68_op (A68_STD, "GE", m, a68_lower_int_ge3);
+  a68_op (A68_STD, "GT", m, a68_lower_int_gt3);
+  a68_op (A68_STD, "LE", m, a68_lower_int_le3);
+  a68_op (A68_STD, "LT", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "=", m, a68_lower_int_eq3);
+  a68_op (A68_STD, ">=", m, a68_lower_int_ge3);
+  a68_op (A68_STD, ">", m, a68_lower_int_gt3);
+  a68_op (A68_STD, "<=", m, a68_lower_int_le3);
+  a68_op (A68_STD, "<", m, a68_lower_int_lt3);
+  a68_op (A68_STD, "/=", m, a68_lower_int_ne3);
+  m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m, a68_lower_pow_int);
+  a68_op (A68_STD, "^", m, a68_lower_pow_int);
+  /* SHORT SHORT BITS operators  */
+  m = a68_proc (M_BOOL, M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "NE", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "<=", m, a68_lower_bit_le3);
+  a68_op (A68_STD, "LE", m, a68_lower_bit_le3);
+  a68_op (A68_STD, ">=", m, a68_lower_bit_ge3);
+  a68_op (A68_STD, "GE", m, a68_lower_bit_ge3);
+  m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "NOT", m, a68_lower_bitnot2);
+  a68_op (A68_STD, "~", m, a68_lower_bitnot2);
+  m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "AND", m, a68_lower_bitand3);
+  a68_op (A68_STD, "OR", m, a68_lower_bitior3);
+  m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, M_INT, NO_MOID);
+  a68_op (A68_STD, "SHL", m, a68_lower_shl3);
+  a68_op (A68_STD, "UP", m, a68_lower_shl3);
+  a68_op (A68_STD, "SHR", m, a68_lower_shr3);
+  a68_op (A68_STD, "DOWN", m, a68_lower_shr3);
+  m = a68_proc (M_BOOL, M_INT, M_SHORT_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3);
+  m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "BIN", m, a68_lower_bin2);
+  m = a68_proc (M_SHORT_SHORT_INT, M_SHORT_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "ABS", m, a68_lower_bitabs2);
+  m = a68_proc (M_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "LENG", m, a68_lower_bitleng2);
+  /* SHORT BITS operatos.  */
+  m = a68_proc (M_SHORT_INT, M_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "ABS", m, a68_lower_bitabs2);
+  m = a68_proc (M_SHORT_BITS, M_SHORT_INT, NO_MOID);
+  a68_op (A68_STD, "BIN", m, a68_lower_bin2);
+  m = a68_proc (M_SHORT_BITS, M_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "NOT", m, a68_lower_bitnot2);
+  a68_op (A68_STD, "~", m, a68_lower_bitnot2);
+  m = a68_proc (M_BOOL, M_SHORT_BITS, M_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "NE", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "<=", m, a68_lower_bit_le3);
+  a68_op (A68_STD, "LE", m, a68_lower_bit_le3);
+  a68_op (A68_STD, ">=", m, a68_lower_bit_ge3);
+  a68_op (A68_STD, "GE", m, a68_lower_bit_ge3);
+  m = a68_proc (M_SHORT_BITS, M_SHORT_BITS, M_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "AND", m, a68_lower_bitand3);
+  a68_op (A68_STD, "OR", m, a68_lower_bitior3);
+  m = a68_proc (M_SHORT_BITS, M_SHORT_BITS, M_INT, NO_MOID);
+  a68_op (A68_STD, "SHL", m, a68_lower_shl3);
+  a68_op (A68_STD, "UP", m, a68_lower_shl3);
+  a68_op (A68_STD, "SHR", m, a68_lower_shr3);
+  a68_op (A68_STD, "DOWN", m, a68_lower_shr3);
+  m = a68_proc (M_BOOL, M_INT, M_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3);
+  m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_bitshorten2);
+  m = a68_proc (M_BITS, M_SHORT_BITS, NO_MOID);
+  a68_op (A68_STD, "LENG", m,  a68_lower_bitleng2);
+  /* BITS operators.  */
+  m = a68_proc (M_INT, M_BITS, NO_MOID);
+  a68_op (A68_STD, "ABS", m, a68_lower_bitabs2);
+  m = a68_proc (M_BITS, M_INT, NO_MOID);
+  a68_op (A68_STD, "BIN", m, a68_lower_bin2);
+  m = a68_proc (M_BITS, M_BITS, NO_MOID);
+  a68_op (A68_STD, "NOT", m, a68_lower_bitnot2);
+  a68_op (A68_STD, "~", m, a68_lower_bitnot2);
+  m = a68_proc (M_BOOL, M_BITS, M_BITS, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "<=", m, a68_lower_bit_le3);
+  a68_op (A68_STD, ">=", m, a68_lower_bit_ge3);
+  a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "NE", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "LE", m, a68_lower_bit_le3);
+  a68_op (A68_STD, "GE", m, a68_lower_bit_ge3);
+  m = a68_proc (M_BITS, M_BITS, M_BITS, NO_MOID);
+  a68_op (A68_STD, "AND", m, a68_lower_bitand3);
+  a68_op (A68_STD, "OR", m, a68_lower_bitior3);
+  m = a68_proc (M_BITS, M_BITS, M_INT, NO_MOID);
+  a68_op (A68_STD, "SHL", m, a68_lower_shl3);
+  a68_op (A68_STD, "UP", m, a68_lower_shl3);
+  a68_op (A68_STD, "SHR", m, a68_lower_shr3);
+  a68_op (A68_STD, "DOWN", m, a68_lower_shr3);
+  m = a68_proc (M_BOOL, M_INT, M_BITS, NO_MOID);
+  a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3);
+  m = a68_proc (M_LONG_BITS, M_BITS, NO_MOID);
+  a68_op (A68_STD, "LENG", m, a68_lower_bitleng2);
+  m = a68_proc (M_SHORT_BITS, M_BITS, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_bitshorten2);
+  /* LONG BITS operatos.  */
+  m = a68_proc (M_LONG_INT, M_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "ABS", m, a68_lower_bitabs2);
+  m = a68_proc (M_LONG_BITS, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "BIN", m, a68_lower_bin2);
+  m = a68_proc (M_LONG_BITS, M_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "NOT", m, a68_lower_bitnot2);
+  a68_op (A68_STD, "~", m, a68_lower_bitnot2);
+  m = a68_proc (M_BOOL, M_LONG_BITS, M_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "NE", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "<=", m, a68_lower_bit_le3);
+  a68_op (A68_STD, "LE", m, a68_lower_bit_le3);
+  a68_op (A68_STD, ">=", m, a68_lower_bit_ge3);
+  a68_op (A68_STD, "GE", m, a68_lower_bit_ge3);
+  m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "AND", m, a68_lower_bitand3);
+  a68_op (A68_STD, "OR", m, a68_lower_bitior3);
+  m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_INT, NO_MOID);
+  a68_op (A68_STD, "SHL", m, a68_lower_shl3);
+  a68_op (A68_STD, "UP", m, a68_lower_shl3);
+  a68_op (A68_STD, "SHR", m, a68_lower_shr3);
+  a68_op (A68_STD, "DOWN", m, a68_lower_shr3);
+  m = a68_proc (M_BOOL, M_INT, M_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3);
+  m = a68_proc (M_BITS, M_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_bitshorten2);
+  m = a68_proc (M_LONG_LONG_BITS, M_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "LENG", m,  a68_lower_bitleng2);
+  /* LONG LONG BITS operators  */
+  m = a68_proc (M_BOOL, M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "EQ", m, a68_lower_bit_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "NE", m, a68_lower_bit_ne3);
+  a68_op (A68_STD, "<=", m, a68_lower_bit_le3);
+  a68_op (A68_STD, "LE", m, a68_lower_bit_le3);
+  a68_op (A68_STD, ">=", m, a68_lower_bit_ge3);
+  a68_op (A68_STD, "GE", m, a68_lower_bit_ge3);
+  m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "NOT", m, a68_lower_bitnot2);
+  a68_op (A68_STD, "~", m, a68_lower_bitnot2);
+  m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "AND", m, a68_lower_bitand3);
+  a68_op (A68_STD, "OR", m, a68_lower_bitior3);
+  m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, M_INT, NO_MOID);
+  a68_op (A68_STD, "SHL", m, a68_lower_shl3);
+  a68_op (A68_STD, "UP", m, a68_lower_shl3);
+  a68_op (A68_STD, "SHR", m, a68_lower_shr3);
+  a68_op (A68_STD, "DOWN", m, a68_lower_shr3);
+  m = a68_proc (M_BOOL, M_INT, M_LONG_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "ELEM", m, a68_lower_bitelem3);
+  m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "BIN", m, a68_lower_bin2);
+  m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "ABS", m, a68_lower_bitabs2);
+  m = a68_proc (M_LONG_BITS, M_LONG_LONG_BITS, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_bitshorten2);
+  /* REAL operators.  */
+  m = A68_MCACHE (proc_real_real);
+  a68_op (A68_STD, "+", m, a68_lower_confirm2);
+  a68_op (A68_STD, "-", m, a68_lower_negate2);
+  a68_op (A68_STD, "ABS", m, a68_lower_realabs2);
+  m = a68_proc (M_INT, M_REAL, NO_MOID);
+  a68_op (A68_STD, "SIGN", m, a68_lower_realsign2);
+  a68_op (A68_STD, "ROUND", m, a68_lower_round2);
+  a68_op (A68_STD, "ENTIER", m, a68_lower_entier2);
+  m = a68_proc (M_BOOL, M_REAL, M_REAL, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_real_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_real_ne3);
+  a68_op (A68_STD, "<", m, a68_lower_real_lt3);
+  a68_op (A68_STD, "<=", m, a68_lower_real_le3);
+  a68_op (A68_STD, ">", m, a68_lower_real_gt3);
+  a68_op (A68_STD, ">=", m, a68_lower_real_ge3);
+  a68_op (A68_STD, "EQ", m, a68_lower_real_eq3);
+  a68_op (A68_STD, "NE", m, a68_lower_real_ne3);
+  a68_op (A68_STD, "LT", m, a68_lower_real_lt3);
+  a68_op (A68_STD, "LE", m, a68_lower_real_le3);
+  a68_op (A68_STD, "GT", m, a68_lower_real_gt3);
+  a68_op (A68_STD, "GE", m, a68_lower_real_ge3);
+  m = A68_MCACHE (proc_real_real_real);
+  a68_op (A68_STD, "+", m, a68_lower_plus_real);
+  a68_op (A68_STD, "-", m, a68_lower_minus_real);
+  a68_op (A68_STD, "*", m, a68_lower_mult_real);
+  a68_op (A68_STD, "/", m, a68_lower_div3);
+  a68_op (A68_STD, "**", m, a68_lower_pow_real);
+  a68_op (A68_STD, "^", m, a68_lower_pow_real);
+  m = a68_proc (M_REAL, M_REAL, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m, a68_lower_pow_real);
+  a68_op (A68_STD, "^", m, a68_lower_pow_real);
+  m = a68_proc (M_REF_REAL, M_REF_REAL, M_REAL, NO_MOID);
+  a68_op (A68_STD, "+:=", m, a68_lower_plusab3);
+  a68_op (A68_STD, "-:=", m, a68_lower_minusab3);
+  a68_op (A68_STD, "*:=", m, a68_lower_multab3);
+  a68_op (A68_STD, "/:=", m, a68_lower_divab3);
+  a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3);
+  a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3);
+  a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3);
+  a68_op (A68_STD, "DIVAB", m, a68_lower_divab3);
+  m = a68_proc (M_LONG_REAL, M_REAL, NO_MOID);
+  a68_op (A68_STD, "LENG", m, a68_lower_lengreal2);
+  /* LONG REAL operators */
+  m = a68_proc (M_LONG_LONG_REAL, M_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "LENG", m, a68_lower_lengreal2);
+  m = a68_proc (M_REAL, M_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenreal2);
+  m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_confirm2);
+  a68_op (A68_STD, "-", m, a68_lower_negate2);
+  a68_op (A68_STD, "ABS", m, a68_lower_realabs2);
+  m = a68_proc (M_INT, M_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "SIGN", m, a68_lower_realsign2);
+  m = a68_proc (M_LONG_INT, M_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "ENTIER", m, a68_lower_entier2);
+  a68_op (A68_STD, "ROUND", m, a68_lower_round2);
+  m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_plus_real);
+  a68_op (A68_STD, "-", m, a68_lower_minus_real);
+  a68_op (A68_STD, "*", m, a68_lower_mult_real);
+  a68_op (A68_STD, "/", m, a68_lower_div3);
+  a68_op (A68_STD, "**", m, a68_lower_pow_real);
+  a68_op (A68_STD, "^", m, a68_lower_pow_real);
+  m = a68_proc (M_REF_LONG_REAL, M_REF_LONG_REAL, M_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "+:=", m, a68_lower_plusab3);
+  a68_op (A68_STD, "-:=", m, a68_lower_minusab3);
+  a68_op (A68_STD, "*:=", m, a68_lower_multab3);
+  a68_op (A68_STD, "/:=", m, a68_lower_divab3);
+  a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3);
+  a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3);
+  a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3);
+  a68_op (A68_STD, "DIVAB", m, a68_lower_divab3);
+  m = a68_proc (M_BOOL, M_LONG_REAL, M_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_real_eq3);
+  a68_op (A68_STD, "EQ", m, a68_lower_real_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_real_ne3);
+  a68_op (A68_STD, "NE", m, a68_lower_real_ne3);
+  a68_op (A68_STD, "<", m, a68_lower_real_lt3);
+  a68_op (A68_STD, "LT", m, a68_lower_real_lt3);
+  a68_op (A68_STD, "<=", m, a68_lower_real_le3);
+  a68_op (A68_STD, "LE", m, a68_lower_real_le3);
+  a68_op (A68_STD, ">", m, a68_lower_real_gt3);
+  a68_op (A68_STD, "GT", m, a68_lower_real_gt3);
+  a68_op (A68_STD, ">=", m, a68_lower_real_ge3);
+  a68_op (A68_STD, "GE", m, a68_lower_real_ge3);
+  m = a68_proc (M_LONG_REAL, M_LONG_REAL, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m, a68_lower_pow_real);
+  a68_op (A68_STD, "^", m, a68_lower_pow_real);
+  /* LONG LONG REAL operators. */
+  m = a68_proc (M_LONG_REAL, M_LONG_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m, a68_lower_shortenreal2);
+  m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "ABS", m, a68_lower_realabs2);
+  a68_op (A68_STD, "+", m, a68_lower_confirm2);
+  a68_op (A68_STD, "-", m, a68_lower_negate2);
+  m = a68_proc (M_INT, M_LONG_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "SIGN", m, a68_lower_realsign2);
+  m = a68_proc (M_LONG_LONG_INT, M_LONG_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "ENTIER", m, a68_lower_entier2);
+  a68_op (A68_STD, "ROUND", m, a68_lower_round2);
+  m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "+", m, a68_lower_plus_real);
+  a68_op (A68_STD, "-", m, a68_lower_minus_real);
+  a68_op (A68_STD, "*", m, a68_lower_mult_real);
+  a68_op (A68_STD, "/", m, a68_lower_div3);
+  a68_op (A68_STD, "**", m, a68_lower_pow_real);
+  a68_op (A68_STD, "^", m, a68_lower_pow_real);
+  m = a68_proc (M_REF_LONG_LONG_REAL, M_REF_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "+:=", m, a68_lower_plusab3);
+  a68_op (A68_STD, "-:=", m, a68_lower_minusab3);
+  a68_op (A68_STD, "*:=", m, a68_lower_multab3);
+  a68_op (A68_STD, "/:=", m, a68_lower_divab3);
+  a68_op (A68_STD, "PLUSAB", m, a68_lower_plusab3);
+  a68_op (A68_STD, "MINUSAB", m, a68_lower_minusab3);
+  a68_op (A68_STD, "TIMESAB", m, a68_lower_multab3);
+  a68_op (A68_STD, "DIVAB", m, a68_lower_divab3);
+  m = a68_proc (M_BOOL, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "=", m, a68_lower_real_eq3);
+  a68_op (A68_STD, "EQ", m, a68_lower_real_eq3);
+  a68_op (A68_STD, "/=", m, a68_lower_real_ne3);
+  a68_op (A68_STD, "NE", m, a68_lower_real_ne3);
+  a68_op (A68_STD, "<", m, a68_lower_real_lt3);
+  a68_op (A68_STD, "LT", m, a68_lower_real_lt3);
+  a68_op (A68_STD, "<=", m, a68_lower_real_le3);
+  a68_op (A68_STD, "LE", m, a68_lower_real_le3);
+  a68_op (A68_STD, ">", m, a68_lower_real_gt3);
+  a68_op (A68_STD, "GT", m, a68_lower_real_gt3);
+  a68_op (A68_STD, ">=", m, a68_lower_real_ge3);
+  a68_op (A68_STD, "GE", m, a68_lower_real_ge3);
+  m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m, a68_lower_pow_real);
+  a68_op (A68_STD, "^", m, a68_lower_pow_real);
+  /* ROWS operators.  */
+  m = a68_proc (M_INT, M_ROWS, NO_MOID);
+  a68_op (A68_STD, "LWB", m, a68_lower_lwb2);
+  a68_op (A68_STD, "UPB", m, a68_lower_upb2);
+  m = a68_proc (M_INT, M_INT, M_ROWS, NO_MOID);
+  a68_op (A68_STD, "LWB", m, a68_lower_lwb3);
+  a68_op (A68_STD, "UPB", m, a68_lower_upb3);
+  /* BYTES operators.  */
+  m = a68_proc (M_BYTES, M_STRING, NO_MOID);
+  a68_idf (A68_STD, "bytespack", m);
+  m = a68_proc (M_CHAR, M_INT, M_BYTES, NO_MOID);
+  a68_op (A68_STD, "ELEM", m);
+  m = a68_proc (M_BYTES, M_BYTES, M_BYTES, NO_MOID);
+  a68_op (A68_STD, "+", m);
+  m = a68_proc (M_REF_BYTES, M_REF_BYTES, M_BYTES, NO_MOID);
+  a68_op (A68_STD, "+:=", m);
+  a68_op (A68_STD, "PLUSAB", m);
+  m = a68_proc (M_BOOL, M_BYTES, M_BYTES, NO_MOID);
+  a68_op (A68_STD, "=", m);
+  a68_op (A68_STD, "/=", m);
+  a68_op (A68_STD, "<", m);
+  a68_op (A68_STD, "<=", m);
+  a68_op (A68_STD, ">", m);
+  a68_op (A68_STD, ">=", m);
+  a68_op (A68_STD, "EQ", m);
+  a68_op (A68_STD, "NE", m);
+  a68_op (A68_STD, "LT", m);
+  a68_op (A68_STD, "LE", m);
+  a68_op (A68_STD, "GT", m);
+  a68_op (A68_STD, "GE", m);
+  /* LONG BYTES operators.  */
+  m = a68_proc (M_LONG_BYTES, M_BYTES, NO_MOID);
+  a68_op (A68_STD, "LENG", m);
+  m = a68_proc (M_BYTES, M_LONG_BYTES, NO_MOID);
+  a68_idf (A68_STD, "SHORTEN", m);
+  m = a68_proc (M_LONG_BYTES, M_STRING, NO_MOID);
+  a68_idf (A68_STD, "longbytespack", m);
+  m = a68_proc (M_CHAR, M_INT, M_LONG_BYTES, NO_MOID);
+  a68_op (A68_STD, "ELEM", m);
+  m = a68_proc (M_LONG_BYTES, M_LONG_BYTES, M_LONG_BYTES, NO_MOID);
+  a68_op (A68_STD, "+", m);
+  m = a68_proc (M_REF_LONG_BYTES, M_REF_LONG_BYTES, M_LONG_BYTES, NO_MOID);
+  a68_op (A68_STD, "+:=", m);
+  a68_op (A68_STD, "PLUSAB", m);
+  m = a68_proc (M_BOOL, M_LONG_BYTES, M_LONG_BYTES, NO_MOID);
+  a68_op (A68_STD, "=", m);
+  a68_op (A68_STD, "/=", m);
+  a68_op (A68_STD, "<", m);
+  a68_op (A68_STD, "<=", m);
+  a68_op (A68_STD, ">", m);
+  a68_op (A68_STD, ">=", m);
+  a68_op (A68_STD, "EQ", m);
+  a68_op (A68_STD, "NE", m);
+  a68_op (A68_STD, "LT", m);
+  a68_op (A68_STD, "LE", m);
+  a68_op (A68_STD, "GT", m);
+  a68_op (A68_STD, "GE", m);
+  /* COMPLEX operators.  */
+  m = a68_proc (M_COMPLEX, M_REAL, M_REAL, NO_MOID);
+  a68_op (A68_STD, "I", m, a68_lower_reali);
+  a68_op (A68_STD, "+*", m, a68_lower_reali);
+  m = a68_proc (M_COMPLEX, M_INT, M_INT, NO_MOID);
+  a68_op (A68_STD, "I", m, a68_lower_inti);
+  a68_op (A68_STD, "+*", m, a68_lower_inti);
+  m = a68_proc (M_REAL, M_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "RE", m, a68_lower_re2);
+  a68_op (A68_STD, "IM", m, a68_lower_im2);
+  a68_op (A68_STD, "ABS", m);
+  a68_op (A68_STD, "ARG", m);
+  m = A68_MCACHE (proc_complex_complex);
+  a68_op (A68_STD, "+", m);
+  a68_op (A68_STD, "-", m);
+  a68_op (A68_STD, "CONJ", m, a68_lower_conj2);
+  m = a68_proc (M_BOOL, M_COMPLEX, M_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "=", m);
+  a68_op (A68_STD, "/=", m);
+  a68_op (A68_STD, "EQ", m);
+  a68_op (A68_STD, "NE", m);
+  m = a68_proc (M_COMPLEX, M_COMPLEX, M_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "+", m);
+  a68_op (A68_STD, "-", m);
+  a68_op (A68_STD, "*", m);
+  a68_op (A68_STD, "/", m);
+  m = a68_proc (M_COMPLEX, M_COMPLEX, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m);
+  a68_op (A68_STD, "UP", m);
+  a68_op (A68_STD, "^", m);
+  m = a68_proc (M_REF_COMPLEX, M_REF_COMPLEX, M_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "+:=", m);
+  a68_op (A68_STD, "-:=", m);
+  a68_op (A68_STD, "*:=", m);
+  a68_op (A68_STD, "/:=", m);
+  a68_op (A68_STD, "PLUSAB", m);
+  a68_op (A68_STD, "MINUSAB", m);
+  a68_op (A68_STD, "TIMESAB", m);
+  a68_op (A68_STD, "DIVAB", m);
+  m = a68_proc (M_COMPLEX, M_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m);
+  /* LONG COMPLEX  operators */
+  m = a68_proc (M_LONG_COMPLEX, M_LONG_INT, M_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "I", m, a68_lower_longinti);
+  a68_op (A68_STD, "+*", m, a68_lower_longinti);
+  m = a68_proc (M_LONG_COMPLEX, M_LONG_REAL, M_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "I", m, a68_lower_longreali);
+  a68_op (A68_STD, "+*", m, a68_lower_longreali);
+  m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "LENG", m);
+  m = a68_proc (M_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m);
+  m = a68_proc (M_LONG_COMPLEX, M_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "LENG", m);
+  m = a68_proc (M_COMPLEX, M_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "SHORTEN", m);
+  m = a68_proc (M_LONG_REAL, M_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "RE", m, a68_lower_re2);
+  a68_op (A68_STD, "IM", m, a68_lower_im2);
+  a68_op (A68_STD, "ARG", m);
+  a68_op (A68_STD, "ABS", m);
+  m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "+", m);
+  a68_op (A68_STD, "-", m);
+  a68_op (A68_STD, "CONJ", m, a68_lower_conj2);
+  m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "+", m);
+  a68_op (A68_STD, "-", m);
+  a68_op (A68_STD, "*", m);
+  a68_op (A68_STD, "/", m);
+  m = a68_proc (M_LONG_COMPLEX, M_LONG_COMPLEX, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m);
+  a68_op (A68_STD, "UP", m);
+  a68_op (A68_STD, "^", m);
+  m = a68_proc (M_BOOL, M_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "=", m);
+  a68_op (A68_STD, "EQ", m);
+  a68_op (A68_STD, "/=", m);
+  a68_op (A68_STD, "NE", m);
+  m = a68_proc (M_REF_LONG_COMPLEX, M_REF_LONG_COMPLEX, M_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "+:=", m);
+  a68_op (A68_STD, "-:=", m);
+  a68_op (A68_STD, "*:=", m);
+  a68_op (A68_STD, "/:=", m);
+  a68_op (A68_STD, "PLUSAB", m);
+  a68_op (A68_STD, "MINUSAB", m);
+  a68_op (A68_STD, "TIMESAB", m);
+  a68_op (A68_STD, "DIVAB", m);
+  /* LONG LONG COMPLEX operators.  */
+  m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_INT, M_LONG_LONG_INT, NO_MOID);
+  a68_op (A68_STD, "I", m, a68_lower_longlonginti);
+  a68_op (A68_STD, "+*", m, a68_lower_longlonginti);
+  m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID);
+  a68_op (A68_STD, "I", m, a68_lower_longlongreali);
+  a68_op (A68_STD, "+*", m, a68_lower_longlongreali);
+  m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "RE", m, a68_lower_re2);
+  a68_op (A68_STD, "IM", m, a68_lower_im2);
+  a68_op (A68_STD, "ARG", m);
+  a68_op (A68_STD, "ABS", m);
+  m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "+", m);
+  a68_op (A68_STD, "-", m);
+  a68_op (A68_STD, "CONJ", m, a68_lower_conj2);
+  m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "+", m);
+  a68_op (A68_STD, "-", m);
+  a68_op (A68_STD, "*", m);
+  a68_op (A68_STD, "/", m);
+  m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, M_INT, NO_MOID);
+  a68_op (A68_STD, "**", m);
+  a68_op (A68_STD, "UP", m);
+  a68_op (A68_STD, "^", m);
+  m = a68_proc (M_BOOL, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "=", m);
+  a68_op (A68_STD, "EQ", m);
+  a68_op (A68_STD, "/=", m);
+  a68_op (A68_STD, "NE", m);
+  m = a68_proc (M_REF_LONG_LONG_COMPLEX, M_REF_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "+:=", m);
+  a68_op (A68_STD, "-:=", m);
+  a68_op (A68_STD, "*:=", m);
+  a68_op (A68_STD, "/:=", m);
+  a68_op (A68_STD, "PLUSAB", m);
+  a68_op (A68_STD, "MINUSAB", m);
+  a68_op (A68_STD, "TIMESAB", m);
+  a68_op (A68_STD, "DIVAB", m);
+  m = a68_proc (M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX, NO_MOID);
+  a68_op (A68_STD, "LENG", m);
+  /* SEMA operators.  */
+  m = a68_proc (M_SEMA, M_INT, NO_MOID);
+  a68_op (A68_STD, "LEVEL", m);
+  m = a68_proc (M_INT, M_SEMA, NO_MOID);
+  a68_op (A68_STD, "LEVEL", m);
+  m = a68_proc (M_VOID, M_SEMA, NO_MOID);
+  a68_op (A68_STD, "UP", m);
+  a68_op (A68_STD, "DOWN", m);
+}
+
+/* GNU extensions for the standenv.  */
+
+static void
+gnu_prelude (void)
+{
+  MOID_T *m = NO_MOID;
+  /* Priorities.  */
+  a68_prio ("ELEMS", 8);
+  /* Identifiers.  */
+  a68_idf (A68_EXT, "infinity", M_REAL, a68_lower_infinity);
+  a68_idf (A68_EXT, "minusinfinity", M_REAL, a68_lower_minusinfinity);
+  a68_idf (A68_EXT, "longlonginfinity", M_LONG_LONG_REAL);
+  a68_idf (A68_EXT, "longlongminusinfinity", M_LONG_LONG_REAL);
+  a68_idf (A68_EXT, "longinfinity", M_LONG_REAL);
+  a68_idf (A68_EXT, "longminusinfinity", M_LONG_REAL);
+  a68_idf (A68_EXT, "minint", M_INT, a68_lower_minint);
+  a68_idf (A68_EXT, "longminint", M_LONG_INT, a68_lower_minint);
+  a68_idf (A68_EXT, "longlongminint", M_LONG_LONG_INT, a68_lower_minint);
+  a68_idf (A68_EXT, "shortminint", M_SHORT_INT, a68_lower_minint);
+  a68_idf (A68_EXT, "shortshortminint", M_SHORT_SHORT_INT, a68_lower_minint);
+  a68_idf (A68_EXT, "minreal", M_REAL, a68_lower_minreal);
+  a68_idf (A68_EXT, "longminreal", M_LONG_REAL, a68_lower_minreal);
+  a68_idf (A68_EXT, "longlongminreal", M_LONG_LONG_REAL, a68_lower_minreal);
+  a68_idf (A68_EXT, "invalidchar", M_CHAR, a68_lower_invalidchar);
+  /* REAL procedures.  */
+  m = A68_MCACHE (proc_real_real);
+  a68_idf (A68_EXT, "log", m, a68_lower_log);
+  /* LONG REAL procedures.  */
+  m = a68_proc (M_LONG_REAL, M_LONG_REAL, NO_MOID);
+  a68_idf (A68_EXT, "longlog", m, a68_lower_long_log);
+  /* LONG LONG REAL procedures.  */
+  m = a68_proc (M_LONG_LONG_REAL, M_LONG_LONG_REAL, NO_MOID);
+  a68_idf (A68_EXT, "longlonglog", m, a68_lower_long_long_log);
+  /* BOOL operators.  */
+  m = a68_proc (M_BOOL, M_BOOL, M_BOOL, NO_MOID);
+  a68_op (A68_EXT, "XOR", m, a68_lower_xor3);
+  /* SHORT SHORT BITS operators.  */
+  m = a68_proc (M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, M_SHORT_SHORT_BITS, NO_MOID);
+  a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3);
+  /* SHORT BITS operators.  */
+  m = a68_proc (M_SHORT_BITS, M_SHORT_BITS, M_SHORT_BITS, NO_MOID);
+  a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3);
+  /* BITS operators.  */
+  m = a68_proc (M_BITS, M_BITS, M_BITS, NO_MOID);
+  a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3);
+  /* LONG BITS operators.  */
+  m = a68_proc (M_LONG_BITS, M_LONG_BITS, M_LONG_BITS, NO_MOID);
+  a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3);
+  /* LONG LONG BITS operators.  */
+  m = a68_proc (M_LONG_LONG_BITS, M_LONG_LONG_BITS, M_LONG_LONG_BITS, NO_MOID);
+  a68_op (A68_EXT, "XOR", m, a68_lower_bitxor3);
+  /* ROWS operators.  */
+  m = a68_proc (M_INT, M_ROWS, NO_MOID);
+  a68_op (A68_EXT, "ELEMS", m, a68_lower_elems2);
+  m = a68_proc (M_INT, M_INT, M_ROWS, NO_MOID);
+  a68_op (A68_EXT, "ELEMS", m, a68_lower_elems3);
+}
+
+/* POSIX prelude.  */
+
+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, "setexitstatus", m, a68_lower_setexitstatus);
+  /* 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);
+  /* 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);
+}
+
+/* Transput.  */
+
+static void
+stand_transput (void)
+{
+  PACK_T *z = NO_PACK;
+  MOID_T *m = NO_MOID;
+
+  /* Modes.  */
+
+  /* NUMBER  */
+  z = NO_PACK;
+  (void) a68_add_mode_to_pack (&z, M_INT, NO_TEXT, NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_LONG_INT, NO_TEXT, NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_LONG_LONG_INT, NO_TEXT, NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_SHORT_INT, NO_TEXT, NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_SHORT_SHORT_INT, NO_TEXT, NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_REAL, NO_TEXT, NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_LONG_REAL, NO_TEXT, NO_NODE);
+  (void) a68_add_mode_to_pack (&z, M_LONG_LONG_REAL, NO_TEXT, NO_NODE);
+  M_NUMBER = a68_add_mode (&TOP_MOID (&A68_JOB), UNION_SYMBOL, a68_count_pack_members (z), NO_NODE, NO_MOID, z);
+
+  /* Layout procedures.  */
+
+  /* Conversion procedures.  */
+  m = a68_proc (M_STRING, M_NUMBER, M_INT, NO_MOID);
+  a68_idf (A68_STD, "whole", m);
+}
+
+/* Build the standard environ symbol table.  */
+
+void
+a68_make_standard_environ (void)
+{
+  stand_moids ();
+  A68_MCACHE (proc_bool) = a68_proc (M_BOOL, NO_MOID);
+  A68_MCACHE (proc_char) = a68_proc (M_CHAR, NO_MOID);
+  A68_MCACHE (proc_complex_complex) = a68_proc (M_COMPLEX, M_COMPLEX, NO_MOID);
+  A68_MCACHE (proc_int) = a68_proc (M_INT, NO_MOID);
+  A68_MCACHE (proc_int_int) = a68_proc (M_INT, M_INT, NO_MOID);
+  A68_MCACHE (proc_int_int_real) = a68_proc (M_REAL, M_INT, M_INT, NO_MOID);
+  A68_MCACHE (proc_int_real) = a68_proc (M_REAL, M_INT, NO_MOID);
+  A68_MCACHE (proc_int_real_real) = a68_proc (M_REAL, M_INT, M_REAL, NO_MOID);
+  A68_MCACHE (proc_int_real_real_real) = a68_proc (M_REAL, M_INT, M_REAL, M_REAL, NO_MOID);
+  A68_MCACHE (proc_real) = a68_proc (M_REAL, NO_MOID);
+  A68_MCACHE (proc_real_int_real) = a68_proc (M_REAL, M_REAL, M_INT, NO_MOID);
+  A68_MCACHE (proc_real_real_int_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_INT, NO_MOID);
+  A68_MCACHE (proc_real_real) = M_PROC_REAL_REAL;
+  A68_MCACHE (proc_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, NO_MOID);
+  A68_MCACHE (proc_real_real_real_int) = a68_proc (M_INT, M_REAL, M_REAL, M_REAL, NO_MOID);
+  A68_MCACHE (proc_real_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, NO_MOID);
+  A68_MCACHE (proc_real_real_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, NO_MOID);
+  A68_MCACHE (proc_real_real_real_real_real_real) = a68_proc (M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, M_REAL, NO_MOID);
+  A68_MCACHE (proc_real_ref_real_ref_int_void) = a68_proc (M_VOID, M_REAL, M_REF_REAL, M_REF_INT, NO_MOID);
+  A68_MCACHE (proc_void) = a68_proc (M_VOID, NO_MOID);
+  stand_prelude ();
+  if (!OPTION_STRICT (&A68_JOB))
+    {
+      gnu_prelude ();
+      posix_prelude ();
+    }
+  stand_transput ();
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 23/47] a68: parser: parsing of modes
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (21 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 22/47] a68: parser: standard prelude definitions Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 24/47] a68: parser: symbol table management Jose E. Marchesi
                   ` (24 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-moids-diagnostics.cc        |  269 +++
 gcc/algol68/a68-moids-misc.cc               | 1370 ++++++++++++++
 gcc/algol68/a68-moids-to-string.cc          |  366 ++++
 gcc/algol68/a68-parser-modes.cc             | 1301 +++++++++++++
 gcc/algol68/a68-parser-moids-check.cc       | 1811 +++++++++++++++++++
 gcc/algol68/a68-parser-moids-coerce.cc      |  874 +++++++++
 gcc/algol68/a68-parser-moids-equivalence.cc |  174 ++
 gcc/algol68/a68-postulates.cc               |  103 ++
 8 files changed, 6268 insertions(+)
 create mode 100644 gcc/algol68/a68-moids-diagnostics.cc
 create mode 100644 gcc/algol68/a68-moids-misc.cc
 create mode 100644 gcc/algol68/a68-moids-to-string.cc
 create mode 100644 gcc/algol68/a68-parser-modes.cc
 create mode 100644 gcc/algol68/a68-parser-moids-check.cc
 create mode 100644 gcc/algol68/a68-parser-moids-coerce.cc
 create mode 100644 gcc/algol68/a68-parser-moids-equivalence.cc
 create mode 100644 gcc/algol68/a68-postulates.cc

diff --git a/gcc/algol68/a68-moids-diagnostics.cc b/gcc/algol68/a68-moids-diagnostics.cc
new file mode 100644
index 00000000000..1bc461d22ef
--- /dev/null
+++ b/gcc/algol68/a68-moids-diagnostics.cc
@@ -0,0 +1,269 @@
+/* MOID diagnostics routines.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/* Give accurate error message.  */
+
+char *
+a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, int depth)
+{
+#define TAIL(z) (&(z)[strlen (z)])
+  static BUFFER txt;
+  if (depth == 1)
+    txt[0] = '\0';
+  if (IS (p, SERIES_MODE))
+    {
+      PACK_T *u = PACK (p);
+
+      int N = 0;
+      if (u == NO_PACK)
+	{
+	  if (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") < 0)
+	    gcc_unreachable ();
+	  N++;
+	}
+      else
+	{
+	  for (; u != NO_PACK; FORWARD (u))
+	    {
+	      if (MOID (u) != NO_MOID)
+		{
+		  if (IS (MOID (u), SERIES_MODE))
+		    (void) a68_mode_error_text (n, MOID (u), q, context, deflex, depth + 1);
+		  else if (!a68_is_coercible (MOID (u), q, context, deflex))
+		    {
+		      size_t len = strlen (txt);
+		      if (len > BUFFER_SIZE / 2)
+			{
+			  if (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") < 0)
+			    gcc_unreachable ();
+			  N++;
+			}
+		      else
+			{
+			  if (strlen (txt) > 0)
+			    {
+			      if (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") < 0)
+				gcc_unreachable ();
+			      N++;
+			    }
+			  if (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s",
+					a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0)
+			    gcc_unreachable ();
+			  N++;
+			}
+		    }
+		}
+	    }
+	}
+      if (depth == 1)
+	{
+	  if (N == 0)
+	    {
+	      if (snprintf (TAIL (txt), SNPRINTF_SIZE, "mode") < 0)
+		gcc_unreachable ();
+	    }
+	  if (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s",
+			a68_moid_to_string (q, MOID_ERROR_WIDTH, n)) < 0)
+	    gcc_unreachable ();
+	}
+    }
+  else if (IS (p, STOWED_MODE) && IS_FLEX (q))
+    {
+      PACK_T *u = PACK (p);
+
+      if (u == NO_PACK)
+	{
+	  if (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") < 0)
+	    gcc_unreachable ();
+	}
+      else
+	{
+	  for (; u != NO_PACK; FORWARD (u))
+	    {
+	      if (!a68_is_coercible (MOID (u), SLICE (SUB (q)), context, deflex))
+		{
+		  size_t len = strlen (txt);
+		  if (len > BUFFER_SIZE / 2)
+		    {
+		      if (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") < 0)
+			gcc_unreachable ();
+		    }
+		  else
+		    {
+		      if (strlen (txt) > 0)
+			{
+			  if (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") < 0)
+			    gcc_unreachable ();
+			}
+		      if (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s",
+				    a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0)
+			gcc_unreachable ();
+		    }
+		}
+	    }
+	  if (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s",
+			a68_moid_to_string (SLICE (SUB (q)), MOID_ERROR_WIDTH, n)) < 0)
+	    gcc_unreachable ();
+	}
+    }
+  else if (IS (p, STOWED_MODE) && IS (q, ROW_SYMBOL))
+    {
+      PACK_T *u = PACK (p);
+
+      if (u == NO_PACK)
+	{
+	  if (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") < 0)
+	    gcc_unreachable ();
+	}
+      else
+	{
+	  for (; u != NO_PACK; FORWARD (u))
+	    {
+	      if (!a68_is_coercible (MOID (u), SLICE (q), context, deflex))
+		{
+		  size_t len = strlen (txt);
+		  if (len > BUFFER_SIZE / 2)
+		    {
+		      if (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") < 0)
+			gcc_unreachable ();
+		    }
+		  else
+		    {
+		      if (strlen (txt) > 0)
+			{
+			  if (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") < 0)
+			    gcc_unreachable ();
+			}
+		      if (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s",
+				    a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n)) < 0)
+			gcc_unreachable ();
+		    }
+		}
+	    }
+	  if (snprintf (TAIL (txt), SNPRINTF_SIZE, " cannot be coerced to %s",
+			a68_moid_to_string (SLICE (q), MOID_ERROR_WIDTH, n)) < 0)
+	    gcc_unreachable ();
+	}
+    }
+  else if (IS (p, STOWED_MODE) && (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL)))
+    {
+      PACK_T *u = PACK (p), *v = PACK (q);
+
+      if (u == NO_PACK)
+	{
+	  if (snprintf (txt, SNPRINTF_SIZE, "empty mode-list") < 0)
+	    gcc_unreachable ();
+	}
+      else
+	{
+	  for (; u != NO_PACK && v != NO_PACK; FORWARD (u), FORWARD (v))
+	    {
+	      if (!a68_is_coercible (MOID (u), MOID (v), context, deflex))
+		{
+		  size_t len = strlen (txt);
+		  if (len > BUFFER_SIZE / 2)
+		    {
+		      if (snprintf (TAIL (txt), SNPRINTF_SIZE, " etcetera") < 0)
+			gcc_unreachable ();
+		    }
+		  else
+		    {
+		      if (strlen (txt) > 0)
+			{
+			  if (snprintf (TAIL (txt), SNPRINTF_SIZE, " and ") < 0)
+			    gcc_unreachable ();
+			}
+		      if (snprintf (TAIL (txt), SNPRINTF_SIZE, "%s cannot be coerced to %s",
+				    a68_moid_to_string (MOID (u), MOID_ERROR_WIDTH, n),
+				    a68_moid_to_string (MOID (v), MOID_ERROR_WIDTH, n)) < 0)
+			gcc_unreachable ();
+		    }
+		}
+	    }
+	}
+    }
+  return txt;
+#undef TAIL
+}
+
+/* Cannot coerce error.  */
+
+void
+a68_cannot_coerce (NODE_T *p, MOID_T *from, MOID_T *to, int context, int deflex, int att)
+{
+  char *txt = a68_mode_error_text (p, from, to, context, deflex, 1);
+
+  if (att == STOP)
+    {
+      if (strlen (txt) == 0)
+	a68_error (p, "M cannot be coerced to M in C context", from, to, context);
+      else
+	a68_error (p, "Y in C context", txt, context);
+    }
+  else
+    {
+      if (strlen (txt) == 0)
+	a68_error (p, "M cannot be coerced to M in C-A", from, to, context, att);
+      else
+	a68_error (p, "Y in C-A", txt, context, att);
+    }
+}
+
+/* Give a warning when a value is silently discarded.  */
+
+void
+a68_warn_for_voiding (NODE_T *p, SOID_T *x, SOID_T *y, int c)
+{
+  (void) c;
+
+  if (CAST (x) == false)
+    {
+      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));
+	}
+    }
+}
+
+/* Warn for things that are likely unintended.  */
+
+void
+a68_semantic_pitfall (NODE_T *p, MOID_T *m, int c, int u)
+{
+  /* semantic_pitfall: warn for things that are likely unintended, for instance
+                       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);
+  else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP))
+    a68_semantic_pitfall (SUB (p), m, c, u);
+}
diff --git a/gcc/algol68/a68-moids-misc.cc b/gcc/algol68/a68-moids-misc.cc
new file mode 100644
index 00000000000..9712c8b2a77
--- /dev/null
+++ b/gcc/algol68/a68-moids-misc.cc
@@ -0,0 +1,1370 @@
+/* Miscellaneous MOID routines.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/*
+ * MODE checker routines.
+ */
+
+/* Absorb nested series modes recursively.  */
+
+void
+a68_absorb_series_pack (MOID_T **p)
+{
+  bool siga;
+
+  do
+    {
+      PACK_T *z = NO_PACK;
+
+      siga = false;
+      for (PACK_T *t = PACK (*p); t != NO_PACK; FORWARD (t))
+	{
+	  if (MOID (t) != NO_MOID && IS (MOID (t), SERIES_MODE))
+	    {
+	      siga = true;
+	      for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s))
+		a68_add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
+	    }
+	  else
+	    a68_add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
+	}
+      PACK (*p) = z;
+    }
+  while (siga);
+}
+
+/* Make SERIES (u, v).  */
+
+MOID_T *
+a68_make_series_from_moids (MOID_T *u, MOID_T *v)
+{
+  MOID_T *x = a68_new_moid ();
+
+  ATTRIBUTE (x) = SERIES_MODE;
+  a68_add_mode_to_pack (&(PACK (x)), u, NO_TEXT, NODE (u));
+  a68_add_mode_to_pack (&(PACK (x)), v, NO_TEXT, NODE (v));
+  a68_absorb_series_pack (&x);
+  DIM (x) = a68_count_pack_members (PACK (x));
+  (void) a68_register_extra_mode (&TOP_MOID (&A68_JOB), x);
+  if (DIM (x) == 1)
+    return MOID (PACK (x));
+  else
+    return x;
+}
+
+/* Absorb firmly related unions in mode.
+
+   For instance invalid UNION (PROC REF UNION (A, B), A, B) -> valid
+   UNION (A, B), which is used in balancing conformity clauses.  */
+
+MOID_T *
+a68_absorb_related_subsets (MOID_T * m)
+{
+  /* For instance invalid UNION (PROC REF UNION (A, B), A, B) -> valid UNION
+     (A, B), which is used in balancing conformity clauses.  */
+  bool siga;
+
+  do
+    {
+      PACK_T *u = NO_PACK;
+
+      siga = false;
+      for (PACK_T *v = PACK (m); v != NO_PACK; FORWARD (v))
+	{
+	  MOID_T *n = a68_depref_completely (MOID (v));
+
+	  if (IS (n, UNION_SYMBOL) && a68_is_subset (n, m, SAFE_DEFLEXING))
+	    {
+	      /*  Unpack it.  */
+	      for (PACK_T *w = PACK (n); w != NO_PACK; FORWARD (w))
+		a68_add_mode_to_pack (&u, MOID (w), NO_TEXT, NODE (w));
+	      siga = true;
+	    }
+	  else
+	    a68_add_mode_to_pack (&u, MOID (v), NO_TEXT, NODE (v));
+	}
+      PACK (m) = a68_absorb_union_pack (u);
+    }
+  while (siga);
+  return m;
+}
+
+/* Absorb nested series and united modes recursively.  */
+
+void
+a68_absorb_series_union_pack (MOID_T **p)
+{
+  bool siga;
+
+  do
+    {
+      PACK_T *z = NO_PACK;
+
+      siga = false;
+      for (PACK_T *t = PACK (*p); t != NO_PACK; FORWARD (t))
+	{
+	  if (MOID (t) != NO_MOID && (IS (MOID (t), SERIES_MODE) || IS (MOID (t), UNION_SYMBOL)))
+	    {
+	      siga = true;
+	      for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s))
+		a68_add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
+	    }
+	  else
+	    a68_add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
+	}
+      PACK (*p) = z;
+    }
+  while (siga);
+}
+
+/* Make united mode, from mode that is a SERIES (..).  */
+
+MOID_T *
+a68_make_united_mode (MOID_T *m)
+{
+  if (m == NO_MOID)
+    return M_ERROR;
+  else if (ATTRIBUTE (m) != SERIES_MODE)
+    return m;
+
+  /* Do not unite a single UNION.  */
+  if (DIM (m) == 1 && IS (MOID (PACK (m)), UNION_SYMBOL))
+    return MOID (PACK (m));
+
+  /* Straighten the series.  */
+  a68_absorb_series_union_pack (&m);
+  /* Copy the series into a UNION.  */
+  MOID_T *u = a68_new_moid ();
+  ATTRIBUTE (u) = UNION_SYMBOL;
+  PACK (u) = NO_PACK;
+  for (PACK_T *w = PACK (m); w != NO_PACK; FORWARD (w))
+    a68_add_mode_to_pack (&(PACK (u)), MOID (w), NO_TEXT, NODE (m));
+
+  /* Absorb and contract the new UNION.  */
+  a68_absorb_series_union_pack (&u);
+  DIM (u) = a68_count_pack_members (PACK (u));
+  PACK (u) = a68_absorb_union_pack (PACK (u));
+  a68_contract_union (u);
+  DIM (u) = a68_count_pack_members (PACK (u));
+  /* A UNION of one mode is that mode itself.  */
+  if (DIM (u) == 1)
+    return MOID (PACK (u));
+  else
+    return a68_register_extra_mode (&TOP_MOID (&A68_JOB), u);
+}
+
+/* Make SOID data structure.  */
+
+void
+a68_make_soid (SOID_T *s, int sort, MOID_T *type, int attribute)
+{
+  ATTRIBUTE (s) = attribute;
+  SORT (s) = sort;
+  MOID (s) = type;
+  CAST (s) = false;
+}
+
+/* Whether mode is not well defined.  */
+
+bool
+a68_is_mode_isnt_well (MOID_T *p)
+{
+  if (p == NO_MOID)
+    return true;
+  else if (!A68_IF_MODE_IS_WELL (p))
+    return true;
+  else if (PACK (p) != NO_PACK)
+    {
+      for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q))
+	{
+	  if (!A68_IF_MODE_IS_WELL (MOID (q)))
+	    return true;
+	}
+    }
+  return false;
+}
+
+/* Add SOID data to free chain.  */
+
+void
+a68_free_soid_list (SOID_T *root)
+{
+  if (root != NO_SOID)
+    {
+      SOID_T *q = root;
+
+      for (; NEXT (q) != NO_SOID; FORWARD (q))
+	;
+      NEXT (q) = A68 (top_soid_list);
+      A68 (top_soid_list) = root;
+    }
+}
+
+/* Add SOID data structure to soid list.  */
+
+void
+a68_add_to_soid_list (SOID_T **root, NODE_T *where, SOID_T *soid)
+{
+  if (*root != NO_SOID)
+    a68_add_to_soid_list (&(NEXT (*root)), where, soid);
+  else
+    {
+      SOID_T *new_one;
+
+      if (A68 (top_soid_list) == NO_SOID)
+	new_one = (SOID_T *) xmalloc (sizeof (SOID_T));
+      else
+	{
+	  new_one = A68 (top_soid_list);
+	  FORWARD (A68 (top_soid_list));
+	}
+
+      a68_make_soid (new_one, SORT (soid), MOID (soid), 0);
+      NODE (new_one) = where;
+      NEXT (new_one) = NO_SOID;
+      *root = new_one;
+    }
+}
+
+/* Pack soids in moid, gather resulting moids from terminators in a clause.  */
+
+MOID_T *
+a68_pack_soids_in_moid (SOID_T *top_sl, int attribute)
+{
+  MOID_T *x = a68_new_moid ();
+  PACK_T *t, **p;
+
+  ATTRIBUTE (x) = attribute;
+  DIM (x) = 0;
+  SUB (x) = NO_MOID;
+  EQUIVALENT (x) = NO_MOID;
+  SLICE (x) = NO_MOID;
+  DEFLEXED (x) = NO_MOID;
+  NAME (x) = NO_MOID;
+  NEXT (x) = NO_MOID;
+  PACK (x) = NO_PACK;
+  p = &(PACK (x));
+  for (; top_sl != NO_SOID; FORWARD (top_sl))
+    {
+      t = a68_new_pack ();
+      MOID (t) = MOID (top_sl);
+      TEXT (t) = NO_TEXT;
+      NODE (t) = NODE (top_sl);
+      NEXT (t) = NO_PACK;
+      DIM (x)++;
+      *p = t;
+      p = &NEXT (t);
+    }
+  (void) a68_register_extra_mode (&TOP_MOID (&A68_JOB), x);
+  return x;
+}
+
+/* Whether P is compatible with Q.  */
+
+bool
+a68_is_equal_modes (MOID_T *p, MOID_T *q, int deflex)
+{
+  if (deflex == FORCE_DEFLEXING)
+    return DEFLEX (p) == DEFLEX (q);
+  else if (deflex == ALIAS_DEFLEXING)
+    {
+      if (IS (p, REF_SYMBOL) && IS (q, REF_SYMBOL))
+	return p == q || DEFLEX (p) == q;
+      else if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL))
+	return DEFLEX (p) == DEFLEX (q);
+  }
+  else if (deflex == SAFE_DEFLEXING)
+    {
+      if (!IS (p, REF_SYMBOL) && !IS (q, REF_SYMBOL))
+	return DEFLEX (p) == DEFLEX (q);
+    }
+  return p == q;
+}
+
+/* Whether mode is deprefable, i.e. whether it can be either deferred or
+   deprocedured.  */
+
+bool
+a68_is_deprefable (MOID_T *p)
+{
+  if (IS_REF (p))
+    return true;
+  else
+    return (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK);
+}
+
+/* Deref or deproc the mode P once.  */
+
+MOID_T *
+a68_depref_once (MOID_T *p)
+{
+  if (IS_REF_FLEX (p))
+    return SUB_SUB (p);
+  else if (IS_REF (p))
+    return SUB (p);
+  else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+    return SUB (p);
+  else
+    return NO_MOID;
+}
+
+/* Depref mode completely.  */
+
+MOID_T *
+a68_depref_completely (MOID_T *p)
+{
+  while (a68_is_deprefable (p))
+    p = a68_depref_once (p);
+  return p;
+}
+
+/* Deproc_completely.  */
+
+MOID_T *
+a68_deproc_completely (MOID_T *p)
+{
+  while (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+    p = a68_depref_once (p);
+  return p;
+}
+
+/* Depref rows.  */
+
+MOID_T *
+a68_depref_rows (MOID_T *p, MOID_T *q)
+{
+  if (q == M_ROWS)
+    {
+      while (a68_is_deprefable (p))
+	p = a68_depref_once (p);
+      return p;
+    }
+  else
+    return q;
+}
+
+/* Derow mode, strip FLEX and BOUNDS.  */
+
+MOID_T *
+a68_derow (MOID_T *p)
+{
+  if (IS_ROW (p) || IS_FLEX (p))
+    return a68_derow (SUB (p));
+  else
+    return p;
+}
+
+/* Whether rows type.  */
+
+bool
+a68_is_rows_type (MOID_T *p)
+{
+  switch (ATTRIBUTE (p))
+    {
+    case ROW_SYMBOL:
+    case FLEX_SYMBOL:
+      return true;
+    case UNION_SYMBOL:
+      {
+	PACK_T *t = PACK (p);
+	bool siga = true;
+	while (t != NO_PACK && siga)
+	  {
+	    siga &= a68_is_rows_type (MOID (t));
+	    FORWARD (t);
+	  }
+	return siga;
+      }
+    default:
+      return false;
+    }
+}
+
+/* Whether mode is PROC (REF FILE) VOID or FORMAT.  */
+
+bool
+a68_is_proc_ref_file_void_or_format (MOID_T *p)
+{
+  if (p == M_PROC_REF_FILE_VOID)
+    return true;
+  else if (p == M_FORMAT)
+    return true;
+  else
+    return false;
+}
+
+/* Whether mode can be transput.  */
+
+bool
+a68_is_transput_mode (MOID_T *p, char rw)
+{
+  if (p == M_INT)
+    return true;
+  else if (p == M_SHORT_INT)
+    return true;
+  else if (p == M_SHORT_SHORT_INT)
+    return true;
+  else if (p == M_LONG_INT)
+    return true;
+  else if (p == M_LONG_LONG_INT)
+    return true;
+  else if (p == M_REAL)
+    return true;
+  else if (p == M_LONG_REAL)
+    return true;
+  else if (p == M_LONG_LONG_REAL)
+    return true;
+  else if (p == M_BOOL)
+    return true;
+  else if (p == M_CHAR)
+    return true;
+  else if (p == M_BITS)
+    return true;
+  else if (p == M_SHORT_BITS)
+    return true;
+  else if (p == M_SHORT_SHORT_BITS)
+    return true;
+  else if (p == M_LONG_BITS)
+    return true;
+  else if (p == M_LONG_LONG_BITS)
+    return true;
+  else if (p == M_COMPLEX)
+    return true;
+  else if (p == M_LONG_COMPLEX)
+    return true;
+  else if (p == M_LONG_LONG_COMPLEX)
+    return true;
+  else if (p == M_ROW_CHAR)
+    return true;
+  else if (p == M_STRING)
+    return true;
+  else if (IS (p, UNION_SYMBOL) || IS (p, STRUCT_SYMBOL))
+    {
+      for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q))
+	{
+	  if (!(a68_is_transput_mode (MOID (q), rw)
+		|| a68_is_proc_ref_file_void_or_format (MOID (q))))
+	    return false;
+	}
+      return true;
+    }
+  else if (IS_FLEX (p))
+    {
+      if (SUB (p) == M_ROW_CHAR)
+	return true;
+      else
+	return (rw == 'w' ? a68_is_transput_mode (SUB (p), rw) : false);
+    }
+  else if (IS_ROW (p))
+    return (a68_is_transput_mode (SUB (p), rw)
+	    || a68_is_proc_ref_file_void_or_format (SUB (p)));
+  else
+    return false;
+}
+
+/* Whether mode is printable.  */
+
+bool
+a68_is_printable_mode (MOID_T *p)
+{
+  if (a68_is_proc_ref_file_void_or_format (p))
+    return true;
+  else
+    return a68_is_transput_mode (p, 'w');
+}
+
+/* Whether mode is readable.  */
+
+bool
+a68_is_readable_mode (MOID_T *p)
+{
+  if (a68_is_proc_ref_file_void_or_format (p))
+    return true;
+  else if (IS_REF (p))
+    return a68_is_transput_mode (SUB (p), 'r');
+  else if (IS_UNION (p))
+    {
+      for (PACK_T *q = PACK (p); q != NO_PACK; FORWARD (q))
+	{
+	  if (!IS_REF (MOID (q)))
+	    return false;
+	  else if (!a68_is_transput_mode (SUB (MOID (q)), 'r'))
+	    return false;
+	}
+      return true;
+    }
+  else
+    return false;
+}
+
+/* Whether name struct.  */
+
+bool
+a68_is_name_struct (MOID_T *p)
+{
+  return (NAME (p) != NO_MOID ? IS (DEFLEX (SUB (p)), STRUCT_SYMBOL) : false);
+}
+
+/* Yield mode to unite to.  */
+
+MOID_T *
+a68_unites_to (MOID_T *m, MOID_T *u)
+{
+  /* Uniting U (m).  */
+  MOID_T *v = NO_MOID;
+
+  if (u == M_SIMPLIN || u == M_SIMPLOUT)
+    return m;
+
+  for (PACK_T *p = PACK (u); p != NO_PACK; FORWARD (p))
+    {
+      /* Prefer []->[] over []->FLEX [].  */
+      if (m == MOID (p))
+	v = MOID (p);
+      else if (v == NO_MOID && DEFLEX (m) == DEFLEX (MOID (p)))
+	v = MOID (p);
+    }
+  return v;
+}
+
+/* Whether moid in pack.  */
+
+bool
+a68_is_moid_in_pack (MOID_T *u, PACK_T *v, int deflex)
+{
+  for (; v != NO_PACK; FORWARD (v))
+    {
+      if (a68_is_equal_modes (u, MOID (v), deflex))
+	return true;
+    }
+
+  return false;
+}
+
+/* Whether P is a subset of Q.  */
+
+bool
+a68_is_subset (MOID_T *p, MOID_T *q, int deflex)
+{
+  bool j =true;
+
+  for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u))
+    j = (j && a68_is_moid_in_pack (MOID (u), PACK (q), deflex));
+
+  return j;
+}
+
+/* Whether P can be united to UNION Q.  */
+
+bool
+a68_is_unitable (MOID_T *p, MOID_T *q, int deflex)
+{
+  if (IS (q, UNION_SYMBOL))
+    {
+      if (IS (p, UNION_SYMBOL))
+	return a68_is_subset (p, q, deflex);
+    else
+      return a68_is_moid_in_pack (p, PACK (q), deflex);
+  }
+
+  return false;
+}
+
+/* Whether all or some components of U can be firmly coerced to a component
+   mode of V..  */
+
+void
+a68_investigate_firm_relations (PACK_T *u, PACK_T *v, bool *all, bool *some)
+{
+  *all = true;
+  *some = true;
+  for (; v != NO_PACK; FORWARD (v))
+    {
+      bool k = false;
+
+      for (PACK_T *w = u; w != NO_PACK; FORWARD (w))
+	k |= a68_is_coercible (MOID (w), MOID (v), FIRM, FORCE_DEFLEXING);
+      *some |= k;
+      *all &= k;
+    }
+}
+
+/* Whether there is a soft path from P to Q.  */
+
+bool
+a68_is_softly_coercible (MOID_T *p, MOID_T *q, int deflex)
+{
+  if (a68_is_equal_modes (p, q, deflex))
+    return true;
+  else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+    return a68_is_softly_coercible (SUB (p), q, deflex);
+  else
+    return false;
+}
+
+/* Whether there is a weak path from P to Q.  */
+
+bool
+a68_is_weakly_coercible (MOID_T * p, MOID_T * q, int deflex)
+{
+  if (a68_is_equal_modes (p, q, deflex))
+    return true;
+  else if (a68_is_deprefable (p))
+    return a68_is_weakly_coercible (a68_depref_once (p), q, deflex);
+  else
+    return false;
+}
+
+/* Whether there is a meek path from P to Q.  */
+
+bool
+a68_is_meekly_coercible (MOID_T *p, MOID_T *q, int deflex)
+{
+  if (a68_is_equal_modes (p, q, deflex))
+    return true;
+  else if (a68_is_deprefable (p))
+    return a68_is_meekly_coercible (a68_depref_once (p), q, deflex);
+  else
+    return false;
+}
+
+/* Whether there is a firm path from P to Q.  */
+
+bool
+a68_is_firmly_coercible (MOID_T *p, MOID_T *q, int deflex)
+{
+  if (a68_is_equal_modes (p, q, deflex))
+    return true;
+  else if (q == M_ROWS && a68_is_rows_type (p))
+    return true;
+  else if (a68_is_unitable (p, q, deflex))
+    return true;
+  else if (a68_is_deprefable (p))
+    return a68_is_firmly_coercible (a68_depref_once (p), q, deflex);
+  else
+    return false;
+}
+
+/* Whether firm.  */
+
+bool
+a68_is_firm (MOID_T *p, MOID_T *q)
+{
+  return (a68_is_firmly_coercible (p, q, SAFE_DEFLEXING)
+	  || a68_is_firmly_coercible (q, p, SAFE_DEFLEXING));
+}
+
+/* Whether P widens to Q.
+
+   This function returns:
+
+   The destination mode Q if P, or
+   Some other mode which is an intermediate step from P to Q, or
+   NO_MOID if P cannot be widened to Q.
+
+   This means that if P is known to widen to Q (a68_is_widenable (P,Q) return
+   true) this function can be invoked repeteadly and it will eventually return
+   Q.  */
+
+MOID_T *
+a68_widens_to (MOID_T *p, MOID_T *q)
+{
+  if (p == M_INT)
+    {
+      if (q == M_REAL || q == M_COMPLEX)
+	{
+	  return M_REAL;
+	}
+      else
+	{
+	  return NO_MOID;
+	}
+    }
+  else if (p == M_LONG_INT)
+    {
+      if (q == M_LONG_REAL)
+	{
+	  return M_LONG_REAL;
+	}
+      else
+	{
+	  return NO_MOID;
+	}
+    }
+  else if (p == M_LONG_LONG_INT)
+    {
+      if (q == M_LONG_LONG_REAL || q == M_LONG_LONG_COMPLEX)
+	  return M_LONG_LONG_REAL;
+      else
+	return NO_MOID;
+    }
+  else if (p == M_REAL)
+    {
+      if (q == M_COMPLEX)
+	{
+	  return M_COMPLEX;
+	}
+      else
+	{
+	  return NO_MOID;
+	}
+    }
+  else if (p == M_LONG_REAL)
+    {
+      if (q == M_LONG_COMPLEX)
+	return M_LONG_COMPLEX;
+      else
+	return NO_MOID;
+    }
+  else if (p == M_LONG_LONG_REAL)
+    {
+      if (q == M_LONG_LONG_COMPLEX)
+	return M_LONG_LONG_COMPLEX;
+      else
+	return NO_MOID;
+    }
+  else if (p == M_BITS)
+    {
+      if (q == M_ROW_BOOL)
+	return M_ROW_BOOL;
+      else if (q == M_FLEX_ROW_BOOL)
+	return M_FLEX_ROW_BOOL;
+      else
+	return NO_MOID;
+    }
+  else if (p == M_SHORT_BITS)
+    {
+      if (q == M_ROW_BOOL)
+	return M_ROW_BOOL;
+      else if (q == M_FLEX_ROW_BOOL)
+	return M_FLEX_ROW_BOOL;
+      else
+	return NO_MOID;
+    }
+  else if (p == M_SHORT_SHORT_BITS)
+    {
+      if (q == M_ROW_BOOL)
+	return M_ROW_BOOL;
+      else if (q == M_FLEX_ROW_BOOL)
+	return M_FLEX_ROW_BOOL;
+      else
+	return NO_MOID;
+    }
+  else if (p == M_LONG_BITS)
+    {
+      if (q == M_ROW_BOOL)
+	return M_ROW_BOOL;
+      else if (q == M_FLEX_ROW_BOOL)
+	return M_FLEX_ROW_BOOL;
+      else
+	return NO_MOID;
+    }
+  else if (p == M_LONG_LONG_BITS)
+    {
+      if (q == M_ROW_BOOL)
+	return M_ROW_BOOL;
+      else if (q == M_FLEX_ROW_BOOL)
+	return M_FLEX_ROW_BOOL;
+      else
+	return NO_MOID;
+    }
+  else if (p == M_BYTES && q == M_ROW_CHAR)
+    return M_ROW_CHAR;
+  else if (p == M_LONG_BYTES && q == M_ROW_CHAR)
+    return M_ROW_CHAR;
+  else if (p == M_BYTES && q == M_FLEX_ROW_CHAR)
+    return M_FLEX_ROW_CHAR;
+  else if (p == M_LONG_BYTES && q == M_FLEX_ROW_CHAR)
+    return M_FLEX_ROW_CHAR;
+  else
+    return NO_MOID;
+}
+
+/* Whether P widens to Q.  */
+
+bool
+a68_is_widenable (MOID_T *p, MOID_T *q)
+{
+  MOID_T *z = a68_widens_to (p, q);
+
+  if (z != NO_MOID)
+    return (z == q ? true : a68_is_widenable (z, q));
+  else
+    return false;
+}
+
+/* Whether P is a REF ROW.  */
+
+bool
+a68_is_ref_row (MOID_T *p)
+{
+  return (NAME (p) != NO_MOID ? IS_ROW (DEFLEX (SUB (p))) : false);
+}
+
+/* Whether strong name.  */
+
+bool
+a68_is_strong_name (MOID_T *p, MOID_T *q)
+{
+  if (p == q)
+    return true;
+  else if (a68_is_ref_row (q))
+    return a68_is_strong_name (p, NAME (q));
+  else
+    return false;
+}
+
+/* Whether strong slice. */
+
+bool
+a68_is_strong_slice (MOID_T *p, MOID_T *q)
+{
+  if (p == q || a68_is_widenable (p, q))
+    return true;
+  else if (SLICE (q) != NO_MOID)
+    return a68_is_strong_slice (p, SLICE (q));
+  else if (IS_FLEX (q))
+    return a68_is_strong_slice (p, SUB (q));
+  else if (a68_is_ref_row (q))
+    return a68_is_strong_name (p, q);
+  else
+    return false;
+}
+
+/* Whether strongly coercible.  */
+
+bool
+a68_is_strongly_coercible (MOID_T *p, MOID_T *q, int deflex)
+{
+  /* Keep this sequence of statements.  */
+  if (a68_is_equal_modes (p, q, deflex))
+    return true;
+  else if (q == M_VOID)
+    return true;
+  else if ((q == M_SIMPLIN || q == M_ROW_SIMPLIN) && a68_is_readable_mode (p))
+    return true;
+  else if (q == M_ROWS && a68_is_rows_type (p))
+    return true;
+  else if (a68_is_unitable (p, a68_derow (q), deflex))
+    return true;
+
+  if (a68_is_ref_row (q) && a68_is_strong_name (p, q))
+    return true;
+  else if (SLICE (q) != NO_MOID && a68_is_strong_slice (p, q))
+    return true;
+  else if (IS_FLEX (q) && a68_is_strong_slice (p, q))
+    return true;
+  else if (a68_is_widenable (p, q))
+    return true;
+  else if (a68_is_deprefable (p))
+    return a68_is_strongly_coercible (a68_depref_once (p), q, deflex);
+  else if (q == M_SIMPLOUT || q == M_ROW_SIMPLOUT)
+    return a68_is_printable_mode (p);
+  else
+    return false;
+}
+
+/* Basic coercions.  */
+
+bool
+a68_basic_coercions (MOID_T *p, MOID_T *q, int c, int deflex)
+{
+  if (a68_is_equal_modes (p, q, deflex))
+    return true;
+  else if (c == NO_SORT)
+    return (p == q);
+  else if (c == SOFT)
+    return a68_is_softly_coercible (p, q, deflex);
+  else if (c == WEAK)
+    return a68_is_weakly_coercible (p, q, deflex);
+  else if (c == MEEK)
+    return a68_is_meekly_coercible (p, q, deflex);
+  else if (c == FIRM)
+    return a68_is_firmly_coercible (p, q, deflex);
+  else if (c == STRONG)
+    return a68_is_strongly_coercible (p, q, deflex);
+  else
+    return false;
+}
+
+/* Whether coercible stowed.  */
+
+bool
+a68_is_coercible_stowed (MOID_T *p, MOID_T *q, int c, int deflex)
+{
+  if (c != STRONG)
+    /* Such construct is always in a strong position, is it not?  */
+    return false;
+  else if (q == M_VOID)
+    return true;
+  else if (IS_FLEX (q))
+    {
+      bool j = true;
+
+      for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u))
+	j &= a68_is_coercible (MOID (u), SLICE (SUB (q)), c, deflex);
+      return j;
+    }
+  else if (IS_ROW (q))
+    {
+      bool j = true;
+
+      for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u))
+	j &= a68_is_coercible (MOID (u), SLICE (q), c, deflex);
+      return j;
+    }
+  else if (IS (q, PROC_SYMBOL) || IS (q, STRUCT_SYMBOL))
+    {
+      if (DIM (p) != DIM (q))
+	return false;
+      else
+	{
+	  PACK_T *u = PACK (p), *v = PACK (q);
+	  bool j = true;
+
+	  while (u != NO_PACK && v != NO_PACK && j)
+	    {
+	      j &= a68_is_coercible (MOID (u), MOID (v), c, deflex);
+	      FORWARD (u);
+	      FORWARD (v);
+	    }
+	  return j;
+	}
+    }
+  else
+    return false;
+}
+
+/* Whether coercible series.  */
+
+bool
+a68_is_coercible_series (MOID_T *p, MOID_T *q, int c, int deflex)
+{
+  if (c == NO_SORT)
+    return false;
+  else if (p == NO_MOID || q == NO_MOID)
+    return false;
+  else if (IS (p, SERIES_MODE) && PACK (p) == NO_PACK)
+    return false;
+  else if (IS (q, SERIES_MODE) && PACK (q) == NO_PACK)
+    return false;
+  else if (PACK (p) == NO_PACK)
+    return a68_is_coercible (p, q, c, deflex);
+  else
+    {
+      bool j = true;
+
+      for (PACK_T *u = PACK (p); u != NO_PACK && j; FORWARD (u))
+	{
+	  if (MOID (u) != NO_MOID)
+	    j &= a68_is_coercible (MOID (u), q, c, deflex);
+	}
+    return j;
+    }
+}
+
+/* Whether P can be coerced to Q in a C context.  */
+
+bool
+a68_is_coercible (MOID_T *p, MOID_T *q, int c, int deflex)
+{
+  if (a68_is_mode_isnt_well (p) || a68_is_mode_isnt_well (q))
+    return true;
+  else if (a68_is_equal_modes (p, q, deflex))
+    return true;
+  else if (p == M_HIP)
+    return true;
+  else if (IS (p, STOWED_MODE))
+    return a68_is_coercible_stowed (p, q, c, deflex);
+  else if (IS (p, SERIES_MODE))
+    return a68_is_coercible_series (p, q, c, deflex);
+  else if (p == M_VACUUM && IS_ROW (DEFLEX (q)))
+    return true;
+  else
+    return a68_basic_coercions (p, q, c, deflex);
+}
+
+/* Whether coercible in context.  */
+
+bool
+a68_is_coercible_in_context (SOID_T *p, SOID_T *q, int deflex)
+{
+  if (SORT (p) != SORT (q))
+    return false;
+  else if (MOID (p) == MOID (q))
+    return true;
+  else
+    return a68_is_coercible (MOID (p), MOID (q), SORT (q), deflex);
+}
+
+/* Whether list Y is balanced.  */
+
+bool
+a68_is_balanced (NODE_T *n, SOID_T *y, int sort)
+{
+  if (sort == STRONG)
+    return true;
+  else
+    {
+      bool k = false;
+
+      for (; y != NO_SOID && !k; FORWARD (y)) 
+	k = (!IS (MOID (y), STOWED_MODE));
+
+      if (k == false)
+	a68_error (n, "construct has no unique mode");
+      return k;
+    }
+}
+
+/* A moid from M to which all other members can be coerced.
+   If no fulcrum of the balance is found, return NO_MOID.  */
+
+MOID_T *
+a68_get_balanced_mode_or_no_mode (MOID_T *m, int sort, bool return_depreffed, int deflex)
+{
+  MOID_T *common_moid = NO_MOID;
+
+  if (m != NO_MOID && !a68_is_mode_isnt_well (m) && IS (m, UNION_SYMBOL))
+    {
+      int depref_level;
+      bool siga = true;
+      /* Test for increasing depreffing.  */
+      for (depref_level = 0; siga; depref_level++)
+	{
+	  siga = false;
+	  /* Test the whole pack.  */
+	  for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p))
+	    {
+	      /* HIPs are not eligible of course.  */
+	      if (MOID (p) != M_HIP)
+		{
+		  MOID_T *candidate = MOID (p);
+		  int k;
+		  /* Depref as far as allowed.  */
+		  for (k = depref_level; k > 0 && a68_is_deprefable (candidate); k--)
+		    candidate = a68_depref_once (candidate);
+		  /* Only need testing if all allowed deprefs succeeded.  */
+		  if (k == 0)
+		    {
+		      MOID_T *to = (return_depreffed ? a68_depref_completely (candidate) : candidate);
+		      bool all_coercible = true;
+
+		      siga = true;
+		      for (PACK_T *q = PACK (m); q != NO_PACK && all_coercible; FORWARD (q))
+			{
+			  MOID_T *from = MOID (q);
+			  if (p != q && from != to)
+			    all_coercible &= a68_is_coercible (from, to, sort, deflex);
+			}
+		      /* If the pack is coercible to the candidate, we mark the
+			 candidate.  We continue searching for longest series
+			 of REF REF PROC REF.  */
+		      if (all_coercible)
+			{
+			  MOID_T *mark = (return_depreffed ? MOID (p) : candidate);
+
+			  if (common_moid == NO_MOID)
+			    common_moid = mark;
+			  else if (IS_FLEX (candidate) && DEFLEX (candidate) == common_moid)
+			    /* We prefer FLEX.  */
+			    common_moid = mark;
+			}
+		    }
+		}
+	    }
+	}
+    }
+
+  return common_moid;
+}
+
+/* A moid from M to which all other members can be coerced.
+   If no fulcrum of the balance is found, return M.  */
+
+MOID_T *
+a68_get_balanced_mode (MOID_T *m, int sort, bool return_depreffed, int deflex)
+{
+  MOID_T *common_moid
+    = a68_get_balanced_mode_or_no_mode (m, sort, return_depreffed, deflex);
+  return common_moid == NO_MOID ? m : common_moid;
+}
+
+/* Whether we can search a common mode from a clause or not.  */
+
+bool
+a68_clause_allows_balancing (int att)
+{
+  switch (att)
+    {
+    case CLOSED_CLAUSE:
+    case CONDITIONAL_CLAUSE:
+    case CASE_CLAUSE:
+    case SERIAL_CLAUSE:
+    case CONFORMITY_CLAUSE:
+      return true;
+    }
+  return false;
+}
+
+/* A unique mode from Z.  */
+
+MOID_T *
+a68_determine_unique_mode (SOID_T *z, int deflex)
+{
+  if (z == NO_SOID)
+    return NO_MOID;
+  else
+    {
+      MOID_T *x = MOID (z);
+
+      if (a68_is_mode_isnt_well (x))
+	return M_ERROR;
+
+      /* If X is a series containing one union, a68_make_united_mode will
+	 return that union (because 'union (union (...))' is the same than
+	 'union (...)') and then a68_get_balanced_mode below will try to
+	 balance the modes in that union.  Not what we want.  */
+      if (ATTRIBUTE (x) == SERIES_MODE
+	  && DIM (x) == 1
+	  && IS (MOID (PACK (x)), UNION_SYMBOL))
+	return MOID (PACK (x));
+
+      x = a68_make_united_mode (x);
+      if (a68_clause_allows_balancing (ATTRIBUTE (z)))
+	return a68_get_balanced_mode (x, STRONG, A68_NO_DEPREF, deflex);
+      else
+	return x;
+    }
+}
+
+/* Insert coercion A in the tree.  */
+
+void
+a68_make_coercion (NODE_T *l, enum a68_attribute a, MOID_T *m)
+{
+  a68_make_sub (l, l, a);
+  MOID (l) = a68_depref_rows (MOID (l), m);
+}
+
+/* Make widening coercion.  */
+
+static void
+make_widening_coercion (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+  MOID_T *z = a68_widens_to (p, q);
+
+  a68_make_coercion (n, WIDENING, z);
+  if (z != q)
+    make_widening_coercion (n, z, q);
+}
+
+/* Make ref rowing coercion.  */
+
+void
+a68_make_ref_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+  if (DEFLEX (p) != DEFLEX (q))
+    {
+      if (a68_is_widenable (p, q))
+	make_widening_coercion (n, p, q);
+      else if (a68_is_ref_row (q))
+	{
+	  a68_make_ref_rowing_coercion (n, p, NAME (q));
+	  a68_make_coercion (n, ROWING, q);
+	}
+    }
+}
+
+/* Make rowing coercion.  */
+
+void
+a68_make_rowing_coercion (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+  if (DEFLEX (p) != DEFLEX (q))
+    {
+      if (a68_is_widenable (p, q))
+	make_widening_coercion (n, p, q);
+      else if (SLICE (q) != NO_MOID)
+	{
+	  a68_make_rowing_coercion (n, p, SLICE (q));
+	  a68_make_coercion (n, ROWING, q);
+	}
+      else if (IS_FLEX (q))
+	a68_make_rowing_coercion (n, p, SUB (q));
+      else if (a68_is_ref_row (q))
+	a68_make_ref_rowing_coercion (n, p, q);
+    }
+}
+
+/* Make uniting coercion.  */
+
+void
+a68_make_uniting_coercion (NODE_T *n, MOID_T *q)
+{
+  a68_make_coercion (n, UNITING, a68_derow (q));
+  if (IS_ROW (q) || IS_FLEX (q))
+    a68_make_rowing_coercion (n, a68_derow (q), q);
+}
+
+/* Make depreffing coercion to coerce node N from mode P to mode Q in a strong
+   context.  */
+
+void
+a68_make_depreffing_coercion (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+  if (DEFLEX (p) == DEFLEX (q))
+    return;
+  else if (q == M_SIMPLOUT && a68_is_printable_mode (p))
+    a68_make_coercion (n, UNITING, q);
+  else if (q == M_ROW_SIMPLOUT && a68_is_printable_mode (p))
+    {
+      a68_make_coercion (n, UNITING, M_SIMPLOUT);
+      a68_make_coercion (n, ROWING, M_ROW_SIMPLOUT);
+    }
+  else if (q == M_SIMPLIN && a68_is_readable_mode (p))
+    a68_make_coercion (n, UNITING, q);
+  else if (q == M_ROW_SIMPLIN && a68_is_readable_mode (p))
+    {
+      a68_make_coercion (n, UNITING, M_SIMPLIN);
+      a68_make_coercion (n, ROWING, M_ROW_SIMPLIN);
+    }
+  else if (q == M_ROWS && a68_is_rows_type (p))
+    {
+      a68_make_coercion (n, UNITING, M_ROWS);
+      MOID (n) = M_ROWS;
+    }
+  else if (a68_is_widenable (p, q))
+    make_widening_coercion (n, p, q);
+  else if (a68_is_unitable (p, a68_derow (q), SAFE_DEFLEXING))
+    a68_make_uniting_coercion (n, q);
+  else if (a68_is_ref_row (q) && a68_is_strong_name (p, q))
+    a68_make_ref_rowing_coercion (n, p, q);
+  else if (SLICE (q) != NO_MOID && a68_is_strong_slice (p, q))
+    a68_make_rowing_coercion (n, p, q);
+  else if (IS_FLEX (q) && a68_is_strong_slice (p, q))
+    a68_make_rowing_coercion (n, p, q);
+  else if (IS_REF (p))
+    {
+      MOID_T *r = a68_depref_once (p);
+      a68_make_coercion (n, DEREFERENCING, r);
+      a68_make_depreffing_coercion (n, r, q);
+    }
+  else if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+    {
+      MOID_T *r = SUB (p);
+
+      a68_make_coercion (n, DEPROCEDURING, r);
+      a68_make_depreffing_coercion (n, r, q);
+    }
+  else if (p != q)
+    a68_cannot_coerce (n, p, q, NO_SORT, SKIP_DEFLEXING, 0);
+}
+
+/* Whether p is a nonproc mode (that is voided directly).  */
+
+bool
+a68_is_nonproc (MOID_T *p)
+{
+  if (IS (p, PROC_SYMBOL) && PACK (p) == NO_PACK)
+    return false;
+  else if (IS_REF (p))
+    return a68_is_nonproc (SUB (p));
+  else
+    return true;
+}
+
+/* Voiden in an appropriate way.  */
+
+void
+a68_make_void (NODE_T *p, MOID_T *q)
+{
+  switch (ATTRIBUTE (p))
+    {
+    case ASSIGNATION:
+    case IDENTITY_RELATION:
+    case GENERATOR:
+    case CAST:
+    case DENOTATION:
+      a68_make_coercion (p, VOIDING, M_VOID);
+      return;
+    default:
+      break;
+    }
+
+  /* MORFs are an involved case.  */
+  switch (ATTRIBUTE (p))
+    {
+    case SELECTION:
+    case SLICE:
+    case ROUTINE_TEXT:
+    case FORMULA:
+    case CALL:
+    case IDENTIFIER:
+      /* A nonproc moid value is eliminated directly.  */
+      if (a68_is_nonproc (q))
+	{
+	  a68_make_coercion (p, VOIDING, M_VOID);
+	  return;
+	}
+      else
+	{
+	  /* Descend the chain of e.g. REF PROC .. until a nonproc moid
+	     remains.  */
+	  MOID_T *z = q;
+
+	  while (!a68_is_nonproc (z))
+	    {
+	      if (IS_REF (z))
+		a68_make_coercion (p, DEREFERENCING, SUB (z));
+	      if (IS (z, PROC_SYMBOL) && NODE_PACK (p) == NO_PACK)
+		a68_make_coercion (p, DEPROCEDURING, SUB (z));
+	      z = SUB (z);
+	    }
+	  if (z != M_VOID)
+	    a68_make_coercion (p, VOIDING, M_VOID);
+	  return;
+	}
+    default:
+      break;
+    }
+
+  /* All other is voided straight away.  */
+  a68_make_coercion (p, VOIDING, M_VOID);
+}
+
+/* Make strong coercion of node N from mode P to mode Q.  */
+
+void
+a68_make_strong (NODE_T *n, MOID_T *p, MOID_T *q)
+{
+  if (q == M_VOID && p != M_VOID)
+    a68_make_void (n, p);
+  else
+    a68_make_depreffing_coercion (n, p, q);
+}
diff --git a/gcc/algol68/a68-moids-to-string.cc b/gcc/algol68/a68-moids-to-string.cc
new file mode 100644
index 00000000000..36ca88c98aa
--- /dev/null
+++ b/gcc/algol68/a68-moids-to-string.cc
@@ -0,0 +1,366 @@
+/* Pretty-print a MOID.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/*
+ * A pretty printer for moids.
+ *
+ * For example "PROC (REF STRUCT (REF SELF, UNION (INT, VOID))) REF SELF"
+ * for a procedure yielding a pointer to an object of its own mode.
+ */
+
+static void moid_to_string_2 (char *, MOID_T *, size_t *, NODE_T *,
+			      bool indicant_value);
+
+/* Add string to MOID text.  */
+
+static void
+add_to_moid_text (char *dst, const char *str, size_t *w)
+{
+  a68_bufcat (dst, str, BUFFER_SIZE);
+  (*w) -= strlen (str);
+}
+
+/* Find a tag, searching symbol tables towards the root.  */
+
+static TAG_T *
+find_indicant_global (TABLE_T * table, MOID_T * mode)
+{
+  if (table != NO_TABLE)
+    {
+      for (TAG_T *s = INDICANTS (table); s != NO_TAG; FORWARD (s))
+	{
+	  if (MOID (s) == mode)
+	    return s;
+	}
+      return find_indicant_global (PREVIOUS (table), mode);
+    }
+  else
+    return NO_TAG;
+}
+
+/* Pack to string.  */
+
+static void
+pack_to_string (char *b, PACK_T *p, size_t *w, bool text, NODE_T *idf,
+		bool indicant_value)
+{
+  for (; p != NO_PACK; FORWARD (p))
+    {
+      moid_to_string_2 (b, MOID (p), w, idf, indicant_value);
+      if (text)
+	{
+	  if (TEXT (p) != NO_TEXT)
+	    {
+	      add_to_moid_text (b, " ", w);
+	      add_to_moid_text (b, TEXT (p), w);
+	    }
+	}
+      if (p != NO_PACK && NEXT (p) != NO_PACK)
+	add_to_moid_text (b, ", ", w);
+    }
+}
+
+/* Moid to string 2.  */
+
+static void moid_to_string_2 (char *b, MOID_T *n, size_t *w, NODE_T *idf,
+			      bool indicant_value)
+{
+  if (n == NO_MOID)
+    {
+      /* Oops. Should not happen.  */
+      add_to_moid_text (b, "null", w);;
+      return;
+    }
+
+  /* Reference to self through REF or PROC.  */
+  if (a68_is_postulated (A68 (postulates), n))
+    {
+      add_to_moid_text (b, "SELF", w);
+      return;
+    }
+
+  /* If declared by a mode-declaration, present the indicant.  */
+  if (idf != NO_NODE && !IS (n, STANDARD))
+    {
+      TAG_T *indy = find_indicant_global (TABLE (idf), n);
+
+      if (indy != NO_TAG)
+	{
+	  add_to_moid_text (b, NSYMBOL (NODE (indy)), w);
+	  if (!indicant_value)
+	    return;
+	  else
+	    add_to_moid_text (b, " = ", w);
+	}
+    }
+
+  /* Write the standard modes.  */
+  if (n == M_HIP)
+    add_to_moid_text (b, "HIP", w);
+  else if (n == M_ERROR)
+    add_to_moid_text (b, "ERROR", w);
+  else if (n == M_UNDEFINED)
+    add_to_moid_text (b, "unresolved mode", w);
+  else if (n == M_C_STRING)
+    add_to_moid_text (b, "C-STRING", w);
+  else if (n == M_COMPLEX)
+    add_to_moid_text (b, "COMPL", w);
+  else if (n == M_LONG_COMPLEX)
+    add_to_moid_text (b, "LONG COMPL", w);
+  else if (n == M_LONG_LONG_COMPLEX)
+    add_to_moid_text (b, "LONG LONG COMPL", w);
+  else if (n == M_STRING)
+    add_to_moid_text (b, "STRING", w);
+  else if (n == M_COLLITEM)
+    add_to_moid_text (b, "COLLITEM", w);
+  else if (IS (n, IN_TYPE_MODE))
+    add_to_moid_text (b, "\"SIMPLIN\"", w);
+  else if (IS (n, OUT_TYPE_MODE))
+    add_to_moid_text (b, "\"SIMPLOUT\"", w);
+  else if (IS (n, ROWS_SYMBOL))
+    add_to_moid_text (b, "\"ROWS\"", w);
+  else if (n == M_VACUUM)
+    add_to_moid_text (b, "\"VACUUM\"", w);
+  else if (IS (n, VOID_SYMBOL) || IS (n, STANDARD) || IS (n, INDICANT))
+    {
+      if (DIM (n) > 0)
+	{
+	  size_t k = DIM (n);
+
+	  if ((*w) >= k * strlen ("LONG ") + strlen (NSYMBOL (NODE (n))))
+	    {
+	      while (k--)
+		add_to_moid_text (b, "LONG ", w);
+	      add_to_moid_text (b, NSYMBOL (NODE (n)), w);
+	    }
+	  else
+	    add_to_moid_text (b, "..", w);
+	}
+      else if (DIM (n) < 0)
+	{
+	  size_t k = -DIM (n);
+
+	  if ((*w) >= k * strlen ("SHORT ") + strlen (NSYMBOL (NODE (n))))
+	    {
+	      while (k--)
+		add_to_moid_text (b, "SHORT ", w);
+	      add_to_moid_text (b, NSYMBOL (NODE (n)), w);
+	    }
+	  else
+	    add_to_moid_text (b, "..", w);
+	}
+      else if (DIM (n) == 0)
+	add_to_moid_text (b, NSYMBOL (NODE (n)), w);
+
+      /*  Write compxounded modes.  */
+    }
+  else if (IS_REF (n))
+    {
+      if ((*w) >= strlen ("REF .."))
+	{
+	  add_to_moid_text (b, "REF ", w);
+	  moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+	}
+      else
+	  add_to_moid_text (b, "REF ..", w);
+    }
+  else if (IS_FLEX (n))
+    {
+      if ((*w) >= strlen ("FLEX .."))
+	{
+	  add_to_moid_text (b, "FLEX ", w);
+	  moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+	}
+      else
+	add_to_moid_text (b, "FLEX ..", w);
+    }
+  else if (IS_ROW (n))
+    {
+      size_t j = strlen ("[] ..") + (DIM (n) - 1) * strlen (",");
+
+      if ((*w) >= j)
+	{
+	  size_t k = DIM (n) - 1;
+	  add_to_moid_text (b, "[", w);
+	  while (k-- > 0)
+	    add_to_moid_text (b, ",", w);
+	  add_to_moid_text (b, "] ", w);
+	  moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+	}
+      else if (DIM (n) == 1)
+	{
+	  add_to_moid_text (b, "[] ..", w);
+	}
+      else
+	{
+	  size_t k = DIM (n);
+	  add_to_moid_text (b, "[", w);
+	  while (k--)
+	    add_to_moid_text (b, ",", w);
+	  add_to_moid_text (b, "] ..", w);
+	}
+    }
+  else if (IS_STRUCT (n))
+    {
+      size_t j = (strlen ("STRUCT ()") + (DIM (n) - 1)
+		  * strlen (".., ") + strlen (".."));
+
+      if ((*w) >= j)
+	{
+	  POSTULATE_T *save = A68 (postulates);
+	  a68_make_postulate (&A68 (postulates), n, NO_MOID);
+	  add_to_moid_text (b, "STRUCT (", w);
+	  pack_to_string (b, PACK (n), w, true, idf, indicant_value);
+	  add_to_moid_text (b, ")", w);
+	  a68_free_postulate_list (A68 (postulates), save);
+	  A68 (postulates) = save;
+	}
+      else
+	{
+	  size_t k = DIM (n);
+	  add_to_moid_text (b, "STRUCT (", w);
+	  while (k-- > 0)
+	    add_to_moid_text (b, ",", w);
+	  add_to_moid_text (b, ")", w);
+	}
+    }
+  else if (IS_UNION (n))
+    {
+      size_t j = (strlen ("UNION ()") + (DIM (n) - 1)
+		  * strlen (".., ") + strlen (".."));
+
+      if ((*w) >= j)
+	{
+	  POSTULATE_T *save = A68 (postulates);
+	  a68_make_postulate (&A68 (postulates), n, NO_MOID);
+	  add_to_moid_text (b, "UNION (", w);
+	  pack_to_string (b, PACK (n), w, false, idf, indicant_value);
+	  add_to_moid_text (b, ")", w);
+	  a68_free_postulate_list (A68 (postulates), save);
+	  A68 (postulates) = save;
+	}
+    else
+      {
+	size_t k = DIM (n);
+	add_to_moid_text (b, "UNION (", w);
+	while (k-- > 0)
+	  add_to_moid_text (b, ",", w);
+	add_to_moid_text (b, ")", w);
+      }
+    }
+  else if (IS (n, PROC_SYMBOL) && DIM (n) == 0)
+    {
+      if ((*w) >= strlen ("PROC .."))
+	{
+	  add_to_moid_text (b, "PROC ", w);
+	  moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+	}
+      else
+	add_to_moid_text (b, "PROC ..", w);
+    }
+  else if (IS (n, PROC_SYMBOL) && DIM (n) > 0)
+    {
+      size_t j = (strlen ("PROC () ..") + (DIM (n) - 1)
+		  * strlen (".., ") + strlen (".."));
+
+      if ((*w) >= j)
+	{
+	  POSTULATE_T *save = A68 (postulates);
+	  a68_make_postulate (&A68 (postulates), n, NO_MOID);
+	  add_to_moid_text (b, "PROC (", w);
+	  pack_to_string (b, PACK (n), w, false, idf, indicant_value);
+	  add_to_moid_text (b, ") ", w);
+	  moid_to_string_2 (b, SUB (n), w, idf, indicant_value);
+	  a68_free_postulate_list (A68 (postulates), save);
+	  A68 (postulates) = save;
+	}
+      else
+	{
+	  size_t k = DIM (n);
+
+	  add_to_moid_text (b, "PROC (", w);
+	  while (k-- > 0)
+	    add_to_moid_text (b, ",", w);
+	  add_to_moid_text (b, ") ..", w);
+	}
+    }
+  else if (IS (n, SERIES_MODE) || IS (n, STOWED_MODE))
+    {
+      size_t j = (strlen ("()") + (DIM (n) - 1)
+		  * strlen (".., ") + strlen (".."));
+
+      if ((*w) >= j)
+	{
+	  add_to_moid_text (b, "(", w);
+	  pack_to_string (b, PACK (n), w, false, idf, indicant_value);
+	  add_to_moid_text (b, ")", w);
+	}
+      else
+	{
+	  size_t k = DIM (n);
+
+	  add_to_moid_text (b, "(", w);
+	  while (k-- > 0)
+	    add_to_moid_text (b, ",", w);
+	  add_to_moid_text (b, ")", w);
+	}
+    }
+  else
+    {
+      char str[SMALL_BUFFER_SIZE];
+      if (snprintf (str, (size_t) SMALL_BUFFER_SIZE, "\\%d", ATTRIBUTE (n)) < 0)
+	gcc_unreachable ();
+      add_to_moid_text (b, str, w);
+    }
+}
+
+/* Pretty-formatted mode N; W is a measure of width.  */
+
+char *
+a68_moid_to_string (MOID_T *n, size_t w, NODE_T *idf, bool indicant_value)
+{
+#define MAX_MTS 8
+  /* We use a static buffer of MAX_MTS strings. This value 8 should be safe.
+     No more than MAX_MTS calls can be pending in for instance printf.  Instead
+     we could allocate each string on the heap but that leaks memory.  */
+  static int mts_buff_ptr = 0;
+  static char mts_buff[8][BUFFER_SIZE];
+  char *a = &(mts_buff[mts_buff_ptr][0]);
+  mts_buff_ptr++;
+  if (mts_buff_ptr >= MAX_MTS)
+    mts_buff_ptr = 0;
+  a[0] = '\0';
+  if (w >= BUFFER_SIZE)
+    w = BUFFER_SIZE - 1;
+  A68 (postulates) = NO_POSTULATE;
+  if (n != NO_MOID)
+    moid_to_string_2 (a, n, &w, idf, indicant_value);
+  else
+    a68_bufcat (a, "null", BUFFER_SIZE);
+  return a;
+#undef MAX_MTS
+}
diff --git a/gcc/algol68/a68-parser-modes.cc b/gcc/algol68/a68-parser-modes.cc
new file mode 100644
index 00000000000..fa2680cf5eb
--- /dev/null
+++ b/gcc/algol68/a68-parser-modes.cc
@@ -0,0 +1,1301 @@
+/* Mode table management.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/*
+ * Mode collection, equivalencing and derived modes.
+ */
+
+/* Few forward references.  */
+
+static MOID_T *get_mode_from_declarer (NODE_T *p);
+
+/*
+ * Mode service routines.
+ */
+
+/* Count bounds in declarer in tree.  */
+
+static int
+count_bounds (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return 0;
+  else
+    {
+      if (IS (p, BOUND))
+	return 1 + count_bounds (NEXT (p));
+      else
+	return count_bounds (NEXT (p)) + count_bounds (SUB (p));
+    }
+}
+
+/* Count number of SHORTs or LONGs. */
+
+static int
+count_sizety (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return 0;
+  else if (IS (p, LONGETY))
+    return count_sizety (SUB (p)) + count_sizety (NEXT (p));
+  else if (IS (p, SHORTETY))
+    return count_sizety (SUB (p)) + count_sizety (NEXT (p));
+  else if (IS (p, LONG_SYMBOL))
+    return 1;
+  else if (IS (p, SHORT_SYMBOL))
+    return -1;
+  else
+    return 0;
+}
+
+/* Count moids in a pack.  */
+
+int
+a68_count_pack_members (PACK_T *u)
+{
+  int k = 0;
+
+  for (; u != NO_PACK; FORWARD (u))
+    k++;
+  return k;
+}
+
+/* Replace a mode by its equivalent mode.  */
+
+static void
+resolve_equivalent (MOID_T **m)
+{
+  while ((*m) != NO_MOID
+	 && EQUIVALENT ((*m)) != NO_MOID
+	 && (*m) != EQUIVALENT (*m))
+    {
+      (*m) = EQUIVALENT (*m);
+    }
+}
+
+/* Reset moid.  */
+
+static void
+reset_moid_tree (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      MOID (p) = NO_MOID;
+      reset_moid_tree (SUB (p));
+    }
+}
+
+/* Renumber moids.  */
+
+void
+a68_renumber_moids (MOID_T *p, int n)
+{
+  if (p != NO_MOID)
+    {
+      NUMBER (p) = n;
+      a68_renumber_moids (NEXT (p), n + 1);
+    }
+}
+
+/* Register mode in the global mode table, if mode is unique.  */
+
+MOID_T *
+a68_register_extra_mode (MOID_T **z, MOID_T *u)
+{
+  /* If we already know this mode, return the existing entry; otherwise link it
+     in.  */
+  for (MOID_T *head = TOP_MOID (&A68_JOB); head != NO_MOID; FORWARD (head))
+    {
+      if (a68_prove_moid_equivalence (head, u))
+	return head;
+  }
+
+  /* Link to chain and exit.  */
+  NUMBER (u) = A68 (mode_count)++;
+  NEXT (u) = (*z);
+  return *z = u;
+}
+
+/* Create a new mode and add it to chain Z.  */
+
+MOID_T *
+a68_add_mode (MOID_T **z, int att, int dim, NODE_T *node, MOID_T *sub, PACK_T *pack)
+{
+  MOID_T *new_mode = a68_new_moid ();
+
+  if (sub == NO_MOID)
+    {
+      if (att == REF_SYMBOL
+	  || att == FLEX_SYMBOL
+	  || att == ROW_SYMBOL)
+	gcc_unreachable ();
+    }
+
+  USE (new_mode) = false;
+  ATTRIBUTE (new_mode) = att;
+  DIM (new_mode) = dim;
+  NODE (new_mode) = node;
+  HAS_ROWS (new_mode) = (att == ROW_SYMBOL);
+  SUB (new_mode) = sub;
+  PACK (new_mode) = pack;
+  NEXT (new_mode) = NO_MOID;
+  EQUIVALENT (new_mode) = NO_MOID;
+  SLICE (new_mode) = NO_MOID;
+  DEFLEXED (new_mode) = NO_MOID;
+  NAME (new_mode) = NO_MOID;
+  MULTIPLE (new_mode) = NO_MOID;
+  ROWED (new_mode) = NO_MOID;
+
+  return a68_register_extra_mode (z, new_mode);
+}
+
+/* Contract a UNION.  */
+
+void
+a68_contract_union (MOID_T *u)
+{
+  for (PACK_T *s = PACK (u); s != NO_PACK; FORWARD (s))
+    {
+      PACK_T *t = s;
+
+      while (t != NO_PACK)
+	{
+	  if (NEXT (t) != NO_PACK && MOID (NEXT (t)) == MOID (s))
+	    {
+	      MOID (t) = MOID (t);
+	      NEXT (t) = NEXT_NEXT (t);
+	    }
+	  else
+	    FORWARD (t);
+	}
+    }
+}
+
+/* Absorb UNION pack.  */
+
+PACK_T *
+a68_absorb_union_pack (PACK_T * u)
+{
+  PACK_T *z;
+  bool siga;
+
+  do
+    {
+      z = NO_PACK;
+      siga = false;
+      for (PACK_T *t = u; t != NO_PACK; FORWARD (t))
+	{
+	  if (IS (MOID (t), UNION_SYMBOL))
+	    {
+	      siga = true;
+	      for (PACK_T *s = PACK (MOID (t)); s != NO_PACK; FORWARD (s))
+		(void) a68_add_mode_to_pack (&z, MOID (s), NO_TEXT, NODE (s));
+	    }
+	  else
+	    {
+	      (void) a68_add_mode_to_pack (&z, MOID (t), NO_TEXT, NODE (t));
+	    }
+	}
+      u = z;
+    }
+  while (siga);
+  return z;
+}
+
+/* Add row and its slices to chain, recursively.  */
+
+static MOID_T *
+add_row (MOID_T **p, int dim, MOID_T *sub, NODE_T *n, bool derivate)
+{
+  MOID_T *q = a68_add_mode (p, ROW_SYMBOL, dim, n, sub, NO_PACK);
+
+  DERIVATE (q) |= derivate;
+  if (dim > 1)
+    SLICE (q) = add_row (&NEXT (q), dim - 1, sub, n, derivate);
+  else
+    SLICE (q) = sub;
+  return q;
+}
+
+/* Add a moid to a pack, maybe with a (field) name.  */
+
+void
+a68_add_mode_to_pack (PACK_T **p, MOID_T *m, const char *text, NODE_T *node)
+{
+  PACK_T *z = a68_new_pack ();
+
+  MOID (z) = m;
+  TEXT (z) = text;
+  NODE (z) = node;
+  NEXT (z) = *p;
+  PREVIOUS (z) = NO_PACK;
+  if (NEXT (z) != NO_PACK)
+    PREVIOUS (NEXT (z)) = z;
+
+  /* Link in chain.  */
+  *p = z;
+}
+
+/* Add a moid to a pack, maybe with a (field) name.  */
+
+void
+a68_add_mode_to_pack_end (PACK_T **p, MOID_T *m, const char *text, NODE_T *node)
+{
+  PACK_T *z = a68_new_pack ();
+
+  MOID (z) = m;
+  TEXT (z) = text;
+  NODE (z) = node;
+  NEXT (z) = NO_PACK;
+  if (NEXT (z) != NO_PACK)
+    PREVIOUS (NEXT (z)) = z;
+
+  /* Link in chain.  */
+  while ((*p) != NO_PACK)
+    p = &(NEXT (*p));
+  PREVIOUS (z) = (*p);
+  (*p) = z;
+}
+
+/* Absorb UNION members.  */
+
+static void
+absorb_unions (MOID_T *m)
+{
+  /* UNION (A, UNION (B, C)) = UNION (A, B, C) or
+     UNION (A, UNION (A, B)) = UNION (A, B).  */
+  for (; m != NO_MOID; FORWARD (m))
+    {
+      if (IS (m, UNION_SYMBOL))
+	PACK (m) = a68_absorb_union_pack (PACK (m));
+    }
+}
+
+/* Contract UNIONs.  */
+
+static void
+contract_unions (MOID_T *m)
+{
+  /* UNION (A, B, A) -> UNION (A, B).  */
+  for (; m != NO_MOID; FORWARD (m))
+    {
+      if (IS (m, UNION_SYMBOL) && EQUIVALENT (m) == NO_MOID)
+	a68_contract_union (m);
+    }
+}
+
+/*
+ * Routines to collect MOIDs from the program text.
+ */
+
+/* Search standard mode in standard environ.  */
+
+static MOID_T *
+search_standard_mode (int sizety, NODE_T *indicant)
+{
+  /* Search standard mode.  */
+  for (MOID_T *p = TOP_MOID (&A68_JOB); p != NO_MOID; FORWARD (p))
+    {
+      if (IS (p, STANDARD)
+	  && DIM (p) == sizety
+	  && NSYMBOL (NODE (p)) == NSYMBOL (indicant))
+	return p;
+  }
+
+  /* Map onto greater precision.  */
+  if (sizety < 0)
+    return search_standard_mode (sizety + 1, indicant);
+  else if (sizety > 0)
+    return search_standard_mode (sizety - 1, indicant);
+  else
+    return NO_MOID;
+}
+
+/* Collect mode from STRUCT field.  */
+
+static void
+get_mode_from_struct_field (NODE_T *p, PACK_T **u)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, IDENTIFIER))
+	{
+	  ATTRIBUTE (p) = FIELD_IDENTIFIER;
+	  (void) a68_add_mode_to_pack (u, NO_MOID, NSYMBOL (p), p);
+	}
+      else if (IS (p, DECLARER))
+	{
+	  MOID_T *new_one = get_mode_from_declarer (p);
+
+	  get_mode_from_struct_field (NEXT (p), u);
+	  for (PACK_T *t = *u; t && MOID (t) == NO_MOID; FORWARD (t))
+	    {
+	      MOID (t) = new_one;
+	      MOID (NODE (t)) = new_one;
+	    }
+	}
+      else
+	{
+	  get_mode_from_struct_field (NEXT (p), u);
+	  get_mode_from_struct_field (SUB (p), u);
+	}
+    }
+}
+
+/* Collect MODE from formal pack.  */
+
+static void
+get_mode_from_formal_pack (NODE_T *p, PACK_T **u)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, DECLARER))
+	{
+	  get_mode_from_formal_pack (NEXT (p), u);
+	  MOID_T *z = get_mode_from_declarer (p);
+	  (void) a68_add_mode_to_pack (u, z, NO_TEXT, p);
+	}
+      else
+	{
+	  get_mode_from_formal_pack (NEXT (p), u);
+	  get_mode_from_formal_pack (SUB (p), u);
+	}
+    }
+}
+
+/* Collect MODE or VOID from formal UNION pack.  */
+
+static void
+get_mode_from_union_pack (NODE_T *p, PACK_T **u)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, DECLARER) || IS (p, VOID_SYMBOL))
+	{
+	  get_mode_from_union_pack (NEXT (p), u);
+	  MOID_T *z = get_mode_from_declarer (p);
+	  (void) a68_add_mode_to_pack (u, z, NO_TEXT, p);
+	}
+      else
+	{
+	  get_mode_from_union_pack (NEXT (p), u);
+	  get_mode_from_union_pack (SUB (p), u);
+	}
+    }
+}
+
+/* Collect mode from PROC, OP pack.  */
+
+static void
+get_mode_from_routine_pack (NODE_T *p, PACK_T **u)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, IDENTIFIER))
+	(void) a68_add_mode_to_pack (u, NO_MOID, NO_TEXT, p);
+      else if (IS (p, DECLARER))
+	{
+	  MOID_T *z = get_mode_from_declarer (p);
+
+	  for (PACK_T *t = *u; t != NO_PACK && MOID (t) == NO_MOID; FORWARD (t))
+	    {
+	      MOID (t) = z;
+	      MOID (NODE (t)) = z;
+	    }
+	  (void) a68_add_mode_to_pack (u, z, NO_TEXT, p);
+	}
+      else
+	{
+	  get_mode_from_routine_pack (NEXT (p), u);
+	  get_mode_from_routine_pack (SUB (p), u);
+	}
+    }
+}
+
+/* Collect MODE from DECLARER.  */
+
+static MOID_T *
+get_mode_from_declarer (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return NO_MOID;
+  else
+    {
+      if (IS (p, DECLARER))
+	{
+	  if (MOID (p) != NO_MOID)
+	    return MOID (p);
+	 else
+	   return MOID (p) = get_mode_from_declarer (SUB (p));
+	}
+      else
+	{
+	  if (IS (p, VOID_SYMBOL))
+	    {
+	      MOID (p) = M_VOID;
+	      return MOID (p);
+	    }
+	  else if (IS (p, LONGETY))
+	    {
+	      if (a68_whether (p, LONGETY, INDICANT, STOP))
+		{
+		  int k = count_sizety (SUB (p));
+		  MOID (p) = search_standard_mode (k, NEXT (p));
+		  return MOID (p);
+		}
+	      else
+		{
+		  return NO_MOID;
+		}
+	    }
+	  else if (IS (p, SHORTETY))
+	    {
+	      if (a68_whether (p, SHORTETY, INDICANT, STOP))
+		{
+		  int k = count_sizety (SUB (p));
+		  MOID (p) = search_standard_mode (k, NEXT (p));
+		  return MOID (p);
+		}
+	      else
+		return NO_MOID;
+	    }
+	  else if (IS (p, INDICANT))
+	    {
+	      MOID_T *q = search_standard_mode (0, p);
+	      if (q != NO_MOID)
+		  MOID (p) = q;
+	      else
+		{
+		  /* 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));
+		  else
+		    MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, NODE (y),
+					     NO_MOID, NO_PACK);
+		}
+	      return MOID (p);
+	    }
+	  else if (IS_REF (p))
+	    {
+	      MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+	      MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
+	      return MOID (p);
+	    }
+	  else if (IS_FLEX (p))
+	    {
+	      MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+	      MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), FLEX_SYMBOL, 0, p, new_one, NO_PACK);
+	      SLICE (MOID (p)) = SLICE (new_one);
+	      return MOID (p);
+	    }
+	  else if (IS (p, FORMAL_BOUNDS))
+	    {
+	      MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+	      MOID (p) = add_row (&TOP_MOID (&A68_JOB),
+				  1 + a68_count_formal_bounds (SUB (p)), new_one, p, false);
+	      return MOID (p);
+	    }
+	  else if (IS (p, BOUNDS))
+	    {
+	      MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+	      MOID (p) = add_row (&TOP_MOID (&A68_JOB), count_bounds (SUB (p)), new_one, p, false);
+	      return MOID (p);
+	    }
+	  else if (IS (p, STRUCT_SYMBOL))
+	    {
+	      PACK_T *u = NO_PACK;
+	      get_mode_from_struct_field (NEXT (p), &u);
+	      MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB),
+				       STRUCT_SYMBOL, a68_count_pack_members (u), p, NO_MOID, u);
+	      return MOID (p);
+	    }
+	  else if (IS (p, UNION_SYMBOL))
+	    {
+	      PACK_T *u = NO_PACK;
+	      get_mode_from_union_pack (NEXT (p), &u);
+	      MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB),
+				       UNION_SYMBOL, a68_count_pack_members (u), p, NO_MOID, u);
+	      return MOID (p);
+	    }
+	  else if (IS (p, PROC_SYMBOL))
+	    {
+	      NODE_T *save = p;
+	      PACK_T *u = NO_PACK;
+	      if (IS (NEXT (p), FORMAL_DECLARERS))
+		{
+		  get_mode_from_formal_pack (SUB_NEXT (p), &u);
+		  FORWARD (p);
+		}
+	      MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+	      MOID (p) =
+		a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (u), save, new_one, u);
+	      MOID (save) = MOID (p);
+	      return MOID (p);
+	    }
+	  else
+	    return NO_MOID;
+	}
+    }
+}
+
+/* Collect MODEs from a routine-text header.  */
+
+static MOID_T *
+get_mode_from_routine_text (NODE_T *p)
+{
+  PACK_T *u = NO_PACK;
+  NODE_T *q = p;
+
+  if (IS (p, PARAMETER_PACK))
+    {
+      get_mode_from_routine_pack (SUB (p), &u);
+      FORWARD (p);
+    }
+  MOID_T *n = get_mode_from_declarer (p);
+  return a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (u), q, n, u);
+}
+
+/* Collect modes from operator-plan.  */
+
+static MOID_T *
+get_mode_from_operator (NODE_T *p)
+{
+  PACK_T *u = NO_PACK;
+  NODE_T *save = p;
+
+  if (IS (NEXT (p), FORMAL_DECLARERS))
+    {
+      get_mode_from_formal_pack (SUB_NEXT (p), &u);
+      FORWARD (p);
+    }
+  MOID_T *new_one = get_mode_from_declarer (NEXT (p));
+  MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), PROC_SYMBOL, a68_count_pack_members (u), save, new_one, u);
+  return MOID (p);
+}
+
+/* Collect mode from denotation.  */
+
+static void
+get_mode_from_denotation (NODE_T *p, int sizety)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, ROW_CHAR_DENOTATION))
+	{
+	  const char *s = NSYMBOL (p);
+	  size_t len = strlen (s);
+
+	  if (len == 1
+	      || (len == 2 && s[0] == '\'')
+	      || (len == 8 && s[0] == '\'' && s[1] == '(' && s[2] == 'u')
+	      || (len == 12 && s[0] == '\'' && s[1] == '(' && s[2] == 'U'))
+	    {
+	      MOID (p) = M_CHAR;
+	    }
+	  else
+	    MOID (p) = M_ROW_CHAR;
+	}
+      else if (IS (p, TRUE_SYMBOL) || IS (p, FALSE_SYMBOL))
+	{
+	  MOID (p) = M_BOOL;
+	}
+      else if (IS (p, INT_DENOTATION))
+	{
+	  if (sizety == -2)
+	    MOID (p) = M_SHORT_SHORT_INT;
+	  else if (sizety == -1)
+	    MOID (p) = M_SHORT_INT;
+	  else if (sizety == 0)
+	    MOID (p) = M_INT;
+	  else if (sizety == 1)
+	    MOID (p) = M_LONG_INT;
+	  else if (sizety == 2)
+	    MOID (p) = M_LONG_LONG_INT;
+	 else
+	   MOID (p) = (sizety > 0 ? M_LONG_LONG_INT : M_INT);
+	}
+      else if (IS (p, REAL_DENOTATION))
+	{
+	  if (sizety == 0)
+	    MOID (p) = M_REAL;
+	  else if (sizety == 1)
+	    MOID (p) = M_LONG_REAL;
+	 else if (sizety == 2)
+	   MOID (p) = M_LONG_LONG_REAL;
+	 else
+	   MOID (p) = (sizety > 0 ? M_LONG_LONG_REAL : M_REAL);
+	}
+      else if (IS (p, BITS_DENOTATION))
+	{
+	  if (sizety == -2)
+	    MOID (p) = M_SHORT_SHORT_BITS;
+	  else if (sizety == -1)
+	    MOID (p) = M_SHORT_BITS;
+	  else if (sizety == 0)
+	    MOID (p) = M_BITS;
+	  else if (sizety == 1)
+	    MOID (p) = M_LONG_BITS;
+	  else if (sizety == 2)
+	    MOID (p) = M_LONG_LONG_BITS;
+	  else
+	    MOID (p) = (sizety > 0 ? M_LONG_LONG_BITS : M_BITS);
+	}
+      else if (IS (p, LONGETY) || IS (p, SHORTETY))
+	{
+	  get_mode_from_denotation (NEXT (p), count_sizety (SUB (p)));
+	  MOID (p) = MOID (NEXT (p));
+	}
+      else if (IS (p, EMPTY_SYMBOL))
+       {
+	 MOID (p) = M_VOID;
+       }
+    }
+}
+
+/* Collect modes from the syntax tree.  */
+
+static void
+get_modes_from_tree (NODE_T *p, int attribute)
+{
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, VOID_SYMBOL))
+	MOID (q) = M_VOID;
+      else if (IS (q, DECLARER))
+	{
+	  if (attribute == VARIABLE_DECLARATION)
+	    {
+	      MOID_T *new_one = get_mode_from_declarer (q);
+	      MOID (q) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
+	    }
+	  else
+	    MOID (q) = get_mode_from_declarer (q);
+	}
+      else if (IS (q, ROUTINE_TEXT))
+	{
+	  MOID (q) = get_mode_from_routine_text (SUB (q));
+	}
+      else if (IS (q, OPERATOR_PLAN))
+	{
+	  MOID (q) = get_mode_from_operator (SUB (q));
+	}
+      else if (a68_is_one_of (q, LOC_SYMBOL, HEAP_SYMBOL, STOP))
+	{
+	  if (attribute == GENERATOR)
+	    {
+	      MOID_T *new_one = get_mode_from_declarer (NEXT (q));
+	      MOID (NEXT (q)) = new_one;
+	      MOID (q) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, NO_NODE, new_one, NO_PACK);
+	    }
+	}
+      else
+	{
+	  if (attribute == DENOTATION)
+	    get_mode_from_denotation (q, 0);
+	}
+    }
+
+  if (attribute != DENOTATION)
+    {
+      for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+	{
+	  if (SUB (q) != NO_NODE)
+	    get_modes_from_tree (SUB (q), ATTRIBUTE (q));
+	}
+    }
+}
+
+//! @brief Collect modes from proc variables.
+
+static void
+get_mode_from_proc_variables (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, PROCEDURE_VARIABLE_DECLARATION))
+	{
+	  get_mode_from_proc_variables (SUB (p));
+	  get_mode_from_proc_variables (NEXT (p));
+	}
+      else if (IS (p, QUALIFIER) || IS (p, PROC_SYMBOL) || IS (p, COMMA_SYMBOL))
+	{
+	  get_mode_from_proc_variables (NEXT (p));
+	}
+      else if (IS (p, DEFINING_IDENTIFIER))
+	{
+	  MOID_T *new_one = MOID (NEXT_NEXT (p));
+	  MOID (p) = a68_add_mode (&TOP_MOID (&A68_JOB), REF_SYMBOL, 0, p, new_one, NO_PACK);
+	}
+    }
+}
+
+/* Collect modes from proc variable declarations.  */
+
+static void
+get_mode_from_proc_var_declarations_tree (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      get_mode_from_proc_var_declarations_tree (SUB (p));
+
+      if (IS (p, PROCEDURE_VARIABLE_DECLARATION))
+	get_mode_from_proc_variables (p);
+    }
+}
+
+/*
+ * Various routines to test modes.
+ */
+
+/* Whether a mode declaration refers to self or relates to void.
+   This uses Lindsey's ying-yang algorithm.  */
+
+static bool
+is_well_formed (MOID_T *def, MOID_T *z, bool yin, bool yang, bool video)
+{
+  if (z == NO_MOID)
+    return false;
+  else if (yin && yang)
+    return z == M_VOID ? video : true;
+  else if (z == M_VOID)
+    return video;
+  else if (IS (z, STANDARD))
+    return true;
+  else if (IS (z, INDICANT))
+    {
+      if (def == NO_MOID)
+	{
+	  /* Check an applied indicant for relation to VOID.  */
+	  while (z != NO_MOID)
+	    z = EQUIVALENT (z);
+	  if (z == M_VOID)
+	    return video;
+	  else
+	    return true;
+	}
+      else
+	{
+	  if (z == def || USE (z))
+	    return yin && yang;
+	  else
+	    {
+	      USE (z) = true;
+	      bool wwf = is_well_formed (def, EQUIVALENT (z), yin, yang, video);
+	      USE (z) = false;
+	  return wwf;
+	    }
+	}
+    }
+  else if (IS_REF (z))
+    return is_well_formed (def, SUB (z), true, yang, false);
+  else if (IS (z, PROC_SYMBOL))
+    return PACK (z) != NO_PACK ? true : is_well_formed (def, SUB (z), true, yang, true);
+  else if (IS_ROW (z))
+    return is_well_formed (def, SUB (z), yin, yang, false);
+  else if (IS_FLEX (z))
+    return is_well_formed (def, SUB (z), yin, yang, false);
+  else if (IS (z, STRUCT_SYMBOL))
+    {
+      for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s))
+	{
+	  if (!is_well_formed (def, MOID (s), yin, true, false))
+	    return false;
+	}
+      return true;
+    }
+  else if (IS (z, UNION_SYMBOL))
+    {
+      for (PACK_T *s = PACK (z); s != NO_PACK; FORWARD (s))
+	{
+	  if (!is_well_formed (def, MOID (s), yin, yang, true))
+	    return false;
+	}
+      return true;
+    }
+  else
+    {
+      return false;
+    }
+}
+
+/* Replace a mode by its equivalent mode (walk chain).  */
+
+static void
+resolve_eq_members (MOID_T *q)
+{
+  resolve_equivalent (&SUB (q));
+  resolve_equivalent (&DEFLEXED (q));
+  resolve_equivalent (&MULTIPLE (q));
+  resolve_equivalent (&NAME (q));
+  resolve_equivalent (&SLICE (q));
+  resolve_equivalent (&TRIM (q));
+  resolve_equivalent (&ROWED (q));
+  for (PACK_T *p = PACK (q); p != NO_PACK; FORWARD (p))
+    resolve_equivalent (&MOID (p));
+}
+
+/* Track equivalent tags.  */
+
+static void
+resolve_eq_tags (TAG_T *z)
+{
+  for (; z != NO_TAG; FORWARD (z))
+    {
+      if (MOID (z) != NO_MOID)
+	resolve_equivalent (&MOID (z));
+    }
+}
+
+/* Bind modes in syntax tree.  */
+
+static void
+bind_modes (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      resolve_equivalent (&MOID (p));
+
+      if (SUB (p) != NO_NODE && a68_is_new_lexical_level (p))
+	{
+	  TABLE_T *s = TABLE (SUB (p));
+	  for (TAG_T *z = INDICANTS (s); z != NO_TAG; FORWARD (z))
+	    {
+	      if (NODE (z) != NO_NODE)
+		{
+		  resolve_equivalent (&MOID (NEXT_NEXT (NODE (z))));
+		  MOID (z) = MOID (NEXT_NEXT (NODE (z)));
+		  MOID (NODE (z)) = MOID (z);
+		}
+	    }
+	}
+      bind_modes (SUB (p));
+    }
+}
+
+/* Routines for calculating subordinates for selections, for instance selection
+   from REF STRUCT (A) yields REF A fields and selection from [] STRUCT (A)
+   yields [] A fields.  */
+
+/* Make name pack.
+   Given a pack with modes: M1, M2, ...
+   Build a pack with modes: REF M1, REF M2, ...  */
+
+static void
+make_name_pack (PACK_T *src, PACK_T **dst, MOID_T **p)
+{
+  if (src != NO_PACK)
+    {
+      make_name_pack (NEXT (src), dst, p);
+      MOID_T *z = a68_add_mode (p, REF_SYMBOL, 0, NO_NODE, MOID (src), NO_PACK);
+      (void) a68_add_mode_to_pack (dst, z, TEXT (src), NODE (src));
+    }
+}
+
+/* Make flex multiple row pack.
+   Given a pack with modes: M1, M2, ...
+   Build a pack with modes: []M1, []M2, ...  */
+
+static void
+make_flex_multiple_row_pack (PACK_T *src, PACK_T **dst, MOID_T **p, int dim)
+{
+  if (src != NO_PACK)
+    {
+      make_flex_multiple_row_pack (NEXT (src), dst, p, dim);
+      MOID_T *z = add_row (p, dim, MOID (src), NO_NODE, false);
+      z = a68_add_mode (p, FLEX_SYMBOL, 0, NO_NODE, z, NO_PACK);
+      (void) a68_add_mode_to_pack (dst, z, TEXT (src), NODE (src));
+    }
+}
+
+/* Make name struct.  */
+
+static MOID_T *
+make_name_struct (MOID_T *m, MOID_T **p)
+{
+  PACK_T *u = NO_PACK;
+  make_name_pack (PACK (m), &u, p);
+  return a68_add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
+}
+
+/* Make name row.  */
+
+static MOID_T *
+make_name_row (MOID_T *m, MOID_T **p)
+{
+  if (SLICE (m) != NO_MOID)
+    return a68_add_mode (p, REF_SYMBOL, 0, NO_NODE, SLICE (m), NO_PACK);
+  else if (SUB (m) != NO_MOID)
+    return a68_add_mode (p, REF_SYMBOL, 0, NO_NODE, SUB (m), NO_PACK);
+  else
+    /* weird, FLEX INT or so ...  */
+    return NO_MOID;
+}
+
+/* Make multiple row pack.  */
+
+static void
+make_multiple_row_pack (PACK_T *src, PACK_T **dst, MOID_T **p, int dim)
+{
+  if (src != NO_PACK)
+    {
+      make_multiple_row_pack (NEXT (src), dst, p, dim);
+      (void) a68_add_mode_to_pack (dst, add_row (p, dim, MOID (src), NO_NODE, false),
+				   TEXT (src), NODE (src));
+    }
+}
+
+/* Make flex multiple struct.  */
+
+static MOID_T *
+make_flex_multiple_struct (MOID_T *m, MOID_T **p, int dim)
+{
+  PACK_T *u = NO_PACK;
+  make_flex_multiple_row_pack (PACK (m), &u, p, dim);
+  return a68_add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
+}
+
+/* Make multiple struct.  */
+
+static MOID_T *
+make_multiple_struct (MOID_T *m, MOID_T **p, int dim)
+{
+  PACK_T *u = NO_PACK;
+  make_multiple_row_pack (PACK (m), &u, p, dim);
+  return a68_add_mode (p, STRUCT_SYMBOL, DIM (m), NO_NODE, NO_MOID, u);
+}
+
+/* Whether mode has row.  */
+
+static bool
+is_mode_has_row (MOID_T *m)
+{
+  if (IS (m, STRUCT_SYMBOL) || IS (m, UNION_SYMBOL))
+    {
+      bool k = false;
+
+      for (PACK_T *p = PACK (m); p != NO_PACK && k == false; FORWARD (p))
+	{
+	  HAS_ROWS (MOID (p)) = is_mode_has_row (MOID (p));
+	  k |= (HAS_ROWS (MOID (p)));
+	}
+      return k;
+    }
+  else
+    return (HAS_ROWS (m) || IS_ROW (m) || IS_FLEX (m));
+}
+
+/* Compute derived modes.  */
+
+static void
+compute_derived_modes (MODULE_T *mod)
+{
+  MOID_T *z;
+  int len = 0, nlen = 1;
+
+  /* UNION things.  */
+  absorb_unions (TOP_MOID (mod));
+  contract_unions (TOP_MOID (mod));
+  /* The for-statement below prevents an endless loop.  */
+  for (int k = 1; k <= 10 && len != nlen; k++)
+    {
+      /* Make deflexed modes.  */
+      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+	{
+	  if (SUB (z) != NO_MOID)
+	    {
+	      if (IS_REF_FLEX (z) && DEFLEXED (SUB_SUB (z)) != NO_MOID)
+		DEFLEXED (z) = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z),
+					     DEFLEXED (SUB_SUB (z)), NO_PACK);
+	      else if (IS_REF (z) && DEFLEXED (SUB (z)) != NO_MOID)
+		DEFLEXED (z) = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z),
+					     DEFLEXED (SUB (z)), NO_PACK);
+	      else if (IS_ROW (z) && DEFLEXED (SUB (z)) != NO_MOID)
+		DEFLEXED (z) = a68_add_mode (&TOP_MOID (mod), ROW_SYMBOL, DIM (z), NODE (z),
+					     DEFLEXED (SUB (z)), NO_PACK);
+	      else if (IS_FLEX (z) && DEFLEXED (SUB (z)) != NO_MOID)
+		DEFLEXED (z) = DEFLEXED (SUB (z));
+	      else if (IS_FLEX (z))
+		DEFLEXED (z) = SUB (z);
+	      else
+		DEFLEXED (z) = z;
+	    }
+	}
+
+      /* Derived modes for stowed modes.  */
+      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+	{
+	  if (NAME (z) == NO_MOID && IS_REF (z))
+	    {
+	      if (IS (SUB (z), STRUCT_SYMBOL))
+		NAME (z) = make_name_struct (SUB (z), &TOP_MOID (mod));
+	      else if (IS_ROW (SUB (z)))
+		NAME (z) = make_name_row (SUB (z), &TOP_MOID (mod));
+	      else if (IS_FLEX (SUB (z)) && SUB_SUB (z) != NO_MOID)
+		NAME (z) = make_name_row (SUB_SUB (z), &TOP_MOID (mod));
+	    }
+
+	  if (MULTIPLE (z) != NO_MOID)
+	    ;
+	  else if (IS_REF (z))
+	    {
+	      if (MULTIPLE (SUB (z)) != NO_MOID)
+		MULTIPLE (z) = make_name_struct (MULTIPLE (SUB (z)), &TOP_MOID (mod));
+	    }
+	  else if (IS_ROW (z))
+	    {
+	      if (IS (SUB (z), STRUCT_SYMBOL))
+		MULTIPLE (z) = make_multiple_struct (SUB (z), &TOP_MOID (mod), DIM (z));
+	    }
+	}
+
+      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+	{
+	  if (TRIM (z) == NO_MOID && IS_FLEX (z))
+	    TRIM (z) = SUB (z);
+	  if (TRIM (z) == NO_MOID && IS_REF_FLEX (z))
+	    TRIM (z) = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), SUB_SUB (z), NO_PACK);
+	}
+
+      /* Fill out stuff for rows, f.i. inverse relations.  */
+      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+	{
+	  if (IS_ROW (z) && DIM (z) > 0 && SUB (z) != NO_MOID && !DERIVATE (z))
+	    (void) add_row (&TOP_MOID (mod), DIM (z) + 1, SUB (z), NODE (z), true);
+	  else if (IS_REF (z) && IS (SUB (z), ROW_SYMBOL) && !DERIVATE (SUB (z)))
+	    {
+	      MOID_T *x = add_row (&TOP_MOID (mod), DIM (SUB (z)) + 1, SUB_SUB (z), NODE (SUB (z)), true);
+	      MOID_T *y = a68_add_mode (&TOP_MOID (mod), REF_SYMBOL, 0, NODE (z), x, NO_PACK);
+	      NAME (y) = z;
+	    }
+	}
+
+      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+	{
+	  if (IS_ROW (z) && SLICE (z) != NO_MOID)
+	    ROWED (SLICE (z)) = z;
+	  if (IS_REF (z))
+	    {
+	      MOID_T *y = SUB (z);
+	      if (SLICE (y) != NO_MOID && IS_ROW (SLICE (y)) && NAME (z) != NO_MOID)
+		ROWED (NAME (z)) = z;
+	    }
+	}
+
+      bind_modes (TOP_NODE (mod));
+      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+	{
+	  if (IS (z, INDICANT) && NODE (z) != NO_NODE)
+	    EQUIVALENT (z) = MOID (NODE (z));
+	}
+      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+	resolve_eq_members (z);
+      resolve_eq_tags (INDICANTS (A68_STANDENV));
+      resolve_eq_tags (IDENTIFIERS (A68_STANDENV));
+      resolve_eq_tags (OPERATORS (A68_STANDENV));
+      resolve_equivalent (&M_STRING);
+      resolve_equivalent (&M_COMPLEX);
+      resolve_equivalent (&M_LONG_COMPLEX);
+      resolve_equivalent (&M_LONG_LONG_COMPLEX);
+      resolve_equivalent (&M_SEMA);
+      /* UNION members could be resolved.  */
+      absorb_unions (TOP_MOID (mod));
+      contract_unions (TOP_MOID (mod));
+      /* FLEX INDICANT could be resolved.  */
+      for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+	{
+	  if (IS_FLEX (z) && SUB (z) != NO_MOID)
+	    {
+	      if (SUB_SUB (z) != NO_MOID && IS (SUB_SUB (z), STRUCT_SYMBOL))
+		MULTIPLE (z) = make_flex_multiple_struct (SUB_SUB (z), &TOP_MOID (mod), DIM (SUB (z)));
+	    }
+	}
+      /* See what new known modes we have generated by resolving..  */
+      for (z = TOP_MOID (mod); z != STANDENV_MOID (&A68_JOB); FORWARD (z))
+	{
+	  MOID_T *v;
+
+	  for (v = NEXT (z); v != NO_MOID; FORWARD (v))
+	    {
+	      if (a68_prove_moid_equivalence (z, v))
+		{
+		  EQUIVALENT (z) = v;
+		  EQUIVALENT (v) = NO_MOID;
+		}
+	    }
+	}
+
+      /* Count the modes to check self consistency.  */
+      len = nlen;
+      for (nlen = 0, z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+	nlen++;
+    }
+
+  gcc_assert (M_STRING == M_FLEX_ROW_CHAR);
+
+  /* Find out what modes contain rows.  */
+  for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+    HAS_ROWS (z) = is_mode_has_row (z);
+
+  /* Check flexible modes.  */
+  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);
+    }
+
+  /* Check on fields in structured modes f.i. STRUCT (REAL x, INT n, REAL x) is
+     wrong.  */
+  for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+    {
+      if (IS (z, STRUCT_SYMBOL) && EQUIVALENT (z) == NO_MOID)
+	{
+	  PACK_T *s = PACK (z);
+
+	  for (; s != NO_PACK; FORWARD (s))
+	    {
+	      PACK_T *t = NEXT (s);
+	      bool x = true;
+
+	      for (t = NEXT (s); t != NO_PACK && x; FORWARD (t))
+		{
+		  if (TEXT (s) == TEXT (t))
+		    {
+		      a68_error (NODE (z), "multiple declaration of field S");
+		      while (NEXT (s) != NO_PACK && TEXT (NEXT (s)) == TEXT (t))
+			FORWARD (s);
+		      x = false;
+		    }
+		}
+	    }
+	}
+    }
+
+  /* Various union test.  */
+  for (z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+    {
+      if (IS (z, UNION_SYMBOL) && EQUIVALENT (z) == NO_MOID)
+	{
+	  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);
+	  /* Discard incestuous unions with firmly related modes.  */
+	  for (; s != NO_PACK; FORWARD (s))
+	    {
+	      PACK_T *t;
+
+	      for (t = NEXT (s); t != NO_PACK; FORWARD (t))
+		{
+		  if (MOID (t) != MOID (s))
+		    {
+		      if (a68_is_firm (MOID (s), MOID (t)))
+			a68_error (NODE (z), "M has firmly related components", z);
+		    }
+		}
+	    }
+
+	  /* Discard incestuous unions with firmly related subsets.  */
+	  for (s = PACK (z); s != NO_PACK; FORWARD (s))
+	    {
+	      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);
+	    }
+	}
+    }
+
+  /* Wrap up and exit.  */
+  a68_free_postulate_list (A68 (top_postulate), NO_POSTULATE);
+  A68 (top_postulate) = NO_POSTULATE;
+}
+
+/* Make list of all modes in the program.  */
+
+void
+a68_make_moid_list (MODULE_T *mod)
+{
+  bool cont = true;
+
+  /* Collect modes from the syntax tree.  */
+  reset_moid_tree (TOP_NODE (mod));
+  get_modes_from_tree (TOP_NODE (mod), STOP);
+  get_mode_from_proc_var_declarations_tree (TOP_NODE (mod));
+
+  /* Connect indicants to their declarers.  */
+  for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+    {
+      if (IS (z, INDICANT))
+	{
+	  NODE_T *u = NODE (z);
+	  gcc_assert (NEXT (u) != NO_NODE);
+	  gcc_assert (NEXT_NEXT (u) != NO_NODE);
+	  gcc_assert (MOID (NEXT_NEXT (u)) != NO_MOID);
+	  EQUIVALENT (z) = MOID (NEXT_NEXT (u));
+	}
+    }
+
+  /* Checks on wrong declarations.  */
+  for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+    USE (z) = false;
+
+  for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+    {
+      if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID)
+	{
+	  if (!is_well_formed (z, EQUIVALENT (z), false, false, true))
+	    {
+	      a68_error (NODE (z), "M does not specify a well formed mode", z);
+	      cont = false;
+	    }
+	}
+    }
+
+  for (MOID_T *z = TOP_MOID (mod); cont && z != NO_MOID; FORWARD (z))
+    {
+      if (IS (z, INDICANT) && EQUIVALENT (z) != NO_MOID)
+	;
+      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);
+	}
+    }
+
+  for (MOID_T *z = TOP_MOID (mod); z != NO_MOID; FORWARD (z))
+    {
+      if (USE (z))
+	gcc_unreachable ();
+    }
+
+  if (ERROR_COUNT (mod) != 0)
+    return;
+
+  compute_derived_modes (mod);
+  a68_init_postulates ();
+}
diff --git a/gcc/algol68/a68-parser-moids-check.cc b/gcc/algol68/a68-parser-moids-check.cc
new file mode 100644
index 00000000000..dd5ebb37bec
--- /dev/null
+++ b/gcc/algol68/a68-parser-moids-check.cc
@@ -0,0 +1,1811 @@
+/* Mode checker routines.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 Jose E. Marchesi.
+
+   Original implementation by J. Marcel van der Veer.
+   Adapted for GCC and fixes 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/>.  */
+
+/* ALGOL 68 contexts are SOFT, WEAK, MEEK, FIRM and STRONG.
+   These contexts are increasing in strength:
+
+   SOFT: Deproceduring
+
+   WEAK: Dereferencing to REF [] or REF STRUCT
+
+   MEEK: Deproceduring and dereferencing
+
+   FIRM: MEEK followed by uniting
+
+   STRONG: FIRM followed by rowing, widening or voiding
+
+   Furthermore you will see in this file next switches:
+
+   (1) FORCE_DEFLEXING allows assignment compatibility between FLEX and non FLEX
+   rows. This can only be the case when there is no danger of altering bounds of a
+   non FLEX row.
+
+   (2) ALIAS_DEFLEXING prohibits aliasing a FLEX row to a non FLEX row (vice versa
+   is no problem) so that one cannot alter the bounds of a non FLEX row by
+   aliasing it to a FLEX row. This is particularly the case when passing names as
+   parameters to procedures:
+
+      PROC x = (REF STRING s) VOID: ..., PROC y = (REF [] CHAR c) VOID: ...;
+
+      x (LOC STRING);    # OK #
+
+      x (LOC [10] CHAR); # Not OK, suppose x changes bounds of s! #
+
+      y (LOC STRING);    # OK #
+
+      y (LOC [10] CHAR); # OK #
+
+   (3) SAFE_DEFLEXING sets FLEX row apart from non FLEX row. This holds for names,
+   not for values, so common things are not rejected, for instance
+
+      STRING x = read string;
+
+      [] CHAR y = read string
+
+   (4) NO_DEFLEXING sets FLEX row apart from non FLEX row.  */
+
+/*
+  In the RR grammar:
+
+     SORT: strong; firm; weak; meek; soft.
+     SORT MOID serial clause;
+       strong void unit, go on token, SORT MOID serial clause;
+       declaration, go on token, SORT MOID serial clause;
+       SORT MOID unit
+
+  And it is the SORT MOID sequence of metanotions, which shall evaluate the
+  same in the complete rule, that control the balancing! o_O
+
+  Also, it denotes how the SORT MOID of the serial clause gets "passed" to the
+  last unit in the serial clause.  Other units have SOID `strong void'.
+
+  It is used to pass down the required mode on whatever context.  Like,
+  PARTICULAR_PROGRAM evaluates in strong context and requires VOID.
+
+  The ATTRIBUTE in the soid is used to pass down the kind of construct that
+  introduces the context+required mode.  This is used in
+  a68_determine_unique_mode in order to know whether balancing shall be
+  performed or not.
+*/
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/* Forward declarations of some of the functions defined below.  */
+
+static void mode_check_enclosed (NODE_T *p, SOID_T *x, SOID_T *y);
+static void mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y);
+static void mode_check_formula (NODE_T *p, SOID_T *x, SOID_T *y);
+
+/* Driver for mode checker.  */
+
+void
+a68_mode_checker (NODE_T *p)
+{
+  if (IS (p, PARTICULAR_PROGRAM))
+    {
+      A68 (top_soid_list) = NO_SOID;
+      SOID_T x, y;
+      a68_make_soid (&x, STRONG, M_VOID, 0);
+      mode_check_enclosed (SUB (p), &x, &y);
+      MOID (p) = MOID (&y);
+    }
+}
+
+/* Mode check on bounds.  */
+
+static void
+mode_check_bounds (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, UNIT))
+    {
+      SOID_T x, y;
+      a68_make_soid (&x, STRONG, M_INT, 0);
+      mode_check_unit (p, &x, &y);
+      if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+	a68_cannot_coerce (p, MOID (&y), M_INT, MEEK, SAFE_DEFLEXING, UNIT);
+      mode_check_bounds (NEXT (p));
+    }
+  else
+    {
+      mode_check_bounds (SUB (p));
+      mode_check_bounds (NEXT (p));
+    }
+}
+
+/* Mode check declarer.  */
+
+static void
+mode_check_declarer (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, BOUNDS))
+    {
+      mode_check_bounds (SUB (p));
+      mode_check_declarer (NEXT (p));
+    }
+  else
+    {
+      mode_check_declarer (SUB (p));
+      mode_check_declarer (NEXT (p));
+    }
+}
+
+/* Mode check identity declaration.  */
+
+static void
+mode_check_identity_declaration (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case DECLARER:
+	  mode_check_declarer (SUB (p));
+	  mode_check_identity_declaration (NEXT (p));
+	  break;
+	case DEFINING_IDENTIFIER:
+	  {
+	    SOID_T x, y;
+	    a68_make_soid (&x, STRONG, MOID (p), 0);
+	    mode_check_unit (NEXT_NEXT (p), &x, &y);
+	    if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+	      a68_cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT);
+	    else if (MOID (&x) != MOID (&y))
+	      /* Check for instance, REF INT i = LOC REF INT.  */
+	      a68_semantic_pitfall (NEXT_NEXT (p), MOID (&x), IDENTITY_DECLARATION, GENERATOR);
+	    break;
+	  }
+	default:
+	  mode_check_identity_declaration (SUB (p));
+	  mode_check_identity_declaration (NEXT (p));
+	  break;
+	}
+    }
+}
+
+/* Mode check variable declaration.  */
+
+static void
+mode_check_variable_declaration (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case DECLARER:
+	  mode_check_declarer (SUB (p));
+	  mode_check_variable_declaration (NEXT (p));
+	  break;
+	case DEFINING_IDENTIFIER:
+	  if (a68_whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP))
+	    {
+	      SOID_T x, y;
+	      a68_make_soid (&x, STRONG, SUB_MOID (p), 0);
+	      mode_check_unit (NEXT_NEXT (p), &x, &y);
+	      if (!a68_is_coercible_in_context (&y, &x, FORCE_DEFLEXING))
+		a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, FORCE_DEFLEXING, UNIT);
+	      else if (SUB_MOID (&x) != MOID (&y))
+		/* Check for instance, REF INT i = LOC REF INT.  */
+		a68_semantic_pitfall (NEXT_NEXT (p), MOID (&x), VARIABLE_DECLARATION, GENERATOR);
+	    }
+	  break;
+	default:
+	  mode_check_variable_declaration (SUB (p));
+	  mode_check_variable_declaration (NEXT (p));
+	  break;
+	}
+    }
+}
+
+/* Mode check routine text.  */
+
+static void
+mode_check_routine_text (NODE_T *p, SOID_T *y)
+{
+  SOID_T w;
+
+  if (IS (p, PARAMETER_PACK))
+    {
+      mode_check_declarer (SUB (p));
+      FORWARD (p);
+    }
+
+  mode_check_declarer (SUB (p));
+  a68_make_soid (&w, STRONG, MOID (p), 0);
+  mode_check_unit (NEXT_NEXT (p), &w, y);
+  if (!a68_is_coercible_in_context (y, &w, FORCE_DEFLEXING))
+    a68_cannot_coerce (NEXT_NEXT (p), MOID (y), MOID (&w), STRONG, FORCE_DEFLEXING, UNIT);
+}
+
+/* Mode check proc declaration.  */
+
+static void
+mode_check_proc_declaration (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, ROUTINE_TEXT))
+    {
+      SOID_T x, y;
+      a68_make_soid (&x, STRONG, NO_MOID, 0);
+      mode_check_routine_text (SUB (p), &y);
+    }
+  else
+    {
+      mode_check_proc_declaration (SUB (p));
+      mode_check_proc_declaration (NEXT (p));
+    }
+}
+
+/* Mode check brief op declaration.  */
+
+static void
+mode_check_brief_op_declaration (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, DEFINING_OPERATOR))
+    {
+      SOID_T y;
+
+      if (MOID (p) != MOID (NEXT_NEXT (p)))
+	{
+	  SOID_T y2, x;
+	  a68_make_soid (&y2, NO_SORT, MOID (NEXT_NEXT (p)), 0);
+	  a68_make_soid (&x, NO_SORT, MOID (p), 0);
+	  a68_cannot_coerce (NEXT_NEXT (p), MOID (&y2), MOID (&x), STRONG, SKIP_DEFLEXING, ROUTINE_TEXT);
+	}
+      mode_check_routine_text (SUB (NEXT_NEXT (p)), &y);
+    }
+  else
+    {
+      mode_check_brief_op_declaration (SUB (p));
+      mode_check_brief_op_declaration (NEXT (p));
+    }
+}
+
+/* Mode check op declaration.  */
+
+static void
+mode_check_op_declaration (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, DEFINING_OPERATOR))
+    {
+      SOID_T y, x;
+      a68_make_soid (&x, STRONG, MOID (p), 0);
+      mode_check_unit (NEXT_NEXT (p), &x, &y);
+      if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+	a68_cannot_coerce (NEXT_NEXT (p), MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, UNIT);
+    }
+  else
+    {
+      mode_check_op_declaration (SUB (p));
+      mode_check_op_declaration (NEXT (p));
+    }
+}
+
+/* Mode check declaration list.  */
+
+static void
+mode_check_declaration_list (NODE_T * p)
+{
+  if (p != NO_NODE)
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case IDENTITY_DECLARATION:
+	  mode_check_identity_declaration (SUB (p));
+	  break;
+	case VARIABLE_DECLARATION:
+	  mode_check_variable_declaration (SUB (p));
+	  break;
+	case MODE_DECLARATION:
+	  mode_check_declarer (SUB (p));
+	  break;
+	case PROCEDURE_DECLARATION:
+	case PROCEDURE_VARIABLE_DECLARATION:
+	  mode_check_proc_declaration (SUB (p));
+	  break;
+	case BRIEF_OPERATOR_DECLARATION:
+	  mode_check_brief_op_declaration (SUB (p));
+	  break;
+	case OPERATOR_DECLARATION:
+	  mode_check_op_declaration (SUB (p));
+	  break;
+	default:
+	  mode_check_declaration_list (SUB (p));
+	  mode_check_declaration_list (NEXT (p));
+	  break;
+	}
+    }
+}
+
+/* Mode check serial clause.  */
+
+static void
+mode_check_serial (SOID_T **r, NODE_T *p, SOID_T *x, bool k)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, INITIALISER_SERIES))
+    {
+      mode_check_serial (r, SUB (p), x, false);
+      mode_check_serial (r, NEXT (p), x, k);
+    }
+  else if (IS (p, DECLARATION_LIST))
+    mode_check_declaration_list (SUB (p));
+  else if (a68_is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP))
+    mode_check_serial (r, NEXT (p), x, k);
+  else if (a68_is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP))
+    {
+      if (NEXT (p) != NO_NODE)
+	{
+	  if (IS (NEXT (p), EXIT_SYMBOL) || IS (NEXT (p), END_SYMBOL) || IS (NEXT (p), CLOSE_SYMBOL))
+	    mode_check_serial (r, SUB (p), x, true);
+	  else
+	    mode_check_serial (r, SUB (p), x, false);
+	  mode_check_serial (r, NEXT (p), x, k);
+	}
+      else
+	mode_check_serial (r, SUB (p), x, true);
+    }
+  else if (IS (p, LABELED_UNIT))
+    mode_check_serial (r, SUB (p), x, k);
+  else if (IS (p, UNIT))
+    {
+      SOID_T y;
+
+      if (k)
+	mode_check_unit (p, x, &y);
+      else
+	{
+	  SOID_T w;
+	  a68_make_soid (&w, STRONG, M_VOID, 0);
+	  mode_check_unit (p, &w, &y);
+	}
+      if (NEXT (p) != NO_NODE)
+	mode_check_serial (r, NEXT (p), x, k);
+      else
+	{
+	  if (k)
+	    a68_add_to_soid_list (r, p, &y);
+	}
+    }
+}
+
+/* Mode check serial clause units.  */
+
+static void
+mode_check_serial_units (NODE_T *p, SOID_T *x, SOID_T *y,
+			 int att __attribute__((unused)))
+{
+  SOID_T *top_sl = NO_SOID;
+
+  mode_check_serial (&top_sl, SUB (p), x, true);
+  if (a68_is_balanced (p, top_sl, SORT (x)))
+    {
+      MOID_T *result = a68_pack_soids_in_moid (top_sl, SERIES_MODE);
+      a68_make_soid (y, SORT (x), result, SERIAL_CLAUSE);
+    }
+  else
+    a68_make_soid (y, SORT (x), (MOID (x) != NO_MOID ? MOID (x) : M_ERROR), 0);
+
+  a68_free_soid_list (top_sl);
+}
+
+/* Mode check unit list.  */
+
+static void
+mode_check_unit_list (SOID_T **r, NODE_T *p, SOID_T *x)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, UNIT_LIST))
+    {
+      mode_check_unit_list (r, SUB (p), x);
+      mode_check_unit_list (r, NEXT (p), x);
+    }
+  else if (IS (p, COMMA_SYMBOL))
+    mode_check_unit_list (r, NEXT (p), x);
+  else if (IS (p, UNIT))
+    {
+      SOID_T y;
+      mode_check_unit (p, x, &y);
+      a68_add_to_soid_list (r, p, &y);
+      mode_check_unit_list (r, NEXT (p), x);
+    }
+}
+
+/* Mode check struct display.  */
+
+static void
+mode_check_struct_display (SOID_T **r, NODE_T *p, PACK_T **fields)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, UNIT_LIST))
+    {
+      mode_check_struct_display (r, SUB (p), fields);
+      mode_check_struct_display (r, NEXT (p), fields);
+    }
+  else if (IS (p, COMMA_SYMBOL))
+    mode_check_struct_display (r, NEXT (p), fields);
+  else if (IS (p, UNIT))
+    {
+      SOID_T x, y;
+
+      if (*fields != NO_PACK)
+	{
+	  a68_make_soid (&x, STRONG, MOID (*fields), 0);
+	  FORWARD (*fields);
+	}
+      else
+	a68_make_soid (&x, STRONG, NO_MOID, 0);
+      mode_check_unit (p, &x, &y);
+      a68_add_to_soid_list (r, p, &y);
+      mode_check_struct_display (r, NEXT (p), fields);
+    }
+}
+
+/* Mode check get specified moids.  */
+
+static void
+mode_check_get_specified_moids (NODE_T *p, MOID_T *u)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (a68_is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP))
+	mode_check_get_specified_moids (SUB (p), u);
+      else if (IS (p, SPECIFIER))
+	{
+	  MOID_T *m = MOID (NEXT_SUB (p));
+	  a68_add_mode_to_pack (&(PACK (u)), m, NO_TEXT, NODE (m));
+	}
+    }
+}
+
+/* Mode check specified unit list.  */
+
+void
+mode_check_specified_unit_list (SOID_T **r, NODE_T *p, SOID_T *x, MOID_T *u)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (a68_is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP))
+	mode_check_specified_unit_list (r, SUB (p), x, u);
+      else if (IS (p, SPECIFIER))
+	{
+	  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);
+
+	}
+      else if (IS (p, UNIT))
+	{
+	  SOID_T y;
+	  mode_check_unit (p, x, &y);
+	  a68_add_to_soid_list (r, p, &y);
+	}
+    }
+}
+
+/* Mode check united case parts.  */
+
+static void
+mode_check_united_case_parts (SOID_T **ry, NODE_T *p, SOID_T *x)
+{
+  SOID_T enq_expct, enq_yield;
+  MOID_T *u = NO_MOID, *v = NO_MOID, *w = NO_MOID;
+  /* Check the CASE part and deduce the united mode.  */
+  a68_make_soid (&enq_expct, MEEK, NO_MOID, 0);
+  mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
+  /* Deduce the united mode from the enquiry clause.
+     This requires balancing.  */
+  u = MOID (&enq_yield);
+  a68_absorb_series_pack (&u);
+  DIM (u) = a68_count_pack_members (PACK (u));
+  if (DIM (u) == 1)
+    u = MOID (PACK (u));
+  else
+    {
+      MOID_T *united, *balanced;
+      united = a68_make_united_mode (u);
+      balanced = a68_get_balanced_mode_or_no_mode (united,
+						   STRONG, A68_NO_DEPREF,
+						   SAFE_DEFLEXING);
+      if (balanced != NO_MOID)
+	u = balanced;
+    }
+  u = a68_depref_completely (u);
+  /* Also deduce the united mode from the specifiers.  */
+  v = a68_new_moid ();
+  ATTRIBUTE (v) = SERIES_MODE;
+  mode_check_get_specified_moids (NEXT_SUB (NEXT (p)), v);
+  v = a68_make_united_mode (v);
+  /* Determine a resulting union.  */
+  if (u == M_HIP)
+    w = v;
+  else
+    {
+      if (IS (u, UNION_SYMBOL))
+	{
+	  bool uv, vu, some;
+	  a68_investigate_firm_relations (PACK (u), PACK (v), &uv, &some);
+	  a68_investigate_firm_relations (PACK (v), PACK (u), &vu, &some);
+	  if (uv && vu)
+	    {
+	      /* Every component has a specifier.  */
+	      w = u;
+	    }
+	  else if (!uv && !vu)
+	    {
+	      /* Hmmmm ... let the coercer sort it out.  */
+	      w = u;
+	    }
+	  else
+	    {
+	      /* This is all the balancing we allow here for the moment. Firmly
+		 related subsets are not valid so we absorb them. If this
+		 doesn't solve it then we get a coercion-error later. */
+	      w = a68_absorb_related_subsets (u);
+	    }
+	}
+      else
+	{
+	  a68_error (NEXT_SUB (p), "M is not a united mode", u);
+	  return;
+	}
+    }
+  MOID (SUB (p)) = w;
+  FORWARD (p);
+  /* Check the IN part.  */
+  mode_check_specified_unit_list (ry, NEXT_SUB (p), x, w);
+  /* OUSE, OUT, ESAC.  */
+  if ((FORWARD (p)) != NO_NODE)
+    {
+      if (a68_is_one_of (p, OUT_PART, CHOICE, STOP))
+	mode_check_serial (ry, NEXT_SUB (p), x, true);
+      else if (a68_is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP))
+	mode_check_united_case_parts (ry, SUB (p), x);
+    }
+}
+
+/* Mode check united case.  */
+
+static void
+mode_check_united_case (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  SOID_T *top_sl = NO_SOID;
+
+  mode_check_united_case_parts (&top_sl, p, x);
+  if (!a68_is_balanced (p, top_sl, SORT (x)))
+    {
+      if (MOID (x) != NO_MOID)
+	a68_make_soid (y, SORT (x), MOID (x), CONFORMITY_CLAUSE);
+      else
+	a68_make_soid (y, SORT (x), M_ERROR, 0);
+    }
+  else
+    {
+      MOID_T *z = a68_pack_soids_in_moid (top_sl, SERIES_MODE);
+      a68_make_soid (y, SORT (x), z, CONFORMITY_CLAUSE);
+    }
+  a68_free_soid_list (top_sl);
+}
+
+/* Mode check unit list 2.  */
+
+static void
+mode_check_unit_list_2 (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  SOID_T *top_sl = NO_SOID;
+
+  if (MOID (x) != NO_MOID)
+    {
+      if (IS_FLEX (MOID (x)))
+	{
+	  SOID_T y2;
+	  a68_make_soid (&y2, SORT (x), SLICE (SUB_MOID (x)), 0);
+	  mode_check_unit_list (&top_sl, SUB (p), &y2);
+	}
+      else if (IS_ROW (MOID (x)))
+	{
+	  SOID_T y2;
+	  a68_make_soid (&y2, SORT (x), SLICE (MOID (x)), 0);
+	  mode_check_unit_list (&top_sl, SUB (p), &y2);
+	}
+      else if (IS (MOID (x), STRUCT_SYMBOL))
+	{
+	  PACK_T *y2 = PACK (MOID (x));
+	  mode_check_struct_display (&top_sl, SUB (p), &y2);
+	}
+      else
+	mode_check_unit_list (&top_sl, SUB (p), x);
+    }
+  else
+    mode_check_unit_list (&top_sl, SUB (p), x);
+
+  a68_make_soid (y, STRONG, a68_pack_soids_in_moid (top_sl, STOWED_MODE), 0);
+  a68_free_soid_list (top_sl);
+}
+
+/* Mode check closed.  */
+
+static void
+mode_check_closed (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, SERIAL_CLAUSE))
+    mode_check_serial_units (p, x, y, SERIAL_CLAUSE);
+  else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP))
+    mode_check_closed (NEXT (p), x, y);
+  MOID (p) = MOID (y);
+}
+
+/* Mode check collateral.  */
+
+void
+mode_check_collateral (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  if (p == NO_NODE)
+    return;
+  else if (a68_whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP)
+	   || a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP))
+    {
+      if (SORT (x) == STRONG)
+	{
+	  if (MOID (x) == NO_MOID)
+	    a68_error (p, "vacuum cannot have row elements (use a Y generator)",
+		       "REF MODE");
+	  else
+	    a68_make_soid (y, STRONG, M_VACUUM, 0);
+	}
+      else
+	a68_make_soid (y, STRONG, M_UNDEFINED, 0);
+    }
+  else
+    {
+      if (IS (p, UNIT_LIST))
+	mode_check_unit_list_2 (p, x, y);
+      else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP))
+	mode_check_collateral (NEXT (p), x, y);
+      MOID (p) = MOID (y);
+    }
+}
+
+/* Mode check conditional 2.  */
+
+static void
+mode_check_conditional_2 (SOID_T **ry, NODE_T *p, SOID_T *x)
+{
+  SOID_T enq_expct, enq_yield;
+
+  a68_make_soid (&enq_expct, MEEK, M_BOOL, 0);
+  mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
+  if (!a68_is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING))
+    a68_cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
+  FORWARD (p);
+  mode_check_serial (ry, NEXT_SUB (p), x, true);
+  if ((FORWARD (p)) != NO_NODE)
+    {
+      if (a68_is_one_of (p, ELSE_PART, CHOICE, STOP))
+	mode_check_serial (ry, NEXT_SUB (p), x, true);
+      else if (a68_is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP))
+	mode_check_conditional_2 (ry, SUB (p), x);
+    }
+}
+
+/* Mode check conditional.  */
+
+static void
+mode_check_conditional (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  SOID_T *top_sl = NO_SOID;
+  mode_check_conditional_2 (&top_sl, p, x);
+  if (!a68_is_balanced (p, top_sl, SORT (x)))
+    {
+      if (MOID (x) != NO_MOID)
+	a68_make_soid (y, SORT (x), MOID (x), CONDITIONAL_CLAUSE);
+      else
+	a68_make_soid (y, SORT (x), M_ERROR, 0);
+    }
+  else
+    {
+      MOID_T *z = a68_pack_soids_in_moid (top_sl, SERIES_MODE);
+      a68_make_soid (y, SORT (x), z, CONDITIONAL_CLAUSE);
+    }
+  a68_free_soid_list (top_sl);
+}
+
+/* Mode check int case 2.  */
+
+static void
+mode_check_int_case_2 (SOID_T **ry, NODE_T *p, SOID_T *x)
+{
+  SOID_T enq_expct, enq_yield;
+  a68_make_soid (&enq_expct, MEEK, M_INT, 0);
+  mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
+  if (!a68_is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING))
+    a68_cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
+  FORWARD (p);
+  mode_check_unit_list (ry, NEXT_SUB (p), x);
+  if ((FORWARD (p)) != NO_NODE)
+    {
+      if (a68_is_one_of (p, OUT_PART, CHOICE, STOP))
+	mode_check_serial (ry, NEXT_SUB (p), x, true);
+      else if (a68_is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP))
+	mode_check_int_case_2 (ry, SUB (p), x);
+    }
+}
+
+/* Mode check int case.  */
+
+static void
+mode_check_int_case (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  SOID_T *top_sl = NO_SOID;
+  mode_check_int_case_2 (&top_sl, p, x);
+  if (!a68_is_balanced (p, top_sl, SORT (x)))
+    {
+      if (MOID (x) != NO_MOID)
+	a68_make_soid (y, SORT (x), MOID (x), CASE_CLAUSE);
+      else
+	a68_make_soid (y, SORT (x), M_ERROR, 0);
+    }
+  else
+    {
+      MOID_T *z = a68_pack_soids_in_moid (top_sl, SERIES_MODE);
+      a68_make_soid (y, SORT (x), z, CASE_CLAUSE);
+    }
+  a68_free_soid_list (top_sl);
+}
+
+/* Mode check loop 2.  */
+
+static void
+mode_check_loop_2 (NODE_T *p, SOID_T *y)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, FOR_PART))
+    mode_check_loop_2 (NEXT (p), y);
+  else if (a68_is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP))
+    {
+      SOID_T ix, iy;
+      a68_make_soid (&ix, STRONG, M_INT, 0);
+      mode_check_unit (NEXT_SUB (p), &ix, &iy);
+      if (!a68_is_coercible_in_context (&iy, &ix, SAFE_DEFLEXING))
+	a68_cannot_coerce (NEXT_SUB (p), MOID (&iy), M_INT, MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
+      mode_check_loop_2 (NEXT (p), y);
+    }
+  else if (IS (p, WHILE_PART))
+    {
+      SOID_T enq_expct, enq_yield;
+      a68_make_soid (&enq_expct, MEEK, M_BOOL, 0);
+      mode_check_serial_units (NEXT_SUB (p), &enq_expct, &enq_yield, ENQUIRY_CLAUSE);
+      if (!a68_is_coercible_in_context (&enq_yield, &enq_expct, SAFE_DEFLEXING))
+	a68_cannot_coerce (p, MOID (&enq_yield), MOID (&enq_expct), MEEK, SAFE_DEFLEXING, ENQUIRY_CLAUSE);
+      mode_check_loop_2 (NEXT (p), y);
+    }
+  else if (a68_is_one_of (p, DO_PART, ALT_DO_PART, STOP))
+    {
+      SOID_T *z = NO_SOID;
+      NODE_T *do_p = NEXT_SUB (p);
+      SOID_T ix;
+      a68_make_soid (&ix, STRONG, M_VOID, 0);
+      if (IS (do_p, SERIAL_CLAUSE))
+	mode_check_serial (&z, do_p, &ix, true);
+      a68_free_soid_list (z);
+    }
+}
+
+/* Mode check loop.  */
+
+static void
+mode_check_loop (NODE_T *p, SOID_T *y)
+{
+  SOID_T *z = NO_SOID;
+  mode_check_loop_2 (p, z);
+  a68_make_soid (y, STRONG, M_VOID, 0);
+}
+
+/* Mode check enclosed.  */
+
+static void
+mode_check_enclosed (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, ENCLOSED_CLAUSE))
+    mode_check_enclosed (SUB (p), x, y);
+  else if (IS (p, CLOSED_CLAUSE))
+    mode_check_closed (SUB (p), x, y);
+  else if (IS (p, PARALLEL_CLAUSE))
+    {
+      mode_check_collateral (SUB (NEXT_SUB (p)), x, y);
+      a68_make_soid (y, STRONG, M_VOID, 0);
+      MOID (NEXT_SUB (p)) = M_VOID;
+    }
+  else if (IS (p, COLLATERAL_CLAUSE))
+    mode_check_collateral (SUB (p), x, y);
+  else if (IS (p, CONDITIONAL_CLAUSE))
+    mode_check_conditional (SUB (p), x, y);
+  else if (IS (p, CASE_CLAUSE))
+    mode_check_int_case (SUB (p), x, y);
+  else if (IS (p, CONFORMITY_CLAUSE))
+    mode_check_united_case (SUB (p), x, y);
+  else if (IS (p, LOOP_CLAUSE))
+    mode_check_loop (SUB (p), y);
+
+  MOID (p) = MOID (y);
+}
+
+/* Search table for operator.  */
+
+static TAG_T *
+search_table_for_operator (TAG_T *t, const char *n, MOID_T *x, MOID_T *y)
+{
+  if (a68_is_mode_isnt_well (x))
+    return A68_PARSER (error_tag);
+  else if (y != NO_MOID && a68_is_mode_isnt_well (y))
+    return A68_PARSER (error_tag);
+
+  for (; t != NO_TAG; FORWARD (t))
+    {
+      if (NSYMBOL (NODE (t)) == n)
+	{
+	  PACK_T *p = PACK (MOID (t));
+	  if (a68_is_coercible (x, MOID (p), FIRM, ALIAS_DEFLEXING))
+	    {
+	      FORWARD (p);
+	      if (p == NO_PACK && y == NO_MOID)
+		/* Matched in case of a monadic.  */
+		return t;
+	      else if (p != NO_PACK && y != NO_MOID
+		       && a68_is_coercible (y, MOID (p), FIRM, ALIAS_DEFLEXING))
+		/* Matched in case of a dyadic.  */
+		return t;
+	    }
+	}
+    }
+  return NO_TAG;
+}
+
+/* Search chain of symbol tables and return matching operator "x n y" or
+   "n x".  */
+
+static TAG_T *
+search_table_chain_for_operator (TABLE_T *s, const char *n, MOID_T *x, MOID_T *y)
+{
+  if (a68_is_mode_isnt_well (x))
+    return A68_PARSER (error_tag);
+  else if (y != NO_MOID && a68_is_mode_isnt_well (y))
+    return A68_PARSER (error_tag);
+
+  while (s != NO_TABLE)
+    {
+      TAG_T *z = search_table_for_operator (OPERATORS (s), n, x, y);
+      if (z != NO_TAG)
+	return z;
+      BACKWARD (s);
+    }
+  return NO_TAG;
+}
+
+/* Return a matching operator "x n y".  */
+
+static TAG_T *
+find_operator (TABLE_T *s, const char *n, MOID_T *x, MOID_T *y)
+{
+  /* Coercions to operand modes are FIRM.  */
+  MOID_T *u, *v; TAG_T *z;
+  /* (A) Catch exceptions first.  */
+  if (x == NO_MOID && y == NO_MOID)
+    return NO_TAG;
+  else if (a68_is_mode_isnt_well (x))
+    return A68_PARSER (error_tag);
+  else if (y != NO_MOID && a68_is_mode_isnt_well (y))
+    return A68_PARSER (error_tag);
+
+  /* (B) MONADs.  */
+  if (x != NO_MOID && y == NO_MOID)
+    {
+      z = search_table_chain_for_operator (s, n, x, NO_MOID);
+      if (z != NO_TAG)
+	return z;
+      else
+	{
+	  /* (B.2) A little trick to allow - (0, 1) or ABS (1, long pi).  */
+	  if (a68_is_coercible (x, M_COMPLEX, STRONG, SAFE_DEFLEXING))
+	    {
+	      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, NO_MOID);
+	      if (z != NO_TAG)
+		return z;
+	    }
+	  if (a68_is_coercible (x, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING))
+	    {
+	      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, NO_MOID);
+	      if (z != NO_TAG)
+		return z;
+	    }
+	  if (a68_is_coercible (x, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING))
+	    z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, NO_MOID);
+	}
+      return NO_TAG;
+    }
+  /* (C) DYADs.  */
+  z = search_table_chain_for_operator (s, n, x, y);
+  if (z != NO_TAG)
+    return z;
+  /* (C.2) Vector and matrix "strong coercions" in standard environ.  */
+  u = DEFLEX (a68_depref_completely (x));
+  v = DEFLEX (a68_depref_completely (y));
+  if ((u == M_ROW_REAL || u == M_ROW_ROW_REAL)
+      || (v == M_ROW_REAL || v == M_ROW_ROW_REAL)
+      || (u == M_ROW_COMPLEX || u == M_ROW_ROW_COMPLEX)
+      || (v == M_ROW_COMPLEX || v == M_ROW_ROW_COMPLEX))
+    {
+      if (u == M_INT)
+	{
+	  z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, y);
+	  if (z != NO_TAG)
+	    return z;
+	  z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y);
+	  if (z != NO_TAG)
+	    return z;
+	}
+      else if (v == M_INT)
+	{
+	  z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_REAL);
+	  if (z != NO_TAG)
+	    return z;
+	  z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX);
+	  if (z != NO_TAG)
+	    return z;
+	}
+      else if (u == M_REAL)
+	{
+	  z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, y);
+	  if (z != NO_TAG)
+	    return z;
+	}
+      else if (v == M_REAL)
+	{
+	  z = search_table_for_operator (OPERATORS (A68_STANDENV), n, x, M_COMPLEX);
+	  if (z != NO_TAG)
+	    return z;
+	}
+    }
+  /* (C.3) Look in standenv for an appropriate cross-term.  */
+  u = a68_make_series_from_moids (x, y);
+  u = a68_make_united_mode (u);
+  v = a68_get_balanced_mode (u, STRONG, A68_NO_DEPREF, SAFE_DEFLEXING);
+  z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v);
+  if (z != NO_TAG)
+    return z;
+  if (a68_is_coercible_series (u, M_REAL, STRONG, SAFE_DEFLEXING))
+    {
+      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_REAL, M_REAL);
+      if (z != NO_TAG)
+	return z;
+    }
+  if (a68_is_coercible_series (u, M_LONG_REAL, STRONG, SAFE_DEFLEXING))
+    {
+      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_REAL, M_LONG_REAL);
+      if (z != NO_TAG)
+	return z;
+    }
+  if (a68_is_coercible_series (u, M_LONG_LONG_REAL, STRONG, SAFE_DEFLEXING))
+    {
+      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_REAL, M_LONG_LONG_REAL);
+      if (z != NO_TAG)
+	return z;
+    }
+  if (a68_is_coercible_series (u, M_COMPLEX, STRONG, SAFE_DEFLEXING))
+    {
+      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_COMPLEX, M_COMPLEX);
+      if (z != NO_TAG)
+	return z;
+    }
+  if (a68_is_coercible_series (u, M_LONG_COMPLEX, STRONG, SAFE_DEFLEXING))
+    {
+      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_COMPLEX, M_LONG_COMPLEX);
+      if (z != NO_TAG)
+	return z;
+    }
+  if (a68_is_coercible_series (u, M_LONG_LONG_COMPLEX, STRONG, SAFE_DEFLEXING))
+    {
+      z = search_table_for_operator (OPERATORS (A68_STANDENV), n, M_LONG_LONG_COMPLEX, M_LONG_LONG_COMPLEX);
+      if (z != NO_TAG)
+	return z;
+    }
+  /* (C.4) Now allow for depreffing for REF REAL +:= INT and alike.  */
+  v = a68_get_balanced_mode (u, STRONG, A68_DEPREF, SAFE_DEFLEXING);
+  z = search_table_for_operator (OPERATORS (A68_STANDENV), n, v, v);
+  if (z != NO_TAG)
+    return z;
+  return NO_TAG;
+}
+
+/* Mode check monadic operator.  */
+
+static void
+mode_check_monadic_operator (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  if (p != NO_NODE)
+    {
+      TAG_T *t;
+      MOID_T *u = a68_determine_unique_mode (y, SAFE_DEFLEXING);
+      if (a68_is_mode_isnt_well (u))
+	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_make_soid (y, SORT (x), M_ERROR, 0);
+	}
+      else
+	{
+	  if (strchr (NOMADS, *(NSYMBOL (p))) != NO_TEXT)
+	    {
+	      t = NO_TAG;
+	      a68_error (p, "monadic S cannot start with a character from Z", NOMADS);
+	      a68_make_soid (y, SORT (x), M_ERROR, 0);
+	    }
+	  else
+	    {
+	      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_make_soid (y, SORT (x), M_ERROR, 0);
+		}
+	    }
+	  if (t != NO_TAG)
+	    MOID (p) = MOID (t);
+	  TAX (p) = t;
+	  if (t != NO_TAG && t != A68_PARSER (error_tag))
+	    {
+	      MOID (p) = MOID (t);
+	      a68_make_soid (y, SORT (x), SUB_MOID (t), 0);
+	    }
+	  else
+	    {
+	      MOID (p) = M_ERROR;
+	      a68_make_soid (y, SORT (x), M_ERROR, 0);
+	    }
+	}
+    }
+}
+
+/* Mode check monadic formula.  */
+
+static void
+mode_check_monadic_formula (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  SOID_T e;
+  a68_make_soid (&e, FIRM, NO_MOID, 0);
+  mode_check_formula (NEXT (p), &e, y);
+  mode_check_monadic_operator (p, &e, y);
+  a68_make_soid (y, SORT (x), MOID (y), 0);
+}
+
+/* Mode check formula.  */
+
+static void
+mode_check_formula (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  SOID_T ls;
+  if (IS (p, MONADIC_FORMULA))
+    mode_check_monadic_formula (SUB (p), x, &ls);
+  else if (IS (p, FORMULA))
+    mode_check_formula (SUB (p), x, &ls);
+  else if (IS (p, SECONDARY))
+    {
+      SOID_T e;
+      a68_make_soid (&e, FIRM, NO_MOID, 0);
+      mode_check_unit (SUB (p), &e, &ls);
+    }
+  MOID_T *u = a68_determine_unique_mode (&ls, SAFE_DEFLEXING);
+  MOID (p) = u;
+  SOID_T rs;
+  if (NEXT (p) == NO_NODE)
+    a68_make_soid (y, SORT (x), u, 0);
+  else
+    {
+      NODE_T *q = NEXT_NEXT (p);
+      if (IS (q, MONADIC_FORMULA))
+	mode_check_monadic_formula (SUB (NEXT_NEXT (p)), x, &rs);
+      else if (IS (q, FORMULA))
+	mode_check_formula (SUB (NEXT_NEXT (p)), x, &rs);
+      else if (IS (q, SECONDARY))
+	{
+	  SOID_T e;
+	  a68_make_soid (&e, FIRM, NO_MOID, 0);
+	  mode_check_unit (SUB (q), &e, &rs);
+	}
+      MOID_T *v = a68_determine_unique_mode (&rs, SAFE_DEFLEXING);
+      MOID (q) = v;
+      if (a68_is_mode_isnt_well (u) || a68_is_mode_isnt_well (v))
+	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_make_soid (y, SORT (x), M_ERROR, 0);
+	}
+      else if (v == M_HIP)
+	{
+	  a68_error (q, "M construct is an invalid operand", u);
+	  a68_make_soid (y, SORT (x), M_ERROR, 0);
+	}
+      else
+	{
+	  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_make_soid (y, SORT (x), M_ERROR, 0);
+	    }
+	  if (op != NO_TAG)
+	    MOID (NEXT (p)) = MOID (op);
+	  TAX (NEXT (p)) = op;
+	  if (op != NO_TAG && op != A68_PARSER (error_tag))
+	    a68_make_soid (y, SORT (x), SUB_MOID (op), 0);
+	  else
+	    a68_make_soid (y, SORT (x), M_ERROR, 0);
+	}
+    }
+}
+
+/* Mode check assignation.  */
+
+static void
+mode_check_assignation (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  /* Get destination mode.  */
+  SOID_T name, tmp, value;
+  a68_make_soid (&name, SOFT, NO_MOID, 0);
+  mode_check_unit (SUB (p), &name, &tmp);
+  /* SOFT coercion.  */
+  MOID_T *ori = a68_determine_unique_mode (&tmp, SAFE_DEFLEXING);
+  MOID_T *name_moid = a68_deproc_completely (ori);
+  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_make_soid (y, SORT (x), M_ERROR, 0);
+      return;
+    }
+  MOID (p) = name_moid;
+  /* Get source mode.  */
+  a68_make_soid (&name, STRONG, SUB (name_moid), 0);
+  mode_check_unit (NEXT_NEXT (p), &name, &value);
+  if (!a68_is_coercible_in_context (&value, &name, FORCE_DEFLEXING))
+    {
+      a68_cannot_coerce (p, MOID (&value), MOID (&name), STRONG, FORCE_DEFLEXING, UNIT);
+      a68_make_soid (y, SORT (x), M_ERROR, 0);
+    }
+  else
+    a68_make_soid (y, SORT (x), name_moid, 0);
+}
+
+/* Mode check identity relation.  */
+
+static void
+mode_check_identity_relation (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  NODE_T *ln = p, *rn = NEXT_NEXT (p);
+  SOID_T e, l, r;
+  a68_make_soid (&e, SOFT, NO_MOID, 0);
+  mode_check_unit (SUB (ln), &e, &l);
+  mode_check_unit (SUB (rn), &e, &r);
+  /* SOFT coercion.  */
+  MOID_T *oril = a68_determine_unique_mode (&l, SAFE_DEFLEXING);
+  MOID_T *orir = a68_determine_unique_mode (&r, SAFE_DEFLEXING);
+  MOID_T *lhs = a68_deproc_completely (oril);
+  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)));
+      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)));
+      rhs = M_ERROR;
+    }
+  if (lhs == M_HIP && rhs == M_HIP)
+    a68_error (p, "construct has no unique mode");
+
+  if (a68_is_coercible (lhs, rhs, STRONG, SAFE_DEFLEXING))
+    lhs = rhs;
+  else if (a68_is_coercible (rhs, lhs, STRONG, SAFE_DEFLEXING))
+    rhs = lhs;
+  else
+    {
+      a68_cannot_coerce (NEXT (p), rhs, lhs, SOFT, SKIP_DEFLEXING, TERTIARY);
+      lhs = rhs = M_ERROR;
+    }
+  MOID (ln) = lhs;
+  MOID (rn) = rhs;
+  a68_make_soid (y, SORT (x), M_BOOL, 0);
+}
+
+/* Mode check bool functions ANDF and ORF.  */
+
+static void
+mode_check_bool_function (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  SOID_T e, l, r;
+  NODE_T *ln = p, *rn = NEXT_NEXT (p);
+  a68_make_soid (&e, STRONG, M_BOOL, 0);
+  mode_check_unit (SUB (ln), &e, &l);
+  if (!a68_is_coercible_in_context (&l, &e, SAFE_DEFLEXING))
+    a68_cannot_coerce (ln, MOID (&l), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY);
+  mode_check_unit (SUB (rn), &e, &r);
+  if (!a68_is_coercible_in_context (&r, &e, SAFE_DEFLEXING))
+    a68_cannot_coerce (rn, MOID (&r), MOID (&e), MEEK, SAFE_DEFLEXING, TERTIARY);
+  MOID (ln) = M_BOOL;
+  MOID (rn) = M_BOOL;
+  a68_make_soid (y, SORT (x), M_BOOL, 0);
+}
+
+/* Mode check cast.  */
+
+static void
+mode_check_cast (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  SOID_T w;
+  mode_check_declarer (p);
+  a68_make_soid (&w, STRONG, MOID (p), 0);
+  CAST (&w) = true;
+  mode_check_enclosed (SUB_NEXT (p), &w, y);
+  if (!a68_is_coercible_in_context (y, &w, SAFE_DEFLEXING))
+    a68_cannot_coerce (NEXT (p), MOID (y), MOID (&w), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
+  a68_make_soid (y, SORT (x), MOID (p), 0);
+}
+
+/* Mode check assertion.  */
+
+static void
+mode_check_assertion (NODE_T *p)
+{
+  SOID_T w, y;
+  a68_make_soid (&w, STRONG, M_BOOL, 0);
+  mode_check_enclosed (SUB_NEXT (p), &w, &y);
+  SORT (&y) = SORT (&w);
+  if (!a68_is_coercible_in_context (&y, &w, NO_DEFLEXING))
+    a68_cannot_coerce (NEXT (p), MOID (&y), MOID (&w), MEEK, NO_DEFLEXING, ENCLOSED_CLAUSE);
+}
+
+/* Mode check argument list.  */
+
+static void
+mode_check_argument_list (SOID_T **r, NODE_T *p, PACK_T **x, PACK_T **v, PACK_T **w)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, GENERIC_ARGUMENT_LIST))
+	ATTRIBUTE (p) = ARGUMENT_LIST;
+
+      if (IS (p, ARGUMENT_LIST))
+	mode_check_argument_list (r, SUB (p), x, v, w);
+      else if (IS (p, UNIT))
+	{
+	  SOID_T y, z;
+	  if (*x != NO_PACK)
+	    {
+	      a68_make_soid (&z, STRONG, MOID (*x), 0);
+	      a68_add_mode_to_pack_end (v, MOID (*x), NO_TEXT, p);
+	      FORWARD (*x);
+	    }
+	  else
+	    a68_make_soid (&z, STRONG, NO_MOID, 0);
+	  mode_check_unit (p, &z, &y);
+	  a68_add_to_soid_list (r, p, &y);
+	}
+      else if (IS (p, TRIMMER))
+	{
+	  SOID_T z;
+	  if (SUB (p) != NO_NODE)
+	    {
+	      a68_error (p, "syntax error detected in A", ARGUMENT);
+	      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);
+	      FORWARD (*x);
+	    }
+	  else if (*x != NO_PACK)
+	    {
+	      a68_make_soid (&z, STRONG, MOID (*x), 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);
+	      FORWARD (*x);
+	    }
+	  else
+	    a68_make_soid (&z, STRONG, NO_MOID, 0);
+	  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);
+    }
+}
+
+/* Mode check argument list 2.  */
+
+static void
+mode_check_argument_list_2 (NODE_T *p, PACK_T *x, SOID_T *y, PACK_T **v, PACK_T **w)
+{
+  SOID_T *top_sl = NO_SOID;
+  mode_check_argument_list (&top_sl, SUB (p), &x, v, w);
+  a68_make_soid (y, STRONG, a68_pack_soids_in_moid (top_sl, STOWED_MODE), 0);
+  a68_free_soid_list (top_sl);
+}
+
+/* Mode check meek int.  */
+
+static void
+mode_check_meek_int (NODE_T *p)
+{
+  SOID_T x, y;
+  a68_make_soid (&x, MEEK, M_INT, 0);
+  mode_check_unit (p, &x, &y);
+  if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+    a68_cannot_coerce (p, MOID (&y), MOID (&x), MEEK, SAFE_DEFLEXING, 0);
+}
+
+/* Mode check trimmer.  */
+
+static void
+mode_check_trimmer (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, TRIMMER))
+    mode_check_trimmer (SUB (p));
+  else if (IS (p, UNIT))
+    {
+      mode_check_meek_int (p);
+      mode_check_trimmer (NEXT (p));
+    }
+  else
+    mode_check_trimmer (NEXT (p));
+}
+
+/* Mode check indexer.  */
+
+static void
+mode_check_indexer (NODE_T *p, int *subs, int *trims)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, TRIMMER))
+    {
+      (*trims)++;
+      mode_check_trimmer (SUB (p));
+    }
+  else if (IS (p, UNIT))
+    {
+      (*subs)++;
+      mode_check_meek_int (p);
+    }
+  else
+    {
+      mode_check_indexer (SUB (p), subs, trims);
+      mode_check_indexer (NEXT (p), subs, trims);
+    }
+}
+
+/* Mode check call.  */
+
+static void
+mode_check_call (NODE_T *p, MOID_T *n, SOID_T *x, SOID_T *y)
+{
+  MOID (p) = n;
+  /* "partial_locale" is the mode of the locale.  */
+  PARTIAL_LOCALE (GINFO (p)) = a68_new_moid ();
+  ATTRIBUTE (PARTIAL_LOCALE (GINFO (p))) = PROC_SYMBOL;
+  PACK (PARTIAL_LOCALE (GINFO (p))) = NO_PACK;
+  SUB (PARTIAL_LOCALE (GINFO (p))) = SUB (n);
+  /* "partial_proc" is the mode of the resulting proc.  */
+  PARTIAL_PROC (GINFO (p)) = a68_new_moid ();
+  ATTRIBUTE (PARTIAL_PROC (GINFO (p))) = PROC_SYMBOL;
+  PACK (PARTIAL_PROC (GINFO (p))) = NO_PACK;
+  SUB (PARTIAL_PROC (GINFO (p))) = SUB (n);
+  /* Check arguments and construct modes.  */
+  SOID_T d;
+  mode_check_argument_list_2 (NEXT (p), PACK (n), &d, &PACK (PARTIAL_LOCALE (GINFO (p))),
+			      &PACK (PARTIAL_PROC (GINFO (p))));
+  DIM (PARTIAL_PROC (GINFO (p))) = a68_count_pack_members (PACK (PARTIAL_PROC (GINFO (p))));
+  DIM (PARTIAL_LOCALE (GINFO (p))) = a68_count_pack_members (PACK (PARTIAL_LOCALE (GINFO (p))));
+  PARTIAL_PROC (GINFO (p)) = a68_register_extra_mode (&TOP_MOID (&A68_JOB), PARTIAL_PROC (GINFO (p)));
+  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_make_soid (y, SORT (x), SUB (n), 0);
+      /*  a68_make_soid (y, SORT (x), M_ERROR, 0);.  */
+    }
+  else
+    {
+      if (!a68_is_coercible (MOID (&d), n, STRONG, ALIAS_DEFLEXING))
+	a68_cannot_coerce (p, MOID (&d), n, STRONG, ALIAS_DEFLEXING, ARGUMENT);
+      if (DIM (PARTIAL_PROC (GINFO (p))) == 0)
+	a68_make_soid (y, SORT (x), SUB (n), 0);
+      else
+	{
+	  a68_warning (NEXT (p), OPT_Wextensions, "@ is an extension");
+	  a68_make_soid (y, SORT (x), PARTIAL_PROC (GINFO (p)), 0);
+	}
+    }
+}
+
+/* Mode check slice.  */
+
+static void
+mode_check_slice (NODE_T *p, MOID_T *ori, SOID_T *x, SOID_T *y)
+{
+  MOID_T *m = a68_depref_completely (ori), *n = ori;
+  /* WEAK coercion.  */
+  while ((IS_REF (n) && !a68_is_ref_row (n)) || (IS (n, PROC_SYMBOL) && PACK (n) == NO_PACK))
+    n = a68_depref_once (n);
+
+  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_make_soid (y, SORT (x), M_ERROR, 0);
+    }
+
+  MOID (p) = n;
+  int dim = 0, subs = 0, trims = 0;
+  mode_check_indexer (SUB_NEXT (p), &subs, &trims);
+  bool is_ref;
+  if ((is_ref = a68_is_ref_row (n)) != 0)
+    dim = DIM (DEFLEX (SUB (n)));
+  else
+    dim = DIM (DEFLEX (n));
+
+  if ((subs + trims) != dim)
+    {
+      a68_error (p, "incorrect number of indexers for M", n);
+      a68_make_soid (y, SORT (x), M_ERROR, 0);
+    }
+  else
+    {
+      if (subs > 0 && trims == 0)
+	{
+	  ANNOTATION (NEXT (p)) = SLICE;
+	  m = n;
+	}
+      else
+	{
+	  ANNOTATION (NEXT (p)) = TRIMMER;
+	  m = n;
+	}
+      while (subs > 0)
+	{
+	  if (is_ref)
+	    m = NAME (m);
+	  else
+	    {
+	      if (IS_FLEX (m))
+		m = SUB (m);
+	      m = SLICE (m);
+	    }
+	  gcc_assert (m != NO_MOID);
+	  subs--;
+	}
+      /* A trim cannot be but deflexed.  */
+      if (ANNOTATION (NEXT (p)) == TRIMMER && TRIM (m) != NO_MOID)
+	{
+	  gcc_assert (TRIM (m) != NO_MOID);
+	  a68_make_soid (y, SORT (x), TRIM (m), 0);
+	}
+      else
+	a68_make_soid (y, SORT (x), m, 0);
+    }
+}
+
+/* Mode check specification.  */
+
+static enum a68_attribute
+mode_check_specification (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  SOID_T w, d;
+  a68_make_soid (&w, WEAK, NO_MOID, 0);
+  mode_check_unit (SUB (p), &w, &d);
+  MOID_T *ori = a68_determine_unique_mode (&d, SAFE_DEFLEXING);
+  MOID_T *m = a68_depref_completely (ori);
+  if (IS (m, PROC_SYMBOL))
+    {
+      /* Assume CALL.  */
+      mode_check_call (p, m, x, y);
+      return CALL;
+    }
+  else if (IS_ROW (m) || IS_FLEX (m))
+    {
+      /* Assume SLICE.  */
+      mode_check_slice (p, ori, x, y);
+      return SLICE;
+    }
+  else
+    {
+      if (m != M_ERROR)
+	a68_error (p, "M construct must yield a routine or a row value", m);
+      a68_make_soid (y, SORT (x), M_ERROR, 0);
+      return PRIMARY;
+    }
+}
+
+/* Mode check selection.  */
+
+static void
+mode_check_selection (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  bool deflex = false;
+  NODE_T *secondary = SUB_NEXT (p);
+  SOID_T w, d;
+  a68_make_soid (&w, WEAK, NO_MOID, 0);
+  mode_check_unit (secondary, &w, &d);
+  MOID_T *n, *ori;
+  n = ori = a68_determine_unique_mode (&d, SAFE_DEFLEXING);
+  PACK_T *t = NO_PACK, *t_2 = NO_PACK;
+  bool coerce = true;
+  while (coerce)
+    {
+      if (IS (n, STRUCT_SYMBOL))
+	{
+	  coerce = false;
+	  t = PACK (n);
+	}
+      else if (IS_REF (n) && (IS_ROW (SUB (n)) || IS_FLEX (SUB (n))) && MULTIPLE (n) != NO_MOID)
+	{
+	  coerce = false;
+	  deflex = true;
+	  t = PACK (MULTIPLE (n));
+	}
+      else if ((IS_ROW (n) || IS_FLEX (n)) && MULTIPLE (n) != NO_MOID)
+	{
+	  coerce = false;
+	  deflex = true;
+	  t = PACK (MULTIPLE (n));
+	}
+      else if (IS_REF (n) && a68_is_name_struct (n))
+	{
+	  coerce = false;
+	  t = PACK (NAME (n));
+	}
+      else if (a68_is_deprefable (n))
+	{
+	  coerce = true;
+	  n = SUB (n);
+	  t = NO_PACK;
+	}
+      else
+	{
+	  coerce = false;
+	  t = NO_PACK;
+	}
+    }
+  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_make_soid (y, SORT (x), M_ERROR, 0);
+      return;
+    }
+
+  MOID (NEXT (p)) = n;
+  const char *fs = NSYMBOL (SUB (p));
+  MOID_T *str = n;
+  while (IS_REF (str))
+    str = SUB (str);
+  if (IS_FLEX (str))
+    str = SUB (str);
+  if (IS_ROW (str))
+    str = SUB (str);
+  t_2 = PACK (str);
+  while (t != NO_PACK && t_2 != NO_PACK)
+    {
+      if (TEXT (t) == fs)
+	{
+	  MOID_T *ret = MOID (t);
+	  if (deflex && TRIM (ret) != NO_MOID)
+	    ret = TRIM (ret);
+	  a68_make_soid (y, SORT (x), ret, 0);
+	  MOID (p) = ret;
+	  NODE_PACK (SUB (p)) = t_2;
+	  return;
+	}
+      FORWARD (t);
+      FORWARD (t_2);
+    }
+  a68_make_soid (&d, NO_SORT, n, 0);
+  a68_error (p, "M has no field Z", str, fs);
+  a68_make_soid (y, SORT (x), M_ERROR, 0);
+}
+
+/* Mode check format text.  */
+
+static void
+mode_check_format_text (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      mode_check_format_text (SUB (p));
+      if (IS (p, FORMAT_PATTERN))
+	{
+	  SOID_T x, y;
+	  a68_make_soid (&x, STRONG, M_FORMAT, 0);
+	  mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
+	  if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+	    a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
+	}
+      else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE)
+	{
+	  SOID_T x, y;
+	  a68_make_soid (&x, STRONG, M_ROW_INT, 0);
+	  mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
+	  if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+	    a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
+	}
+      else if (IS (p, DYNAMIC_REPLICATOR))
+	{
+	  SOID_T x, y;
+	  a68_make_soid (&x, STRONG, M_INT, 0);
+	  mode_check_enclosed (SUB (NEXT_SUB (p)), &x, &y);
+	  if (!a68_is_coercible_in_context (&y, &x, SAFE_DEFLEXING))
+	    a68_cannot_coerce (p, MOID (&y), MOID (&x), STRONG, SAFE_DEFLEXING, ENCLOSED_CLAUSE);
+	}
+    }
+}
+
+/* Mode check unit.  */
+
+static void
+mode_check_unit (NODE_T *p, SOID_T *x, SOID_T *y)
+{
+  if (p == NO_NODE)
+    return;
+  else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP))
+    mode_check_unit (SUB (p), x, y);
+  /* Ex primary.  */
+  else if (IS (p, SPECIFICATION))
+    {
+      ATTRIBUTE (p) = mode_check_specification (SUB (p), x, y);
+      a68_warn_for_voiding (p, x, y, ATTRIBUTE (p));
+    }
+  else if (IS (p, CAST))
+    {
+      mode_check_cast (SUB (p), x, y);
+      a68_warn_for_voiding (p, x, y, CAST);
+    }
+  else if (IS (p, DENOTATION))
+    {
+      a68_make_soid (y, SORT (x), MOID (SUB (p)), 0);
+      a68_warn_for_voiding (p, x, y, DENOTATION);
+    }
+  else if (IS (p, IDENTIFIER))
+    {
+      if ((TAX (p) == NO_TAG) && (MOID (p) == NO_MOID))
+	{
+	  int att = a68_first_tag_global (TABLE (p), NSYMBOL (p));
+	  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");
+	      MOID (p) = M_ERROR;
+	    }
+	  else
+	    {
+	      TAG_T *z = a68_find_tag_global (TABLE (p), att, NSYMBOL (p));
+	      if (att == IDENTIFIER && z != NO_TAG)
+		MOID (p) = MOID (z);
+	      else
+		{
+		  (void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
+		  a68_error (p, "tag S has not been declared properly");
+		  MOID (p) = M_ERROR;
+		}
+	    }
+	}
+      a68_make_soid (y, SORT (x), MOID (p), 0);
+      a68_warn_for_voiding (p, x, y, IDENTIFIER);
+    }
+  else if (IS (p, ENCLOSED_CLAUSE))
+    mode_check_enclosed (SUB (p), x, y);
+  else if (IS (p, FORMAT_TEXT))
+    {
+      mode_check_format_text (p);
+      a68_make_soid (y, SORT (x), M_FORMAT, 0);
+      a68_warn_for_voiding (p, x, y, FORMAT_TEXT);
+      /* Ex secondary.  */
+    }
+  else if (IS (p, GENERATOR))
+    {
+      mode_check_declarer (SUB (p));
+      a68_make_soid (y, SORT (x), MOID (SUB (p)), 0);
+      a68_warn_for_voiding (p, x, y, GENERATOR);
+    }
+  else if (IS (p, SELECTION))
+    {
+      mode_check_selection (SUB (p), x, y);
+      a68_warn_for_voiding (p, x, y, SELECTION);
+      /* Ex tertiary.  */
+    }
+  else if (IS (p, NIHIL))
+    a68_make_soid (y, STRONG, M_HIP, 0);
+  else if (IS (p, FORMULA))
+    {
+      mode_check_formula (p, x, y);
+      if (!IS_REF (MOID (y)))
+	a68_warn_for_voiding (p, x, y, FORMULA);
+    }
+  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_make_soid (y, STRONG, M_HIP, 0);  */
+      a68_make_soid (y, SORT (x), M_HIP, 0);
+    }
+  else if (IS (p, ASSIGNATION))
+    mode_check_assignation (SUB (p), x, y);
+  else if (IS (p, IDENTITY_RELATION))
+    {
+      mode_check_identity_relation (SUB (p), x, y);
+      a68_warn_for_voiding (p, x, y, IDENTITY_RELATION);
+    }
+  else if (IS (p, ROUTINE_TEXT))
+    {
+      mode_check_routine_text (SUB (p), y);
+      a68_make_soid (y, SORT (x), MOID (p), 0);
+      a68_warn_for_voiding (p, x, y, ROUTINE_TEXT);
+    }
+  else if (IS (p, ASSERTION))
+    {
+      mode_check_assertion (SUB (p));
+      a68_make_soid (y, STRONG, M_VOID, 0);
+    }
+  else if (IS (p, AND_FUNCTION))
+    {
+      mode_check_bool_function (SUB (p), x, y);
+      a68_warn_for_voiding (p, x, y, AND_FUNCTION);
+    }
+  else if (IS (p, OR_FUNCTION))
+    {
+      mode_check_bool_function (SUB (p), x, y);
+      a68_warn_for_voiding (p, x, y, OR_FUNCTION);
+    }
+
+  MOID (p) = MOID (y);
+}
diff --git a/gcc/algol68/a68-parser-moids-coerce.cc b/gcc/algol68/a68-parser-moids-coerce.cc
new file mode 100644
index 00000000000..15b2c1fb899
--- /dev/null
+++ b/gcc/algol68/a68-parser-moids-coerce.cc
@@ -0,0 +1,874 @@
+/* Mode coercion driver.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+#define A68_INSERT_COERCIONS(n, p, q) a68_make_strong ((n), (p), MOID (q))
+
+/* A few forward references of functions defined below.  */
+
+static void coerce_unit (NODE_T *p, SOID_T *q);
+static void coerce_formula (NODE_T *p, SOID_T *q __attribute__ ((unused)));
+static void coerce_operand (NODE_T *p, SOID_T *q);
+
+/* Coerce bounds.  */
+
+static void
+coerce_bounds (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, UNIT))
+	{
+	  SOID_T q;
+	  a68_make_soid (&q, MEEK, M_INT, 0);
+	  coerce_unit (p, &q);
+	}
+      else
+	coerce_bounds (SUB (p));
+    }
+}
+
+/* Coerce declarer.  */
+
+static void
+coerce_declarer (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, BOUNDS))
+	coerce_bounds (SUB (p));
+      else
+	coerce_declarer (SUB (p));
+    }
+}
+
+/* Coerce identity declaration.  */
+
+static void
+coerce_identity_declaration (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case DECLARER:
+	  coerce_declarer (SUB (p));
+	  coerce_identity_declaration (NEXT (p));
+        break;
+	case DEFINING_IDENTIFIER:
+	  {
+	    SOID_T q;
+	    a68_make_soid (&q, STRONG, MOID (p), 0);
+	    coerce_unit (NEXT_NEXT (p), &q);
+	    break;
+	  }
+	default:
+	  coerce_identity_declaration (SUB (p));
+	  coerce_identity_declaration (NEXT (p));
+	  break;
+	}
+    }
+}
+
+/* Coerce variable declaration.  */
+
+static void
+coerce_variable_declaration (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case DECLARER:
+	  coerce_declarer (SUB (p));
+	  coerce_variable_declaration (NEXT (p));
+	  break;
+	case DEFINING_IDENTIFIER:
+	  if (a68_whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP))
+	    {
+	      SOID_T q;
+	      a68_make_soid (&q, STRONG, SUB_MOID (p), 0);
+	      coerce_unit (NEXT_NEXT (p), &q);
+	      break;
+	    }
+	  /* Fallthrough.  */
+	default:
+	  coerce_variable_declaration (SUB (p));
+	  coerce_variable_declaration (NEXT (p));
+	  break;
+	}
+    }
+}
+
+/* Coerce routine text.  */
+
+static void
+coerce_routine_text (NODE_T *p)
+{
+  if (IS (p, PARAMETER_PACK))
+    FORWARD (p);
+  SOID_T w;
+  a68_make_soid (&w, STRONG, MOID (p), 0);
+  coerce_unit (NEXT_NEXT (p), &w);
+}
+
+/* Coerce proc declaration.  */
+
+static void
+coerce_proc_declaration (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, ROUTINE_TEXT))
+    coerce_routine_text (SUB (p));
+  else
+    {
+      coerce_proc_declaration (SUB (p));
+      coerce_proc_declaration (NEXT (p));
+    }
+}
+
+/* Coerce_op_declaration.  */
+
+static void
+coerce_op_declaration (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, DEFINING_OPERATOR))
+    {
+      SOID_T q;
+      a68_make_soid (&q, STRONG, MOID (p), 0);
+      coerce_unit (NEXT_NEXT (p), &q);
+    }
+  else
+    {
+      coerce_op_declaration (SUB (p));
+      coerce_op_declaration (NEXT (p));
+    }
+}
+
+/* Coerce brief op declaration.  */
+
+static void
+coerce_brief_op_declaration (NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, DEFINING_OPERATOR))
+    coerce_routine_text (SUB (NEXT_NEXT (p)));
+  else
+    {
+      coerce_brief_op_declaration (SUB (p));
+      coerce_brief_op_declaration (NEXT (p));
+    }
+}
+
+/* Coerce declaration list.  */
+
+static void
+coerce_declaration_list (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case IDENTITY_DECLARATION:
+	  coerce_identity_declaration (SUB (p));
+	  break;
+	case VARIABLE_DECLARATION:
+	  coerce_variable_declaration (SUB (p));
+	  break;
+	case MODE_DECLARATION:
+	  coerce_declarer (SUB (p));
+	  break;
+	case PROCEDURE_DECLARATION:
+	case PROCEDURE_VARIABLE_DECLARATION:
+	  coerce_proc_declaration (SUB (p));
+	  break;
+	case BRIEF_OPERATOR_DECLARATION:
+	  coerce_brief_op_declaration (SUB (p));
+	  break;
+	case OPERATOR_DECLARATION:
+	  coerce_op_declaration (SUB (p));
+	  break;
+	default:
+	  coerce_declaration_list (SUB (p));
+	  coerce_declaration_list (NEXT (p));
+	  break;
+	}
+    }
+}
+
+/* Coerce serial.  */
+
+static void
+coerce_serial (NODE_T *p, SOID_T *q, bool k)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, INITIALISER_SERIES))
+    {
+      coerce_serial (SUB (p), q, false);
+      coerce_serial (NEXT (p), q, k);
+    }
+  else if (IS (p, DECLARATION_LIST))
+    coerce_declaration_list (SUB (p));
+  else if (a68_is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP))
+    coerce_serial (NEXT (p), q, k);
+  else if (a68_is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP))
+    {
+      NODE_T *z = NEXT (p);
+      if (z != NO_NODE)
+	{
+	  if (IS (z, EXIT_SYMBOL) || IS (z, END_SYMBOL) || IS (z, CLOSE_SYMBOL))
+	    coerce_serial (SUB (p), q, true);
+	  else
+	    coerce_serial (SUB (p), q, false);
+	}
+      else
+	coerce_serial (SUB (p), q, true);
+      coerce_serial (NEXT (p), q, k);
+    }
+  else if (IS (p, LABELED_UNIT))
+    coerce_serial (SUB (p), q, k);
+  else if (IS (p, UNIT))
+    {
+      if (k)
+	coerce_unit (p, q);
+      else
+	{
+	  SOID_T strongvoid;
+	  a68_make_soid (&strongvoid, STRONG, M_VOID, 0);
+	  coerce_unit (p, &strongvoid);
+	}
+    }
+}
+
+/* Coerce closed.  */
+
+static void
+coerce_closed (NODE_T *p, SOID_T *q)
+{
+  if (IS (p, SERIAL_CLAUSE))
+    coerce_serial (p, q, true);
+  else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP))
+    coerce_closed (NEXT (p), q);
+}
+
+/* Coerce conditional.  */
+
+static void
+coerce_conditional (NODE_T *p, SOID_T *q)
+{
+  SOID_T w;
+  a68_make_soid (&w, MEEK, M_BOOL, 0);
+  coerce_serial (NEXT_SUB (p), &w, true);
+  FORWARD (p);
+  coerce_serial (NEXT_SUB (p), q, true);
+  if ((FORWARD (p)) != NO_NODE)
+    {
+      if (a68_is_one_of (p, ELSE_PART, CHOICE, STOP))
+	coerce_serial (NEXT_SUB (p), q, true);
+      else if (a68_is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP))
+	coerce_conditional (SUB (p), q);
+    }
+}
+
+/* Coerce unit list.  */
+
+static void
+coerce_unit_list (NODE_T *p, SOID_T *q)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, UNIT_LIST))
+    {
+      coerce_unit_list (SUB (p), q);
+      coerce_unit_list (NEXT (p), q);
+    }
+  else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP))
+    coerce_unit_list (NEXT (p), q);
+  else if (IS (p, UNIT))
+    {
+      coerce_unit (p, q);
+      coerce_unit_list (NEXT (p), q);
+    }
+}
+
+/* Coerce int case.  */
+
+static void
+coerce_int_case (NODE_T *p, SOID_T *q)
+{
+  SOID_T w;
+  a68_make_soid (&w, MEEK, M_INT, 0);
+  coerce_serial (NEXT_SUB (p), &w, true);
+  FORWARD (p);
+  coerce_unit_list (NEXT_SUB (p), q);
+  if ((FORWARD (p)) != NO_NODE)
+    {
+      if (a68_is_one_of (p, OUT_PART, CHOICE, STOP))
+	coerce_serial (NEXT_SUB (p), q, true);
+      else if (a68_is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP))
+	coerce_int_case (SUB (p), q);
+    }
+}
+
+/* Coerce spec unit list.  */
+
+static void
+coerce_spec_unit_list (NODE_T *p, SOID_T *q)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (a68_is_one_of (p, SPECIFIED_UNIT_LIST, SPECIFIED_UNIT, STOP))
+	coerce_spec_unit_list (SUB (p), q);
+      else if (IS (p, UNIT))
+	coerce_unit (p, q);
+    }
+}
+
+/* Coerce united case.  */
+
+static void
+coerce_united_case (NODE_T *p, SOID_T *q)
+{
+  SOID_T w;
+  a68_make_soid (&w, MEEK, MOID (SUB (p)), 0);
+  coerce_serial (NEXT_SUB (p), &w, true);
+  FORWARD (p);
+  coerce_spec_unit_list (NEXT_SUB (p), q);
+  if ((FORWARD (p)) != NO_NODE)
+    {
+      if (a68_is_one_of (p, OUT_PART, CHOICE, STOP))
+	coerce_serial (NEXT_SUB (p), q, true);
+      else if (a68_is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP))
+	coerce_united_case (SUB (p), q);
+    }
+}
+
+/* Coerce loop.  */
+
+static void
+coerce_loop (NODE_T *p)
+{
+  if (IS (p, FOR_PART))
+    coerce_loop (NEXT (p));
+  else if (a68_is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP))
+    {
+      SOID_T w;
+      a68_make_soid (&w, MEEK, M_INT, 0);
+      coerce_unit (NEXT_SUB (p), &w);
+      coerce_loop (NEXT (p));
+    }
+  else if (IS (p, WHILE_PART))
+    {
+      SOID_T w;
+      a68_make_soid (&w, MEEK, M_BOOL, 0);
+      coerce_serial (NEXT_SUB (p), &w, true);
+      coerce_loop (NEXT (p));
+    }
+  else if (a68_is_one_of (p, DO_PART, ALT_DO_PART, STOP))
+    {
+      SOID_T w;
+      NODE_T *do_p = NEXT_SUB (p);
+      a68_make_soid (&w, STRONG, M_VOID, 0);
+      coerce_serial (do_p, &w, true);
+    }
+}
+
+/* Coerce struct display.  */
+
+static void
+coerce_struct_display (PACK_T **r, NODE_T *p)
+{
+  if (p == NO_NODE)
+    return;
+  else if (IS (p, UNIT_LIST))
+    {
+      coerce_struct_display (r, SUB (p));
+      coerce_struct_display (r, NEXT (p));
+    }
+  else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, COMMA_SYMBOL, STOP))
+    coerce_struct_display (r, NEXT (p));
+  else if (IS (p, UNIT))
+    {
+      SOID_T s;
+      a68_make_soid (&s, STRONG, MOID (*r), 0);
+      coerce_unit (p, &s);
+      FORWARD (*r);
+      coerce_struct_display (r, NEXT (p));
+    }
+}
+
+/* Coerce collateral.  */
+
+static void
+coerce_collateral (NODE_T *p, SOID_T *q)
+{
+  if (!(a68_whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP)
+	|| a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)))
+    {
+      if (IS (MOID (q), STRUCT_SYMBOL))
+	{
+	  PACK_T *t = PACK (MOID (q));
+	  coerce_struct_display (&t, p);
+	}
+      else if (IS_FLEX (MOID (q)))
+	{
+	  SOID_T w;
+	  a68_make_soid (&w, STRONG, SLICE (SUB_MOID (q)), 0);
+	  coerce_unit_list (p, &w);
+	}
+      else if (IS_ROW (MOID (q)))
+	{
+	  SOID_T w;
+	  a68_make_soid (&w, STRONG, SLICE (MOID (q)), 0);
+	  coerce_unit_list (p, &w);
+	}
+      else
+	{
+	  /* if (MOID (q) != M_VOID).  */
+	  coerce_unit_list (p, q);
+	}
+    }
+}
+
+/* Coerce_enclosed.  */
+
+static void
+coerce_enclosed (NODE_T *p, SOID_T *q)
+{
+  if (IS (p, ENCLOSED_CLAUSE))
+    coerce_enclosed (SUB (p), q);
+  else if (IS (p, CLOSED_CLAUSE))
+    coerce_closed (SUB (p), q);
+  else if (IS (p, COLLATERAL_CLAUSE))
+    coerce_collateral (SUB (p), q);
+  else if (IS (p, PARALLEL_CLAUSE))
+    coerce_collateral (SUB (NEXT_SUB (p)), q);
+  else if (IS (p, CONDITIONAL_CLAUSE))
+    coerce_conditional (SUB (p), q);
+  else if (IS (p, CASE_CLAUSE))
+    coerce_int_case (SUB (p), q);
+  else if (IS (p, CONFORMITY_CLAUSE))
+    coerce_united_case (SUB (p), q);
+  else if (IS (p, LOOP_CLAUSE))
+    coerce_loop (SUB (p));
+
+  MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+}
+
+/* Get monad moid.  */
+
+static MOID_T *
+get_monad_moid (NODE_T *p)
+{
+  if (TAX (p) != NO_TAG && TAX (p) != A68_PARSER (error_tag))
+    {
+      MOID (p) = MOID (TAX (p));
+      return MOID (PACK (MOID (p)));
+    }
+  else
+    return M_ERROR;
+}
+
+/* Coerce monad oper.  */
+
+static void
+coerce_monad_oper (NODE_T *p, SOID_T *q)
+{
+  if (p != NO_NODE)
+    {
+      SOID_T z;
+      a68_make_soid (&z, FIRM, MOID (PACK (MOID (TAX (p)))), 0);
+      A68_INSERT_COERCIONS (NEXT (p), MOID (q), &z);
+    }
+}
+
+/* Coerce monad formula.  */
+
+static void
+coerce_monad_formula (NODE_T *p)
+{
+  SOID_T e;
+  a68_make_soid (&e, STRONG, get_monad_moid (p), 0);
+  coerce_operand (NEXT (p), &e);
+  coerce_monad_oper (p, &e);
+}
+
+/* Coerce operand.  */
+
+static void
+coerce_operand (NODE_T *p, SOID_T *q)
+{
+  if (IS (p, MONADIC_FORMULA))
+    {
+      coerce_monad_formula (SUB (p));
+      if (MOID (p) != MOID (q))
+	{
+	  a68_make_sub (p, p, FORMULA);
+	  A68_INSERT_COERCIONS (p, MOID (p), q);
+	  a68_make_sub (p, p, TERTIARY);
+	}
+      MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+    }
+  else if (IS (p, FORMULA))
+    {
+      coerce_formula (SUB (p), q);
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+      MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+    }
+  else if (IS (p, SECONDARY))
+    {
+      coerce_unit (SUB (p), q);
+      MOID (p) = MOID (SUB (p));
+    }
+}
+
+/* Coerce formula.  */
+
+static void
+coerce_formula (NODE_T *p, SOID_T *q __attribute__ ((unused)))
+{
+  if (IS (p, MONADIC_FORMULA) && NEXT (p) == NO_NODE)
+    coerce_monad_formula (SUB (p));
+  else
+    {
+      if (TAX (NEXT (p)) != NO_TAG && TAX (NEXT (p)) != A68_PARSER (error_tag))
+	{
+	  SOID_T s;
+	  NODE_T *op = NEXT (p), *nq = NEXT_NEXT (p);
+	  MOID_T *w = MOID (op);
+	  MOID_T *u = MOID (PACK (w)), *v = MOID (NEXT (PACK (w)));
+	  a68_make_soid (&s, STRONG, u, 0);
+	  coerce_operand (p, &s);
+	  a68_make_soid (&s, STRONG, v, 0);
+	  coerce_operand (nq, &s);
+	}
+    }
+}
+
+/* Coerce assignation.  */
+
+static void
+coerce_assignation (NODE_T *p)
+{
+  SOID_T w;
+  a68_make_soid (&w, SOFT, MOID (p), 0);
+  coerce_unit (SUB (p), &w);
+  a68_make_soid (&w, STRONG, SUB_MOID (p), 0);
+  coerce_unit (NEXT_NEXT (p), &w);
+}
+
+/* Coerce relation.  */
+
+static void
+coerce_relation (NODE_T *p)
+{
+  SOID_T w;
+  a68_make_soid (&w, STRONG, MOID (p), 0);
+  coerce_unit (SUB (p), &w);
+  a68_make_soid (&w, STRONG, MOID (NEXT_NEXT (p)), 0);
+  coerce_unit (SUB (NEXT_NEXT (p)), &w);
+}
+
+/* Coerce bool function.  */
+
+static void
+coerce_bool_function (NODE_T *p)
+{
+  SOID_T w;
+  a68_make_soid (&w, STRONG, M_BOOL, 0);
+  coerce_unit (SUB (p), &w);
+  coerce_unit (SUB (NEXT_NEXT (p)), &w);
+}
+
+/* Coerce assertion.  */
+
+static void
+coerce_assertion (NODE_T *p)
+{
+  SOID_T w;
+  a68_make_soid (&w, MEEK, M_BOOL, 0);
+  coerce_enclosed (SUB_NEXT (p), &w);
+}
+
+/* Coerce selection.  */
+
+static void
+coerce_selection (NODE_T * p)
+{
+  SOID_T w;
+  a68_make_soid (&w, STRONG, MOID (NEXT (p)), 0);
+  coerce_unit (SUB_NEXT (p), &w);
+}
+
+/* Coerce cast.  */
+
+static void
+coerce_cast (NODE_T * p)
+{
+  coerce_declarer (p);
+  SOID_T w;
+  a68_make_soid (&w, STRONG, MOID (p), 0);
+  coerce_enclosed (NEXT (p), &w);
+}
+
+/* Coerce argument list.  */
+
+static void
+coerce_argument_list (PACK_T **r, NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, ARGUMENT_LIST))
+	coerce_argument_list (r, SUB (p));
+      else if (IS (p, UNIT))
+	{
+	  SOID_T s;
+	  a68_make_soid (&s, STRONG, MOID (*r), 0);
+	  coerce_unit (p, &s);
+	  FORWARD (*r);
+	}
+      else if (IS (p, TRIMMER))
+	FORWARD (*r);
+    }
+}
+
+/* Coerce call.  */
+
+static void
+coerce_call (NODE_T *p)
+{
+  MOID_T *proc = MOID (p);
+  SOID_T w;
+  a68_make_soid (&w, MEEK, proc, 0);
+  coerce_unit (SUB (p), &w);
+  FORWARD (p);
+  PACK_T *t = PACK (proc);
+  coerce_argument_list (&t, SUB (p));
+}
+
+/* Coerce meek int.  */
+
+static void
+coerce_meek_int (NODE_T *p)
+{
+  SOID_T x;
+  a68_make_soid (&x, MEEK, M_INT, 0);
+  coerce_unit (p, &x);
+}
+
+/* Coerce trimmer.  */
+
+static void
+coerce_trimmer (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, UNIT))
+	{
+	  coerce_meek_int (p);
+	  coerce_trimmer (NEXT (p));
+	}
+      else
+	coerce_trimmer (NEXT (p));
+    }
+}
+
+/* Coerce indexer.  */
+
+static void
+coerce_indexer (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, TRIMMER))
+	coerce_trimmer (SUB (p));
+      else if (IS (p, UNIT))
+	coerce_meek_int (p);
+      else
+	{
+	  coerce_indexer (SUB (p));
+	  coerce_indexer (NEXT (p));
+	}
+    }
+}
+
+/* Coerce_slice.  */
+
+static void
+coerce_slice (NODE_T *p)
+{
+  SOID_T w;
+  MOID_T *row = MOID (p);
+  a68_make_soid (&w, STRONG, row, 0);
+  coerce_unit (SUB (p), &w);
+  coerce_indexer (SUB_NEXT (p));
+}
+
+/* Coerce format text.  */
+
+static void
+coerce_format_text (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      coerce_format_text (SUB (p));
+      if (IS (p, FORMAT_PATTERN))
+	{
+	  SOID_T x;
+	  a68_make_soid (&x, STRONG, M_FORMAT, 0);
+	  coerce_enclosed (SUB (NEXT_SUB (p)), &x);
+	}
+      else if (IS (p, GENERAL_PATTERN) && NEXT_SUB (p) != NO_NODE)
+	{
+	  SOID_T x;
+	  a68_make_soid (&x, STRONG, M_ROW_INT, 0);
+	  coerce_enclosed (SUB (NEXT_SUB (p)), &x);
+	}
+      else if (IS (p, DYNAMIC_REPLICATOR))
+	{
+	  SOID_T x;
+	  a68_make_soid (&x, STRONG, M_INT, 0);
+	  coerce_enclosed (SUB (NEXT_SUB (p)), &x);
+	}
+    }
+}
+
+/* Coerce unit.  */
+
+static void
+coerce_unit (NODE_T *p, SOID_T *q)
+{
+  if (p == NO_NODE)
+    return;
+  else if (a68_is_one_of (p, UNIT, TERTIARY, SECONDARY, PRIMARY, STOP))
+    {
+      coerce_unit (SUB (p), q);
+      MOID (p) = MOID (SUB (p));
+      /* Ex primary.  */
+    }
+  else if (IS (p, CALL))
+    {
+      coerce_call (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+  else if (IS (p, SLICE))
+    {
+      coerce_slice (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+  else if (IS (p, CAST))
+    {
+      coerce_cast (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+  else if (a68_is_one_of (p, DENOTATION, IDENTIFIER, STOP))
+    A68_INSERT_COERCIONS (p, MOID (p), q);
+  else if (IS (p, FORMAT_TEXT))
+    {
+      coerce_format_text (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+  else if (IS (p, ENCLOSED_CLAUSE))
+    {
+      coerce_enclosed (p, q);
+      /* Ex secondary.  */
+    }
+  else if (IS (p, SELECTION))
+    {
+      coerce_selection (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+  else if (IS (p, GENERATOR))
+    {
+      coerce_declarer (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+      /* Ex tertiary.  */
+    }
+  else if (IS (p, NIHIL))
+    {
+      if (ATTRIBUTE (MOID (q)) != REF_SYMBOL && MOID (q) != M_VOID)
+	a68_error (p, "context does not require a name");
+      MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+    }
+  else if (IS (p, FORMULA))
+    {
+      coerce_formula (SUB (p), q);
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+  else if (IS (p, JUMP))
+    {
+      if (MOID (q) == M_PROC_VOID)
+	a68_make_sub (p, p, PROCEDURING);
+      MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+    }
+  else if (IS (p, SKIP))
+    MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+  else if (IS (p, ASSIGNATION))
+    {
+      coerce_assignation (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+      MOID (p) = a68_depref_rows (MOID (p), MOID (q));
+    }
+  else if (IS (p, IDENTITY_RELATION))
+    {
+      coerce_relation (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+  else if (IS (p, ROUTINE_TEXT))
+    {
+      coerce_routine_text (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+  else if (a68_is_one_of (p, AND_FUNCTION, OR_FUNCTION, STOP))
+    {
+      coerce_bool_function (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+  else if (IS (p, ASSERTION))
+    {
+      coerce_assertion (SUB (p));
+      A68_INSERT_COERCIONS (p, MOID (p), q);
+    }
+}
+
+/* Driver for coercion insertions.  */
+
+void
+a68_coercion_inserter (NODE_T *p)
+{
+  if (IS (p, PARTICULAR_PROGRAM))
+    {
+      SOID_T q;
+      a68_make_soid (&q, STRONG, M_VOID, 0);
+      coerce_enclosed (SUB (p), &q);
+    }
+}
diff --git a/gcc/algol68/a68-parser-moids-equivalence.cc b/gcc/algol68/a68-parser-moids-equivalence.cc
new file mode 100644
index 00000000000..3c0ffc7692c
--- /dev/null
+++ b/gcc/algol68/a68-parser-moids-equivalence.cc
@@ -0,0 +1,174 @@
+/* Prove equivalence of modes.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/* Routines for establishing equivalence of modes.
+   After I made this mode equivalencer (in 1993), I found:
+
+   Algol Bulletin 30.3.3 C.H.A. Koster: On infinite modes, 86-89 [1969],
+
+   which essentially concurs with this test on mode equivalence I wrote.
+   It is elementary logic anyway: prove equivalence, assuming equivalence.  */
+
+/* Forward declarations of some of the functions defined below.  */
+
+static bool are_modes_equivalent (MOID_T * a, MOID_T * b);
+
+/* Whether packs are equivalent, same sequence of equivalence modes.  */
+
+static bool
+are_packs_equivalent (PACK_T *s, PACK_T *t)
+{
+  for (; s != NO_PACK && t != NO_PACK; s = s->next, t = t->next)
+    {
+      if (!are_modes_equivalent (MOID (s), MOID (t)))
+	return false;
+      if (TEXT (s) != TEXT (t))
+	return false;
+    }
+
+  return s == NO_PACK && t == NO_PACK;
+}
+
+/* Whether packs are subsets.  */
+
+static bool
+is_united_subset (PACK_T *s, PACK_T *t)
+{
+  /* For all modes in 's' there must be an equivalent in 't'.  */
+  for (PACK_T *p = s; p != NO_PACK; p = p->next)
+    {
+      bool f = false;
+      for (PACK_T *q = t; q != NO_PACK && !f; q = q->next)
+	f = are_modes_equivalent (MOID (p), MOID (q));
+
+      if (!f)
+	return false;
+    }
+
+  return true;
+}
+
+/* Whether packs are subsets.  */
+
+static bool
+are_united_packs_equivalent (PACK_T *s, PACK_T *t)
+{
+  return is_united_subset (s, t) && is_united_subset (t, s);
+}
+
+/* Whether moids A and B are structurally equivalent.  */
+
+static bool
+are_modes_equivalent (MOID_T * a, MOID_T * b)
+{
+  /* First lets try some cheap heuristics.  */
+
+  if (a == NO_MOID || b == NO_MOID)
+    /* Modes can be NO_MOID in partial argument lists.  */
+    return false;
+  else if (a == M_ERROR || b == M_ERROR)
+    return false;
+  else if (a == b)
+    return true;
+  else if (ATTRIBUTE (a) != ATTRIBUTE (b))
+    return false;
+  else if (DIM (a) != DIM (b))
+    return false;
+  else if (IS (a, STANDARD))
+    return (a == b);
+  else if (EQUIVALENT (a) == b || EQUIVALENT (b) == a)
+    return true;
+  else if (a68_is_postulated_pair (A68 (top_postulate), a, b)
+	   || a68_is_postulated_pair (A68 (top_postulate), b, a))
+    return true;
+  else if (IS (a, INDICANT))
+    {
+      if (NODE (a) == NO_NODE || NODE (b) == NO_NODE)
+	return false;
+      else
+	return NODE (a) == NODE (b);
+    }
+
+  /* Investigate structure.  */
+
+  /* We now know that 'a' and 'b' have same attribute, dimension, ...  */
+  if (IS (a, REF_SYMBOL))
+    /* REF MODE  */
+    return are_modes_equivalent (a->sub, b->sub);
+  else if (IS (a, ROW_SYMBOL))
+    /* [] MODE  */
+    return are_modes_equivalent (a->sub, b->sub);
+  else if (IS (a, FLEX_SYMBOL))
+    /* FLEX [...] MODE  */
+    return are_modes_equivalent (a->sub, b->sub);
+  else if (IS (a, STRUCT_SYMBOL))
+    {
+      /* STRUCT (...)  */
+      POSTULATE_T *save = A68 (top_postulate);
+      a68_make_postulate (&A68 (top_postulate), a, b);
+      bool z = are_packs_equivalent (PACK (a), PACK (b));
+      a68_free_postulate_list (A68 (top_postulate), save);
+      A68 (top_postulate) = save;
+      return z;
+    }
+  else if (IS (a, UNION_SYMBOL))
+    /* UNION (...)  */
+    return are_united_packs_equivalent (PACK (a), PACK (b));
+  else if (IS (a, PROC_SYMBOL) && PACK (a) == NO_PACK && PACK (b) == NO_PACK)
+    /* PROC MOID  */
+    return are_modes_equivalent (a->sub, b->sub);
+  else if (IS (a, PROC_SYMBOL) && PACK (a) != NO_PACK && PACK (b) != NO_PACK)
+    {
+      /* PROC (...) MOID  */
+      POSTULATE_T *save = A68 (top_postulate);
+      a68_make_postulate (&A68 (top_postulate), a, b);
+      bool z = are_modes_equivalent (a->sub, b->sub);
+      if (z)
+	z = are_packs_equivalent (PACK (a), PACK (b));
+      a68_free_postulate_list (A68 (top_postulate), save);
+      A68 (top_postulate) = save;
+      return z;
+    }
+  else if (IS (a, SERIES_MODE) || IS (a, STOWED_MODE))
+    /* Modes occurring in displays.  */
+    return are_packs_equivalent (PACK (a), PACK (b));
+
+  return false;
+}
+
+//! @brief Whether two modes are structurally equivalent.
+
+bool
+a68_prove_moid_equivalence (MOID_T *p, MOID_T *q)
+{
+// Prove two modes to be equivalent under assumption that they indeed are.
+  POSTULATE_T *save = A68 (top_postulate);
+  bool z = are_modes_equivalent (p, q);
+  a68_free_postulate_list (A68 (top_postulate), save);
+  A68 (top_postulate) = save;
+  return z;
+}
diff --git a/gcc/algol68/a68-postulates.cc b/gcc/algol68/a68-postulates.cc
new file mode 100644
index 00000000000..35388c332cd
--- /dev/null
+++ b/gcc/algol68/a68-postulates.cc
@@ -0,0 +1,103 @@
+/* Postulates needed for improving equivalence of modes.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.h"
+
+/* Initialise use of postulate-lists.  */
+
+void
+a68_init_postulates (void)
+{
+  A68 (top_postulate) = NO_POSTULATE;
+  A68 (top_postulate_list) = NO_POSTULATE;
+}
+
+/* Make old postulates available for new use.  */
+
+void
+a68_free_postulate_list (POSTULATE_T *start, POSTULATE_T *stop)
+{
+  if (start == stop)
+    return;
+
+  POSTULATE_T *last = start;
+  for (; NEXT (last) != stop; FORWARD (last))
+    ;
+
+  NEXT (last) = A68 (top_postulate_list);
+  A68 (top_postulate_list) = start;
+}
+
+/* Add postulates to postulate-list.  */
+
+void
+a68_make_postulate (POSTULATE_T **p, MOID_T *a, MOID_T *b)
+{
+  POSTULATE_T *new_one;
+
+  if (A68 (top_postulate_list) != NO_POSTULATE)
+    {
+      new_one = A68 (top_postulate_list);
+      A68 (top_postulate_list) = A68 (top_postulate_list)->next;
+    }
+  else
+    {
+      new_one = (POSTULATE_T *) xmalloc (sizeof (POSTULATE_T));
+      A68 (new_postulates)++;
+    }
+
+  new_one->a = a;
+  new_one->b = b;
+  new_one->next = *p;
+  *p = new_one;
+}
+
+/* Where postulates are in the list.  */
+
+POSTULATE_T
+*a68_is_postulated_pair (POSTULATE_T *p, MOID_T *a, MOID_T *b)
+{
+  for (; p != NO_POSTULATE; p = p->next)
+    {
+      if (p->a == a && p->b == b)
+	return p;
+    }
+
+  return NO_POSTULATE;
+}
+
+/* Where postulate is in the list.  */
+
+POSTULATE_T
+*a68_is_postulated (POSTULATE_T *p, MOID_T *a)
+{
+  for (; p != NO_POSTULATE; p = p->next)
+    {
+      if (p->a == a)
+	return p;
+    }
+
+  return NO_POSTULATE;
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 24/47] a68: parser: symbol table management
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (22 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 23/47] a68: parser: parsing of modes Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 25/47] a68: parser: static scope checker Jose E. Marchesi
                   ` (23 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-taxes.cc | 1648 +++++++++++++++++++++++++++++++
 1 file changed, 1648 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-taxes.cc

diff --git a/gcc/algol68/a68-parser-taxes.cc b/gcc/algol68/a68-parser-taxes.cc
new file mode 100644
index 00000000000..23317a4b9f9
--- /dev/null
+++ b/gcc/algol68/a68-parser-taxes.cc
@@ -0,0 +1,1648 @@
+/* Symbol table management.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/*
+ * Symbol table handling, managing TAGS.
+ */
+
+/* Forward declarations for several functions defined below.  */
+
+static TAG_T *find_tag_local (TABLE_T *table, int a, const char *name);
+
+/* Set level for procedures.  */
+
+void
+a68_set_proc_level (NODE_T *p, int n)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      PROCEDURE_LEVEL (INFO (p)) = n;
+      if (IS (p, ROUTINE_TEXT))
+	a68_set_proc_level (SUB (p), n + 1);
+      else
+	a68_set_proc_level (SUB (p), n);
+    }
+}
+
+/* Set nests for diagnostics.  */
+
+void
+a68_set_nest (NODE_T *p, NODE_T *s)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      NEST (p) = s;
+      if (IS (p, PARTICULAR_PROGRAM))
+	a68_set_nest (SUB (p), p);
+      else if (IS (p, CLOSED_CLAUSE) && LINE_NUMBER (p) != 0)
+	a68_set_nest (SUB (p), p);
+      else if (IS (p, COLLATERAL_CLAUSE) && LINE_NUMBER (p) != 0)
+	a68_set_nest (SUB (p), p);
+      else if (IS (p, CONDITIONAL_CLAUSE) && LINE_NUMBER (p) != 0)
+	a68_set_nest (SUB (p), p);
+      else if (IS (p, CASE_CLAUSE) && LINE_NUMBER (p) != 0)
+	a68_set_nest (SUB (p), p);
+      else if (IS (p, CONFORMITY_CLAUSE) && LINE_NUMBER (p) != 0)
+	a68_set_nest (SUB (p), p);
+      else if (IS (p, LOOP_CLAUSE) && LINE_NUMBER (p) != 0)
+	a68_set_nest (SUB (p), p);
+      else
+	a68_set_nest (SUB (p), s);
+    }
+}
+
+/*
+ * Routines that work with tags and symbol tables.
+ */
+
+static void tax_tags (NODE_T *);
+static void tax_specifier_list (NODE_T *);
+static void tax_parameter_list (NODE_T *);
+static void tax_format_texts (NODE_T *);
+
+/* Find a tag, searching symbol tables towards the root.  */
+
+int
+a68_first_tag_global (TABLE_T * table, const char *name)
+{
+  if (table != NO_TABLE)
+    {
+      for (TAG_T *s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    return IDENTIFIER;
+	}
+      for (TAG_T *s = INDICANTS (table); s != NO_TAG; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    return INDICANT;
+	}
+      for (TAG_T *s = LABELS (table); s != NO_TAG; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    return LABEL;
+	}
+      for (TAG_T *s = OPERATORS (table); s != NO_TAG; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    return OP_SYMBOL;
+	}
+      for (TAG_T *s = PRIO (table); s != NO_TAG; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    return PRIO_SYMBOL;
+	}
+      return a68_first_tag_global (PREVIOUS (table), name);
+    }
+  else
+    return STOP;
+}
+
+/* Whether routine can be "lengthety-mapped".  */
+
+static bool
+is_mappable_routine (char *z)
+{
+#define ACCEPT(u, v) {\
+  if (strlen (u) >= strlen (v)) {\
+    if (strcmp (&u[strlen (u) - strlen (v)], v) == 0) {\
+      return true;\
+  }}}
+
+  /* Math routines.  */
+  ACCEPT (z, "arccos");
+  ACCEPT (z, "arccosdg");
+  ACCEPT (z, "arccot");
+  ACCEPT (z, "arccotdg");
+  ACCEPT (z, "arcsin");
+  ACCEPT (z, "arcsindg");
+  ACCEPT (z, "arctan");
+  ACCEPT (z, "arctandg");
+  ACCEPT (z, "beta");
+  ACCEPT (z, "betainc");
+  ACCEPT (z, "cbrt");
+  ACCEPT (z, "cos");
+  ACCEPT (z, "cosdg");
+  ACCEPT (z, "cospi");
+  ACCEPT (z, "cot");
+  ACCEPT (z, "cot");
+  ACCEPT (z, "cotdg");
+  ACCEPT (z, "cotpi");
+  ACCEPT (z, "curt");
+  ACCEPT (z, "erf");
+  ACCEPT (z, "erfc");
+  ACCEPT (z, "exp");
+  ACCEPT (z, "gamma");
+  ACCEPT (z, "gammainc");
+  ACCEPT (z, "gammaincg");
+  ACCEPT (z, "gammaincgf");
+  ACCEPT (z, "ln");
+  ACCEPT (z, "log");
+  ACCEPT (z, "pi");
+  ACCEPT (z, "sin");
+  ACCEPT (z, "sindg");
+  ACCEPT (z, "sinpi");
+  ACCEPT (z, "sqrt");
+  ACCEPT (z, "tan");
+  ACCEPT (z, "tandg");
+  ACCEPT (z, "tanpi");
+  /* Random generator.  */
+  ACCEPT (z, "nextrandom");
+  ACCEPT (z, "random");
+  /* BITS.  */
+  ACCEPT (z, "bitspack");
+  /* Enquiries.  */
+  ACCEPT (z, "maxint");
+  ACCEPT (z, "intwidth");
+  ACCEPT (z, "maxreal");
+  ACCEPT (z, "realwidth");
+  ACCEPT (z, "expwidth");
+  ACCEPT (z, "maxbits");
+  ACCEPT (z, "bitswidth");
+  ACCEPT (z, "byteswidth");
+  ACCEPT (z, "smallreal");
+  return false;
+#undef ACCEPT
+}
+
+/* Map "short sqrt" onto "sqrt" etcetera.  */
+
+static TAG_T *
+bind_lengthety_identifier (const char *u)
+{
+#define CAR(u, v) (strncmp (u, v, strlen(v)) == 0)
+  /* We can only map routines blessed by "is_mappable_routine", so there is no
+     "short print" or "long char in string". */
+  if (CAR (u, "short"))
+    {
+      do
+	{
+	  u = &u[strlen ("short")];
+	  char *v = TEXT (a68_add_token (&A68 (top_token), u));
+	  TAG_T *w = find_tag_local (A68_STANDENV, IDENTIFIER, v);
+	  if (w != NO_TAG && is_mappable_routine (v))
+	    return w;
+	}
+      while (CAR (u, "short"));
+    }
+  else if (CAR (u, "long"))
+    {
+      do
+	{
+	  u = &u[strlen ("long")];
+	  char *v = TEXT (a68_add_token (&A68 (top_token), u));
+	  TAG_T *w = find_tag_local (A68_STANDENV, IDENTIFIER, v);
+	  if (w != NO_TAG && is_mappable_routine (v))
+	    return w;
+	}
+      while (CAR (u, "long"));
+    }
+
+  return NO_TAG;
+#undef CAR
+}
+
+/* Bind identifier tags to the symbol table.  */
+
+static void
+bind_identifier_tag_to_symbol_table (NODE_T * p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      bind_identifier_tag_to_symbol_table (SUB (p));
+
+      if (a68_is_one_of (p, IDENTIFIER, DEFINING_IDENTIFIER, STOP))
+	{
+	  int att = a68_first_tag_global (TABLE (p), NSYMBOL (p));
+
+	  if (att == STOP)
+	    {
+	      TAG_T *z = bind_lengthety_identifier (NSYMBOL (p));
+
+	      if (z != NO_TAG)
+		MOID (p) = MOID (z);
+	      TAX (p) = z;
+	    }
+	  else
+	    {
+	      TAG_T *z = a68_find_tag_global (TABLE (p), att, NSYMBOL (p));
+
+	      if (att == IDENTIFIER && z != NO_TAG)
+		MOID (p) = MOID (z);
+	      else if (att == LABEL && z != NO_TAG)
+		;
+	      else if ((z = bind_lengthety_identifier (NSYMBOL (p))) != NO_TAG)
+		MOID (p) = MOID (z);
+	      else
+		{
+		  a68_error (p, "tag S has not been declared properly");
+		  z = a68_add_tag (TABLE (p), IDENTIFIER, p, M_ERROR, NORMAL_IDENTIFIER);
+		  MOID (p) = M_ERROR;
+		}
+	      TAX (p) = z;
+	      if (IS (p, DEFINING_IDENTIFIER))
+		NODE (z) = p;
+	    }
+	}
+    }
+}
+
+/* Tell whether the given tree refers to the applied indicant INDICANT in an
+   actual declarer.  */
+
+static bool
+declarer_contains_indicant (NODE_T *p, NODE_T *indicant)
+{
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, DECLARER)
+	  && IS (SUB (q), INDICANT)
+	  && ((TAX (SUB (q)) && IS_RECURSIVE (TAX (SUB (q))))
+	      || IS_LITERALLY (SUB (q), NSYMBOL (indicant))))
+	{
+	  return true;
+	}
+
+      if (declarer_contains_indicant (SUB (q), indicant))
+	return true;
+    }
+
+  return false;
+}
+
+/* Bind indicant tags to the symbol table.  */
+
+static void
+bind_indicant_tag_to_symbol_table (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      bind_indicant_tag_to_symbol_table (SUB (p));
+
+      if (a68_is_one_of (p, INDICANT, DEFINING_INDICANT, STOP))
+	{
+	  TAG_T *z = a68_find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
+
+	  if (z != NO_TAG)
+	    {
+	      MOID (p) = MOID (z);
+	      TAX (p) = z;
+	      if (IS (p, DEFINING_INDICANT))
+		{
+		  NODE (z) = p;
+		  IS_RECURSIVE (z) = declarer_contains_indicant (NEXT_NEXT (p), p);
+		}
+	    }
+	}
+    }
+}
+
+/* Enter specifier identifiers in the symbol table.  */
+
+static void
+tax_specifiers (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      tax_specifiers (SUB (p));
+
+      if (SUB (p) != NO_NODE && IS (p, SPECIFIER))
+	tax_specifier_list (SUB (p));
+    }
+}
+
+/* Enter specifier identifiers in the symbol table.  */
+
+static void
+tax_specifier_list (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, OPEN_SYMBOL))
+	tax_specifier_list (NEXT (p));
+      else if (a68_is_one_of (p, CLOSE_SYMBOL, VOID_SYMBOL, STOP))
+	;
+      else if (IS (p, IDENTIFIER))
+	{
+	  TAG_T *z = a68_add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, SPECIFIER_IDENTIFIER);
+	  HEAP (z) = LOC_SYMBOL;
+	}
+      else if (IS (p, DECLARER))
+	{
+	  tax_specifiers (SUB (p));
+	  tax_specifier_list (NEXT (p));
+	  /* last identifier entry is identifier with this declarer.  */
+	  if (IDENTIFIERS (TABLE (p)) != NO_TAG
+	      && PRIO (IDENTIFIERS (TABLE (p))) == SPECIFIER_IDENTIFIER)
+	    MOID (IDENTIFIERS (TABLE (p))) = MOID (p);
+	}
+    }
+}
+
+/* Enter parameter identifiers in the symbol table.  */
+
+static void
+tax_parameters (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (SUB (p) != NO_NODE)
+	{
+	  tax_parameters (SUB (p));
+	  if (IS (p, PARAMETER_PACK))
+	    tax_parameter_list (SUB (p));
+	}
+    }
+}
+
+/* Enter parameter identifiers in the symbol table.  */
+
+static void
+tax_parameter_list (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (a68_is_one_of (p, OPEN_SYMBOL, COMMA_SYMBOL, STOP))
+      tax_parameter_list (NEXT (p));
+      else if (IS (p, CLOSE_SYMBOL))
+	;
+      else if (a68_is_one_of (p, PARAMETER_LIST, PARAMETER, STOP))
+	{
+	  tax_parameter_list (NEXT (p));
+	  tax_parameter_list (SUB (p));
+	}
+      else if (IS (p, IDENTIFIER))
+	{
+	  /* parameters are always local.  */
+	  HEAP (a68_add_tag (TABLE (p), IDENTIFIER, p, NO_MOID, PARAMETER_IDENTIFIER)) = LOC_SYMBOL;
+	}
+      else if (IS (p, DECLARER))
+	{
+	  tax_parameter_list (NEXT (p));
+	  /* last identifier entries are identifiers with this declarer.  */
+	  for (TAG_T *s = IDENTIFIERS (TABLE (p)); s != NO_TAG && MOID (s) == NO_MOID; FORWARD (s))
+	    MOID (s) = MOID (p);
+	  tax_parameters (SUB (p));
+	}
+    }
+}
+
+/* Enter FOR identifiers in the symbol table.  */
+
+static void
+tax_for_identifiers (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      tax_for_identifiers (SUB (p));
+
+      if (IS (p, FOR_SYMBOL))
+	{
+	  if ((FORWARD (p)) != NO_NODE)
+	    (void) a68_add_tag (TABLE (p), IDENTIFIER, p, M_INT, LOOP_IDENTIFIER);
+	}
+    }
+}
+
+/* Enter routine texts in the symbol table.  */
+
+static void
+tax_routine_texts (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      tax_routine_texts (SUB (p));
+
+      if (IS (p, ROUTINE_TEXT))
+	{
+	  TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, MOID (p), ROUTINE_TEXT);
+	  TAX (p) = z;
+	  HEAP (z) = LOC_SYMBOL;
+	  USE (z) = true;
+	}
+    }
+}
+
+/* Enter format texts in the symbol table.  */
+
+static void
+tax_format_texts (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      tax_format_texts (SUB (p));
+
+      if (IS (p, FORMAT_TEXT))
+	{
+	  TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_TEXT);
+	  TAX (p) = z;
+	  USE (z) = true;
+	}
+      else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE)
+	{
+	  TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, M_FORMAT, FORMAT_IDENTIFIER);
+	  TAX (p) = z;
+	  USE (z) = true;
+	}
+    }
+}
+
+/* Enter FORMAT pictures in the symbol table.  */
+
+static void
+tax_pictures (NODE_T * p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      tax_pictures (SUB (p));
+
+      if (IS (p, PICTURE))
+	TAX (p) = a68_add_tag (TABLE (p), ANONYMOUS, p, M_COLLITEM, FORMAT_IDENTIFIER);
+    }
+}
+
+/* Enter generators in the symbol table.  */
+
+static void
+tax_generators (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      tax_generators (SUB (p));
+
+      if (IS (p, GENERATOR))
+	{
+	  if (IS (SUB (p), LOC_SYMBOL))
+	    {
+	      TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (SUB (p)), GENERATOR);
+	      HEAP (z) = LOC_SYMBOL;
+	      USE (z) = true;
+	      TAX (p) = z;
+	    }
+	}
+    }
+}
+
+/* Find a firmly related operator for operands.  */
+
+static TAG_T *
+find_firmly_related_op (TABLE_T *c, const char *n, MOID_T *l, MOID_T *r, TAG_T *self)
+{
+  if (c != NO_TABLE)
+    {
+      TAG_T *s = OPERATORS (c);
+
+      for (; s != NO_TAG; FORWARD (s))
+	{
+	  if (s != self && NSYMBOL (NODE (s)) == n)
+	    {
+	      PACK_T *t = PACK (MOID (s));
+	      if (t != NO_PACK && a68_is_firm (MOID (t), l))
+		{
+		  /* catch monadic operator.  */
+		  if ((FORWARD (t)) == NO_PACK)
+		    {
+		      if (r == NO_MOID)
+			  return s;
+		    }
+		  else
+		    {
+		      /* catch dyadic operator.  */
+		      if (r != NO_MOID && a68_is_firm (MOID (t), r))
+			return s;
+		    }
+		}
+	    }
+	}
+    }
+  return NO_TAG;
+}
+
+/* Check for firmly related operators in this range.  */
+
+static void
+test_firmly_related_ops_local (NODE_T *p, TAG_T *s)
+{
+  if (s != NO_TAG)
+    {
+      PACK_T *u = PACK (MOID (s));
+
+      if (u != NO_PACK)
+	{
+	  MOID_T *l = MOID (u);
+	  MOID_T *r = (NEXT (u) != NO_PACK ? MOID (NEXT (u)) : NO_MOID);
+	  TAG_T *t = find_firmly_related_op (TAG_TABLE (s), NSYMBOL (NODE (s)), l, r, s);
+
+	  if (t != NO_TAG)
+	    {
+	      a68_error (p, "M Z is firmly related to M Z",
+			 MOID (s), NSYMBOL (NODE (s)), MOID (t),
+			 NSYMBOL (NODE (t)));
+	    }
+
+	  /* Warn for hidden firmly related operators defined in outer ranges,
+	     if requested.  */
+	  for (TABLE_T *prev = PREVIOUS (TAG_TABLE (s));
+	       prev != NO_TABLE;
+	       prev = PREVIOUS (prev))
+	    {
+	      TAG_T *t = find_firmly_related_op (prev, NSYMBOL (NODE (s)), l, r,
+						 NO_TAG /* self */);
+	      if (t != NO_TAG)
+		{
+		  if (TAG_TABLE (t) == A68_STANDENV)
+		    {
+		      if (a68_warning (p, OPT_Whidden_declarations,
+				       "'M Z' hides a firmly related operator in a larger reach",
+				       MOID (s), NSYMBOL (NODE (s))))
+			{
+			  a68_inform (NO_NODE,
+				      "operator 'M Z' defined in the standard prelude",
+				      MOID (t), NSYMBOL (NODE (t)));
+			}
+		    }
+		  else
+		    {
+		      if (a68_warning (p, OPT_Whidden_declarations,
+				       "'M Z' hides a firmly related operator in a larger reach",
+				       MOID (s), NSYMBOL (NODE (s))))
+			{
+			  a68_inform (NODE (t),
+				      "previous hidden declaration of S declared here",
+				      NSYMBOL (NODE (s)));
+			}
+		    }
+
+		  /* Report only one level of hidding or it gets messy.  */
+		  break;
+		}
+	    }
+	}
+      if (NEXT (s) != NO_TAG)
+	test_firmly_related_ops_local ((p == NO_NODE ? NO_NODE : NODE (NEXT (s))), NEXT (s));
+    }
+}
+
+/* Find firmly related operators in this program.  */
+
+static void
+test_firmly_related_ops (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (SUB (p) != NO_NODE && a68_is_new_lexical_level (p))
+	{
+	  TAG_T *oops = OPERATORS (TABLE (SUB (p)));
+
+	  if (oops != NO_TAG)
+	    test_firmly_related_ops_local (NODE (oops), oops);
+	}
+      test_firmly_related_ops (SUB (p));
+    }
+}
+
+/* Driver for the processing of TAXes.  */
+
+void
+a68_collect_taxes (NODE_T *p)
+{
+  tax_tags (p);
+  tax_specifiers (p);
+  tax_parameters (p);
+  tax_for_identifiers (p);
+  tax_routine_texts (p);
+  tax_pictures (p);
+  tax_format_texts (p);
+  tax_generators (p);
+  bind_identifier_tag_to_symbol_table (p);
+  bind_indicant_tag_to_symbol_table (p);
+  test_firmly_related_ops (p);
+  test_firmly_related_ops_local (NO_NODE, OPERATORS (A68_STANDENV));
+}
+
+/* Whether tag has already been declared in this range.  */
+
+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");
+}
+
+/* Whether tag has already been declared in this range.  */
+
+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");
+
+  TAG_T *s = a68_find_tag_global (PREVIOUS (TABLE (n)), a, NSYMBOL (n));
+  if (s != NO_TAG)
+    {
+      if (TAG_TABLE (s) == A68_STANDENV)
+	{
+	  a68_warning (n, OPT_Whidden_declarations,
+		       "declaration hides prelude declaration of M S",
+		       MOID (s), NSYMBOL (n));
+	}
+      else
+	{
+	  if (a68_warning (n, OPT_Whidden_declarations,
+			   "declaration hides a declaration of S with larger reach",
+			   NSYMBOL (n)))
+	    {
+	      a68_inform (NO_NODE,
+			  "previous hidden declaration of S declared here",
+			  NSYMBOL (n));
+	    }
+	}
+    }
+}
+
+/* Add tag to local symbol table.  */
+
+TAG_T *
+a68_add_tag (TABLE_T *s, int a, NODE_T *n, MOID_T *m, int p)
+{
+#define INSERT_TAG(l, n) {NEXT (n) = *(l); *(l) = (n);}
+  if (s != NO_TABLE)
+    {
+      TAG_T *z = a68_new_tag ();
+
+      TAG_TABLE (z) = s;
+      PRIO (z) = p;
+      MOID (z) = m;
+      NODE (z) = n;
+      /* TAX(n) = z;.  */
+      switch (a)
+	{
+	case IDENTIFIER:
+	  already_declared_hidden (n, IDENTIFIER);
+	  already_declared_hidden (n, LABEL);
+	  INSERT_TAG (&IDENTIFIERS (s), z);
+	  break;
+	case INDICANT:
+	  already_declared_hidden (n, INDICANT);
+	  already_declared (n, OP_SYMBOL);
+	  already_declared (n, PRIO_SYMBOL);
+	  INSERT_TAG (&INDICANTS (s), z);
+	  break;
+	case LABEL:
+	  already_declared_hidden (n, LABEL);
+	  already_declared_hidden (n, IDENTIFIER);
+	  INSERT_TAG (&LABELS (s), z);
+	  break;
+	case OP_SYMBOL:
+	  already_declared (n, INDICANT);
+	  INSERT_TAG (&OPERATORS (s), z);
+	  break;
+	case PRIO_SYMBOL:
+	  already_declared (n, PRIO_SYMBOL);
+	  already_declared (n, INDICANT);
+	  INSERT_TAG (&PRIO (s), z);
+	  break;
+	case ANONYMOUS:
+	  INSERT_TAG (&ANONYMOUS (s), z);
+	  break;
+	default:
+	  gcc_unreachable ();
+	}
+      return z;
+    }
+  else
+    return NO_TAG;
+}
+
+/* Find a tag, searching symbol tables towards the root.  */
+
+TAG_T *
+a68_find_tag_global (TABLE_T *table, int a, const char *name)
+{
+  if (table != NO_TABLE)
+    {
+      TAG_T *s = NO_TAG;
+      switch (a)
+	{
+	case IDENTIFIER:
+	  s = IDENTIFIERS (table);
+	  break;
+	case INDICANT:
+	  s = INDICANTS (table);
+	  break;
+	case LABEL:
+	  s = LABELS (table);
+	  break;
+	case OP_SYMBOL:
+	  s = OPERATORS (table);
+	  break;
+	case PRIO_SYMBOL:
+	  s = PRIO (table);
+	  break;
+	default:
+	  gcc_unreachable ();
+	  break;
+	}
+      
+      for (; s != NO_TAG; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    return s;
+	}
+      return a68_find_tag_global (PREVIOUS (table), a, name);
+    }
+  else
+    return NO_TAG;
+}
+
+/* Whether identifier or label global.  */
+
+int
+a68_is_identifier_or_label_global (TABLE_T *table, const char *name)
+{
+  if (table != NO_TABLE)
+    {
+      for (TAG_T *s = IDENTIFIERS (table); s != NO_TAG; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    return IDENTIFIER;
+	}
+      for (TAG_T *s = LABELS (table); s != NO_TAG; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    return LABEL;
+	}
+      return a68_is_identifier_or_label_global (PREVIOUS (table), name);
+    }
+  else
+    return 0;
+}
+
+/* Find a tag, searching only local symbol table.  */
+
+static TAG_T *
+find_tag_local (TABLE_T *table, int a, const char *name)
+{
+  if (table != NO_TABLE)
+    {
+      TAG_T *s = NO_TAG;
+
+      if (a == OP_SYMBOL)
+	s = OPERATORS (table);
+      else if (a == PRIO_SYMBOL)
+	s = PRIO (table);
+      else if (a == IDENTIFIER)
+	s = IDENTIFIERS (table);
+      else if (a == INDICANT)
+	s = INDICANTS (table);
+      else if (a == LABEL)
+	s = LABELS (table);
+      else
+	gcc_unreachable ();
+
+    for (; s != NO_TAG; FORWARD (s))
+      {
+	if (NSYMBOL (NODE (s)) == name)
+	  return s;
+      }
+    }
+  return NO_TAG;
+}
+
+/* Whether context specifies HEAP or LOC for an identifier.  */
+
+static int
+tab_qualifier (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (a68_is_one_of (p, UNIT, ASSIGNATION, TERTIARY, SECONDARY, GENERATOR, STOP))
+	return tab_qualifier (SUB (p));
+      else if (a68_is_one_of (p, LOC_SYMBOL, HEAP_SYMBOL, STOP))
+	return ATTRIBUTE (p) == LOC_SYMBOL ? LOC_SYMBOL : HEAP_SYMBOL;
+      else
+	return LOC_SYMBOL;
+    }
+  else
+    return LOC_SYMBOL;
+}
+
+/* Enter identity declarations in the symbol table.  */
+
+static void
+tax_identity_dec (NODE_T *p, MOID_T **m)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, IDENTITY_DECLARATION))
+	{
+	  tax_identity_dec (SUB (p), m);
+	  tax_identity_dec (NEXT (p), m);
+	}
+      else if (IS (p, DECLARER))
+	{
+	  tax_tags (SUB (p));
+	  *m = MOID (p);
+	  tax_identity_dec (NEXT (p), m);
+	}
+      else if (IS (p, COMMA_SYMBOL))
+	{
+	  tax_identity_dec (NEXT (p), m);
+	}
+      else if (IS (p, DEFINING_IDENTIFIER))
+	{
+	  TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
+
+	  MOID (p) = *m;
+	  HEAP (entry) = LOC_SYMBOL;
+	  TAX (p) = entry;
+	  MOID (entry) = *m;
+	  if (ATTRIBUTE (*m) == REF_SYMBOL)
+	    HEAP (entry) = tab_qualifier (NEXT_NEXT (p));
+	  tax_identity_dec (NEXT_NEXT (p), m);
+	}
+      else
+	tax_tags (p);
+    }
+}
+
+/* Enter variable declarations in the symbol table.  */
+
+static void
+tax_variable_dec (NODE_T *p, int *q, MOID_T **m)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, VARIABLE_DECLARATION))
+	{
+	  tax_variable_dec (SUB (p), q, m);
+	  tax_variable_dec (NEXT (p), q, m);
+	}
+      else if (IS (p, DECLARER))
+	{
+	  tax_tags (SUB (p));
+	  *m = MOID (p);
+	  tax_variable_dec (NEXT (p), q, m);
+	}
+      else if (IS (p, QUALIFIER))
+	{
+	  *q = ATTRIBUTE (SUB (p));
+	  tax_variable_dec (NEXT (p), q, m);
+	}
+      else if (IS (p, COMMA_SYMBOL))
+	{
+	  tax_variable_dec (NEXT (p), q, m);
+	}
+      else if (IS (p, DEFINING_IDENTIFIER))
+	{
+	  TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
+
+	  MOID (p) = *m;
+	  TAX (p) = entry;
+	  HEAP (entry) = *q;
+	  if (*q == LOC_SYMBOL)
+	    {
+	      TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, SUB (*m), GENERATOR);
+	      HEAP (z) = LOC_SYMBOL;
+	      USE (z) = true;
+	      BODY (entry) = z;
+	    }
+	  else
+	    {
+	      BODY (entry) = NO_TAG;
+	    }
+	  MOID (entry) = *m;
+	  tax_variable_dec (NEXT (p), q, m);
+	}
+      else
+	tax_tags (p);
+    }
+}
+
+/* Enter procedure variable declarations in the symbol table.  */
+
+static void
+tax_proc_variable_dec (NODE_T *p, int *q)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, PROCEDURE_VARIABLE_DECLARATION))
+	{
+	  tax_proc_variable_dec (SUB (p), q);
+	  tax_proc_variable_dec (NEXT (p), q);
+	}
+      else if (IS (p, QUALIFIER))
+	{
+	  *q = ATTRIBUTE (SUB (p));
+	  tax_proc_variable_dec (NEXT (p), q);
+	}
+      else if (a68_is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP))
+	{
+	  tax_proc_variable_dec (NEXT (p), q);
+	}
+      else if (IS (p, DEFINING_IDENTIFIER))
+	{
+	  TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
+
+	  TAX (p) = entry;
+	  HEAP (entry) = *q;
+	  MOID (entry) = MOID (p);
+	  if (*q == LOC_SYMBOL)
+	    {
+	      TAG_T *z = a68_add_tag (TABLE (p), ANONYMOUS, p, SUB_MOID (p), GENERATOR);
+	      HEAP (z) = LOC_SYMBOL;
+	      USE (z) = true;
+	      BODY (entry) = z;
+	    }
+	  else
+	    {
+	      BODY (entry) = NO_TAG;
+	    }
+	  tax_proc_variable_dec (NEXT (p), q);
+	}
+      else
+	tax_tags (p);
+    }
+}
+
+/* Enter procedure declarations in the symbol table.  */
+
+static void
+tax_proc_dec (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, PROCEDURE_DECLARATION))
+	{
+	  tax_proc_dec (SUB (p));
+	  tax_proc_dec (NEXT (p));
+	}
+      else if (a68_is_one_of (p, PROC_SYMBOL, COMMA_SYMBOL, STOP))
+	{
+	  tax_proc_dec (NEXT (p));
+	}
+      else if (IS (p, DEFINING_IDENTIFIER))
+	{
+	  TAG_T *entry = find_tag_local (TABLE (p), IDENTIFIER, NSYMBOL (p));
+
+	  MOID_T *m = MOID (NEXT_NEXT (p));
+	  MOID (p) = m;
+	  TAX (p) = entry;
+	  HEAP (entry) = LOC_SYMBOL;
+	  MOID (entry) = m;
+	  tax_proc_dec (NEXT (p));
+	}
+      else
+	tax_tags (p);
+    }
+}
+
+/* Check validity of operator declaration.  */
+
+static void
+check_operator_dec (NODE_T *p, MOID_T *u)
+{
+  int k = 0;
+
+  if (u == NO_MOID)
+    {
+      NODE_T *pack = SUB_SUB (NEXT_NEXT (p)); /* Where the parameter pack
+						 is.  */
+      if (ATTRIBUTE (NEXT_NEXT (p)) != ROUTINE_TEXT)
+	pack = SUB (pack);
+      k = 1 + a68_count_operands (pack);
+    }
+  else
+    k = a68_count_pack_members (PACK (u));
+
+  if (k < 1 || k > 2)
+    {
+      a68_error (p, "incorrect number of operands for 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);
+    }
+  else if (k == 2 && !a68_find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p)))
+    {
+      a68_error (p, "dyadic S has no priority declaration");
+    }
+}
+
+/* Enter operator declarations in the symbol table.  */
+
+static void
+tax_op_dec (NODE_T *p, MOID_T **m)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, OPERATOR_DECLARATION))
+	{
+	  tax_op_dec (SUB (p), m);
+	  tax_op_dec (NEXT (p), m);
+	}
+      else if (IS (p, OPERATOR_PLAN))
+	{
+	  tax_tags (SUB (p));
+	  *m = MOID (p);
+	  tax_op_dec (NEXT (p), m);
+	}
+      else if (IS (p, OP_SYMBOL))
+	{
+	  tax_op_dec (NEXT (p), m);
+	}
+      else if (IS (p, COMMA_SYMBOL))
+	{
+	  tax_op_dec (NEXT (p), m);
+	}
+      else if (IS (p, DEFINING_OPERATOR))
+	{
+	  TAG_T *entry = OPERATORS (TABLE (p));
+	  check_operator_dec (p, *m);
+	  while (entry != NO_TAG && NODE (entry) != p)
+	    FORWARD (entry);
+	  MOID (p) = *m;
+	  TAX (p) = entry;
+	  HEAP (entry) = LOC_SYMBOL;
+	  MOID (entry) = *m;
+	  tax_op_dec (NEXT (p), m);
+	}
+      else
+	{
+	  tax_tags (p);
+	}
+    }
+}
+
+/* Enter brief operator declarations in the symbol table.  */
+
+static void
+tax_brief_op_dec (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, BRIEF_OPERATOR_DECLARATION))
+	{
+	  tax_brief_op_dec (SUB (p));
+	  tax_brief_op_dec (NEXT (p));
+	}
+      else if (a68_is_one_of (p, OP_SYMBOL, COMMA_SYMBOL, STOP))
+	{
+	  tax_brief_op_dec (NEXT (p));
+	}
+      else if (IS (p, DEFINING_OPERATOR))
+	{
+	  TAG_T *entry = OPERATORS (TABLE (p));
+	  MOID_T *m = MOID (NEXT_NEXT (p));
+	  check_operator_dec (p, NO_MOID);
+	  while (entry != NO_TAG && NODE (entry) != p)
+	    FORWARD (entry);
+	  MOID (p) = m;
+	  TAX (p) = entry;
+	  HEAP (entry) = LOC_SYMBOL;
+	  MOID (entry) = m;
+	  tax_brief_op_dec (NEXT (p));
+	}
+      else
+	{
+	  tax_tags (p);
+	}
+    }
+}
+
+/* Enter priority declarations in the symbol table.  */
+
+static void tax_prio_dec (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, PRIORITY_DECLARATION))
+	{
+	  tax_prio_dec (SUB (p));
+	  tax_prio_dec (NEXT (p));
+	}
+      else if (a68_is_one_of (p, PRIO_SYMBOL, COMMA_SYMBOL, STOP))
+	{
+	  tax_prio_dec (NEXT (p));
+	}
+      else if (IS (p, DEFINING_OPERATOR))
+	{
+	  TAG_T *entry = PRIO (TABLE (p));
+	  while (entry != NO_TAG && NODE (entry) != p)
+	    FORWARD (entry);
+	  MOID (p) = NO_MOID;
+	  TAX (p) = entry;
+	  HEAP (entry) = LOC_SYMBOL;
+	  tax_prio_dec (NEXT (p));
+	}
+      else
+	{
+	  tax_tags (p);
+	}
+    }
+}
+
+/* Enter TAXes in the symbol table.  */
+
+static void
+tax_tags (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      int heap = LOC_SYMBOL;
+      MOID_T *m = NO_MOID;
+
+      if (IS (p, IDENTITY_DECLARATION))
+	tax_identity_dec (p, &m);
+      else if (IS (p, VARIABLE_DECLARATION))
+	tax_variable_dec (p, &heap, &m);
+      else if (IS (p, PROCEDURE_DECLARATION))
+	tax_proc_dec (p);
+      else if (IS (p, PROCEDURE_VARIABLE_DECLARATION))
+	tax_proc_variable_dec (p, &heap);
+      else if (IS (p, OPERATOR_DECLARATION))
+	tax_op_dec (p, &m);
+      else if (IS (p, BRIEF_OPERATOR_DECLARATION))
+	tax_brief_op_dec (p);
+      else if (IS (p, PRIORITY_DECLARATION))
+	tax_prio_dec (p);
+      else
+      tax_tags (SUB (p));
+    }
+}
+
+/* Reset symbol table nest count.  */
+
+void
+a68_reset_symbol_table_nest_count (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (SUB (p) != NO_NODE && a68_is_new_lexical_level (p))
+	NEST (TABLE (SUB (p))) = A68 (symbol_table_count)++;
+      a68_reset_symbol_table_nest_count (SUB (p));
+    }
+}
+
+//! @brief Bind routines in symbol table to the tree.
+
+void
+a68_bind_routine_tags_to_tree (NODE_T *p)
+{
+  /* By inserting coercions etc. some may have shifted.  */
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, ROUTINE_TEXT) && TAX (p) != NO_TAG)
+	NODE (TAX (p)) = p;
+      a68_bind_routine_tags_to_tree (SUB (p));
+    }
+}
+
+/* Bind formats in symbol table to tree.  */
+
+static void
+bind_format_tags_to_tree (NODE_T *p)
+{
+  /* By inserting coercions etc. some may have shifted.  */
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, FORMAT_TEXT) && TAX (p) != NO_TAG)
+	NODE (TAX (p)) = p;
+      else if (IS (p, FORMAT_DELIMITER_SYMBOL) && NEXT (p) != NO_NODE && TAX (p) != NO_TAG)
+	NODE (TAX (p)) = p;
+
+      bind_format_tags_to_tree (SUB (p));
+    }
+}
+
+/* Fill outer level of symbol table.  */
+
+void
+a68_fill_symbol_table_outer (NODE_T *p, TABLE_T *s)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (TABLE (p) != NO_TABLE)
+	OUTER (TABLE (p)) = s;
+
+      if (SUB (p) != NO_NODE && IS (p, ROUTINE_TEXT))
+	a68_fill_symbol_table_outer (SUB (p), TABLE (SUB (p)));
+      else if (SUB (p) != NO_NODE && IS (p, FORMAT_TEXT))
+	a68_fill_symbol_table_outer (SUB (p), TABLE (SUB (p)));
+      else
+	a68_fill_symbol_table_outer (SUB (p), s);
+    }
+}
+
+/* Flood branch in tree with local symbol table S.  */
+
+static void
+flood_with_symbol_table_restricted (NODE_T *p, TABLE_T *s)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      TABLE (p) = s;
+      if (ATTRIBUTE (p) != ROUTINE_TEXT && ATTRIBUTE (p) != SPECIFIED_UNIT)
+	{
+	  if (a68_is_new_lexical_level (p))
+	    PREVIOUS (TABLE (SUB (p))) = s;
+	  else
+	    flood_with_symbol_table_restricted (SUB (p), s);
+	}
+    }
+}
+
+/* Final structure of symbol table after parsing.  */
+
+void
+a68_finalise_symbol_table_setup (NODE_T *p, int l)
+{
+  TABLE_T *s = TABLE (p);
+  NODE_T *q = p;
+
+  while (q != NO_NODE)
+    {
+      /* routine texts are ranges.  */
+      if (IS (q, ROUTINE_TEXT))
+	flood_with_symbol_table_restricted (SUB (q), a68_new_symbol_table (s));
+
+      /* specifiers are ranges.  */
+      else if (IS (q, SPECIFIED_UNIT))
+	flood_with_symbol_table_restricted (SUB (q), a68_new_symbol_table (s));
+
+      /* level count and recursion.  */
+      if (SUB (q) != NO_NODE)
+	{
+	  if (a68_is_new_lexical_level (q))
+	    {
+	      LEX_LEVEL (SUB (q)) = l + 1;
+	      PREVIOUS (TABLE (SUB (q))) = s;
+	      a68_finalise_symbol_table_setup (SUB (q), l + 1);
+	      if (IS (q, WHILE_PART))
+		{
+		  /* This was a bug that went unnoticed for 15 years!.  */
+		  TABLE_T *s2 = TABLE (SUB (q));
+		  if ((FORWARD (q)) == NO_NODE)
+		    return;
+		  if (IS (q, ALT_DO_PART))
+		    {
+		      PREVIOUS (TABLE (SUB (q))) = s2;
+		      LEX_LEVEL (SUB (q)) = l + 2;
+		      a68_finalise_symbol_table_setup (SUB (q), l + 2);
+		    }
+		}
+	    }
+	  else
+	    {
+	      TABLE (SUB (q)) = s;
+	      a68_finalise_symbol_table_setup (SUB (q), l);
+	    }
+	}
+      TABLE (q) = s;
+
+      if (IS (q, FOR_SYMBOL))
+	FORWARD (q);
+      FORWARD (q);
+    }
+
+  /* FOR identifiers are in the DO ... OD range.  */
+  for (q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, FOR_SYMBOL))
+	TABLE (NEXT (q)) = TABLE (SEQUENCE (NEXT (q)));
+    }
+}
+
+/* First structure of symbol table for parsing.  */
+
+void
+a68_preliminary_symbol_table_setup (NODE_T *p)
+{
+  TABLE_T *s = TABLE (p);
+  bool not_a_for_range = false;
+
+  /* Let the tree point to the current symbol table.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    TABLE (q) = s;
+
+  /* insert new tables when required.  */
+  for (NODE_T *q = p; q != NO_NODE && !not_a_for_range; FORWARD (q))
+    {
+      if (SUB (q) != NO_NODE)
+	{
+	  /* BEGIN ... END, CODE ... EDOC, DEF ... FED, DO ... OD, $ ... $,
+	     { ... } are ranges.  */
+	  if (a68_is_one_of (q, BEGIN_SYMBOL, DO_SYMBOL, ALT_DO_SYMBOL,
+			     FORMAT_DELIMITER_SYMBOL, STOP))
+	    {
+	      TABLE (SUB (q)) = a68_new_symbol_table (s);
+	      a68_preliminary_symbol_table_setup (SUB (q));
+	    }
+	  /* ( ... ) is a range.   */
+	  else if (IS (q, OPEN_SYMBOL))
+	    {
+	      if (a68_whether (q, OPEN_SYMBOL, THEN_BAR_SYMBOL, STOP))
+		{
+		  TABLE (SUB (q)) = s;
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		  FORWARD (q);
+		  TABLE (SUB (q)) = a68_new_symbol_table (s);
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		  if ((FORWARD (q)) == NO_NODE)
+		    not_a_for_range = true;
+		  else
+		    {
+		      if (IS (q, THEN_BAR_SYMBOL))
+			{
+			  TABLE (SUB (q)) = a68_new_symbol_table (s);
+			  a68_preliminary_symbol_table_setup (SUB (q));
+			}
+		      if (IS (q, OPEN_SYMBOL))
+			{
+			  TABLE (SUB (q)) = a68_new_symbol_table (s);
+			  a68_preliminary_symbol_table_setup (SUB (q));
+			}
+		    }
+		}
+	      else
+		{
+		  /* Don't worry about STRUCT (...), UNION (...), PROC (...)
+		     yet.  */
+		  TABLE (SUB (q)) = a68_new_symbol_table (s);
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		}
+	    }
+	  /* IF ... THEN ... ELSE ... FI are ranges.  */
+	  else if (IS (q, IF_SYMBOL))
+	    {
+	      if (a68_whether (q, IF_SYMBOL, THEN_SYMBOL, STOP))
+		{
+		  TABLE (SUB (q)) = s;
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		  FORWARD (q);
+		  TABLE (SUB (q)) = a68_new_symbol_table (s);
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		  if ((FORWARD (q)) == NO_NODE)
+		    not_a_for_range = true;
+		  else
+		    if (IS (q, ELSE_SYMBOL))
+		      {
+			TABLE (SUB (q)) = a68_new_symbol_table (s);
+			a68_preliminary_symbol_table_setup (SUB (q));
+		      }
+		  if (IS (q, IF_SYMBOL))
+		    {
+		      TABLE (SUB (q)) = a68_new_symbol_table (s);
+		      a68_preliminary_symbol_table_setup (SUB (q));
+		    }
+		}
+	      else
+		{
+		  TABLE (SUB (q)) = a68_new_symbol_table (s);
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		}
+	    }
+	  /* CASE ... IN ... OUT ... ESAC are ranges.  */
+	  else if (IS (q, CASE_SYMBOL))
+	    {
+	      if (a68_whether (q, CASE_SYMBOL, IN_SYMBOL, STOP))
+		{
+		  TABLE (SUB (q)) = s;
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		  FORWARD (q);
+		  TABLE (SUB (q)) = a68_new_symbol_table (s);
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		  if ((FORWARD (q)) == NO_NODE)
+		    not_a_for_range = true;
+		  else
+		    {
+		      if (IS (q, OUT_SYMBOL))
+			{
+			  TABLE (SUB (q)) = a68_new_symbol_table (s);
+			  a68_preliminary_symbol_table_setup (SUB (q));
+			}
+		      if (IS (q, CASE_SYMBOL))
+			{
+			  TABLE (SUB (q)) = a68_new_symbol_table (s);
+			  a68_preliminary_symbol_table_setup (SUB (q));
+			}
+		    }
+		}
+	      else
+		{
+		  TABLE (SUB (q)) = a68_new_symbol_table (s);
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		}
+	    }
+	  /* WHILE ... DO ... OD are ranges.  */
+	  else if (IS (q, WHILE_SYMBOL))
+	    {
+	      TABLE_T *u = a68_new_symbol_table (s);
+	      TABLE (SUB (q)) = u;
+	      a68_preliminary_symbol_table_setup (SUB (q));
+	      if ((FORWARD (q)) == NO_NODE)
+		not_a_for_range = true;
+	      else if (IS (q, ALT_DO_SYMBOL))
+		{
+		  TABLE (SUB (q)) = a68_new_symbol_table (u);
+		  a68_preliminary_symbol_table_setup (SUB (q));
+		}
+	    }
+	  else
+	    {
+	      TABLE (SUB (q)) = s;
+	      a68_preliminary_symbol_table_setup (SUB (q));
+	    }
+	}
+    }
+  /* FOR identifiers will go to the DO ... OD range.  */
+  if (!not_a_for_range)
+    {
+      for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+	{
+	  if (IS (q, FOR_SYMBOL))
+	    {
+	      NODE_T *r = q;
+	      TABLE (NEXT (q)) = NO_TABLE;
+	      for (; r != NO_NODE && TABLE (NEXT (q)) == NO_TABLE; FORWARD (r))
+		{
+		  if ((a68_is_one_of (r, WHILE_SYMBOL, ALT_DO_SYMBOL, STOP))
+		      && (NEXT (q) != NO_NODE && SUB (r) != NO_NODE))
+		    {
+		      TABLE (NEXT (q)) = TABLE (SUB (r));
+		      SEQUENCE (NEXT (q)) = SUB (r);
+		    }
+		}
+	    }
+	}
+    }
+}
+
+/* Mark a mode as in use.  */
+
+static void
+mark_mode (MOID_T *m)
+{
+  if (m != NO_MOID && USE (m) == false)
+    {
+      PACK_T *p = PACK (m);
+      USE (m) = true;
+      for (; p != NO_PACK; FORWARD (p))
+	{
+	  mark_mode (MOID (p));
+	  mark_mode (SUB (m));
+	  mark_mode (SLICE (m));
+	}
+    }
+}
+
+//! @brief Traverse tree and mark modes as used.
+
+void
+a68_mark_moids (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      a68_mark_moids (SUB (p));
+      if (MOID (p) != NO_MOID)
+	mark_mode (MOID (p));
+    }
+}
+
+/* Mark various tags as used.  */
+
+void
+a68_mark_auxilliary (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (SUB (p) != NO_NODE)
+	{
+	  /* You get no warnings on unused PROC parameters. That is ok since
+	     A68 has some parameters that you may not use at all - think of
+	     PROC (REF FILE) BOOL event routines in transput.  */
+	  a68_mark_auxilliary (SUB (p));
+	}
+      else if (IS (p, OPERATOR))
+	{
+	  TAG_T *z;
+
+	  if (TAX (p) != NO_TAG)
+	    USE (TAX (p)) = true;
+	  
+	  if ((z = a68_find_tag_global (TABLE (p), PRIO_SYMBOL, NSYMBOL (p))) != NO_TAG)
+	    USE (z) = true;
+	}
+      else if (IS (p, INDICANT))
+	{
+	  TAG_T *z = a68_find_tag_global (TABLE (p), INDICANT, NSYMBOL (p));
+
+	  if (z != NO_TAG)
+	    {
+	      TAX (p) = z;
+	      USE (z) = true;
+	    }
+	}
+      else if (IS (p, IDENTIFIER))
+	{
+	  if (TAX (p) != NO_TAG)
+	    USE (TAX (p)) = true;
+	}
+    }
+}
+
+/* Check a single tag.  */
+
+static void
+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));
+    }
+}
+
+/* Driver for traversing tree and warn for unused tags.  */
+
+void
+a68_warn_for_unused_tags (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (SUB (p) != NO_NODE)
+	{
+	  if (a68_is_new_lexical_level (p))
+	    {
+	      unused (OPERATORS (TABLE (SUB (p))));
+	      unused (PRIO (TABLE (SUB (p))));
+	      unused (IDENTIFIERS (TABLE (SUB (p))));
+	      unused (LABELS (TABLE (SUB (p))));
+	      unused (INDICANTS (TABLE (SUB (p))));
+	    }
+	}
+      a68_warn_for_unused_tags (SUB (p));
+    }
+}
+
+/* Mark jumps and procedured jumps.  */
+
+void
+a68_jumps_from_procs (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, PROCEDURING))
+	{
+	  NODE_T *u = SUB_SUB (p);
+
+	  if (IS (u, GOTO_SYMBOL))
+	    FORWARD (u);
+	  USE (TAX (u)) = true;
+	}
+      else if (IS (p, JUMP))
+	{
+	  NODE_T *u = SUB (p);
+
+	  if (IS (u, GOTO_SYMBOL))
+	    FORWARD (u);
+	  if ((TAX (u) == NO_TAG) && (MOID (u) == NO_MOID)
+	      && (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");
+	    }
+	  else
+	    USE (TAX (u)) = true;
+	}
+      else
+	a68_jumps_from_procs (SUB (p));
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 25/47] a68: parser: static scope checker
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (23 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 24/47] a68: parser: symbol table management Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 26/47] a68: parser: debug facilities Jose E. Marchesi
                   ` (22 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-scope.cc | 975 ++++++++++++++++++++++++++++++++
 1 file changed, 975 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-scope.cc

diff --git a/gcc/algol68/a68-parser-scope.cc b/gcc/algol68/a68-parser-scope.cc
new file mode 100644
index 00000000000..990e7ec857e
--- /dev/null
+++ b/gcc/algol68/a68-parser-scope.cc
@@ -0,0 +1,975 @@
+/* Static scope checker.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+/* A static scope checker inspects the source. Note that ALGOL 68 also needs
+   dynamic scope checking. This phase concludes the parser.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+typedef struct TUPLE_T TUPLE_T;
+typedef struct SCOPE_T SCOPE_T;
+
+struct TUPLE_T
+{
+  int level;
+  bool transient;
+};
+
+struct SCOPE_T
+{
+  NODE_T *where;
+  TUPLE_T tuple;
+  SCOPE_T *next;
+};
+
+enum { NOT_TRANSIENT = 0, TRANSIENT };
+
+static void gather_scopes_for_youngest (NODE_T *, SCOPE_T **);
+static void scope_statement (NODE_T *, SCOPE_T **);
+static void scope_enclosed_clause (NODE_T *, SCOPE_T **);
+static void scope_formula (NODE_T *, SCOPE_T **);
+static void scope_routine_text (NODE_T *, SCOPE_T **);
+
+/*
+ * Static scope checker.
+ */
+
+/* Scope_make_tuple.  */
+
+static TUPLE_T
+scope_make_tuple (int e, int t)
+{
+  static TUPLE_T z;
+  LEVEL (&z) = e;
+  TRANSIENT (&z) = t;
+  return z;
+}
+
+/* Link scope information into the list.  */
+
+static void
+scope_add (SCOPE_T **sl, NODE_T *p, TUPLE_T tup)
+{
+  if (sl != NO_VAR)
+    {
+      SCOPE_T *ns = (SCOPE_T *) xmalloc (sizeof (SCOPE_T));
+      WHERE (ns) = p;
+      TUPLE (ns) = tup;
+      NEXT (ns) = *sl;
+      *sl = ns;
+    }
+}
+
+/* Scope_check.  */
+
+static bool
+scope_check (SCOPE_T *top, int mask, int dest)
+{
+  int errors = 0;
+
+  /* Transient names cannot be stored.  */
+  if (mask & TRANSIENT)
+    {
+      for (SCOPE_T *s = top; s != NO_SCOPE; FORWARD (s))
+	{
+	  if (TRANSIENT (&TUPLE (s)) & TRANSIENT)
+	    {
+	      a68_error (WHERE (s), "attempt at storing a transient name");
+	      STATUS_SET (WHERE (s), SCOPE_ERROR_MASK);
+	      errors++;
+	    }
+	}
+    }
+
+  /* Potential scope violations.  */
+  for (SCOPE_T *s = top; s != NO_SCOPE; FORWARD (s))
+    {
+      if (dest < LEVEL (&TUPLE (s)) && !STATUS_TEST (WHERE (s), SCOPE_ERROR_MASK))
+	{
+	  MOID_T *ws = MOID (WHERE (s));
+
+	  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)));
+	    }
+	  STATUS_SET (WHERE (s), SCOPE_ERROR_MASK);
+	  errors++;
+	}
+    }
+  return (errors == 0);
+}
+
+/* Scope_check_multiple.  */
+
+static bool
+scope_check_multiple (SCOPE_T *top, int mask, SCOPE_T *dest)
+{
+  bool no_err = true;
+
+  for (; dest != NO_SCOPE; FORWARD (dest))
+    no_err = no_err && scope_check (top, mask, LEVEL (&TUPLE (dest)));
+  return no_err;
+}
+
+/* Check_identifier_usage.  */
+
+static void
+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");
+      check_identifier_usage (t, SUB (p));
+    }
+}
+
+/* Scope_find_youngest_outside.  */
+
+static TUPLE_T
+scope_find_youngest_outside (SCOPE_T *s, int treshold)
+{
+  TUPLE_T z = scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT);
+
+  for (; s != NO_SCOPE; FORWARD (s))
+    {
+      if (LEVEL (&TUPLE (s)) > LEVEL (&z) && LEVEL (&TUPLE (s)) <= treshold)
+	z = TUPLE (s);
+    }
+  return z;
+}
+
+/* Scope_find_youngest.  */
+
+static TUPLE_T
+scope_find_youngest (SCOPE_T *s)
+{
+  return scope_find_youngest_outside (s, INT_MAX);
+}
+
+/*
+ * Routines for determining scope of ROUTINE TEXT or FORMAT TEXT.
+ */
+
+/* Get_declarer_elements.  */
+
+static void
+get_declarer_elements (NODE_T *p, SCOPE_T **r, bool no_ref)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, BOUNDS))
+	gather_scopes_for_youngest (SUB (p), r);
+      else if (IS (p, INDICANT))
+	{
+	  if (MOID (p) != NO_MOID && TAX (p) != NO_TAG && HAS_ROWS (MOID (p)) && no_ref)
+	    scope_add (r, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT));
+	}
+      else if (IS_REF (p))
+	get_declarer_elements (NEXT (p), r, false);
+      else if (a68_is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP))
+	;
+      else
+	{
+	  get_declarer_elements (SUB (p), r, no_ref);
+	  get_declarer_elements (NEXT (p), r, no_ref);
+	}
+    }
+}
+
+/* Gather_scopes_for_youngest.  */
+
+static void
+gather_scopes_for_youngest (NODE_T *p, SCOPE_T **s)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if ((a68_is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP))
+	  && (YOUNGEST_ENVIRON (TAX (p)) == PRIMAL_SCOPE))
+	{
+	  SCOPE_T *t = NO_SCOPE;
+	  TUPLE_T tup;
+
+	  gather_scopes_for_youngest (SUB (p), &t);
+	  tup = scope_find_youngest_outside (t, LEX_LEVEL (p));
+	  YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup);
+	  /* Direct link into list iso "gather_scopes_for_youngest (SUB (p),
+	     s);".  */
+	  if (t != NO_SCOPE)
+	    {
+	      SCOPE_T *u = t;
+	      while (NEXT (u) != NO_SCOPE) {
+		FORWARD (u);
+	      }
+	      NEXT (u) = *s;
+	      (*s) = t;
+	    }
+	}
+      else if (a68_is_one_of (p, IDENTIFIER, OPERATOR, STOP))
+	{
+	  if (TAX (p) != NO_TAG && TAG_LEX_LEVEL (TAX (p)) != PRIMAL_SCOPE)
+	    scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT));
+	}
+      else if (IS (p, DECLARER))
+	get_declarer_elements (p, s, true);
+      else
+	gather_scopes_for_youngest (SUB (p), s);
+  }
+}
+
+/* Get_youngest_environs.  */
+
+static void
+get_youngest_environs (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (a68_is_one_of (p, ROUTINE_TEXT, FORMAT_TEXT, STOP))
+	{
+	  SCOPE_T *s = NO_SCOPE;
+	  TUPLE_T tup;
+	  gather_scopes_for_youngest (SUB (p), &s);
+	  tup = scope_find_youngest_outside (s, LEX_LEVEL (p));
+	  YOUNGEST_ENVIRON (TAX (p)) = LEVEL (&tup);
+	}
+      else
+	get_youngest_environs (SUB (p));
+  }
+}
+
+/* Bind_scope_to_tag.  */
+
+static void
+bind_scope_to_tag (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, DEFINING_IDENTIFIER) && MOID (p) == M_FORMAT)
+	{
+	  if (IS (NEXT_NEXT (p), FORMAT_TEXT))
+	    {
+	      SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p)));
+	      SCOPE_ASSIGNED (TAX (p)) = true;
+	    }
+	  return;
+	}
+      else if (IS (p, DEFINING_IDENTIFIER))
+	{
+	  if (IS (NEXT_NEXT (p), ROUTINE_TEXT))
+	    {
+	      SCOPE (TAX (p)) = YOUNGEST_ENVIRON (TAX (NEXT_NEXT (p)));
+	      SCOPE_ASSIGNED (TAX (p)) = true;
+	    }
+	  return;
+	}
+      else
+	bind_scope_to_tag (SUB (p));
+  }
+}
+
+/* Bind_scope_to_tags.  */
+
+static void
+bind_scope_to_tags (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (a68_is_one_of (p, PROCEDURE_DECLARATION, IDENTITY_DECLARATION, STOP))
+	bind_scope_to_tag (SUB (p));
+      else
+	bind_scope_to_tags (SUB (p));
+    }
+}
+
+/* Scope_bounds.  */
+
+static void
+scope_bounds (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, UNIT))
+	scope_statement (p, NO_VAR);
+      else
+	scope_bounds (SUB (p));
+    }
+}
+
+/* Scope_declarer.  */
+
+static void
+scope_declarer (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, BOUNDS))
+	scope_bounds (SUB (p));
+      else if (IS (p, INDICANT))
+	;
+      else if (IS_REF (p))
+	scope_declarer (NEXT (p));
+      else if (a68_is_one_of (p, PROC_SYMBOL, UNION_SYMBOL, STOP))
+	;
+      else
+	{
+	  scope_declarer (SUB (p));
+	  scope_declarer (NEXT (p));
+	}
+    }
+}
+
+/* Scope_identity_declaration.  */
+
+static void
+scope_identity_declaration (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      scope_identity_declaration (SUB (p));
+
+      if (IS (p, DEFINING_IDENTIFIER))
+	{
+	  NODE_T *unit = NEXT_NEXT (p);
+	  SCOPE_T *s = NO_SCOPE;
+	  TUPLE_T tup;
+	  int z = PRIMAL_SCOPE;
+
+	  if (ATTRIBUTE (MOID (TAX (p))) != PROC_SYMBOL)
+	    check_identifier_usage (TAX (p), unit);
+	  scope_statement (unit, &s);
+	  (void) scope_check (s, TRANSIENT, LEX_LEVEL (p));
+	  tup = scope_find_youngest (s);
+	  z = LEVEL (&tup);
+	  if (z < LEX_LEVEL (p))
+	    {
+	      SCOPE (TAX (p)) = z;
+	      SCOPE_ASSIGNED (TAX (p)) = true;
+	    }
+	  return;
+	}
+    }
+}
+
+/* Scope_variable_declaration.  */
+
+static void
+scope_variable_declaration (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      scope_variable_declaration (SUB (p));
+      if (IS (p, DECLARER))
+	scope_declarer (SUB (p));
+      else if (IS (p, DEFINING_IDENTIFIER))
+	{
+	  if (a68_whether (p, DEFINING_IDENTIFIER, ASSIGN_SYMBOL, UNIT, STOP))
+	    {
+	      NODE_T *unit = NEXT_NEXT (p);
+	      SCOPE_T *s = NO_SCOPE;
+	      check_identifier_usage (TAX (p), unit);
+	      scope_statement (unit, &s);
+	      (void) scope_check (s, TRANSIENT, LEX_LEVEL (p));
+	      return;
+	    }
+	}
+    }
+}
+
+/* Scope_procedure_declaration.  */
+
+static void
+scope_procedure_declaration (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      scope_procedure_declaration (SUB (p));
+
+      if (a68_is_one_of (p, DEFINING_IDENTIFIER, DEFINING_OPERATOR, STOP))
+	{
+	  NODE_T *unit = NEXT_NEXT (p);
+	  SCOPE_T *s = NO_SCOPE;
+
+	  scope_statement (unit, &s);
+	  (void) scope_check (s, NOT_TRANSIENT, LEX_LEVEL (p));
+	  return;
+	}
+    }
+}
+
+/* Scope_declaration_list.  */
+
+static void
+scope_declaration_list (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, IDENTITY_DECLARATION))
+	scope_identity_declaration (SUB (p));
+      else if (IS (p, VARIABLE_DECLARATION))
+	scope_variable_declaration (SUB (p));
+      else if (IS (p, MODE_DECLARATION))
+	scope_declarer (SUB (p));
+      else if (IS (p, PRIORITY_DECLARATION))
+	;
+      else if (IS (p, PROCEDURE_DECLARATION))
+       scope_procedure_declaration (SUB (p));
+      else if (IS (p, PROCEDURE_VARIABLE_DECLARATION))
+	scope_procedure_declaration (SUB (p));
+      else if (a68_is_one_of (p, BRIEF_OPERATOR_DECLARATION, OPERATOR_DECLARATION, STOP))
+	scope_procedure_declaration (SUB (p));
+      else
+	{
+	  scope_declaration_list (SUB (p));
+	  scope_declaration_list (NEXT (p));
+	}
+    }
+}
+
+/* Scope_arguments.  */
+
+static void
+scope_arguments (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, UNIT))
+	{
+	  SCOPE_T *s = NO_SCOPE;
+	  scope_statement (p, &s);
+	  (void) scope_check (s, TRANSIENT, LEX_LEVEL (p));
+	}
+      else
+	scope_arguments (SUB (p));
+  }
+}
+
+/* Is_coercion.  */
+
+static bool
+is_coercion (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case DEPROCEDURING:
+	case DEREFERENCING:
+	case UNITING:
+	case ROWING:
+	case WIDENING:
+	case VOIDING:
+	case PROCEDURING:
+	  return true;
+	default:
+	  return false;
+	}
+    }
+  else
+    return false;
+}
+
+/* Scope_coercion.  */
+
+static void
+scope_coercion (NODE_T *p, SCOPE_T **s)
+{
+  if (is_coercion (p))
+    {
+      if (IS (p, VOIDING))
+	scope_coercion (SUB (p), NO_VAR);
+      else if (IS (p, DEREFERENCING))
+	/* Leave this to the dynamic scope checker.  */
+	scope_coercion (SUB (p), NO_VAR);
+      else if (IS (p, DEPROCEDURING))
+	scope_coercion (SUB (p), NO_VAR);
+      else if (IS (p, ROWING))
+	{
+	  SCOPE_T *z = NO_SCOPE;
+
+	  scope_coercion (SUB (p), &z);
+	  (void) scope_check (z, TRANSIENT, LEX_LEVEL (p));
+	  if (IS_REF_FLEX (MOID (SUB (p))))
+	    scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT));
+	  else
+	    scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT));
+	}
+      else if (IS (p, PROCEDURING))
+	{
+	  /* Can only be a JUMP.  */
+	  NODE_T *q = SUB_SUB (p);
+	  if (IS (q, GOTO_SYMBOL))
+	    FORWARD (q);
+
+	  scope_add (s, q, scope_make_tuple (TAG_LEX_LEVEL (TAX (q)), NOT_TRANSIENT));
+	}
+      else if (IS (p, UNITING))
+	{
+	  SCOPE_T *z = NO_SCOPE;
+
+	  scope_coercion (SUB (p), &z);
+	  if (z != NO_SCOPE)
+	    {
+	      (void) scope_check (z, TRANSIENT, LEX_LEVEL (p));
+	      scope_add (s, p, scope_find_youngest (z));
+	    }
+	}
+      else
+	scope_coercion (SUB (p), s);
+    }
+  else
+    scope_statement (p, s);
+}
+
+/* Scope_format_text.  */
+
+static void
+scope_format_text (NODE_T *p, SCOPE_T **s)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, FORMAT_PATTERN))
+	scope_enclosed_clause (SUB (NEXT_SUB (p)), s);
+      else if (IS (p, FORMAT_ITEM_G) && NEXT (p) != NO_NODE)
+	scope_enclosed_clause (SUB_NEXT (p), s);
+      else if (IS (p, DYNAMIC_REPLICATOR))
+	scope_enclosed_clause (SUB (NEXT_SUB (p)), s);
+      else
+	scope_format_text (SUB (p), s);
+    }
+}
+
+/* Scope_operand.  */
+
+static void
+scope_operand (NODE_T *p, SCOPE_T **s)
+{
+  if (IS (p, MONADIC_FORMULA))
+    scope_operand (NEXT_SUB (p), s);
+  else if (IS (p, FORMULA))
+    scope_formula (p, s);
+  else if (IS (p, SECONDARY))
+    scope_statement (SUB (p), s);
+}
+
+/* Scope_formula.  */
+
+static void
+scope_formula (NODE_T *p, SCOPE_T **s)
+{
+  NODE_T *q = SUB (p);
+  SCOPE_T *s2 = NO_SCOPE;
+
+  scope_operand (q, &s2);
+  (void) scope_check (s2, TRANSIENT, LEX_LEVEL (p));
+  if (NEXT (q) != NO_NODE)
+    {
+      SCOPE_T *s3 = NO_SCOPE;
+      scope_operand (NEXT_NEXT (q), &s3);
+      (void) scope_check (s3, TRANSIENT, LEX_LEVEL (p));
+    }
+  (void) s;
+}
+
+/* Scope_routine_text.  */
+
+static void
+scope_routine_text (NODE_T *p, SCOPE_T **s)
+{
+  NODE_T *q = SUB (p);
+  NODE_T *routine = (IS (q, PARAMETER_PACK) ? NEXT (q) : q);
+  SCOPE_T *x = NO_SCOPE;
+
+  scope_statement (NEXT_NEXT (routine), &x);
+  (void) scope_check (x, TRANSIENT, LEX_LEVEL (p));
+  TUPLE_T routine_tuple = scope_make_tuple (YOUNGEST_ENVIRON (TAX (p)), NOT_TRANSIENT);
+  scope_add (s, p, routine_tuple);
+}
+
+/* Scope_statement.  */
+
+static void
+scope_statement (NODE_T *p, SCOPE_T **s)
+{
+  if (is_coercion (p))
+    scope_coercion (p, s);
+  else if (a68_is_one_of (p, PRIMARY, SECONDARY, TERTIARY, UNIT, STOP))
+    scope_statement (SUB (p), s);
+  else if (a68_is_one_of (p, NIHIL, STOP))
+    scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT));
+  else if (IS (p, DENOTATION))
+    ;
+  else if (IS (p, IDENTIFIER))
+    {
+      if (IS_REF (MOID (p)))
+	{
+	  if (PRIO (TAX (p)) == PARAMETER_IDENTIFIER)
+	    scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)) - 1, NOT_TRANSIENT));
+	  else
+	    {
+	      if (HEAP (TAX (p)) == HEAP_SYMBOL)
+		scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT));
+	      else if (SCOPE_ASSIGNED (TAX (p)))
+		scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT));
+	      else
+		scope_add (s, p, scope_make_tuple (TAG_LEX_LEVEL (TAX (p)), NOT_TRANSIENT));
+	    }
+	}
+      else if (ATTRIBUTE (MOID (p)) == PROC_SYMBOL && SCOPE_ASSIGNED (TAX (p)) == true)
+	scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT));
+      else if (MOID (p) == M_FORMAT && SCOPE_ASSIGNED (TAX (p)) == true)
+	scope_add (s, p, scope_make_tuple (SCOPE (TAX (p)), NOT_TRANSIENT));
+    }
+  else if (IS (p, ENCLOSED_CLAUSE))
+    scope_enclosed_clause (SUB (p), s);
+  else if (IS (p, CALL))
+    {
+      SCOPE_T *x = NO_SCOPE;
+
+      scope_statement (SUB (p), &x);
+      (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p));
+      scope_arguments (NEXT_SUB (p));
+    }
+  else if (IS (p, SLICE))
+    {
+      SCOPE_T *x = NO_SCOPE;
+      MOID_T *m = MOID (SUB (p));
+
+      if (IS_REF (m))
+	{
+	  if (ATTRIBUTE (SUB (p)) == PRIMARY && ATTRIBUTE (SUB_SUB (p)) == SLICE)
+	    scope_statement (SUB (p), s);
+	  else
+	    {
+	      scope_statement (SUB (p), &x);
+	      (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p));
+	    }
+	  if (IS_FLEX (SUB (m)))
+	    scope_add (s, SUB (p), scope_make_tuple (LEX_LEVEL (p), TRANSIENT));
+	  scope_bounds (SUB (NEXT_SUB (p)));
+	}
+      if (IS_REF (MOID (p)))
+	scope_add (s, p, scope_find_youngest (x));
+    }
+  else if (IS (p, FORMAT_TEXT))
+    {
+      SCOPE_T *x = NO_SCOPE;
+      scope_format_text (SUB (p), &x);
+      scope_add (s, p, scope_find_youngest (x));
+    }
+  else if (IS (p, CAST))
+    {
+      SCOPE_T *x = NO_SCOPE;
+      scope_enclosed_clause (SUB (NEXT_SUB (p)), &x);
+      (void) scope_check (x, NOT_TRANSIENT, LEX_LEVEL (p));
+      scope_add (s, p, scope_find_youngest (x));
+    }
+  else if (IS (p, SELECTION))
+    {
+      SCOPE_T *ns = NO_SCOPE;
+      scope_statement (NEXT_SUB (p), &ns);
+      (void) scope_check (ns, NOT_TRANSIENT, LEX_LEVEL (p));
+      if (a68_is_ref_refety_flex (MOID (NEXT_SUB (p))))
+	scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), TRANSIENT));
+      scope_add (s, p, scope_find_youngest (ns));
+  }
+  else if (IS (p, GENERATOR))
+    {
+      if (IS (SUB (p), LOC_SYMBOL))
+	{
+	  if (NON_LOCAL (p) != NO_TABLE)
+	    scope_add (s, p, scope_make_tuple (LEVEL (NON_LOCAL (p)), NOT_TRANSIENT));
+	  else
+	    scope_add (s, p, scope_make_tuple (LEX_LEVEL (p), NOT_TRANSIENT));
+	}
+      else
+	scope_add (s, p, scope_make_tuple (PRIMAL_SCOPE, NOT_TRANSIENT));
+      scope_declarer (SUB (NEXT_SUB (p)));
+    }
+  else if (IS (p, FORMULA))
+    scope_formula (p, s);
+  else if (IS (p, ASSIGNATION))
+    {
+      NODE_T *unit = NEXT (NEXT_SUB (p));
+      SCOPE_T *ns = NO_SCOPE, *nd = NO_SCOPE;
+      TUPLE_T tup;
+      scope_statement (SUB_SUB (p), &nd);
+      scope_statement (unit, &ns);
+      (void) scope_check_multiple (ns, TRANSIENT, nd);
+      tup = scope_find_youngest (nd);
+      scope_add (s, p, scope_make_tuple (LEVEL (&tup), NOT_TRANSIENT));
+    }
+  else if (IS (p, ROUTINE_TEXT))
+    scope_routine_text (p, s);
+  else if (a68_is_one_of (p, IDENTITY_RELATION, AND_FUNCTION, OR_FUNCTION, STOP))
+    {
+      SCOPE_T *n = NO_SCOPE;
+      scope_statement (SUB (p), &n);
+      scope_statement (NEXT (NEXT_SUB (p)), &n);
+      (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p));
+    }
+  else if (IS (p, ASSERTION))
+    {
+      SCOPE_T *n = NO_SCOPE;
+      scope_enclosed_clause (SUB (NEXT_SUB (p)), &n);
+      (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p));
+    }
+  else if (a68_is_one_of (p, JUMP, SKIP, STOP))
+    {
+      ;
+    }
+}
+
+/* Scope_statement_list.  */
+
+static void
+scope_statement_list (NODE_T *p, SCOPE_T **s)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, UNIT))
+	scope_statement (p, s);
+      else
+	scope_statement_list (SUB (p), s);
+    }
+}
+
+/* Scope_serial_clause.  */
+
+static void
+scope_serial_clause (NODE_T *p, SCOPE_T **s, bool terminator)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, INITIALISER_SERIES))
+	{
+	  scope_serial_clause (SUB (p), s, false);
+	  scope_serial_clause (NEXT (p), s, terminator);
+	}
+      else if (IS (p, DECLARATION_LIST))
+	scope_declaration_list (SUB (p));
+      else if (a68_is_one_of (p, LABEL, SEMI_SYMBOL, EXIT_SYMBOL, STOP))
+	scope_serial_clause (NEXT (p), s, terminator);
+      else if (a68_is_one_of (p, SERIAL_CLAUSE, ENQUIRY_CLAUSE, STOP))
+	{
+	  if (NEXT (p) != NO_NODE)
+	    {
+	      int j = ATTRIBUTE (NEXT (p));
+	      if (j == EXIT_SYMBOL || j == END_SYMBOL || j == CLOSE_SYMBOL)
+		scope_serial_clause (SUB (p), s, true);
+	      else
+		scope_serial_clause (SUB (p), s, false);
+	    }
+	  else
+	    scope_serial_clause (SUB (p), s, true);
+	  scope_serial_clause (NEXT (p), s, terminator);
+	}
+      else if (IS (p, LABELED_UNIT))
+	scope_serial_clause (SUB (p), s, terminator);
+      else if (IS (p, UNIT))
+	{
+	  if (terminator)
+	    scope_statement (p, s);
+	  else
+	    scope_statement (p, NO_VAR);
+	}
+    }
+}
+
+/* Scope_closed_clause.  */
+
+static void
+scope_closed_clause (NODE_T *p, SCOPE_T **s)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, SERIAL_CLAUSE))
+	scope_serial_clause (p, s, true);
+      else if (a68_is_one_of (p, OPEN_SYMBOL, BEGIN_SYMBOL, STOP))
+	scope_closed_clause (NEXT (p), s);
+    }
+}
+
+/* Scope_collateral_clause.  */
+
+static void
+scope_collateral_clause (NODE_T *p, SCOPE_T **s)
+{
+  if (p != NO_NODE)
+    {
+      if (!(a68_whether (p, BEGIN_SYMBOL, END_SYMBOL, STOP)
+	    || a68_whether (p, OPEN_SYMBOL, CLOSE_SYMBOL, STOP)))
+	{
+	  scope_statement_list (p, s);
+	}
+    }
+}
+
+/* Scope_conditional_clause.  */
+
+static void
+scope_conditional_clause (NODE_T *p, SCOPE_T **s)
+{
+  scope_serial_clause (NEXT_SUB (p), NO_VAR, true);
+  FORWARD (p);
+  scope_serial_clause (NEXT_SUB (p), s, true);
+  if ((FORWARD (p)) != NO_NODE)
+    {
+      if (a68_is_one_of (p, ELSE_PART, CHOICE, STOP))
+	scope_serial_clause (NEXT_SUB (p), s, true);
+      else if (a68_is_one_of (p, ELIF_PART, BRIEF_ELIF_PART, STOP))
+	scope_conditional_clause (SUB (p), s);
+    }
+}
+
+/* Scope_case_clause.  */
+
+static void
+scope_case_clause (NODE_T *p, SCOPE_T **s)
+{
+  SCOPE_T *n = NO_SCOPE;
+  scope_serial_clause (NEXT_SUB (p), &n, true);
+  (void) scope_check (n, NOT_TRANSIENT, LEX_LEVEL (p));
+  FORWARD (p);
+  scope_statement_list (NEXT_SUB (p), s);
+  if ((FORWARD (p)) != NO_NODE)
+    {
+      if (a68_is_one_of (p, OUT_PART, CHOICE, STOP))
+	scope_serial_clause (NEXT_SUB (p), s, true);
+      else if (a68_is_one_of (p, CASE_OUSE_PART, BRIEF_OUSE_PART, STOP))
+	scope_case_clause (SUB (p), s);
+      else if (a68_is_one_of (p, CONFORMITY_OUSE_PART, BRIEF_CONFORMITY_OUSE_PART, STOP))
+	scope_case_clause (SUB (p), s);
+    }
+}
+
+/* Scope_loop_clause.  */
+
+static void
+scope_loop_clause (NODE_T *p)
+{
+  if (p != NO_NODE)
+    {
+      if (IS (p, FOR_PART))
+	scope_loop_clause (NEXT (p));
+      else if (a68_is_one_of (p, FROM_PART, BY_PART, TO_PART, STOP))
+	{
+	  scope_statement (NEXT_SUB (p), NO_VAR);
+	  scope_loop_clause (NEXT (p));
+	}
+      else if (IS (p, WHILE_PART))
+	{
+	  scope_serial_clause (NEXT_SUB (p), NO_VAR, true);
+	  scope_loop_clause (NEXT (p));
+	}
+      else if (a68_is_one_of (p, DO_PART, ALT_DO_PART, STOP))
+	{
+	  NODE_T *do_p = NEXT_SUB (p);
+
+	  if (IS (do_p, SERIAL_CLAUSE))
+	    scope_serial_clause (do_p, NO_VAR, true);
+	}
+    }
+}
+
+/* Scope_enclosed_clause.  */
+
+static void
+scope_enclosed_clause (NODE_T *p, SCOPE_T **s)
+{
+  if (IS (p, ENCLOSED_CLAUSE))
+    scope_enclosed_clause (SUB (p), s);
+  else if (IS (p, CLOSED_CLAUSE))
+    scope_closed_clause (SUB (p), s);
+  else if (a68_is_one_of (p, COLLATERAL_CLAUSE, PARALLEL_CLAUSE, STOP))
+    scope_collateral_clause (SUB (p), s);
+  else if (IS (p, CONDITIONAL_CLAUSE))
+    scope_conditional_clause (SUB (p), s);
+  else if (a68_is_one_of (p, CASE_CLAUSE, CONFORMITY_CLAUSE, STOP))
+    scope_case_clause (SUB (p), s);
+  else if (IS (p, LOOP_CLAUSE))
+    scope_loop_clause (SUB (p));
+}
+
+/* Whether a symbol table contains no (anonymous) definition.  */
+
+static bool
+empty_table (TABLE_T * t)
+{
+  if (IDENTIFIERS (t) == NO_TAG)
+    return (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG);
+  else if (PRIO (IDENTIFIERS (t)) == LOOP_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG)
+    return (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG);
+  else if (PRIO (IDENTIFIERS (t)) == SPECIFIER_IDENTIFIER && NEXT (IDENTIFIERS (t)) == NO_TAG)
+    return (OPERATORS (t) == NO_TAG && INDICANTS (t) == NO_TAG);
+  else
+    return false;
+}
+
+/* Indicate non-local environs.  */
+
+static void
+get_non_local_environs (NODE_T *p, int max)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, ROUTINE_TEXT))
+	get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p)));
+      else if (IS (p, FORMAT_TEXT))
+	get_non_local_environs (SUB (p), LEX_LEVEL (SUB (p)));
+      else
+	{
+	  get_non_local_environs (SUB (p), max);
+	  NON_LOCAL (p) = NO_TABLE;
+	  if (TABLE (p) != NO_TABLE)
+	    {
+	      TABLE_T *q = TABLE (p);
+	      while (q != NO_TABLE && empty_table (q)
+		     && PREVIOUS (q) != NO_TABLE && LEVEL (PREVIOUS (q)) >= max)
+		{
+		  NON_LOCAL (p) = PREVIOUS (q);
+		  q = PREVIOUS (q);
+		}
+	    }
+	}
+    }
+}
+
+/* The static scope checker.  */
+
+void
+a68_scope_checker (NODE_T *p)
+{
+  /* Establish scopes of routine texts and format texts.  */
+  get_youngest_environs (p);
+  /* Find non-local environs.  */
+  get_non_local_environs (p, PRIMAL_SCOPE);
+  /* PROC and FORMAT identities can now be assigned a scope.  */
+  bind_scope_to_tags (p);
+  /* Now check evertyhing else.  */
+  scope_enclosed_clause (SUB (p), NO_VAR);
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 26/47] a68: parser: debug facilities
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (24 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 25/47] a68: parser: static scope checker Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 27/47] a68: parser: extraction of tags from phrases Jose E. Marchesi
                   ` (21 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-parser-debug.cc: New file.
---
 gcc/algol68/a68-parser-debug.cc | 90 +++++++++++++++++++++++++++++++++
 1 file changed, 90 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-debug.cc

diff --git a/gcc/algol68/a68-parser-debug.cc b/gcc/algol68/a68-parser-debug.cc
new file mode 100644
index 00000000000..fb862407d2d
--- /dev/null
+++ b/gcc/algol68/a68-parser-debug.cc
@@ -0,0 +1,90 @@
+/* Debug facilities for the Algol 68 parser.
+   Copyright (C) 2025 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 "diagnostic.h"
+
+#include "a68.h"
+
+/* Write a printable representation of the parse tree with top node P to the
+   standard output.  */
+
+static void
+a68_dump_parse_tree_1 (NODE_T *p, int level)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      int i;
+      location_t loc = a68_get_node_location (p);
+
+      for (i = 0; i < level; ++i)
+	printf ("  ");
+      printf ("NODE %d::%s",
+	      NUMBER (p),
+	      a68_attribute_name (ATTRIBUTE (p)));
+
+      if (ATTRIBUTE (p) == IDENTIFIER
+	  || ATTRIBUTE (p) == DEFINING_IDENTIFIER
+	  || ATTRIBUTE (p) == DEFINING_OPERATOR
+	  || ATTRIBUTE (p) == BOLD_TAG)
+	printf (" %s", NSYMBOL (p));
+
+      if (MOID (p) != NO_MOID)
+	{
+	  MOID_T *moid = MOID (p);
+	  char b[BUFFER_SIZE];
+	  b[0] = '\0';
+
+	  if (IS (moid, SERIES_MODE))
+	    {
+	      if (PACK (moid) != NO_PACK && NEXT (PACK (moid)) == NO_PACK)
+		a68_bufcat (b, a68_moid_to_string (MOID (PACK (moid)), MOID_ERROR_WIDTH, p),
+			    BUFFER_SIZE);
+	      else
+		a68_bufcat (b, a68_moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
+	    }
+	  else
+	    a68_bufcat (b, a68_moid_to_string (moid, MOID_ERROR_WIDTH, p), BUFFER_SIZE);
+
+	  printf (" (%s)", b);
+	}
+      printf (" %s:%d:%d",
+	      LOCATION_FILE (loc), LOCATION_LINE (loc),	LOCATION_COLUMN (loc));
+      printf ("\n");
+      a68_dump_parse_tree_1 (SUB (p), level + 1);
+    }
+}
+
+void
+a68_dump_parse_tree (NODE_T *p)
+{
+  a68_dump_parse_tree_1 (p, 0);
+}
+
+void
+a68_dump_modes (MOID_T *moid)
+{
+  for (; moid != NO_MOID; FORWARD (moid))
+    {
+      printf ("%p %s\n", (void *) moid,
+	      a68_moid_to_string (moid, MOID_ERROR_WIDTH, NODE (moid),
+				  true /* indicant_value */));
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 27/47] a68: parser: extraction of tags from phrases
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (25 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 26/47] a68: parser: debug facilities Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 28/47] a68: parser: dynamic stack usage in serial clauses Jose E. Marchesi
                   ` (20 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Signed-off-by: Jose E. Marchesi <jemarch@gnu.org>
Co-authored-by: Marcel van der Veer <algol68g@xs4all.nl>
---
 gcc/algol68/a68-parser-extract.cc | 675 ++++++++++++++++++++++++++++++
 1 file changed, 675 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-extract.cc

diff --git a/gcc/algol68/a68-parser-extract.cc b/gcc/algol68/a68-parser-extract.cc
new file mode 100644
index 00000000000..b778be492c6
--- /dev/null
+++ b/gcc/algol68/a68-parser-extract.cc
@@ -0,0 +1,675 @@
+/* Extract tags from phrases.
+   Copyright (C) 2001-2023 J. Marcel van der Veer.
+   Copyright (C) 2025 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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "a68.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.
+  These routines do not look very elegant as they have to scan through all kind
+  of symbols to find a pattern that they recognise.  */
+
+/* Insert alt equals symbol.  */
+
+static void
+insert_alt_equals (NODE_T *p)
+{
+  NODE_T *q = a68_new_node ();
+  *q = *p;
+  INFO (q) = a68_new_node_info ();
+  *INFO (q) = *INFO (p);
+  GINFO (q) = a68_new_genie_info ();
+  *GINFO (q) = *GINFO (p);
+  ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+  NSYMBOL (q) = TEXT (a68_add_token (&A68 (top_token), "="));
+  NEXT (p) = q;
+  PREVIOUS (q) = p;
+  if (NEXT (q) != NO_NODE)
+    PREVIOUS (NEXT (q)) = q;
+}
+
+/* Detect redefined keyword.  */
+
+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);
+}
+
+/* Skip anything until a comma, semicolon or EXIT is found.  */
+
+static NODE_T *
+skip_unit (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, COMMA_SYMBOL))
+	return p;
+      else if (IS (p, SEMI_SYMBOL))
+	return p;
+      else if (IS (p, EXIT_SYMBOL))
+	return p;
+    }
+  return NO_NODE;
+}
+
+/* Attribute of entry in symbol table.  */
+
+static int
+find_tag_definition (TABLE_T *table, const char *name)
+{
+  if (table != NO_TABLE)
+    {
+      int ret = 0;
+      bool found = false;
+      for (TAG_T *s = INDICANTS (table); s != NO_TAG && !found; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    {
+	      ret += INDICANT;
+	      found = true;
+	    }
+	}
+      found = false;
+      for (TAG_T *s = OPERATORS (table); s != NO_TAG && !found; FORWARD (s))
+	{
+	  if (NSYMBOL (NODE (s)) == name)
+	    {
+	      ret += OPERATOR;
+	      found = true;
+	    }
+	}
+      if (ret == 0)
+	return find_tag_definition (PREVIOUS (table), name);
+      else
+	return ret;
+    }
+  else
+    return 0;
+}
+
+/* Fill in whether bold tag is operator or indicant.  */
+
+void
+a68_elaborate_bold_tags (NODE_T *p)
+{
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, BOLD_TAG))
+	{
+	  switch (find_tag_definition (TABLE (q), NSYMBOL (q)))
+	    {
+	    case 0:
+	      a68_error (q, "tag S has not been declared properly");
+	      break;
+	    case INDICANT:
+	      ATTRIBUTE (q) = INDICANT;
+	      break;
+	    case OPERATOR:
+	      ATTRIBUTE (q) = OPERATOR;
+	      break;
+	    }
+	}
+    }
+}
+
+/* Skip declarer, or argument pack and declarer.  */
+
+static NODE_T *
+skip_pack_declarer (NODE_T *p)
+{
+  /* Skip () REF [] REF FLEX [] [] ...  */
+  while (p != NO_NODE
+	 && (a68_is_one_of (p, SUB_SYMBOL, OPEN_SYMBOL, REF_SYMBOL,
+			    FLEX_SYMBOL, SHORT_SYMBOL, LONG_SYMBOL, STOP)))
+    {
+      FORWARD (p);
+    }
+
+  /* Skip STRUCT (), UNION () or PROC [()].  */
+  if (p != NO_NODE && (a68_is_one_of (p, STRUCT_SYMBOL, UNION_SYMBOL, STOP)))
+    return NEXT (p);
+  else if (p != NO_NODE && IS (p, PROC_SYMBOL))
+    return skip_pack_declarer (NEXT (p));
+  else
+    return p;
+}
+
+/* Search MODE A = .., B = .. and store indicants.  */
+
+void
+a68_extract_indicants (NODE_T *p)
+{
+  NODE_T *q = p;
+
+  while (q != NO_NODE)
+    {
+      if (IS (q, MODE_SYMBOL))
+	{
+	  bool siga = true;
+	  do
+	    {
+	      FORWARD (q);
+	      detect_redefined_keyword (q, MODE_DECLARATION);
+	      if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP))
+		{
+		  /* Store in the symbol table, but also in the moid list.
+		     Position of definition (q) connects to this lexical
+		     level!  */
+		  if (a68_add_tag (TABLE (p), INDICANT, q, NO_MOID, STOP) == NO_TAG)
+		    gcc_unreachable ();
+		  if (a68_add_mode (&TOP_MOID (&A68_JOB), INDICANT, 0, q, NO_MOID, NO_PACK) == NO_MOID)
+		    gcc_unreachable ();
+		  ATTRIBUTE (q) = DEFINING_INDICANT;
+		  FORWARD (q);
+		  ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+		  q = skip_pack_declarer (NEXT (q));
+		  FORWARD (q);
+		}
+	      else
+		siga = false;
+	    }
+	  while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+	}
+      else
+	FORWARD (q);
+    }
+}
+
+#define GET_PRIORITY(q, k)						\
+  do									\
+    {									\
+      errno=0;								\
+      (k) = atoi (NSYMBOL (q));						\
+      if (errno != 0) {							\
+	a68_error ((q), "invalid priority declaration");		\
+	(k) = MAX_PRIORITY;						\
+      } else if ((k) < 1 || (k) > MAX_PRIORITY) {			\
+	a68_error ((q), "invalid priority declaration");		\
+	(k) = MAX_PRIORITY;						\
+      }									\
+    }									\
+  while (0)
+
+/* Search PRIO X = .., Y = .. and store priorities.  */
+
+void
+a68_extract_priorities (NODE_T *p)
+{
+  NODE_T *q = p;
+  while (q != NO_NODE)
+    {
+      if (IS (q, PRIO_SYMBOL))
+	{
+	  bool siga = true;
+	  do
+	    {
+	      FORWARD (q);
+	      detect_redefined_keyword (q, PRIORITY_DECLARATION);
+	      /* An operator tag like ++ or && gives strange errors so we catch
+		 it here.  */
+	      if (a68_whether (q, OPERATOR, OPERATOR, STOP))
+		{
+		  NODE_T *y = q;
+		  a68_error (q, "invalid operator tag");
+		  ATTRIBUTE (q) = DEFINING_OPERATOR;
+		  /* Remove one superfluous operator, and hope it was only
+		     one.  */
+		  NEXT (q) = NEXT_NEXT (q);
+		  PREVIOUS (NEXT (q)) = q;
+		  FORWARD (q);
+		  ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+		  FORWARD (q);
+		  int k;
+		  GET_PRIORITY (q, k);
+		  ATTRIBUTE (q) = PRIORITY;
+		  if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG)
+		    gcc_unreachable ();
+		  FORWARD (q);
+		}
+	      else if (a68_whether (q, OPERATOR, EQUALS_SYMBOL, INT_DENOTATION, STOP)
+		       || a68_whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, INT_DENOTATION, STOP))
+		{
+		  NODE_T *y = q;
+		  ATTRIBUTE (q) = DEFINING_OPERATOR;
+		  FORWARD (q);
+		  ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+		  FORWARD (q);
+		  int k;
+		  GET_PRIORITY (q, k);
+		  ATTRIBUTE (q) = PRIORITY;
+		  if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG)
+		    gcc_unreachable ();
+		  FORWARD (q);
+		}
+	      else if (a68_whether (q, BOLD_TAG, IDENTIFIER, STOP))
+		{
+		  siga = false;
+		}
+	      else if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, INT_DENOTATION, STOP))
+		{
+		  NODE_T *y = q;
+		  ATTRIBUTE (q) = DEFINING_OPERATOR;
+		  FORWARD (q);
+		  ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+		  FORWARD (q);
+		  int k;
+		  GET_PRIORITY (q, k);
+		  ATTRIBUTE (q) = PRIORITY;
+		  if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG)
+		    gcc_unreachable ();
+		  FORWARD (q);
+		} else if (a68_whether (q, BOLD_TAG, INT_DENOTATION, STOP)
+			   || a68_whether (q, OPERATOR, INT_DENOTATION, STOP)
+			   || a68_whether (q, EQUALS_SYMBOL, INT_DENOTATION, STOP))
+		{
+		  /* The scanner cannot separate operator and "=" sign so we do this here.  */
+		  int len = (int) strlen (NSYMBOL (q));
+		  if (len > 1 && NSYMBOL (q)[len - 1] == '=')
+		    {
+		      NODE_T *y = q;
+		      char *sym = (char *) xmalloc ((size_t) (len + 1));
+		      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");
+		      ATTRIBUTE (q) = DEFINING_OPERATOR;
+		      insert_alt_equals (q);
+		      q = NEXT_NEXT (q);
+		      int k;
+		      GET_PRIORITY (q, k);
+		      ATTRIBUTE (q) = PRIORITY;
+		      if (a68_add_tag (TABLE (p), PRIO_SYMBOL, y, NO_MOID, k) == NO_TAG)
+			gcc_unreachable ();
+		      FORWARD (q);
+		    }
+		  else
+		    siga = false;
+		}
+	      else
+		siga = false;
+	    }
+	  while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+	}
+      else
+	FORWARD (q);
+    }
+}
+
+/* Search OP [( .. ) ..] X = .., Y = .. and store operators.  */
+
+void
+a68_extract_operators (NODE_T *p)
+{
+  NODE_T *q = p;
+
+  while (q != NO_NODE)
+    {
+      if (!IS (q, OP_SYMBOL))
+	FORWARD (q);
+      else
+	{
+	  bool siga = true;
+	  bool in_proc = true;
+	  /* Skip operator plan.  */
+	  if (NEXT (q) != NO_NODE && IS (NEXT (q), OPEN_SYMBOL))
+	    {
+	      q = skip_pack_declarer (NEXT (q));
+	      in_proc = false;
+	    }
+	  /* Sample operators.  */
+	  if (q != NO_NODE)
+	    {
+	      do
+		{
+		  FORWARD (q);
+		  detect_redefined_keyword (q, OPERATOR_DECLARATION);
+		  /* Unacceptable operator tags like ++ or && could give
+		     strange errors.  */
+		  if (a68_whether (q, OPERATOR, OPERATOR, STOP))
+		    {
+		      a68_error (q, "invalid operator tag");
+		      ATTRIBUTE (q) = DEFINING_OPERATOR;
+		      TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP);
+		      if (t == NO_TAG)
+			gcc_unreachable ();
+		      IN_PROC (t) = in_proc;
+		      /* Remove one superfluous operator, and hope it was only one.  */
+		      NEXT (q) = NEXT_NEXT (q);
+		      PREVIOUS (NEXT (q)) = q;
+		      FORWARD (q);
+		      ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+		      q = skip_unit (q);
+		    }
+		  else if (a68_whether (q, OPERATOR, EQUALS_SYMBOL, STOP)
+			   || a68_whether (q, EQUALS_SYMBOL, EQUALS_SYMBOL, STOP))
+		    {
+		      ATTRIBUTE (q) = DEFINING_OPERATOR;
+		      TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP);
+		      if (t == NO_TAG)
+			gcc_unreachable ();
+		      IN_PROC (t) = in_proc;
+		      FORWARD (q);
+		      ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+		      q = skip_unit (q);
+		    }
+		  else if (a68_whether (q, BOLD_TAG, IDENTIFIER, STOP))
+		    {
+		      siga = false;
+		    }
+		  else if (a68_whether (q, BOLD_TAG, EQUALS_SYMBOL, STOP))
+		    {
+		      ATTRIBUTE (q) = DEFINING_OPERATOR;
+		      TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP);
+		      if (t == NO_TAG)
+			gcc_unreachable ();
+		      IN_PROC (t) = in_proc;
+		      FORWARD (q);
+		      ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+		      q = skip_unit (q);
+		    }
+		  else if (q != NO_NODE && (a68_is_one_of (q, OPERATOR, BOLD_TAG, EQUALS_SYMBOL, STOP)))
+		    {
+		      /* The scanner cannot separate operator and "=" sign so
+			 we do this here.  */
+		      int len = (int) strlen (NSYMBOL (q));
+		      if (len > 1 && NSYMBOL (q)[len - 1] == '=')
+			{
+			  char *sym = (char *) xmalloc ((size_t) (len + 1));
+			  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");
+			  ATTRIBUTE (q) = DEFINING_OPERATOR;
+			  insert_alt_equals (q);
+			  TAG_T *t = a68_add_tag (TABLE (p), OP_SYMBOL, q, NO_MOID, STOP);
+			  if (t == NO_TAG)
+			    gcc_unreachable ();
+			  IN_PROC (t) = in_proc;
+			  FORWARD (q);
+			  q = skip_unit (q);
+			}
+		      else
+			siga = false;
+		    }
+		  else
+		    siga = false;
+		}
+	      while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+	    }
+	}
+    }
+}
+
+/* Search and store labels.  */
+
+void
+a68_extract_labels (NODE_T *p, int expect)
+{
+  /* Only handle candidate phrases as not to search indexers!.  */
+  if (expect == SERIAL_CLAUSE || expect == ENQUIRY_CLAUSE || expect == SOME_CLAUSE)
+    {
+      for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+	{
+	  if (a68_whether (q, IDENTIFIER, COLON_SYMBOL, STOP))
+	    {
+	      TAG_T *z = a68_add_tag (TABLE (p), LABEL, q, NO_MOID, LOCAL_LABEL);
+	      ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+	      UNIT (z) = NO_NODE;
+	    }
+	}
+    }
+}
+
+/* Search MOID x = .., y = .. and store identifiers.  */
+
+static void
+extract_identities (NODE_T *p)
+{
+  NODE_T *q = p;
+
+  while (q != NO_NODE)
+    {
+      if (a68_whether (q, DECLARER, IDENTIFIER, EQUALS_SYMBOL, STOP))
+	{
+	  bool siga = true;
+	  do
+	    {
+	      if (a68_whether ((FORWARD (q)), IDENTIFIER, EQUALS_SYMBOL, STOP))
+		{
+		  TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER);
+		  if (tag == NO_TAG)
+		    gcc_unreachable ();
+		  ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+		  FORWARD (q);
+		  ATTRIBUTE (q) = ALT_EQUALS_SYMBOL;
+		  q = skip_unit (q);
+		}
+	      else if (a68_whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP))
+		{
+		  /* Handle common error in ALGOL 68 programs.  */
+		  a68_error (q, "mixed identity-declaration and variable-declaration");
+		  if (a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) == NO_TAG)
+		    gcc_unreachable ();
+		  ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+		  ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL;
+		  q = skip_unit (q);
+		}
+	      else
+		siga = false;
+	    }
+	  while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+	}
+      else
+	FORWARD (q);
+    }
+}
+
+/* Search MOID x [:= ..], y [:= ..] and store identifiers.  */
+
+static void
+extract_variables (NODE_T *p)
+{
+  NODE_T *q = p;
+
+  while (q != NO_NODE)
+    {
+      if (a68_whether (q, HEAP_SYMBOL, DECLARER, IDENTIFIER, STOP)
+	  || a68_whether (q, LOC_SYMBOL, DECLARER, IDENTIFIER, STOP)
+	  || a68_whether (q, DECLARER, IDENTIFIER, STOP))
+	{
+	  if (!IS (q, DECLARER))
+	    FORWARD (q);
+
+	  bool siga = true;
+	  do
+	    {
+	      FORWARD (q);	      
+	      if (a68_whether (q, IDENTIFIER, STOP))
+		{
+		  if (a68_whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP))
+		    {
+		      /* Handle common error in ALGOL 68 programs.  */
+		      a68_error (q, "mixed identity-declaration and variable-declaration");
+		      ATTRIBUTE (NEXT (q)) = ASSIGN_SYMBOL;
+		    }
+		  TAG_T *tag = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER);
+		  if (tag == NO_TAG)
+		    gcc_unreachable ();
+		  VARIABLE (tag) = true;
+		  ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+		  q = skip_unit (q);
+		}
+	      else
+		siga = false;
+	    }
+	  while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+	}
+      else
+	FORWARD (q);
+    }
+}
+
+/* Search PROC x = .., y = .. and stores identifiers.  */
+
+static void
+extract_proc_identities (NODE_T *p)
+{
+  NODE_T *q = p;
+
+  while (q != NO_NODE)
+    {
+      if (a68_whether (q, PROC_SYMBOL, IDENTIFIER, EQUALS_SYMBOL, STOP))
+	{
+	  bool siga = true;
+	  do
+	    {
+	      FORWARD (q);
+	      if (a68_whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP))
+		{
+		  TAG_T *t = a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER);
+		  IN_PROC (t) = true;
+		  ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+		  ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL;
+		  q = skip_unit (q);
+		}
+	      else if (a68_whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP))
+		{
+		  /* Handle common error in ALGOL 68 programs. */
+		  a68_error (q, "mixed identity-declaration and variable-declaration");
+		  if (a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) == NO_TAG)
+		    gcc_unreachable ();
+		  ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+		  ATTRIBUTE (FORWARD (q)) = ALT_EQUALS_SYMBOL;
+		  q = skip_unit (q);
+		}
+	      else
+		siga = false;
+	    }
+	  while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+	}
+      else
+	FORWARD (q);
+    }
+}
+
+/* Search PROC x [:= ..], y [:= ..]; store identifiers.  */
+
+static void
+extract_proc_variables (NODE_T *p)
+{
+  NODE_T *q = p;
+
+  while (q != NO_NODE)
+    {
+      if (a68_whether (q, PROC_SYMBOL, IDENTIFIER, STOP))
+	{
+	  bool siga = true;
+	  do
+	    {
+	      FORWARD (q);
+	      if (a68_whether (q, IDENTIFIER, ASSIGN_SYMBOL, STOP))
+		{
+		  if (a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) == NO_TAG)
+		    gcc_unreachable ();
+		  ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+		  q = skip_unit (FORWARD (q));
+		}
+	      else if (a68_whether (q, IDENTIFIER, EQUALS_SYMBOL, STOP))
+		{
+		  /* Handle common error in ALGOL 68 programs.  */
+		  a68_error (q, "mixed identity-declaration and variable-declaration");
+		  if (a68_add_tag (TABLE (p), IDENTIFIER, q, NO_MOID, NORMAL_IDENTIFIER) == NO_TAG)
+		    gcc_unreachable ();
+		  ATTRIBUTE (q) = DEFINING_IDENTIFIER;
+		  ATTRIBUTE (FORWARD (q)) = ASSIGN_SYMBOL;
+		  q = skip_unit (q);
+		} else
+		siga = false;
+	    }
+	  while (siga && q != NO_NODE && IS (q, COMMA_SYMBOL));
+	}
+      else
+	FORWARD (q);
+    }
+}
+
+/* Schedule gathering of definitions in a phrase.  */
+
+void
+a68_extract_declarations (NODE_T *p)
+{
+  /* Get definitions so we know what is defined in this range.  */
+  extract_identities (p);
+  extract_variables (p);
+  extract_proc_identities (p);
+  extract_proc_variables (p);
+  /* By now we know whether "=" is an operator or not.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, EQUALS_SYMBOL))
+	ATTRIBUTE (q) = OPERATOR;
+      else if (IS (q, ALT_EQUALS_SYMBOL))
+	ATTRIBUTE (q) = EQUALS_SYMBOL;
+    }
+
+  /* Get qualifiers.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (a68_whether (q, LOC_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP))
+	a68_make_sub (q, q, QUALIFIER);
+      if (a68_whether (q, HEAP_SYMBOL, DECLARER, DEFINING_IDENTIFIER, STOP))
+	a68_make_sub (q, q, QUALIFIER);
+      if (a68_whether (q, LOC_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP))
+	a68_make_sub (q, q, QUALIFIER);
+      if (a68_whether (q, HEAP_SYMBOL, PROC_SYMBOL, DEFINING_IDENTIFIER, STOP))
+	a68_make_sub (q, q, QUALIFIER);
+    }
+
+  /* Give priorities to operators.  */
+  for (NODE_T *q = p; q != NO_NODE; FORWARD (q))
+    {
+      if (IS (q, OPERATOR))
+	{
+	  if (a68_find_tag_global (TABLE (q), OP_SYMBOL, NSYMBOL (q)))
+	    {
+	      TAG_T *s = a68_find_tag_global (TABLE (q), PRIO_SYMBOL, NSYMBOL (q));
+
+	      if (s != NO_TAG)
+		PRIO (INFO (q)) = PRIO (s);
+	      else
+		PRIO (INFO (q)) = 0;
+	    }
+	  else
+	    {
+	      a68_error (q, "tag S has not been declared properly");
+	      PRIO (INFO (q)) = 1;
+	    }
+	}
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 28/47] a68: parser: dynamic stack usage in serial clauses
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (26 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 27/47] a68: parser: extraction of tags from phrases Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 29/47] a68: low: lowering entry point and misc handlers Jose E. Marchesi
                   ` (19 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-parser-serial-dsa.cc: New file.
---
 gcc/algol68/a68-parser-serial-dsa.cc | 114 +++++++++++++++++++++++++++
 1 file changed, 114 insertions(+)
 create mode 100644 gcc/algol68/a68-parser-serial-dsa.cc

diff --git a/gcc/algol68/a68-parser-serial-dsa.cc b/gcc/algol68/a68-parser-serial-dsa.cc
new file mode 100644
index 00000000000..b48c13da3bf
--- /dev/null
+++ b/gcc/algol68/a68-parser-serial-dsa.cc
@@ -0,0 +1,114 @@
+/* Check dynamic stack usage in serial clauses.
+   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/>.  */
+
+/* This file implements a phase that determines what serial clauses contain
+   phrases whose elaboration may involve dynamic stack allocation.  It
+   annotates the SERIAL_CLAUSE parse nodes by setting the DYNAMIC_STACK_ALLOCS
+   flag.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/* Uncomment the following line for debugging traces.  */
+/* #define SERIAL_DSA_DEBUG */
+
+static void
+serial_dsa_check_serial_clause (NODE_T *p, bool *dsa)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, GENERATOR))
+	{
+	  /* LOC generators always result in dyamic stack allocation regardless
+	     of the mode of the allocated value.  */
+	  if (IS (SUB (p), LOC_SYMBOL))
+	    {
+#ifdef SERIAL_DSA_DEBUG
+	      fprintf (stderr, "serial_dsa: %s:%d: loc generator implies DSA\n",
+		       FILENAME (LINE (INFO (p))),
+		       LINE_NUMBER (p));
+#endif
+	      *dsa = true;
+	      return;
+	    }
+	}
+      else if (IS (p, DEFINING_IDENTIFIER))
+	{
+	  /* Variable declarations of values with sample loc generators will
+	     result in dynamic stack allocation.
+
+	     Note that label declarations do no have a mode, so we have to
+	     check for MOID (p).  */
+
+	  if (MOID (p) != NO_MOID && IS_REF (MOID (p)))
+	    {
+	      bool heap = HEAP (TAX (p)) == HEAP_SYMBOL;
+	      if (HAS_ROWS (SUB (MOID (p))) && !heap)
+		{
+#ifdef SERIAL_DSA_DEBUG		  
+		  fprintf (stderr,
+			   "serial_dsa: %s:%d: defining identifier %s implies DSA\n",
+			   FILENAME (LINE (INFO (p))),
+			   LINE_NUMBER (p),
+			   NSYMBOL (p));
+#endif
+		  *dsa = true;
+		  return;
+		}
+	    }
+	}
+      else
+	{
+	  /* Inner serial clauses will take care of their own.  Code in routine
+	     texts will not impact the stack of the containing serial
+	     clause.  */
+	  if (!IS (p, SERIAL_CLAUSE) && !IS (p, ROUTINE_TEXT))
+	    serial_dsa_check_serial_clause (SUB (p), dsa);
+	}
+    }
+}
+
+void
+a68_serial_dsa (NODE_T *p)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      a68_serial_dsa (SUB (p));
+      if (IS (p, SERIAL_CLAUSE))
+	{
+	  bool dsa = false;
+	  serial_dsa_check_serial_clause (SUB (p), &dsa);
+	  DYNAMIC_STACK_ALLOCS (p) = dsa;
+#ifdef SERIAL_DSA_DEBUG
+	  if (dsa)
+	    {
+	      fprintf (stderr, "serial_dsa: %s:%d: marking serial clause %p as DSA\n",
+		       FILENAME (LINE (INFO (p))),
+		       LINE_NUMBER (p),
+		       (void *) p);
+	    }
+	  
+#endif
+	}
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 29/47] a68: low: lowering entry point and misc handlers
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (27 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 28/47] a68: parser: dynamic stack usage in serial clauses Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 30/47] a68: low: plain values Jose E. Marchesi
                   ` (18 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-low.cc: New file.
	* algol68/a68-low-misc.cc: Likewise.
---
 gcc/algol68/a68-low-misc.cc |  213 +++++++
 gcc/algol68/a68-low.cc      | 1153 +++++++++++++++++++++++++++++++++++
 2 files changed, 1366 insertions(+)
 create mode 100644 gcc/algol68/a68-low-misc.cc
 create mode 100644 gcc/algol68/a68-low.cc

diff --git a/gcc/algol68/a68-low-misc.cc b/gcc/algol68/a68-low-misc.cc
new file mode 100644
index 00000000000..e2ad5cb412b
--- /dev/null
+++ b/gcc/algol68/a68-low-misc.cc
@@ -0,0 +1,213 @@
+/* Lower miscellaneous tree nodes to GENERIC.
+   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"
+
+/* Lower an assertion.
+
+     assertion : assert symbol, enclosed clause.
+*/
+
+tree
+a68_lower_assertion (NODE_T *p, LOW_CTX_T ctx)
+{
+  if (!OPTION_ASSERT (&A68_JOB))
+    return a68_get_empty();
+
+  /* Build the call to the assert run-time function.  */
+  unsigned int lineno = NUMBER (LINE (INFO (p)));
+  const char *filename_str = FILENAME (LINE (INFO (p)));
+  tree filename = build_string_literal (strlen (filename_str) + 1,
+					filename_str);
+  tree call = a68_build_libcall (A68_LIBCALL_ASSERT,
+				 void_type_node, 2,
+				 filename,
+				 build_int_cst (unsigned_type_node, lineno));
+  /* Check condition and call assert if required.  */
+  tree assertion = fold_build2_loc (a68_get_node_location (p),
+				    COMPOUND_EXPR,
+				    a68_void_type,
+				    build2_loc (a68_get_node_location (p),
+						TRUTH_ORIF_EXPR,
+						a68_int_type,
+						a68_lower_tree (NEXT (SUB (p)), ctx),
+						fold_build2 (COMPOUND_EXPR,
+							     a68_int_type,
+							     call,
+							     build_int_cst (a68_int_type, 0))),
+				    a68_get_empty ());
+  TREE_SIDE_EFFECTS (assertion) = 1;
+  return assertion;
+}
+
+/* Lower a jump to a label.
+
+     jump : goto symbol, identifier;
+            identifier.
+
+   A jump lowers into a ({ GOTO_EXPR; EMPTY }).  */
+
+tree
+a68_lower_jump (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *label_identifier = SUB (p);
+  MOID_T *jump_mode = MOID (p);
+  if (!IS (label_identifier, IDENTIFIER))
+    FORWARD (label_identifier);
+
+  /* Create LABEL_DECL if necessary and chain it in both current block and bind
+     expression.  */
+  if (TAX_TREE_DECL (TAX (label_identifier)) == NULL_TREE)
+    {
+      tree label_decl = build_decl (a68_get_node_location (label_identifier),
+				    LABEL_DECL,
+				    a68_get_mangled_identifier (NSYMBOL (label_identifier)),
+				    void_type_node);
+      TAX_TREE_DECL (TAX (label_identifier)) = label_decl;
+    }
+
+  MOID (label_identifier) = M_VOID;
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  CTYPE (jump_mode),
+			  fold_build1_loc (a68_get_node_location (p),
+					   GOTO_EXPR,
+					   void_type_node,
+					   a68_lower_tree (label_identifier, ctx)),
+			  a68_get_skip_tree (jump_mode));
+}
+
+/* Lower a parameter into a chain of PARAM_DECLs.
+
+     parameter : declarer, identifier;
+                 parameter, comma symbol, identifier.
+*/
+
+tree
+a68_lower_parameter (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree prev_parm_decls = NULL_TREE;
+  NODE_T *identifier = NO_NODE;
+  if (IS (SUB (p), PARAMETER))
+    {
+      prev_parm_decls = a68_lower_tree (SUB (p), ctx);
+      identifier = NEXT (NEXT (SUB (p)));
+    }
+  else
+    identifier = NEXT (SUB (p));
+
+  /* Create the PARM_DECL.  */
+  tree parm_decl = build_decl (a68_get_node_location (p),
+			       PARM_DECL,
+			       a68_get_mangled_identifier (NSYMBOL (identifier)),
+			       CTYPE (MOID (identifier)));
+  DECL_CONTEXT (parm_decl) = current_function_decl;
+  DECL_ARG_TYPE (parm_decl) = TREE_TYPE (parm_decl);
+  TAX_TREE_DECL (TAX (identifier)) = parm_decl;
+
+  layout_decl (parm_decl, 0);
+
+  if (prev_parm_decls != NULL)
+    return chainon (prev_parm_decls, parm_decl);
+  else
+    return parm_decl;
+}
+
+/* Lower a list of parameters into a chain of PARAM_DECLs.
+
+        parameter list : parameter;
+                         parameter list; comma symbol; parameter.
+*/
+
+tree
+a68_lower_parameter_list (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree parm_decl = NULL_TREE;
+  tree prev_parm_decls = NULL_TREE;
+  if (IS (SUB (p), PARAMETER_LIST))
+    {
+      prev_parm_decls = a68_lower_tree (SUB (p), ctx);
+      parm_decl = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+    }
+  else
+    parm_decl = a68_lower_tree (SUB (p), ctx);
+
+  gcc_assert (parm_decl != NULL_TREE);
+  if (prev_parm_decls != NULL)
+    return chainon (prev_parm_decls, parm_decl);
+  else
+    return parm_decl;
+}
+
+/* Lower a parameter pack into a chain of PARAM_DECLs.
+
+     parameter pack : open symbol, parameter list, close symbol.
+*/
+
+tree
+a68_lower_parameter_pack (NODE_T *p, LOW_CTX_T ctx)
+{
+  /* Lower the contained PARAMETER_LIST.  */
+  return a68_lower_tree (NEXT (SUB (p)), ctx);
+}
+
+/* Lower an applied operator.
+
+   Applied operators lower into a function object that gets one argument in
+   case of monadic operators, or two arguments in case of dyadic operators.  */
+
+tree
+a68_lower_operator (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  /* This is an user defined operator.  Handle it in a similar way than applied
+     identifiers.  */
+  tree func_decl = TAX_TREE_DECL (TAX (p));
+  if (func_decl == NULL_TREE)
+    {
+      if (IN_PROC (TAX (p)))
+	func_decl = a68_make_proc_identity_declaration_decl (p);
+      else
+	func_decl = a68_make_identity_declaration_decl (p);
+      TAX_TREE_DECL (TAX (p)) = func_decl;
+    }
+  return func_decl;
+}
diff --git a/gcc/algol68/a68-low.cc b/gcc/algol68/a68-low.cc
new file mode 100644
index 00000000000..69376081b03
--- /dev/null
+++ b/gcc/algol68/a68-low.cc
@@ -0,0 +1,1153 @@
+/* Lower the Algol 68 parse tree to GENERIC.
+   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"
+
+/* Return a tree with an identifier for the mangled version of a given
+   name.  */
+
+tree
+a68_get_mangled_identifier (const char *name)
+{
+  char *mangled_name = (char *) alloca (strlen (name) + 1);
+  memcpy (mangled_name, name, strlen (name) + 1);
+
+  /* Avoid MONADS and NOMADS.  */
+  for (char *p = mangled_name; *p != '\0'; ++p)
+    {
+      if (strchr (MONADS, *p) != NULL || strchr (NOMADS, *p) != NULL
+	  || strchr (":=", *p))
+	*p = '_';
+    }
+
+  return get_identifier (mangled_name);
+}
+
+/* Return a tree with the EMPTY value.
+
+   EMPTY is the only denotation of the VOID mode.  It is used in unions to
+   denote "no value".  It must have size zero, so it lowers into an empty
+   constructor with zero elements of type void.  This is what GNU C uses to
+   implement the empty struct extension.  */
+
+tree
+a68_get_empty (void)
+{
+  return build_constructor (a68_void_type, NULL);
+}
+
+/* Return a tree with the yielding of SKIP of a given mode.
+
+   SKIP stands for some value of some given mode.  It shall be used only in a
+   context where the compiler can determine the mode.
+
+   The particular value to which it elaborates is non-important, but this
+   compiler always uses the same values.  See the a68_get_ref_*_tree functions
+   for details on what values are these.  */
+
+tree
+a68_get_skip_tree (MOID_T *m)
+{
+  tree expr = NULL_TREE;
+
+  while (EQUIVALENT (m) != NO_MOID)
+    m = EQUIVALENT (m);
+
+  if (IS_INTEGRAL (m))
+    expr = a68_get_int_skip_tree (m);
+  else if (m == M_CHAR)
+    expr = a68_get_char_skip_tree ();
+  else if (m == M_BOOL)
+    expr = a68_get_bool_skip_tree ();
+  else if (IS_REAL (m))
+    expr = a68_get_real_skip_tree (m);
+  else if (IS_BITS (m))
+    expr = a68_get_bits_skip_tree (m);
+  else if (IS_REF (m))
+    expr = a68_get_ref_skip_tree (m);
+  else if (IS (m, PROC_SYMBOL))
+    expr = a68_get_proc_skip_tree (m);
+  else if (IS_STRUCT (m))
+    expr = a68_get_struct_skip_tree (m);
+  else if (IS_UNION (m))
+    expr = a68_get_union_skip_tree (m);
+  else if (IS_FLEXETY_ROW (m))
+    expr = a68_get_multiple_skip_tree (m);
+  else if (m == M_STRING)
+      expr = a68_get_string_skip_tree ();
+  else if (m == M_ROWS  || IS (m, SERIES_MODE))
+    {
+      /* XXX assert that all modes in the series are rows? */
+      tree rows_type = CTYPE (M_ROWS);
+      tree dim_field = TYPE_FIELDS (rows_type);
+      tree triplets_field = TREE_CHAIN (dim_field);
+      tree null_pointer = build_int_cst (TREE_TYPE (triplets_field), 0);
+      expr = build_constructor_va (rows_type, 2,
+				   dim_field, size_zero_node,
+				   triplets_field, null_pointer);
+    }
+  else if (m == M_VOID || m == M_HIP)
+    expr = a68_get_empty ();
+  else
+    {
+      fatal_error (UNKNOWN_LOCATION,
+		   "get skip tree: cannot compute SKIP for mode %s",
+		   a68_moid_to_string (m, MOID_ERROR_WIDTH, NODE (m), true));
+      gcc_unreachable ();
+    }
+
+  return expr;
+}
+
+/* Given a tree node EXP holding a value of mode M:
+
+   *NUM_REFS is set to the number of REFs in M.
+
+   *NUM_POINTERS is set to the number of pointers in the type of EXP that
+   correspond to the REFs in M.  */
+
+void
+a68_ref_counts (tree exp, MOID_T *m, int *num_refs, int *num_pointers)
+{
+  /* Count REFs in M and pointers in the type of EXP.  Note that VAR_DECLs
+     corresponding to REF PROC are of type pointer, so these should not count
+     for the count!  */
+
+  /* Make sure we are accessing the real mode definition.  */
+  while (EQUIVALENT (m) != NO_MOID)
+    m = EQUIVALENT (m);
+
+  *num_refs = 0;
+  *num_pointers = 0;
+  for (MOID_T *s = m; s != NO_MOID && IS_REF (s); s = SUB (s))
+    *num_refs += 1;
+  for (tree p = TREE_TYPE (exp);
+       p != NULL_TREE && POINTER_TYPE_P (p) && TREE_CODE (TREE_TYPE (p)) != FUNCTION_TYPE;
+       p = TREE_TYPE (p))
+    *num_pointers += 1;
+
+  gcc_assert (*num_refs >= *num_pointers);
+}
+
+/* The Algol 68 variable declaration
+
+     [LOC|HEAP] AMODE foo;
+
+   Is in principle equivalent to the identity declaration
+
+     REF AMODE foo = [LOC|HEAP] AMODE;
+
+   In both cases the object ascribed to the defining identifier `foo' is of
+   mode REF AMODE.  The ascribed object is a name which is created by a
+   generator implied in the actual declarer in the first case, and an explicit
+   generator in the initialization expression in the second case.
+
+   However, this front-end implements these two cases differently in order to
+   reduce the amount of both indirect addressing and of storage:
+
+   - The variable declaration `[LOC|HEAP] AMODE foo;' lowers into a VAR_DECL
+     with type ATYPE provided that the generator is LOC and that it contains no
+     rows.  Accessing it requires direct addressing.  When its address is
+     required, an ADDR_EXPR shall be used.
+
+   - The identity declaration `REF AMODE foo = LOC AMODE;' lowers into a
+     VAR_DECL with type *ATYPE.  Accessing it requires indirect addressing.  It
+     is effectively a pointer.
+
+   This introduces the complication that an expression (the VAR_DECL) whose
+   type is TYPE can appear in a place where *TYPE is expected.  This function,
+   given the required mode and an expression, adds as many ADDR_EXPR to EXPR as
+   necessary so the resulting value is of the required type.  Other than this
+   nuisance, the parser guarantees that the entities have the right type at the
+   location they appear, so a call to a68_consolidate_ref is all must be needed
+   at any point in the lowering process to guarantee a valid value for the
+   context.
+
+   This function expects:
+   - That the type of EXPR is zero or more pointers to a base type BTYPE.
+   - That the mode M is zero or more REFs to a base non-ref mode AMODE.
+   - That the number of pointers in the type of EXPR is less or equal than the
+     number of REFs in the mode M.
+   - That BTYPE and AMODE are equivalent.  */
+
+tree
+a68_consolidate_ref (MOID_T *m, tree expr)
+{
+  int num_refs, num_pointers;
+  a68_ref_counts (expr, m, &num_refs, &num_pointers);
+
+  /* Address EXPR as many times as necessary to match the number of REFs in the
+     desired mode.  */
+  while (num_pointers < num_refs)
+    {
+      if (TREE_CODE (expr) == COMPOUND_EXPR)
+	{
+	  /* (..., x) -> (..., &x) */
+	  //	  gcc_assert (TREE_CODE (TREE_OPERAND (expr, 0)) == MODIFY_EXPR);
+	  //	  gcc_assert (VAR_P (TREE_OPERAND (expr, 1)));
+	  TREE_OPERAND (expr, 1) = a68_consolidate_ref (m, TREE_OPERAND (expr, 1));
+	  TREE_TYPE (expr) = TREE_TYPE (TREE_OPERAND (expr, 1));
+	}
+      else
+	{
+	  /* x -> &x */
+	  if (TREE_CODE (expr) == INDIRECT_REF)
+	    /* expr is an indirection.  Remove the pointer rather than adding
+	       an addr.  This avoids &* situations and marking stuff as
+	       addressable unnecessarily.  */
+	    expr = TREE_OPERAND (expr,0);
+	  else
+	    {
+	      TREE_ADDRESSABLE (expr) = true;
+	      expr = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (expr)), expr);
+	    }
+	}
+      num_pointers += 1;
+    }
+
+  return expr;
+}
+
+/* Make a declaration for an anonymous routine of mode MODE.  */
+
+tree
+a68_make_anonymous_routine_decl (MOID_T *mode)
+{
+  /* The CTYPE of MODE is a pointer to a function.  We need the pointed
+     function type for the FUNCTION_DECL.  */
+  tree func_type = TREE_TYPE (CTYPE (mode));
+  tree func_decl = build_decl (UNKNOWN_LOCATION,
+			       FUNCTION_DECL,
+			       NULL_TREE /* name, set below.  */,
+			       func_type);
+  char *name = xasprintf ("routine%d", DECL_UID (func_decl));
+  DECL_NAME (func_decl) = a68_get_mangled_identifier (name);
+  free (name);
+  DECL_EXTERNAL (func_decl) = 0;
+  DECL_STATIC_CHAIN (func_decl) = !a68_in_global_range ();
+  /* Nested functions should be addressable.
+     XXX this should be propagated to their containing functions, so for now
+     we mark them all as addressable.  */
+  TREE_ADDRESSABLE (func_decl) = 1;
+  /* A nested function is not global.  */
+  TREE_PUBLIC (func_decl) = a68_in_global_range ();
+  TREE_STATIC (func_decl) = 1;
+
+  return func_decl;
+}
+
+/* Make a declaration for a constant procedure or operator.  */
+
+tree
+a68_make_proc_identity_declaration_decl (NODE_T *identifier)
+{
+  /* The CTYPE of MODE is a pointer to a function.  We need the pointed
+     function type for the FUNCTION_DECL.  */
+  tree func_type = TREE_TYPE (CTYPE (MOID (identifier)));
+  tree func_decl = build_decl (UNKNOWN_LOCATION,
+			       FUNCTION_DECL,
+			       a68_get_mangled_identifier (NSYMBOL (identifier)),
+			       func_type);
+  DECL_EXTERNAL (func_decl) = 0;
+  DECL_STATIC_CHAIN (func_decl) = !a68_in_global_range ();
+  /* Nested functions should be addressable.
+     XXX this should be propagated to their containing functions, so for now
+     we mark them all as addressable.  */
+  TREE_ADDRESSABLE (func_decl) = 1;
+  /* A nested function is not global.  */
+  TREE_PUBLIC (func_decl) = a68_in_global_range ();
+  TREE_STATIC (func_decl) = 1;
+
+  return func_decl;
+}
+
+/* Make a declaration for an identity declaration.  */
+
+tree
+a68_make_identity_declaration_decl (NODE_T *identifier)
+{
+  tree type = CTYPE (MOID (identifier));
+
+  tree decl = build_decl (a68_get_node_location (identifier),
+			  VAR_DECL,
+			  a68_get_mangled_identifier (NSYMBOL (identifier)),
+			  type);
+  TREE_PUBLIC (decl) = 0;
+#if 0
+  if (!IS_REF (MOID (identifier)))
+    TREE_CONSTANT (decl) = 1;
+#endif
+  DECL_INITIAL (decl) = a68_get_skip_tree (MOID (identifier));
+  return decl;
+}
+
+/* Make a declaration for a variable declaration.
+   The mode of the given identifier is expected to be a REF AMODE.  */
+
+tree
+a68_make_variable_declaration_decl (NODE_T *identifier)
+{
+  gcc_assert (IS_REF (MOID (identifier)));
+
+  MOID_T *mode = MOID (identifier);
+  bool use_pointer = ((HEAP (TAX (identifier)) == HEAP_SYMBOL)
+		      || HAS_ROWS (SUB (MOID (identifier))));
+  tree type = use_pointer ? CTYPE (mode) : CTYPE (SUB (mode));
+  tree decl = build_decl (a68_get_node_location (identifier),
+			  VAR_DECL,
+			  a68_get_mangled_identifier (NSYMBOL (identifier)),
+			  type);
+  TREE_PUBLIC (decl) = 0;
+  DECL_INITIAL (decl) = a68_get_skip_tree (use_pointer ? mode : SUB (mode));
+  return decl;
+}
+
+/* Do a checked indirection.
+
+   P is a tree node used for its location information.
+   EXP is an expression that gets indirected.
+   EXP_MODE is the mode of exp.  */
+
+tree
+a68_checked_indirect_ref (NODE_T *p, tree exp, MOID_T *exp_mode)
+{
+  tree exp_type = TREE_TYPE (exp);
+  tree nil_check = NULL_TREE;
+
+  if (OPTION_NIL_CHECKING (&A68_JOB))
+    {
+      exp = save_expr (exp);
+      tree consolidated_exp = a68_consolidate_ref (exp_mode, exp);
+
+      /* Check whether we are dereferencing NIL.  */
+      unsigned int lineno = NUMBER (LINE (INFO (p)));
+      const char *filename_str = FILENAME (LINE (INFO (p)));
+      tree filename = build_string_literal (strlen (filename_str) + 1,
+					    filename_str);
+      tree call = a68_build_libcall (A68_LIBCALL_DEREFNIL,
+					 void_type_node, 2,
+					 filename,
+					 build_int_cst (unsigned_type_node, lineno));
+      call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node);
+      nil_check = fold_build2 (NE_EXPR, exp_type,
+			       consolidated_exp,
+			       build_int_cst (exp_type, 0));
+      nil_check = fold_build2 (TRUTH_ORIF_EXPR, exp_type,
+			       nil_check, call);
+    }
+
+  tree deref = fold_build1 (INDIRECT_REF, TREE_TYPE (exp_type), exp);
+  if (nil_check == NULL_TREE)
+    return deref;
+  else
+    return fold_build2 (COMPOUND_EXPR, TREE_TYPE (deref),
+			nil_check, deref);
+}
+
+/* Deref a given expression EXP whose mode is MOID (P).
+
+   The value to dereference always corresponds to a name, but it may consist
+   of:
+
+   - Not a pointer, in which case corresponds to a name lowered to a VAR_DECL.
+
+   - A pointer to a function, in which case corresponds to a name of mode REF
+     PROC, lowered to a VAR_DECL.
+
+   - Any other pointer corresponds to a name lowered to a VAR_DECL that is a
+     pointer.
+
+   In the first two cases, in both r-value and l-value situations the expected
+   result is achieved by just returning the value: in r-value the decl denotes
+   the value, in l-value the decl denotes the (direct) address of the
+   value.  */
+
+tree
+a68_low_deref (tree exp, NODE_T *p)
+{
+  int num_refs, num_pointers;
+  a68_ref_counts (exp, MOID (p), &num_refs, &num_pointers);
+
+  if (num_refs > num_pointers)
+    return exp;
+  else
+    {
+      gcc_assert (num_refs == num_pointers);
+      return a68_checked_indirect_ref (p, exp, MOID (p));
+    }
+}
+
+/* Get a deep-copy of a given Algol 68 value EXP.  */
+
+tree
+a68_low_dup (tree expr, bool use_heap)
+{
+  tree dup = NULL_TREE;
+  tree type = TREE_TYPE (expr);
+
+  /* XXX */
+  use_heap = true;
+
+  /* Determine the mode corresponding to the type of EXPR.  */
+  MOID_T *m = a68_type_moid (type);
+  gcc_assert (m != NO_MOID);
+  while (EQUIVALENT (m) != NO_MOID)
+    m = EQUIVALENT (m);
+
+  if (A68_ROW_TYPE_P (type))
+    {
+      /* We need to copy the elements as well as the descriptor.  There is no
+	 need to check bounds.  */
+
+      /* Deflexe the mode as appropriate.  */
+      while (IS_FLEX (m))
+	m = SUB (m);
+      gcc_assert (IS_ROW (m) || m == M_STRING);
+
+      a68_push_range (NULL);
+
+      /* First allocate space for the dupped elements.  */
+      expr = save_expr (expr);
+      tree elements = a68_multiple_elements (expr);
+      tree element_pointer_type = TREE_TYPE (elements);
+      tree element_type = TREE_TYPE (element_pointer_type);
+      tree new_elements_size = save_expr (a68_multiple_elements_size (expr));
+      tree new_elements = a68_lower_tmpvar ("new_elements%",
+					    TREE_TYPE (elements),
+					    (use_heap
+					     ? a68_lower_malloc (TREE_TYPE (TREE_TYPE (elements)),
+								 new_elements_size)
+					     : a68_lower_alloca (TREE_TYPE (TREE_TYPE (elements)),
+								 new_elements_size)));
+
+      /* Then copy the elements.
+
+	 If the mode of the elements stored in the multiple dont have rows,
+	 then we can just use memcpy.  Otherwise, we have to loop and recurse
+	 to dup all the elements in the multiple one by one.
+
+	 The above applies to multiples of any number of dimensions.  */
+      if (m == M_STRING || !HAS_ROWS (SUB (m)))
+	{
+	  a68_add_stmt (a68_lower_memcpy (new_elements,
+					  elements,
+					  new_elements_size));
+	  a68_add_stmt (new_elements);
+	}
+      else
+	{
+	  /* Note that num_elems includes elements that are not accessible due
+	     to trimming.  */
+	  tree num_elems = a68_lower_tmpvar ("numelems%", size_type_node,
+					     fold_build2 (TRUNC_DIV_EXPR, sizetype,
+							  new_elements_size,
+							  size_in_bytes (element_type)));
+	  tree orig_elements = a68_lower_tmpvar ("orig_elements%",
+						 element_pointer_type, elements);
+	  tree index = a68_lower_tmpvar ("index%", size_type_node, size_zero_node);
+
+	  /* Begin of loop body.  */
+	  a68_push_range (NULL);
+
+	  /* if (index == num_elems) break; */
+	  a68_add_stmt (fold_build1 (EXIT_EXPR,
+				     void_type_node,
+				     fold_build2 (EQ_EXPR,
+						  size_type_node,
+						  index, num_elems)));
+	  /* new_elements[index] = elements[index] */
+	  tree offset = fold_build2 (MULT_EXPR, sizetype,
+				     index, size_in_bytes (element_type));
+	  tree new_elem_lvalue = fold_build2 (MEM_REF, element_type,
+					      fold_build2 (POINTER_PLUS_EXPR,
+							   element_pointer_type,
+							   new_elements,
+							   offset),
+					      fold_convert (element_pointer_type,
+							    integer_zero_node));
+	  tree elem = fold_build2 (MEM_REF, element_type,
+				   fold_build2 (POINTER_PLUS_EXPR,
+						element_pointer_type,
+						orig_elements,
+						offset),
+				   fold_convert (element_pointer_type,
+						 integer_zero_node));
+	  a68_add_stmt (fold_build2 (MODIFY_EXPR, element_type,
+				     new_elem_lvalue,
+				     a68_low_dup (elem, use_heap)));
+	  /* index++ */
+	  a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR,
+				     size_type_node,
+				     index, size_one_node));
+	  tree loop_body = a68_pop_range ();
+	  /* End of loop body.  */
+
+	  a68_add_stmt (fold_build1 (LOOP_EXPR,
+				     void_type_node,
+				     loop_body));
+	  a68_add_stmt (new_elements);
+	}
+
+      new_elements = a68_pop_range ();
+      TREE_TYPE (new_elements) = element_pointer_type;
+
+      /* Now build a descriptor pointing to the dupped elements and return it.
+	 Note that the descriptor is always allocated on the stack.  */
+      dup = a68_row_value_raw (type,
+			       a68_multiple_triplets (expr),
+			       new_elements,
+			       new_elements_size);
+    }
+  else if (!HAS_ROWS (m))
+    {
+      /* Non-multiple values that do not contain rows do not need to be dupped,
+	 since they can be just moved around using the semantics of
+	 MODIFY_EXPR.  */
+      dup = expr;
+    }
+  else if (A68_STRUCT_TYPE_P (type))
+    {
+      /* Since struct value can contain multiples and unions and other values
+	 that require deep copy, we cannot simply rely on the C semantics of a
+	 MODIFY_EXPR.  */
+      tree struct_type = type;
+      vec <constructor_elt, va_gc> *ce = NULL;
+
+      expr = save_expr (expr);
+      for (tree field = TYPE_FIELDS (struct_type);
+	   field;
+	   field = TREE_CHAIN (field))
+	{
+	  CONSTRUCTOR_APPEND_ELT (ce, field,
+				  a68_low_dup (fold_build3 (COMPONENT_REF,
+							    TREE_TYPE (field),
+							    expr,
+							    field,
+							    NULL_TREE),
+					       use_heap));
+	}
+      dup = build_constructor (struct_type, ce);
+    }
+  else if (A68_UNION_TYPE_P (type))
+    {
+      /* We need to recurse in whatever type corresponding to the active mode
+	 in the united value.  This shall be done at run-time by using a series
+	 of
+
+	   IF overhead IS index of mode blah in union
+	   THEN dup = dup_type (CTYPE (mode blah in union))
+	   FI
+      */
+
+      MOID_T *union_mode = a68_type_moid (type);
+
+      a68_push_range (union_mode);
+      dup = a68_lower_tmpvar ("dup%", type, expr);
+
+      tree cunion_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
+      tree field_decl = TYPE_FIELDS (cunion_type);
+      while (EQUIVALENT (union_mode) != NO_MOID)
+	union_mode = EQUIVALENT (union_mode);
+      for (PACK_T *pack = PACK (union_mode); pack != NO_PACK; FORWARD (pack))
+	{
+	  tree continue_label_decl = build_decl (UNKNOWN_LOCATION,
+						 LABEL_DECL,
+						 NULL, /* Set below.  */
+						 void_type_node);
+	  char *label_name = xasprintf ("continue%d%%", DECL_UID (continue_label_decl));
+	  DECL_NAME (continue_label_decl) = get_identifier (label_name);
+	  free (label_name);
+
+	  a68_add_decl (continue_label_decl);
+
+	  a68_add_stmt (fold_build2 (TRUTH_ORIF_EXPR,
+				     integer_type_node,
+				     fold_build2 (EQ_EXPR,
+						  integer_type_node,
+						  a68_union_overhead (dup),
+						  size_int (a68_united_mode_index (union_mode, MOID (pack)))),
+				     fold_build2 (COMPOUND_EXPR,
+						  integer_type_node,
+						  build1 (GOTO_EXPR, void_type_node, continue_label_decl),
+						  integer_zero_node)));
+	  a68_add_stmt (fold_build2 (MODIFY_EXPR, type,
+				     fold_build3 (COMPONENT_REF,
+						  TREE_TYPE (field_decl),
+						  a68_union_cunion (dup),
+						  field_decl,
+						  NULL_TREE),
+				     a68_low_dup (fold_build3 (COMPONENT_REF,
+							       TREE_TYPE (field_decl),
+							       a68_union_cunion (dup),
+							       field_decl,
+							       NULL_TREE),
+						  use_heap)));
+	  a68_add_stmt (build1 (LABEL_EXPR, void_type_node, continue_label_decl));
+	  field_decl = TREE_CHAIN (field_decl);
+	}
+
+      a68_add_stmt (dup);
+      dup = a68_pop_range ();
+    }
+  else
+    /* Not an Algol 68 value.  */
+    gcc_unreachable ();
+
+  return dup;
+}
+
+/* Lower code to ascribe the value yielded by the expression in RHS to the
+   defining identifier implied by the LHS, which is a VAR_DECL tree.  MODE is
+   the mode of the value to be ascribed.  */
+
+tree
+a68_low_ascription (MOID_T *mode, tree lhs, tree rhs)
+{
+  gcc_assert (VAR_P (lhs));
+
+  tree type = CTYPE (mode);
+  if (IS (mode, PROC_SYMBOL))
+    {
+      /* A pointer to a function, or a function, is expected at the right hand
+	 side.  We need a pointer for the left hand side..  */
+      if (TREE_CODE (TREE_TYPE (rhs)) == FUNCTION_TYPE)
+	{
+	  type = build_pointer_type (type);
+	  rhs = fold_build1 (ADDR_EXPR, type, rhs);
+	}
+    }
+
+  if (HAS_ROWS (mode))
+    rhs = a68_low_dup (rhs);
+  return fold_build2 (MODIFY_EXPR, type, lhs, rhs);
+}
+
+/* Perform an assignation of RHS to LHS.
+
+   MODE_RHS is the mode of the rhs.
+   MODE_LHS is the mode of the lhs.
+
+   MODE_LHS shall be REF [FLEX] MODE_LHS.  */
+
+tree
+a68_low_assignation (NODE_T *p,
+		     tree lhs, MOID_T *mode_lhs,
+		     tree rhs, MOID_T *mode_rhs)
+{
+  NODE_T *lhs_node = SUB (p);
+  tree assignation = NULL_TREE;
+  tree orig_rhs = rhs;
+
+  if (IS_FLEXETY_ROW (mode_rhs))
+    {
+      /* Make a deep copy of the rhs.  Note that we have to use the heap
+	 because the scope of the lhs may be older than the scope of the rhs.
+	 XXX this can be ommitted if a68_multiple_copy_elems below supports
+	 overlapping multiples.  */
+      if (HAS_ROWS (mode_rhs))
+	rhs = a68_low_dup (rhs, true /* use_heap */);
+      rhs = save_expr (rhs);
+
+      /* Determine whether the REF [FLEX] MODE_LHS is flexible.  */
+      if (SUB (mode_lhs) == M_STRING || IS_FLEX (SUB (mode_lhs)))
+	{
+	  /* Assigning to a flexible name updates descriptor with new bounds
+	     and also sets the elements to the dup of the rhs.  No boundscheck
+	     is peformed.  XXX but bound checking in contained values may be
+	     necessary, ghost elements.  */
+	  if (POINTER_TYPE_P (TREE_TYPE (lhs))
+	      && TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs))
+	    {
+	      /* Make sure to not evaluate the expression yielding the pointer
+		 more than once.  */
+	      lhs = save_expr (lhs);
+	      tree deref_lhs = a68_checked_indirect_ref (lhs_node, lhs, mode_lhs);
+	      assignation = fold_build2 (COMPOUND_EXPR,
+					 TREE_TYPE (lhs),
+					 fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs),
+						      deref_lhs, rhs),
+					 lhs);
+	    }
+	  else
+	    {
+	      /* The lhs is either a variable or a component ref as a l-value.  It
+		 is ok to evaluate it as an r-value as well as doing so inroduces
+		 no side-effects.  */
+	      assignation = fold_build2 (COMPOUND_EXPR,
+					 TREE_TYPE (lhs),
+					 fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs),
+						      lhs, rhs),
+					 lhs);
+	    }
+	}
+      else
+	{
+	  /* Dereference the multiple at the left-hand side.  This may require
+	     indirection.  */
+
+	  tree effective_lhs;
+	  if (POINTER_TYPE_P (TREE_TYPE (lhs)))
+	    {
+	      /* The name at the lhs is a pointer.  */
+	      gcc_assert (TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs));
+	      lhs = save_expr (lhs);
+	      effective_lhs = a68_checked_indirect_ref (lhs_node, lhs, mode_lhs);
+	    }
+	  else
+	    {
+	      /* The name at the lhs is either a variable or a component ref as
+		 a l-value.  It is ok to evaluate it as an r-value as well as
+		 doing so introduces no side-effects.  */
+	      effective_lhs = lhs;
+	    }
+
+	  /* Copy over the elements in a loop.  The space occupied by the
+	     previous elements stored in the lhs multiple will be recovered by
+	     either stack shrinkage or garbage collected.  */
+	  tree copy_elements = a68_multiple_copy_elems (mode_rhs, effective_lhs, rhs);
+	  assignation = fold_build2 (COMPOUND_EXPR,
+				     TREE_TYPE (lhs),
+				     copy_elements,
+				     lhs);
+
+	  /* Check the bounds of the multiple at the rhs to make sure they are
+	     the same than the bounds of the multiple already referred by the
+	     lhs.  If the bounds don't match then emit a run-time error.  */
+	  if (OPTION_BOUNDS_CHECKING (&A68_JOB))
+	    assignation = fold_build2 (COMPOUND_EXPR,
+				       TREE_TYPE (assignation),
+				       a68_multiple_bounds_check_equal (p,
+									effective_lhs,
+									rhs),
+				       assignation);
+
+	}
+    }
+  else
+    {
+      /* First make sure we got a pointer in the RHS in case it is a name.  */
+      rhs = a68_consolidate_ref (mode_rhs, rhs);
+
+      /* The assignation implies copying the entire value being assigned, so
+	 make sure we do a deep copy whenever needed.  Note that we have to use
+	 the heap because the scope of the lhs may be older than the scope of
+	 the rhs.  */
+      if (HAS_ROWS (mode_rhs))
+	rhs = a68_low_dup (rhs, true /* use_heap */);
+
+      if (POINTER_TYPE_P (TREE_TYPE (lhs))
+	  && TREE_TYPE (TREE_TYPE (lhs)) == TREE_TYPE (rhs))
+	{
+	  /* If the left hand side is a pointer, deref it, but return the
+	     pointer.  Make sure to not evaluate the expression yielding the
+	     pointer more than once.  */
+	  lhs = save_expr (lhs);
+	  tree deref_lhs = a68_checked_indirect_ref (lhs_node, lhs, mode_lhs);
+	  assignation = fold_build2 (COMPOUND_EXPR,
+				     TREE_TYPE (lhs),
+				     fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs),
+						  deref_lhs, rhs),
+				     lhs);
+	}
+      else
+	{
+	  /* Otherwise the lhs is either a variable or a component ref as an
+	     l-value.  It is ok to evaluate it as an r-value as well as doing
+	     so introduces no side-effects.  */
+	  assignation = fold_build2 (COMPOUND_EXPR,
+				     TREE_TYPE (lhs),
+				     fold_build2 (MODIFY_EXPR, TREE_TYPE (lhs),
+						  lhs, rhs),
+				     lhs);
+	}
+    }
+
+  /* Since it is been assigned to a name, the rhs is no longer constant.  */
+  if (A68_ROW_TYPE_P (TREE_TYPE (orig_rhs)) || A68_STRUCT_TYPE_P (TREE_TYPE (orig_rhs)))
+    TREE_CONSTANT (orig_rhs) = 0;
+  return assignation;
+}
+
+/* Build a tree that copies SIZE bytes from SRC into DST.  */
+
+tree
+a68_lower_memcpy (tree dst, tree src, tree size)
+{
+  return build_call_expr (builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
+			  dst, src, size);
+}
+
+/* Build a tree that allocates SIZE bytes on the stack and returns a *TYPE
+   pointer to it.  */
+
+tree
+a68_lower_alloca (tree type, tree size)
+{
+  tree call = builtin_decl_explicit (BUILT_IN_ALLOCA_WITH_ALIGN);
+  call = build_call_expr_loc (UNKNOWN_LOCATION, call, 2,
+			      size,
+			      size_int (TYPE_ALIGN (type)));
+  call = fold_convert (build_pointer_type (type), call);
+  return call;
+}
+
+
+/* Build a tree that allocates SIZE bytes on the heap and returns a *TYPE
+   pointer to it.  */
+
+tree
+a68_lower_malloc (tree type, tree size)
+{
+  return fold_convert (build_pointer_type (type),
+		       a68_build_libcall (A68_LIBCALL_MALLOC, ptr_type_node,
+					  1, size));
+}
+
+/* Build code for a temporary variable named NAME, of type TYPE and initialized
+   to INIT.  Returns the decl node for the temporary.  */
+
+tree
+a68_lower_tmpvar (const char *name, tree type, tree init)
+{
+  tree tmpvar = build_decl (UNKNOWN_LOCATION,
+			    VAR_DECL,
+			    get_identifier (name),
+			    type);
+  DECL_ARTIFICIAL (tmpvar) = 1;
+  DECL_IGNORED_P (tmpvar) = 1;
+  a68_add_decl (tmpvar);
+  a68_add_decl_expr (fold_build1 (DECL_EXPR, type, tmpvar));
+  a68_add_stmt (fold_build2 (INIT_EXPR, type, tmpvar, init));
+  return tmpvar;
+}
+
+/* Build a FUNC_DECL for a top-level non-public function and return it.  */
+
+tree
+a68_low_toplevel_func_decl (const char *name, tree fntype)
+{
+  tree fndecl = build_decl (UNKNOWN_LOCATION,
+			    FUNCTION_DECL,
+			    NULL /* set below */,
+			    fntype);
+  char *_name = xasprintf ("__ga68_%s%d", name, DECL_UID (fndecl));
+  DECL_NAME (fndecl) = get_identifier (_name);
+  free (_name);
+  DECL_EXTERNAL (fndecl) = 0;
+  TREE_PUBLIC (fndecl) = 0;
+  TREE_STATIC (fndecl) = 1;
+
+  return fndecl;
+}
+
+/* Build a PARM_DECL whose context is TYPE with the given NAME.  */
+
+tree
+a68_low_func_param (tree fndecl, const char *name, tree type)
+{
+  tree param = build_decl (UNKNOWN_LOCATION, PARM_DECL,
+			   get_identifier (name), type);
+  DECL_CONTEXT (param) = fndecl;
+  DECL_ARG_TYPE (param) = TREE_TYPE (param);
+  layout_decl (param, 0);
+  return param;
+}
+
+/* Lower a particular program.
+
+     particular program : label, enclosed clause; enclosed clause.
+
+   This handler always returns NULL_TREE.  */
+
+static tree
+lower_particular_program (NODE_T *p,
+			  LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  /* Create the main function that conforms the particular program.  */
+  tree main_decl = build_decl (a68_get_node_location (p),
+			       FUNCTION_DECL,
+			       get_identifier ("__algol68_main"),
+			       build_function_type (void_type_node,
+						    void_list_node));
+  DECL_EXTERNAL (main_decl) = 0;
+  TREE_PUBLIC (main_decl) = 1;
+  TREE_STATIC (main_decl) = 1;
+
+  a68_push_function_range (main_decl,
+			   void_type_node /* result_type */);
+
+  /* Lower the body of the function.  */
+  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);
+  return NULL_TREE;
+}
+
+/* Lower the given tree P using the given context CTX.  */
+
+tree
+a68_lower_tree (NODE_T *p, LOW_CTX_T ctx)
+{
+#if 0
+  for (int i = 0; i < ctx.level; ++i)
+    printf (" ");
+  printf ("LOWER TREE: %d::%s\n",
+  	  NUMBER (p), a68_attribute_name (ATTRIBUTE (p)));
+#endif
+  ctx.level++;
+
+  tree res = NULL_TREE;
+
+  if (p == NO_NODE)
+    gcc_unreachable ();
+
+  switch (ATTRIBUTE (p))
+    {
+    case PARTICULAR_PROGRAM:
+      res = lower_particular_program (p, ctx);
+      break;
+      /* Clauses */
+    case ENCLOSED_CLAUSE:
+      res = a68_lower_enclosed_clause (p, ctx);
+      break;
+    case CLOSED_CLAUSE:
+      res = a68_lower_closed_clause (p, ctx);
+      break;
+    case PARALLEL_CLAUSE:
+      res = a68_lower_parallel_clause (p, ctx);
+      break;
+    case COLLATERAL_CLAUSE:
+      res = a68_lower_collateral_clause (p, ctx);
+      break;
+    case UNIT_LIST:
+      res = a68_lower_unit_list (p, ctx);
+      break;
+    case CONDITIONAL_CLAUSE:
+      res = a68_lower_conditional_clause (p, ctx);
+      break;
+    case ENQUIRY_CLAUSE:
+      res = a68_lower_enquiry_clause (p, ctx);
+      break;
+    case CASE_CLAUSE:
+      res = a68_lower_case_clause (p, ctx);
+      break;
+    case CONFORMITY_CLAUSE:
+      res = a68_lower_conformity_clause (p, ctx);
+      break;
+    case LOOP_CLAUSE:
+      res = a68_lower_loop_clause (p, ctx);
+      break;
+    case SERIAL_CLAUSE:
+      res = a68_lower_serial_clause (p, ctx);
+      break;
+    case INITIALISER_SERIES:
+      res = a68_lower_initialiser_series (p, ctx);
+      break;
+    case EXIT_SYMBOL:
+      res = a68_lower_completer (p, ctx);
+      break;
+    case LABELED_UNIT:
+      res = a68_lower_labeled_unit (p, ctx);
+      break;
+    case LABEL:
+      res = a68_lower_label (p, ctx);
+      break;
+      /* Declarations.  */
+    case DECLARATION_LIST:
+      res = a68_lower_declaration_list (p, ctx);
+      break;
+    case DECLARER:
+      res = a68_lower_declarer (p, ctx);
+      break;
+    case IDENTITY_DECLARATION:
+      res = a68_lower_identity_declaration (p, ctx);
+      break;
+    case VARIABLE_DECLARATION:
+      res = a68_lower_variable_declaration (p, ctx);
+      break;
+    case PROCEDURE_DECLARATION:
+      res = a68_lower_procedure_declaration (p, ctx);
+      break;
+    case PROCEDURE_VARIABLE_DECLARATION:
+      res = a68_lower_procedure_variable_declaration (p, ctx);
+      break;
+    case PRIORITY_DECLARATION:
+      res = a68_lower_priority_declaration (p, ctx);
+      break;
+    case BRIEF_OPERATOR_DECLARATION:
+      res = a68_lower_brief_operator_declaration (p, ctx);
+      break;
+    case OPERATOR_DECLARATION:
+      res = a68_lower_operator_declaration (p, ctx);
+      break;
+    case MODE_DECLARATION:
+      res = a68_lower_mode_declaration (p, ctx);
+      break;
+      /* Units. */
+    case UNIT:
+      res = a68_lower_unit (p, ctx);
+      break;
+    case ROUTINE_TEXT:
+      res = a68_lower_routine_text (p, ctx);
+      break;
+    case ASSIGNATION:
+      res = a68_lower_assignation (p, ctx);
+      break;
+    case TERTIARY:
+      res = a68_lower_tertiary (p, ctx);
+      break;
+    case MONADIC_FORMULA:
+      res = a68_lower_monadic_formula (p, ctx);
+      break;
+    case FORMULA:
+      res = a68_lower_formula (p, ctx);
+      break;
+    case SECONDARY:
+      res = a68_lower_secondary (p, ctx);
+      break;
+    case SLICE:
+      res = a68_lower_slice (p, ctx);
+      break;
+    case SELECTION:
+      res = a68_lower_selection (p, ctx);
+      break;
+    case PRIMARY:
+      res = a68_lower_primary (p, ctx);
+      break;
+    case GENERATOR:
+      res = a68_lower_generator (p, ctx);
+      break;
+    case CALL:
+      res = a68_lower_call (p, ctx);
+      break;
+    case CAST:
+      res = a68_lower_cast (p, ctx);
+      break;
+    case AND_FUNCTION:
+    case OR_FUNCTION:
+      res = a68_lower_logic_function (p, ctx);
+      break;
+    case IDENTITY_RELATION:
+      res = a68_lower_identity_relation (p, ctx);
+      break;
+    case EMPTY_SYMBOL:
+      res = a68_lower_empty (p, ctx);
+      break;
+    case NIHIL:
+      res = a68_lower_nihil (p, ctx);
+      break;
+    case SKIP:
+      res = a68_lower_skip (p, ctx);
+      break;
+    case DENOTATION:
+      res = a68_lower_denotation (p, ctx);
+      break;
+    case IDENTIFIER:
+      res = a68_lower_identifier (p, ctx);
+      break;
+      /* Coercions.  */
+    case ROWING:
+      res = a68_lower_rowing (p, ctx);
+      break;
+    case WIDENING:
+      res = a68_lower_widening (p, ctx);
+      break;
+    case DEPROCEDURING:
+      res = a68_lower_deproceduring (p, ctx);
+      break;
+    case PROCEDURING:
+      res = a68_lower_proceduring (p, ctx);
+      break;
+    case VOIDING:
+      res = a68_lower_voiding (p, ctx);
+      break;
+    case DEREFERENCING:
+      res = a68_lower_dereferencing (p, ctx);
+      break;
+      /* Others. */
+    case UNITING:
+      res = a68_lower_uniting (p, ctx);
+      break;
+    case JUMP:
+      res = a68_lower_jump (p, ctx);
+      break;
+    case PARAMETER:
+      res = a68_lower_parameter (p, ctx);
+      break;
+    case PARAMETER_LIST:
+      res = a68_lower_parameter_list (p, ctx);
+      break;
+    case PARAMETER_PACK:
+      res = a68_lower_parameter_pack (p, ctx);
+      break;
+    case OPERATOR:
+      res = a68_lower_operator (p, ctx);
+      break;
+    case ASSERTION:
+      res = a68_lower_assertion (p, ctx);
+      break;
+    case STOP:
+      res = NULL_TREE;
+      break;
+    default:
+      fatal_error (a68_get_node_location (p), "cannot lower node %s",
+		   a68_attribute_name (ATTRIBUTE (p)));
+      gcc_unreachable ();
+      break;
+    }
+
+  return res;
+}
+
+/* Lower an Algol 68 complete parse tree to a GENERIC tree.  */
+
+tree
+a68_lower_top_tree (NODE_T *p)
+{
+  LOW_CTX_T top_ctx;
+
+  top_ctx.declarer = NULL;
+  top_ctx.proc_decl_identifier = NO_NODE;
+  top_ctx.level = 0;
+  return a68_lower_tree (p, top_ctx);
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 30/47] a68: low: plain values
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (28 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 29/47] a68: low: lowering entry point and misc handlers Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 31/47] a68: low: stowed values Jose E. Marchesi
                   ` (17 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-low-bits.cc: New file.
	* algol68/a68-low-bools.cc: Likewise.
	* algol68/a68-low-chars.cc: Likewise.
	* algol68/a68-low-complex.cc: Likewise.
	* algol68/a68-low-ints.cc: Likewise.
	* algol68/a68-low-procs.cc: Likewise.
	* algol68/a68-low-reals.cc: Likewise.
	* algol68/a68-low-refs.cc: Likewise.
	* algol68/a68-low-strings.cc: Likewise.
---
 gcc/algol68/a68-low-bits.cc    | 297 ++++++++++++++++
 gcc/algol68/a68-low-bools.cc   |  77 ++++
 gcc/algol68/a68-low-chars.cc   | 170 +++++++++
 gcc/algol68/a68-low-complex.cc | 141 ++++++++
 gcc/algol68/a68-low-ints.cc    | 327 +++++++++++++++++
 gcc/algol68/a68-low-procs.cc   |  52 +++
 gcc/algol68/a68-low-reals.cc   | 620 +++++++++++++++++++++++++++++++++
 gcc/algol68/a68-low-refs.cc    |  52 +++
 gcc/algol68/a68-low-strings.cc | 390 +++++++++++++++++++++
 9 files changed, 2126 insertions(+)
 create mode 100644 gcc/algol68/a68-low-bits.cc
 create mode 100644 gcc/algol68/a68-low-bools.cc
 create mode 100644 gcc/algol68/a68-low-chars.cc
 create mode 100644 gcc/algol68/a68-low-complex.cc
 create mode 100644 gcc/algol68/a68-low-ints.cc
 create mode 100644 gcc/algol68/a68-low-procs.cc
 create mode 100644 gcc/algol68/a68-low-reals.cc
 create mode 100644 gcc/algol68/a68-low-refs.cc
 create mode 100644 gcc/algol68/a68-low-strings.cc

diff --git a/gcc/algol68/a68-low-bits.cc b/gcc/algol68/a68-low-bits.cc
new file mode 100644
index 00000000000..465969f9ade
--- /dev/null
+++ b/gcc/algol68/a68-low-bits.cc
@@ -0,0 +1,297 @@
+/* Lowering routines for all things related to BITS values.
+   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"
+
+/* Return a tree with the yielind of SKIP for the given BITS mode.  */
+
+tree
+a68_get_bits_skip_tree (MOID_T *m)
+{
+  tree type;
+
+  if (m == M_BITS)
+    type = a68_bits_type;
+  else if (m == M_LONG_BITS)
+    type = a68_long_bits_type;
+  else if (m == M_LONG_LONG_BITS)
+    type = a68_long_long_bits_type;
+  else if (m == M_SHORT_BITS)
+    type = a68_short_bits_type;
+  else if (m == M_SHORT_SHORT_BITS)
+    type = a68_short_short_bits_type;
+  else
+    gcc_unreachable ();
+
+  return build_int_cst (type, 0);
+}
+
+/* Given a BITS type, compute the number of bits that fit in a value of that
+   type.  The result is an INT.  */
+
+tree
+a68_bits_width (tree type)
+{
+  return fold_convert (a68_int_type, TYPE_SIZE (type));
+}
+
+/* Given a BITS type, compute the maximum value that can be expressed with that
+   type.  */
+
+tree
+a68_bits_maxbits (tree type)
+{
+  return fold_convert (type, TYPE_MAX_VALUE (type));
+}
+
+/* Given a SIZETY INT value VAL, compute and return a SIZETY BITS reflecting
+   its constituent bits.
+
+   In strict Algol 68 the BIN of a negative value is BITS (SKIP).
+
+   In GNU 68 the BIN of a negative value is the constituent bits of the two's
+   complement of the value.  */
+
+tree
+a68_bits_bin (MOID_T *m, tree val)
+{
+  tree type = CTYPE (m);
+
+  if (OPTION_STRICT (&A68_JOB))
+    return a68_get_bits_skip_tree (m);
+  else
+    return fold_convert (type, val);
+}
+
+/* Given a SIZETY BITS value BITS, compute and return the corresponding SIZETY
+   INT.
+
+   In strict Algol 68 the ABS of a BITS value reflecting a bit pattern that
+   would correspond a negative integral value is INT (SKIP).
+
+   In GNU 68 the ABS of a BITS value reflecting a bit pattern that would
+   correspond a negative integral value is that negative integral value.  */
+
+tree
+a68_bits_abs (MOID_T *m, tree bits)
+{
+  tree type = CTYPE (m);
+
+  if (OPTION_STRICT (&A68_JOB))
+    {
+      tree integral_val = save_expr (fold_convert (type, bits));
+      return fold_build3 (COND_EXPR,
+			  type,
+			  fold_build2 (LT_EXPR, type, integral_val,
+				       build_int_cst (type, 0)),
+			  a68_get_int_skip_tree (m),
+			  integral_val);
+    }
+  else
+    return fold_convert (type, bits);
+}
+
+/* Given a SIZETY BITS value BITS, shorten it into a SIZETY BITS whose tree
+   type is TYPE.  */
+
+tree
+a68_bits_shorten (tree type, tree bits)
+{
+  /* This will truncate at the left, which is what is intended.  */
+  return fold_convert (type, bits);
+}
+
+/* Given a SIZETY BITS value BITS, length it into a SIZETY BITS whose tree type
+   is TYPE.  */
+
+tree
+a68_bits_leng (tree type, tree bits)
+{
+  /* This will add zeroes to the left, which is what is intended.  */
+  return fold_convert (type, bits);
+}
+
+/* Given a SIZETY BITS value BITS, compute and return a new SIZETY BITS whose
+   bits are the logical negation of the bits of BITS.  */
+
+tree
+a68_bits_not (tree bits)
+{
+  return fold_build1 (BIT_NOT_EXPR, TREE_TYPE (bits), bits);
+}
+
+/* Given two SIZETY BITS values BITS1 and BITS2, compute and return a new
+   SIZETY BITS whose bits are the `and' of the bits of BITS1 and
+   BITS2.  */
+
+tree
+a68_bits_and (tree bits1, tree bits2)
+{
+  return fold_build2 (BIT_AND_EXPR, TREE_TYPE (bits1), bits1, bits2);
+}
+
+/* Given two SIZETY BITS values BITS1 and BITS2, compute and return a new
+   SIZETY BITS whose bits are the inclusive-or of the bits of BITS1 and
+   BITS2.  */
+
+tree
+a68_bits_ior (tree bits1, tree bits2)
+{
+  return fold_build2 (BIT_IOR_EXPR, TREE_TYPE (bits1), bits1, bits2);
+}
+
+/* Given two SIZETY BITS values BITS1 and BITS2, compute and return a new
+   SIZETY BITS whose bits are the exclusive-or of the bits of BITS1 and
+   BITS2.  */
+
+tree
+a68_bits_xor (tree bits1, tree bits2)
+{
+  return fold_build2 (BIT_XOR_EXPR, TREE_TYPE (bits1), bits1, bits2);
+}
+
+/* Given a position POS of mode INT and a BITS of mode SIZETY BITS, return a
+   BOOL reflecting the state of the bit occupying the position POS in BITS.
+
+   If POS is out of range a run-time error is emitted.  */
+
+tree
+a68_bits_elem (NODE_T *p, tree pos, tree bits)
+{
+  pos = save_expr (pos);
+  tree one = build_int_cst (TREE_TYPE (bits), 1);
+
+  tree shift = fold_build2 (MINUS_EXPR, bitsizetype,
+			    TYPE_SIZE (TREE_TYPE (bits)),
+			    fold_convert (bitsizetype, pos));
+  tree elem = fold_build2 (EQ_EXPR,
+			   a68_bool_type,
+			   fold_build2 (BIT_AND_EXPR,
+					TREE_TYPE (bits),
+					fold_build2 (RSHIFT_EXPR,
+						     TREE_TYPE (bits),
+						     bits, shift),
+					one),
+			   one);
+
+  /* Do bounds checking if requested.  */
+  if (OPTION_BOUNDS_CHECKING (&A68_JOB))
+    {
+      unsigned int lineno = NUMBER (LINE (INFO (p)));
+      const char *filename_str = FILENAME (LINE (INFO (p)));
+      tree filename = build_string_literal (strlen (filename_str) + 1,
+					    filename_str);
+      tree call = a68_build_libcall (A68_LIBCALL_BITSBOUNDSERROR,
+				     void_type_node, 3,
+				     filename,
+				     build_int_cst (unsigned_type_node, lineno),
+				     fold_convert (ssizetype, pos));
+      tree check = fold_build2 (TRUTH_AND_EXPR, integer_type_node,
+				fold_build2 (GT_EXPR, integer_type_node,
+					     pos, fold_convert (TREE_TYPE (pos), integer_zero_node)),
+				fold_build2 (LE_EXPR, integer_type_node,
+					     fold_convert (bitsizetype, pos),
+					     TYPE_SIZE (TREE_TYPE (bits))));
+
+      check = fold_build2_loc (a68_get_node_location (p),
+			       TRUTH_ORIF_EXPR,
+			       ssizetype,
+			       check,
+			       fold_build2 (COMPOUND_EXPR, a68_bool_type,
+					    call, boolean_false_node));
+      elem = fold_build2 (COMPOUND_EXPR, a68_bool_type,
+			  check, elem);
+    }
+
+  return elem;
+}
+
+/* Given two SIZETY BITS values BITS1 and BITS2, return a BOOL value indicating
+   whether all the bits set in BITS1 are also set in BITS2.  */
+
+tree
+a68_bits_subset (tree bits1, tree bits2)
+{
+  /* We compute this operation with `A | B == B' as specified by the Report */
+  bits2 = save_expr (bits2);
+  return fold_build2 (EQ_EXPR, a68_bool_type,
+		      fold_build2 (BIT_IOR_EXPR, TREE_TYPE (bits1), bits1, bits2),
+		      bits2);
+}
+
+/* Rotate the bits in BITS SHIFT bits to the left if SHIFT is positive, or ABS
+   (SHIFT) bits to the right if SHIFT is negative.
+
+   A run-time error is raised if the count overflows the BITS value.  */
+
+tree
+a68_bits_shift (tree shift, tree bits)
+{
+  shift = save_expr (shift);
+  bits = save_expr (bits);
+  return fold_build3 (COND_EXPR,
+		      TREE_TYPE (bits),
+		      fold_build2 (GE_EXPR, TREE_TYPE (shift),
+				   shift, build_int_cst (TREE_TYPE (shift), 0)),
+		      fold_build2 (LSHIFT_EXPR, TREE_TYPE (bits),
+				   bits, shift),
+		      fold_build2 (RSHIFT_EXPR, TREE_TYPE (bits),
+				   bits,
+				   fold_build1 (ABS_EXPR, TREE_TYPE (shift), shift)));
+}
+
+/* Given two bits values, build an expression that calculates whether A = B.  */
+
+tree
+a68_bits_eq (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two bits values, build an expression that calculates whether A /=
+   B.  */
+
+tree
+a68_bits_ne (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b);
+}
diff --git a/gcc/algol68/a68-low-bools.cc b/gcc/algol68/a68-low-bools.cc
new file mode 100644
index 00000000000..000e919407d
--- /dev/null
+++ b/gcc/algol68/a68-low-bools.cc
@@ -0,0 +1,77 @@
+/* Lowering routines for all things related to BOOL values.
+   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"
+
+/* Return a tree with the yielind of SKIP of a BOOL mode.  */
+
+tree
+a68_get_bool_skip_tree (void)
+{
+  return build_int_cst (a68_bool_type, 0);
+}
+
+/* The absolute value of a BOOL is a non-zero INT for TRUE and zero for
+   FALSE.  */
+
+tree
+a68_bool_abs (tree val)
+{
+  return fold_convert (a68_int_type, val);
+}
+
+/* Given two boolean values, build an expression that calculates whether A = B.  */
+
+tree
+a68_bool_eq (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two boolean values, build an expression that calculates whether A /=
+   B.  */
+
+tree
+a68_bool_ne (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b);
+}
diff --git a/gcc/algol68/a68-low-chars.cc b/gcc/algol68/a68-low-chars.cc
new file mode 100644
index 00000000000..24449347555
--- /dev/null
+++ b/gcc/algol68/a68-low-chars.cc
@@ -0,0 +1,170 @@
+/* Lowering routines for all things related to STRINGs.
+   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"
+
+/* Return a tree with the yielind of SKIP of a CHAR mode.  */
+
+tree
+a68_get_char_skip_tree (void)
+{
+  return build_int_cst (a68_char_type, ' ');
+}
+
+/* Return the maximum valid character code that can be stored in a CHAR.  */
+tree
+a68_char_max (void)
+{
+  /* 0x10FFFF is the maximum valid code point in Unicode.  */
+  return build_int_cst (a68_char_type, 0x10FFFF);
+}
+
+/* Given an integral value, if it denotes a char code build the corresponding
+   CHAR.  Otherwise raise a run-time error.  */
+
+tree
+a68_char_repr (NODE_T *p, tree val)
+{
+  /* UCS-4 (UTF-32) encodes the Unicode code points using the identity
+     function.  Valid code points are in the ranges [U+0000,U+D7FF] and
+     [U+E000,U+10FFFF].  */
+
+  tree c = save_expr (val);
+  tree val_type = TREE_TYPE (val);
+
+  /* (c >= 0 && c < 0xd800) */
+  tree range1 = fold_build2 (TRUTH_AND_EXPR, integer_type_node,
+			     fold_build2 (GE_EXPR, integer_type_node,
+					  c, fold_convert (val_type, integer_zero_node)),
+			     fold_build2 (LT_EXPR, integer_type_node,
+					  c, build_int_cst (val_type, 0xd800)));
+  /* (c >= 0xe000 && c < 0x110000) */
+  tree range2 = fold_build2 (TRUTH_AND_EXPR, integer_type_node,
+			     fold_build2 (GE_EXPR, integer_type_node,
+					  c, build_int_cst (val_type, 0xe000)),
+			     fold_build2 (LT_EXPR, integer_type_node,
+					  c, build_int_cst (val_type, 0x110000)));
+  tree notvalid = fold_build1 (TRUTH_NOT_EXPR,
+			       integer_type_node,
+			       fold_build2 (TRUTH_OR_EXPR, integer_type_node,
+					    range1, range2));
+
+  /* Call to the runtime run-time error handler.  */
+  unsigned int lineno = NUMBER (LINE (INFO (p)));
+  const char *filename_str = FILENAME (LINE (INFO (p)));
+  tree filename = build_string_literal (strlen (filename_str) + 1,
+					    filename_str);
+  tree call = a68_build_libcall (A68_LIBCALL_INVALIDCHARERROR,
+				 void_type_node, 3,
+				 filename,
+				 build_int_cst (unsigned_type_node, lineno),
+				 fold_convert (a68_int_type, c));
+
+  /* Return the REPR of the given integer value, or raise run-time error.  */
+  return fold_build2 (COMPOUND_EXPR, a68_char_type,
+		      fold_build3 (COND_EXPR, integer_type_node,
+				   notvalid,
+				   call, integer_zero_node),
+		      fold_convert (a68_char_type, c));
+}
+
+/* the ABS of a CHAR is an INT containing an unique value for each permissable
+   char value.  */
+
+tree
+a68_char_abs (tree val)
+{
+  return fold_convert (a68_int_type, val);
+}
+
+/* Given two characters, build an expression that calculates whether A = B.  */
+
+tree
+a68_char_eq (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two characters, build an expression that calculates whether A /=
+   B.  */
+
+tree
+a68_char_ne (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two characters, build an expression that calculates
+   whether A < B.  */
+
+tree
+a68_char_lt (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, LT_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two characters, build an expression that calculates
+   whether A <= B.  */
+
+tree
+a68_char_le (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, LE_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two characters, build an expression that calculates
+   whether A > B.  */
+
+tree
+a68_char_gt (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, GT_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two characters, build an expression that calculates
+   whether A >= B.  */
+
+tree
+a68_char_ge (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, GE_EXPR, boolean_type_node, a, b);
+}
diff --git a/gcc/algol68/a68-low-complex.cc b/gcc/algol68/a68-low-complex.cc
new file mode 100644
index 00000000000..aed1c3c3dab
--- /dev/null
+++ b/gcc/algol68/a68-low-complex.cc
@@ -0,0 +1,141 @@
+/* Lowering routines for all things related to COMPL values.
+   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"
+
+/* Build a new COMPL value with real part RE and imaginary part IM, of mode
+   MODE.  */
+
+tree
+a68_complex_i (MOID_T *mode, tree re, tree im)
+{
+  tree compl_type = CTYPE (mode);
+
+  tree re_field = TYPE_FIELDS (compl_type);
+  tree im_field = TREE_CHAIN (re_field);
+  return build_constructor_va (CTYPE (mode), 2,
+			       re_field, re,
+			       im_field, im);
+}
+
+/* Given a COMPL value Z, get its real part.  */
+
+tree
+a68_complex_re (tree z)
+{
+  tree re_field = TYPE_FIELDS (TREE_TYPE (z));
+  return fold_build3 (COMPONENT_REF, TREE_TYPE (re_field),
+		      z, re_field, NULL_TREE);
+}
+
+tree
+a68_complex_im (tree z)
+{
+  tree im_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (z)));
+  return fold_build3 (COMPONENT_REF, TREE_TYPE (im_field),
+		      z, im_field, NULL_TREE);
+}
+
+/* Return the conjugate of the given complex Z of mode MODE.  */
+
+tree
+a68_complex_conj (MOID_T *mode, tree z)
+{
+  tree re_field = TYPE_FIELDS (TREE_TYPE (z));
+  tree complex_type = build_complex_type (TREE_TYPE (re_field), false /* named */);
+
+  z = save_expr (z);
+  tree complex = fold_build2 (COMPLEX_EXPR, complex_type,
+			      a68_complex_re (z), a68_complex_im (z));
+  tree conj = fold_build1 (CONJ_EXPR, TREE_TYPE (complex), complex);
+
+  return a68_complex_i (mode,
+			fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (z)), conj),
+			fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (z)), conj));
+}
+
+/* Widen a real R to a complex of mode MODE.  */
+
+tree
+a68_complex_widen_from_real (MOID_T *mode, tree r)
+{
+  tree compl_type = CTYPE (mode);
+  gcc_assert (compl_type != NULL_TREE);
+
+  /* Sanity check.  */
+  if (mode == M_COMPLEX)
+    gcc_assert (TREE_TYPE (r) == a68_real_type);
+  else if (mode == M_LONG_COMPLEX)
+    gcc_assert (TREE_TYPE (r) == a68_long_real_type);
+  else if (mode == M_LONG_LONG_COMPLEX)
+    gcc_assert (TREE_TYPE (r) == a68_long_long_real_type);
+  else
+    gcc_unreachable ();
+
+  a68_push_range (mode);
+  tree res = a68_lower_tmpvar ("compl%", compl_type,
+			       a68_get_skip_tree (mode));
+
+  /* Look for the "re" field.  */
+  tree field_id = a68_get_mangled_identifier ("re");
+  tree field = NULL_TREE;
+  for (tree f = TYPE_FIELDS (compl_type); f; f = DECL_CHAIN (f))
+    {
+      if (field_id == DECL_NAME (f))
+	{
+	  field = f;
+	  break;
+	}
+    }
+  gcc_assert (field != NULL_TREE);
+
+  /* Set it to the given real value.  */
+  a68_add_stmt (fold_build2 (MODIFY_EXPR,
+			     TREE_TYPE (r),
+			     fold_build3 (COMPONENT_REF,
+					  TREE_TYPE (field),
+					  res, field,
+					  NULL_TREE),
+			     r));
+  a68_add_stmt (res);
+  return a68_pop_range ();
+}
diff --git a/gcc/algol68/a68-low-ints.cc b/gcc/algol68/a68-low-ints.cc
new file mode 100644
index 00000000000..d119de9a56b
--- /dev/null
+++ b/gcc/algol68/a68-low-ints.cc
@@ -0,0 +1,327 @@
+/* Lowering routines for all things related to INT values.
+   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"
+
+/* Return a tree with the yielind of SKIP for the given integral mode.  */
+
+tree
+a68_get_int_skip_tree (MOID_T *m)
+{
+  tree type;
+
+  if (m == M_INT)
+    type = a68_int_type;
+  else if (m == M_LONG_INT)
+    type = a68_long_int_type;
+  else if (m == M_LONG_LONG_INT)
+    type = a68_long_long_int_type;
+  else if (m == M_SHORT_INT)
+    type = a68_short_int_type;
+  else if (m == M_SHORT_SHORT_INT)
+    type = a68_short_short_int_type;
+  else
+    gcc_unreachable ();
+
+  return build_int_cst (type, 0);
+}
+
+/* Given an integral type, build the maximum value expressable in that
+   type.  */
+
+tree
+a68_int_maxval (tree type)
+{
+  return fold_convert (type, TYPE_MAX_VALUE (type));
+}
+
+/* Given an integral type, build the minimum value expressable in that
+   type.  */
+
+tree
+a68_int_minval (tree type)
+{
+  return fold_convert (type, TYPE_MIN_VALUE (type));
+}
+
+/* Given an integral type, build an INT with the number of decimal digits
+   required to represent a value of that typ, not including sign.  */
+
+tree
+a68_int_width (tree type)
+{
+  /* Note that log10 (2) is ~ 0.3.
+     Thanks to Andrew Pinski for suggesting using this expression.  */
+  return fold_build2 (PLUS_EXPR, a68_int_type,
+		      build_int_cst (a68_int_type, 1),
+		      fold_build2 (TRUNC_DIV_EXPR,
+				   a68_int_type,
+				   fold_build2 (MULT_EXPR, a68_int_type,
+						build_int_cst (a68_int_type, TYPE_PRECISION (type)),
+						build_int_cst (a68_int_type, 3)),
+				   build_int_cst (a68_int_type, 10)));
+}
+
+/* Given an integer value VAL, return -1 if it is less than zero, 0 if it is
+   zero and +1 if it is bigger than zero.  The built value is always of mode
+   M_INT.  */
+
+tree
+a68_int_sign (tree val)
+{
+  tree zero = build_int_cst (TREE_TYPE (val), 0);
+  return fold_build3 (COND_EXPR,
+		      a68_int_type,
+		      fold_build2 (EQ_EXPR, integer_type_node, val, zero),
+		      build_int_cst (a68_int_type, 0),
+		      fold_build3 (COND_EXPR,
+				   a68_int_type,
+				   fold_build2 (GT_EXPR, integer_type_node, val, zero),
+				   build_int_cst (a68_int_type, 1),
+				   build_int_cst (a68_int_type, -1)));
+}
+
+/* Absolute value of an integer.  */
+
+tree
+a68_int_abs (tree val)
+{
+  return fold_build1 (ABS_EXPR, TREE_TYPE (val), val);
+}
+
+/* Build the integral value lengthened from the value of VAL, from mode
+   FROM_MODE to mode TO_MODE.  */
+
+tree
+a68_int_leng (MOID_T *to_mode, MOID_T *from_mode ATTRIBUTE_UNUSED, tree val)
+{
+  /* Lengthening can be done by just a cast.  */
+  return fold_convert (CTYPE (to_mode), val);
+}
+
+/* Build the integral value that can be lengthened to the value of VAL, from
+   mode FROM_MODE to mode TO_MODE.
+
+   If VAL cannot be represented in TO_MODE because it is bigger than the most
+   positive value representable in TO_MODE, then it is truncated to that value.
+
+   Likewise, if VAL cannot be represented in TO_MODE because it is less than
+   the most negative value representable in TO_MODE, then it is truncated to
+   that value.  */
+
+tree
+a68_int_shorten (MOID_T *to_mode, MOID_T *from_mode ATTRIBUTE_UNUSED, tree val)
+{
+  tree most_positive_value = fold_convert (CTYPE (from_mode),
+					   a68_int_maxval (CTYPE (to_mode)));
+  tree most_negative_value = fold_convert (CTYPE (from_mode),
+					   a68_int_minval (CTYPE (to_mode)));
+
+  val = save_expr (val);
+  most_positive_value = save_expr (most_positive_value);
+  most_negative_value = save_expr (most_negative_value);
+  return fold_build3 (COND_EXPR, CTYPE (to_mode),
+		      fold_build2 (GT_EXPR, a68_bool_type, val, most_positive_value),
+		      fold_convert (CTYPE (to_mode), most_positive_value),
+		      fold_build3 (COND_EXPR, CTYPE (to_mode),
+				   fold_build2 (LT_EXPR, a68_bool_type, val, most_negative_value),
+				   fold_convert (CTYPE (to_mode), most_negative_value),
+				   fold_convert (CTYPE (to_mode), val)));
+}
+
+/* Given two integral values of mode M, build an expression that calculates the
+   addition of A and B.  */
+
+tree
+a68_int_plus (MOID_T *m, tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, PLUS_EXPR, CTYPE (m), a, b);
+}
+
+/* Given two integral values of mode M, build an expression that calculates the
+   subtraction of A by B.  */
+
+tree
+a68_int_minus (MOID_T *m, tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, MINUS_EXPR, CTYPE (m), a, b);
+}
+
+/* Given two integral values of mode M, build an expression that calculates the
+   multiplication of A by B.  */
+
+tree
+a68_int_mult (MOID_T *m, tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, MULT_EXPR, CTYPE (m), a, b);
+}
+
+/* Given two integral values of mode M, build an expression that calculates the
+   division of A by B.  */
+
+tree
+a68_int_div (MOID_T *m, tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, TRUNC_DIV_EXPR, CTYPE (m), a, b);
+}
+
+/* Given two integral values of mode M, build an expression that calculates
+   whether A = B.  */
+
+tree
+a68_int_eq (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two integral values of mode M, build an expression that calculates
+   whether A /= B.  */
+
+tree
+a68_int_ne (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two integral values of mode M, build an expression that calculates
+   whether A < B.  */
+
+tree
+a68_int_lt (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, LT_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two integral values of mode M, build an expression that calculates
+   whether A <= B.  */
+
+tree
+a68_int_le (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, LE_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two integral values of mode M, build an expression that calculates
+   whether A > B.  */
+
+tree
+a68_int_gt (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, GT_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two integral values of mode M, build an expression that calculates
+   whether A >= B.  */
+
+tree
+a68_int_ge (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, GE_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two integral values of mode M, build and expression that calculates the
+   modulus as specified by the Revised Report:
+
+   OP MOD = (L INT a, b) L INT:
+     (INT r = a - a % b * b; r < 0 | r + ABS b | r)
+*/
+
+tree
+a68_int_mod (MOID_T *m, tree a, tree b, location_t loc)
+{
+  a = save_expr (a);
+  b = save_expr (b);
+  tree r = a68_int_minus (m, a, a68_int_mult (m, a68_int_div (m, a, b), b));
+
+  r = save_expr (r);
+  return fold_build3_loc (loc, COND_EXPR, CTYPE (m),
+			  a68_int_lt (r, build_int_cst (CTYPE (m), 0)),
+			  a68_int_plus (m, r, a68_int_abs (b)),
+			  r);
+}
+
+/* Given two integral values values, the first of mode M an the second of mode
+   INT, build an expression that calculates the exponentiation of A by B, as
+   specified by the Revised Report:
+
+   OP ** = (L INT a, INT b) L INT:
+     (b >= 0 | L INT p := L 1; TO b DO p := p * a OD; p)
+*/
+
+tree
+a68_int_pow (MOID_T *m, tree a, tree b, location_t loc)
+{
+  tree zero = build_int_cst (CTYPE (m), 0);
+  tree one = build_int_cst (CTYPE (m), 1);
+
+  a = save_expr (a);
+  b = save_expr (fold_convert (CTYPE (m), b));
+
+  a68_push_range (m);
+  tree index = a68_lower_tmpvar ("index%", CTYPE (m), zero);
+  tree p = a68_lower_tmpvar ("p%", CTYPE (m), one);
+
+  /* Begin of loop body.  */
+  a68_push_range (NULL);
+  {
+    /* if (index == b) break;  */
+    a68_add_stmt (fold_build1 (EXIT_EXPR,
+			       void_type_node,
+			       fold_build2 (EQ_EXPR, CTYPE (m),
+					    index, b)));
+    a68_add_stmt (fold_build2 (MODIFY_EXPR, CTYPE (m),
+			       p, a68_int_mult (m, p, a)));
+
+    /* index++ */
+    a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, CTYPE (m),
+			       index, one));
+  }
+  tree loop_body = a68_pop_range ();
+  a68_add_stmt (fold_build1 (LOOP_EXPR,
+			     void_type_node,
+			     loop_body));
+  a68_add_stmt (p);
+  tree calculate_p = a68_pop_range ();
+  return fold_build3_loc (loc, COND_EXPR, CTYPE (m),
+			  a68_int_ge (b, zero),
+			  calculate_p, zero);
+}
diff --git a/gcc/algol68/a68-low-procs.cc b/gcc/algol68/a68-low-procs.cc
new file mode 100644
index 00000000000..cc43d52aa6b
--- /dev/null
+++ b/gcc/algol68/a68-low-procs.cc
@@ -0,0 +1,52 @@
+/* Lowering routines for all things related to procedures.
+   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"
+
+/* Return a tree with the yielding of SKIP for the given procedure mode.  */
+
+tree
+a68_get_proc_skip_tree (MOID_T *m)
+{
+  /* A SKIP for a procecure mode lowers to a NULL pointer to a function.  */
+  return build_int_cst (CTYPE (m), 0);
+}
diff --git a/gcc/algol68/a68-low-reals.cc b/gcc/algol68/a68-low-reals.cc
new file mode 100644
index 00000000000..ab0064a4855
--- /dev/null
+++ b/gcc/algol68/a68-low-reals.cc
@@ -0,0 +1,620 @@
+/* Lowering routines for all things related to REAL values.
+   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 "math.h" /* For log10 */
+
+#include "a68.h"
+
+tree
+a68_get_real_skip_tree (MOID_T *m)
+{
+  tree int_type = NULL_TREE;
+  tree real_type = NULL_TREE;
+
+  if (m == M_REAL)
+    {
+      int_type = a68_int_type;
+      real_type = a68_real_type;
+    }
+  else if (m == M_LONG_REAL)
+    {
+      int_type = a68_long_int_type;
+      real_type = a68_long_real_type;
+    }
+  else if (m == M_LONG_LONG_REAL)
+    {
+      int_type = a68_long_long_int_type;
+      real_type = a68_long_long_real_type;
+    }
+  else
+    gcc_unreachable ();
+
+  return build_real_from_int_cst (real_type,
+				  build_int_cst (int_type, 0));
+}
+
+static tree
+addr_of_builtin_decl (enum built_in_function fncode)
+{
+  tree builtin = builtin_decl_explicit (fncode);
+  return fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (builtin)), builtin);
+}
+
+/* Build PI for the given real type.  */
+
+tree
+a68_real_pi (tree type)
+{
+  return build_real (type, dconst_pi ());
+}
+
+/* Given a real type, build the maximum value expresssable with that type.  */
+
+tree
+a68_real_maxval (tree type)
+{
+  REAL_VALUE_TYPE max;
+  real_maxval (&max, 0, TYPE_MODE (type));
+  return build_real (type, max);
+}
+
+/* Given a real type, build the minimum value expressable with that type.  */
+
+tree
+a68_real_minval (tree type)
+{
+  REAL_VALUE_TYPE min;
+  real_maxval (&min, 1, TYPE_MODE (type));
+  return build_real (type, min);
+}
+
+/* Given a real type, build the smallest value which can be meaningfully added
+   to or substracted from 1.  */
+
+tree
+a68_real_smallval (tree type)
+{
+  /* The smallest real value which can be meaningfully added to or subtracted
+     from 1.  */
+  const machine_mode mode = TYPE_MODE (type);
+  const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+
+  char buf[128];
+  if (fmt->pnan < fmt->p)
+    snprintf (buf, sizeof (buf), "0x1p%d", fmt->emin - fmt->p);
+  else
+    snprintf (buf, sizeof (buf), "0x1p%d", 1 - fmt->p);
+
+  REAL_VALUE_TYPE res;
+  real_from_string (&res, buf);
+  return build_real (type, res);
+}
+
+/* Given a real type, build an INT with the number of decimal digits required
+   to represent a mantissa, such that a real is not reglected in comparison
+   with 1, not including sign.  */
+
+tree
+a68_real_width (tree type)
+{
+  const machine_mode mode = TYPE_MODE (type);
+  const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+  return build_int_cst (a68_int_type, fmt->p);
+}
+
+/* Given a real type, build an INT with the number of decimal digits required
+   to represent a decimal exponent, such that a real can be correctly
+   represented, not including sign.  */
+
+tree
+a68_real_exp_width (tree type ATTRIBUTE_UNUSED)
+{
+  const machine_mode mode = TYPE_MODE (type);
+  const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+  const double log10_2 = .30102999566398119521;
+  double log10_b = log10_2;
+  int max_10_exp = fmt->emax * log10_b;
+
+  return build_int_cst (a68_int_type, 1 + log10 (max_10_exp));
+}
+
+/* Given a real value VAL, return -1 if it is less than zero, 0 if it is zero
+   and +1 if it is bigger than zero.  The built value is always of mode
+   M_INT.  */
+
+tree
+a68_real_sign (tree val)
+{
+  tree zero = build_real (TREE_TYPE (val), dconst0);
+  return fold_build3 (COND_EXPR,
+		      a68_int_type,
+		      build2 (EQ_EXPR, integer_type_node, val, zero),
+		      build_int_cst (a68_int_type, 0),
+		      fold_build3 (COND_EXPR,
+				   a68_int_type,
+				   fold_build2 (GT_EXPR, integer_type_node, val, zero),
+				   build_int_cst (a68_int_type, 1),
+				   build_int_cst (a68_int_type, -1)));
+}
+
+/* Absolute value of a real value.  */
+
+tree
+a68_real_abs (tree val)
+{
+  return fold_build1 (ABS_EXPR, TREE_TYPE (val), val);
+}
+
+tree
+a68_real_sqrt (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_SQRTF;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_SQRT;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_SQRTL;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+tree
+a68_real_tan (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_TANF;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_TAN;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_TANL;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+tree
+a68_real_sin (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_SINF;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_SIN;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_SINL;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+tree
+a68_real_cos (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_COSF;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_COS;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_COSL;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+tree
+a68_real_acos (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_ACOSF;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_ACOS;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_ACOSL;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+tree
+a68_real_asin (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_ASINF;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_ASIN;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_ASINL;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+tree
+a68_real_atan (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_ATANF;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_ATAN;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_ATANL;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+tree
+a68_real_ln (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_LOGF;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_LOG;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_LOGL;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+tree
+a68_real_log (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_LOG10F;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_LOG10;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_LOG10L;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+tree
+a68_real_exp (tree type)
+{
+  enum built_in_function builtin;
+
+  if (type == float_type_node)
+    builtin = BUILT_IN_EXPF;
+  else if (type == double_type_node)
+    builtin = BUILT_IN_EXP;
+  else if (type == long_double_type_node)
+    builtin = BUILT_IN_EXPL;
+  else
+    gcc_unreachable ();
+
+  return addr_of_builtin_decl (builtin);
+}
+
+/* Build the real value lengthened from the value of VAL, from mode
+   FROM_MODE to mode TO_MODE.  */
+
+tree
+a68_real_leng (MOID_T *to_mode, MOID_T *from_mode ATTRIBUTE_UNUSED, tree val)
+{
+  /* Lengthening can be done by just a conversion.  */
+  return fold_convert (CTYPE (to_mode), val);
+}
+
+/* Build the real value that can be lengthened to the value of VAL, from mode
+   FROM_MODE to mode TO_MODE.
+
+   If VAL cannot be represented in TO_MODE because it is bigger than the most
+   positive value representable in TO_MODE, then it is truncated to that value.
+
+   Likewise, if VAL cannot be represented in TO_MODE because it is less than
+   the most negative value representable in TO_MODE, then it is truncated to
+   that value.  */
+
+tree
+a68_real_shorten (MOID_T *to_mode, MOID_T *from_mode ATTRIBUTE_UNUSED, tree val)
+{
+  tree most_positive_value = fold_convert (CTYPE (from_mode),
+					   a68_real_maxval (CTYPE (to_mode)));
+  tree most_negative_value = fold_convert (CTYPE (from_mode),
+					   a68_real_minval (CTYPE (to_mode)));
+
+  val = save_expr (val);
+  most_positive_value = save_expr (most_positive_value);
+  most_negative_value = save_expr (most_negative_value);
+  return fold_build3 (COND_EXPR, CTYPE (to_mode),
+		      fold_build2 (GT_EXPR, a68_bool_type, val, most_positive_value),
+		      fold_convert (CTYPE (to_mode), most_positive_value),
+		      fold_build3 (COND_EXPR, CTYPE (to_mode),
+				   fold_build2 (LT_EXPR, a68_bool_type, val, most_negative_value),
+				   fold_convert (CTYPE (to_mode), most_negative_value),
+				   fold_convert (CTYPE (to_mode), val)));
+}
+
+/* Given a real expression VAL of mode MODE, produce an integral value which is
+   equal to the given real, or the next integer below (more negative than) the
+   given real.  */
+
+tree
+a68_real_entier (tree val, MOID_T *to_mode, MOID_T *from_mode)
+{
+  tree fn = NULL_TREE;
+  tree to_type = CTYPE (to_mode);
+
+  if (from_mode == M_REAL)
+    {
+      if (to_type == integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_IFLOORF);
+      else if (to_type == long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LFLOORF);
+      else if (to_type == long_long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LLFLOORF);
+      else
+	gcc_unreachable ();
+    }
+  else if (from_mode == M_LONG_REAL)
+    {
+      if (to_type == integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_IFLOOR);
+      else if (to_type == long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LFLOOR);
+      else if (to_type == long_long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LLFLOOR);
+      else
+	gcc_unreachable ();
+    }
+  else if (from_mode == M_LONG_LONG_REAL)
+    {
+      if (to_type == integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_IFLOORL);
+      else if (to_type == long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LFLOORL);
+      else if (to_type == long_long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LLFLOORL);
+      else
+	gcc_unreachable ();
+    }
+  else
+    gcc_unreachable ();
+
+  return build_call_expr_loc (UNKNOWN_LOCATION, fn, 1, val);
+}
+
+/* Given a real expression VAL of mode MODE, produce an integral value which is
+   the nearest integer to the given real.  */
+
+tree
+a68_real_round (tree val, MOID_T *to_mode, MOID_T *from_mode)
+{
+  tree fn = NULL_TREE;
+  tree to_type = CTYPE (to_mode);
+
+  if (from_mode == M_REAL)
+    {
+      if (to_type == integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_IROUNDF);
+      else if (to_type == long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LROUNDF);
+      else if (to_type == long_long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LLROUNDF);
+      else
+	gcc_unreachable ();
+    }
+  else if (from_mode == M_LONG_REAL)
+    {
+      if (to_type == integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_IROUND);
+      else if (to_type == long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LROUND);
+      else if (to_type == long_long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LLROUND);
+      else
+	gcc_unreachable ();
+    }
+  else if (from_mode == M_LONG_LONG_REAL)
+    {
+      if (to_type == integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_IROUNDL);
+      else if (to_type == long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LROUNDL);
+      else if (to_type == long_long_integer_type_node)
+	fn = builtin_decl_explicit (BUILT_IN_LLROUNDL);
+      else
+	gcc_unreachable ();
+    }
+  else
+    gcc_unreachable ();
+
+  return build_call_expr_loc (UNKNOWN_LOCATION, fn, 1, val);
+}
+
+
+/* Given two real values of mode M, build an expression that calculates the
+   addition of A and B.  */
+
+tree
+a68_real_plus (MOID_T *m, tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, PLUS_EXPR, CTYPE (m), a, b);
+}
+
+/* Given two real values of mode M, build an expression that calculates the
+   subtraction of A by B.  */
+
+tree
+a68_real_minus (MOID_T *m, tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, MINUS_EXPR, CTYPE (m), a, b);
+}
+
+/* Given two real values of mode M, build an expression that calculates the
+   multiplication of A by B.  */
+
+tree
+a68_real_mult (MOID_T *m, tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, MULT_EXPR, CTYPE (m), a, b);
+}
+
+/* Given two real values of mode M, build an expression that calculates the
+   division of A by B.  */
+
+tree
+a68_real_div (MOID_T *m, tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, RDIV_EXPR, CTYPE (m), a, b);
+}
+
+/* Given two real values of mode M, build an expression that calculates whether
+   A = B.  */
+
+tree
+a68_real_eq (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, EQ_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two real values of mode M, build an expression that calculates whether
+   A /= B.  */
+
+tree
+a68_real_ne (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, NE_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two real values of mode M, build an expression that calculates whether
+   A < B.  */
+
+tree
+a68_real_lt (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, LT_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two real values of mode M, build an expression that calculates
+   whether A <= B.  */
+
+tree
+a68_real_le (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, LE_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two real values of mode M, build an expression that calculates whether
+   A > B.  */
+
+tree
+a68_real_gt (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, GT_EXPR, boolean_type_node, a, b);
+}
+
+/* Given two real values of mode M, build an expression that calculates whether
+   A >= B.  */
+
+tree
+a68_real_ge (tree a, tree b, location_t loc)
+{
+  return fold_build2_loc (loc, GE_EXPR, boolean_type_node, a, b);
+}
+
+/* Exponentiation involving real values.
+
+   REAL <- REAL, REAL
+   REAL <- REAL, INT
+   LONG REAL <- LONG REAL, LONG REAL
+   LONG REAL <- LONG REAL, INT
+   LONG LONG REAL <- LONG LONG REAL, LONG LONG REAL
+   LONG LONG REAL <- LONG LONG REAL, INT  */
+
+tree
+a68_real_pow (MOID_T *m, MOID_T *a_mode, MOID_T *b_mode,
+	      tree a, tree b, location_t loc)
+{
+  enum built_in_function built_in;
+  if (m == M_REAL)
+    {
+      gcc_assert (a_mode == M_REAL);
+      built_in = b_mode == M_REAL ? BUILT_IN_POWF : BUILT_IN_POWIF;
+    }
+  else if (m == M_LONG_REAL)
+    {
+      gcc_assert (a_mode == M_LONG_REAL);
+      built_in = b_mode == M_LONG_REAL ? BUILT_IN_POW : BUILT_IN_POWI;
+    }
+  else if (m == M_LONG_LONG_REAL)
+    {
+      gcc_assert (a_mode == M_LONG_LONG_REAL);
+      built_in = b_mode == M_LONG_LONG_REAL ? BUILT_IN_POWL : BUILT_IN_POWIL;
+    }
+  else
+    gcc_unreachable ();
+
+  tree call = builtin_decl_explicit (built_in);
+  gcc_assert (call != NULL_TREE);
+  return build_call_expr_loc (loc, call, 2, a, b);
+}
diff --git a/gcc/algol68/a68-low-refs.cc b/gcc/algol68/a68-low-refs.cc
new file mode 100644
index 00000000000..ba9987b57ed
--- /dev/null
+++ b/gcc/algol68/a68-low-refs.cc
@@ -0,0 +1,52 @@
+/* Lowering routines for all things related to names.
+   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"
+
+/* Return a tree with the yielding of SKIP for the given name mode.  */
+
+tree
+a68_get_ref_skip_tree (MOID_T *m)
+{
+  /* Build a NULL pointer.  */
+  return build_int_cst (CTYPE (m), 0);
+}
diff --git a/gcc/algol68/a68-low-strings.cc b/gcc/algol68/a68-low-strings.cc
new file mode 100644
index 00000000000..f9fdd56febd
--- /dev/null
+++ b/gcc/algol68/a68-low-strings.cc
@@ -0,0 +1,390 @@
+/* Lowering routines for all things related to STRINGs.
+   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"
+
+/* Return a tree with the yielding of SKIP for M_STRING.  */
+
+tree
+a68_get_string_skip_tree (void)
+{
+  return a68_get_multiple_skip_tree (M_FLEX_ROW_CHAR);
+}
+
+/* Copy chars from STR to ELEMENTS starting at TO_INDEX chars in ELEMENTS.  */
+
+static void
+copy_string (tree elements, tree to_index, tree str)
+{
+  tree char_pointer_type = build_pointer_type (a68_char_type);
+  tree num_elems
+    = a68_lower_tmpvar ("num_elems%", sizetype, a68_multiple_num_elems (str));
+
+  tree from_index
+    = a68_lower_tmpvar ("from_index%", sizetype, size_zero_node);
+  tree from_offset
+    = a68_lower_tmpvar ("from_offset%", sizetype, size_zero_node);
+
+  /* Begin of loop body.  */
+  a68_push_range (NULL);
+  {
+    /* if (from_index == num_elems) break;  */
+    a68_add_stmt (fold_build1 (EXIT_EXPR, void_type_node,
+			       fold_build2 (GE_EXPR, sizetype,
+					    from_index, num_elems)));
+
+    /* *(elements + to_index) = *(elements + from_index)  */
+    tree to_offset = fold_build2 (MULT_EXPR, sizetype,
+				  to_index, size_in_bytes (a68_char_type));
+    a68_add_stmt (fold_build2 (MODIFY_EXPR,
+			       void_type_node,
+			       fold_build2 (MEM_REF, a68_char_type,
+					    fold_build2 (POINTER_PLUS_EXPR,
+							 char_pointer_type,
+							 elements, to_offset),
+					    fold_convert (char_pointer_type,
+							  integer_zero_node)),
+			       fold_build2 (MEM_REF, a68_char_type,
+					    fold_build2 (POINTER_PLUS_EXPR,
+							 char_pointer_type,
+							 a68_multiple_elements (str),
+							 from_offset),
+					    fold_convert (char_pointer_type,
+							  integer_zero_node))));
+
+    /* from_offset = from_offset + stride */
+    a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+			       from_offset,
+			       fold_build2 (PLUS_EXPR, sizetype,
+					    from_offset,
+					    a68_multiple_stride (str, size_zero_node))));
+    /* to_index = to_index + 1 */
+    a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, sizetype, to_index, size_one_node));
+
+    /* from_index = from_index + 1 */
+    a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, sizetype, from_index, size_one_node));
+  }  
+
+  /* End of loop body.  */
+  tree loop_body = a68_pop_range ();
+  a68_add_stmt (fold_build1 (LOOP_EXPR,
+			     void_type_node,
+			     loop_body));
+}
+
+/* Given two STRINGs STR1 and STR2, allocate a new string on the stack with a
+   copy of the concatenated characters of the given string.  */
+
+tree
+a68_string_concat (tree str1, tree str2)
+{
+  tree char_pointer_type = build_pointer_type (a68_char_type);
+  static tree string_concat_fndecl;
+
+  if (string_concat_fndecl == NULL_TREE)
+    {
+      string_concat_fndecl
+	= a68_low_toplevel_func_decl ("string_concat",
+				      build_function_type_list (char_pointer_type,
+								TREE_TYPE (str1),
+								TREE_TYPE (str2),
+								NULL_TREE));
+      announce_function (string_concat_fndecl);
+
+      tree s1 = a68_low_func_param (string_concat_fndecl, "s1", TREE_TYPE (str1));
+      tree s2 = a68_low_func_param (string_concat_fndecl, "s2", TREE_TYPE (str2));
+      DECL_ARGUMENTS (string_concat_fndecl) = chainon (s1, s2);
+						       
+      a68_push_function_range (string_concat_fndecl, char_pointer_type,
+			       true /* top_level */);
+
+      tree n1 = a68_lower_tmpvar ("n1%", sizetype, a68_multiple_num_elems (s1));
+      tree n2 = a68_lower_tmpvar ("n2%", sizetype, a68_multiple_num_elems (s2));
+      tree num_elems = a68_lower_tmpvar ("num_elems%", sizetype,
+					 fold_build2 (PLUS_EXPR, sizetype, n1, n2));
+
+      /* First allocate memory for the result string.  We need enough space to
+	 hold the elements of both strings with a stride of 1S.  */
+      tree char_pointer_type = build_pointer_type (a68_char_type);
+      tree elements_size = fold_build2 (MULT_EXPR, sizetype,
+					size_in_bytes (a68_char_type),
+					num_elems);
+      tree elements = a68_lower_tmpvar ("elements%", char_pointer_type,
+					a68_lower_malloc (a68_char_type, elements_size));
+
+      /* Copy elements.  */
+      tree to_index = a68_lower_tmpvar ("to_index%", sizetype, size_zero_node);
+      copy_string (elements, to_index, s1);
+      copy_string (elements, to_index, s2);
+      a68_pop_function_range (elements);
+    }
+
+  /* Build the resulting multiple.  */
+  str1 = save_expr (str1);
+  str2 = save_expr (str2);
+  tree n1 = a68_multiple_num_elems (str1);
+  tree n2 = a68_multiple_num_elems (str2);
+  tree num_elems = save_expr (fold_build2 (PLUS_EXPR, sizetype, n1, n2));
+  tree elements_size = fold_build2 (MULT_EXPR, sizetype,
+				    size_in_bytes (a68_char_type),
+				    num_elems);
+  tree lower_bound = ssize_int (1);
+  tree upper_bound = fold_convert (ssizetype, num_elems);
+  tree elements = build_call_nary (char_pointer_type,
+				   fold_build1 (ADDR_EXPR,
+						build_pointer_type (TREE_TYPE (string_concat_fndecl)),
+						string_concat_fndecl),
+				   2, str1, str2);
+  return a68_row_value (CTYPE (M_STRING), 1 /* dim */,
+			elements, elements_size,
+			&lower_bound, &upper_bound);
+}
+
+/* Given a STRING STR and an INT FACTOR, return STRING concatenated to itself
+   FACTOR - 1 times.
+
+   Negative values of FACTOR are interpreted as zero.  */
+
+tree
+a68_string_mult (tree str, tree factor)
+{
+  a68_push_range (M_STRING);
+
+  str = save_expr (str);
+  tree ssize_one_node = ssize_int (1);
+  tree res = a68_lower_tmpvar ("res%", CTYPE (M_STRING), str);
+  tree index = a68_lower_tmpvar ("index%", ssizetype, ssize_one_node);
+
+  /* Begin of loop body.  */
+  a68_push_range (NULL);
+
+  /* if (index == FACTOR) break;  */
+  a68_add_stmt (fold_build1 (EXIT_EXPR,
+			     void_type_node,
+			     fold_build2 (GE_EXPR, ssizetype,
+					  index,
+					  fold_convert (ssizetype, factor))));
+
+  /* res += str */
+  a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (res),
+			     res,
+			     a68_string_concat (res, str)));
+
+  /* index++ */
+  a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR,
+			     ssizetype,
+			     index, ssize_one_node));
+  tree loop_body = a68_pop_range ();
+  /* End of loop body.  */
+  a68_add_stmt (fold_build1 (LOOP_EXPR,
+			     void_type_node,
+			     loop_body));
+  a68_add_stmt (res);
+  return a68_pop_range ();
+}
+
+/* Given a CHAR C, build a string whose contents are just that CHAR.  */
+
+tree
+a68_string_from_char (tree c)
+{
+  tree lower_bound = ssize_int (1);
+  tree upper_bound = lower_bound;
+  tree char_pointer_type = build_pointer_type (a68_char_type);
+
+  a68_push_range (M_STRING);
+
+  tree elements = a68_lower_tmpvar ("elements%", char_pointer_type,
+				    a68_lower_malloc (a68_char_type,
+						      size_one_node));
+  a68_add_stmt (fold_build2 (MODIFY_EXPR,
+			     void_type_node,
+			     fold_build1 (INDIRECT_REF, a68_char_type, elements),
+			     c));
+  a68_add_stmt (a68_row_value (CTYPE (M_STRING), 1 /* dim */,
+			       elements,
+			       size_in_bytes (a68_char_type),
+			       &lower_bound, &upper_bound));
+  return a68_pop_range ();
+}
+
+/* Compare the two given strings lexicographically and return -1 (less than), 0
+   (equal to) or 1 (bigger than) reflecting the result of the comparison.  */
+
+tree
+a68_string_cmp (tree s1, tree s2)
+{
+  s1 = save_expr (s1);
+  tree s1_elems = a68_multiple_elements (s1);
+  tree s1_len = a68_multiple_num_elems (s1);
+  tree s1_stride = a68_multiple_stride (s1, size_zero_node);
+
+  s2 = save_expr (s2);
+  tree s2_elems = a68_multiple_elements (s2);
+  tree s2_len = a68_multiple_num_elems (s2);
+  tree s2_stride = a68_multiple_stride (s2, size_zero_node);
+
+  return a68_build_libcall (A68_LIBCALL_U32_CMP2,
+			    a68_int_type, 6,
+			    s1_elems, s1_len, s1_stride,
+			    s2_elems, s2_len, s2_stride);
+}
+
+/* Return a newly allocated UTF-8 string resulting from processing the string
+   breaks in STR.  This function assumes the passed string is well-formed (the
+   scanner is in charge of seeing that is true) and just ICEs if it is not.  */
+
+char *
+a68_string_process_breaks (const char *str)
+{
+  size_t len = 0;
+  char *res = NULL;
+
+  /* First calculate the size of the resulting string.  */
+  for (const char *p = str; *p != '\0';)
+    {
+      if (*p == '\'')
+	{
+	  switch (p[1])
+	    {
+	    case '\'':
+	    case 'n':
+	    case 'f':
+	    case 'r':
+	    case 't':
+	      len += 1;
+	      p += 2;
+	      break;
+	    case '(':
+	      p += 2;
+	      while (1)
+		{
+		  if (p[0] == ')')
+		    {
+		      p++;
+		      break;
+		    }
+		  else if (p[0] == ',' || ISSPACE (p[0]))
+		    {
+		      p++;
+		      continue;
+		    }
+
+		  /* An Unicode codepoint encoded in UTF-8 occupies at most six
+		     octets.  */
+		  len += 6;
+		  p += (p[0] == 'u' ? 5 : 9);
+		}
+	      break;
+	    default:
+	      gcc_unreachable ();
+	    }
+	}
+      else
+	{
+	  len += 1;
+	  p += 1;
+	}
+    }
+
+  /* Now and allocate it, adding space for a trailing NULL.  */
+  res = (char *) xmalloc (len + 1);
+
+  /* Finally fill it with the result of expanding all the string breaks.  */
+  size_t offset = 0;
+  for (const char *p = str; *p != '\0';)
+    {
+      if (*p == '\'')
+	{
+	  switch (p[1])
+	    {
+	    case '\'': res[offset] = '\''; p += 2; offset += 1; break;
+	    case 'n': res[offset] = '\n'; p += 2;  offset += 1; break;
+	    case 't': res[offset] = '\t'; p += 2;  offset += 1; break;
+	    case 'r': res[offset] = '\r'; p += 2;  offset += 1; break;
+	    case 'f': res[offset] = '\f'; p += 2;  offset += 1; break;
+	    case '(':
+	      {
+		p += 2;
+		while (1)
+		  {
+		    if (p[0] == ')')
+		      {
+			p++;
+			break;
+		      }
+		    else if (p[0] == ',' || ISSPACE (p[0]))
+		      {
+			p++;
+			continue;
+		      }
+
+		    /* Skip the u or U.  */
+		    gcc_assert (p[0] == 'u' || p[0] == 'U');
+		    p++;
+
+		    char *end;
+		    int64_t codepoint = strtol (p, &end, 16);
+		    gcc_assert (end > p);
+		    p = end;
+		    /* Append the UTF-8 encoding of the obtained codepoint to
+		       the `res' string.  */
+		    int n = a68_u8_uctomb ((uint8_t *) res + offset, codepoint, 6);
+		    gcc_assert (n > 0);
+		    offset += n;
+		  }
+		break;
+	      }
+	    default: gcc_unreachable ();
+	    }
+	}
+      else
+	{
+	  res[offset] = *p;
+	  offset += 1;
+	  p += 1;
+	}
+    }
+  res[offset] = '\0';
+
+  return res;
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 31/47] a68: low: stowed values
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (29 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 30/47] a68: low: plain values Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 32/47] a68: low: standard prelude Jose E. Marchesi
                   ` (16 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-low-multiples.cc: New file.
	* algol68/a68-low-structs.cc: Likewise.
	* algol68/a68-low-unions.cc: Likewise.
---
 gcc/algol68/a68-low-multiples.cc | 1097 ++++++++++++++++++++++++++++++
 gcc/algol68/a68-low-structs.cc   |   63 ++
 gcc/algol68/a68-low-unions.cc    |  279 ++++++++
 3 files changed, 1439 insertions(+)
 create mode 100644 gcc/algol68/a68-low-multiples.cc
 create mode 100644 gcc/algol68/a68-low-structs.cc
 create mode 100644 gcc/algol68/a68-low-unions.cc

diff --git a/gcc/algol68/a68-low-multiples.cc b/gcc/algol68/a68-low-multiples.cc
new file mode 100644
index 00000000000..ce5996c9249
--- /dev/null
+++ b/gcc/algol68/a68-low-multiples.cc
@@ -0,0 +1,1097 @@
+/* Lowering routines for all things related to multiples.
+   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"
+
+/* Algol 68 multiples are multi-dimensional and dynamically sized. They have a
+   static part and a dynamic part.  The static part is conformed by a
+   "descriptor", which contains information about each of the dimensions, and a
+   pointer to the actual elements stored in the multiple.  The dynamic part are
+   the elements, which are stored in column order.  Both the descriptor and the
+   elements may reside on the stack, data section, or the heap.  The mode of a
+   multiple is a "row".
+
+   Schematically, the descriptor contains:
+
+      triplets%
+        lb% ub% stride%
+	...
+      elements%
+      elements_size%
+
+   Where elements_size% is the size of the buffer pointed by elements%, in
+   bytes.
+
+   There is a triplet per dimension in the multiple.  The number of dimensions
+   in a row mode is static and is determined at compile-time.
+
+   The infomation stored for each triplet is:
+
+     lb%     is the lower bound of the dimension.
+     ub%     is the upper bound of the dimension.
+     stride% is the stride of the dimension.
+
+   The stride of each dimension is the number of bytes to skip in order to
+   access the next element in that dimension.  They express the layout of the
+   multiple in memory.
+
+   Algol 68 multi-dimensional multiples are stored in row-major (generalized,
+   lexicographical) order:
+
+     [1:3,1:2]AMODE = ((e1, e2, e3),
+                       (e4, e5, e6))
+
+   is stored as:
+
+          1  2  3
+       1  e1 e2 e3      | stride 2S ->  stride 1S
+       2  e4 e5 e6      v
+
+   Where S is the size in bytes of a single element.  That means that for two
+   dimensional multiples, the column stride is always 1S and the row stride is
+   the column size.
+
+   In general, given a mode with number of elements N1, N2, N3, ...:
+
+     [N1,N2,N3...,Nn]AMODE
+
+   the strides of the dimensions are:
+
+     S1 = N2 * S2
+     S2 = N3 * S3
+     S3 = N4 * S4
+     ...
+     Si = N1 * N2 * ... * Ni-1
+
+   Indexing is then performed by a dot-product of an element coordinate and the
+   strides:
+
+     (i1,i2,i3) . (S1,S2,S3) = offset + i1*S1 + i2*S2 + i3*S3 = index in elements array.
+
+   Note that the number of elements in each dimension can be easily derived
+   from the bounds and there is no need to store them explicitly, save for
+   performance reasons.  Descriptors are bulky enough and often they they are
+   stored on the stack, so we prefer to pay in performance and save in
+   storage.  */
+
+/* Return a tree with the yielding of SKIP for the given row mode, a
+   multiple.  */
+
+tree
+a68_get_multiple_skip_tree (MOID_T *m)
+{
+  tree res = NULL_TREE;
+  int dim = DIM (m);
+  tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+  tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+  tree ssize_one_node = fold_convert (ssizetype, size_one_node);
+  tree ssize_zero_node = fold_convert (ssizetype, size_zero_node);
+  for (int i = 0; i < dim; ++i)
+    {
+      lower_bounds[i] = ssize_one_node;
+      upper_bounds[i] = ssize_zero_node;
+    }
+  res = a68_row_value (CTYPE (m), dim,
+		       build_int_cst (build_pointer_type (void_type_node), 0),
+		       size_zero_node, /* elements_size */
+		       lower_bounds, upper_bounds);
+  free (lower_bounds);
+  free (upper_bounds);
+  return res;
+}
+
+/* Return the number of dimensions of the multiple EXP as an integer
+   constant.  */
+
+tree
+a68_multiple_dimensions (tree exp)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+  /* triplets% is the first field in the descriptor.  */
+  tree triplets_field = TYPE_FIELDS (TREE_TYPE (exp));
+  return array_type_nelts_top (TREE_TYPE (triplets_field));
+}
+
+/* Return an expression that evaluates to the total number of elements stored
+   in a multiple as a sizetype.  */
+
+tree
+a68_multiple_num_elems (tree exp)
+{
+  /* We have to calculate the number of elements based on the dimension
+     triplets in the array type.  The number of dimensions is known at compile
+     time, so we don't really need a loop.  */
+
+  tree num_dimensions_tree = a68_multiple_dimensions (exp);
+  gcc_assert (TREE_CODE (num_dimensions_tree) == INTEGER_CST);
+  int num_dimensions = tree_to_shwi (num_dimensions_tree);
+
+  tree size = NULL_TREE;
+  for (int dim = 0; dim < num_dimensions; ++dim)
+    {
+      tree size_dim = size_int (dim);
+      tree lower_bound = a68_multiple_lower_bound (exp, size_dim);
+      tree upper_bound = a68_multiple_upper_bound (exp, size_dim);
+      tree dim_size = fold_build2 (PLUS_EXPR, sizetype,
+				   fold_convert (sizetype, fold_build2 (MINUS_EXPR,
+									ssizetype,
+									upper_bound,
+									lower_bound)),
+				   size_one_node);
+
+      if (size == NULL_TREE)
+	size = dim_size;
+      else
+	size = fold_build2 (MULT_EXPR, sizetype, size, dim_size);
+    }
+
+  return size;
+}
+
+/* Return a size expression that evaluates to the total size, in bytes, of the
+   elements stored in the multiple.  */
+
+tree
+a68_multiple_elements_size (tree exp)
+{
+  tree type = TREE_TYPE (exp);
+  gcc_assert (A68_ROW_TYPE_P (type));
+
+  /* elements_size% is the third field in the descriptor.  */
+  tree elements_size_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type)));
+  return fold_build3 (COMPONENT_REF, TREE_TYPE (elements_size_field),
+		      exp, elements_size_field, NULL_TREE);
+}
+
+/* Return the triplet for dimension DIM in the multiple EXP.  */
+
+static tree
+multiple_triplet (tree exp, tree dim)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+  /* triplets% is the first field in the descriptor.  */
+  tree triplets_field = TYPE_FIELDS (TREE_TYPE (exp));
+  tree triplets = fold_build3 (COMPONENT_REF,
+			       TREE_TYPE (triplets_field),
+			       exp,
+			       triplets_field,
+			       NULL_TREE);
+
+  /* Get the triplet for the given dimension.  */
+  return build4 (ARRAY_REF,
+		 TREE_TYPE (TREE_TYPE (triplets)),
+		 triplets,
+		 dim,
+		 NULL_TREE,
+		 NULL_TREE);
+}
+
+/* Return the lower bound of dimension DIM of the multiple EXP.  The returned
+   value is a ssizetype.  */
+
+tree
+a68_multiple_lower_bound (tree exp, tree dim)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+  /* lb% is the first field in the triplet.  */
+  tree triplet = multiple_triplet (exp, dim);
+  tree lower_bound_field = TYPE_FIELDS (TREE_TYPE (triplet));
+  return fold_build3 (COMPONENT_REF,
+		      TREE_TYPE (lower_bound_field),
+		      triplet,
+		      lower_bound_field,
+		      NULL_TREE);
+}
+
+/* Return an expression that sets the lower bound of dimension DIM of the
+   multiple EXP to BOUND.  */
+
+tree
+a68_multiple_set_lower_bound (tree exp, tree dim, tree bound)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+  return fold_build2 (MODIFY_EXPR,
+		      TREE_TYPE (bound),
+		      a68_multiple_lower_bound (exp, dim),
+		      bound);
+}
+
+/* Return the upper bound of dimension DIM of the multiple EXP.  The returned
+   value is a ssizetype.  */
+
+tree
+a68_multiple_upper_bound (tree exp, tree dim)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+  /* ub% is the second field in the triplet.  */
+  tree triplet = multiple_triplet (exp, dim);
+  tree upper_bound_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (triplet)));
+  return fold_build3 (COMPONENT_REF,
+		      TREE_TYPE (upper_bound_field),
+		      triplet,
+		      upper_bound_field,
+		      NULL_TREE);
+}
+
+/* Return an expression that sets the upper bound of dimension DIM of the
+   multiple EXP to BOUND.  */
+
+tree
+a68_multiple_set_upper_bound (tree exp, tree dim, tree bound)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+  return fold_build2 (MODIFY_EXPR,
+		      TREE_TYPE (bound),
+		      a68_multiple_upper_bound (exp, dim),
+		      bound);
+}
+
+/* Return the stride of dimension DIM of the multiple EXP.  */
+
+tree
+a68_multiple_stride (tree exp, tree dim)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+  /* stride% is the third field in the triplet.  */
+  tree triplet = multiple_triplet (exp, dim);
+  tree stride_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (triplet))));
+  return fold_build3 (COMPONENT_REF,
+		      TREE_TYPE (stride_field),
+		      triplet,
+		      stride_field,
+		      NULL_TREE);
+}
+
+/* Return an expression that sets the stride of dimension DIM of the multiple
+   EXP to STRIDE.
+
+   STRIDE must be a sizetype.  */
+
+tree
+a68_multiple_set_stride (tree exp, tree dim, tree stride)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+  return fold_build2 (MODIFY_EXPR,
+		      TREE_TYPE (stride),
+		      a68_multiple_stride (exp, dim),
+		      stride);
+}
+
+/* Return the triplets of the multiple EXP.  */
+
+tree
+a68_multiple_triplets (tree exp)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+  /* triplets% is the first field in the descriptor.  */
+  tree triplets_field = TYPE_FIELDS (TREE_TYPE (exp));
+  return fold_build3 (COMPONENT_REF,
+		      TREE_TYPE (triplets_field),
+		      exp,
+		      triplets_field,
+		      NULL_TREE);
+}
+
+/* Return the pointer to the elements of the multiple EXP.  */
+
+tree
+a68_multiple_elements (tree exp)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (exp)));
+
+  /* elements% is the second field in the descriptor.  */
+  tree elements_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp)));
+  return fold_build3 (COMPONENT_REF,
+		      TREE_TYPE (elements_field),
+		      exp,
+		      elements_field,
+		      NULL_TREE);
+}
+
+/* Return an expression that sets the elements% field of EXP to ELEMENTS.  */
+
+tree
+a68_multiple_set_elements (tree exp, tree elements)
+{
+  /* elements% is the second field in the descriptor.  */
+  tree elements_field = TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp)));
+  return fold_build2 (MODIFY_EXPR,
+		      TREE_TYPE (elements_field),
+		      fold_build3 (COMPONENT_REF,
+				   TREE_TYPE (elements_field),
+				   exp,
+				   elements_field,
+				   NULL_TREE),
+		      elements);
+}
+
+/* Return an expression that sets the elements_size% field of EXP to
+   ELEMENTS_SIZE, which must be a sizetype.  */
+
+tree
+a68_multiple_set_elements_size (tree exp, tree elements_size)
+{
+  /* elements_size% is the third field in the descriptor.  */
+  tree elements_size_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))));
+  return fold_build2 (MODIFY_EXPR,
+		      TREE_TYPE (elements_size_field),
+		      fold_build3 (COMPONENT_REF,
+				   TREE_TYPE (elements_size_field),
+				   exp,
+				   elements_size_field,
+				   NULL_TREE),
+		      elements_size);
+}
+
+/* Given two arrays of LOWER_BOUNDs and UPPER_BOUNDs corresponding to DIM
+   dimensions of a multiple of type TYPE, fill in the strides in STRIDES, which
+   is assumed to be a buffer big enough to hold DIM tree nodes.  The bounds
+   shall be of type ssizetype, and the calculated strides are of type sizetype,
+   i.e. unsigned.  */
+
+void
+a68_multiple_compute_strides (tree type, size_t dim,
+			      tree *lower_bounds, tree *upper_bounds,
+			      tree *strides)
+{
+  tree stride = size_in_bytes (a68_row_elements_type (type));
+  for (ssize_t i = dim - 1; i >= 0; --i)
+    {
+      strides[i] = stride;
+
+      /* Calculate the stride for the previous dimension.  */
+      tree dim_num_elems
+	= save_expr (fold_build2 (PLUS_EXPR,
+				  sizetype,
+				  fold_convert (sizetype,
+						fold_build2 (MINUS_EXPR, ssizetype,
+							     upper_bounds[i], lower_bounds[i])),
+				  size_one_node));
+      stride = fold_build2 (MULT_EXPR, sizetype, stride, dim_num_elems);
+    }
+}
+
+/* Return a constructor for a multiple of row type TYPE, using TRIPLETS and
+   ELEMENTS.  ELEMENTS_SIZE is the size in bytes of the memory pointed by
+   ELEMENTS.  */
+
+tree
+a68_row_value_raw (tree type, tree triplets,
+		   tree elements, tree elements_size)
+{
+  tree triplets_field;
+  tree elements_field;
+  tree elements_size_field;
+  vec <constructor_elt, va_gc> *ce = NULL;
+
+  gcc_assert (A68_ROW_TYPE_P (type));
+  triplets_field = TYPE_FIELDS (type);
+  elements_field = TREE_CHAIN (triplets_field);
+  elements_size_field = TREE_CHAIN (elements_field);
+  CONSTRUCTOR_APPEND_ELT (ce, triplets_field, triplets);
+  CONSTRUCTOR_APPEND_ELT (ce, elements_field,
+			  fold_build1 (CONVERT_EXPR ,TREE_TYPE (elements_field), elements));
+  CONSTRUCTOR_APPEND_ELT (ce, elements_size_field, elements_size);
+  return build_constructor (type, ce);
+}
+
+/* Return a constructor for a multiple of row type TYPE, of DIM dimensions and
+   pointing to ELEMENTS.
+
+   ELEMENTS_SIZE contains the size in bytes of the memory pointed by ELEMENTS.
+
+   *LOWER_BOUND and *UPPER_BOUND are the bounds for the DIM dimensions.
+*/
+
+tree
+a68_row_value (tree type, size_t dim,
+	       tree elements, tree elements_size,
+	       tree *lower_bound, tree *upper_bound)
+{
+  tree triplets_field;
+  tree elements_field;
+  tree elements_size_field;
+  vec <constructor_elt, va_gc> *ce = NULL;
+
+  gcc_assert (A68_ROW_TYPE_P (type));
+  triplets_field = TYPE_FIELDS (type);
+  elements_field = TREE_CHAIN (triplets_field);
+  elements_size_field = TREE_CHAIN (elements_field);
+
+  tree triplet_type = TREE_TYPE (TREE_TYPE (triplets_field));
+  tree lower_bound_field = TYPE_FIELDS (triplet_type);
+  tree upper_bound_field = TREE_CHAIN (TYPE_FIELDS (triplet_type));
+  tree stride_field = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (triplet_type)));
+
+  /* Calculate strides.  */
+  tree *strides = (tree *) xmalloc (sizeof (tree) * dim);
+  a68_multiple_compute_strides (type, dim, lower_bound, upper_bound, strides);
+
+  vec <constructor_elt, va_gc> *triplets_ce = NULL;
+  for (size_t i = 0; i < dim; ++i)
+    {
+      CONSTRUCTOR_APPEND_ELT (triplets_ce,
+			      size_int (i),
+			      build_constructor_va (triplet_type,
+						    3,
+						    lower_bound_field, lower_bound[i],
+						    upper_bound_field, upper_bound[i],
+						    stride_field, strides[i]));
+    }
+  free (strides);
+  CONSTRUCTOR_APPEND_ELT (ce, triplets_field,
+			  build_constructor (TREE_TYPE (triplets_field), triplets_ce));
+  CONSTRUCTOR_APPEND_ELT (ce, elements_field,
+			  fold_build1 (CONVERT_EXPR, TREE_TYPE (elements_field), elements));
+  CONSTRUCTOR_APPEND_ELT (ce, elements_size_field,
+			  elements_size ? elements_size : size_zero_node);
+  tree multiple = build_constructor (type, ce);
+  return multiple;
+}
+
+/* Build a tree to slice a multiple given a set of indexes.
+
+   P is the tree node corresponding to the slice.  It is used as the source of
+   location information.
+
+   MULTIPLE is the multiple value being sliced.  If SLICING_NAME is true, it
+   means the slicing operation is for a name and therefore it must yield a
+   name.
+
+   INDEXES is a list of NUM_INDEXES indexes, which are units.
+   NUM_INDEXES must match the dimension of the multiple.  */
+
+tree
+a68_multiple_slice (NODE_T *p,
+		    tree multiple, bool slicing_name,
+		    int num_indexes, tree *indexes)
+{
+  tree slice = NULL_TREE;
+  tree bounds_check = NULL_TREE;
+
+  multiple = save_expr (multiple);
+  tree index = NULL_TREE;
+  for (int idx = 0; idx < num_indexes; ++idx)
+    {
+      tree lower_bound = a68_multiple_lower_bound (multiple, size_int (idx));
+      tree index_expr = save_expr (indexes[idx]);
+
+      /* Do run-time bound checking if requested.  */
+      if (OPTION_BOUNDS_CHECKING (&A68_JOB))
+	{
+	  tree upper_bound = a68_multiple_upper_bound (multiple, size_int (idx));
+	  unsigned int lineno = NUMBER (LINE (INFO (p)));
+	  const char *filename_str = FILENAME (LINE (INFO (p)));
+	  tree filename = build_string_literal (strlen (filename_str) + 1,
+						    filename_str);
+	  tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDS,
+					 void_type_node, 5,
+					 filename,
+					 build_int_cst (unsigned_type_node, lineno),
+					 fold_convert (ssizetype, index_expr),
+					 fold_convert (ssizetype, lower_bound),
+					 fold_convert (ssizetype, upper_bound));
+	  call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node);
+
+	  /* If LB > UB, the dimension contains no elements.
+	     Otherwise, it must hold IDX >= LB && IDX <= UB */
+	  tree dim_bounds_check = fold_build2 (TRUTH_AND_EXPR, sizetype,
+					       fold_build2 (LE_EXPR, ssizetype,
+							    lower_bound, upper_bound),
+					       fold_build2 (TRUTH_AND_EXPR,
+							    boolean_type_node,
+							    fold_build2 (GE_EXPR, ssizetype,
+									 fold_convert (ssizetype,
+										       index_expr),
+									 lower_bound),
+							    fold_build2 (LE_EXPR, ssizetype,
+									 fold_convert (ssizetype,
+										       index_expr),
+									 upper_bound)));
+	  dim_bounds_check = fold_build2_loc (a68_get_node_location (p),
+					      TRUTH_ORIF_EXPR,
+					      ssizetype,
+					      dim_bounds_check, call);
+
+	  /* bounds_check_ok || call_runtime_error */
+	  if (bounds_check == NULL_TREE)
+	    bounds_check = dim_bounds_check;
+	  else
+	    bounds_check = fold_build2 (TRUTH_ANDIF_EXPR,
+					ssizetype,
+					bounds_check,
+					dim_bounds_check);
+	}
+
+      /* Now add the effect of this dimension's subscript in the index.  Note
+	 that the stride is expressed in bytes.  */
+      tree stride = a68_multiple_stride (multiple, size_int (idx));
+      tree adjusted_index
+	= fold_convert (sizetype, fold_build2 (MINUS_EXPR, ssizetype,
+					       fold_convert (ssizetype, index_expr),
+					       lower_bound));
+      tree term = fold_build2 (MULT_EXPR, sizetype,
+			       adjusted_index, stride);
+      if (index == NULL_TREE)
+	index = term;
+      else
+	index = fold_build2 (PLUS_EXPR, sizetype,
+			     index, term);
+    }
+
+  tree elements = a68_multiple_elements (multiple);
+  tree element_pointer_type = TREE_TYPE (elements);
+  tree element_type = TREE_TYPE (element_pointer_type);
+
+  /* Now refer to the indexed element.  In case we are slicing a ref to a
+     multiple, return the address of the element and not the element
+     itself.  */
+  tree element_address = fold_build2 (POINTER_PLUS_EXPR,
+				      element_pointer_type,
+				      elements,
+				      index);
+  if (slicing_name)
+    slice = element_address;
+  else
+    slice = fold_build2 (MEM_REF,
+			 element_type,
+			 fold_build2 (POINTER_PLUS_EXPR,
+				      element_pointer_type,
+				      elements,
+				      index),
+			 fold_convert (element_pointer_type,
+				       integer_zero_node));
+
+  /* Prepend bounds checking code if necessary.  */
+  if (bounds_check != NULL_TREE)
+    {
+      slice = fold_build2_loc (a68_get_node_location (p),
+			       COMPOUND_EXPR,
+			       TREE_TYPE (slice),
+			       bounds_check,
+			       slice);
+    }
+
+  return slice;
+}
+
+/* Auxiliary routine for a68_multiple_copy_elemens.  */
+
+static tree
+copy_multiple_dimension_elems (size_t dim, size_t num_dimensions,
+			       tree to, tree from,
+			       tree to_elements, tree from_elements,
+			       tree *to_offset, tree *from_offset,
+			       tree *indexes)
+{
+  tree element_pointer_type = TREE_TYPE (from_elements);
+  tree element_type = TREE_TYPE (element_pointer_type);
+  tree upb = a68_multiple_upper_bound (from, size_int (dim));
+
+  char *name = xasprintf ("r%ld%%", dim);
+  indexes[dim] = a68_lower_tmpvar (name, ssizetype,
+				   a68_multiple_lower_bound (from,
+							     size_int (dim)));
+  free (name);
+
+  /* Loop body.  */
+  a68_push_range (NULL);
+  {
+    /* if (indexes[dim] > upb) break; */
+    a68_add_stmt (fold_build1 (EXIT_EXPR, void_type_node,
+			       fold_build2 (GT_EXPR, size_type_node,
+					    indexes[dim], upb)));
+
+    /* Add this dimension's contribution to the offsets.  */
+    tree index = fold_convert (sizetype,
+			       fold_build2 (MINUS_EXPR, ssizetype,
+					    upb, indexes[dim]));
+    *to_offset = fold_build2 (PLUS_EXPR, sizetype,
+			      *to_offset,
+			      fold_build2 (MULT_EXPR, sizetype,
+					   index,
+					   a68_multiple_stride (to, size_int (dim))));
+    *from_offset = fold_build2 (PLUS_EXPR, sizetype,
+				*from_offset,
+				fold_build2 (MULT_EXPR, sizetype,
+					     index,
+					     a68_multiple_stride (from, size_int (dim))));
+
+    if (dim == num_dimensions - 1)
+      {
+	/* Most inner loop, copy one element.  */
+
+	tree to_off = a68_lower_tmpvar ("to_offset%", sizetype, *to_offset);
+	tree from_off = a68_lower_tmpvar ("from_offset%", sizetype, *from_offset);
+
+	tree to_elem = fold_build2 (MEM_REF,
+				    element_type,
+				    fold_build2 (POINTER_PLUS_EXPR,
+						 element_pointer_type,
+						 to_elements,
+						 to_off),
+				    fold_convert (element_pointer_type,
+						  integer_zero_node));
+	tree from_elem = fold_build2 (MEM_REF,
+				      element_type,
+				      fold_build2 (POINTER_PLUS_EXPR,
+						   element_pointer_type,
+						   from_elements,
+						   from_off),
+				      fold_convert (element_pointer_type,
+						    integer_zero_node));
+
+	/* XXX
+	   if may_overlap then modify only if dst_offset < src_offset */
+	a68_add_stmt (fold_build2 (MODIFY_EXPR, element_type,
+				   to_elem, from_elem));
+      }
+    else
+      {
+	a68_add_stmt (copy_multiple_dimension_elems (dim + 1, num_dimensions,
+						     to, from,
+						     to_elements, from_elements,
+						     to_offset, from_offset,
+						     indexes));
+      }
+
+    /* indexes[dim]++ */
+    a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR, ssizetype,
+			       indexes[dim], ssize_int (1)));
+  }
+  tree loop_body = a68_pop_range ();
+
+  return fold_build1 (LOOP_EXPR, void_type_node, loop_body);
+}
+
+/* Copy the elements of a given multiple (string) FROM to the multiple (string)
+   TO.
+
+   The dimensions and bounds of both multiples are supposed to match, and they
+   are supposed to not be flat.
+
+   XXX simple cases  with same strides may be done with a memcpy.
+   XXX compile this into a support routine to reduce code size.  */
+
+tree
+a68_multiple_copy_elems (MOID_T *mode, tree to, tree from)
+{
+  gcc_assert (A68_ROW_TYPE_P (TREE_TYPE (to))
+	      && A68_ROW_TYPE_P (TREE_TYPE (from)));
+
+  /* Deflex modes as needed and determine dimension.  */
+  if (IS_FLEX (mode))
+    mode = SUB (mode);
+  int num_dimensions = (mode == M_STRING ? 1 : DIM (mode));
+
+  a68_push_range (NULL);
+  to = a68_lower_tmpvar ("to%", TREE_TYPE (to), to);
+  from = a68_lower_tmpvar ("from%", TREE_TYPE (from), from);
+  tree from_elements = a68_multiple_elements (from);
+  tree element_pointer_type = TREE_TYPE (from_elements);
+  from_elements = a68_lower_tmpvar ("from_elements%", element_pointer_type,
+				    from_elements);
+  tree to_elements = a68_lower_tmpvar ("to_elements%", element_pointer_type,
+				       a68_multiple_elements (to));
+
+  tree *indexes = (tree *) xmalloc (num_dimensions * sizeof (tree));
+  tree to_offset = size_zero_node;
+  tree from_offset = size_zero_node;
+  a68_add_stmt (copy_multiple_dimension_elems (0 /* dim */, num_dimensions,
+					       to, from,
+					       to_elements, from_elements,
+					       &to_offset, &from_offset,
+					       indexes));
+  free (indexes);
+  return a68_pop_range ();
+}
+
+/* Given a rows type, return the number of dimensions.  */
+
+tree
+a68_rows_dim (tree exp)
+{
+  gcc_assert (A68_ROWS_TYPE_P (TREE_TYPE (exp)));
+
+  /* dim% is the first field in the rows struct.  */
+  tree dim_field = TYPE_FIELDS (TREE_TYPE (exp));
+  return fold_build3 (COMPONENT_REF,
+		      TREE_TYPE (dim_field),
+		      exp,
+		      dim_field,
+		      NULL_TREE);
+}
+
+/* Given a multiple value, create a rows value reflecting the multiple's
+   dimensions and triplets.  */
+
+tree
+a68_rows_value (tree multiple)
+{
+  tree rows_type = CTYPE (M_ROWS);
+  tree dim_field = TYPE_FIELDS (rows_type);
+  tree triplets_field = TREE_CHAIN (dim_field);
+
+  tree dimensions = save_expr (a68_multiple_dimensions (multiple));
+  tree triplets = fold_build1 (ADDR_EXPR, TREE_TYPE (triplets_field),
+			       a68_multiple_triplets (multiple));
+  return build_constructor_va (rows_type, 2,
+			       dim_field, dimensions,
+			       triplets_field, triplets);
+}
+
+/* Given a rows value and a dimension number, return the upper bound or the
+   lower of the given dimension.  The returned bound is a ssizetype.
+
+   DIM must be a sizetype.  */
+
+static tree
+rows_lower_or_upper_bound (tree rows, tree dim, bool upper)
+{
+  tree rows_type = TREE_TYPE (rows);
+  tree triplet_type = a68_triplet_type ();
+  tree triplet_pointer_type = build_pointer_type (triplet_type);
+  tree triplet_lb_field = TYPE_FIELDS (triplet_type);
+  tree triplet_ub_field = TREE_CHAIN (TYPE_FIELDS (triplet_type));
+  tree triplets_field = TREE_CHAIN (TYPE_FIELDS (rows_type));
+  tree triplets = fold_build3 (COMPONENT_REF, triplet_pointer_type,
+			       rows, triplets_field, NULL_TREE);
+  tree triplet_offset = fold_build2 (MULT_EXPR, sizetype,
+				     dim,
+				     size_in_bytes (triplet_type));
+  tree bound = fold_build3 (COMPONENT_REF, ssizetype,
+			    fold_build1 (INDIRECT_REF, triplet_type,
+					 fold_build2 (POINTER_PLUS_EXPR,
+						      triplet_pointer_type,
+						      triplets,
+						      triplet_offset)),
+			    upper ? triplet_ub_field : triplet_lb_field,
+			    NULL_TREE);
+
+  return bound;
+}
+
+/* Return the lower bound of dimension DIM of ROWS.  */
+
+tree
+a68_rows_lower_bound (tree rows, tree dim)
+{
+  return rows_lower_or_upper_bound (rows, dim, false);
+}
+
+/* Return the upper bound of dimension DIM of ROWS.  */
+
+tree
+a68_rows_upper_bound (tree rows, tree dim)
+{
+  return rows_lower_or_upper_bound (rows, dim, true);
+}
+
+/* Return a tree that checks that a given INDEX is correct given a multiple's
+   bounds in a given rank DIM.
+
+   If UPPER_BOUND is true then INDEX shall be less or equal than the multiple's
+   upper bound.  Otherwise INDEX shall be bigger or equal than the multiple's
+   lower bound.
+
+   If the condition above doesn't hold then a call to a run-time function is
+   performed: if UPPER_BOUND is true then ARRAYUPPERBOUND is called.  Otherwise
+   ARRAYLOWERBOUND is called.  */
+
+tree
+a68_multiple_single_bound_check (NODE_T *p, tree dim,
+				 tree multiple, tree index, bool upper_bound)
+{
+  index = save_expr (index);
+  multiple = save_expr (multiple);
+
+  tree bound = (upper_bound
+		? a68_multiple_upper_bound (multiple, dim)
+		: a68_multiple_lower_bound (multiple, dim));
+  a68_libcall_fn libcall = (upper_bound
+			    ? A68_LIBCALL_ARRAYUPPERBOUND
+			    : A68_LIBCALL_ARRAYLOWERBOUND);
+
+  /* Build the call to ARRAY*BOUNDS. */
+  unsigned int lineno = NUMBER (LINE (INFO (p)));
+  const char *filename_str = FILENAME (LINE (INFO (p)));
+  tree filename = build_string_literal (strlen (filename_str) + 1,
+					filename_str);
+  tree call = a68_build_libcall (libcall,
+				 void_type_node, 4,
+				 filename,
+				 build_int_cst (unsigned_type_node, lineno),
+				 fold_convert (ssizetype, index),
+				 fold_convert (ssizetype, bound));
+  call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node);
+
+  tree bounds_check = fold_build2 (upper_bound ? LE_EXPR : GE_EXPR,
+				   ssizetype,
+				   fold_convert (ssizetype, index),
+				   bound);
+  return fold_build2_loc (a68_get_node_location (p),
+			  TRUTH_ORIF_EXPR,
+			  ssizetype,
+			  bounds_check, call);
+}
+
+/* Return a tree that checks whether the given DIM is a valid dimension/rank of
+   a boundable object with dimension BOUNDABLE_DIM.  If the provided DIM is not
+   a valid dimention then a call to the run-time function ARRAYDIM is
+   performed.
+
+   BOUNDABLE_DIM and DIM must be of type sizetype.  They are both one-based.
+
+   The parse tree node P is used as the source for the filename and line number
+   passed to the run-time function.  */
+
+static tree
+a68_boundable_dim_check (NODE_T *p, tree boundable_dim, tree dim)
+{
+  boundable_dim = save_expr (boundable_dim);
+  dim = save_expr (dim);
+
+  /* Build the call to ARRAYDIM. */
+  unsigned int lineno = NUMBER (LINE (INFO (p)));
+  const char *filename_str = FILENAME (LINE (INFO (p)));
+  tree filename = build_string_literal (strlen (filename_str) + 1,
+					filename_str);
+  tree call = a68_build_libcall (A68_LIBCALL_ARRAYDIM,
+				 void_type_node, 4,
+				 filename,
+				 build_int_cst (unsigned_type_node, lineno),
+				 boundable_dim, dim);
+  call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node);
+
+  tree dim_check = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+				fold_build2 (GT_EXPR, boolean_type_node, dim, size_zero_node),
+				fold_build2 (LE_EXPR, boolean_type_node, dim, boundable_dim));
+  return fold_build2_loc (a68_get_node_location (p),
+			  TRUTH_ORIF_EXPR,
+			  ssizetype,
+			  dim_check, call);
+}
+
+/* Return a tree that checks whether the given DIM is a valid dimension/rank of
+   the given rows value ROWS.
+
+   DIM is a sizetype.
+   The parse tree node P is used as the source for the filename and line
+   number.  */
+
+tree
+a68_rows_dim_check (NODE_T *p, tree rows, tree dim)
+{
+  return a68_boundable_dim_check (p, a68_rows_dim (rows), dim);
+}
+
+/* Return a tree that checks whether the given DIM is a valid dimension/rank of
+   the given multiple value MULTIPLE.
+
+   DIM is a sizetype.
+   The parse tree node P is used as the source for the filename and line
+   number.  */
+
+tree
+a68_multiple_dim_check (NODE_T *p, tree multiple, tree dim)
+{
+  return a68_boundable_dim_check (p, a68_multiple_dimensions (multiple), dim);
+}
+
+/* Return a tree that checks whether the given INDEX falls within the bounds of
+   MULTIPLE in the rank DIM.  If the provided index is out of bounds then a
+   call to the run-time function ARRAYBOUNDS is performed.
+
+   DIM must be a sizetype.
+   MULTIPLE must be a multiple value.
+   INDEX must be a ssizetype.
+
+   The parse tree node P is used as the source for the filename and line number
+   passed to the run-time function.  */
+
+tree
+a68_multiple_bounds_check (NODE_T *p, tree dim,
+			   tree multiple, tree index)
+{
+  index = save_expr (index);
+  multiple = save_expr (multiple);
+
+  tree upper_bound = a68_multiple_upper_bound (multiple, dim);
+  tree lower_bound = a68_multiple_lower_bound (multiple, dim);
+
+  /* Build the call to ARRAYBOUNDS. */
+  unsigned int lineno = NUMBER (LINE (INFO (p)));
+  const char *filename_str = FILENAME (LINE (INFO (p)));
+  tree filename = build_string_literal (strlen (filename_str) + 1,
+					filename_str);
+  tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDS,
+				 void_type_node, 5,
+				 filename,
+				 build_int_cst (unsigned_type_node, lineno),
+				 fold_convert (ssizetype, index),
+				 fold_convert (ssizetype, lower_bound),
+				 fold_convert (ssizetype, upper_bound));
+  call = fold_build2 (COMPOUND_EXPR, a68_bool_type, call, boolean_false_node);
+
+  /* If LB > UB, the dimension contains no elements.
+     Otherwise, it must hold IDX >= LB && IDX <= UB */
+  tree bounds_check = fold_build2 (TRUTH_AND_EXPR, sizetype,
+				   fold_build2 (LE_EXPR, ssizetype,
+						lower_bound, upper_bound),
+				   fold_build2 (TRUTH_AND_EXPR,
+						boolean_type_node,
+						fold_build2 (GE_EXPR, ssizetype,
+							     fold_convert (ssizetype,
+									   index),
+							     lower_bound),
+						fold_build2 (LE_EXPR, ssizetype,
+							     fold_convert (ssizetype,
+									   index),
+							     upper_bound)));
+  return fold_build2_loc (a68_get_node_location (p),
+			  TRUTH_ORIF_EXPR,
+			  ssizetype,
+			  bounds_check, call);
+}
+
+/* Emit a run-time error if the bounds of M1 and M2 are not the same.  Both
+   multiples are assumed to have the same type and therefore feature the same
+   number of dimensions.  */
+
+tree
+a68_multiple_bounds_check_equal (NODE_T *p, tree m1, tree m2)
+{
+  m1 = save_expr (m1);
+  m2 = save_expr (m2);
+
+  /* First determine the rank of the multiples and check they match.  */
+  tree m1_dimensions = a68_multiple_dimensions (m1);
+  tree m2_dimensions = a68_multiple_dimensions (m2);
+  gcc_assert (TREE_CODE (m1_dimensions) == INTEGER_CST
+	      && TREE_CODE (m2_dimensions) == INTEGER_CST);
+
+  int dim1 = tree_to_shwi (m1_dimensions);
+  int dim2 = tree_to_shwi (m2_dimensions);
+  gcc_assert (dim1 == dim2);
+
+  a68_push_range (NULL /* VOID */);
+
+  /* For each dimension, check that bounds are the same in both multiples.  */
+  int i;
+  for (i = 0; i < dim1; ++i)
+    {
+      tree dim_tree = build_int_cst (ssizetype, i);
+      tree dim_plus_one = fold_build2 (PLUS_EXPR, ssizetype,
+				       dim_tree,
+				       fold_convert (ssizetype, size_one_node));
+
+      tree lb1 = save_expr (a68_multiple_lower_bound (m1, dim_tree));
+      tree lb2 = save_expr (a68_multiple_lower_bound (m2, dim_tree));
+
+      tree ub1 = save_expr (a68_multiple_upper_bound (m1, dim_tree));
+      tree ub2 = save_expr (a68_multiple_upper_bound (m2, dim_tree));
+
+      tree bounds_equal = fold_build2 (TRUTH_AND_EXPR,
+				       boolean_type_node,
+				       fold_build2 (EQ_EXPR, boolean_type_node,
+						    lb1, lb2),
+				       fold_build2 (EQ_EXPR, boolean_type_node,
+						    ub1, ub2));
+
+      unsigned int lineno = NUMBER (LINE (INFO (p)));
+      const char *filename_str = FILENAME (LINE (INFO (p)));
+      tree filename = build_string_literal (strlen (filename_str) + 1,
+					    filename_str);
+      tree call = a68_build_libcall (A68_LIBCALL_ARRAYBOUNDSMISMATCH,
+				     void_type_node, 7,
+				     filename,
+				     build_int_cst (unsigned_type_node, lineno),
+				     dim_plus_one,
+				     lb1, ub1, lb2, ub2);
+      call = fold_build2 (COMPOUND_EXPR, boolean_type_node, call, boolean_false_node);
+
+      tree check = fold_build2_loc (a68_get_node_location (p),
+				    TRUTH_ORIF_EXPR, boolean_type_node,
+				    bounds_equal,
+				    call);
+      a68_add_stmt (check);
+    }
+
+  return a68_pop_range ();
+}
+
+/* Allocate a multiple on the heap.
+
+   M is the mode the multiple to allocate.
+   DIM is the number of dimensions of the multiple.
+   ELEMS is a pointer to the elements of the multiple.
+   ELEMS_SIZE is the size in bytes of ELEMS.
+   *LOWER_BOUND and *UPPER_BOUND are the bounds for the DIM dimensions.  */
+
+tree
+a68_row_malloc (tree type, int dim, tree elems, tree elems_size,
+		tree *lower_bound, tree *upper_bound)
+{
+  tree ptr_to_type = build_pointer_type (type);
+
+  a68_push_range (NULL);
+
+  /* Allocate space for the descriptor.  */
+  tree ptr_to_multiple = a68_lower_tmpvar ("ptr_to_multiple%", ptr_to_type,
+					   a68_lower_malloc (type, size_in_bytes (type)));
+  tree multiple = a68_row_value (type, dim,
+				 elems, elems_size,
+				 lower_bound, upper_bound);
+  a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+			     fold_build1 (INDIRECT_REF, type, ptr_to_multiple),
+			     multiple));
+  a68_add_stmt (ptr_to_multiple);
+  tree res = a68_pop_range ();
+  TREE_TYPE (res) = ptr_to_type;
+  return res;
+}
diff --git a/gcc/algol68/a68-low-structs.cc b/gcc/algol68/a68-low-structs.cc
new file mode 100644
index 00000000000..12bb6192fb4
--- /dev/null
+++ b/gcc/algol68/a68-low-structs.cc
@@ -0,0 +1,63 @@
+/* Lowering routines for all things related to structs.
+   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"
+
+/* Return a tree with the yielding of SKIP for the given structured mode.  */
+
+tree
+a68_get_struct_skip_tree (MOID_T *m)
+{
+  /* Build a constructor that assigns SKIPs to each field in the struct
+     type.  */
+
+  vec <constructor_elt, va_gc> *ve = NULL;
+  tree field = TYPE_FIELDS (CTYPE (m));
+  for (PACK_T *elem = PACK (m); elem; FORWARD (elem))
+    {
+      gcc_assert (field != NULL_TREE);
+      CONSTRUCTOR_APPEND_ELT (ve, field, a68_get_skip_tree (MOID (elem)));
+      field = DECL_CHAIN (field);
+    }
+
+  return build_constructor (CTYPE (m), ve);
+}
diff --git a/gcc/algol68/a68-low-unions.cc b/gcc/algol68/a68-low-unions.cc
new file mode 100644
index 00000000000..f775877f327
--- /dev/null
+++ b/gcc/algol68/a68-low-unions.cc
@@ -0,0 +1,279 @@
+/* Lowering routines for all things related to unions.
+   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"
+
+/* Algol 68 unions are implemented in this front-end as a data structure
+   consisting of an overhead followed by a value:
+
+     overhead%
+     value%
+
+   Where overhead% is an index that identifies the kind of object currently
+   united, and value% is a GENERIC union.  The value currently united in the
+   union is the overhead%-th field in value%.
+
+   At the language level there are no values of union modes in Algol 68.  All
+   values are built from either SKIP (for uninitialized UNION values) or as the
+   result of an uniting coercion.  */
+
+/* Given an union mode P and a mode Q, return whether Q is a mode in P.  */
+
+bool
+a68_union_contains_mode (MOID_T *p, MOID_T *q)
+{
+  while (EQUIVALENT (p) != NO_MOID)
+    p = EQUIVALENT (p);
+
+  for (PACK_T *pack = PACK (p); pack != NO_PACK; FORWARD (pack))
+    {
+      MOID_T *m = MOID (pack);
+
+      if (a68_is_equal_modes (q, m, SAFE_DEFLEXING)
+	  || (m == M_STRING && IS_ROW (q) && SUB (q) == M_CHAR)
+	  || (q == M_STRING && IS_ROW (m) && SUB (m) == M_CHAR))
+	return true;
+    }
+
+  return false;
+}
+
+/* Given an union mode P and a mode Q, return an integer with the index of the
+   occurrence of Q in P.  */
+
+int
+a68_united_mode_index (MOID_T *p, MOID_T *q)
+{
+  int ret = 0;
+  while (EQUIVALENT (p) != NO_MOID)
+    p = EQUIVALENT (p);
+  for (PACK_T *pack = PACK (p); pack != NO_PACK; FORWARD (pack))
+    {
+      MOID_T *m = MOID (pack);
+
+      if (a68_is_equal_modes (q, m, SAFE_DEFLEXING)
+	  || (m == M_STRING && IS_ROW (q) && SUB (q) == M_CHAR)
+	  || (q == M_STRING && IS_ROW (m) && SUB (m) == M_CHAR))
+	return ret;
+      ret += 1;
+    }
+
+  /* Not found.  Shouldn't happen.  */
+  gcc_unreachable ();
+  return 0;
+}
+
+/* Given two united modes FROM and TO, and an overhead FROM_OVERHEAD in mode
+   FROM, return the corresponding overhead in mode TO.
+
+   This function assumes that the mode with FROM_OVERHEAD in mode FROM exists
+   in TO.  */
+
+tree
+a68_union_translate_overhead (MOID_T *from, tree from_overhead,
+			      MOID_T *to)
+{
+  /* Note that the initialization value for to_overhead should never be used.
+     XXX perhaps translate it to a run-time call to abort/compiler-error.  */
+  tree to_overhead = size_int (0);
+
+  from_overhead = save_expr (from_overhead);
+
+  int i = 0;
+  for (PACK_T *pack = PACK (from); pack != NO_PACK; FORWARD (pack), ++i)
+    {
+      MOID_T *mode = MOID (pack);
+
+      if (a68_union_contains_mode (to, mode))
+	{
+	  to_overhead = fold_build3 (COND_EXPR, sizetype,
+				     fold_build2 (EQ_EXPR, boolean_type_node,
+						  from_overhead,
+						  size_int (i)),
+				     size_int (a68_united_mode_index (to, mode)),
+				     to_overhead);
+	}
+    }
+
+  return to_overhead;
+}
+
+/* Get the overhead of a given united value EXP.  */
+
+tree
+a68_union_overhead (tree exp)
+{
+  tree type = TREE_TYPE (exp);
+  tree overhead_field = TYPE_FIELDS (type);
+  return fold_build3 (COMPONENT_REF,
+		      TREE_TYPE (overhead_field),
+		      exp,
+		      overhead_field,
+		      NULL_TREE);
+}
+
+/* Set the overhead of a given united value EXP to OVERHEAD.  */
+
+tree
+a68_union_set_overhead (tree exp, tree overhead)
+{
+  tree type = TREE_TYPE (exp);
+  tree overhead_field = TYPE_FIELDS (type);
+  return fold_build2 (MODIFY_EXPR,
+		      TREE_TYPE (overhead),
+		      fold_build3 (COMPONENT_REF,
+				   TREE_TYPE (overhead_field),
+				   exp,
+				   overhead_field,
+				   NULL_TREE),
+		      overhead);
+}
+
+/* Get the cunion in the given union EXP.  */
+
+tree
+a68_union_cunion (tree exp)
+{
+  tree type = TREE_TYPE (exp);
+  tree value_field = TREE_CHAIN (TYPE_FIELDS (type));
+  return fold_build3 (COMPONENT_REF,
+		      TREE_TYPE (value_field),
+		      exp,
+		      value_field,
+		      NULL_TREE);
+}
+
+/* Build a SKIP value for a given union mode M.
+
+   The SKIP value computed is:
+
+   overhead% refers to the first united mode in the union
+   value% is the SKIP for the first united mode in the union
+*/
+
+tree
+a68_get_union_skip_tree (MOID_T *m)
+{
+  tree type = CTYPE (m);
+  tree overhead_field = TYPE_FIELDS (type);
+  tree value_field = TREE_CHAIN (TYPE_FIELDS (type));
+
+  /* Overhead selects the first union alternative.  */
+  tree overhead = size_zero_node;
+  /* First union alternative.
+
+     Note that the first union alternative corresponds to the last alternative
+     in the mode as written in the source program.  */
+  tree value_type = TREE_TYPE (value_field);
+  tree first_alternative_field = TYPE_FIELDS (value_type);
+  tree value = build_constructor_va (TREE_TYPE (value_field),
+				     1,
+				     first_alternative_field,
+				     a68_get_skip_tree (MOID (PACK (m))));
+  return build_constructor_va (CTYPE (m),
+			       2,
+			       overhead_field, overhead,
+			       value_field, value);
+}
+
+/* Return the alternative (value) at the index INDEX in the united value
+   EXP.  */
+
+tree
+a68_union_alternative (tree exp, int index)
+{
+  tree type = TREE_TYPE (exp);
+  tree value_field = TREE_CHAIN (TYPE_FIELDS (type));
+  tree value = fold_build3 (COMPONENT_REF,
+			    TREE_TYPE (value_field),
+			    exp,
+			    value_field,
+			    NULL_TREE);
+
+  /* Get the current alternative in the value union.  */
+  tree value_type = TREE_TYPE (value_field);
+  tree alternative_field = TYPE_FIELDS (value_type);
+  for (int i = 0; i < index; ++i)
+    {
+      gcc_assert (TREE_CHAIN (alternative_field));
+      alternative_field = TREE_CHAIN (alternative_field);
+    }
+
+  /* Get the current alternative from the value.  */
+  return fold_build3 (COMPONENT_REF,
+		      TREE_TYPE (alternative_field),
+		      value,
+		      alternative_field,
+		      NULL_TREE);
+}
+
+/* Return a constructor for an union of mode MODE, holding the value in EXP
+   which is of mode EXP_MODE.  */
+
+tree
+a68_union_value (MOID_T *mode, tree exp, MOID_T *exp_mode)
+{
+  tree type = CTYPE (mode);
+  tree overhead_field = TYPE_FIELDS (type);
+  tree value_field = TREE_CHAIN (TYPE_FIELDS (type));
+
+  int alternative_index = a68_united_mode_index (mode, exp_mode);
+  tree overhead = build_int_cst (sizetype, alternative_index);
+
+  /* Get the field for the alternative corresponding to alternative_index.  */
+  tree value_type = TREE_TYPE (value_field);
+  tree alternative_field = TYPE_FIELDS (value_type);
+  for (int i = 0; i < alternative_index; ++i)
+    {
+      gcc_assert (TREE_CHAIN (alternative_field));
+      alternative_field = TREE_CHAIN (alternative_field);
+    }
+
+  tree value = build_constructor_va (TREE_TYPE (value_field),
+				     1,
+				     alternative_field,
+				     a68_consolidate_ref (exp_mode, exp));
+  return build_constructor_va (type,
+			       2,
+			       overhead_field, overhead,
+			       value_field, value);
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 32/47] a68: low: standard prelude
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (30 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 31/47] a68: low: stowed values Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 33/47] a68: low: clauses and declarations Jose E. Marchesi
                   ` (15 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-low-posix.cc: New file.
	* algol68/a68-low-prelude.cc: Likewise.
---
 gcc/algol68/a68-low-posix.cc   |  553 ++++++++
 gcc/algol68/a68-low-prelude.cc | 2151 ++++++++++++++++++++++++++++++++
 2 files changed, 2704 insertions(+)
 create mode 100644 gcc/algol68/a68-low-posix.cc
 create mode 100644 gcc/algol68/a68-low-prelude.cc

diff --git a/gcc/algol68/a68-low-posix.cc b/gcc/algol68/a68-low-posix.cc
new file mode 100644
index 00000000000..fd30677757c
--- /dev/null
+++ b/gcc/algol68/a68-low-posix.cc
@@ -0,0 +1,553 @@
+/* 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"
+
+/* Set the exit status of the running process, to be returned to the OS upon
+   exit.  */
+
+tree
+a68_posix_setexitstatus (void)
+{
+  return a68_get_libcall (A68_LIBCALL_SET_EXIT_STATUS);
+}
+
+/* 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_errno (void)
+{
+  return a68_get_libcall (A68_LIBCALL_POSIX_ERRNO);
+}
+
+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 (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 (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 (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 (gets_fndecl)),
+		      gets_fndecl);
+}
diff --git a/gcc/algol68/a68-low-prelude.cc b/gcc/algol68/a68-low-prelude.cc
new file mode 100644
index 00000000000..944db198a83
--- /dev/null
+++ b/gcc/algol68/a68-low-prelude.cc
@@ -0,0 +1,2151 @@
+/* Lower Algol 68 pre-defined operators and procedures.
+   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 "convert.h"
+
+#include "a68.h"
+
+/* The following handlers are for lowing the entities defined in
+   a68-parser-prelude.c.  */
+
+tree
+a68_lower_unimplemented (NODE_T *p,
+			 LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  fatal_error (a68_get_node_location (p),
+	       "no lowering routine installed for construct.  jemarch has been lazy");
+}
+
+tree
+a68_lower_charabs2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_char_abs (op);
+}
+
+tree
+a68_lower_boolabs2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_bool_abs (op);
+}
+
+tree
+a68_lower_intabs2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_int_abs (op);
+}
+
+tree
+a68_lower_realabs2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_real_abs (op);
+}
+
+tree
+a68_lower_confirm2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  /* Used to implement monadic +.  */
+  return a68_lower_tree (NEXT (SUB (p)), ctx);
+}
+
+tree
+a68_lower_negate2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return fold_build1_loc (a68_get_node_location (p),
+			  NEGATE_EXPR,
+			  CTYPE (MOID (p)),
+			  a68_lower_tree (NEXT (SUB (p)), ctx));
+}
+
+/* Lower an ENTIER standard monadic operator.  */
+
+tree
+a68_lower_entier2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *op = NEXT (SUB (p));
+  return a68_real_entier (a68_lower_tree (op, ctx), MOID (p), MOID (op));
+}
+
+/* Lower a ROUND standard monadic operator.
+
+   This operator gets a LONGSETY REAL and produces a LONGSETY INT which is the
+   nearest integer to the given real.  */
+
+tree
+a68_lower_round2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *op = NEXT (SUB (p));
+  return a68_real_round (a68_lower_tree (op, ctx), MOID (p), MOID (op));
+}
+
+tree
+a68_lower_not2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return fold_build1_loc (a68_get_node_location (p),
+			  TRUTH_NOT_EXPR,
+			  CTYPE (MOID (p)),
+			  a68_lower_tree (NEXT (SUB (p)), ctx));
+}
+
+tree
+a68_lower_and3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return fold_build2_loc (a68_get_node_location (p),
+			  TRUTH_AND_EXPR,
+			  CTYPE (MOID (p)),
+			  a68_lower_tree (SUB (p), ctx),
+			  a68_lower_tree (NEXT (NEXT (SUB (p))), ctx));
+}
+
+tree
+a68_lower_or3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return fold_build2_loc (a68_get_node_location (p),
+			  TRUTH_OR_EXPR,
+			  CTYPE (MOID (p)),
+			  a68_lower_tree (SUB (p), ctx),
+			  a68_lower_tree (NEXT (NEXT (SUB (p))), ctx));
+}
+
+tree
+a68_lower_xor3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return fold_build2_loc (a68_get_node_location (p),
+			  TRUTH_XOR_EXPR,
+			  CTYPE (MOID (p)),
+			  a68_lower_tree (SUB (p), ctx),
+			  a68_lower_tree (NEXT (NEXT (SUB (p))), ctx));
+}
+
+tree
+a68_lower_plus_int (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *m = MOID (p);
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_int_plus (m, op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_plus_real (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *m = MOID (p);
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_real_plus (m, op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_minus_int (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *m = MOID (p);
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_int_minus (m, op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_minus_real (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *m = MOID (p);
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_real_minus (m, op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_mult_int (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *m = MOID (p);
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_int_mult (m, op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_mult_real (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *m = MOID (p);
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_real_mult (m, op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_multab3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree lhs = a68_lower_tree (SUB (p), ctx);
+  lhs = a68_consolidate_ref (MOID (SUB (p)), lhs);
+  lhs = save_expr (lhs);
+  NODE_T *rhs_node = NEXT (NEXT (SUB (p)));
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+  tree operation = fold_build2_loc (a68_get_node_location (p),
+				    MULT_EXPR,
+				    TREE_TYPE (rhs),
+				    a68_low_deref (lhs, SUB (p)),
+				    rhs);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (lhs),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  lhs);
+}
+
+tree
+a68_lower_over3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *m = MOID (p);
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_int_div (m, op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_mod3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *m = MOID (p);
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_int_mod (m, op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_div3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_real_div (MOID (p),
+		       a68_lower_tree (SUB (p), ctx),
+		       a68_lower_tree (NEXT (NEXT (SUB (p))), ctx),
+		       a68_get_node_location (p));
+}
+
+tree
+a68_lower_rdiv3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_real_div (MOID (p),
+		       fold_build1 (FLOAT_EXPR, CTYPE (MOID (p)),
+				    a68_lower_tree (SUB (p), ctx)),
+		       fold_build1 (FLOAT_EXPR, CTYPE (MOID (p)),
+				    a68_lower_tree (NEXT (NEXT (SUB (p))), ctx)),
+		       a68_get_node_location (p));
+}
+
+tree
+a68_lower_int_eq3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_int_eq (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_int_ne3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_int_ne (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_int_lt3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_int_lt (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_int_le3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_int_le (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_int_gt3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_int_gt (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_int_ge3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_int_ge (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_real_eq3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_real_eq (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_real_ne3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_real_ne (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_real_lt3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_real_lt (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_real_le3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_real_le (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_real_gt3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_real_gt (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_real_ge3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_real_ge (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_char_eq3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_char_eq (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_char_ne3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_char_ne (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_char_lt3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_char_lt (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_char_le3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_char_le (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_char_gt3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_char_gt (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_char_ge3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_char_ge (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_bool_eq3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_bool_eq (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_bool_ne3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_bool_ne (op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_sign2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_int_sign (op);
+}
+
+tree
+a68_lower_realsign2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_real_sign (op);
+}
+
+tree
+a68_lower_plusab3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree lhs = a68_lower_tree (SUB (p), ctx);
+  lhs = a68_consolidate_ref (MOID (SUB (p)), lhs);
+  lhs = save_expr (lhs);
+  NODE_T *rhs_node = NEXT (NEXT (SUB (p)));
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+  tree operation = fold_build2_loc (a68_get_node_location (p),
+				    PLUS_EXPR,
+				    TREE_TYPE (rhs),
+				    a68_low_deref (lhs, SUB (p)),
+				    rhs);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (lhs),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  lhs);
+}
+
+tree
+a68_lower_minusab3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree lhs = a68_lower_tree (SUB (p), ctx);
+  lhs = a68_consolidate_ref (MOID (SUB (p)), lhs);
+  lhs = save_expr (lhs);
+  NODE_T *rhs_node = NEXT (NEXT (SUB (p)));
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+  tree operation = fold_build2_loc (a68_get_node_location (p),
+				    MINUS_EXPR,
+				    TREE_TYPE (rhs),
+				    a68_low_deref (lhs, SUB (p)),
+				    rhs);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (lhs),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  lhs);
+}
+
+tree
+a68_lower_overab3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree lhs = a68_lower_tree (SUB (p), ctx);
+  lhs = a68_consolidate_ref (MOID (SUB (p)), lhs);
+  lhs = save_expr (lhs);
+  NODE_T *rhs_node = NEXT (NEXT (SUB (p)));
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+  tree operation = fold_build2_loc (a68_get_node_location (p),
+				    TRUNC_DIV_EXPR,
+				    TREE_TYPE (rhs),
+				    a68_low_deref (lhs, SUB (p)),
+				    rhs);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (lhs),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  lhs);
+}
+
+tree
+a68_lower_modab3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree lhs = a68_lower_tree (SUB (p), ctx);
+  lhs = a68_consolidate_ref (MOID (SUB (p)), lhs);
+  lhs = save_expr (lhs);
+  NODE_T *rhs_node = NEXT (NEXT (SUB (p)));
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+  tree operation = fold_build2_loc (a68_get_node_location (p),
+				    TRUNC_MOD_EXPR,
+				    TREE_TYPE (rhs),
+				    a68_low_deref (lhs, SUB (p)),
+				    rhs);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (lhs),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  lhs);
+}
+
+tree
+a68_lower_divab3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree lhs = a68_lower_tree (SUB (p), ctx);
+  lhs = a68_consolidate_ref (MOID (SUB (p)), lhs);
+  lhs = save_expr (lhs);
+  NODE_T *rhs_node = NEXT (NEXT (SUB (p)));
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+  tree operation = fold_build2_loc (a68_get_node_location (p),
+				    RDIV_EXPR,
+				    TREE_TYPE (rhs),
+				    a68_low_deref (lhs, SUB (p)),
+				    rhs);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (lhs),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  lhs);
+}
+
+/* UPB comes in two flavors.
+
+   The unary operator returns the upper bound of the first dimension of the
+   operand multple.
+
+   The binary operator returns the upper bound of the given dimension of the
+   operand multiple.  The dimension is one-based.  If the specified dimension
+   is out of bounds then an a run-time error is raised.  */
+
+static tree
+upb (NODE_T *p, tree boundable, tree dim)
+{
+  boundable = save_expr (boundable);
+  dim = save_expr (dim);
+
+  /* BOUNDABLE can be a multiple or a ROWS.  */
+  tree zero_based_dim
+    = save_expr (fold_build2 (MINUS_EXPR, TREE_TYPE (dim), dim, size_one_node));
+  tree type = TREE_TYPE (boundable);
+  if (A68_ROW_TYPE_P (type))
+    {
+      return fold_build2 (COMPOUND_EXPR, ssizetype,
+			  a68_multiple_dim_check (p, boundable, dim),
+			  a68_multiple_upper_bound (boundable, zero_based_dim));
+    }
+  else if (A68_ROWS_TYPE_P (type))
+    {
+      return fold_build2 (COMPOUND_EXPR, ssizetype,
+			  a68_rows_dim_check (p, boundable, dim),
+			  a68_rows_upper_bound (boundable, zero_based_dim));
+    }
+  else
+    gcc_unreachable ();
+}
+
+tree
+a68_lower_upb2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree multiple = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return fold_convert (CTYPE (MOID (p)), upb (p, multiple, size_one_node));
+}
+
+tree
+a68_lower_upb3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree dim = fold_convert (sizetype, a68_lower_tree (SUB (p), ctx));
+  tree multiple = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return fold_convert (CTYPE (MOID (p)), upb (p, multiple, dim));
+}
+
+/* LWB comes in two flavors.
+
+   The unary operator returns the lower bound of the first dimension of the
+   operand multple.
+
+   The binary operator returns the lower bound of the given dimension of the
+   operand multiple.  The dimension is one-based.  If the specified dimension
+   is out of bounds then an a run-time error is raised.  */
+
+static tree
+lwb (NODE_T *p, tree boundable, tree dim)
+{
+  boundable = save_expr (boundable);
+  dim = save_expr (dim);
+
+  /* BOUNDABLE can be a multiple or an union whose all alternatives yield a
+     multiple.  */
+  tree zero_based_dim
+    = save_expr (fold_build2 (MINUS_EXPR, TREE_TYPE (dim), dim, size_one_node));
+  tree type = TREE_TYPE (boundable);
+  if (A68_ROW_TYPE_P (type))
+    {
+      return fold_build2 (COMPOUND_EXPR, ssizetype,
+			  a68_multiple_dim_check (p, boundable, dim),
+			  a68_multiple_lower_bound (boundable, zero_based_dim));
+    }
+  else if (A68_ROWS_TYPE_P (type))
+    {
+      return fold_build2 (COMPOUND_EXPR, ssizetype,
+			  a68_rows_dim_check (p, boundable, dim),
+			  a68_rows_lower_bound (boundable, zero_based_dim));
+    }
+  else
+    gcc_unreachable ();
+}
+
+tree
+a68_lower_lwb2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree multiple = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return fold_convert (CTYPE (MOID (p)), lwb (p, multiple, size_one_node));
+}
+
+tree
+a68_lower_lwb3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree dim = fold_convert (sizetype, a68_lower_tree (SUB (p), ctx));
+  tree multiple = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return fold_convert (CTYPE (MOID (p)), lwb (p, multiple, dim));
+}
+
+/* ELEMS comes in two flavors.
+
+   The unary operator returns the number of elements in the first dimension of
+   the operand multple.
+
+   DIM must be a size.
+
+   The binary operator returns the number of elements in the given dimension of the
+   operand multiple.  The dimension is one-based.  If the specified dimension
+   is out of bounds then an a run-time error is raised.  */
+
+static tree
+elems (NODE_T *p, tree boundable, tree dim)
+{
+  dim = save_expr (dim);
+
+  /* BOUNDABLE can be a multiple or a ROWS.  */
+  tree type = TREE_TYPE (boundable);
+
+  /* Make DIM zero-based.  */
+  tree dim_minus_one
+    = fold_build2 (MINUS_EXPR, TREE_TYPE (dim), dim, size_one_node);
+
+  boundable = save_expr (boundable);
+  tree upper_bound = NULL_TREE;
+  tree lower_bound = NULL_TREE;
+  tree check_dimension = NULL_TREE;
+  if (A68_ROW_TYPE_P (type))
+    {
+      upper_bound = a68_multiple_upper_bound (boundable, dim_minus_one);
+      lower_bound = a68_multiple_lower_bound (boundable, dim_minus_one);
+      check_dimension = a68_multiple_dim_check (p, boundable, dim);
+    }
+  else if (A68_ROWS_TYPE_P (type))
+    {
+      upper_bound = a68_rows_upper_bound (boundable, dim_minus_one);
+      lower_bound = a68_rows_lower_bound (boundable, dim_minus_one);
+      check_dimension = a68_rows_dim_check (p, boundable, dim);
+    }
+  else
+    gcc_unreachable ();
+
+  upper_bound = save_expr (upper_bound);
+  lower_bound = save_expr (lower_bound);
+
+  tree non_flat = fold_build2 (PLUS_EXPR,
+			       sizetype,
+			       fold_convert (sizetype,
+					     fold_build2 (MINUS_EXPR, ssizetype,
+							  upper_bound, lower_bound)),
+			       size_one_node);
+
+  tree elems = fold_build3 (COND_EXPR, sizetype,
+			    fold_build2 (LT_EXPR, boolean_type_node,
+					 upper_bound, lower_bound),
+			    size_zero_node,
+			    non_flat);
+
+  if (OPTION_BOUNDS_CHECKING (&A68_JOB))
+    elems = fold_build2 (COMPOUND_EXPR, sizetype,
+			 check_dimension,
+			 elems);
+
+  return elems;
+}
+
+tree
+a68_lower_elems2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree multiple = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return fold_convert (CTYPE (MOID (p)), elems (p, multiple, size_one_node));
+}
+
+tree
+a68_lower_elems3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree dim = fold_convert (sizetype, a68_lower_tree (SUB (p), ctx));
+  tree multiple = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return fold_convert (CTYPE (MOID (p)), elems (p, multiple, dim));
+}
+
+tree
+a68_lower_pow_int (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_int_pow (MOID (p), op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_pow_real (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *mode = MOID (p);
+  MOID_T *op1_mode = MOID (SUB (p));
+  MOID_T *op2_mode = MOID (NEXT (NEXT (SUB (p))));
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_real_pow (mode, op1_mode, op2_mode,
+		       op1, op2, a68_get_node_location (p));
+}
+
+tree
+a68_lower_odd2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *op = NEXT (SUB (p));
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  EQ_EXPR,
+			  a68_bool_type,
+			  fold_build2 (BIT_AND_EXPR,
+				       CTYPE (MOID (op)),
+				       a68_lower_tree (op, ctx),
+				       build_int_cst (CTYPE (MOID (op)), 1)),
+			  build_int_cst (CTYPE (MOID (op)), 1));
+}
+
+tree
+a68_lower_string_eq3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  tree cmp = a68_string_cmp (op1, op2);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  EQ_EXPR,
+			  a68_bool_type,
+			  cmp,
+			  build_int_cst (a68_int_type, 0));
+}
+
+tree
+a68_lower_string_ne3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  tree cmp = a68_string_cmp (op1, op2);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  NE_EXPR,
+			  a68_bool_type,
+			  cmp,
+			  build_int_cst (a68_int_type, 0));
+}
+
+tree
+a68_lower_string_lt3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  tree cmp = a68_string_cmp (op1, op2);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  LT_EXPR,
+			  a68_bool_type,
+			  cmp,
+			  build_int_cst (a68_int_type, 0));
+}
+
+tree
+a68_lower_string_le3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  tree cmp = a68_string_cmp (op1, op2);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  LE_EXPR,
+			  a68_bool_type,
+			  cmp,
+			  build_int_cst (a68_int_type, 0));
+}
+
+tree
+a68_lower_string_gt3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  tree cmp = a68_string_cmp (op1, op2);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  GT_EXPR,
+			  a68_bool_type,
+			  cmp,
+			  build_int_cst (a68_int_type, 0));
+}
+
+tree
+a68_lower_string_ge3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  tree cmp = a68_string_cmp (op1, op2);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  GE_EXPR,
+			  a68_bool_type,
+			  cmp,
+			  build_int_cst (a68_int_type, 0));
+}
+
+tree
+a68_lower_string_plus3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_string_concat (a68_lower_tree (SUB (p), ctx),
+			    a68_lower_tree (NEXT (NEXT (SUB (p))), ctx));
+}
+
+tree
+a68_lower_string_plusab3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree lhs = a68_lower_tree (SUB (p), ctx);
+  lhs = a68_consolidate_ref (MOID (SUB (p)), lhs);
+  lhs = save_expr (lhs);
+  NODE_T *rhs_node = NEXT (NEXT (SUB (p)));
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+  tree operation = a68_string_concat (a68_low_deref (lhs, SUB (p)), rhs);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (lhs),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  lhs);
+}
+
+tree
+a68_lower_string_plusto3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *lhs_node = NEXT (NEXT (SUB (p)));
+  tree lhs = a68_lower_tree (lhs_node, ctx);
+  lhs = a68_consolidate_ref (MOID (lhs_node), lhs);
+  lhs = save_expr (lhs);
+  MOID_T *lhs_mode = MOID (lhs_node);
+  NODE_T *rhs_node = SUB (p);
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+  tree operation = a68_string_concat (rhs, a68_low_deref (lhs, NEXT (NEXT (SUB (p)))));
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (lhs),
+			  a68_low_assignation (p, lhs, lhs_mode,
+					       operation, MOID (rhs_node)),
+			  lhs);
+}
+
+tree
+a68_lower_repr2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *op = NEXT (SUB (p));
+  return a68_char_repr (op, a68_lower_tree (op, ctx));
+}
+
+tree
+a68_lower_char_plus3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+  return a68_string_concat (a68_string_from_char (op1),
+			    a68_string_from_char (op2));
+}
+
+tree
+a68_lower_char_mult3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *n1 = SUB (p);
+  NODE_T *n2 = NEXT (NEXT (SUB (p)));
+
+  if (MOID (n1) == M_INT)
+    {
+      gcc_assert (MOID (n2) == M_STRING || MOID (n2) == M_ROW_CHAR);
+      return a68_string_mult (a68_string_from_char (a68_lower_tree (n2, ctx)),
+			      a68_lower_tree (n1, ctx));
+    }
+  else
+    {
+      gcc_assert (MOID (n1) == M_CHAR);
+      gcc_assert (MOID (n2) == M_INT);
+      return a68_string_mult (a68_string_from_char (a68_lower_tree (n1, ctx)),
+			      a68_lower_tree (n2, ctx));
+    }
+}
+
+tree
+a68_lower_string_mult3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *n1 = SUB (p);
+  NODE_T *n2 = NEXT (NEXT (SUB (p)));
+
+  if (MOID (n1) == M_INT)
+    {
+      gcc_assert (MOID (n2) == M_STRING || MOID (n2) == M_ROW_CHAR);
+      return a68_string_mult (a68_lower_tree (n2, ctx),
+			      a68_lower_tree (n1, ctx));
+    }
+  else
+    {
+      gcc_assert (MOID (n1) == M_STRING || MOID (n1) == M_ROW_CHAR);
+      gcc_assert (MOID (n2) == M_INT);
+      return a68_string_mult (a68_lower_tree (n1, ctx),
+			      a68_lower_tree (n2, ctx));
+    }
+}
+
+tree
+a68_lower_string_multab3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree lhs = a68_lower_tree (SUB (p), ctx);
+  lhs = a68_consolidate_ref (MOID (SUB (p)), lhs);
+  lhs = save_expr (lhs);
+  NODE_T *rhs_node = NEXT (NEXT (SUB (p)));
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+  tree operation = a68_string_mult (a68_low_deref (lhs, SUB (p)), rhs);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (lhs),
+			  a68_low_assignation (p, lhs, MOID (SUB (p)), operation, MOID (rhs_node)),
+			  lhs);
+}
+
+/* SIZETY BITS operators.  */
+
+tree
+a68_lower_bin2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_bits_bin (MOID (p), op);
+}
+
+tree
+a68_lower_bitabs2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_bits_abs (MOID (p), op);
+}
+
+tree
+a68_lower_bitleng2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_bits_leng (CTYPE (MOID (p)), op);
+}
+
+tree
+a68_lower_bitshorten2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_bits_shorten (CTYPE (MOID (p)), op);
+}
+
+tree
+a68_lower_bitnot2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_bits_not (op);
+}
+
+tree
+a68_lower_bitand3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_and (op1, op2);
+}
+
+tree
+a68_lower_bitior3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_ior (op1, op2);
+}
+
+tree
+a68_lower_bitxor3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_xor (op1, op2);
+}
+
+tree
+a68_lower_shl3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree bits = a68_lower_tree (SUB (p), ctx);
+  tree shift = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_shift (shift, bits);
+}
+
+tree
+a68_lower_shr3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree bits = a68_lower_tree (SUB (p), ctx);
+  tree shift = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_shift (fold_build1 (NEGATE_EXPR,
+				      TREE_TYPE (shift), shift),
+			 bits);
+}
+
+tree
+a68_lower_bitelem3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree pos = a68_lower_tree (SUB (p), ctx);
+  tree bits = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_elem (p, pos, bits);
+}
+
+tree
+a68_lower_bit_eq3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_eq (op1, op2);
+}
+
+tree
+a68_lower_bit_ne3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_ne (op1, op2);
+}
+
+tree
+a68_lower_bit_le3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_subset (op1, op2);
+}
+
+tree
+a68_lower_bit_ge3 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  return a68_bits_subset (op2, op1);
+}
+
+/* Environment enquiries.  */
+
+tree
+a68_lower_maxint (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_int_maxval (CTYPE (MOID (p)));
+}
+
+tree
+a68_lower_minint (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_int_minval (CTYPE (MOID (p)));
+}
+
+tree
+a68_lower_maxbits (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_bits_maxbits (CTYPE (MOID (p)));
+}
+
+tree
+a68_lower_maxreal (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_maxval (CTYPE (MOID (p)));
+}
+
+tree
+a68_lower_minreal (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_minval (CTYPE (MOID (p)));
+}
+
+tree
+a68_lower_smallreal (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_smallval (CTYPE (MOID (p)));
+}
+
+tree
+a68_lower_bitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_bits_width (a68_bits_type);
+}
+
+tree
+a68_lower_longbitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_bits_width (a68_long_bits_type);
+}
+
+tree
+a68_lower_longlongbitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_bits_width (a68_long_long_bits_type);
+}
+
+tree
+a68_lower_shortbitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_bits_width (a68_short_bits_type);
+}
+
+tree
+a68_lower_shortshortbitswidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_bits_width (a68_short_short_bits_type);
+}
+
+tree
+a68_lower_intwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_int_width (a68_int_type);
+}
+
+tree
+a68_lower_longintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_int_width (a68_long_int_type);
+}
+
+tree
+a68_lower_longlongintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_int_width (a68_long_long_int_type);
+}
+
+tree
+a68_lower_shortintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_int_width (a68_short_int_type);
+}
+
+tree
+a68_lower_shortshortintwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_int_width (a68_short_short_int_type);
+}
+
+tree
+a68_lower_realwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_width (a68_real_type);
+}
+
+tree
+a68_lower_longrealwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_width (a68_long_real_type);
+}
+
+tree
+a68_lower_longlongrealwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_width (a68_long_long_real_type);
+}
+
+tree
+a68_lower_expwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_exp_width (a68_real_type);
+}
+
+tree
+a68_lower_longexpwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_exp_width (a68_long_real_type);
+}
+
+tree
+a68_lower_longlongexpwidth (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_exp_width (a68_long_long_real_type);
+}
+
+tree
+a68_lower_pi (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_real_pi (CTYPE (MOID (p)));
+}
+
+tree
+a68_lower_nullcharacter (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  static tree null_character = NULL_TREE;
+
+  if (null_character == NULL_TREE)
+    null_character = build_int_cst (a68_char_type, 0);
+  return null_character;
+}
+
+tree
+a68_lower_flip (NODE_T *p ATTRIBUTE_UNUSED,
+		LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  static tree flip = NULL_TREE;
+
+  if (flip == NULL_TREE)
+    flip = build_int_cst (a68_char_type, 84); /* T */
+  return flip;
+}
+
+tree
+a68_lower_invalidchar (NODE_T *p ATTRIBUTE_UNUSED,
+		       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  static tree invalidchar = NULL_TREE;
+
+  if (invalidchar == NULL_TREE)
+    invalidchar = build_int_cst (a68_char_type, 0xfffd);
+  return invalidchar;
+}
+
+tree
+a68_lower_flop (NODE_T *p ATTRIBUTE_UNUSED,
+		LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  static tree flop = NULL_TREE;
+
+  if (flop == NULL_TREE)
+    flop = build_int_cst (a68_char_type, 70); /* F */
+  return flop;
+}
+
+tree
+a68_lower_errorchar (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  static tree errorchar = NULL_TREE;
+
+  if (errorchar == NULL_TREE)
+    errorchar = build_int_cst (a68_char_type, 42); /* * */
+  return errorchar;
+}
+
+tree
+a68_lower_blank (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  static tree blank = NULL_TREE;
+
+  if (blank == NULL_TREE)
+    blank = build_int_cst (a68_char_type, 32);
+  return blank;
+}
+
+tree
+a68_lower_intlengths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  HOST_WIDE_INT int_size = int_size_in_bytes (a68_int_type);
+  HOST_WIDE_INT long_int_size = int_size_in_bytes (a68_long_int_type);
+  HOST_WIDE_INT long_long_int_size = int_size_in_bytes (a68_long_long_int_type);
+
+  gcc_assert (int_size != -1);
+  gcc_assert (long_int_size != -1);
+  gcc_assert (long_long_int_size != -1);
+
+  int lengths = 1;
+  if (long_long_int_size != long_int_size)
+    lengths++;
+  if (long_int_size != int_size)
+    lengths++;
+
+  return build_int_cst (CTYPE (MOID (p)), lengths);
+}
+
+tree
+a68_lower_intshorths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  HOST_WIDE_INT int_size = int_size_in_bytes (a68_int_type);
+  HOST_WIDE_INT short_int_size = int_size_in_bytes (a68_short_int_type);
+  HOST_WIDE_INT short_short_int_size = int_size_in_bytes (a68_short_short_int_type);
+
+  gcc_assert (int_size != -1);
+  gcc_assert (short_int_size != -1);
+  gcc_assert (short_short_int_size != -1);
+
+  int shorths = 1;
+  if (short_short_int_size != short_int_size)
+    shorths++;
+  if (short_int_size != int_size)
+    shorths++;
+
+  return build_int_cst (CTYPE (MOID (p)), shorths);
+}
+
+tree
+a68_lower_bitslengths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  HOST_WIDE_INT bits_size = int_size_in_bytes (a68_bits_type);
+  HOST_WIDE_INT long_bits_size = int_size_in_bytes (a68_long_bits_type);
+  HOST_WIDE_INT long_long_bits_size = int_size_in_bytes (a68_long_long_bits_type);
+
+  gcc_assert (bits_size != -1);
+  gcc_assert (long_bits_size != -1);
+  gcc_assert (long_long_bits_size != -1);
+
+  int lengths = 1;
+  if (long_long_bits_size != long_bits_size)
+    lengths++;
+  if (long_bits_size != bits_size)
+    lengths++;
+
+  return build_int_cst (CTYPE (MOID (p)), lengths);
+}
+
+tree
+a68_lower_bitsshorths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  HOST_WIDE_INT bits_size = int_size_in_bytes (a68_bits_type);
+  HOST_WIDE_INT short_bits_size = int_size_in_bytes (a68_short_bits_type);
+  HOST_WIDE_INT short_short_bits_size = int_size_in_bytes (a68_short_short_bits_type);
+
+  gcc_assert (bits_size != -1);
+  gcc_assert (short_bits_size != -1);
+  gcc_assert (short_short_bits_size != -1);
+
+  int shorths = 1;
+  if (short_short_bits_size != short_bits_size)
+    shorths++;
+  if (short_bits_size != bits_size)
+    shorths++;
+
+  return build_int_cst (CTYPE (MOID (p)), shorths);
+}
+
+tree
+a68_lower_reallengths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  HOST_WIDE_INT real_size = int_size_in_bytes (a68_real_type);
+  HOST_WIDE_INT long_real_size = int_size_in_bytes (a68_long_real_type);
+  HOST_WIDE_INT long_long_real_size = int_size_in_bytes (a68_long_long_real_type);
+
+  gcc_assert (real_size != -1);
+  gcc_assert (long_real_size != -1);
+  gcc_assert (long_long_real_size != -1);
+
+  int lengths = 1;
+  if (long_long_real_size != long_real_size)
+    lengths++;
+  if (long_real_size != real_size)
+    lengths++;
+
+  return build_int_cst (CTYPE (MOID (p)), lengths);
+}
+
+tree
+a68_lower_realshorths (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return build_int_cst (CTYPE (MOID (p)), 1);
+}
+
+tree
+a68_lower_infinity (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return build_real (CTYPE (MOID (p)), dconstinf);
+}
+
+tree
+a68_lower_minusinfinity (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return build_real (CTYPE (MOID (p)), dconstninf);
+}
+
+tree
+a68_lower_maxabschar (NODE_T *p ATTRIBUTE_UNUSED,
+		      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_char_max ();
+}
+
+tree
+a68_lower_sqrt (NODE_T *p ATTRIBUTE_UNUSED,
+		LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_sqrt (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_sqrt (NODE_T *p ATTRIBUTE_UNUSED,
+		     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_sqrt (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_sqrt (NODE_T *p ATTRIBUTE_UNUSED,
+			  LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_sqrt (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_tan (NODE_T *p ATTRIBUTE_UNUSED,
+	       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_tan (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_tan (NODE_T *p ATTRIBUTE_UNUSED,
+		    LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_tan (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_tan (NODE_T *p ATTRIBUTE_UNUSED,
+			 LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_tan (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_sin (NODE_T *p ATTRIBUTE_UNUSED,
+	       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_sin (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_sin (NODE_T *p ATTRIBUTE_UNUSED,
+		    LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_sin (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_sin (NODE_T *p ATTRIBUTE_UNUSED,
+			 LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_sin (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_cos (NODE_T *p ATTRIBUTE_UNUSED,
+	       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_cos (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_cos (NODE_T *p ATTRIBUTE_UNUSED,
+		    LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_cos (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_cos (NODE_T *p ATTRIBUTE_UNUSED,
+			 LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_cos (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_acos (NODE_T *p ATTRIBUTE_UNUSED,
+		LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_acos (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_acos (NODE_T *p ATTRIBUTE_UNUSED,
+		     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_acos (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_acos (NODE_T *p ATTRIBUTE_UNUSED,
+			  LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_acos (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_asin (NODE_T *p ATTRIBUTE_UNUSED,
+		LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_asin (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_asin (NODE_T *p ATTRIBUTE_UNUSED,
+		     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_asin (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_asin (NODE_T *p ATTRIBUTE_UNUSED,
+			  LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_asin (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_atan (NODE_T *p ATTRIBUTE_UNUSED,
+		LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_atan (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_atan (NODE_T *p ATTRIBUTE_UNUSED,
+		     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_atan (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_atan (NODE_T *p ATTRIBUTE_UNUSED,
+			  LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_atan (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_ln (NODE_T *p ATTRIBUTE_UNUSED,
+	      LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_ln (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_ln (NODE_T *p ATTRIBUTE_UNUSED,
+		   LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_ln (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_ln (NODE_T *p ATTRIBUTE_UNUSED,
+			LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_ln (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_log (NODE_T *p ATTRIBUTE_UNUSED,
+	       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_log (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_log (NODE_T *p ATTRIBUTE_UNUSED,
+		    LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_log (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_log (NODE_T *p ATTRIBUTE_UNUSED,
+			 LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_log (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_exp (NODE_T *p ATTRIBUTE_UNUSED,
+	       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_exp (a68_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_exp (NODE_T *p ATTRIBUTE_UNUSED,
+		    LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_exp (a68_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_long_long_exp (NODE_T *p ATTRIBUTE_UNUSED,
+			 LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_real_exp (a68_long_long_real_type);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_reali (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  tree t = a68_complex_i (M_COMPLEX, op1, op2);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_longreali (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  tree t = a68_complex_i (M_LONG_COMPLEX, op1, op2);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_longlongreali (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  tree t = a68_complex_i (M_LONG_LONG_COMPLEX, op1, op2);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_inti (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  tree t = a68_complex_i (M_COMPLEX,
+			  convert_to_real (a68_real_type, op1),
+			  convert_to_real (a68_real_type, op2));
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_longinti (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  tree t= a68_complex_i (M_LONG_COMPLEX,
+			 convert_to_real (a68_long_real_type, op1),
+			 convert_to_real (a68_long_real_type, op2));
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_longlonginti (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op1 = a68_lower_tree (SUB (p), ctx);
+  tree op2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+  tree t = a68_complex_i (M_LONG_LONG_COMPLEX,
+			  convert_to_real (a68_long_long_real_type, op1),
+			  convert_to_real (a68_long_long_real_type, op2));
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_re2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  tree t = a68_complex_re (op);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_im2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  tree t = a68_complex_im (op);
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+tree
+a68_lower_conj2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_complex_conj (MOID (p), op);
+}
+
+tree
+a68_lower_shortenint2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_int_shorten (MOID (p), MOID (NEXT (SUB (p))),
+			  a68_lower_tree (NEXT (SUB (p)), ctx));
+}
+
+tree
+a68_lower_lengint2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_int_leng (MOID (p), MOID (NEXT (SUB (p))),
+		       a68_lower_tree (NEXT (SUB (p)), ctx));
+}
+
+tree
+a68_lower_shortenreal2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_real_shorten (MOID (p), MOID (NEXT (SUB (p))),
+			   a68_lower_tree (NEXT (SUB (p)), ctx));
+}
+
+tree
+a68_lower_lengreal2 (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_real_leng (MOID (p), MOID (NEXT (SUB (p))),
+			a68_lower_tree (NEXT (SUB (p)), ctx));
+}
+
+tree
+a68_lower_random (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_get_libcall (A68_LIBCALL_RANDOM);
+}
+
+tree
+a68_lower_longrandom (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  /* Note we dont build a call because this will get deprocedured in case it is
+     actually called.  */
+  return a68_get_libcall (A68_LIBCALL_LONGRANDOM);
+}
+
+tree
+a68_lower_longlongrandom (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_get_libcall (A68_LIBCALL_LONGLONGRANDOM);
+}
+
+/********* POSIX prelude.  ***************/
+
+tree
+a68_lower_setexitstatus (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree t = a68_posix_setexitstatus ();
+  if (CAN_HAVE_LOCATION_P (t))
+    SET_EXPR_LOCATION (t, a68_get_node_location (p));
+  return t;
+}
+
+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_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, 0x0);
+}
+
+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, 0x3);
+}
+
+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, 0x1);
+}
+
+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, 0x2);
+}
+
+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, 0x4);
+}
+
+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_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;
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 33/47] a68: low: clauses and declarations
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (31 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 32/47] a68: low: standard prelude Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 34/47] a68: low: runtime Jose E. Marchesi
                   ` (14 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-low-clauses.cc: New file.
	* algol68/a68-low-decls.cc: Likewise.
---
 gcc/algol68/a68-low-clauses.cc | 1407 ++++++++++++++++++++++++++++++++
 gcc/algol68/a68-low-decls.cc   |  629 ++++++++++++++
 2 files changed, 2036 insertions(+)
 create mode 100644 gcc/algol68/a68-low-clauses.cc
 create mode 100644 gcc/algol68/a68-low-decls.cc

diff --git a/gcc/algol68/a68-low-clauses.cc b/gcc/algol68/a68-low-clauses.cc
new file mode 100644
index 00000000000..7ed026f7fc1
--- /dev/null
+++ b/gcc/algol68/a68-low-clauses.cc
@@ -0,0 +1,1407 @@
+/* Lower clauses to GENERIC.
+   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"
+
+/* Given a serial_clause node P, return whether it performs dynamic stack
+   allocations.
+
+   This function allocates for the fact that the bottom-up parser generates
+   successively nested serial clauses like
+
+     SERIAL_CLAUSE
+       SERIAL_CLAUSE
+        ...
+
+   the outer of which corresponds to a single serial clause in the source code,
+   but it is the inner ones annotated by the dsa pass.  */
+
+static bool
+serial_clause_dsa (NODE_T *p)
+{
+  NODE_T *s = NEXT (SUB (p));
+
+  for (s = p; SUB (s) &&  IS (s, SERIAL_CLAUSE); s = SUB (s))
+    {
+      if (DYNAMIC_STACK_ALLOCS (s))
+	return true;
+    }
+
+  return false;
+}
+
+/* Lower one or more labels.
+
+     label : defining identifier, colon symbol;
+             label, defining identifier, colon symbol;
+
+   A label lowers into a LABEL_EXPR and the declaration of a LABEL_DECL in the
+   current block and bind.  Lists of labels get returned in nested compound
+   expressions.  */
+
+tree
+a68_lower_label (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree expr = NULL_TREE;
+
+  if (IS (SUB (p), LABEL))
+    expr = a68_lower_tree (SUB (p), ctx);
+
+  NODE_T *defining_identifier;
+
+  if (IS (SUB (p), DEFINING_IDENTIFIER))
+    defining_identifier = SUB (p);
+  else
+    {
+      gcc_assert (IS (NEXT (SUB (p)), DEFINING_IDENTIFIER));
+      defining_identifier = NEXT (SUB (p));
+    }
+
+  /* Create LABEL_DECL if necessary.  */
+  tree label_decl = TAX_TREE_DECL (TAX (defining_identifier));
+  if (label_decl == NULL_TREE)
+    {
+      label_decl = build_decl (a68_get_node_location (defining_identifier),
+			       LABEL_DECL,
+			       a68_get_mangled_identifier (NSYMBOL (defining_identifier)),
+			       void_type_node);
+      TAX_TREE_DECL (TAX (defining_identifier)) = label_decl;
+    }
+
+  a68_add_decl (label_decl);
+
+  /* Return the accummulated LABEL_EXPRs.  */
+  tree label_expr = build1 (LABEL_EXPR, void_type_node, label_decl);
+  if (expr)
+    return fold_build2_loc (a68_get_node_location (p),
+			    COMPOUND_EXPR,
+			    void_type_node,
+			    expr, label_expr);
+  else
+    return label_expr;
+}
+
+/* Lower a labeled unit.
+
+     labeled unit : label, unit.
+
+   Lower the label, then the unit.  Return them in a compound expression.  */
+
+tree
+a68_lower_labeled_unit (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree label_expr = a68_lower_tree (SUB (p), ctx);
+  tree unit_expr = a68_lower_tree (NEXT (SUB (p)), ctx);
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  TREE_TYPE (unit_expr),
+			  label_expr, unit_expr);
+}
+
+/* Lower a completer.
+
+     exit_symbol
+
+   This handler replaces the last expression in stmt_list with a statement
+   assigning it to the clause result of the current serial clause, then jump to
+   the exit label of the current serial clause. Note that a completer is a
+   separator so stmt_list contains at least one expression at this point.  Note
+   that a completer can only appear inside a serial clause.
+
+   This function always returns NULL_TREE, so the traversing code shall always
+   be careful to travese on these nodes explicitly and ignore the returned
+   value.  */
+
+tree
+a68_lower_completer (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  a68_add_completer ();
+  return NULL_TREE;
+}
+
+/* Lower an initialiser series.
+
+   Parse tree:
+
+   initialiser series : serial clause, semi symbol, declaration list;
+                        initialiser series, declaration list;
+			initialiser series, semi symbol, unit;
+			initialiser series, semi symbol, labeled unit;
+			initialiser series, semi symbol, declaration list.
+
+   GENERIC:
+
+   Traverse subtree adding units and labels to STMT_LIST, and declarations to
+   BLOCK.
+
+   This function always returns NULL_TREE, so the traversing code shall always
+   be careful to travese on these nodes explicitly and ignore the returned
+   value.  */
+
+tree
+a68_lower_initialiser_series (NODE_T *p, LOW_CTX_T ctx)
+{
+  for (NODE_T *s = SUB (p); s != NO_NODE; FORWARD (s))
+    {
+      if (!IS (s, SEMI_SYMBOL))
+	a68_add_stmt (a68_lower_tree (s, ctx));
+    }
+  return NULL_TREE;
+}
+
+/* Lower a serial clause.
+
+     serial clause : labeled unit;
+                     unit;
+		     serial clause, semi symbol, unit;
+		     serial clause, exit symbol, labeled unit;
+		     serial clause, semi_symbol, declaration list;
+		     initialiser series, semi symbol, unit;
+		     initialiser series, semi symbol, labeled unit.
+
+   Ranges:
+
+     serial-clause
+     ------------- R1
+
+   See the function body to see the lowering actions.
+
+   This function always returns NULL_TREE, so the traversing code shall always
+   be careful to travese on these nodes explicitly and ignore the returned
+   value.  */
+
+tree
+a68_lower_serial_clause (NODE_T *p, LOW_CTX_T ctx)
+{
+  if (IS (SUB (p), SERIAL_CLAUSE))
+    {
+      /* Traverse down for side-effects.  */
+      (void) a68_lower_tree (SUB (p), ctx);
+
+      if (IS (NEXT (SUB (p)), EXIT_SYMBOL))
+	{
+	  /* Traverse the completer for side-effects.  This turns the last
+	     expression in the current statements list into an assignment.  */
+	  (void) a68_lower_tree (NEXT (SUB (p)), ctx);
+	  /* Now append the result of the labeled unit to the current
+	     statements list.  */
+	  a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx));
+	}
+      else
+	{
+	  /* Append the result of either the unit or the declarations list in
+	     the current statements list.  */
+	  a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx));
+	}
+    }
+  else if (IS (SUB (p), INITIALISER_SERIES))
+    {
+      /* Traverse down for side-effects.  */
+      (void) a68_lower_tree (SUB (p), ctx);
+
+      /* Append the result of either the unit or the declarations list in the
+	 current statements list.  */
+      a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx));
+    }
+  else
+    {
+      /* Append the result of either the unit or labeled unit in the current
+	 statements list.  */
+      a68_add_stmt (a68_lower_tree (SUB (p), ctx));
+    }
+
+  return NULL_TREE;
+}
+
+/* Lower a loop clause.
+
+     loop clause : for part, from part, by part, to part, while part, alt do part;
+                   for part, from part, by part, while part, alt do part;
+		   for part, from part, while part, alt do part;
+		   for part, by part, to part, while part, alt do part;
+		   for part, by part, to part, while part, alt do part;
+		   for part, by part, while part, alt do part;
+		   for part, while part, alt do part;
+		   for part, from part, by part, to part, alt do part;
+		   for part, from part, by part, alt do part;
+		   for part, from part, alt do part;
+		   for part, by part, to part, alt do part;
+		   for part, by part, alt do part;
+		   for part, to part, alt do part,
+		   for part, alt do part;
+		   from part, by part, to part, while part, alt do part;
+		   from part, by part, while aprt, alt do part;
+		   from part, to part, while aprt, alt do part;
+		   from part, while part, alt do part;
+		   from part, by part, to part, alt do part;
+		   from part, by part, alt do part;
+		   from part, to part, alt do part;
+		   from part, alt do part;
+		   by part, to part, while part, alt do part;
+		   by part, while part, alt do part;
+		   by part, to part, alt do part;
+		   by part, alt do part;
+		   to part, while part, alt do part;
+		   to part, alt do part;
+		   while part, alt do part;
+		   do part.
+*/
+
+tree
+a68_lower_loop_clause (NODE_T *p ATTRIBUTE_UNUSED,
+		       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  NODE_T *s = SUB (p);
+  bool while_part = false;
+  bool has_iterator = false;
+  tree iterator = NULL_TREE;
+  tree while_condition = NULL_TREE;
+  tree do_part = NULL_TREE;
+  tree from_part = NULL_TREE;
+  tree by_part = NULL_TREE;
+  tree to_part = NULL_TREE;
+  tree overflow = NULL_TREE;
+  NODE_T *iterator_defining_identifier = NO_NODE;
+
+  if (IS (s, FOR_PART))
+    {
+      /* Get the defining identifier.  */
+      iterator_defining_identifier = NEXT (SUB (s));
+      has_iterator = true;
+      FORWARD (s);
+    }
+
+  if (IS (s, FROM_PART))
+    {
+      /* Lower the unit.  */
+      from_part = a68_lower_tree (NEXT (SUB (s)), ctx);
+      has_iterator = true;
+      FORWARD (s);
+    }
+
+  if (IS (s, BY_PART))
+    {
+      /* Lower the unit.  */
+      by_part = a68_lower_tree (NEXT (SUB (s)), ctx);
+      has_iterator = true;
+      FORWARD (s);
+    }
+
+  if (IS (s, TO_PART))
+    {
+      /* Lower the unit.  */
+      to_part = a68_lower_tree (NEXT (SUB (s)), ctx);
+      has_iterator = true;
+      FORWARD (s);
+    }
+
+  if (has_iterator)
+    {
+      /* Introduce a range that spans until the end of the loop clause.   */
+      a68_push_range (M_VOID);
+
+      /* Compute some defaults for not specified loop parts.  Note that to_part
+	 defaults to max_int or min_int depending on the signedness of
+	 by_part.  */
+      if (from_part == NULL_TREE)
+	from_part = integer_one_node;
+      if (by_part == NULL_TREE)
+	by_part = integer_one_node;
+      if (to_part == NULL_TREE)
+	{
+	  to_part = fold_build3 (COND_EXPR,
+				 a68_bool_type,
+				 fold_build2 (LT_EXPR, a68_int_type, by_part,
+					      build_int_cst (a68_int_type, 0)),
+				 a68_int_minval (a68_int_type),
+				 a68_int_maxval (a68_int_type));
+	}
+
+      /* If the user has specified an explicit iterator in the form of a
+	 defining-identifier in a for-part, use it as the name in the iterator
+	 declaration and install the resulting declaration in the taxes table
+	 in order for applied identifiers in the rest of the loop to find it.
+	 Otherwise, the iterator is not directly accessible by the
+	 programmer.  */
+      const char *iterator_name = (iterator_defining_identifier == NO_NODE
+				   ? "iterator%"
+				   : NSYMBOL (iterator_defining_identifier));
+      iterator = a68_lower_tmpvar (iterator_name, a68_int_type, from_part);
+      if (iterator_defining_identifier != NO_NODE)
+	TAX_TREE_DECL (TAX (iterator_defining_identifier)) = iterator;
+
+      /* The from_part and to_part expressions shall be evaluated once and once
+	 only.  The expression for from_part is evaluated only once in the
+	 initialization expression for iterator% above, but we need to put
+	 to_part in a temporary since it is used in the loop body.  */
+      to_part = a68_lower_tmpvar ("to_part%", TREE_TYPE (to_part), to_part);
+
+      /* We need to detect overflow/underflow of the iterator.  */
+      overflow = a68_lower_tmpvar ("overflow%", boolean_type_node,
+				   boolean_false_node);
+    }
+
+  if (IS (s, WHILE_PART))
+    {
+      while_part = true;
+      /* Introduce a range that spans until the end of the loop clause.  */
+      a68_push_range (M_VOID);
+      /* Process the enquiry clause, which yields a BOOL.  */
+      a68_push_stmt_list (M_BOOL);
+      (void) a68_lower_tree (NEXT (SUB (s)), ctx);
+      while_condition = a68_pop_stmt_list ();
+      FORWARD (s);
+    }
+
+  /* DO part.  */
+  gcc_assert (IS (s, ALT_DO_PART) || IS (s, DO_PART));
+
+  /* Build the loop's body.  */
+  a68_push_range (NULL);
+  {
+    /* First lower the loop exit condition.  */
+    if (has_iterator || while_part)
+      {
+	tree exit_condition = NULL_TREE;
+	/* IF overflow OREL (by_part < 0 THEN iterator < to_part ELSE iterator > to_part) FI */
+	if (has_iterator)
+	  exit_condition = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node,
+					overflow,
+					fold_build3 (COND_EXPR,
+						     a68_bool_type,
+						     fold_build2 (LT_EXPR, a68_int_type, by_part,
+								  build_int_cst (a68_int_type, 0)),
+						     fold_build2 (LT_EXPR, a68_int_type,
+								  iterator, to_part),
+						     fold_build2 (GT_EXPR, a68_int_type,
+								  iterator, to_part)));
+	/* NOT while_condition */
+	if (while_part)
+	  {
+	    tree while_exit_condition = fold_build1 (TRUTH_NOT_EXPR,
+						     a68_bool_type,
+						     while_condition);
+	    if (has_iterator)
+	      exit_condition = fold_build2 (TRUTH_ORIF_EXPR, a68_bool_type,
+					    exit_condition, while_exit_condition);
+	    else
+	      exit_condition = while_exit_condition;
+	  }
+
+	if (exit_condition != NULL_TREE)
+	  a68_add_stmt (fold_build1 (EXIT_EXPR, void_type_node, exit_condition));
+      }
+
+    /* Serial clauses in DO .. OD do not yield any value.  */
+    bool dsa = serial_clause_dsa (NEXT (SUB (s)));
+    bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE;
+    a68_push_serial_clause_range (M_VOID, dsa && local);
+    (void) a68_lower_tree (NEXT (SUB (s)), ctx);
+    do_part = a68_pop_serial_clause_range ();
+    a68_add_stmt (do_part);
+
+    if (has_iterator)
+      {
+	/* Increment the iterator by BY_PART.  Detect overflow.
+	   Given a + b = sum, overflows = ((~((a) ^ (b)) & ((a) ^ (sum))) < 0)
+	   See OVERFLOW_SUM_SIGN in double-int.cc for an explanation
+	   of this formula.
+	*/
+	tree type = TREE_TYPE (iterator);
+	tree a = iterator;
+	tree b = save_expr (by_part);
+	tree sum = fold_build2 (PLUS_EXPR, type, a, b);
+	a68_add_stmt (fold_build2 (MODIFY_EXPR, boolean_type_node,
+				   overflow,
+				   fold_build2 (LT_EXPR, boolean_type_node,
+						fold_build2 (BIT_AND_EXPR, type,
+							     fold_build1 (BIT_NOT_EXPR, type,
+									  fold_build2 (BIT_XOR_EXPR, type,
+										       a, b)),
+							     fold_build2 (BIT_XOR_EXPR, type,
+									  a, sum)),
+						build_int_cst (a68_int_type, 0))));
+	a68_add_stmt (fold_build2 (MODIFY_EXPR, type, iterator, sum));
+      }
+  }
+  tree loop_body = a68_pop_range ();
+
+  /* Finally build the LOOP_EXPR and exit the introduced ranges.  */
+  tree loop_clause = fold_build1_loc (a68_get_node_location (p),
+				      LOOP_EXPR, a68_void_type, loop_body);
+  if (while_part)
+    {
+      a68_add_stmt (loop_clause);
+      loop_clause = a68_pop_range ();
+    }
+  if (has_iterator)
+    {
+      a68_add_stmt (loop_clause);
+      loop_clause = a68_pop_range ();
+    }
+
+  return loop_clause;
+}
+
+/* Lower a conformity clause.
+
+     conformity clause : case part, conformity in part, out part, esac symbol;
+                         case part, conformity in part, esac symbol;
+			 case part, conformity in part, conformity ouse part;
+                         open part, conformity choice, choice, close symbol;
+                         open part, conformity choice, close symbol;
+			 open part, conformity choice, brief conformity ouse part.
+
+     conformity choice : then bar symbol, specified unit list;
+                         then bar symbol, specified unit.
+
+     specified unit list : specified unit list, comma symbol, specified unit;
+                           specified unit list, specified unit.
+
+     specified unit : specifier, colon symbol, unit.
+
+     specifier : open symbol, declarer, identifier, close symbol;
+                 open symbol, declarer, close symbol;
+		 open symbol, void symbol, close symbol.
+*/
+
+static void
+lower_unite_case_unit (NODE_T *p,
+		       tree enquiry, MOID_T *enquiry_mode,
+		       tree result, tree exit_label, LOW_CTX_T ctx)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, SPECIFIER))
+	{
+	  MOID_T *spec_moid = MOID (NEXT (SUB (p)));
+	  NODE_T *spec_identifier = NEXT (NEXT (SUB (p)));
+	  NODE_T *spec_unit = NEXT (NEXT (p));
+	  const char *specifier_identifier_name = NULL;
+	  if (IS (spec_identifier, IDENTIFIER))
+	    specifier_identifier_name = NSYMBOL (spec_identifier);
+
+	  tree overhead = a68_union_overhead (enquiry);
+	  tree spec_value = NULL_TREE;
+	  tree entry_selected = NULL_TREE;
+	  if (IS_UNION (spec_moid))
+	    {
+	      /* The spec_moid is an united mode, which must be unitable to the
+		 enquiry_mode.  */
+	      gcc_assert (a68_is_unitable (spec_moid, enquiry_mode,
+					   SAFE_DEFLEXING));
+
+	      /* Build the entry_selected expression.
+
+		 For each mode in spec_moid, determine the corresponding index
+		 in enquiry_mode and add a check for it to the expression.  */
+	      for (PACK_T *pack = PACK (spec_moid); pack != NO_PACK; FORWARD (pack))
+		{
+		  int index = a68_united_mode_index (enquiry_mode, MOID (pack));
+		  tree expr = fold_build2 (EQ_EXPR,
+					   boolean_type_node,
+					   overhead,
+					   build_int_cst (TREE_TYPE (overhead), index));
+		  if (entry_selected == NULL_TREE)
+		    entry_selected = expr;
+		  else
+		    entry_selected = fold_build2 (TRUTH_OR_EXPR,
+						  boolean_type_node,
+						  entry_selected,
+						  expr);
+		}
+
+	      /* The spec_value is an union of mode spec_moid, with the
+		 overhead translated from enquiry_mode.  */
+	      tree spec_overhead
+		= a68_union_translate_overhead (enquiry_mode, overhead, spec_moid);
+	      a68_push_range (spec_moid);
+	      spec_value = a68_lower_tmpvar ("spec_value%",
+					     CTYPE (spec_moid),
+					     a68_get_skip_tree (spec_moid));
+	      a68_add_stmt (a68_union_set_overhead (spec_value, spec_overhead));
+	      tree from_cunion = a68_union_cunion (enquiry);
+	      tree to_cunion = a68_union_cunion (spec_value);
+	      a68_add_stmt (a68_lower_memcpy (fold_build1 (ADDR_EXPR,
+							   build_pointer_type (TREE_TYPE (to_cunion)),
+							   to_cunion),
+					      fold_build1 (ADDR_EXPR,
+							   build_pointer_type (TREE_TYPE (from_cunion)),
+							   from_cunion),
+					      size_in_bytes (TREE_TYPE (to_cunion))));
+	      a68_add_stmt (spec_value);
+	      spec_value = a68_pop_range ();
+	    }
+	  else
+	    {
+	      int index = a68_united_mode_index (enquiry_mode, spec_moid);
+	      spec_value = a68_union_alternative (enquiry, index);
+	      entry_selected = fold_build2 (EQ_EXPR,
+					    TREE_TYPE (overhead),
+					    overhead,
+					    build_int_cst (TREE_TYPE (overhead), index));
+	    }
+
+	  a68_push_range (M_VOID);
+	  {
+	    /* If the enquiry value is ascribed to an identifier in the case
+	       entry then create a suitable declaration and turn the identifier
+	       into a defining identifier.  */
+	    if (specifier_identifier_name)
+	      {
+		tree united_value = a68_lower_tmpvar (specifier_identifier_name,
+						      CTYPE (spec_moid), spec_value);
+		TAX_TREE_DECL (TAX (spec_identifier)) = united_value;
+	      }
+
+	    /* Set result% to the lowering of the unit and jump to the end of
+	       the enquiry clause.  */
+	    a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
+				       result, a68_lower_tree (spec_unit, ctx)));
+	    a68_add_stmt (fold_build1 (GOTO_EXPR,
+				       void_type_node,
+				       exit_label));
+	    a68_add_stmt (a68_get_skip_tree (M_VOID));
+	  }
+	  tree process_entry = a68_pop_range ();
+
+	  /* IF index = overhead THEN process entry FI */
+	  a68_add_stmt (fold_build3 (COND_EXPR,
+				     a68_void_type,
+				     entry_selected,
+				     process_entry,
+				     a68_get_skip_tree (M_VOID)));
+
+	  FORWARD (p); /* Skip specifier.  */
+	  FORWARD (p); /* Skip unit.  */
+	  /* The unit is skipped in the for loop post-action.  */
+	}
+      else
+	lower_unite_case_unit (SUB (p),
+			       enquiry, enquiry_mode,
+			       result, exit_label, ctx);
+    }
+}
+
+tree
+a68_lower_conformity_clause (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *conformity_clause_mode = MOID (p);
+
+  /* CASE or OUSE.  */
+  NODE_T *s = SUB (p);
+  NODE_T *enquiry_node = NEXT (SUB (s));
+  MOID_T *enquiry_mode = MOID (SUB (s));
+
+  /* Push a binding environment for the enquiry clause.  */
+  a68_push_range (conformity_clause_mode);
+
+  /* Process the enquiry clause and put the resulting value in enquiry%.  */
+  a68_push_stmt_list (enquiry_mode);
+  (void) a68_lower_tree (enquiry_node, ctx);
+  tree enquiry = a68_lower_tmpvar ("enquiry%",
+				   CTYPE (enquiry_mode),
+				   a68_pop_stmt_list ());
+
+  /* Create a decl for result%.  */
+  tree result = a68_lower_tmpvar ("result%",
+				  CTYPE (conformity_clause_mode),
+				  a68_get_skip_tree (conformity_clause_mode));
+
+  /* Create an exit label.  */
+  tree exit_label = build_decl (UNKNOWN_LOCATION,
+				LABEL_DECL,
+				get_identifier ("exit_label%"),
+				void_type_node);
+  DECL_CONTEXT (exit_label) = a68_range_context ();
+  a68_add_decl (exit_label);
+  a68_add_decl_expr (fold_build1 (DECL_EXPR, TREE_TYPE (exit_label), exit_label));
+
+  /* IN.  */
+  FORWARD (s);
+  lower_unite_case_unit (NEXT (SUB (s)),
+			 enquiry, enquiry_mode,
+			 result, exit_label, ctx);
+
+  /* OUT.  */
+  FORWARD (s);
+  switch (ATTRIBUTE (s))
+    {
+    case CHOICE:
+    case OUT_PART:
+      {
+	bool dsa = serial_clause_dsa (NEXT (SUB (s)));
+	bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE;
+	a68_push_serial_clause_range (conformity_clause_mode, dsa && local);
+
+	(void) a68_lower_tree (NEXT (SUB (s)), ctx);
+	a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
+				   result, a68_pop_serial_clause_range ()));
+	a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label));
+	break;
+      }
+    case CLOSE_SYMBOL:
+    case ESAC_SYMBOL:
+      a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				 TREE_TYPE (result),
+				 result,
+				 a68_get_skip_tree (conformity_clause_mode)));
+      a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label));
+      break;
+    default:
+      /* Recurse.
+
+	 Note that the parser guarantees that the embedded CASE clause is a
+	 conformity clause, and that its mode is the same than the containing
+	 clause, but it doesn't annotate the mode in the tree node so we have
+	 to do it here.  */
+      MOID (s) = conformity_clause_mode;
+      a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				 TREE_TYPE (result),
+				 result,
+				 a68_lower_conformity_clause (s, ctx)));
+      a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label));
+      break;
+    }
+
+  /* ESAC */
+  a68_add_stmt (build1 (LABEL_EXPR, void_type_node, exit_label));
+  a68_add_stmt (result);
+  return a68_pop_range ();
+}
+
+/* Lower a case clause.
+
+     case clause : open part, case choice clause, choice, close symbol;
+                   open part, case choice clause, close symbol;
+		   open part, case shoice clause, brief ouse part;
+		   case part, case in part, out part, esac symbol;
+		   case part, case in part, esac symbol;
+		   case part, case in part, case ouse part;
+*/
+
+static void
+lower_int_case_unit (NODE_T *p,
+		     tree enquiry, MOID_T *enquiry_mode,
+		     tree result, tree exit_label, int *count,
+		     LOW_CTX_T ctx)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, UNIT))
+	{
+	  a68_push_range (M_VOID);
+	  {
+	    /* Set result% to the lowering of the unit and jump to the end of
+	       the enquiry clause.  */
+	    a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
+				       result, a68_lower_tree (p, ctx)));
+	    a68_add_stmt (fold_build1 (GOTO_EXPR,
+				       void_type_node,
+				       exit_label));
+	    a68_add_stmt (a68_get_skip_tree (M_VOID));
+	  }
+	  tree process_entry = a68_pop_range ();
+
+	  /* IF count = enquiry THEN process entry FI */
+	  a68_add_stmt (fold_build3 (COND_EXPR,
+				     a68_void_type,
+				     fold_build2 (EQ_EXPR,
+						  TREE_TYPE (enquiry),
+						  enquiry,
+						  build_int_cst (TREE_TYPE (enquiry), *count)),
+				     process_entry,
+				     a68_get_skip_tree (M_VOID)));
+	  *count += 1;
+	}
+      else
+	lower_int_case_unit (SUB (p),
+			     enquiry, enquiry_mode,
+			     result, exit_label, count, ctx);
+    }
+}
+
+tree
+a68_lower_case_clause (NODE_T *p ATTRIBUTE_UNUSED,
+		       LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  MOID_T *case_clause_mode = MOID (p);
+
+  /* CASE or OUSE  */
+  NODE_T *s = SUB (p);
+  NODE_T *enquiry_node = NEXT (SUB (s));
+  MOID_T *enquiry_mode = M_INT;
+
+  /* Push a bingding environment fo the case clause.  */
+  a68_push_range (case_clause_mode);
+
+  /* Process the enquiry clause and put the result value in enquiry%.  */
+  a68_push_stmt_list (enquiry_mode);
+  (void) a68_lower_tree (enquiry_node, ctx);
+  tree enquiry = a68_lower_tmpvar ("enquiry%",
+				   CTYPE (enquiry_mode),
+				   a68_pop_stmt_list ());
+  /* Create a decl for result%.  */
+  tree result = a68_lower_tmpvar ("result%",
+				  CTYPE (case_clause_mode),
+				  a68_get_skip_tree (case_clause_mode));
+
+  /* Create an exit label.  */
+  tree exit_label = build_decl (UNKNOWN_LOCATION,
+				LABEL_DECL,
+				get_identifier ("exit_label%"),
+				void_type_node);
+  DECL_CONTEXT (exit_label) = a68_range_context ();
+  a68_add_decl (exit_label);
+  a68_add_decl_expr (fold_build1 (DECL_EXPR, TREE_TYPE (exit_label), exit_label));
+
+  /* IN.  */
+  FORWARD (s);
+  int count = 1;
+  lower_int_case_unit (NEXT (SUB (s)),
+		       enquiry, enquiry_mode,
+		       result, exit_label, &count, ctx);
+
+  /* OUT.  */
+  FORWARD (s);
+  switch (ATTRIBUTE (s))
+    {
+    case CHOICE:
+    case OUT_PART:
+      {
+	bool dsa = serial_clause_dsa (NEXT (SUB (s)));
+	bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE;
+	a68_push_serial_clause_range (case_clause_mode, dsa && local);
+
+	(void) a68_lower_tree (NEXT (SUB (s)), ctx);
+	a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
+				   result, a68_pop_serial_clause_range ()));
+	a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label));
+	break;
+      }
+    case CLOSE_SYMBOL:
+    case ESAC_SYMBOL:
+      a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				 TREE_TYPE (result),
+				 result,
+				 a68_get_skip_tree (case_clause_mode)));
+      a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label));
+      break;
+    default:
+      /* Recurse.
+
+	 Note that the parser guarantees that the embedded CASE clause has the
+	 same mode than the containing clause, but it doesn't annotate the OUSE
+	 node with its mode so we have to do it here.  */
+      MOID (s) = case_clause_mode;
+      a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				 TREE_TYPE (result),
+				 result,
+				 a68_lower_case_clause (s, ctx)));
+      a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, exit_label));
+      break;
+    }
+
+  /* ESAC */
+  a68_add_stmt (build1 (LABEL_EXPR, void_type_node, exit_label));
+  a68_add_stmt (result);
+  return a68_pop_range ();
+}
+
+/* Lower an enquiry clause.
+
+     enquiry clause : unit;
+                      enquiry clause, semi symbol, unit;
+                      enquiry clause, comma symbol, unit;
+		      initialiser series, semi symbol, unit.
+
+   The units and declarations in the enquiry clause get lowered into
+   expressions and declaration nodes which are added to the current serial
+   clause.
+
+   This function always returns NULL_TREE, so the traversing code shall always
+   be careful to travese on these nodes explicitly and ignore the returned
+   value.  */
+
+tree
+a68_lower_enquiry_clause (NODE_T *p, LOW_CTX_T ctx)
+{
+  if (IS (SUB (p), UNIT))
+    {
+      a68_add_stmt (a68_lower_tree (SUB (p), ctx));
+    }
+  else if (IS (SUB (p), ENQUIRY_CLAUSE))
+    {
+      (void) a68_lower_tree (SUB (p), ctx);
+      gcc_assert (IS (NEXT (NEXT (SUB (p))), UNIT));
+      a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx));
+    }
+  else
+    {
+      gcc_assert (IS (SUB (p), INITIALISER_SERIES));
+      gcc_assert (IS (NEXT (NEXT (SUB (p))), UNIT));
+      (void) a68_lower_tree (SUB (p), ctx);
+      a68_add_stmt (a68_lower_tree (NEXT (NEXT (SUB (p))), ctx));
+    }
+
+  return NULL_TREE;
+}
+
+/* Lower a conditional clause.
+
+     conditional clause : open part, choice, choice, close symbol;
+                          open part, choice, close symbol;
+			  open part, choice, brief elif part;
+			  if part, then part, else part, fi symbol;
+			  if part, then part, elif part;
+			  if part, then part, fi symbol.
+
+     if part : if symbol, enquiry clause;
+               if symbol, initialiser series.
+
+     then part : then symbol, serial clause;
+                 then symbol, initialiser series.
+
+     elif part : elif if part, then part, else part, fi symbol;
+                 elif if part, then part, fi symbol;
+		 elif if part, then part, elif part.
+
+     else part : else symbol, serial clause;
+                 else symbol, initialiser series.
+
+     elif if part : elif symbol, enquiry clause.
+
+     open part : open symbol, enquiry clause.
+
+     choice : then bar symbol, serial clause;
+              then bar symbol initialiser series.
+
+     brief elif part : else open part, choice, choice, close symbol;
+                       else open part, choice, close symbol;
+		       else open part, choice, bief elif part.
+
+     else open part : else bar symbol, enquiry clause;
+                      else bar symbol, initialiser series.
+
+   Ranges:
+
+     IF enquiry-clause THEN expr ELSE expr FI
+                            --- R2    ---- R3
+     ---------------------------------------- R1
+
+   The conditional clause lowers into:
+
+     BIND_EXPR
+       BIND_EXPR_VARS -> delcls in enquiry clause.
+       BIND_EXPR_BODY
+         STMT_LIST
+           enquiry% = ...;
+           COND_EXPR (enquiry%, then_expr, else_expr)  */
+
+tree
+a68_lower_conditional_clause (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree then_expr = NULL_TREE;
+  tree else_expr = NULL_TREE;
+
+  MOID_T *conditional_clause_mode = MOID (p);
+  MOID_T *effective_rows_mode = NO_MOID;
+  bool is_rows = false;
+
+  /* Push a binding environment for the conditional.  */
+  a68_push_range (is_rows ? effective_rows_mode : conditional_clause_mode);
+
+  /* Create a decl for %enquiry and add it to the bind's declaration chain.  */
+  tree enquiry_decl = build_decl (UNKNOWN_LOCATION,
+				  VAR_DECL,
+				  NULL, /* Set below.  */
+				  a68_bool_type);
+  char *enquiry_name = xasprintf ("enquiry%d%%", DECL_UID(enquiry_decl));
+  DECL_NAME (enquiry_decl) = get_identifier (enquiry_name);
+  free (enquiry_name);
+  DECL_INITIAL (enquiry_decl) = a68_get_skip_tree (M_BOOL);
+  a68_add_decl (enquiry_decl);
+
+  /* Add a DECL_EXPR for enquiry_decl%  */
+  a68_add_stmt (fold_build1 (DECL_EXPR, a68_bool_type, enquiry_decl));
+
+  /* IF or ELIF part.  */
+  NODE_T *s = SUB (p);
+
+  /* Process the enquiry clause.  */
+  (void) a68_lower_tree (NEXT (SUB (s)), ctx);
+
+  /* Assignation enquiry% = .. expr ..
+     Note that since no completers are allowed in enquiry clauses,
+     the last statement in the statement list has to be the unit
+     yielding the boolean value.  */
+  tree_stmt_iterator si = tsi_last (a68_range_stmt_list ());
+  gcc_assert (TREE_TYPE (tsi_stmt (si)) != void_type_node);
+  a68_add_stmt (fold_build2 (MODIFY_EXPR, a68_bool_type, enquiry_decl, tsi_stmt (si)));
+  tsi_delink (&si);
+
+  /* THEN part.  */
+  FORWARD (s);
+  bool dsa = serial_clause_dsa (NEXT (SUB (s)));
+  bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE;
+  a68_push_serial_clause_range (is_rows ? effective_rows_mode : conditional_clause_mode,
+				dsa && local);
+  (void) a68_lower_tree (NEXT (SUB (s)), ctx);
+  then_expr = a68_pop_serial_clause_range ();
+
+  /* ELSE part  */
+  FORWARD (s);
+  switch (ATTRIBUTE (s))
+    {
+    case CHOICE:
+    case ELSE_PART:
+      {
+	bool dsa = serial_clause_dsa (NEXT (SUB (s)));
+	bool local = NON_LOCAL (NEXT (SUB (s))) == NO_TABLE;
+	a68_push_serial_clause_range (is_rows ? effective_rows_mode : conditional_clause_mode,
+				      dsa && local);
+	(void) a68_lower_tree (NEXT (SUB (s)), ctx);
+	else_expr = a68_pop_serial_clause_range ();
+	break;
+      }
+    case CLOSE_SYMBOL:
+    case FI_SYMBOL:
+      {
+	else_expr = a68_get_skip_tree (is_rows ? effective_rows_mode : conditional_clause_mode);
+	break;
+      }
+    default:
+      {
+	/* ELIF part.  Recurse.  */
+	MOID (s) = conditional_clause_mode;
+	else_expr = a68_lower_conditional_clause (s, ctx);
+      }
+    }
+
+  /* Build the conditional clause's COND_EXPR.  */
+  a68_add_stmt (fold_build3_loc (a68_get_node_location (p),
+				 COND_EXPR,
+				 CTYPE (is_rows ? effective_rows_mode : conditional_clause_mode),
+				 enquiry_decl,
+				 then_expr, else_expr));
+
+  return a68_pop_range ();
+}
+
+/* Lower a comma separated list of zero, two, or more units
+
+     unit list : unit list, comma symbol, unit;
+                 unit list, unit.
+
+   The list of units lowers into appending the units into the current
+   statements list.
+
+   This function always returns NULL_TREE, so the traversing code shall always
+   be careful to traverse on these nodes explicitly and ignore the returned
+   value.  */
+
+tree
+a68_lower_unit_list (NODE_T *p, LOW_CTX_T ctx)
+{
+  if (IS (SUB (p), UNIT_LIST))
+    (void) a68_lower_tree (SUB (p), ctx);
+
+  for (NODE_T *s = SUB (p); s != NO_NODE; FORWARD (s))
+    {
+      if (IS (s, UNIT))
+	a68_add_stmt (a68_lower_tree (s, ctx));
+    }
+
+  return NULL_TREE;
+}
+
+/* Lower a collateral clause.
+
+     collateral clause : open symbol, unit list, close symbol;
+                         open symbol, close symbol;
+                         begin symbol, unit list, end symbol;
+			 begin symbol, end symbol.
+
+   An empty collateral clause lowers into EMPTY.  */
+
+tree
+a68_lower_collateral_clause (NODE_T *p ATTRIBUTE_UNUSED,
+			     LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  bool clause_is_empty = (ATTRIBUTE (NEXT (SUB (p))) != UNIT_LIST);
+  MOID_T *mode = MOID (p);
+
+  /* Lower the constituent units into a statements list.  */
+  a68_push_stmt_list (mode);
+  if (!clause_is_empty)
+    (void) a68_lower_tree (NEXT (SUB (p)), ctx);
+  tree units = a68_pop_stmt_list ();
+
+  /* The collateral clause lowers to different constructions depending on its
+     nature.  */
+  if (mode == M_VOID)
+    {
+      /* A VOID-collateral-clause lowers into a STMT_LIST containing all
+	 the units.  Since there cannot be declarations in a collateral
+	 clause, there is no need to introduce a new binding scope.  Note
+	 that for now we are not really elaborating collaterally, but
+	 sequentially.  */
+      return units;
+    }
+  else if (IS_FLEXETY_ROW (mode) || mode == M_STRING)
+    {
+      if (mode == M_STRING)
+	mode = M_FLEX_ROW_CHAR;
+
+      /* This is a row display.  It lowers to a multiple.  */
+      tree row_type = CTYPE (mode);
+      size_t dim = DIM (DEFLEX (mode));
+
+      if (clause_is_empty)
+	{
+	  /* The clause is empty.  This lowers into a multiple with DIM
+	     dimension, each dimension having bounds of 1:0, and no
+	     elements.  */
+	  tree element_pointer_type = a68_row_elements_pointer_type (row_type);
+	  tree multiple_elements = build_int_cst (element_pointer_type, 0);
+	  tree multiple_elements_size = size_zero_node;
+
+	  tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+	  tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+	  tree ssize_one_node = fold_convert (ssizetype, size_one_node);
+	  tree ssize_zero_node = fold_convert (ssizetype, size_zero_node);
+	  for (size_t d = 0; d < dim; ++d)
+	    {
+	      lower_bounds[d] = ssize_one_node;
+	      upper_bounds[d] = ssize_zero_node;
+	    }
+
+	  tree row = a68_row_value (row_type, dim,
+				    multiple_elements,
+				    multiple_elements_size,
+				    lower_bounds, upper_bounds);
+	  TREE_CONSTANT (row) = 1;
+	  free (lower_bounds);
+	  free (upper_bounds);
+	  return row;
+	}
+
+      if (dim == 1)
+	{
+	  /* Create a constructor with the multiple's elements.  */
+	  vec <constructor_elt, va_gc> *ve = NULL;
+	  int num_units = 0;
+	  for (tree_stmt_iterator si = tsi_start (units); !tsi_end_p (si); tsi_next (&si))
+	    {
+	      tree unit = tsi_stmt (si);
+	      if (A68_TYPE_HAS_ROWS_P (TREE_TYPE (unit)))
+		unit = a68_low_dup (unit);
+	      CONSTRUCTOR_APPEND_ELT (ve, size_int (num_units), unit);
+	      num_units += 1;
+	    }
+
+	  tree element_pointer_type = a68_row_elements_pointer_type (row_type);
+	  tree array_constructor_type = build_array_type (TREE_TYPE (element_pointer_type),
+							  build_index_type (size_int (num_units - 1)));
+	  tree array_constructor = build_constructor (array_constructor_type, ve);
+	  tree multiple_elements = fold_build1 (ADDR_EXPR,
+						element_pointer_type,
+						array_constructor);
+	  tree elements_type = TREE_TYPE (element_pointer_type);
+	  tree multiple_elements_size = fold_build2 (MULT_EXPR, sizetype,
+						     size_int (num_units),
+						     size_in_bytes (elements_type));
+	  tree lower_bound = fold_convert (ssizetype, size_one_node);
+	  tree upper_bound = ssize_int (num_units);
+	  tree row = a68_row_value (row_type, dim,
+				    multiple_elements,
+				    multiple_elements_size,
+				    &lower_bound, &upper_bound);
+	  return row;
+	}
+      else
+	{
+	  gcc_assert (dim > 1);
+
+	  /* The units in the collateral clause are multiples, whose elements
+	     are to be copied consecutively in a new multiple.  The descriptor
+	     of this multiple is constructed as follows:
+
+	     The first dimension is:
+
+	     - The lower bound is 1.
+	     - The upper bound is the number of sub-multiples processed
+	       here.
+             - The stride is the number of elements in each sub-multiple
+	       multiplied by the element size.
+
+	     Subsequent dimensions are taken from the first inner multiple.
+	     All descriptors of the inner multiples shall be equal.  This is
+	     checked at run-time, and in case of discrepancy a run-time error
+	     is emitted.
+
+             Let's see an example.  Suppose in the stmt-list we have:
+
+               (1, 2, 3)
+                 {triplets: {lb: 1 ub: 3 stride: 1S} elements: {1, 2, 3}}
+               (4, 5, 6)
+                 {triplets: {lb: 1 ub: 3 stride: 1S} elements: {4, 5, 6}}
+
+             The resulting multiple would be:
+
+               ((1, 2, 3), (4, 5, 6))
+                 {triplets: {{lb: 1 ub: 2 stride: 3S}, {lb: 1 ub: 3 stride: 1S}}
+                  elements: {1, 2, 3, 4, 5, 6}}  */
+
+	  tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+	  tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+	  size_t num_units = 0;
+
+	  for (tree_stmt_iterator si = tsi_start (units); !tsi_end_p (si); tsi_next (&si))
+	    num_units++;
+
+	  a68_push_range (mode);
+
+	  /* Process each sub-multiple.  The first sub-multiple establishes the
+	     bounds that all subsequent sub-multiples shall match.  */
+	  tree multiple_elements = NULL_TREE;
+	  tree multiple_elements_size = NULL_TREE;
+	  tree sub_multiple = NULL_TREE;
+	  //	  tree sub_multiple_lb = NULL_TREE;
+	  //	  tree sub_multiple_ub = NULL_TREE;
+	  //	  tree sub_multiple_stride = NULL_TREE;
+	  tree index = a68_lower_tmpvar ("index%", sizetype, size_zero_node);
+	  for (tree_stmt_iterator si = tsi_start (units); !tsi_end_p (si); tsi_next (&si))
+	    {
+	      if (sub_multiple == NULL)
+		sub_multiple = a68_lower_tmpvar ("sub_multiple%",
+						 TREE_TYPE (tsi_stmt (si)),
+						 tsi_stmt (si));
+	      else
+		a68_add_stmt (fold_build2 (MODIFY_EXPR,
+					   TREE_TYPE (tsi_stmt (si)),
+					   sub_multiple,
+					   tsi_stmt (si)));
+
+	      if (si == tsi_start (units))
+		{
+#if 0
+		  tree ssize_zero_node = fold_convert (ssizetype, size_zero_node);
+		  /* The first sub-multiple establishes the bounds that all
+		     subsequent sub-multiples shall match.  */
+		  sub_multiple_lb = a68_lower_tmpvar ("sub_multiple_lb%",
+						      ssizetype,
+						      a68_multiple_lower_bound (sub_multiple,
+										ssize_zero_node));
+		  sub_multiple_ub = a68_lower_tmpvar ("sub_multiple_ub%",
+						      ssizetype,
+						      a68_multiple_upper_bound (sub_multiple,
+										ssize_zero_node));
+		  sub_multiple_stride = a68_lower_tmpvar ("sub_multiple_stride%",
+							  sizetype,
+							  a68_multiple_stride (sub_multiple,
+									       size_zero_node));
+#endif
+		  /* Now we have enough information to calculate the size of
+		     the elements of the new multiple and allocate
+		     multiple_elements.  */
+		  tree sub_multiple_elements = a68_multiple_elements (sub_multiple);
+		  tree elements_pointer_type = TREE_TYPE (sub_multiple_elements);
+		  tree elements_type = TREE_TYPE (elements_pointer_type);
+		  multiple_elements_size = fold_build2 (MULT_EXPR, sizetype,
+							     size_int (num_units),
+							     size_in_bytes (elements_type));
+		  multiple_elements_size = fold_build2 (MULT_EXPR, sizetype,
+							multiple_elements_size,
+							a68_multiple_num_elems (sub_multiple));
+		  multiple_elements = a68_lower_tmpvar ("multiple_elements%",
+							elements_pointer_type,
+							a68_lower_alloca (elements_type,
+									  multiple_elements_size));
+
+		  /* We can also now calculate the bounds of the new multiple.
+		     The top-level triplet has lower bound 1, upper bound is
+		     num_units, and stride is the number of elements in each
+		     sub-multiple multiplied by the element size.  Bounds for
+		     the subsequent DIM-1 dimensions are copied from the
+		     sub-multiple's descriptor.  */
+		  lower_bounds[0] = fold_convert (ssizetype, size_one_node);
+		  upper_bounds[0] = ssize_int (num_units);
+		  for (size_t d = 1; d < dim; ++d)
+		    {
+		      lower_bounds[d] = a68_multiple_lower_bound (sub_multiple,
+								  ssize_int (d - 1));
+		      upper_bounds[d] = a68_multiple_upper_bound (sub_multiple,
+								  ssize_int (d - 1));
+		    }
+		}
+	      else
+		{
+		  /* Check bounds of this sub-multiple.  Note that this is
+		     always done at run-time, since the interpretation of a row
+		     display depens on the target type, whether it is a row row
+		     or a row of rows, for example.  */
+		  // XXX use sub_multiple_lb, sub_multiple_ub and sub_multiple_stride
+		}
+
+	      /* Copy the elements of a copy of the sub-multiple in the
+		 elements of the multiple.  */
+	      tree sub_multiple_elements = a68_multiple_elements (sub_multiple);
+	      // XXX should we make a copy of the sub_multiple_elements here?
+	      // We DO need to iterate slicing, because of strides: if
+	      // the sub_multiple is a trimmer.
+	      sub_multiple_elements = sub_multiple_elements;
+	      tree sub_multiple_elements_type = TREE_TYPE (sub_multiple_elements);
+	      tree sub_multiple_num_elems = a68_multiple_num_elems (sub_multiple);
+	      tree sub_multiple_element_type = TREE_TYPE (sub_multiple_elements_type);
+	      tree sub_multiple_elements_size = fold_build2 (MULT_EXPR, sizetype,
+							     sub_multiple_num_elems,
+							     size_in_bytes (sub_multiple_element_type));
+
+	      /* memcpy (multiple_elements[index], sub_multiple_elements)  */
+	      a68_add_stmt (a68_lower_memcpy (fold_build2 (POINTER_PLUS_EXPR,
+							   sub_multiple_elements_type,
+							   multiple_elements,
+							   index),
+					      sub_multiple_elements,
+					      sub_multiple_elements_size));
+	      /* index += sub_multiple_elements_size */
+	      a68_add_stmt (fold_build2 (MODIFY_EXPR, sizetype,
+					 index,
+					 fold_build2 (PLUS_EXPR, sizetype,
+						      index, sub_multiple_elements_size)));
+	    }
+
+	  tree multiple = a68_lower_tmpvar ("multiple%",
+					    row_type,
+					    a68_row_value (row_type, dim,
+							   multiple_elements,
+							   multiple_elements_size,
+							   lower_bounds, upper_bounds));
+	  free (lower_bounds);
+	  free (upper_bounds);
+
+	  /* Yield the multiple.  */
+	  a68_add_stmt (multiple);
+	  return a68_pop_range ();
+	}
+    }
+  else if (IS_STRUCT (mode))
+    {
+      /* This is a struct display.  There are as many units in the clause as
+	 fields in the struct type.  Build a constructor with the values for
+	 the fields.  */
+      vec <constructor_elt, va_gc> *ve = NULL;
+      tree_stmt_iterator si = tsi_start (units);
+      for (tree f = TYPE_FIELDS (CTYPE (mode)); f; f = DECL_CHAIN (f))
+	{
+	  tree v = tsi_stmt (si);
+	  gcc_assert (v != NULL_TREE);
+	  v = a68_consolidate_ref (a68_type_moid (TREE_TYPE (f)) ,v);
+	  CONSTRUCTOR_APPEND_ELT (ve, f, v);
+	  tsi_next (&si);
+	}
+      tree ctor = build_constructor (CTYPE (mode), ve);
+      return ctor;
+    }
+  else
+    gcc_unreachable ();
+}
+
+/* Lower a parallel clause.
+
+     parallel clause : par symbol, collateral clause.
+*/
+
+tree
+a68_lower_parallel_clause (NODE_T *p ATTRIBUTE_UNUSED,
+			   LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  /* XXX For now treat like a VOID collateral clause.  */
+  return a68_lower_tree (NEXT (SUB (p)), ctx);
+}
+
+/* Lower a closed clause.
+
+     closed clause : open symbol, serial clause, close symbol;
+                     open symbol, initialiser series, close symbol;
+		     begin symbol, serial clause, end symbol;
+		     begin symbol, initialiser series, end symbol;
+
+  This function returns a BIND_EXPR.  */
+
+tree
+a68_lower_closed_clause (NODE_T *p, LOW_CTX_T ctx)
+{
+  /* Determine the mode of the closed clause.  */
+  MOID_T *clause_mode = MOID (p);
+  gcc_assert (clause_mode != NO_MOID);
+  gcc_assert (CTYPE (clause_mode) != NULL_TREE);
+
+  /* Lower the enclosed serial clause.
+
+     Note that a serial clause can be nested right inside another, and in that
+     case the range we are pushing corresponds to all of them, so we have to
+     keep this into account when determining whether using a DSA serial
+     range.  */
+
+  bool dsa = serial_clause_dsa (NEXT (SUB (p)));
+  bool local = NON_LOCAL (NEXT (SUB (p))) == NO_TABLE;
+  a68_push_serial_clause_range (clause_mode, dsa && local);
+  (void) a68_lower_tree (NEXT (SUB (p)), ctx);
+  return a68_pop_serial_clause_range ();
+}
+
+/* Lower an enclosed clause.
+
+     enclosed clause : parallel clause; closed clause;
+                       collateral clause; conditional clause;
+		       case clause; conformity clause;
+		       loop clause.
+*/
+
+tree
+a68_lower_enclosed_clause (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_lower_tree (SUB (p), ctx);
+}
diff --git a/gcc/algol68/a68-low-decls.cc b/gcc/algol68/a68-low-decls.cc
new file mode 100644
index 00000000000..afc7284bd79
--- /dev/null
+++ b/gcc/algol68/a68-low-decls.cc
@@ -0,0 +1,629 @@
+/* Lower mode, identity and variable declarations to GENERIC.
+   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"
+
+/* Lower one or more mode declarations.
+
+     mode declaration : mode symbol, defining indicant,
+                        equals symbol, declarer;
+                        mode symbol, defining indicant,
+			equals symbol, void symbol;
+                        mode declaration, comma symbol,
+			defining indicant, equals symbol, declarer;
+                        mode declaration, comma symbol,
+			defining indicant, equals symbol, void symbol.
+
+   Each mode declaration lowers into a TYPE_DECL, which are chained in the
+   current block.  This function returns void_node.
+
+   Note that the defining indicant is already annotated with the declared mode
+   so there is no need to go hunting for the declarer in the subtree.  */
+
+tree
+a68_lower_mode_declaration (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *defining_indicant = NO_NODE;
+
+  if (IS (SUB (p), MODE_DECLARATION))
+    {
+      a68_lower_tree (SUB (p), ctx);
+      defining_indicant = NEXT (NEXT (SUB (p)));
+    }
+  else
+    {
+      gcc_assert (IS (SUB (p), MODE_SYMBOL));
+      defining_indicant = NEXT (SUB (p));
+    }
+
+  /* Create a TYPE_DECL declaration for the defined mode and chain it in the
+     current block.  */
+  tree ctype = CTYPE (MOID (defining_indicant));
+  tree decl_name = a68_get_mangled_identifier (NSYMBOL (defining_indicant));
+  tree decl = build_decl (a68_get_node_location (p),
+			  TYPE_DECL, decl_name, ctype);
+  SET_DECL_ASSEMBLER_NAME (decl, decl_name);
+  TREE_PUBLIC (decl) = 1;
+  TYPE_CONTEXT (ctype) = DECL_CONTEXT (decl);
+  TYPE_NAME (ctype) = decl;
+  TYPE_STUB_DECL (ctype) = decl;
+  a68_add_decl (decl);
+
+  return void_node;
+}
+
+/* Lower one or more variable declarations.
+
+     variable declaration : qualifier, declarer, defining identifier,
+                            assign symbol, unit;
+     			    qualifier, declarer, defining identiifer;
+			    qualifier, declarer, defining identifier;
+			    declarer, defining identifier, assign symbol, unit;
+			    declarer, defining identifier;
+			    variable declaration, comma symbol,
+			    defining identifier, assign symbol, unit;
+			    variable declaration, comma symbol,
+			    defining identifier;
+
+  Each variable declaration lowers into a VAR_DECL, which are chained in the
+  current block.  This function also returns an expression with code to
+  initialize the variable in case there is an initializer.
+
+  If the variable declaration implies a LOC generator then the VAR_DECL for REF
+  AMODE declares a value of type CTYPE (AMODE).  This is an optimization in
+  order to avoid indirect addressing.  If the variable declaration implies a
+  HEAP generator, however, then the VAR_DECL declares a value of type pointer
+  to CTYPE (AMODE0.  In this later case no optimization is possible and it has
+  exactly the same effect than an identity declaration `REF AMODE
+  defining_identifier = HEAP AMODE'.
+
+  Note that the defining identifier is annotated with its mode, so there is no
+  need to go hunting for the declarer in the subtree.  */
+
+tree
+a68_lower_variable_declaration (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *defining_identifier, *unit;
+  NODE_T *declarer = NO_NODE;
+
+  tree sub_expr = NULL_TREE;
+
+  if (IS (SUB (p), VARIABLE_DECLARATION))
+    {
+      LOW_CTX_T new_ctx = ctx;
+      new_ctx.declarer = &declarer;
+      sub_expr = a68_lower_tree (SUB (p), new_ctx);
+      defining_identifier = NEXT (NEXT (SUB (p)));
+    }
+  else if (IS (SUB (p), QUALIFIER))
+    {
+      /* The qualifier determines what kind of generator is used in the
+	 variable declaration.  This is already annotated in the tax entry for
+	 the definining identifier.  */
+      declarer = NEXT (SUB (p));
+      defining_identifier = NEXT (NEXT (SUB (p)));
+    }
+  else if (IS (SUB (p), DECLARER))
+    {
+      declarer = SUB (p);
+      defining_identifier = NEXT (SUB (p));
+    }
+  else
+    gcc_unreachable ();
+
+  /* Communicate declarer upward.  */
+  if (ctx.declarer != NULL)
+    *ctx.declarer = declarer;
+
+  /* See if this variable declaration features an initializing unit.  */
+  if (NEXT (defining_identifier) != NO_NODE)
+    {
+      gcc_assert (NEXT (defining_identifier)
+		  && IS (NEXT (defining_identifier), ASSIGN_SYMBOL)
+		  && NEXT (NEXT (defining_identifier)));
+      unit = NEXT (NEXT (defining_identifier));
+    }
+  else
+    unit = NO_NODE;
+
+  /* If not done already by an applied identifier in lower_identifier, create a
+     declaration for the defined entity and chain it in the current block.  The
+     declaration has an initial value of SKIP.  */
+  tree var_decl = TAX_TREE_DECL (TAX (defining_identifier));
+  if (var_decl == NULL_TREE)
+    {
+      var_decl = a68_make_variable_declaration_decl (defining_identifier);
+      TAX_TREE_DECL (TAX (defining_identifier)) = var_decl;
+    }
+
+  /* Chain declaration in current block and bind.  */
+  a68_add_decl (var_decl);
+
+  /* Add a decl_expr in the current range.  */
+  a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
+				      DECL_EXPR,
+				      TREE_TYPE (var_decl),
+				      var_decl));
+
+  tree expr = NULL_TREE;
+
+  /* If the variable is heap allocated or has rows, the var_decl created above
+     is a pointer.  Run a generator to get the memory with descriptors filled
+     in.  Note that we cannot set the pointer as the initial of the var_decl
+     because the bounds in the actual declarer shall be elaborated at the point
+     of the code where the declaration appears, not at the beginning of its
+     reach.  Note that the mode of the declarer will be always a REF since this
+     is a variable declaration: the referred mode is what we pass to
+     a68_low_generator.  */
+  bool heap = HEAP (TAX (defining_identifier)) == HEAP_SYMBOL;
+  if (heap || HAS_ROWS (SUB (MOID (defining_identifier))))
+    {
+      gcc_assert(IS_REF (MOID (declarer)));
+      expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (var_decl),
+			  var_decl,
+			  a68_low_generator (declarer,
+					     SUB (MOID (declarer)),
+					     heap, ctx));
+    }
+
+  if (unit != NO_NODE)
+    {
+      tree rhs = a68_lower_tree (unit, ctx);
+      tree assignation = a68_low_assignation (p,
+					      var_decl, MOID (defining_identifier),
+					      rhs, MOID (unit));
+      if (expr != NULL_TREE)
+	expr = fold_build2_loc (a68_get_node_location (p),
+				COMPOUND_EXPR,
+				TREE_TYPE (assignation),
+				expr, assignation);
+      else
+	expr = assignation;
+    }
+
+  /* Tail in a compound expression with sub declarations, if any.  */
+  if (sub_expr != NULL_TREE)
+    {
+      if (expr != NULL_TREE)
+	expr = fold_build2_loc (a68_get_node_location (p),
+				COMPOUND_EXPR,
+				TREE_TYPE (var_decl),
+				sub_expr,
+				expr);
+      else
+	expr = sub_expr;
+    }
+
+  return expr;
+}
+
+/* Lower one or more identity declarations.
+
+     identity declaration : declarer, defining identifier,
+                            equals symbol, unit;
+                            identity declaration, comma symbol,
+			    defining identifier, equals symbol, unit;
+
+   Each identity declaration lowers into a declaration.
+
+   VAR_DECL with both TREE_CONSTANT and TREE_READONLY set.  Note that we cannot
+   use CONST_DECL because of two reasons.  First, CONST_DECL only works for
+   scalar modes.  Second, since Algol 68 allows usage of identifiers before
+   they get declared, each declaration adds a declaration with a SKIP initial
+   value, and also an assignation of the value at the declaration point.  This
+   function also returns an expression with code to initialize the declared
+   constant.  */
+
+tree
+a68_lower_identity_declaration (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree unit_tree = NULL_TREE;
+  tree sub_expr = NULL_TREE;
+
+  /* Note that the formal declarer in the construct is not used.  This is
+     because it is already reflected in the mode of the identity
+     declaration.  */
+
+  NODE_T *defining_identifier;
+  if (IS (SUB (p), IDENTITY_DECLARATION))
+    {
+      sub_expr = a68_lower_tree (SUB (p), ctx);
+      defining_identifier = NEXT (NEXT (SUB (p)));
+    }
+  else if (IS (SUB (p), DECLARER))
+    {
+      defining_identifier = NEXT (SUB (p));
+    }
+  else
+    gcc_unreachable ();
+
+  NODE_T *unit = NEXT (NEXT (defining_identifier));
+
+  /* If not done already by an applied identifier in lower_identifier, create a
+     declaration for the defined entity and chain it in the current block.  The
+     declaration has an initial value of SKIP.  */
+  tree id_decl = TAX_TREE_DECL (TAX (defining_identifier));
+  if (id_decl == NULL_TREE)
+    {
+      id_decl = a68_make_identity_declaration_decl (defining_identifier);
+      TAX_TREE_DECL (TAX (defining_identifier)) = id_decl;
+    }
+
+  /* Chain declaration in current block and bind.  */
+  a68_add_decl (id_decl);
+  /* Prepare the DECL_EXPR.  */
+  a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
+				      DECL_EXPR,
+				      TREE_TYPE (id_decl),
+				      id_decl));
+
+  unit_tree = a68_lower_tree (unit, ctx);
+  unit_tree = a68_consolidate_ref (MOID (unit), unit_tree);
+  tree expr = a68_low_ascription (MOID (defining_identifier),
+				  id_decl, unit_tree);
+
+  /* If the ascribed value is constant, mark the declaration as constant.  */
+  TREE_CONSTANT (id_decl) = TREE_CONSTANT (unit_tree);
+
+  /* Tail in a compound expression with sub declarations, if any.  */
+  if (sub_expr != NULL_TREE)
+    {
+      if (expr != NULL_TREE)
+	expr = fold_build2_loc (a68_get_node_location (p),
+				COMPOUND_EXPR,
+				TREE_TYPE (id_decl),
+				sub_expr,
+				expr);
+      else
+	expr = sub_expr;
+    }
+
+  return expr;
+}
+
+/* Lower a declarer.
+
+     declarer : indicant;
+     		longety, indicant;
+     		shortety, indicant;
+		flex symbol, declarer;
+		flex symbol, bounds, declarer;
+		flex symbol, formal bounds, declarer;
+		bounds, declarer;
+		formal bounds, declarer;
+                ref symbol, declarer;
+		struct symbol, structure pack;
+		union symbol, union pack;
+                proc symbol, declarer;
+		proc symbol, formal declarers, declarer;
+		proc symbol, formal declarers, void symbol;
+
+
+  This handler lowes a DECLARER tree into an expression that evaluates to the
+  size of the actual declarer.  Note that this is a self-contained handler and
+  it does traverse the sub-tree on its own.  */
+
+tree
+a68_lower_declarer (NODE_T *p ATTRIBUTE_UNUSED,
+		    LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  gcc_unreachable ();
+}
+
+/* Lower a declaration list.
+
+    declaration list : mode declaration;
+                       priority declaration;
+                       brief operator declaration;
+                       operator declaration;
+                       identity declaration;
+                       procedure declaration;
+                       procedure variable declaration;
+                       variable declaration;
+                       environ name;
+		       declaration list, comma symbol, declaration list;
+
+   Process the subtree, which produces declarations associated with the current
+   context and which get added to the current block.  The list of declarations
+   gets returned in nested compound expressions.  */
+
+tree
+a68_lower_declaration_list (NODE_T *p, LOW_CTX_T ctx)
+{
+  if (IS (SUB (p), DECLARATION_LIST))
+    {
+      tree left = a68_lower_tree (SUB (p), ctx);
+      tree right = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+      /* The trees `left' and `right' may be NULL_TREE if the declarations
+	 under them didn't have an initializing expression.  In that case,
+	 replace them by nops which are removed at fold time.  This is ugly,
+	 but works.  */
+      if (left == NULL_TREE)
+	left = integer_zero_node;
+      if (right == NULL_TREE)
+	right = integer_zero_node;
+
+      return fold_build2_loc (a68_get_node_location (p),
+			      COMPOUND_EXPR,
+			      void_type_node,
+			      left, right);
+    }
+  else
+    return a68_lower_tree (SUB (p), ctx);
+}
+
+/* Lower a procedure declaration.
+
+     procedure declaration : proc symbol, defining identifier, assign symbol, routine text;
+                             procedure declaration, comma symbol,
+			     defining identifier, equals symbol, routine text.
+
+   Each procedure declaration lowers into a declaration.  */
+
+tree
+a68_lower_procedure_declaration (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree sub_func_decl = NULL_TREE;
+  NODE_T *defining_identifier;
+  if (IS (SUB (p), PROCEDURE_DECLARATION))
+    {
+      sub_func_decl = a68_lower_tree (SUB (p), ctx);
+      defining_identifier = NEXT (NEXT (SUB (p)));
+    }
+  else if (IS (SUB (p), PROC_SYMBOL))
+    {
+      defining_identifier = NEXT (SUB (p));
+    }
+  else
+    gcc_unreachable ();
+
+  NODE_T *routine_text = NEXT (NEXT (defining_identifier));
+
+  /* Lower the routine text to get a function decl.  */
+  ctx.proc_decl_identifier = defining_identifier;
+  tree func_decl = a68_lower_tree (routine_text, ctx);
+
+  /* Tail in a compound expression with sub declarations, if any.  */
+  if (sub_func_decl != NULL_TREE)
+    {
+      if (func_decl != NULL_TREE)
+	func_decl = fold_build2_loc (a68_get_node_location (p),
+				     COMPOUND_EXPR,
+				     TREE_TYPE (func_decl),
+				     sub_func_decl,
+				     func_decl);
+      else
+	func_decl = sub_func_decl;
+    }
+
+  return func_decl;
+}
+
+/* Lower a procedure variable declaration.
+
+     procedure variable declaration
+       : proc symbol, defining identifier, assign symbol, routine text;
+         qualifier, proc symbol, defining identifier, assign symbol, routine text;
+	 procedure variable declaration, comma symbol, defining identiier, assign symbol, routine text.
+
+   This lowers into the declaration of a VAR_DECL which is a pointer to the
+   free standing routine yielded by the routine text.  */
+
+tree
+a68_lower_procedure_variable_declaration (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree sub_decl = NULL_TREE;
+  NODE_T *defining_identifier;
+  if (IS (SUB (p), PROCEDURE_VARIABLE_DECLARATION))
+    {
+      sub_decl = a68_lower_tree (SUB (p), ctx);
+      defining_identifier = NEXT (NEXT (SUB (p)));
+    }
+  else if (IS (SUB (p), PROC_SYMBOL))
+    defining_identifier = NEXT (SUB (p));
+  else if (IS (SUB (p), QUALIFIER))
+    /* The qualifier determines what kind of generator is used in the variable
+       declaration.  This is already annotated in the tax entry for the
+       definining identifier.  */
+    defining_identifier = NEXT (NEXT (SUB (p)));
+  else
+    gcc_unreachable ();
+  NODE_T *routine_text = NEXT (NEXT (defining_identifier));
+
+  /* The routine text lowers into a pointer to function.  */
+  ctx.proc_decl_identifier = NO_NODE;
+  tree routine = a68_lower_tree (routine_text, ctx);
+
+  /* Create a declaration for the proc variable, if that hasn't been done
+     already.  */
+  tree decl = TAX_TREE_DECL (TAX (defining_identifier));
+  if (decl == NULL_TREE)
+    {
+      decl = a68_make_variable_declaration_decl (defining_identifier);
+      TAX_TREE_DECL (TAX (defining_identifier)) = decl;
+    }
+
+  /* Chain declaration in current block and bind.  */
+  a68_add_decl (decl);
+  /* Add a decl_expr in the current range.  */
+  a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
+				      DECL_EXPR,
+				      TREE_TYPE (decl),
+				      decl));
+  /* Initialize.
+
+     If the variable is heap allocated then the var_decl created above is a
+     pointer.  We don't allocate the actual function on the heap, because the
+     scope of procedures is not global.  */
+  bool heap = HEAP (TAX (defining_identifier)) == HEAP_SYMBOL;
+  a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (decl), decl,
+			     heap ? fold_build1 (ADDR_EXPR, TREE_TYPE (decl),
+						 routine) : routine));
+
+  /* Tail in a compound expression with sub declarations, if any.  */
+  if (sub_decl != NULL_TREE)
+    {
+      if (decl != NULL_TREE)
+	decl = fold_build2_loc (a68_get_node_location (p),
+				COMPOUND_EXPR,
+				TREE_TYPE (decl),
+				sub_decl,
+				decl);
+      else
+	decl = sub_decl;
+    }
+
+  return decl;
+}
+
+/* Lower a priority declaration.
+
+   This lowers to nothing.  Operator priority is fully handled by the parser in
+   order to decide which operator declaration corresponds to each applied
+   operator.  */
+
+tree
+a68_lower_priority_declaration (NODE_T *p ATTRIBUTE_UNUSED,
+				LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return NULL_TREE;
+}
+
+/* Lower a brief operator declaration.
+
+     brief operator declaration
+       : op symbol, defining operator, equals symbol, routine text;
+         brief operator declaration, comma symbol, defining operator, equals symbol, routine text.
+
+   The declarations low in a series of FUNCTION_DECLs, one per declared
+   operator.  */
+
+tree
+a68_lower_brief_operator_declaration (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree sub_func_decl = NULL_TREE;
+  NODE_T *defining_operator;
+
+  if (IS (SUB (p), BRIEF_OPERATOR_DECLARATION))
+    {
+      sub_func_decl = a68_lower_tree (SUB (p), ctx);
+      defining_operator = NEXT (NEXT (SUB (p)));
+    }
+  else
+    defining_operator = NEXT (SUB (p));
+  NODE_T *routine_text = NEXT (NEXT (defining_operator));
+
+  /* Lower the routine text to get a function decl.  */
+  ctx.proc_decl_identifier = defining_operator;
+  tree func_decl = a68_lower_tree (routine_text, ctx);
+
+  /* Tail in a compound expression with sub declarations, if any.  */
+  if (sub_func_decl != NULL_TREE)
+    {
+      if (func_decl != NULL_TREE)
+	func_decl = fold_build2_loc (a68_get_node_location (p),
+				     COMPOUND_EXPR,
+				     TREE_TYPE (func_decl),
+				     sub_func_decl,
+				     func_decl);
+      else
+	func_decl = sub_func_decl;
+    }
+
+  return func_decl;
+}
+
+/* Lower an operator declaration.
+
+     operator declaration : operator plan, defining operator, equals symbol, unit;
+                            operator declaration, comma symbol, defining operator, equals symbol, unit.
+
+   Each operator declaration lowers into a declaration.  */
+
+tree
+a68_lower_operator_declaration (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree sub_op_decl = NULL_TREE;
+  NODE_T *defining_operator;
+
+  if (IS (SUB (p), OPERATOR_DECLARATION))
+    {
+      sub_op_decl = a68_lower_tree (SUB (p), ctx);
+      defining_operator = NEXT (NEXT (SUB (p)));
+    }
+  else
+    defining_operator = NEXT (SUB (p));
+  NODE_T *unit = NEXT (NEXT (defining_operator));
+
+  tree op_decl = TAX_TREE_DECL (TAX (defining_operator));
+  if (op_decl == NULL_TREE)
+    {
+      op_decl = a68_make_identity_declaration_decl (defining_operator);
+      TAX_TREE_DECL (TAX (defining_operator)) = op_decl;
+    }
+
+  /* Chain declaration in current block and bind and emit DECL_EXPR.  */
+  a68_add_decl (op_decl);
+  a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
+				      DECL_EXPR,
+				      TREE_TYPE (op_decl),
+				      op_decl));
+  /* Initialize.  */
+  a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (op_decl), op_decl,
+			     a68_lower_tree (unit, ctx)));
+
+  /* Tail in a compound expression with sub declarations, if any.  */
+  if (sub_op_decl != NULL_TREE)
+    {
+      if (op_decl != NULL_TREE)
+	op_decl = fold_build2_loc (a68_get_node_location (p),
+				   COMPOUND_EXPR,
+				   TREE_TYPE (op_decl),
+				   sub_op_decl,
+				   op_decl);
+      else
+	op_decl = sub_op_decl;
+    }
+
+  return op_decl;
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 34/47] a68: low: runtime
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (32 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 33/47] a68: low: clauses and declarations Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 35/47] a68: low: builtins Jose E. Marchesi
                   ` (13 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

Libcalls for operations implemented in the run-time environment.

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

gcc/ChangeLog

	* algol68/a68-low-runtime.cc: New file.
	* algol68/a68-low-runtime.def: Likewise.
---
 gcc/algol68/a68-low-runtime.cc  | 225 ++++++++++++++++++++++++++++++++
 gcc/algol68/a68-low-runtime.def |  91 +++++++++++++
 2 files changed, 316 insertions(+)
 create mode 100644 gcc/algol68/a68-low-runtime.cc
 create mode 100644 gcc/algol68/a68-low-runtime.def

diff --git a/gcc/algol68/a68-low-runtime.cc b/gcc/algol68/a68-low-runtime.cc
new file mode 100644
index 00000000000..4ea93e991e1
--- /dev/null
+++ b/gcc/algol68/a68-low-runtime.cc
@@ -0,0 +1,225 @@
+/* Libcalls to Algol 68 run-time functions.
+   Copyright (C) 2006-2025 Free Software Foundation, Inc.
+   Copyright (C) 2025 Jose E. Marchesi.
+
+   Written by Jose E. Marchesi.
+   Adapted from gcc/d/runtime.cc.
+
+   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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "tree.h"
+#include "fold-const.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"
+
+/* The lowering pass may generate expressions to call various runtime library
+   functions.  Most of these functions are implemented in libga68.  This file
+   provides facilities to compile libcalls to runtime functions.  The file
+   a68-low-runtime.def contains a database of available runtime library
+   functions.  */
+
+enum a68_libcall_type
+{
+  LCT_VOID,
+  LCT_CHAR,
+  LCT_CONSTCHARPTR,
+  LCT_VOIDPTR,
+  LCT_UNISTR,
+  LCT_UNISTRPTR,
+  LCT_SIZE,
+  LCT_SSIZE,
+  LCT_SIZEPTR,
+  LCT_UINT,
+  LCT_INT,
+  LCT_LONGLONGINT,
+  LCT_FLOAT,
+  LCT_DOUBLE,
+  LCT_LONGDOUBLE,
+  LCT_END
+};
+
+/* An array of all types that are used by the runtime functions we need.  */
+
+static tree libcall_types[LCT_END];
+
+/* Internal list of library functions.  */
+
+static tree libcall_decls[A68_LIBCALL_LAST];
+
+/* Return the TREE type that is described by TYPE.  */
+
+static tree
+get_libcall_type (a68_libcall_type type)
+{
+  if (libcall_types[type])
+    return libcall_types[type];
+
+  if (type == LCT_VOID)
+    libcall_types[type] = void_type_node;
+  else if (type == LCT_CHAR)
+    libcall_types[type] = uint32_type_node;
+  else if (type == LCT_CONSTCHARPTR)
+    libcall_types[type] = build_pointer_type (build_qualified_type (char_type_node,
+								    TYPE_QUAL_CONST));
+  else if (type == LCT_VOIDPTR)
+    libcall_types[type] = ptr_type_node;
+  else if (type == LCT_UNISTR)
+    libcall_types[type] = build_pointer_type (a68_char_type);
+  else if (type == LCT_UNISTRPTR)
+    libcall_types[type] = build_pointer_type (build_pointer_type (a68_char_type));
+  else if (type == LCT_SIZE)
+    libcall_types[type] = sizetype;
+  else if (type == LCT_SSIZE)
+    libcall_types[type] = ssizetype;
+  else if (type == LCT_SIZEPTR)
+    libcall_types[type] = build_pointer_type (sizetype);
+  else if (type == LCT_UINT)
+    libcall_types[type] = unsigned_type_node;
+  else if (type == LCT_INT)
+    libcall_types[type] = integer_type_node;
+  else if (type == LCT_LONGLONGINT)
+    libcall_types[type] = long_long_integer_type_node;
+  else if (type == LCT_FLOAT)
+    libcall_types[type] = float_type_node;
+  else if (type == LCT_DOUBLE)
+    libcall_types[type] = double_type_node;
+  else if (type == LCT_LONGDOUBLE)
+    libcall_types[type] = long_double_type_node;
+  else
+    gcc_unreachable ();
+
+  return libcall_types[type];
+}
+
+/* Build and return a function declaration named NAME.  The RETURN_TYPE is the
+   type returned, FLAGS are the expression call flags, and NPARAMS is the
+   number of arguments, the types of which are provided in `...'.  */
+
+static tree
+build_libcall_decl (const char *name, a68_libcall_type return_type,
+		    int flags, int nparams, ...)
+{
+  tree *args = XALLOCAVEC (tree, nparams);
+  bool varargs = false;
+  tree fntype;
+
+  /* Add parameter types, using `void' as the last parameter type
+     to mean this function accepts a variable list of arguments.  */
+  va_list ap;
+  va_start (ap, nparams);
+
+  for (int i = 0; i < nparams; i++)
+    {
+      a68_libcall_type ptype = (a68_libcall_type) va_arg (ap, int);
+      tree type = get_libcall_type (ptype);
+
+      if (type == void_type_node)
+	{
+	  varargs = true;
+	  nparams = i;
+	}
+      else
+	args[i] = type;
+    }
+
+  va_end (ap);
+
+  /* Build the function.  */
+  tree tret = get_libcall_type (return_type);
+  if (varargs)
+    fntype = build_varargs_function_type_array (tret, nparams, args);
+  else
+    fntype = build_function_type_array (tret, nparams, args);
+
+  tree decl = build_decl (UNKNOWN_LOCATION, FUNCTION_DECL,
+			  get_identifier (name), fntype);
+  DECL_EXTERNAL (decl) = 1;
+  TREE_PUBLIC (decl) = 1;
+  DECL_ARTIFICIAL (decl) = 1;
+  DECL_VISIBILITY (decl) = VISIBILITY_DEFAULT;
+  DECL_VISIBILITY_SPECIFIED (decl) = 1;
+
+  /* Set any attributes on the function, such as malloc or noreturn.  */
+  set_call_expr_flags (decl, flags);
+  return decl;
+}
+
+/* Return or create the runtime library function declaration for LIBCALL.
+   Library functions are generated as needed.  This could probably be changed
+   in the future to be done in the compiler init stage, like GCC builtin trees
+   are.  */
+
+tree
+a68_get_libcall (a68_libcall_fn libcall)
+{
+  if (libcall_decls[libcall])
+    return libcall_decls[libcall];
+
+  switch (libcall)
+    {
+#define DEF_A68_RUNTIME(CODE, NAME, TYPE, PARAMS, FLAGS) \
+    case A68_LIBCALL_ ## CODE:	\
+      libcall_decls[libcall] = build_libcall_decl (NAME, TYPE, FLAGS, PARAMS); \
+      break;
+#include "a68-low-runtime.def"
+#undef DEF_A68_RUNTIME
+    default:
+      gcc_unreachable ();
+    }
+
+  return libcall_decls[libcall];
+}
+
+/* Generate a call to LIBCALL, returning the result as TYPE.  NARGS is the
+   number of call arguments, the expressions of which are provided in `...'.
+   This does not perform conversions or promotions on the arguments.  */
+
+tree
+a68_build_libcall (a68_libcall_fn libcall, tree type ATTRIBUTE_UNUSED,
+		   int nargs, ...)
+{
+  /* Build the call expression to the runtime function.  */
+  tree decl = a68_get_libcall (libcall);
+  tree *args = XALLOCAVEC (tree, nargs);
+  va_list ap;
+
+  va_start (ap, nargs);
+  for (int i = 0; i < nargs; i++)
+    args[i] = va_arg (ap, tree);
+  va_end (ap);
+
+  tree result = build_call_expr_loc_array (input_location, decl, nargs, args);
+
+  /* Assumes caller knows what it is doing.  */
+  return result;
+}
diff --git a/gcc/algol68/a68-low-runtime.def b/gcc/algol68/a68-low-runtime.def
new file mode 100644
index 00000000000..21ec855947d
--- /dev/null
+++ b/gcc/algol68/a68-low-runtime.def
@@ -0,0 +1,91 @@
+/* a68-low-runtime.def -- Definitions for Algol 68 runtime functions.
+   Copyright (C) 2025 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/>.  */
+
+/* Helper macros for parameter building.  */
+#define P0()	0
+#define P1(T1)	1, LCT_ ## T1
+#define P2(T1, T2) \
+		2, LCT_ ## T1, LCT_ ## T2
+#define P3(T1, T2, T3) \
+		3, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3
+#define P4(T1, T2, T3, T4) \
+		4, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4
+#define P5(T1, T2, T3, T4, T5)  \
+		5, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4, LCT_ ## T5
+#define P6(T1, T2, T3, T4, T5, T6)  \
+		6, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4, LCT_ ## T5, LCT_ ## T6
+#define P7(T1, T2, T3, T4, T5, T6, T7)					\
+                7, LCT_ ## T1, LCT_ ## T2, LCT_ ## T3, LCT_ ## T4, LCT_ ## T5, LCT_ ## T6, LCT_ ## T7
+#define RT(T1)	LCT_ ## T1
+
+/* Algol 68 runtime library functions.  */
+
+/* DEF_A68_RUNTIME (CODE, NAME, TYPE, PARAMS, FLAGS)
+   CODE	    The enum code used to refer to this function.
+   NAME	    The name of this function as a string.
+   FLAGS    ECF flags to describe attributes of the function.
+
+   Used for declaring functions that are called by generated code.  */
+
+DEF_A68_RUNTIME (ASSERT, "_libga68_assert", RT(VOID), P2(CONSTCHARPTR, UINT), ECF_NORETURN)
+DEF_A68_RUNTIME (SET_EXIT_STATUS, "_libga68_set_exit_status", RT(VOID), P1(INT), 0)
+DEF_A68_RUNTIME (MALLOC, "_libga68_malloc", RT(VOIDPTR), P1(SIZE), ECF_NOTHROW | ECF_LEAF | ECF_MALLOC)
+DEF_A68_RUNTIME (DEREFNIL, "_libga68_derefnil", RT(VOID), P2(CONSTCHARPTR, UINT), ECF_NORETURN)
+DEF_A68_RUNTIME (UNREACHABLE, "_libga68_unreachable", RT(VOID), P2(CONSTCHARPTR, UINT), ECF_NORETURN)
+DEF_A68_RUNTIME (INVALIDCHARERROR, "_libga68_invalidcharerror", RT(VOID), P3(CONSTCHARPTR,UINT,INT), ECF_NORETURN)
+DEF_A68_RUNTIME (BITSBOUNDSERROR, "_libga68_bitsboundserror", RT(VOID), P3(CONSTCHARPTR,UINT,SSIZE), ECF_NORETURN)
+DEF_A68_RUNTIME (ARRAYLOWERBOUND, "_libga68_lower_bound", RT(VOID),
+		 P4(CONSTCHARPTR, UINT, SSIZE, SSIZE), ECF_NORETURN)
+DEF_A68_RUNTIME (ARRAYUPPERBOUND, "_libga68_upper_bound", RT(VOID),
+		 P4(CONSTCHARPTR, UINT, SSIZE, SSIZE), ECF_NORETURN)
+DEF_A68_RUNTIME (ARRAYBOUNDS, "_libga68_bounds", RT(VOID),
+		 P5(CONSTCHARPTR, UINT, SSIZE, SSIZE, SSIZE), ECF_NORETURN)
+DEF_A68_RUNTIME (ARRAYBOUNDSMISMATCH, "_libga68_bounds_mismatch", RT(VOID),
+		 P7(CONSTCHARPTR, UINT, SIZE, SSIZE, SSIZE, SSIZE, SSIZE), ECF_NORETURN)
+DEF_A68_RUNTIME (ARRAYDIM, "_libga68_dim", RT(VOID),
+                 P4(CONSTCHARPTR, UINT, SIZE, SIZE), ECF_NORETURN)
+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_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 (U32_CMP2, "_libga68_u32_cmp2", RT(INT), P6(UNISTR, SIZE, SIZE, UNISTR, SIZE, SIZE), 0)
+
+#undef P0
+#undef P1
+#undef P2
+#undef P3
+#undef P4
+#undef P5
+#undef RT
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 35/47] a68: low: builtins
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (33 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 34/47] a68: low: runtime Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 36/47] a68: low: ranges Jose E. Marchesi
                   ` (12 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-low-builtins.cc: New file.
---
 gcc/algol68/a68-low-builtins.cc | 533 ++++++++++++++++++++++++++++++++
 1 file changed, 533 insertions(+)
 create mode 100644 gcc/algol68/a68-low-builtins.cc

diff --git a/gcc/algol68/a68-low-builtins.cc b/gcc/algol68/a68-low-builtins.cc
new file mode 100644
index 00000000000..eabf7b34835
--- /dev/null
+++ b/gcc/algol68/a68-low-builtins.cc
@@ -0,0 +1,533 @@
+/* GCC built-ins support for Algol 68.
+   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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "tree.h"
+#include "fold-const.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"
+
+/* Define a built-in function.  */
+
+static void
+local_define_builtin (const char *name, tree type, enum built_in_function code,
+                      const char *library_name, int ecf_flags)
+{
+  tree decl;
+
+  decl = add_builtin_function (name, type, code, BUILT_IN_NORMAL,
+			       library_name, NULL_TREE);
+  set_call_expr_flags (decl, ecf_flags);
+  set_builtin_decl (code, decl, true);
+}
+
+/* Install the GCC built-ins so the front-end can use them.  */
+
+void
+a68_install_builtins (void)
+{
+  if (!builtin_decl_explicit_p (BUILT_IN_IROUNDF))
+    {
+      tree ftype = build_function_type_list (integer_type_node,
+					     float_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_iroundf", ftype, BUILT_IN_IROUNDF,
+			    "iroundf", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LROUNDF))
+    {
+      tree ftype = build_function_type_list (long_integer_type_node,
+					     float_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_lroundf", ftype, BUILT_IN_LROUNDF,
+			    "lroundf", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LLROUNDF))
+    {
+      tree ftype = build_function_type_list (long_long_integer_type_node,
+					     float_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_llroundf", ftype, BUILT_IN_LLROUNDF,
+			    "llroundf", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_IROUND))
+    {
+      tree ftype = build_function_type_list (integer_type_node,
+					     double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_iround", ftype, BUILT_IN_IROUND,
+			    "iround", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LROUND))
+    {
+      tree ftype = build_function_type_list (long_integer_type_node,
+					     double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_lround", ftype, BUILT_IN_LROUND,
+			    "lround", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LLROUND))
+    {
+      tree ftype = build_function_type_list (long_long_integer_type_node,
+					     double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_llround", ftype, BUILT_IN_LLROUND,
+			    "llround", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_IROUNDL))
+    {
+      tree ftype = build_function_type_list (integer_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_iroundl", ftype, BUILT_IN_IROUNDL,
+			    "iroundl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LROUNDL))
+    {
+      tree ftype = build_function_type_list (long_integer_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_lroundl", ftype, BUILT_IN_LROUNDL,
+			    "lroundl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LLROUNDL))
+    {
+      tree ftype = build_function_type_list (long_long_integer_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_llroundl", ftype, BUILT_IN_LLROUNDL,
+			    "llroundl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_IFLOORF))
+    {
+      tree ftype = build_function_type_list (integer_type_node,
+					     float_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_ifloorf", ftype, BUILT_IN_IFLOORF,
+			    "ifloorf", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LFLOORF))
+    {
+      tree ftype = build_function_type_list (long_integer_type_node,
+					     float_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_lfloorf", ftype, BUILT_IN_LFLOORF,
+			    "lfloorf", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LLFLOORF))
+    {
+      tree ftype = build_function_type_list (long_long_integer_type_node,
+					     float_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_llfloorf", ftype, BUILT_IN_LLFLOORF,
+			    "llfloorf", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_IFLOOR))
+    {
+      tree ftype = build_function_type_list (integer_type_node,
+					     double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_ifloor", ftype, BUILT_IN_IFLOOR,
+			    "ifloor", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LFLOOR))
+    {
+      tree ftype = build_function_type_list (long_integer_type_node,
+					     double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_lfloor", ftype, BUILT_IN_LFLOOR,
+			    "lfloor", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LLFLOOR))
+    {
+      tree ftype = build_function_type_list (long_long_integer_type_node,
+					     double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_llfloor", ftype, BUILT_IN_LLFLOOR,
+			    "llfloor", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_IFLOORL))
+    {
+      tree ftype = build_function_type_list (integer_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_ifloorl", ftype, BUILT_IN_IFLOORL,
+			    "ifloorl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LFLOORL))
+    {
+      tree ftype = build_function_type_list (long_integer_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_lfloorl", ftype, BUILT_IN_LFLOORL,
+			    "lfloorl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LLFLOORL))
+    {
+      tree ftype = build_function_type_list (long_long_integer_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_llfloorl", ftype, BUILT_IN_LLFLOORL,
+			    "llfloorl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_POWF))
+    {
+      tree ftype = build_function_type_list (float_type_node,
+					     float_type_node, float_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_powf", ftype, BUILT_IN_POWF,
+			    "powf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_POWIF))
+    {
+      tree ftype = build_function_type_list (float_type_node,
+					     float_type_node, integer_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_powif", ftype, BUILT_IN_POWIF,
+			    "powif", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_POW))
+    {
+      tree ftype = build_function_type_list (double_type_node,
+					     double_type_node, double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_pow", ftype, BUILT_IN_POW,
+			    "pow", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_POWI))
+    {
+      tree ftype = build_function_type_list (double_type_node,
+					     double_type_node, integer_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_powi", ftype, BUILT_IN_POWI,
+			    "powi", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_POWL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node, long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_powl", ftype, BUILT_IN_POWL,
+			    "powl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_POWIL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node, integer_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_powil", ftype, BUILT_IN_POWIL,
+			    "powil", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_CALLOC))
+    {
+      tree ftype = build_function_type_list (ptr_type_node,
+					     size_type_node, size_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_calloc", ftype, BUILT_IN_CALLOC,
+			    "calloc", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_MEMCPY))
+    {
+      tree ftype = build_function_type_list (ptr_type_node,
+					     ptr_type_node, const_ptr_type_node, size_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_memcpy", ftype, BUILT_IN_MEMSET,
+			    "memcpy", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_MEMSET))
+    {
+      tree ftype = build_function_type_list (ptr_type_node,
+					     ptr_type_node, integer_type_node, size_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_memset", ftype, BUILT_IN_MEMSET,
+			    "memset", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_SQRTF))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_sqrtf", ftype, BUILT_IN_SQRTF,
+			    "sqrtf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_SQRT))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_sqrt", ftype, BUILT_IN_SQRT,
+			    "sqrt", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_SQRTL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_sqrtl", ftype, BUILT_IN_SQRTL,
+			    "sqrtl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_TANF))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_tanf", ftype, BUILT_IN_TANF,
+			    "tanf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_TAN))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_tan", ftype, BUILT_IN_TAN,
+			    "tan", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_TANL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_tanl", ftype, BUILT_IN_TANL,
+			    "tanl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_SINF))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_sinf", ftype, BUILT_IN_SINF,
+			    "sinf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_SIN))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_sin", ftype, BUILT_IN_SIN,
+			    "sin", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_SINL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_sinl", ftype, BUILT_IN_SINL,
+			    "sinl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_COSF))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_cosf", ftype, BUILT_IN_COSF,
+			    "cosf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_COS))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_cos", ftype, BUILT_IN_COS,
+			    "cos", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_COSL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_cosl", ftype, BUILT_IN_COSL,
+			    "cosl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_ACOSF))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_acosf", ftype, BUILT_IN_ACOSF,
+			    "acosf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_ACOS))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_acos", ftype, BUILT_IN_ACOS,
+			    "acos", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_ACOSL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_acosl", ftype, BUILT_IN_ACOSL,
+			    "acosl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_ASINF))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_asinf", ftype, BUILT_IN_ASINF,
+			    "asinf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_ASIN))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_asin", ftype, BUILT_IN_ASIN,
+			    "asin", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_ASINL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_asinl", ftype, BUILT_IN_ASINL,
+			    "asinl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_ATANF))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_atanf", ftype, BUILT_IN_ATANF,
+			    "atanf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_ATAN))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_atan", ftype, BUILT_IN_ATAN,
+			    "atan", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_ATANL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_atanl", ftype, BUILT_IN_ATANL,
+			    "atanl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LOGF))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_logf", ftype, BUILT_IN_LOGF,
+			    "logf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LOG))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_log", ftype, BUILT_IN_LOG,
+			    "log", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LOGL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_logl", ftype, BUILT_IN_LOGL,
+			    "logl", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LOG10F))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_log10f", ftype, BUILT_IN_LOG10F,
+			    "log10f", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LOG10))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_log10", ftype, BUILT_IN_LOG10,
+			    "log10", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_LOG10L))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_log10l", ftype, BUILT_IN_LOG10L,
+			    "log10l", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_EXPF))
+    {
+      tree ftype = build_function_type_list (float_type_node, float_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_expf", ftype, BUILT_IN_EXPF,
+			    "expf", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_EXP))
+    {
+      tree ftype = build_function_type_list (double_type_node, double_type_node, NULL_TREE);
+      local_define_builtin ("__builtin_exp", ftype, BUILT_IN_EXP,
+			    "exp", ECF_NOTHROW | ECF_LEAF);
+    }
+
+  if (!builtin_decl_explicit_p (BUILT_IN_EXPL))
+    {
+      tree ftype = build_function_type_list (long_double_type_node,
+					     long_double_type_node,
+					     NULL_TREE);
+      local_define_builtin ("__builtin_expl", ftype, BUILT_IN_EXPL,
+			    "expl", ECF_NOTHROW | ECF_LEAF);
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 36/47] a68: low: ranges
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (34 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 35/47] a68: low: builtins Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 37/47] a68: low: units and coercions Jose E. Marchesi
                   ` (11 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-low-ranges.cc: New file.
---
 gcc/algol68/a68-low-ranges.cc | 697 ++++++++++++++++++++++++++++++++++
 1 file changed, 697 insertions(+)
 create mode 100644 gcc/algol68/a68-low-ranges.cc

diff --git a/gcc/algol68/a68-low-ranges.cc b/gcc/algol68/a68-low-ranges.cc
new file mode 100644
index 00000000000..8b9a802b249
--- /dev/null
+++ b/gcc/algol68/a68-low-ranges.cc
@@ -0,0 +1,697 @@
+/* Management of ranges in the Algol 68 front-end.
+   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/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+
+#include "tree.h"
+#include "fold-const.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 "tree-nested.h"
+
+#include "a68.h"
+
+/* Many Algol 68 constructions introduce a new range of definitions.  This is
+   the case of clauses and of routine definitions.  The stack of ranges at any
+   point in the program determines the "nest" of the constructions declared in
+   the program.  This nest carries a record of all the declarations forming the
+   environment in which that construct is to be interpreted.
+
+   This file contains a manager of ranges of which we allocate one for each
+   range inducing construct.  The top-level range corresponds to the primal
+   environment.
+
+   The ranges are used by the lowering code in order to create GCC tree BLOCK
+   nodes, and also to keep track of the set of declarations and of statements
+   being added by the current serial clause.  */
+
+struct GTY (()) range
+{
+  /* Whether this range entry doesn't introduce a lexical frame.  Declarations
+     and decl_exprs get added to the nearst enclosing range that is not
+     frameless.  */
+  bool frameless;
+
+  /* A chain of _DECL nodes for all variables, constants, functions,
+     and typedef types.  These are in the reverse of the order supplied.  */
+  tree names;
+
+  /* A statements list of DECL_EXPR nodes for all the declarations in the
+     range.  These are prepended to the statements list when the range is
+     closed.  */
+  tree decl_exprs;
+
+  /* The context of the range, either a function declaration or a translation
+     unit.  */
+  tree context;
+
+  /* The range below this one.  */
+  struct range *next;
+
+  /* Statement list.  */
+  tree stmt_list;
+
+  /* List of blocks to which the block created for this range is the
+     superblock.  */
+  tree blocks;
+
+  /* Mode associated with the range.  For serial clauses, this is the mode of
+     the value yielded by the clause.  */
+  MOID_T *mode;
+
+  /* If not TREE_NULL, then the range corresponds to a function, which can be
+     either nested or defined at top-level.  */
+  tree fndecl;
+  bool top_level_function;
+
+  /* The following fields are used by ranges introduced by serial
+     clauses.  */
+  bool save_restore_stack;
+  bool has_completers;
+  tree clause_result_decl;
+  tree clause_exit_label_decl;
+  tree clause_stack_save_decl;
+};
+
+/* Global and current ranges.  */
+
+static GTY (()) struct range *global_range;
+static GTY (()) struct range *current_range;
+
+/* Create a new range and push it in the list.  */
+
+static struct range *
+new_range (void)
+{
+  struct range *range = ggc_alloc<struct range> ();
+
+  range->frameless = false;
+  range->names = NULL;
+  range->decl_exprs = alloc_stmt_list ();
+  range->context = NULL;
+  range->next = NULL;
+  range->blocks = NULL_TREE;
+  range->stmt_list = alloc_stmt_list ();
+  range->fndecl = NULL_TREE;
+  range->top_level_function = false;
+  range->save_restore_stack = false;
+  range->has_completers = false;
+  range->clause_result_decl = NULL_TREE;
+  range->clause_exit_label_decl = NULL_TREE;
+  range->clause_stack_save_decl = NULL_TREE;
+  range->mode = NO_MOID;
+  return range;
+}
+
+/* Push a new frameless range.  */
+
+void
+a68_push_stmt_list (MOID_T *mode)
+{
+  a68_push_range (mode);
+  current_range->frameless = true;
+}
+
+/* Pop a frameless range.  */
+
+tree
+a68_pop_stmt_list (void)
+{
+  /* This will result into a stmt list.  */
+  tree res = a68_pop_range ();
+  gcc_assert (TREE_CODE (res) == STATEMENT_LIST);
+  return res;
+}
+
+/* Push a new range.  */
+
+void
+a68_push_range (MOID_T *mode)
+{
+  struct range *range = new_range ();
+  if (current_range)
+    range->context = current_range->context;
+  range->next = current_range;
+  range->mode = mode;
+  current_range = range;
+}
+
+/* Pop a range, with a finalizer.
+
+   Return a BIND_EXPR, a statement list or a TRY_FINALLY_EXPR.  */
+
+tree
+a68_pop_range_with_finalizer (tree finalizer)
+{
+  tree range = a68_pop_range ();
+  return fold_build2 (TRY_FINALLY_EXPR, TREE_TYPE (range),
+		      range, finalizer);
+}
+
+/* Pop a range.  Return either a BIND_EXPR or a statements list.  */
+
+tree
+a68_pop_range (void)
+{
+  struct range *range = current_range;
+  current_range = range->next;
+  tree type = (range->mode == NULL ? void_type_node : CTYPE (range->mode));
+
+  /* If TYPE is a pointer type and the last expression in the statement list is
+     a variable of the type pointed by TYPE then take its address.  */
+  tree_stmt_iterator i = tsi_last (range->stmt_list);
+  if (POINTER_TYPE_P (type) && TREE_TYPE (type) == TREE_TYPE (tsi_stmt (i)))
+    {
+      append_to_statement_list_force (a68_consolidate_ref (range->mode, tsi_stmt (i)),
+				      &range->stmt_list);
+      tsi_delink (&i);
+    }
+
+  tree clause = NULL_TREE;
+  if (range->frameless)
+    clause = range->stmt_list;
+  else
+    {
+      /* Create a block and set its declarations and supercontext.  */
+      tree block = make_node (BLOCK);
+      BLOCK_VARS (block) = range->names;
+      BLOCK_SUBBLOCKS (block) = range->blocks;
+
+      /* In each subblock, record that this is its superior.  */
+      for (tree t = range->blocks; t; t = BLOCK_CHAIN (t))
+	BLOCK_SUPERCONTEXT (t) = block;
+
+      if (range->fndecl)
+	{
+	  BLOCK_SUPERCONTEXT (block) = range->fndecl;
+	  DECL_INITIAL (range->fndecl) = block;
+	}
+      else
+	{
+	  current_range->blocks
+	    = block_chainon (current_range->blocks, block);
+	}
+
+      TREE_USED (block) = true;
+
+      /* Create a BIND if the range contains declarations.  Otherwise just
+	 use the statements list.  */
+      clause = range->stmt_list;
+      if (range->names != NULL_TREE)
+	{
+	  clause = build3 (BIND_EXPR,
+			   type,
+			   range->names,
+			   range->stmt_list,
+			   block);
+	  TREE_SIDE_EFFECTS (clause) = 1;
+	  BIND_EXPR_VARS (clause) = BLOCK_VARS (block);
+	}
+
+      /* Prepend the decl_exprs to the range's statements list.  */
+      tree_stmt_iterator q = tsi_start (range->stmt_list);
+      tsi_link_before (&q, range->decl_exprs, TSI_SAME_STMT);
+    }
+
+  /* Set the type of the stmt_list.  */
+  TREE_TYPE (range->stmt_list) = type;
+  TREE_SIDE_EFFECTS (range->stmt_list) = 1;
+
+  return clause;
+}
+
+/* Add a new expression to the current range.  */
+
+void
+a68_add_stmt (tree exp)
+{
+  if (exp == void_node)
+    /* This may result from a mode declaration.  */
+    return;
+  gcc_assert (current_range != NULL);
+  append_to_statement_list_force (exp,
+				  &current_range->stmt_list);
+}
+
+/* Add a new declaration to the current range.  */
+
+void
+a68_add_decl (tree decl)
+{
+  gcc_assert (current_range != NULL);
+  struct range *range = current_range;
+
+  /* Search for the right frame where to add the declaration.  */
+  while (range->frameless)
+    {
+      gcc_assert (range->next != NULL);
+      range = range->next;
+    }
+
+  tree n = range->names;
+  while (n != decl && n != NULL)
+    n = TREE_CHAIN (n);
+  if (n != decl)
+    {
+      if (decl != current_function_decl)
+	DECL_CONTEXT (decl) = range->context;
+      /* Note this list needs to be in reverse order for compatibility with
+	 GCC.  */
+      TREE_CHAIN (decl) = range->names;
+      range->names = decl;
+    }
+}
+
+/* Add a new declaration expr to the current range.  */
+
+void
+a68_add_decl_expr (tree decl_expr)
+{
+  gcc_assert (current_range != NULL);
+  struct range *range = current_range;
+
+  /* Search for the right frame where to add the declaration expr.  */
+  while (range->frameless)
+    {
+      gcc_assert (range->next != NULL);
+      range = range->next;
+    }
+
+  append_to_statement_list_force (decl_expr, &range->decl_exprs);
+}
+
+/* Add a completer in the current range.  */
+
+void
+a68_add_completer (void)
+{
+  struct range *range = current_range;
+
+  /* The last statement in the statements list is either a single unit or a
+     labeled unit, i.e a COMPOUND_EXPR whose first expression is a label and
+     second expression is the unit.  Consolidate the unit within the labeled
+     unit to a ref.  */
+  tree_stmt_iterator i = tsi_last (range->stmt_list);
+  tree last_expr = tsi_stmt (i);
+
+  if (TREE_CODE (last_expr) == COMPOUND_EXPR
+      && TREE_CODE (TREE_OPERAND (last_expr, 0)) == LABEL_EXPR)
+    {
+      TREE_OPERAND (last_expr, 1) = a68_consolidate_ref (range->mode,
+							 TREE_OPERAND (last_expr, 1));
+      TREE_TYPE (last_expr) = TREE_TYPE (TREE_OPERAND (last_expr, 1));
+    }
+  else
+    last_expr = a68_consolidate_ref (range->mode, last_expr);
+
+  /* Now assign the labeled unit to the clause result decl then jump to the end
+     of the serial clause.  */
+  append_to_statement_list_force (fold_build2 (MODIFY_EXPR,
+					       void_type_node,
+					       range->clause_result_decl,
+					       last_expr),
+				  &range->stmt_list);
+  tsi_delink (&i);
+  append_to_statement_list_force (fold_build1 (GOTO_EXPR, void_type_node,
+					       range->clause_exit_label_decl),
+				  &range->stmt_list);
+  range->has_completers = true;
+}
+
+/* Get the context of the current range.  */
+
+tree
+a68_range_context (void)
+{
+  gcc_assert (current_range != NULL);
+  return current_range->context;
+}
+
+/* Get the list of declarations in the current range.  */
+
+tree
+a68_range_names (void)
+{
+  struct range *range = current_range;
+
+  while (range->frameless && range->next != NULL)
+    range = range->next;
+
+  if (range != NULL)
+    return range->names;
+  else
+    return NULL_TREE;
+}
+
+/* Get the statements list of the current range.  */
+
+tree
+a68_range_stmt_list (void)
+{
+  gcc_assert (current_range != NULL);
+  return current_range->stmt_list;
+}
+
+/* Push a range for a function.  */
+
+void
+a68_push_function_range (tree fndecl, tree result_type,
+			 bool top_level)
+{
+  a68_push_range (NULL /* VOID */);
+  current_range->fndecl = fndecl;
+  current_range->top_level_function = top_level;
+  current_range->context = fndecl;
+
+  /* Setup the result declaration.  */
+  tree resdecl = build_decl (UNKNOWN_LOCATION,
+			     RESULT_DECL,
+			     get_identifier ("resdecl%"),
+			     result_type);
+  DECL_ARTIFICIAL (resdecl) = 1;
+  DECL_IGNORED_P (resdecl) = 1;
+  DECL_CONTEXT (resdecl) = fndecl;
+  DECL_RESULT (fndecl) = resdecl;
+  rest_of_decl_compilation (fndecl, 1, 0);
+  make_decl_rtl (fndecl);
+  allocate_struct_function (fndecl, false);
+
+  /* Let GCC know the current scope is this function.  */
+  current_function_decl = fndecl;
+}
+
+/* Pop a range for a function.  */
+
+void
+a68_pop_function_range (tree body)
+{
+  tree fndecl = current_range->fndecl;
+  bool top_level = current_range->top_level_function;
+
+  if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
+    {
+      a68_add_stmt (body);
+    }
+  else
+    {
+      /* Append the return statement.
+	 Note that this does the copy of the returned value.  */
+      tree return_stmt = fold_build1 (RETURN_EXPR,
+				      void_type_node,
+				      fold_build2 (MODIFY_EXPR,
+						   TREE_TYPE (DECL_RESULT (fndecl)),
+						   DECL_RESULT (fndecl),
+						   a68_low_dup (body, true /* use_heap */)));
+      a68_add_stmt (return_stmt);
+    }
+
+  /* Set the body of the function.  */
+  DECL_SAVED_TREE (fndecl) = a68_pop_range ();
+
+  /* Output the GENERIC tree for the function..  */
+  dump_function (TDI_original, fndecl);
+  /* This compiles the function all the way to assembler language output.
+     Nested functions are finalized when the containing top-level function is
+     finalized.  */
+  if (top_level || a68_in_global_range ())
+    cgraph_node::finalize_function (fndecl, true);
+  else
+    /* Register this function with cgraph just far enough to get it added to
+       our parent's nested function list.  */
+    (void) cgraph_node::get_create (fndecl);
+
+  /* Let GCC know the current scope has changed.  */
+  current_function_decl = NULL_TREE;
+  for (struct range *r = current_range; r; r = r->next)
+    {
+      if (r->fndecl != NULL_TREE)
+	current_function_decl = r->fndecl;
+    }
+}
+
+/* Push a range for a serial clause.
+
+    label1:                 BIND_EXPR_BODY (STATEMENT_LIST (
+     expr1;                  label1,
+     expr2                   expr1,
+   exit label2:              clause_result = expr2,
+     expr3;                  goto exit_label,
+     expr4                   label2,
+   exit label3:              expr3,
+     expr5                   clause_result = expr4,
+                             goto exit_label,
+                             label3,
+                             clause_result = expr5,
+                             exit_label,
+			     clause_result)) */
+
+void
+a68_push_serial_clause_range (MOID_T *clause_mode,
+			      bool save_restore_stack)
+{
+  /* Get the type of the enclosing clause.  */
+  tree clause_type = CTYPE (clause_mode);
+
+  /* If the serial clause has declarations that involve dynamic allocation, and
+     the environ it establishes is local, then save the stack pointer.  */
+  if (save_restore_stack)
+    {
+      a68_push_range (clause_mode);
+      current_range->save_restore_stack = true;
+
+      tree outer_clause_result_decl = build_decl (UNKNOWN_LOCATION,
+						  VAR_DECL,
+						  NULL, /* Set below.  */
+						  clause_type);
+      char *outer_clause_result_name = xasprintf ("outer_clause_result%d%%",
+						  DECL_UID (outer_clause_result_decl));
+      DECL_NAME (outer_clause_result_decl) = get_identifier (outer_clause_result_name);
+      free (outer_clause_result_name);
+      current_range->clause_result_decl = outer_clause_result_decl;
+      a68_add_decl (outer_clause_result_decl);
+
+      /* Variable used to save the stack pointer.  */
+      tree stack_save_decl = build_decl (UNKNOWN_LOCATION,
+					 VAR_DECL,
+					 get_identifier ("stack_save%"),
+					 build_pointer_type (char_type_node));
+      current_range->clause_stack_save_decl = stack_save_decl;
+      a68_add_decl (stack_save_decl);
+      a68_add_stmt (fold_build1 (DECL_EXPR,
+				 TREE_TYPE (stack_save_decl),
+				 stack_save_decl));
+
+      /* Save stack pointer.  */
+      tree call = builtin_decl_implicit (BUILT_IN_STACK_SAVE);
+      call = build_call_expr_loc (UNKNOWN_LOCATION, call, 0);
+      a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+				 stack_save_decl, call));
+    }
+
+  /* Push a new range.  */
+  a68_push_range (clause_mode);
+  current_range->save_restore_stack = save_restore_stack;
+
+  /* Create a decl for clause_result with the right type and add it to the
+     block's declaration list.  */
+  tree clause_result_decl = build_decl (UNKNOWN_LOCATION,
+					VAR_DECL,
+					NULL, /* Set below.  */
+					clause_type);
+  char *clause_result_name = xasprintf ("clause_result%d%%", DECL_UID (clause_result_decl));
+  DECL_NAME (clause_result_decl) = get_identifier (clause_result_name);
+  free (clause_result_name);
+  DECL_INITIAL (clause_result_decl) = a68_get_skip_tree (clause_mode);
+  DECL_CONTEXT (clause_result_decl) = current_range->context;
+  current_range->clause_result_decl = clause_result_decl;
+
+  /* Create a decl for the clause's exit label.  */
+  tree clause_exit_label_decl = build_decl (UNKNOWN_LOCATION,
+					    LABEL_DECL,
+					    NULL, /* Set below.  */
+					    void_type_node);
+  char *exit_label_name = xasprintf ("clause_exit_label%d%%", DECL_UID (clause_exit_label_decl));
+  DECL_NAME (clause_exit_label_decl) = get_identifier (exit_label_name);
+  free (exit_label_name);
+  DECL_CONTEXT (clause_exit_label_decl) = current_range->context;
+  current_range->clause_exit_label_decl = clause_exit_label_decl;
+}
+
+/* Pop a range for a serial clause and return the resulting bind
+   expression.  */
+
+tree
+a68_pop_serial_clause_range (void)
+{
+  struct range *range = current_range;
+  MOID_T *clause_mode = range->mode;
+  tree clause_type = CTYPE (clause_mode);
+
+  /* The last expression in the statements list is either a single unit or a
+     labeled unit.  Consolidate it to a ref if required by the mode of the
+     serial clause.  */
+  {
+    tree_stmt_iterator si = tsi_last (range->stmt_list);
+    tree last_expr = tsi_stmt (si);
+    if (TREE_CODE (last_expr) == COMPOUND_EXPR
+	&& TREE_CODE (TREE_OPERAND (last_expr, 0)) == LABEL_EXPR)
+      {
+	TREE_OPERAND (last_expr, 1) = a68_consolidate_ref (range->mode,
+							   TREE_OPERAND (last_expr, 1));
+	TREE_TYPE (last_expr) = TREE_TYPE (TREE_OPERAND (last_expr, 1));
+      }
+    else
+      last_expr = a68_consolidate_ref (range->mode, last_expr);
+    a68_add_stmt (last_expr);
+    tsi_delink (&si);
+  }
+
+  /* If the serial clause has completers, we have to make use of the
+     clause_result% and clause_exit_label% mechanism to assure the statements
+     list has a single exit at the end.  */
+  if (range->has_completers)
+    {
+      /* First prepend EXPR_DECL expressions for clause_result% and
+	 clause_exit_label% */
+      {
+	tree_stmt_iterator si = tsi_start (range->stmt_list);
+	tsi_link_before (&si,
+			 fold_build1 (DECL_EXPR,
+				      TREE_TYPE (range->clause_result_decl),
+				      range->clause_result_decl),
+			 TSI_CONTINUE_LINKING);
+	tsi_link_before (&si,
+			 fold_build1 (DECL_EXPR,
+				      TREE_TYPE (range->clause_exit_label_decl),
+				      range->clause_exit_label_decl),
+			 TSI_CONTINUE_LINKING);
+      }
+
+      /* Then turn the last expression in stmt_list to an assignment to
+	 clause_result_decl%, but don't bother if it has been voided.  */
+      if (clause_type != a68_void_type)
+	{
+	  tree_stmt_iterator si = tsi_last (range->stmt_list);
+	  tree last_expr = tsi_stmt (si);
+
+	  a68_add_stmt (build2 (MODIFY_EXPR,
+				clause_type,
+				range->clause_result_decl,
+				last_expr));
+	  tsi_delink (&si);
+	}
+
+      a68_add_decl (range->clause_result_decl);
+      a68_add_decl (range->clause_exit_label_decl);
+
+      /* Finally append the exit label and last expression with
+	 result_decl.  */
+      a68_add_stmt (build1 (LABEL_EXPR, void_type_node, range->clause_exit_label_decl));
+      a68_add_stmt (build1 (NON_LVALUE_EXPR, clause_type, range->clause_result_decl));
+    }
+
+  /* Check that the type of the last statement in the statements list is the
+     same than the type corresponding to the clause mode.  */
+  {
+    tree_stmt_iterator si = tsi_last (range->stmt_list);
+    if (TREE_TYPE (tsi_stmt (si)) != clause_type
+	/* But NIL can appear in a context expecting VOID with no widening.  */
+	&& !(clause_type == a68_void_type
+	     && POINTER_TYPE_P (TREE_TYPE (tsi_stmt (si)))
+	     && TREE_CODE (tsi_stmt (si)) == INTEGER_CST
+	     && tree_to_shwi (tsi_stmt (si)) == 0)
+	/* And any row type is valid when M_ROWS is expected.  */
+	&& !(A68_ROWS_TYPE_P (clause_type)
+	     && A68_ROWS_TYPE_P (TREE_TYPE (tsi_stmt (si))))
+	/* Do not rely on comparing pointer types, as the equality fails in
+	   that case.  We need a better way of comparing types, either using
+	   TYPE_CANONICAL or caching.  */
+	&& !(POINTER_TYPE_P (TREE_TYPE (tsi_stmt (si))) && POINTER_TYPE_P (clause_type)))
+      {
+	printf ("last statement:\n");
+	debug_tree (tsi_stmt (si));
+	printf ("expected type:\n");
+	debug_tree (clause_type);
+	gcc_unreachable ();
+      }
+  }
+
+  /* If the serial clause has declarations that involve dynamic allocation, and
+     the environ it establishes is local, then restore the stack pointer.  */
+  if (range->save_restore_stack)
+    {
+      /* Turn last expression of inner clause into a modify statement.  This
+	 may involve a copy.  This can be omitted if the serial clause yields
+	 void.  */
+      if (clause_type != a68_void_type)
+	{
+	  tree_stmt_iterator si = tsi_last (range->stmt_list);
+	  tree last_expr = tsi_stmt (si);
+
+	  a68_add_stmt (build2 (MODIFY_EXPR,
+				clause_type,
+				range->next->clause_result_decl,
+				a68_low_dup (last_expr)));
+	  tsi_delink (&si);
+	}
+
+      /* Finish inner clause, restoring stack pointer on finalizing.  */
+      tree restore_sp = builtin_decl_implicit (BUILT_IN_STACK_RESTORE);
+      restore_sp = build_call_expr_loc (UNKNOWN_LOCATION, restore_sp, 1,
+					current_range->next->clause_stack_save_decl);
+      a68_add_stmt (a68_pop_range_with_finalizer (restore_sp));
+      /* The result value is now in clause_result_decl.  */
+      a68_add_stmt (build1 (NON_LVALUE_EXPR, clause_type,
+			    current_range->clause_result_decl));
+    }
+
+  return a68_pop_range ();
+}
+
+/* Whether the current range is the global range.  */
+
+bool
+a68_in_global_range (void)
+{
+  return current_range == global_range;
+}
+
+/* Initialize ranges.  */
+
+void
+a68_init_ranges (void)
+{
+  global_range = new_range ();
+  global_range->context = build_translation_unit_decl (NULL);
+  current_range = global_range;
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 37/47] a68: low: units and coercions
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (35 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 36/47] a68: low: ranges Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 38/47] a68: low: modes Jose E. Marchesi
                   ` (10 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-low-coercions.cc: New file.
	* algol68/a68-low-generator.cc: Likewise.
	* algol68/a68-low-units.cc: Likewise.
---
 gcc/algol68/a68-low-coercions.cc |  471 ++++++++++++
 gcc/algol68/a68-low-generator.cc |  533 +++++++++++++
 gcc/algol68/a68-low-units.cc     | 1191 ++++++++++++++++++++++++++++++
 3 files changed, 2195 insertions(+)
 create mode 100644 gcc/algol68/a68-low-coercions.cc
 create mode 100644 gcc/algol68/a68-low-generator.cc
 create mode 100644 gcc/algol68/a68-low-units.cc

diff --git a/gcc/algol68/a68-low-coercions.cc b/gcc/algol68/a68-low-coercions.cc
new file mode 100644
index 00000000000..b9e1acee9ce
--- /dev/null
+++ b/gcc/algol68/a68-low-coercions.cc
@@ -0,0 +1,471 @@
+/* Lower Algol 68 coercions to GENERIC.
+   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"
+
+/* Lower a dereferencing coercion.  */
+tree
+a68_lower_dereferencing (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_low_deref (a68_lower_tree (SUB (p), ctx), SUB (p));
+}
+
+/* Lower an uniting coercion.  */
+
+tree
+a68_lower_uniting (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree coercend_tree = a68_lower_tree (SUB (p), ctx);
+
+  if (MOID (p) == M_ROWS)
+    {
+      /* ROWS is a mode to which any ROW mode can be strongly coerced.  It is
+	 used as the mode of the second operand of the ELEMS, LWB and UPB
+	 operators.  The coercion is expressed in the parse tree via uniting.
+	 This results in replacing the multiple with a "rows" value that
+	 contains dimension and bounds information.  */
+      if (A68_ROW_TYPE_P (TREE_TYPE (coercend_tree)))
+	return a68_rows_value (coercend_tree);
+      else if (A68_UNION_TYPE_P (TREE_TYPE (coercend_tree)))
+	{
+	  /* coercend_tree is expanded more than once below.  */
+	  coercend_tree = save_expr (coercend_tree);
+
+	  /* Union of row modes.  We should create a rows value for the currently
+	     selected value.  */
+	  a68_push_range (M_ROWS);
+	  tree done_label = build_decl (UNKNOWN_LOCATION,
+					LABEL_DECL,
+					get_identifier ("done_label%"),
+					void_type_node);
+	  DECL_CONTEXT (done_label) = a68_range_context ();
+	  a68_add_decl (done_label);
+	  a68_add_decl_expr (fold_build1 (DECL_EXPR, TREE_TYPE (done_label), done_label));
+	  tree rows = a68_lower_tmpvar ("rows%", CTYPE (M_ROWS),
+					a68_get_skip_tree (M_ROWS));
+	  tree coercend_overhead = a68_union_overhead (coercend_tree);
+	  tree overhead = a68_lower_tmpvar ("overhead%", TREE_TYPE (coercend_overhead),
+					    coercend_overhead);
+	  int field_index = 0;
+	  for (tree field = TYPE_FIELDS (TREE_TYPE (a68_union_cunion (coercend_tree)));
+	       field;
+	       field = DECL_CHAIN (field))
+	    {
+	      a68_push_range (M_VOID);
+	      {
+		/* Set rows% to the rows value computed from coercend_tree.FIELD,
+		   which is of some multiple type.  */
+		a68_add_stmt (fold_build2 (MODIFY_EXPR, CTYPE (M_ROWS),
+					   rows,
+					   a68_rows_value (a68_union_alternative (coercend_tree,
+										  field_index))));
+		a68_add_stmt (fold_build1 (GOTO_EXPR, void_type_node, done_label));
+		a68_add_stmt (a68_get_skip_tree (M_VOID));
+	      }
+	      tree process_entry = a68_pop_range ();
+
+	      /* IF overhead = field_index THEN rows% = rows_from_multiple FI */
+	      a68_add_stmt (fold_build3 (COND_EXPR,
+					 a68_void_type,
+					 fold_build2 (EQ_EXPR,
+						      TREE_TYPE (overhead),
+						      overhead,
+						      build_int_cst (TREE_TYPE (overhead), field_index)),
+					 process_entry,
+					 a68_get_skip_tree (M_VOID)));
+	      field_index += 1;
+	    }
+
+	  /* This should not be reached.  Emit run-time error.  */
+	  {
+	    unsigned int lineno = NUMBER (LINE (INFO (p)));
+	    const char *filename_str = FILENAME (LINE (INFO (p)));
+	    tree filename = build_string_literal (strlen (filename_str) + 1,
+						  filename_str);
+	    tree call = a68_build_libcall (A68_LIBCALL_UNREACHABLE,
+					   void_type_node, 2,
+					   filename,
+					   build_int_cst (unsigned_type_node, lineno));
+	    a68_add_stmt (call);
+	  }
+
+	  a68_add_stmt (build1 (LABEL_EXPR, void_type_node, done_label));
+	  a68_add_stmt (rows);
+	  return a68_pop_range ();
+	}
+      else
+	{
+	  debug_tree (TREE_TYPE (coercend_tree));
+	  gcc_assert (A68_ROWS_TYPE_P (TREE_TYPE (coercend_tree)));
+	  return coercend_tree;
+	}
+    }
+  else if (IS_UNION (MOID (SUB (p))))
+    {
+      /* We have to extract the value of the coercend union.  */
+      a68_push_range (MOID (p));
+      {
+	MOID_T *coercend_mode = MOID (SUB (p));
+	MOID_T *coercee_mode = MOID (p);
+
+	/* Temporaries for the coercend's components.  */
+	tree coercend = a68_lower_tmpvar ("coercend%", TREE_TYPE (coercend_tree), coercend_tree);
+	tree cval = a68_union_cunion (coercend);
+	tree coverhead = a68_union_overhead (coercend);
+	tree coercend_value = a68_lower_tmpvar ("coercend_value%", TREE_TYPE (cval), cval);
+	tree coercend_overhead = a68_lower_tmpvar ("coercend_overhead%", sizetype, coverhead);
+
+	/* Create the coercee.  */
+	tree coercee = a68_lower_tmpvar ("coercee%",
+					 CTYPE (MOID (p)),
+					 a68_get_skip_tree (MOID (p)));
+	tree coercee_value = a68_union_cunion (coercee);
+
+	/* First translate overhead.  This is crude, but it works.  */
+	int idx = 0;
+	tree coercee_overhead = size_zero_node;
+	while (EQUIVALENT (coercend_mode) != NO_MOID)
+	  coercend_mode = EQUIVALENT (coercend_mode);
+	for (PACK_T *pack = PACK (coercend_mode); pack != NO_PACK; FORWARD (pack))
+	  {
+	    coercee_overhead = fold_build3 (COND_EXPR,
+					    sizetype,
+					    fold_build2 (EQ_EXPR,
+							 sizetype,
+							 coercend_overhead,
+							 size_int (idx)),
+					    size_int (a68_united_mode_index (coercee_mode, MOID (pack))),
+					    coercee_overhead);
+	    idx++;
+	  }
+	a68_add_stmt (a68_union_set_overhead (coercee, coercee_overhead));
+
+	/* Now copy over the value.  This of course relies on the fact the
+	   value of the coercend is smaller or of the same size than the value
+	   of the built union.  */
+	a68_add_stmt (a68_lower_memcpy (fold_build1 (ADDR_EXPR,
+						     build_pointer_type (TREE_TYPE (coercee_value)),
+						     coercee_value),
+					fold_build1 (ADDR_EXPR,
+						     build_pointer_type (TREE_TYPE (coercend_value)),
+						     coercend_value),
+					size_in_bytes (TREE_TYPE (coercend_value))));
+	a68_add_stmt (coercee);
+      }
+      return a68_pop_range ();
+    }
+  else
+    {
+      /* Produce a united mode one of whose component modes is the mode of the
+	 coercend.  */
+      return a68_union_value (MOID (p), coercend_tree, MOID (SUB (p)));
+    }
+}
+
+/* Lower a rowing coercion.  */
+
+tree
+a68_lower_rowing (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *mode = MOID (p);
+  bool did_deref = false;
+
+  /* If the primary is a REF, we need to dereference it to get the referred
+     value.  */
+  tree primary = NULL_TREE;
+  tree orig_primary = NULL_TREE;
+  MOID_T *target_mode = NO_MOID;
+  if (IS_REF (mode))
+    {
+      gcc_assert (IS_REF (MOID (SUB (p))));
+      did_deref = true;
+      target_mode = SUB (mode);
+
+      a68_push_range (mode);
+      /* Note that we have to consolidate because we need a pointer to compare
+	 to NIL below.  */
+      orig_primary = a68_lower_tmpvar ("orig_primary%",
+				       CTYPE (MOID (SUB (p))),
+				       a68_consolidate_ref (MOID (SUB (p)),
+							    a68_lower_tree (SUB (p), ctx)));
+      primary = a68_low_deref (orig_primary, SUB (p));
+    }
+  else
+    {
+      target_mode = mode;
+      primary = a68_lower_tree (SUB (p), ctx);
+      /* The primary gets expanded more than once below.  */
+      primary = save_expr (primary);
+    }
+
+  /* Perform the rowing in the primary. */
+  tree ssize_one_node = fold_convert (ssizetype, size_one_node);
+  tree rowed_primary = NULL_TREE;
+  if (DIM (DEFLEX (target_mode)) >= 2)
+    {
+      /* []A -> [,]A  */
+
+      /* First determine the number of dimensions of the resulting
+	 multiple.  */
+      tree primary_dimensions = a68_multiple_dimensions (primary);
+      gcc_assert (TREE_CODE (primary_dimensions) == INTEGER_CST);
+      int dim = tree_to_shwi (primary_dimensions) + 1;
+
+      /* Compute bounds.  */
+      tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+      tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+
+      lower_bounds[0] = ssize_one_node;
+      upper_bounds[0] = ssize_one_node;
+      for (int d = 1; d < dim; ++d)
+	{
+	  lower_bounds[d] = a68_multiple_lower_bound (primary, ssize_int (d - 1));
+	  upper_bounds[d] = a68_multiple_upper_bound (primary, ssize_int (d - 1));
+	}
+
+      rowed_primary = a68_row_value (CTYPE (target_mode), dim,
+				     a68_multiple_elements (primary),
+				     a68_multiple_elements_size (primary),
+				     lower_bounds, upper_bounds);
+      free (lower_bounds);
+      free (upper_bounds);
+    }
+  else
+    {
+      /* A -> []A  */
+      tree row_type = CTYPE (target_mode);
+      tree lower_bound = ssize_one_node;
+      tree upper_bound = ssize_one_node;
+      tree elements = (did_deref
+		       ? orig_primary
+		       : fold_build1 (ADDR_EXPR,
+				      build_pointer_type (TREE_TYPE (primary)),
+				      build_constructor_va (build_array_type (TREE_TYPE (primary),
+									      build_index_type (size_zero_node)),
+							    1, size_zero_node,  primary)));
+      tree elements_type = a68_row_elements_type (row_type);
+      tree elements_size = size_in_bytes (elements_type);
+      rowed_primary = a68_row_value (row_type, 1,
+				     elements, elements_size,
+				     &lower_bound, &upper_bound);
+    }
+
+  /* Build a ref if we rowed a ref.  */
+  if (did_deref)
+    {
+      tree pointer_type = build_pointer_type (TREE_TYPE (rowed_primary));
+      rowed_primary = fold_build1 (ADDR_EXPR, pointer_type, rowed_primary);
+      /* Rowing NIL yields NIL.  */
+      rowed_primary = fold_build3_loc (a68_get_node_location (p),
+				       COND_EXPR,
+				       pointer_type,
+				       fold_build2 (EQ_EXPR,
+						    pointer_type,
+						    fold_convert (pointer_type, orig_primary),
+						    build_int_cst (pointer_type, 0)),
+				       build_int_cst (pointer_type, 0),
+				       rowed_primary);
+      a68_add_stmt (rowed_primary);
+      rowed_primary = a68_pop_range ();
+    }
+
+  return rowed_primary;
+}
+
+/* Lower a widening coercion.
+
+   Widening allows the following conversions of mode:
+
+   LONGSETY INT to LONGSETY REAL
+   LONGSETY REAL to LONGSETY COMPL
+   LONGSETY BITS to []BOOL
+   LONGSETY BYTES to []CHAR  */
+
+tree
+a68_lower_widening (NODE_T *p, LOW_CTX_T ctx)
+{
+  if (MOID (p) == M_REAL
+      || MOID (p) == M_LONG_REAL
+      || MOID (p) == M_LONG_LONG_REAL)
+    {
+      return convert_to_real (CTYPE (MOID (p)), a68_lower_tree (SUB (p), ctx));
+    }
+  if (MOID (p) == M_COMPLEX
+      || MOID (p) == M_LONG_COMPLEX
+      || MOID (p) == M_LONG_LONG_COMPLEX)
+    {
+      return a68_complex_widen_from_real (MOID (p),
+					  a68_lower_tree (SUB (p), ctx));
+    }
+  else if (MOID (p) == M_ROW_BOOL)
+    {
+      /* Widen a LONGSETY BITS to a row of BOOLs.  */
+      tree coercend = a68_lower_tree (SUB (p), ctx);
+      tree coercend_type = TREE_TYPE (coercend);
+      HOST_WIDE_INT bits_size = int_size_in_bytes (coercend_type);
+      gcc_assert (bits_size != -1);
+      bits_size = bits_size * 8;
+
+      tree pointer_to_bool_type = build_pointer_type (a68_bool_type);
+      a68_push_range (M_ROW_BOOL);
+      /* First allocate space for the elements.  */
+      tree elements = a68_lower_tmpvar ("elements%",
+					pointer_to_bool_type,
+					a68_lower_alloca (a68_bool_type,
+							  fold_build2 (MULT_EXPR,
+								       sizetype,
+								       size_int (bits_size),
+								       size_in_bytes (a68_bool_type))));
+
+      /* Set the elements, each element is a BOOL which is TRUE if the
+	 corresponding bit in the coercend is set, FALSE otherwise.  */
+      tree coercend_one_node = build_int_cst (coercend_type, 1);
+      coercend = save_expr (coercend);
+      for (HOST_WIDE_INT bit = 0; bit < bits_size; ++bit)
+	{
+	  tree offset = fold_build2 (MULT_EXPR, sizetype,
+				     size_int (bit), size_in_bytes (a68_bool_type));
+	  tree bit_set = fold_convert (a68_bool_type,
+				       fold_build2 (BIT_AND_EXPR, coercend_type,
+						    fold_build2 (RSHIFT_EXPR, coercend_type,
+								 coercend,
+								 build_int_cst (coercend_type,
+										bits_size - 1 - bit)),
+						    coercend_one_node));
+
+	  a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				     a68_bool_type,
+				     fold_build2 (MEM_REF,
+						  a68_bool_type,
+						  fold_build2 (POINTER_PLUS_EXPR,
+							       pointer_to_bool_type,
+							       elements,
+							       offset),
+						  fold_convert (pointer_to_bool_type,
+								integer_zero_node)),
+				     bit_set));
+	}
+
+      /* Create multiple.  */
+      tree lower_bound = ssize_int (1);
+      tree upper_bound = ssize_int (bits_size);
+      tree elements_size = fold_build2 (MULT_EXPR, sizetype,
+					size_int (bits_size),
+					size_in_bytes (a68_bool_type));
+      tree multiple = a68_row_value (CTYPE (M_ROW_BOOL), 1 /* dim */,
+				     elements, elements_size,
+				     &lower_bound, &upper_bound);
+      a68_add_stmt (multiple);
+      return a68_pop_range ();
+    }
+  else
+    {
+      fatal_error (a68_get_node_location (p),
+		   "cannot do widening from %s to %s",
+		   a68_moid_to_string (MOID (SUB (p)), MOID_ERROR_WIDTH, SUB (p)),
+		   a68_moid_to_string (MOID (p), MOID_ERROR_WIDTH, p));
+      gcc_unreachable ();
+    }
+}
+
+/* Lower a voiding coercion.
+
+   The voiding lowers into a compound expression with the voided expression
+   (for side-effects) and returns EMPTY.  */
+
+tree
+a68_lower_voiding (NODE_T *p, LOW_CTX_T ctx)
+{
+  return fold_build2_loc (a68_get_node_location (p),
+			  COMPOUND_EXPR,
+			  a68_void_type,
+			  a68_lower_tree (SUB (p), ctx),
+			  a68_get_empty ());
+}
+
+/* Lower a proceduring coercion.
+
+     proceduring : jump.
+
+   In the Revised language only jump statements can be procedured.  The
+   coercion results in a new function whose body is the jump instruction.  */
+
+tree
+a68_lower_proceduring (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree jump = a68_lower_tree (SUB (p), ctx);
+
+  tree procedured_goto = a68_make_anonymous_routine_decl (MOID (p));
+  a68_add_decl (procedured_goto);
+  a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
+				      DECL_EXPR,
+				      TREE_TYPE (procedured_goto),
+				      procedured_goto));
+  announce_function (procedured_goto);
+
+  a68_push_function_range (procedured_goto, CTYPE (SUB (MOID (p))));
+  a68_pop_function_range (jump);
+  return fold_build1 (ADDR_EXPR,
+		      build_pointer_type (TREE_TYPE (procedured_goto)),
+		      procedured_goto);
+}
+
+/* Lower a deproceduring coercion.
+   The deproceduring lowers into a call expression.  */
+
+tree
+a68_lower_deproceduring (NODE_T *p, LOW_CTX_T ctx)
+{
+  tree func = a68_lower_tree (SUB (p), ctx);
+
+  if (POINTER_TYPE_P (TREE_TYPE (func)))
+    {
+      if (TREE_CODE (func) == ADDR_EXPR)
+	func = TREE_OPERAND (func, 0);
+      else
+	func = fold_build1 (INDIRECT_REF,
+			    TREE_TYPE (TREE_TYPE (func)),
+			    func);
+    }
+
+  return build_call_expr_loc (a68_get_node_location (p), func, 0);
+}
diff --git a/gcc/algol68/a68-low-generator.cc b/gcc/algol68/a68-low-generator.cc
new file mode 100644
index 00000000000..5c4d65569b3
--- /dev/null
+++ b/gcc/algol68/a68-low-generator.cc
@@ -0,0 +1,533 @@
+/* Lower generators.
+   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"
+
+
+typedef tree (*allocator_t) (tree, tree);
+
+/* Lower to code that fill in BOUNDS and elements pointers in the given buffer
+   pointed by BUFFER at offset OFFSET according to the mode MODE, and evals to
+   BUFFER.  */
+
+static tree
+fill_in_buffer (tree buffer, tree offset, tree_stmt_iterator *bounds, MOID_T *m,
+		allocator_t allocator)
+{
+  tree filler = NULL_TREE;
+  tree type = CTYPE (m);
+  tree pointer_type = build_pointer_type (type);
+
+  a68_push_stmt_list (M_VOID);
+
+  if (m == M_INT || m == M_BOOL || m == M_CHAR || m == M_REAL || IS_REF (m))
+    {
+      tree val_address = fold_build2 (POINTER_PLUS_EXPR, pointer_type, buffer, offset);
+      tree init_val = a68_get_skip_tree (m);
+      tree modify = fold_build2 (MODIFY_EXPR,
+				 type,
+				 fold_build1 (INDIRECT_REF, type, val_address),
+				 init_val);
+      a68_add_stmt (modify);
+    }
+  else if (!HAS_ROWS (m))
+    {
+      /* This mode has no rows.  We can just fill in with zeroes, which
+	 translates into SKIP values for all possibly contained types.  */
+      tree call = builtin_decl_explicit (BUILT_IN_MEMSET);
+      call = build_call_expr_loc (UNKNOWN_LOCATION, call, 3,
+				  buffer,
+				  integer_zero_node,
+				  fold_convert (sizetype, size_in_bytes (CTYPE (m))));
+      a68_add_stmt (call);
+    }
+  else if (m == M_STRING)
+    {
+      /* Strings are rows but handled especially as they are created empty and
+	 don't feature bounds in the formal declarer.  */
+
+      /* First the descriptor.  */
+      tree pointer_byte_size = size_int (POINTER_SIZE / BITS_PER_UNIT);
+      tree lb_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+      a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+				 fold_build1 (INDIRECT_REF, ssizetype, lb_address),
+				 ssize_int (1)));
+      offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size);
+      tree ub_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+      a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+				 fold_build1 (INDIRECT_REF, ssizetype, ub_address),
+				 ssize_int (0)));
+      offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size);
+      tree stride_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+      a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+				 fold_build1 (INDIRECT_REF, sizetype, stride_address),
+				 size_in_bytes (a68_char_type)));
+
+      /* The data is an empty string, i.e NULL.  */
+      offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size);
+      tree elems_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+      a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+				 fold_build1 (INDIRECT_REF, build_pointer_type (a68_char_type),
+					      elems_address),
+				 build_int_cst (build_pointer_type (a68_char_type), 0)));
+
+      /* The size of the elements is zero.  */
+      offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size);
+      tree elems_size_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+      a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+				 fold_build1 (INDIRECT_REF, build_pointer_type (a68_char_type),
+					      elems_size_address),
+				 size_zero_node));
+    }
+  else if (A68_ROW_TYPE_P (type))
+    {
+      /* If the row mode is flexible we can deflex it now: these also must have
+	 bounds specified for them, with the only exception of strings/flexible
+	 rows of chars, which are handled above.  Note we cannot use DEFLEXED
+	 here because that contains the fully deflexed mode.  For example,
+	 DEFLEXED returns [][]INT for FLEX[]FLEX[]INT, and we want []FLEX[]INT
+	 instead.  */
+      if (IS_FLEX (m))
+	m = SUB (m);
+
+      /* Consume two bounds from BOUNDS for each dimension and patch them at
+	 their right offsets.  Note that we have to process from upper
+	 dimension to lower dimension so we can calculate the stride as we
+	 go.  */
+      size_t dim = DIM (m);
+
+      /* Collect lower and upper bounds and calculate the number of elements of
+	 the multiple.  */
+      tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+      tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * dim);
+      tree num_elems = NULL_TREE;
+      for (size_t i = 0; i < dim; ++i)
+	{
+	  /* Note we have to convert the bounds from CTYPE(M_INT) to
+	     ssizetype.  */
+	  lower_bounds[i] = fold_convert (ssizetype, save_expr (tsi_stmt (*bounds)));
+	  tsi_next (bounds);
+	  upper_bounds[i] = fold_convert (ssizetype, save_expr (tsi_stmt (*bounds)));
+	  tsi_next (bounds);
+
+	  tree dim_num_elems
+	    = fold_build2 (PLUS_EXPR, sizetype,
+			   fold_convert (sizetype,
+					 fold_build2 (MINUS_EXPR, ssizetype,
+						      upper_bounds[i], lower_bounds[i])),
+			   size_one_node);
+	  dim_num_elems = fold_build3 (COND_EXPR,
+				       sizetype,
+				       fold_build2 (LT_EXPR, ssizetype,
+						    upper_bounds[i], lower_bounds[i]),
+				       size_zero_node,
+				       dim_num_elems);
+	  if (num_elems == NULL_TREE)
+	    num_elems = dim_num_elems;
+	  else
+	    num_elems = fold_build2 (MULT_EXPR, sizetype, num_elems, dim_num_elems);
+	}
+
+      /* Calculate strides.  */
+      tree *strides = (tree *) xmalloc (sizeof (tree) * dim);
+      a68_multiple_compute_strides (type, dim, lower_bounds, upper_bounds, strides);
+
+      /* Now emit instructions to patch the bounds and strides.  */
+      tree pointer_byte_size = size_int (POINTER_SIZE / BITS_PER_UNIT);
+      for (size_t i = 0; i < dim; ++i)
+	{
+	  /* Lower bound.  */
+	  tree lb_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+	  a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				     void_type_node,
+				     fold_build1 (INDIRECT_REF, ssizetype, lb_address),
+				     lower_bounds[i]));
+	  /* Upper bound.  */
+	  offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size);
+	  tree ub_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+	  a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				     void_type_node,
+				     fold_build1 (INDIRECT_REF, ssizetype, ub_address),
+				     upper_bounds[i]));
+	  /* Stride.  */
+	  offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size);
+	  tree stride_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+	  a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				     void_type_node,
+				     fold_build1 (INDIRECT_REF, sizetype, stride_address),
+				     strides[i]));
+	  offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size);
+	}
+      free (lower_bounds);
+      free (upper_bounds);
+      free (strides);
+
+      /* Now allocate space for the elements.  */
+      MOID_T *elem_mode = SUB (m);
+      tree elem_size = fold_convert (sizetype, size_in_bytes (CTYPE (elem_mode)));
+      tree elems_size = save_expr (fold_build2 (MULT_EXPR, sizetype, elem_size, num_elems));
+      tree elemsptr = (*allocator) (CTYPE (elem_mode), elems_size);
+      elemsptr = save_expr (elemsptr);
+
+      /* And initialize them.  */
+      if (elem_mode == M_INT || elem_mode == M_BOOL || elem_mode == M_CHAR
+	  || elem_mode == M_REAL || IS_REF (elem_mode))
+	{
+	  /* Memsetting the buffer with either zeroes or ones satisfies the
+	     SKIP value for these modes.  */
+	  tree call = builtin_decl_explicit (BUILT_IN_MEMSET);
+	  call = build_call_expr_loc (UNKNOWN_LOCATION, call, 3,
+				      elemsptr,
+				      integer_zero_node,
+				      elems_size);
+	  a68_add_stmt (call);
+	}
+      else
+	{
+	  /* Recurse in a loop to fill in elements.  */
+	  a68_push_range (NULL);
+	  tree num_elems_var = a68_lower_tmpvar ("numelems%", size_type_node,
+						 num_elems);
+	  tree index = a68_lower_tmpvar ("index%", size_type_node, size_zero_node);
+	  tree elems_var = a68_lower_tmpvar ("elems%", TREE_TYPE (elemsptr),
+					     elemsptr);
+	  tree elem_offset = a68_lower_tmpvar ("elem_offset%", size_type_node,
+					       size_zero_node);
+
+	  /* Begin of loop body.  */
+	  a68_push_range (NULL);
+	  a68_add_stmt (fold_build1 (EXIT_EXPR,
+				     void_type_node,
+				     fold_build2 (EQ_EXPR,
+						  size_type_node,
+						  index, num_elems_var)));
+	  a68_add_stmt (fill_in_buffer (elems_var, elem_offset, bounds, elem_mode,
+					allocator));
+	  /* Increase elem_offset  */
+	  a68_add_stmt (fold_build2 (MODIFY_EXPR, sizetype,
+				     elem_offset,
+				     fold_build2 (PLUS_EXPR, sizetype,
+						  elem_offset, elem_size)));
+	  /* index++ */
+	  a68_add_stmt (fold_build2 (POSTINCREMENT_EXPR,
+				     size_type_node,
+				     index, size_one_node));
+	  tree loop_body = a68_pop_range ();
+	  /* End of loop body.  */
+	  a68_add_stmt (fold_build1 (LOOP_EXPR,
+				     void_type_node,
+				     loop_body));
+	  a68_add_stmt (a68_pop_range ());
+	}
+
+      /* Patch the elements% field.  */
+      tree elems_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+      a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				 void_type_node,
+				 fold_build1 (INDIRECT_REF,
+					      build_pointer_type (CTYPE (elem_mode)), elems_address),
+				 elemsptr));
+      /* Patch the elements_size% field.  */
+      offset = fold_build2 (PLUS_EXPR, sizetype, offset, pointer_byte_size);
+      tree elems_size_address = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+      a68_add_stmt (fold_build2 (MODIFY_EXPR,
+				 void_type_node,
+				 fold_build1 (INDIRECT_REF,
+					      sizetype,
+					      elems_size_address),
+				 elems_size));
+    }
+  else if (A68_STRUCT_TYPE_P (type))
+    {
+      /* Initialize the struct's fields in the allocated buffer.  */
+      tree base = a68_lower_tmpvar ("base%", TREE_TYPE (buffer),
+				    fold_build2 (POINTER_PLUS_EXPR,
+						 TREE_TYPE (buffer),
+						 buffer, offset));
+      PACK_T *field_pack = PACK (m);
+      for (tree field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
+	{
+	  gcc_assert (COMPLETE_TYPE_P (TREE_TYPE (field)));
+	  //	  printf ("BYTE_POSITION\n");
+	  //	  debug_tree (byte_position (field));
+	  a68_add_stmt (fill_in_buffer (base, byte_position (field),
+					bounds, MOID (field_pack), allocator));
+	  FORWARD (field_pack);
+	}
+    }
+  else if (A68_UNION_TYPE_P (type))
+    {
+      /* Union values are initialized with an overhead of (sizetype) -1, which
+	 means it is not initialized.  Note that row declarers in united modes
+	 are formal declarers, so they never contribute bounds. */
+      tree overhead_address
+	= fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer), buffer, offset);
+      tree uninitialized = fold_convert (sizetype, build_minus_one_cst (ssizetype));
+      a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node,
+				 fold_build1 (INDIRECT_REF, sizetype, overhead_address),
+				 uninitialized));
+#if 0
+      /* Set the rest of the union with zeroes.  */
+      tree value_address
+	= fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (buffer),
+		       buffer,
+		       fold_build2 (PLUS_EXPR, sizetype, offset, size_in_bytes (sizetype)));
+
+      tree value_field = TREE_CHAIN (TYPE_FIELDS (type));
+      tree call = builtin_decl_explicit (BUILT_IN_MEMSET);
+      call = build_call_expr_loc (UNKNOWN_LOCATION, call, 3,
+				  value_address,
+				  integer_zero_node,
+				  size_in_bytes (TREE_TYPE (value_field)));
+      a68_add_stmt (call);
+#endif
+    }
+  else
+    gcc_unreachable ();
+
+  a68_add_stmt (buffer);
+  filler = a68_pop_stmt_list ();
+  TREE_TYPE (filler) = pointer_type;
+  return filler;
+}
+
+/* Lower to code that generates storage for a value of mode M, using bounds
+   from BOUNDS.  */
+
+static tree
+gen_mode (MOID_T *m, tree_stmt_iterator *bounds, allocator_t allocator)
+{
+  /* Allocate space for the value and fill it.  */
+  tree buffer = (*allocator) (CTYPE (m), size_in_bytes (CTYPE (m)));
+  buffer = save_expr (buffer);
+  return fill_in_buffer (buffer, size_zero_node, bounds, m, allocator);
+}
+
+/* Collect row bounds from BOUNDS.
+   Lower bounds are optional, and if not found they default to 1.  */
+
+static void
+collect_bounds (NODE_T *p, LOW_CTX_T ctx)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, BOUNDS_LIST))
+	collect_bounds (SUB (p), ctx);
+      else if (IS (p, BOUND))
+	collect_bounds (SUB (p), ctx);
+      else if (IS (p, UNIT))
+	{
+	  /* First the lower bound.  */
+	  tree lower_bound;
+	  if (NEXT (p) != NO_NODE && IS (NEXT (p), COLON_SYMBOL))
+	    {
+	      lower_bound = a68_lower_tree (p, ctx);
+	      p = NEXT_NEXT (p);
+	    }
+	  else
+	    /* Default lower bound.  */
+	    lower_bound = integer_one_node;
+
+	  /* Now the upper bound.  */
+	  tree upper_bound = a68_lower_tree (p, ctx);
+
+	  /* See the comment for collect_declarer_bounds for an explanation for
+	     the usage of save_expr here.  */
+	  a68_add_stmt (save_expr (lower_bound));
+	  a68_add_stmt (save_expr (upper_bound));
+	}
+    }
+}
+
+/* Append all the bounds found in the given declarer in the current statements
+   list.  */
+
+static void
+collect_declarer_bounds_1 (NODE_T *p, LOW_CTX_T ctx)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, BOUNDS))
+	collect_bounds (SUB (p), ctx);
+      else if (IS (p, INDICANT) && IS_LITERALLY (p, "STRING"))
+	return;
+      else if (IS (p, INDICANT))
+	{
+	  if (TAX (p) != NO_TAG && HAS_ROWS (MOID (TAX (p))))
+	    /* Continue from definition at MODE A = ....  */
+	    collect_declarer_bounds_1 (NEXT_NEXT (NODE (TAX (p))), ctx);
+	}
+      else if (IS (p, DECLARER)
+	       && (IS_UNION (MOID (p)) || !HAS_ROWS (MOID (p))))
+	  return;
+      else
+	collect_declarer_bounds_1 (SUB (p), ctx);
+    }
+}
+
+/* Given a declarer node, return a statements list with all the expressions of
+   the bounds within it.
+
+   Note that the language rules mandates that the bounds expression shall be
+   evaluated just once even when they are used by several generators, such as
+   in
+
+     [n +:= 1]real a, b;
+
+     Therefore the expressions are saved in save_exprs and the statements list
+     is cached in the CDECL field of the parse tree node.  */
+
+static tree
+collect_declarer_bounds (NODE_T *p, LOW_CTX_T ctx)
+{
+  if (CDECL (p) == NULL_TREE)
+    {
+      a68_push_stmt_list (M_VOID);
+      collect_declarer_bounds_1 (SUB (p), ctx);
+      CDECL (p) = a68_pop_stmt_list ();
+    }
+
+  return CDECL (p);
+}
+
+/* Low the elaboration of a generator.
+
+   The lowered code evaluates to a pointer.
+
+   DECLARER is the actual declarer passed to the generator.
+
+   MODE is the mode of the value to generate.
+
+   HEAP is true if we are lowering a heap generator, false if we are lowering a
+   LOC generator.  */
+
+tree
+a68_low_generator (NODE_T *declarer,
+		   MOID_T *mode,
+		   bool heap, LOW_CTX_T ctx)
+{
+  /* If the declarer is a mode indicant which has a recursive definition then
+     we need to lower to a function which gets immediately called rather than
+     an expression, to handle the recursivity.  In that case, though, we need
+     to always heap allocated memory for obvious reasons, which sucks, but such
+     is life.  */
+
+  if (IS (SUB (declarer), INDICANT) && TAX (SUB (declarer)) != NO_TAG
+      && IS_RECURSIVE (TAX (SUB (declarer))))
+    {
+      if (TAX_TREE_DECL (TAX (SUB (declarer))) != NULL_TREE)
+	{
+	  /* This is a recursive mode indicant.  Just call the function.  */
+	  return save_expr (build_call_expr_loc (a68_get_node_location (SUB (declarer)),
+						 TAX_TREE_DECL (TAX (SUB (declarer))),
+						 0));
+	}
+
+      tree ret_type = build_pointer_type (CTYPE (mode));
+      tree func_decl = build_decl (a68_get_node_location (declarer),
+				   FUNCTION_DECL,
+				   NULL_TREE /* name, set below */,
+				   build_function_type (ret_type, void_list_node));
+      char *name = xasprintf ("genroutine%d", DECL_UID (func_decl));
+      DECL_NAME (func_decl) = a68_get_mangled_identifier (name);
+      free (name);
+      DECL_EXTERNAL (func_decl) = 0;
+      DECL_STATIC_CHAIN (func_decl) = !a68_in_global_range ();
+      TREE_ADDRESSABLE (func_decl) = 1;
+      TREE_PUBLIC (func_decl) = a68_in_global_range ();
+      TREE_STATIC (func_decl) = 1;
+      TAX_TREE_DECL (TAX (SUB (declarer))) = func_decl;
+
+      a68_add_decl (func_decl);
+      a68_add_decl_expr (fold_build1_loc (a68_get_node_location (declarer),
+					  DECL_EXPR,
+					  TREE_TYPE (func_decl),
+					  func_decl));
+      announce_function (func_decl);
+      a68_push_function_range (func_decl, ret_type);
+
+      /* Collect bounds from declarer.  */
+      tree bounds = collect_declarer_bounds (declarer, ctx);
+
+      /* Allocate and initialize a memory buffer for a value of mode MODE with
+	 bounds in BOUNDS.  */
+      tree_stmt_iterator bounds_iter = tsi_start (bounds);
+      tree gen = gen_mode (mode, &bounds_iter, a68_lower_malloc);
+      a68_pop_function_range (gen);
+      /* Avoid this generator function, which uses the global lexical
+	 environment, to be reused in other contexts.  */
+      TAX_TREE_DECL (TAX (SUB (declarer))) = NULL_TREE;
+      return save_expr (build_call_expr_loc (a68_get_node_location (declarer),
+					     func_decl, 0));
+    }
+  else
+    {
+      /* Collect bounds from declarer.  */
+      tree bounds = collect_declarer_bounds (declarer, ctx);
+
+      /* Allocate and initialize a memory buffer for a value of mode MODE with
+	 bounds in BOUNDS.  */
+      tree_stmt_iterator bounds_iter = tsi_start (bounds);
+      tree gen = gen_mode (mode, &bounds_iter,
+			   heap ? a68_lower_malloc : a68_lower_alloca);
+      return gen;
+    }
+}
+
+/* Allocate storage for a value of mode M.
+   NBOUNDS is the number of bounds in BOUNDS.  */
+
+tree
+a68_low_gen (MOID_T *m, size_t nbounds, tree *bounds, bool use_heap)
+{
+  /* First collect bounds from BOUNDS into a statements list, which is what
+     gen_mode expects.  */
+  tree bounds_list = alloc_stmt_list ();
+  for (size_t i = 0; i < nbounds; ++i)
+    append_to_statement_list_force (bounds[i], &bounds_list);
+  allocator_t allocator = use_heap ? a68_lower_malloc : a68_lower_alloca;
+
+  tree_stmt_iterator q = tsi_start (bounds_list);
+  tree ret = gen_mode (m, &q, allocator);
+  free_stmt_list (bounds_list);
+  return ret;
+}
diff --git a/gcc/algol68/a68-low-units.cc b/gcc/algol68/a68-low-units.cc
new file mode 100644
index 00000000000..85a94a8b0ac
--- /dev/null
+++ b/gcc/algol68/a68-low-units.cc
@@ -0,0 +1,1191 @@
+/* Lower units to GENERIC.
+   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"
+
+/* Note that enclosed clauses, which are units, are handled in
+   a68-low-clauses.  */
+
+/* Lower an applied identifier.
+
+   This lowers into the declaration of the referred identifier.  The
+   declaration of the identifier should now be available in the symbol table
+   entry for the identifier.  */
+
+tree
+a68_lower_identifier (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  if (TAG_TABLE (TAX (p)) == A68_STANDENV)
+    {
+      /* This identifier is defined in the standard prelude.  Use its lowering
+	 handler.  */
+      LOWERER_T lowerer = LOWERER (TAX (p));
+      return (*lowerer) (p, ctx);
+    }
+  else
+    {
+      tree id_decl = TAX_TREE_DECL (TAX (p));
+
+      if (id_decl == NULL_TREE)
+	{
+	  /* This is an applied identifier used before the corresponding defining
+	     identifier gets defined in either an identity declaration or a
+	     variable declaration.  Create the declaration and install it in the
+	     symbol table.  The declaration itself, declaration expr and
+	     initialization assignment for the declaration will be emitted by the
+	     corresponding declaration lowering handler.  Note that the defining
+	     identifier (and therefore the declaration associated with this applied
+	     identifier) may be in an outer lexical block.  */
+
+	  if (IS (MOID (p), PROC_SYMBOL))
+	    {
+	      if (VARIABLE (TAX (p)))
+		id_decl = a68_make_variable_declaration_decl (p);
+	      else if (IN_PROC (TAX (p)))
+		id_decl = a68_make_proc_identity_declaration_decl (p);
+	      else
+		id_decl = a68_make_identity_declaration_decl (p);
+	    }
+	  else
+	    {
+	      if (VARIABLE (TAX (p)))
+		id_decl = a68_make_variable_declaration_decl (p);
+	      else
+		id_decl = a68_make_identity_declaration_decl (p);
+	    }
+
+	  TAX_TREE_DECL (TAX (p)) = id_decl;
+	}
+
+      /* If the identifier refers to a FUNCTION_DECL, this means the declaration
+	 was made by a procecure-identity-dclaration.  The applied identifier in
+	 that case refers to the address of the corresponding function.  */
+      if (TREE_CODE (id_decl) == FUNCTION_DECL)
+	return fold_build1 (ADDR_EXPR,
+			    build_pointer_type (TREE_TYPE (id_decl)),
+			    id_decl);
+      else
+	return id_decl;
+    }
+}
+
+/* Lower a string denotation.
+
+   String denotations are of mode []CHAR, and lower into a multiple with a
+   single dimension, and with the following characteristics:
+
+   - The lower bound of dimension 0 is 1.
+   - The upper bound of dimension 0 is strlen (NSYMBOL (p)).
+   - The stride of dimension 0 is 0.
+   - The pointed elements are a buffer of CHARs allocated in the stack.  */
+
+tree
+a68_lower_string_denotation (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  /* First process string breaks.  */
+  char *str = a68_string_process_breaks (NSYMBOL (p));
+
+  /* Build a multiple of UCS-4 CHARs from the resulting UTF-8 string.  */
+  size_t ucslen;
+  uint32_t *ucsbuf = a68_u8_to_u32 ((const uint8_t *) str, strlen (str),
+				    NULL, &ucslen);
+  free (str);
+  tree string_literal = build_string_literal (ucslen * sizeof (uint32_t),
+					      (char *) ucsbuf, a68_char_type);
+  tree elements = string_literal;
+  tree lower_bound = fold_convert (ssizetype, size_one_node);
+  tree upper_bound = ssize_int (ucslen);
+  tree elements_size = fold_build2 (MULT_EXPR, sizetype,
+				    size_int (ucslen),
+				    size_in_bytes (a68_char_type));
+  tree multiple = a68_row_value (CTYPE (M_ROW_CHAR), 1,
+				 elements, elements_size,
+				 &lower_bound, &upper_bound);
+  TREE_CONSTANT (multiple) = true;
+  free (ucsbuf);
+  return multiple;
+}
+
+/* Lower denotation.
+
+     denotation : int denotation; real denotation; bits denotation;
+     		  row char denotation;
+		  true symbol; false symbol;
+		  empty symbol;
+		  longety, int denotation;
+                  longety, real denotation;
+		  longety, bits denotation;
+		  shortety, int denotation;
+		  shortety, real denotation;
+		  shortety, bits denotation.
+
+   Denotations lower into GENERIC cst expressions.  */
+
+tree
+a68_lower_denotation (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *moid = MOID (p);
+
+  if (moid == M_VOID)
+    /* EMPTY  */
+    return a68_lower_empty (p, ctx);
+  else if (moid == M_BOOL)
+    /* TRUE or FALSE.  */
+    return (NSYMBOL (p)[0] == 'T') ? boolean_true_node : boolean_false_node;
+  else if (moid == M_CHAR)
+    {
+      char *s = a68_string_process_breaks (NSYMBOL (p));
+      uint32_t ucs;
+      int length = a68_u8_mbtouc (&ucs, (const uint8_t *) s, 1);
+      gcc_assert (length == 1);
+      free (s);
+      return build_int_cst (a68_char_type, ucs);
+    }
+  else if (moid == M_ROW_CHAR)
+    return a68_lower_string_denotation (p, ctx);
+  else if (moid == M_INT
+	   || moid == M_LONG_INT
+	   || moid == M_LONG_LONG_INT
+	   || moid == M_SHORT_INT
+	   || moid == M_SHORT_SHORT_INT)
+    {
+      /* SIZETY INT */
+      tree type;
+      char *end;
+      NODE_T *s = NO_NODE;
+      if (IS (SUB (p), LONGETY) || IS (SUB (p), SHORTETY))
+	s = NEXT (SUB (p));
+      else
+	s = SUB (p);
+
+      type = CTYPE (moid);
+      int64_t val = strtol (NSYMBOL (s), &end, 10);
+      gcc_assert (end[0] == '\0');
+      return build_int_cst (type, val);
+    }
+  if (moid == M_BITS
+      || moid == M_LONG_BITS
+      || moid == M_LONG_LONG_BITS
+      || moid == M_SHORT_BITS
+      || moid == M_SHORT_SHORT_BITS)
+    {
+      /* SIZETY BITS */
+
+      tree type;
+      char *end;
+      NODE_T *s = NO_NODE;
+      if (IS (SUB (p), LONGETY) || IS (SUB (p), SHORTETY))
+	s = NEXT (SUB (p));
+      else
+	s = SUB (p);
+
+      type = CTYPE (moid);
+      int64_t radix = strtol (NSYMBOL (s), &end, 10);
+      gcc_assert (end != NSYMBOL (s) && *end == 'r');
+      end++;
+      int64_t val = strtol (end, &end, radix);
+      gcc_assert (end[0] == '\0');
+      return build_int_cst (type, val);
+    }
+  else if (moid == M_REAL
+	   || moid == M_LONG_REAL
+	   || moid == M_LONG_LONG_REAL)
+    {
+      /* SIZETY INT */
+      tree type;
+      NODE_T *s = NO_NODE;
+      if (IS (SUB (p), LONGETY) || IS (SUB (p), SHORTETY))
+	s = NEXT (SUB (p));
+      else
+	s = SUB (p);
+
+      if (moid == M_REAL)
+	type = float_type_node;
+      else if (moid == M_LONG_REAL)
+	type = double_type_node;
+      else if (moid == M_LONG_LONG_REAL)
+	type = long_double_type_node;
+      else
+	gcc_unreachable ();
+
+      REAL_VALUE_TYPE val;
+      real_from_string (&val, NSYMBOL (s));
+      return build_real (type, val);
+    }
+
+  gcc_unreachable ();
+  return NULL_TREE;
+}
+
+/* Lower SKIP.
+
+     skip
+*/
+
+tree
+a68_lower_skip (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_get_skip_tree (MOID (p));
+}
+
+/* Lower NIHIL.
+
+     nihil : nil.
+
+   NIL stands for a name referring to no value and which must be
+   distinguishable from any other name.  It is of mode REF AMODE.  NIL is never
+   subject to coercion and it may only occur where the context is strong,
+   i.e. where AMODE is known at compile-time.
+
+   It lowers to a pointer to AMODE with value 0.  */
+
+tree
+a68_lower_nihil (NODE_T *p, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  tree type = CTYPE (MOID (p));
+
+  gcc_assert (type == a68_void_type || POINTER_TYPE_P (type));
+  if (type == a68_void_type)
+    return a68_lower_empty (p, ctx);
+  else
+    return build_int_cst (type, 0);
+}
+
+/* Lower EMPTY.  */
+
+tree
+a68_lower_empty (NODE_T *p ATTRIBUTE_UNUSED, LOW_CTX_T ctx ATTRIBUTE_UNUSED)
+{
+  return a68_get_empty ();
+}
+
+/* Lower an identity relation.
+
+     identity relation : tertiary, is symbol, tertiary;
+     			 tertiary, isnt symbol, tertiary.
+
+   An identity relation determines whether two name values are the same.  It
+   lowers into EQ_EXPR in case of IS and into NE_EXPR in case of ISNT.  */
+
+tree
+a68_lower_identity_relation (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *lhs = SUB (p);
+  NODE_T *oper = NEXT (lhs);
+  NODE_T *rhs = NEXT (oper);
+
+  /* Consolidate arguments to make sure we are comparing pointers in the
+     r-value context of the EQ_EXPR or NE_EXPR operation below.  */
+  tree op1 = a68_consolidate_ref (MOID (lhs), a68_lower_tree (lhs, ctx));
+  tree op2 = a68_consolidate_ref (MOID (rhs), a68_lower_tree (rhs, ctx));
+
+  tree_code code;
+  if (IS (oper, IS_SYMBOL))
+    code = EQ_EXPR;
+  else if (IS (oper, ISNT_SYMBOL))
+    code = NE_EXPR;
+  else
+    gcc_unreachable ();
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  code, boolean_type_node, op1, op2);
+}
+
+/* Lower AND_FUNCTION and OR_FUNCTION.
+
+     and function : tertiary, andf symbol, tertiary.
+     or function : tertiary, orf_symbol, tertiary.
+
+   These are pseudo-operators that are used to implement short-circuits
+   evaluation of logical expressions.
+
+   These pseudo-operators lower into TRUTH_ANDIF_EXPR or TRUTH_ORIF_EXPR,
+   respectively.  */
+
+tree
+a68_lower_logic_function (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *lhs = SUB (p);
+  NODE_T *oper = NEXT (lhs);
+  NODE_T *rhs = NEXT (oper);
+
+  tree op1 = a68_lower_tree (lhs, ctx);
+  tree op2 = a68_lower_tree (rhs, ctx);
+
+  tree_code code;
+  if (IS (oper, ANDF_SYMBOL))
+    code = TRUTH_ANDIF_EXPR;
+  else if (IS (oper, ORF_SYMBOL))
+    code = TRUTH_ORIF_EXPR;
+  else
+    gcc_unreachable ();
+
+  return fold_build2_loc (a68_get_node_location (p),
+			  code, boolean_type_node, op1, op2);
+}
+
+/* Lower a primary.
+
+     primary : identifier; denotation; cast; enclosed clause; format text.
+
+   The primary lowers into some GENERIC expression.  */
+
+tree
+a68_lower_primary (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_lower_tree (SUB (p), ctx);
+}
+
+/* Lower a cast.
+
+     cast : declarer, enclosed clause;
+            void symbol, enclosed clause.
+
+   A cast establishes a strong context with some required mode.  This context
+   allows coercions to be applied, and these coercions have been inserted in
+   the parse tree by the parser.  */
+
+tree
+a68_lower_cast (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_lower_tree (NEXT (SUB (p)), ctx);
+}
+
+/* Lower a slice.
+
+     slice : MULTIPLE INDEXER
+
+   Slicing a multiple may result in either an element of the multiple, if the
+   operation is indexing, or another multiple, if the operation is a
+   trimming.  */
+
+static void
+lower_subscript_for_indexes (NODE_T *p, LOW_CTX_T ctx)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case TRIMMER:
+	  /* Because of ANNOTATION (indexer) == SLICE */
+	  gcc_unreachable ();
+	  break;
+	case UNIT:
+	  a68_add_stmt (a68_lower_tree (p, ctx));
+	  break;
+	case GENERIC_ARGUMENT:
+	case GENERIC_ARGUMENT_LIST:
+	  lower_subscript_for_indexes (SUB (p), ctx);
+	  break;
+	default:
+	  break;
+	}
+    }
+}
+
+static void
+lower_subscript_for_trimmers (NODE_T *p, LOW_CTX_T ctx,
+			      tree multiple, tree new_multiple,
+			      int *dim, int *new_dim,
+			      tree elements_pointer_type)
+{
+  /* new.elements := multiple.elements;
+     FOR dim TO num dimensions
+     DO CO t[dim] is either a subscript i or a trimmer i : j @ k CO
+        new.elements +:= i * multiple.strides[dim];
+        IF t[dim] is a trimmer
+        THEN INT d := ( k is absent | 1 | multiple.lb[dim] - k );
+             new.lb[dim] := multiple.lb[dim] - d;
+	     new.ub[dim] := multiple.ub[dim] - d;
+	     new.strides[dim] := multiple.strides[dim]
+        FI
+     OD
+  */
+
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      switch (ATTRIBUTE (p))
+	{
+	case UNIT:
+	  {
+	    tree unit = save_expr (fold_convert (ssizetype, a68_lower_tree (p, ctx)));
+	    tree new_elements = a68_multiple_elements (new_multiple);
+	    tree size_dim = size_int (*dim);
+	    tree dim_lower_bound = save_expr (a68_multiple_lower_bound (multiple, size_dim));
+	    tree stride = save_expr (a68_multiple_stride (multiple, size_dim));
+
+	    /* Validate bounds.  */
+	    if (OPTION_BOUNDS_CHECKING (&A68_JOB))
+	      a68_add_stmt (a68_multiple_bounds_check (p, size_dim, multiple, unit));
+
+	    /* new_elements += i * strides[dim] */
+	    tree offset = fold_build2 (MULT_EXPR, sizetype,
+				       fold_convert (sizetype, fold_build2 (MINUS_EXPR, ssizetype,
+									    unit, dim_lower_bound)),
+				       stride);
+
+	    offset = save_expr (offset);
+	    new_elements = fold_build2 (POINTER_PLUS_EXPR,
+					elements_pointer_type,
+					new_elements,
+					offset);
+	    a68_add_stmt (a68_multiple_set_elements (new_multiple, new_elements));
+
+	    /* elements_size -= i * strides[dim] */
+	    tree elements_size = a68_multiple_elements_size (new_multiple);
+	    elements_size = fold_build2 (MINUS_EXPR, sizetype,
+					 elements_size, offset);
+	    a68_add_stmt (a68_multiple_set_elements_size (new_multiple, elements_size));
+
+	    *dim += 1;
+	    break;
+	  }
+	case TRIMMER:
+	  {
+	    /* First collect components from the trimmer.  */
+	    tree size_dim = size_int (*dim);
+	    tree dim_lower_bound = save_expr (a68_multiple_lower_bound (multiple, size_dim));
+	    tree lower_bound = dim_lower_bound;
+	    tree upper_bound = save_expr (a68_multiple_upper_bound (multiple, size_dim));
+	    tree at = ssize_int (1);
+
+	    NODE_T *q = SUB (p);
+	    if (q != NO_NODE)
+	      {
+		if (IS (q, AT_SYMBOL))
+		  {
+		    /* Both bounds are implicit.  */
+		    at = save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx)));
+		  }
+		else if (IS (q, COLON_SYMBOL))
+		  {
+		    /* Lower bound is implicit.  */
+		    FORWARD (q);
+		    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
+		  {
+		    /* Lower bound is explicit.  */
+		    lower_bound = fold_convert (ssizetype, a68_lower_tree (q, ctx));
+		    FORWARD (q);
+		    gcc_assert (IS (q, COLON_SYMBOL));
+		    FORWARD (q);
+		    if (q != NO_NODE)
+		      {
+			if (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 && IS (q, AT_SYMBOL))
+			      at =
+				save_expr (fold_convert (ssizetype, a68_lower_tree (NEXT (q), ctx)));
+			  }
+		      }
+		  }
+	      }
+
+	    /* Time for some bounds checking.
+
+	       Note that in trimmers, given the current dimension's bounds
+	       (L,U), we cannot simply do the check:
+
+	            L <= lower_bound <= U
+		    L <= upper_bound <= U
+
+	       This is because the multiple may be flat, and the dimension may
+	       have bounds such like U < L.  In that case, the expressions
+	       above would always eval to false for any lower_bound and
+	       upper_bound.
+
+	       So we check for this instead:
+
+	            L <= lower_bound AND upper_bound <= U
+
+               This allows to trim a "flat dimension" using a trimmer where
+	       upper_bound < lower_bound.  The result is, of course, another
+	       "flat dimension" in the multiple result of the trimming.  */
+
+	    if (OPTION_BOUNDS_CHECKING (&A68_JOB))
+	      {
+		a68_add_stmt (a68_multiple_single_bound_check (p, size_dim, multiple,
+							       lower_bound,
+							       false /* upper_bound */));
+		a68_add_stmt (a68_multiple_single_bound_check (p, size_dim, multiple,
+							       upper_bound,
+							       true /* upper_bound */));
+	      }
+
+	    /* new_elements += i * strides[dim] */
+	    tree stride = save_expr (a68_multiple_stride (multiple, size_dim));
+	    tree new_elements = a68_multiple_elements (new_multiple);
+	    tree offset = fold_build2 (MULT_EXPR, sizetype,
+				       fold_convert (sizetype, fold_build2 (MINUS_EXPR, ssizetype,
+									    lower_bound, dim_lower_bound)),
+				       stride);
+
+	    offset = save_expr (offset);
+	    new_elements = fold_build2 (POINTER_PLUS_EXPR,
+					elements_pointer_type,
+					new_elements,
+					offset);
+	    a68_add_stmt (a68_multiple_set_elements (new_multiple, new_elements));
+
+	    /* elements_size -= i * strides[dim] */
+	    tree elements_size = a68_multiple_elements_size (new_multiple);
+	    elements_size = fold_build2 (MINUS_EXPR, sizetype,
+					 elements_size, offset);
+	    a68_add_stmt (a68_multiple_set_elements_size (new_multiple,
+							  elements_size));
+
+	    /* Fill the triplet for this dimension in new_multiple.  */
+	    tree size_new_dim = size_int (*new_dim);
+	    tree d = fold_build2 (MINUS_EXPR, ssizetype, lower_bound, at);
+
+	    a68_add_stmt (a68_multiple_set_lower_bound (new_multiple, size_new_dim,
+							fold_build2 (MINUS_EXPR, ssizetype,
+								     lower_bound, d)));
+	    a68_add_stmt (a68_multiple_set_upper_bound (new_multiple, size_new_dim,
+							fold_build2 (MINUS_EXPR, ssizetype,
+								     upper_bound, d)));
+	    a68_add_stmt (a68_multiple_set_stride (new_multiple, size_new_dim, stride));
+
+	    *new_dim += 1;
+	    *dim += 1;
+	    break;
+	  }
+	default:
+	  lower_subscript_for_trimmers (SUB (p), ctx,
+					multiple, new_multiple,
+					dim, new_dim,
+					elements_pointer_type);
+	}
+    }
+}
+
+tree
+a68_lower_slice (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *indexer = NEXT_SUB (p);
+  MOID_T *orig_multiple_mode = MOID (SUB (p));
+  MOID_T *multiple_mode = orig_multiple_mode;
+  bool slicing_name = false;
+
+  /* First of all, lower the multiple being sliced.  If it is a name to a
+     multiple, set a flag and dereference.  */
+  tree multiple = a68_lower_tree (SUB (p), ctx);
+  MOID_T *orig_sliced_multiple_mode = MOID (p);
+  MOID_T *sliced_multiple_mode = MOID (p);
+  size_t slice_num_dimensions = 0;
+  if (IS_REF (MOID (SUB (p))))
+    {
+      slicing_name = true;
+      multiple = a68_low_deref (multiple, SUB (p));
+      multiple_mode = SUB (multiple_mode);
+      slice_num_dimensions = DIM (SUB (MOID (p)));
+      sliced_multiple_mode = SUB (sliced_multiple_mode);
+    }
+  else
+    slice_num_dimensions = DIM (MOID (p));
+
+  tree slice = NULL_TREE;
+  if (ANNOTATION (indexer) == SLICE)
+    {
+      /* The slice has only indexers and no trimmers.  Collect units and slice
+	 an element of the multiple using a68_multiple_slice.  This operation
+	 results in an element of the multiple.  */
+
+      /* Collect units  */
+      a68_push_range (NULL);
+      lower_subscript_for_indexes (SUB (indexer), ctx);
+      tree units = a68_pop_range ();
+
+      /* We need to allocate space for as many indexes as dimensions of the
+	 multiple.  */
+      tree num_dimensions_tree = a68_multiple_dimensions (multiple);
+      gcc_assert (TREE_CODE (num_dimensions_tree) == INTEGER_CST);
+      int num_dimensions = tree_to_shwi (num_dimensions_tree);
+
+      int num_indexes = 0;
+      tree *indexes = (tree *) xmalloc (sizeof (tree) * num_dimensions);
+      for (tree_stmt_iterator si = tsi_start (units);
+	   !tsi_end_p (si);
+	   tsi_next (&si))
+	{
+	  /* Add the unit to the list of indexes.  */
+	  indexes[num_indexes] = tsi_stmt (si);
+	  num_indexes++;
+	}
+      gcc_assert (num_indexes == num_dimensions);
+
+      /* Slice.  */
+      slice = a68_multiple_slice (p, multiple, slicing_name,
+				  num_indexes, indexes);
+      free (indexes);
+    }
+  else if (ANNOTATION (indexer) == TRIMMER)
+    {
+      /* The slice has both indexers and trimmers.  Traverse the indexer
+	 subtree to obtain the descriptor of the trimmed multiple (which is
+	 another multiple) and the pointer to the elements, which points to
+	 some position within the elements of the trimmed multiple.  This
+	 operation results in a new multiple of the same mode than the trimmed
+	 multiple with shared elements.  */
+
+      a68_push_range (sliced_multiple_mode);
+
+      tree sliced_multiple = a68_lower_tmpvar ("multiple%", TREE_TYPE (multiple),
+					       multiple);
+      tree *lower_bounds = (tree *) xmalloc (sizeof (tree) * slice_num_dimensions);
+      tree *upper_bounds = (tree *) xmalloc (sizeof (tree) * slice_num_dimensions);
+      tree ssize_one_node = fold_convert (ssizetype, size_one_node);
+      tree ssize_zero_node = fold_convert (ssizetype, size_zero_node);
+      for (size_t d = 0; d < slice_num_dimensions; ++d)
+	{
+	  /* Note that these dummy bounds and the implied strides will be
+	     overwritten by lower_subscript_for_trimmers below.  */
+	  lower_bounds[d] = ssize_one_node;
+	  upper_bounds[d] = ssize_zero_node;
+	}
+      tree new_multiple = a68_row_value (CTYPE (sliced_multiple_mode),
+					 slice_num_dimensions,
+					 a68_multiple_elements (sliced_multiple),
+					 a68_multiple_elements_size (sliced_multiple),
+					 lower_bounds, upper_bounds);
+      new_multiple = save_expr (new_multiple);
+      new_multiple = a68_lower_tmpvar ("new_multiple%", TREE_TYPE (new_multiple),
+				       new_multiple);
+
+      int dim = 0;
+      int new_dim = 0;
+      lower_subscript_for_trimmers (SUB (indexer), ctx,
+				    sliced_multiple, new_multiple,
+				    &dim, &new_dim,
+				    a68_row_elements_pointer_type (TREE_TYPE (multiple)));
+      a68_add_stmt (new_multiple);
+      slice = a68_pop_range ();
+
+      /* In case we are slicing a ref to a multiple, return the address of the
+	 resulting multiple and not the multiple itself.  But in this case we
+	 need an address in the heap, because the trimmed multiple may be in
+	 the heap and the result shall have the same scope.  */
+      if (slicing_name)
+	{
+	  tree ptrtype = CTYPE (orig_sliced_multiple_mode);
+	  tree slice_addr = fold_build1 (ADDR_EXPR, ptrtype, slice);
+	  tree alloc = a68_lower_malloc (ptrtype, size_in_bytes (TREE_TYPE (slice)));
+	  alloc = save_expr (alloc);
+	  tree copy = a68_lower_memcpy (alloc, slice_addr, size_in_bytes (TREE_TYPE (slice)));
+
+	  slice = fold_build2 (COMPOUND_EXPR, ptrtype, copy, alloc);
+	}
+    }
+  else
+    gcc_unreachable ();
+
+  return slice;
+}
+
+/* Lower a selection.
+
+     selection : selector, secondary.
+     selector : field identifier, of symbol.
+
+   The selection lowers into a COMPONENT_REF of the field corresponding to the
+   field identifier.  */
+
+tree
+a68_lower_selection (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *secondary = NEXT (SUB (p));
+  NODE_T *field_identifier = SUB (SUB (p));
+
+  MOID_T *secondary_mode = MOID (secondary);
+  tree secondary_expr = a68_lower_tree (secondary, ctx);
+
+  tree res = NULL_TREE;
+
+  /* If the secondary is an address, we need to indirect.  */
+  if (IS_REF (secondary_mode))
+    {
+      secondary_expr = a68_low_deref (secondary_expr, secondary);
+      secondary_mode = SUB (secondary_mode);
+    }
+
+  if (IS_FLEX (secondary_mode) || IS_ROW (secondary_mode))
+    {
+      /* This is the selection of a multiple of structs.
+
+	 The result is a multiple with same dimensions, dimension bounds and
+	 strides than the indexed multiple.  The elements pointer is made to
+	 point to the selected field of the first struct.  */
+
+      MOID_T *result_mode = MOID (p);
+      if (IS_REF (result_mode))
+	result_mode = SUB (result_mode);
+      MOID_T *struct_mode = SUB (secondary_mode);
+      tree field_id = a68_get_mangled_identifier (SYMBOL (INFO (field_identifier)));
+      tree struct_type = CTYPE (struct_mode);
+      a68_push_range (result_mode);
+      tree selection = a68_lower_tmpvar ("selection%", CTYPE (result_mode),
+					 a68_get_skip_tree (result_mode));
+      tree multiple = a68_lower_tmpvar ("multiple%", TREE_TYPE (secondary_expr),
+					secondary_expr);
+
+      /* First set the bounds of the selection, which are exactly the same
+	 bounds than the selected multiple.  */
+      for (int dim = 0; dim < DIM (DEFLEX (secondary_mode)); ++dim)
+	{
+	  tree size_dim = size_int (dim);
+	  tree lower_bound = a68_multiple_lower_bound (multiple, size_dim);
+	  tree upper_bound = a68_multiple_upper_bound (multiple, size_dim);
+	  tree stride = a68_multiple_stride (multiple, size_dim);
+	  a68_add_stmt (a68_multiple_set_lower_bound (selection, size_dim,
+						      lower_bound));
+	  a68_add_stmt (a68_multiple_set_upper_bound (selection, size_dim,
+						      upper_bound));
+	  a68_add_stmt (a68_multiple_set_stride (selection, size_dim,
+						 stride));
+	}
+
+      /* Now set the elements pointer, which is the elements pointer of the
+	 selected multiple offset the offset of the selected field in its
+	 struct type.  */
+      tree elements = a68_multiple_elements (selection);
+      tree multiple_elements = a68_multiple_elements (multiple);
+      tree multiple_elements_size = a68_multiple_elements_size (multiple);
+      tree element_pointer_type = TREE_TYPE (elements);
+      tree field_offset = NULL_TREE;
+      for (tree f = TYPE_FIELDS (struct_type); f; f = DECL_CHAIN (f))
+	{
+	  if (field_id == DECL_NAME (f))
+	    {
+	      field_offset = byte_position (f);
+	      break;
+	    }
+	}
+      gcc_assert (field_offset != NULL_TREE);
+      a68_add_stmt (a68_multiple_set_elements (selection,
+					       fold_build2 (POINTER_PLUS_EXPR,
+							    element_pointer_type,
+							    multiple_elements,
+							    field_offset)));
+
+      /* The size of the buffer pointed by the elements pointer has to be
+	 adjusted accordingly.  */
+      a68_add_stmt (a68_multiple_set_elements_size (selection,
+						    fold_build2 (MINUS_EXPR, sizetype,
+								 multiple_elements_size,
+								 field_offset)));
+
+      a68_add_stmt (selection);
+      res = a68_pop_range ();
+    }
+  else
+    {
+      /* This is the selection of a struct field.  */
+      gcc_assert (A68_STRUCT_TYPE_P (TREE_TYPE (secondary_expr)));
+
+      /* Search for the selected field in the struct type.  */
+      tree struct_type = TREE_TYPE (secondary_expr);
+      tree field_id = a68_get_mangled_identifier (SYMBOL (INFO (field_identifier)));
+      tree field = NULL_TREE;
+      for (tree f = TYPE_FIELDS (struct_type); f; f = DECL_CHAIN (f))
+	{
+	  if (field_id == DECL_NAME (f))
+	    {
+	      field = f;
+	      break;
+	    }
+	}
+      gcc_assert (field != NULL_TREE);
+
+      /* Emit the COMPONENT_REF.  */
+      res = fold_build3_loc (a68_get_node_location (p),
+			     COMPONENT_REF,
+			     TREE_TYPE (field),
+			     secondary_expr,
+			     field,
+			     NULL_TREE);
+    }
+
+  /* The selection of a name yields a name.  */
+  if (IS_REF (MOID (secondary)))
+    /* XXX This may require copying.  */
+    return fold_build1 (ADDR_EXPR, CTYPE (MOID (p)), res);
+  else
+    return res;
+}
+
+/* Lower a secondary.
+
+     secondary : primary; generator; selection.
+
+   The secondary lowers into some GENERIC expression.  */
+
+tree
+a68_lower_secondary (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_lower_tree (SUB (p), ctx);
+}
+
+/* Lower a formula.
+
+     formula : secondary, operator, secondary;
+     	       secondary, operator, monadic formula;
+	       secondary, operator, formula;
+	       monadic formula;
+	       monadic formula, operator, secondary;
+	       monadic formula, operator, monadic formula;
+	       monadic formula, operator, formula;
+	       formula, operator, secondary;
+	       formula, operator, monadic formula;
+	       formula, operator, formula.
+
+   The formula lowers into some GENERIC expression.  */
+
+tree
+a68_lower_formula (NODE_T *p, LOW_CTX_T ctx)
+{
+  if (IS (SUB (p), MONADIC_FORMULA) && NEXT (SUB (p)) == NO_NODE)
+    return a68_lower_tree (SUB (p), ctx);
+  else
+    {
+      /* If the operator is defined in the standard prelude, then use its lowering
+	 code.  */
+      if (TAG_TABLE (TAX (NEXT (SUB (p)))) == A68_STANDENV)
+	{
+	  LOWERER_T lowerer = LOWERER (TAX (NEXT (SUB (p))));
+	  return (*lowerer) (p, ctx);
+	}
+      else
+	{
+	  tree arg1 = a68_lower_tree (SUB (p), ctx);
+	  tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
+	  tree arg2 = a68_lower_tree (NEXT (NEXT (SUB (p))), ctx);
+
+	  if (POINTER_TYPE_P (TREE_TYPE (op)))
+	    op = fold_build1 (INDIRECT_REF,
+			      TREE_TYPE (TREE_TYPE (op)),
+			      op);
+	  return build_call_expr_loc (a68_get_node_location (p), op, 2, arg1, arg2);
+	}
+    }
+}
+
+/* Lower a monadic formula.
+
+     monadic formula : operator, secondary;
+                       operator, monadic formula.
+
+   The monadic formula lowers into some GENERIC expression.  */
+
+tree
+a68_lower_monadic_formula (NODE_T *p, LOW_CTX_T ctx)
+{
+  /* If the operator is defined in the standard prelude, then use its lowering
+     code.  */
+  if (TAG_TABLE (TAX (SUB (p))) == A68_STANDENV)
+    {
+      LOWERER_T lowerer = LOWERER (TAX (SUB (p)));
+      return (*lowerer) (p, ctx);
+    }
+  else
+    {
+      tree op = a68_lower_tree (SUB (p), ctx);
+      tree secondary = a68_lower_tree (NEXT (SUB (p)), ctx);
+
+      if (POINTER_TYPE_P (TREE_TYPE (op)))
+	op = fold_build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (op)), op);
+      return build_call_expr_loc (a68_get_node_location (p), op, 1, secondary);
+    }
+}
+
+/* Lower a tertiary.
+
+     tertiary : nihil; monadic formula; formula; secondary.
+
+  The tertiary lowers to some GENERIC expression.  */
+
+tree
+a68_lower_tertiary (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_lower_tree (SUB (p), ctx);
+}
+
+/* Lower an assignation.
+
+     assignation : tertiary, assign symbol, tertiary;
+                   tertiary, assign symbol, identity relation;
+		   tertiary, assign symbol, and function;
+		   tertiary, assign symbol, or function;
+		   tertiary, assign symbol, routine text;
+		   tertiary, assign symbol, jump;
+		   tertiary, assign symbol, skip;
+		   tertiary, assign symbol, assignation;
+		   tertiary, assign symbol, code clause.
+
+   An assignation lowers into appending a MODIFY_EXPR to the statements list,
+   and the result of the expression is the left hand side.  A compound
+   expression fits perfectly */
+
+tree
+a68_lower_assignation (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *lhs_node = SUB (p);
+  NODE_T *rhs_node = NEXT (NEXT (SUB (p)));
+  tree lhs = a68_lower_tree (lhs_node, ctx);
+  tree rhs = a68_lower_tree (rhs_node, ctx);
+
+  return a68_low_assignation (p,
+			      lhs, MOID (lhs_node),
+			      rhs, MOID (rhs_node));
+}
+
+/* Lower a generator.
+
+     generator : loc symbol, declarer;
+                 heap symbol, declarer;
+		 new symbol, declarer.
+
+   LOC generators lower into calls to BUILT_IN_ALLOCA.
+   HEAP generators lower into calls to malloc.  */
+
+tree
+a68_lower_generator (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *declarer = NEXT (SUB (p));
+  return a68_low_generator (declarer,
+			    MOID (declarer),
+			    !IS (SUB (p), LOC_SYMBOL),
+			    ctx);
+}
+
+/* Lower a procedure call.
+
+ */
+
+static void
+collect_call_arguments (NODE_T *p, vec<tree, va_gc> *args, LOW_CTX_T ctx)
+{
+  for (; p != NO_NODE; FORWARD (p))
+    {
+      if (IS (p, UNIT))
+	{
+	  /* In Algol 68 parameters are passed via an identity declaration, so
+	     this must implement same semantics.  */
+	  tree arg = a68_lower_tree (p, ctx);
+	  if (HAS_ROWS (MOID (p)))
+	    arg = a68_low_dup (arg);
+	  arg = a68_consolidate_ref (MOID (p), arg);
+	  args->quick_push (arg);
+	}
+      else
+	collect_call_arguments (SUB (p), args, ctx);
+    }
+}
+
+tree
+a68_lower_call (NODE_T *p, LOW_CTX_T ctx)
+{
+  MOID_T *proc_mode = MOID (SUB (p));
+  MOID_T *ret_mode = SUB (proc_mode);
+  unsigned int nargs = DIM (proc_mode);
+
+  /* Collect arguments.  */
+  vec<tree, va_gc> *args;
+  vec_alloc (args, nargs);
+  collect_call_arguments (NEXT (SUB (p)), args, ctx);
+
+  /* Lower the primary to call.  */
+  tree primary = a68_lower_tree (SUB (p), ctx);
+
+  /* We need a pointer to a function type.  */
+  if (!POINTER_TYPE_P (TREE_TYPE (primary)))
+    primary = fold_build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (primary)),
+			   primary);
+
+  /* Build a function call.  */
+  tree call = build_call_vec (CTYPE (ret_mode), primary, args);
+  SET_EXPR_LOCATION (call, a68_get_node_location (p));
+  return call;
+}
+
+/* Lower a routine text.
+
+     routine text : parameter pack, (declarer ; void symbol), colon symbol, assignation;
+                    parameter pack, (declarer ; void symbol), colon symbol, identity relation;
+		    parameter pack, (declarer ; void symbol), colon symbol, and function;
+		    parameter pack, (declarer ; void symbol), colon symbol, or runction;
+		    parameter pack, (declarer ; void symbol), colon symbol, jump;
+		    parameter pack, (declarer ; void symbol), colon symbol, skip;
+		    parameter pack, (declarer ; void symbol), colon symbol, tertiary;
+		    parameter pack, (declarer ; void symbol), colon symbol, routine text;
+		    parameter pack, (declarer ; void symboL), colon symbol, code clause;
+                    (declarer ; void symbol), colon symbol, assignation;
+                    (declarer ; void symbol), colon symbol, identity relation;
+		    (declarer ; void symbol), colon symbol, and function;
+		    (declarer ; void symbol), colon symbol, or runction;
+		    (declarer ; void symbol), colon symbol, jump;
+		    (declarer ; void symbol), colon symbol, skip;
+		    (declarer ; void symbol), colon symbol, tertiary;
+		    (declarer ; void symbol), colon symbol, routine text;
+		    (declarer ; void symbol), colon symbol, code clause.
+
+  Routine texts are used to create routines.  They can stand as the actual
+  parameter of an identity declaration, as the actual parameter of a call, or
+  as the right-hand side of an assignation.
+
+  This lowering function is called in two different contexts:
+
+  1) As part of a routine-identity-declaration, in which case the routine
+     resulting from this routine-text is beign ascribed to an identifier given
+     in ctx.proc_decl_identifier.  In that case, we lower to a FUNC_DECL
+     initialized with the body of the routine-text.
+
+  2) As a free standing routine-text.  In that case ctx.proc_decl_identifier is
+     NO_NODE. We lower to the address of a FUNC_DECL that features some unique
+     name.  This pointer will then likely be assigned or ascribed to some
+     variable or identifier in non-contracted identity declaration, but we
+     cannot assume that so we have to opt for the indirection.  */
+
+tree
+a68_lower_routine_text (NODE_T *p, LOW_CTX_T ctx)
+{
+  NODE_T *s = SUB (p);
+
+  tree func_decl = NULL_TREE;
+  NODE_T *defining_identifier = ctx.proc_decl_identifier;
+  if (defining_identifier != NO_NODE)
+    {
+      /* The routine-text is part of a routine-identity-declaration.  */
+      func_decl = TAX_TREE_DECL (TAX (defining_identifier));
+      if (func_decl == NULL_TREE)
+	{
+	  func_decl = a68_make_proc_identity_declaration_decl (defining_identifier);
+	  TAX_TREE_DECL (TAX (defining_identifier)) = func_decl;
+	}
+    }
+  else
+    /* The routine-text is free standing.  */
+    func_decl = a68_make_anonymous_routine_decl (MOID (p));
+
+  a68_add_decl (func_decl);
+  a68_add_decl_expr (fold_build1_loc (a68_get_node_location (p),
+				      DECL_EXPR,
+				      TREE_TYPE (func_decl),
+				      func_decl));
+  announce_function (func_decl);
+
+  /* PARAMETER_PACK.  */
+  NODE_T *parameter_pack_node = NO_NODE;
+  tree parameter_pack = NULL_TREE; /* This is computed below.  */
+  if (IS (s, PARAMETER_PACK))
+    {
+      parameter_pack_node = s;
+      FORWARD (s);
+    }
+
+  /* DECLARER or VOID_SYMBOL */
+  if (IS (s, DECLARER) || IS (s, VOID_SYMBOL))
+    /* This is not used, as this formal declarer is also available in the
+       procedure mode.  So just skip it.  */
+    FORWARD (s);
+
+  /* Skip the COLON_SYMBOL.  */
+  gcc_assert (IS (s, COLON_SYMBOL));
+  FORWARD (s);
+
+  /* Lower the function body.
+
+     This should be done in a new range in which the formal parameters of the
+     routine-text have been declared.  */
+  a68_push_function_range (func_decl, CTYPE (SUB (MOID (p))) /* result_type */);
+  if (parameter_pack_node != NO_NODE)
+    parameter_pack = a68_lower_tree (parameter_pack_node, ctx);
+  DECL_ARGUMENTS (func_decl) = parameter_pack;
+  ctx.proc_decl_identifier = NO_NODE;
+  tree func_body = a68_lower_tree (s, ctx);
+  a68_pop_function_range (func_body);
+
+  if (defining_identifier != NO_NODE)
+    /* Routine-text immediately ascribed to some identifier in a
+       proc-identity-declaration.  Return the FUNC_DECL.  */
+    return func_decl;
+  else
+    /* Free standing routine-text.  Return its address.  */
+    return fold_build1 (ADDR_EXPR,
+			build_pointer_type (TREE_TYPE (func_decl)),
+			func_decl);
+}
+
+/* Lower an unit.
+
+      unit : assignation; identity relation;
+             and function; or function; routine text;
+             jump; skip; tertiary; assertion; code clause.
+
+   The unit lowers to an expression.  */
+
+tree
+a68_lower_unit (NODE_T *p, LOW_CTX_T ctx)
+{
+  return a68_lower_tree (SUB (p), ctx);
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 38/47] a68: low: modes
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (36 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 37/47] a68: low: units and coercions Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 39/47] a68: libga68: sources, spec and misc files Jose E. Marchesi
                   ` (9 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/ChangeLog

	* algol68/a68-low-moids.cc: New file.
---
 gcc/algol68/a68-low-moids.cc | 729 +++++++++++++++++++++++++++++++++++
 1 file changed, 729 insertions(+)
 create mode 100644 gcc/algol68/a68-low-moids.cc

diff --git a/gcc/algol68/a68-low-moids.cc b/gcc/algol68/a68-low-moids.cc
new file mode 100644
index 00000000000..4dbf1189162
--- /dev/null
+++ b/gcc/algol68/a68-low-moids.cc
@@ -0,0 +1,729 @@
+/* Lower Algol 68 modes to GCC trees.
+   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 "stringpool.h"
+#include "tree.h"
+
+#include "tree.h"
+#include "fold-const.h"
+#include "diagnostic.h"
+#include "langhooks.h"
+#include "tm.h"
+#include "function.h"
+#include "toplev.h"
+#include "varasm.h"
+#include "predict.h"
+#include "stor-layout.h"
+#include "print-tree.h"
+
+#include "a68.h"
+
+static tree a68_lower_mode (MOID_T *m);
+
+/*
+ * Support routines and definitions.
+ */
+
+/* Build a stub TYPE_DECL for a given TYPE.
+
+   This is used for TYPE_STUB_DECL so we can generate debug info for all our
+   modes, so the TYPE_DECL has no name.  */
+
+static void
+build_stub_type_decl (tree type, tree context)
+{
+  if (TYPE_STUB_DECL (type))
+    return;
+
+  tree decl = build_decl (UNKNOWN_LOCATION,
+			  TYPE_DECL,
+			  NULL_TREE /* name */,
+			  type);
+  TREE_PUBLIC (decl) = 1;
+  DECL_CONTEXT (decl) = context;
+  TYPE_CONTEXT (type) = DECL_CONTEXT (decl);
+  TYPE_NAME (type) = decl; /* Weird.  This is for typedefs! */
+  TYPE_STUB_DECL (type) = decl;
+}
+
+/* Builds a record type whose name is NAME.  NFIELDS is the number of fields,
+   provided as field ident/type pairs.
+
+   This code is copied from the D front end.  */
+
+static tree
+make_struct_type (tree type, const char *name, int nfields, ...)
+{
+  tree fields = NULL_TREE;
+  va_list ap;
+
+  va_start (ap, nfields);
+
+  for (int i = 0; i < nfields; i++)
+    {
+      tree ident = va_arg (ap, tree);
+      tree type = va_arg (ap, tree);
+      tree field = build_decl (BUILTINS_LOCATION, FIELD_DECL, ident, type);
+      DECL_CHAIN (field) = fields;
+      fields = field;
+    }
+
+  va_end (ap);
+
+  if (type == NULL_TREE)
+    type = make_node (RECORD_TYPE);
+  finish_builtin_struct (type, name, fields, NULL_TREE);
+
+  return type;
+}
+
+/* Iterate over all the field selectors FIELDS of a structure type and add them
+   as fields to CONTEXT.  Returns the number of field selectors found.  */
+
+static size_t
+chain_struct_fields (PACK_T *fields, tree context)
+{
+  PACK_T *elem;
+  size_t num_fields;
+
+  for (num_fields = 0, elem = fields;
+       elem != NO_PACK;
+       FORWARD (elem), ++num_fields)
+    {
+      const char *field_name = TEXT (elem);
+      MOID_T *field_mode = MOID (elem);
+      tree field_type = a68_lower_mode (field_mode);
+
+      /* Create the field declaration.
+         The declaration is not a compiler-generated entity.
+	 Do not ignore the declaration for symbolic debug purposes. */
+      tree field_decl = build_decl ((NODE (field_mode)
+				     ? a68_get_node_location (NODE (field_mode))
+				     : UNKNOWN_LOCATION),
+				    FIELD_DECL,
+				    field_name ? get_identifier (field_name) : NULL_TREE,
+				    field_type);
+      DECL_ARTIFICIAL (field_decl) = 0;
+      DECL_IGNORED_P (field_decl) = 0;
+
+      /* If the mode of the field is not a ref then references to the field
+	 cannot appear in a LHS of an assignment.  */
+      TREE_READONLY (field_decl) = IS_REF (field_mode);
+
+      /* Associate the tree field declaration and the front end node.  */
+      DECL_LANG_SPECIFIC (field_decl) =
+	(NODE (field_mode) ? a68_build_lang_decl (NODE (field_mode)) : NULL);
+
+      /* Chain the field declaration in its containing context.  */
+      DECL_FIELD_CONTEXT (field_decl) = context;
+      TYPE_FIELDS (context) = chainon (TYPE_FIELDS (context), field_decl);
+    }
+
+  return num_fields;
+}
+
+/* If the union or struct type TYPE completes the type of any previous field
+   declarations, lay them out now.  */
+
+static void
+finish_incomplete_fields (tree type)
+{
+  for (tree fwdref = TYPE_FORWARD_REFERENCES (type); fwdref != NULL_TREE;
+       fwdref = TREE_CHAIN (fwdref))
+    {
+      tree field = TREE_VALUE (fwdref);
+      tree struct_or_union_type = DECL_FIELD_CONTEXT (field);
+
+      relayout_decl (field);
+      bool type_complete = true;
+      for (tree field = TYPE_FIELDS (struct_or_union_type);
+	   field;
+	   field = DECL_CHAIN (field))
+	{
+	  if (!COMPLETE_TYPE_P (TREE_TYPE (field)))
+	    {
+	      type_complete = false;
+	      break;
+	    }
+	}
+
+      if (type_complete)
+	{
+	  // XXX why this fires
+	  //	  gcc_assert (!COMPLETE_TYPE_P (struct_or_union_type));
+	  layout_type (struct_or_union_type);
+	  /* Set the back-end type mode now that all fields have had their size
+	     set.  */
+	  compute_record_mode (struct_or_union_type);
+	}
+    };
+
+  /* No more forward references to process.  */
+  TYPE_FORWARD_REFERENCES (type) = NULL_TREE;
+}
+
+/*
+ * Mode lowering routines.
+ */
+
+/* Lower a HIP mode to a GENERIC tree.
+   HIP is the mode of NIL.  */
+
+static tree
+lower_hip_mode (MOID_T *m)
+{
+  static tree hip_type;
+
+  if (hip_type == NULL)
+    {
+      hip_type = build_pointer_type (a68_void_type);
+      TYPE_LANG_SPECIFIC (hip_type) = a68_build_lang_type (m);
+      CTYPE (m) = hip_type;
+    }
+
+  return hip_type;
+}
+
+/* Lower a standard mode to a GENERIC tree.
+
+   Note that this function only has to handle the standard modes that have not
+   been resolved to some equivalent.  */
+
+static tree
+lower_standard_mode (MOID_T *m)
+{
+  tree type = NULL_TREE;
+
+  if (m == M_VOID)
+    type = a68_void_type;
+  else if (m == M_BOOL)
+    type = a68_bool_type;
+  else if (m == M_CHAR)
+    type = a68_char_type;
+  else if (m == M_SHORT_SHORT_INT)
+    type = a68_short_short_int_type;
+  else if (m == M_SHORT_INT)
+    type = a68_short_int_type;
+  else if (m == M_INT)
+    type = a68_int_type;
+  else if (m == M_LONG_INT)
+    type = a68_long_int_type;
+  else if (m == M_LONG_LONG_INT)
+    type = a68_long_long_int_type;
+  else if (m == M_REAL)
+    type = a68_real_type;
+  else if (m == M_LONG_REAL)
+    type = a68_long_real_type;
+  else if (m == M_LONG_LONG_REAL)
+    type = a68_long_long_real_type;
+  else if (m == M_SHORT_SHORT_BITS)
+    type = a68_short_short_bits_type;
+  else if (m == M_SHORT_BITS)
+    type = a68_short_bits_type;
+  else if (m == M_BITS)
+    type = a68_bits_type;
+  else if (m == M_LONG_BITS)
+    type = a68_long_bits_type;
+  else if (m == M_LONG_LONG_BITS)
+    type = a68_long_long_bits_type;
+  else if (m == M_BYTES)
+    type = a68_bytes_type;
+  else if (m == M_LONG_BYTES)
+    type = a68_long_bytes_type;
+  else if (m == M_FILE)
+    /* XXX for now this is a file descriptor.  */
+    type = integer_type_node;
+  else if (m == M_CHANNEL)
+    /* XXX for now this is a channel descriptor.  */
+    type = integer_type_node;
+  else
+    gcc_unreachable ();
+
+  TYPE_LANG_SPECIFIC (type) = a68_build_lang_type (m);
+  return type;
+}
+
+/* Lower a struct mode to a GENERIC tree.  */
+
+static tree
+lower_struct_mode (MOID_T *m)
+{
+  /* First make the GENERIC struct.  This is needed in case of
+     self-references.  */
+  tree struct_type = make_node (RECORD_TYPE);
+  TYPE_NAME (struct_type) = get_identifier ("lalastruct%");
+  TYPE_FIELDS (struct_type) = NULL_TREE;
+  TYPE_CXX_ODR_P (struct_type) = 0;
+  CTYPE (m) = struct_type;
+  TYPE_LANG_SPECIFIC (struct_type) = a68_build_lang_type (m); /* XXX this will get overrided. */
+
+  /* Add field declarations.  */
+  chain_struct_fields (PACK (m), struct_type);
+
+  /* Layout all fields.  */
+  bool struct_type_complete = true;
+  for (tree field = TYPE_FIELDS (struct_type); field; field = DECL_CHAIN (field))
+    {
+      tree basetype = TREE_TYPE (field);
+
+      if (!COMPLETE_TYPE_P (basetype))
+	{
+	  tree field_type = TREE_TYPE (field);
+	  tree forward_refs = tree_cons (NULL_TREE, field,
+					 TYPE_FORWARD_REFERENCES (field_type));
+	  TYPE_FORWARD_REFERENCES (struct_type) = forward_refs;
+
+	  struct_type_complete = false;
+	  continue;
+	}
+
+      layout_decl (field, 0);
+      gcc_assert (DECL_SIZE (field) != NULL_TREE);
+    }
+
+  /* If all fields have complete types then we can layout the struct type now.
+     Otherwise it will be done in finish_incomplete_types.  */
+  if (struct_type_complete)
+    {
+      layout_type (struct_type);
+      /* Set the back-end type mode now that all fields have had their size
+	 set.  */
+      compute_record_mode (struct_type);
+    }
+
+  /* Finish debugging output for this type.  */
+  build_stub_type_decl (struct_type, NULL_TREE /* context */);
+  rest_of_type_compilation (struct_type, TYPE_FILE_SCOPE_P (struct_type));
+  rest_of_decl_compilation (TYPE_NAME (struct_type), 1 /* file scope p */, 0);
+  A68_STRUCT_TYPE_P (struct_type) = 1;
+  return struct_type;
+}
+
+/* Lower a ref mode to a GENERIC tree.
+   REF AMODE lowers to a pointer.  */
+
+static tree
+lower_ref_mode (MOID_T *m)
+{
+  return build_pointer_type (a68_lower_mode (SUB (m)));
+}
+
+/* Lower a flex mode to a GENERIC tree.  */
+
+static tree
+lower_flex_mode (MOID_T *m)
+{
+  /* This is basically a qualifier of the parent REF.  */
+  return a68_lower_mode (SUB (m));
+}
+
+/* Lower a proc mode to a GENERIC tree.  */
+
+static tree
+lower_proc_mode (MOID_T *m)
+{
+  tree fnargs = NULL_TREE;
+  tree ret_type;
+
+  /* We have to create the function type in advance because it can appear
+     recursively as the type of arguments and/or of the return value.  We
+     cannot use build_function_type, as it doesn't support recursive types.  */
+  tree function_type = make_node (FUNCTION_TYPE);
+  tree ptr_function_type = build_pointer_type (function_type);
+  CTYPE (m) = ptr_function_type;
+
+  /* Now add arguments and return value types.  */
+  for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p))
+    {
+      tree arg_type = a68_lower_mode (MOID (p));
+      fnargs = chainon (fnargs, build_tree_list (0, arg_type));
+    }
+  ret_type = a68_lower_mode (SUB (m));
+
+  /* Complete the function type.  Note that there is some code duplication with
+     build_function_type, which we cannot use, but such is life.  */
+  TREE_TYPE (function_type) = ret_type; /* THIS */
+  TYPE_ARG_TYPES (function_type) = fnargs;
+  SET_TYPE_STRUCTURAL_EQUALITY (function_type);
+
+  if (!COMPLETE_TYPE_P (function_type))
+    layout_type (function_type);
+
+  return ptr_function_type;
+}
+
+/* Lower an union mode to a GENERIC tree.
+
+   overhead%     Characterizes the actual mode of the value.
+   value%        GENERIC union.  */
+
+static tree
+lower_union_mode (MOID_T *m)
+{
+  // XXX make the union type QUAL_UNION_TYPE and relate the fields with the
+  // overhead%.  This is necessary for DWARF.
+  tree union_type = make_node (RECORD_TYPE);
+  TYPE_NAME (union_type) = NULL_TREE;
+  TYPE_FIELDS (union_type) = NULL_TREE;
+  TYPE_CXX_ODR_P (union_type) = 0;
+  CTYPE (m) = union_type;
+
+  /* Then the GENERIC union.  */
+  tree c_union_type = make_node (UNION_TYPE);
+  TYPE_NAME (c_union_type) = NULL_TREE;
+  TYPE_FIELDS (c_union_type) = NULL_TREE;
+  TYPE_CXX_ODR_P (c_union_type) = 0; // XXX otherwise lto complains.  why.
+  SET_TYPE_STRUCTURAL_EQUALITY (c_union_type);
+
+  /* Add field declarations.  */
+  chain_struct_fields (PACK (m), c_union_type);
+
+  /* Layout all fields now the type is complete.  */
+  bool c_union_type_complete = true;
+  for (tree field = TYPE_FIELDS (c_union_type); field; field = DECL_CHAIN (field))
+    {
+      tree field_type = TREE_TYPE (field);
+
+      if (!COMPLETE_TYPE_P (field_type))
+	{
+	  tree field_type = TREE_TYPE (field);
+	  tree forward_refs = tree_cons (NULL_TREE, field,
+					 TYPE_FORWARD_REFERENCES (field_type));
+	  TYPE_FORWARD_REFERENCES (c_union_type) = forward_refs;
+
+	  c_union_type_complete = false;
+	  continue;
+	}
+
+      layout_decl (field, 0);
+      gcc_assert (DECL_SIZE (field) != NULL_TREE);
+    }
+
+  /* If all fields have complete types then we can layout the c-union type now.
+     Otherwise it will be done in finish_incomplete_types.  */
+  if (c_union_type_complete)
+    {
+      layout_type (c_union_type);
+      /* Set the back-end type mode now that all fields have had their size
+	 set.  */
+      compute_record_mode (c_union_type);
+    }
+
+  /* Finish debugging output for this type.  */
+  build_stub_type_decl (c_union_type, NULL_TREE /* context */);
+  rest_of_type_compilation (c_union_type, TYPE_FILE_SCOPE_P (c_union_type));
+  rest_of_decl_compilation (TYPE_NAME (c_union_type), 1 /* file scope p */, 0);
+
+  /* Now the type with the overhead.  */
+  TYPE_NAME (union_type) = get_identifier ("union%");
+  tree overhead_field = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
+				    get_identifier ("overhead%"), sizetype);
+  tree value_field = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
+				 get_identifier ("value%"), c_union_type);
+  DECL_FIELD_CONTEXT (overhead_field) = union_type;
+  DECL_FIELD_CONTEXT (value_field) = union_type;
+  DECL_CHAIN (value_field) = NULL_TREE;
+  DECL_CHAIN (overhead_field) = value_field;
+  TYPE_FIELDS (union_type) = overhead_field;
+
+  if (c_union_type_complete)
+    {
+      layout_type (union_type);
+      /* Set the back-end type mode now that all fields have had their size
+	 set.  */
+      compute_record_mode (union_type);
+    }
+  else
+    {
+      tree forward_refs = tree_cons (NULL_TREE, value_field,
+				     TYPE_FORWARD_REFERENCES (union_type));
+      TYPE_FORWARD_REFERENCES (union_type) = forward_refs;
+    }
+
+  SET_TYPE_STRUCTURAL_EQUALITY (union_type);
+  A68_UNION_TYPE_P (union_type) = 1;
+  return union_type;
+}
+
+/* Return the type for an array descriptor triplet.  */
+
+tree
+a68_triplet_type (void)
+{
+  static tree triplet_type = NULL_TREE;
+  if (triplet_type == NULL_TREE)
+    {
+      triplet_type = make_struct_type (NULL_TREE, "triplet%", 3,
+				       get_identifier ("lb%"),
+				       ssizetype,
+				       get_identifier ("ub%"),
+				       ssizetype,
+				       get_identifier ("stride%"),
+				       sizetype);
+    }
+
+  return triplet_type;
+}
+
+/* Return the lower bound field in an array descriptor triplet.  */
+
+tree
+a68_triplet_type_lower_bound (tree triplet)
+{
+  tree lb_field = TYPE_FIELDS (triplet);
+  return lb_field;
+}
+
+/* Lower a row mode to a GENERIC tree.
+
+   descriptor%
+     triplets%     Value of ARRAY_TYPE with an entry per multiple dimension.
+     {
+       li%         Lower bound of dimension.
+       ui%         Upper bound of dimension.
+       di%         Stride of dimension in bytes.
+     }
+   elements%       Pointer to the elements.
+   elements_size%  Size of elements% in bytes.
+*/
+
+static tree
+lower_row_mode (MOID_T *m)
+{
+  int num_dimensions = DIM (m);
+  tree triplet_type = a68_triplet_type ();
+  tree triplets_type = build_array_type (triplet_type,
+					 build_index_type (size_int (num_dimensions - 1)));
+  tree element_type = a68_lower_mode (SUB (m));
+  tree row_type = make_struct_type (NULL_TREE, "row%", 3,
+				    get_identifier ("triplets%"),
+				    triplets_type,
+				    get_identifier ("elements%"),
+				    build_pointer_type (element_type),
+				    get_identifier ("elements_size%"),
+				    sizetype);
+  layout_type (row_type);
+  A68_ROW_TYPE_P (row_type) = 1;
+  return row_type;
+}
+
+/* Given a row type, return the type of the pointer to its elements.  */
+
+tree
+a68_row_elements_pointer_type (tree type)
+{
+  gcc_assert (A68_ROW_TYPE_P (type));
+  /* elements% is the second field.  */
+  return TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
+}
+
+/* Given a row type, return the type of its elements.  */
+
+tree
+a68_row_elements_type (tree type)
+{
+  return TREE_TYPE (a68_row_elements_pointer_type (type));
+}
+
+/* Lower a ROWS mode to a GENERIC tree.
+
+   dim%         Number of dimensions.
+   triplets%    Pointer to triplets.
+
+   Values of this mode are passed to the operators UPB, LWB and ELEMS, which
+   need only descriptor information.  There is no need to store any multiple
+   elements.  */
+
+static tree
+lower_rows_mode (MOID_T *m ATTRIBUTE_UNUSED)
+{
+  static tree rows_type = NULL_TREE;
+
+  if (rows_type == NULL_TREE)
+    {
+      rows_type = make_struct_type (NULL_TREE, "rows%", 2,
+				    get_identifier ("dim%"),
+				    sizetype,
+				    get_identifier ("triplets%"),
+				    build_pointer_type (a68_triplet_type ()));
+      A68_ROWS_TYPE_P (rows_type) = 1;
+    }
+  return rows_type;
+}
+
+/* Lower modes in a series.  This is used as the mode of the mode yielded by an
+   enclosed clause that yields a series of united rows, for M_ROWS.  */
+
+static tree
+lower_series (MOID_T *m)
+{
+  for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p))
+    {
+      if (IS (MOID (p), SERIES_MODE) || IS (MOID (p), STOWED_MODE))
+	lower_series (MOID (p));
+      else
+	(void) a68_lower_mode (MOID (p));
+    }
+
+  return lower_rows_mode (NO_MOID);
+}
+
+/* Lower a mode to a GENERIC tree.  */
+
+static tree
+a68_lower_mode (MOID_T *m)
+{
+  tree type = NULL_TREE;
+
+  /* If the given mode has already been lowered, return the corresponding
+     tree.  */
+  if (CTYPE (m) != NULL)
+    return CTYPE (m);
+
+  if (EQUIVALENT (m) != NO_MOID && EQUIVALENT (m) != m)
+    /* This covers INDICANTs and standard MOIDS having an equivalent mode.  */
+    type = a68_lower_mode (EQUIVALENT (m));
+  else if (m == M_VOID)
+    type = a68_void_type;
+  else if (m == M_HIP)
+    type = lower_hip_mode (m);
+  else if (IS (m, STANDARD))
+    type = lower_standard_mode (m);
+  else if (IS_REF (m))
+    type = lower_ref_mode (m);
+  else if (IS_FLEX (m))
+    type = lower_flex_mode (m);
+  else if (IS (m, PROC_SYMBOL))
+    type = lower_proc_mode (m);
+  else if (IS_STRUCT (m))
+    type = lower_struct_mode (m);
+  else if (IS_ROW (m))
+    type = lower_row_mode (m);
+  else if (IS_UNION (m))
+    type = lower_union_mode (m);
+  else if (m == M_SIMPLOUT || m == M_SIMPLIN)
+    type = a68_void_type;
+  else if (IS (m, ROWS_SYMBOL))
+    /* ROWS is a mode that means "any row mode".  */
+    type = lower_rows_mode (m);
+  else if (m == M_VACUUM)
+    /* This is a mode that should not survive the parser.  */
+    type = a68_void_type;
+  else if (IS (m, SERIES_MODE) || IS (m, STOWED_MODE))
+    {
+      /* When dealing with operators the parser creates some modes that leak
+	 SERIES and STOWED "proto-modes" in them, such as for example:
+
+	 UNION ((INT, INT), INT, PROC [] CHAR)
+
+	 These are not really real Algol 68 modes and are useless by
+	 themselves, so when we find them, we traverse them (they ultimately
+	 contain valid modes that may show up in other contexts and that
+	 require being lowered) and just report them as VOID.  */
+      type = lower_series (m);
+    }
+  else
+    {
+      fatal_error (NODE (m) ? a68_get_node_location (NODE (m)) : UNKNOWN_LOCATION,
+		   "Cannot lower mode %s",
+		   a68_moid_to_string (m, MOID_ERROR_WIDTH, NODE (m)));
+    }
+
+  /* Associate the created tree node with the mode, and vice-versa.  */
+  gcc_assert (type != NULL_TREE);
+  TYPE_LANG_SPECIFIC (type) = a68_build_lang_type (m);
+  A68_TYPE_HAS_ROWS_P (type) = HAS_ROWS (m);
+  if (CTYPE (m) == NULL_TREE)
+    CTYPE (m) = type;
+  //  printf ("DONE LOWERING %s\n", a68_moid_to_string (m, MOID_ERROR_WIDTH, NODE (m)));
+  return type;
+}
+
+/* Lower MOIDs to GENERIC trees.  */
+
+void
+a68_lower_moids (MOID_T *mode)
+{
+  /* First pass: all modes but refs.  */
+  for (MOID_T *m = mode; m != NO_MOID; FORWARD (m))
+    (void) a68_lower_mode (m);
+
+  /* Try to layout all incomplete types.  This is a two-passes process.  */
+
+  for (MOID_T *m = mode; m != NO_MOID; FORWARD (m))
+    {
+      if (IS_STRUCT (m))
+	{
+	  tree struct_type = CTYPE (m);
+	  finish_incomplete_fields (struct_type);
+	}
+      else if (IS_UNION (m))
+	{
+	  tree union_type = CTYPE (m);
+	  tree c_union_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (union_type)));
+	  finish_incomplete_fields (c_union_type);
+	  finish_incomplete_fields (union_type);
+	}
+    }
+
+  for (MOID_T *m = mode; m != NO_MOID; FORWARD (m))
+    {
+      if (!COMPLETE_TYPE_P (CTYPE (m)))
+	{
+	  if (IS_STRUCT (m))
+	    {
+	      tree struct_type = CTYPE (m);
+	      layout_type (struct_type);
+	      compute_record_mode (struct_type);
+	    }
+	  else if (IS_UNION (m))
+	    {
+	      tree union_type = CTYPE (m);
+	      tree c_union_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (union_type)));
+
+	      if (!COMPLETE_TYPE_P (c_union_type))
+		{
+		  layout_type (c_union_type);
+		  compute_record_mode (c_union_type);
+		}
+
+	      layout_type (union_type);
+	      compute_record_mode (union_type);
+	    }
+	  else
+	    layout_type (CTYPE (m));
+	}
+    }
+
+  /* Sanity check.  */
+  for (MOID_T *m = mode; m != NO_MOID; FORWARD (m))
+    {
+      gcc_assert (COMPLETE_TYPE_P (CTYPE (m)));
+      if (IS_UNION (m))
+	{
+	  tree union_type = CTYPE (m);
+	  tree c_union_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (union_type)));
+	  gcc_assert (COMPLETE_TYPE_P (c_union_type));
+	}
+    }
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 39/47] a68: libga68: sources, spec and misc files
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (37 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 38/47] a68: low: modes Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 40/47] a68: libga68: build system Jose E. Marchesi
                   ` (8 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

ChangeLog

	* libga68/README: New file.
	* libga68/ga68-alloc.c: Likewise.
	* libga68/ga68-error.c: Likewise.
	* libga68/ga68-posix.c: Likewise.
	* libga68/ga68-standenv.c: Likewise.
	* libga68/ga68-unistr.c: Likewise.
	* libga68/ga68.h: Likewise.
	* libga68/libga68.c: Likewise.
	* libga68/libga68.spec.in: Likewise.
---
 libga68/README          |   2 +
 libga68/ga68-alloc.c    | 114 ++++++++
 libga68/ga68-error.c    | 151 ++++++++++
 libga68/ga68-posix.c    | 403 ++++++++++++++++++++++++++
 libga68/ga68-standenv.c |  48 ++++
 libga68/ga68-unistr.c   | 615 ++++++++++++++++++++++++++++++++++++++++
 libga68/ga68.h          | 119 ++++++++
 libga68/libga68.c       |  52 ++++
 libga68/libga68.spec.in |  11 +
 9 files changed, 1515 insertions(+)
 create mode 100644 libga68/README
 create mode 100644 libga68/ga68-alloc.c
 create mode 100644 libga68/ga68-error.c
 create mode 100644 libga68/ga68-posix.c
 create mode 100644 libga68/ga68-standenv.c
 create mode 100644 libga68/ga68-unistr.c
 create mode 100644 libga68/ga68.h
 create mode 100644 libga68/libga68.c
 create mode 100644 libga68/libga68.spec.in

diff --git a/libga68/README b/libga68/README
new file mode 100644
index 00000000000..23929a60451
--- /dev/null
+++ b/libga68/README
@@ -0,0 +1,2 @@
+This is the GNU Algol 68 run-time library.  It provides the run-time
+components needed by programs compiled by the ga68 compiler.
diff --git a/libga68/ga68-alloc.c b/libga68/ga68-alloc.c
new file mode 100644
index 00000000000..1cf922eb211
--- /dev/null
+++ b/libga68/ga68-alloc.c
@@ -0,0 +1,114 @@
+/* Run-time routines for memory allocation.
+
+   Copyright (C) 2025 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/>.  */
+
+#include <stdlib.h>
+
+#include "ga68.h"
+
+/* Heap allocation routines.  */
+
+void
+_libga68_free_internal (void *pt)
+{
+  free (pt);
+}
+
+void *
+_libga68_malloc_internal (size_t size)
+{
+  void *res = (void *) malloc (size);
+  if (!res)
+    _libga68_abort ("Virtual memory exhausted\n");
+  return res;
+}
+
+#if LIBGA68_WITH_GC
+#include <gc/gc.h>
+
+void
+_libga68_init_heap (void)
+{
+  if (!GC_is_init_called ())
+    {
+      GC_INIT ();
+      /*      GC_allow_register_threads (); */
+    }
+}
+
+void *
+_libga68_realloc (void *ptr, size_t size)
+{
+  void *res = (void *) GC_realloc (ptr, size);
+  if (!res)
+    _libga68_abort ("Virtual memory exhausted\n");
+  return res;
+}
+
+void *
+_libga68_realloc_unchecked (void *ptr, size_t size)
+{
+  void *res = (void *) GC_realloc (ptr, size);
+  return res;
+}
+
+void *
+_libga68_malloc (size_t size)
+{
+  void *res = (void *) GC_malloc (size);
+  if (!res)
+    _libga68_abort ("Virtual memory exhausted\n");
+  return res;
+}
+
+#else
+
+void
+_libga68_init_heap (void)
+{
+}
+
+void *
+_libga68_realloc (void *ptr, size_t size)
+{
+  void *res = (void *) realloc (ptr, size);
+  if (!res)
+    _libga68_abort ("Virtual memory exhausted\n");
+  return res;
+}
+
+void *
+_libga68_realloc_unchecked (void *ptr, size_t size)
+{
+  void *res = (void *) realloc (ptr, size);
+  return res;
+}
+
+void *
+_libga68_malloc (size_t size)
+{
+  void *res = (void *) malloc (size);
+  if (!res)
+    _libga68_abort ("Virtual memory exhausted\n");
+  return res;
+}
+
+#endif /* !LIBGA68_WITH_GC */
diff --git a/libga68/ga68-error.c b/libga68/ga68-error.c
new file mode 100644
index 00000000000..14edef242f4
--- /dev/null
+++ b/libga68/ga68-error.c
@@ -0,0 +1,151 @@
+/* Support run-time routines for error handling.
+
+   Copyright (C) 2025 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/>.  */
+
+#include <stdio.h>
+#include <stdlib.h> /* For abort.  */
+
+#include "ga68.h"
+
+/* Run-time error handling.
+
+   Please use the following format when outputing runtime error messages:
+
+     FILE:LINE:[COLUMN:] TEXT
+
+   This keeps the output aligned with other runtime libraries such as the
+   sanitizers.  */
+
+/* Emit a formatted error message to the standard output and then terminate the
+   process with an error code.  */
+
+void
+_libga68_abort (const char *fmt, ...)
+{
+  va_list ap;
+
+  va_start (ap, fmt);
+  vfprintf (stderr, fmt, ap);
+  abort ();
+  va_end (ap);
+}
+
+/* Assertion failure.  */
+
+void
+_libga68_assert (const char *filename, unsigned int lineno)
+{
+  _libga68_abort ("%s:%u: runtime error: ASSERT failure\n",
+		 filename, lineno);
+}
+
+/* Attempt to dereference NIL failure.  */
+
+void
+_libga68_derefnil (const char *filename, unsigned int lineno)
+{
+  _libga68_abort ("%s:%d: runtime error: attempt to dereference NIL\n",
+		  filename, lineno);
+}
+
+/* Invalid character expression.  */
+
+void
+_libga68_invalidcharerror (const char *filename, unsigned int lineno,
+			   int c)
+{
+  if (c < 0)
+    _libga68_abort ("%s:%d: runtime error: %d is not a valid character point\n",
+		    filename, lineno, c);
+  _libga68_abort ("%s:%d: runtime error: U+%x is not a valid character point\n",
+		  filename, lineno, c);
+}
+
+/* Out of bounds error in bits ELEM operator.  */
+
+void
+_libga68_bitsboundserror (const char *filename, unsigned int lineno,
+			  ssize_t pos)
+{
+  _libga68_abort ("%s:%d: runtime error: bound %d out of range in ELEM\n",
+		  filename, lineno, pos);
+}
+
+/* Unreachable error.  */
+
+void
+_libga68_unreachable (const char *filename, unsigned int lineno)
+{
+  _libga68_abort ("%s:%d: runtime error: unreachable reached\n",
+		  filename, lineno);
+}
+
+/* Lower bound failure.  */
+
+void
+_libga68_lower_bound (const char *filename, unsigned int lineno,
+			   ssize_t index, ssize_t lower_bound)
+{
+  _libga68_abort ("%s:%d: runtime error: lower bound %d must be >= %d\n",
+		  filename, lineno, index, lower_bound);
+}
+
+/* Upper bound failure.  */
+
+void
+_libga68_upper_bound (const char *filename, unsigned int lineno,
+			   ssize_t index, ssize_t upper_bound)
+{
+  _libga68_abort ("%s:%d: runtime error: upper bound %d must be <= %d\n",
+		  filename, lineno, index, upper_bound);
+}
+
+/* Bounds failure.  */
+
+void
+_libga68_bounds (const char *filename, unsigned int lineno,
+		 ssize_t index, ssize_t lower_bound, ssize_t upper_bound)
+{
+  _libga68_abort ("%s:%d: runtime error: bound %d out of range [%d:%d]\n",
+		  filename, lineno, index, lower_bound, upper_bound);
+}
+
+/* Dimension failure.  */
+
+void
+_libga68_dim (const char *filename, unsigned int lineno,
+	      size_t dim, size_t index)
+{
+  _libga68_abort ("%s:%d: runtime error: invalid dimension %d; shall be > 0 and <= %d\n",
+		  filename, lineno, index, dim);
+}
+
+/* Multiples have different bounds in assignations.  */
+
+void
+_libga68_bounds_mismatch (const char *filename, unsigned int lineno,
+			  size_t dim, ssize_t lb1, ssize_t ub1,
+			  ssize_t lb2, ssize_t ub2)
+{
+  _libga68_abort ("%s:%d: runtime error: multiple bounds mismatch in \
+assignation: dim %d: [%d:%d] /= [%d:%d]\n",
+		  filename, lineno, dim, lb1, ub1, lb2, ub2);
+}
diff --git a/libga68/ga68-posix.c b/libga68/ga68-posix.c
new file mode 100644
index 00000000000..cd8104cdc51
--- /dev/null
+++ b/libga68/ga68-posix.c
@@ -0,0 +1,403 @@
+/* Support run-time routines for the POSIX prelude.
+
+   Copyright (C) 2025 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/>.  */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <fcntl.h>  /* For open.  */
+#include <unistd.h> /* For close and write.  */
+#include <errno.h>  /* For errno.  */
+#include <sys/socket.h>
+#include <sys/stat.h> /* For struct stat */
+#include <netinet/in.h>
+#include <netdb.h> /* For gethostbyname.  */
+#include <limits.h> /* For LLONG_MAX */
+
+#include "ga68.h"
+
+/* Some Unicode code points used in this file.  */
+
+#define REPLACEMENT_CHARACTER 0xFFFD
+#define NEWLINE 0x000A
+
+/* Errno.  */
+
+static int _libga68_errno;
+
+/* Simple I/O based on POSIX file descriptors.  */
+
+int
+_libga68_posixerrno (void)
+{
+  return _libga68_errno;
+}
+
+void
+_libga68_posixperror (uint32_t *s, size_t len, size_t stride)
+{
+  size_t u8len;
+  uint8_t *u8str = _libga68_u32_to_u8 (s, len, stride, NULL, &u8len);
+
+  const char *errstr = strerror (_libga68_errno);
+  (void) write (2, u8str, u8len);
+  (void) write (2, ": ", 2);
+  (void) write (2, errstr, strlen (errstr));
+  (void) write (2, "\n", 1);
+}
+
+uint32_t *
+_libga68_posixstrerror (int errnum, size_t *len)
+{
+  const char *str = strerror (errnum);
+  return _libga68_u8_to_u32 ((const uint8_t *)str, strlen (str), NULL, len);
+}
+
+#define FILE_O_DEFAULT 0x0
+#define FILE_O_RDONLY  0x1
+#define FILE_O_WRONLY  0x2
+#define FILE_O_RDWR    0x3
+#define FILE_O_TRUNC   0x4
+
+int
+_libga68_posixfopen (uint32_t *pathname, size_t len, size_t stride,
+		     unsigned int flags)
+{
+  int openflags = 0;
+  size_t u8len;
+  uint8_t *u8pathname = _libga68_u32_to_u8 (pathname, len, stride, NULL, &u8len);
+
+  if (flags & FILE_O_RDONLY)
+    openflags |= O_RDONLY;
+  if (flags & FILE_O_WRONLY)
+    openflags |= O_WRONLY;
+  if (flags & FILE_O_RDWR)
+    openflags |= O_RDWR;
+  if (flags & FILE_O_TRUNC)
+    openflags |= O_TRUNC;
+
+  char *filepath = _libga68_malloc_internal (u8len + 1);
+  memcpy (filepath, u8pathname, u8len);
+  filepath[u8len] = '\0';
+  int fd = open (filepath, openflags);
+  _libga68_errno = errno;
+  _libga68_free_internal (filepath);
+  return fd;
+}
+
+int
+_libga68_posixcreat (uint32_t *pathname, size_t len, size_t stride,
+		     uint32_t mode)
+{
+  size_t u8len;
+  uint8_t *u8pathname = _libga68_u32_to_u8 (pathname, len, stride, NULL, &u8len);
+  u8pathname[u8len] = '\0';
+
+  int res = creat (u8pathname, mode);
+  _libga68_errno = errno;
+  return res;
+}
+
+int
+_libga68_posixclose (int fd)
+{
+  int res = close (fd);
+  _libga68_errno = errno;
+  return res;
+}
+
+/* Implementation of the posix prelude `posix argc'.  */
+
+int
+_libga68_posixargc (void)
+{
+  return _libga68_argc;
+}
+
+/* Implementation of the posix prelude `posix argv'.  */
+
+uint32_t *
+_libga68_posixargv (int n, size_t *len)
+{
+  if (n < 0 || n > _libga68_argc)
+    {
+      /* Return an empty string.  */
+      *len = 0;
+      return NULL;
+    }
+  else
+    {
+      char *arg = _libga68_argv[n - 1];
+      return _libga68_u8_to_u32 (arg, strlen (arg), NULL, len);
+    }
+}
+
+/* Implementation of the posix prelude `posix getenv'.  */
+
+void
+_libga68_posixgetenv (uint32_t *s, size_t len, size_t stride,
+		      uint32_t **r, size_t *rlen)
+{
+  size_t varlen;
+  char *varname = _libga68_u32_to_u8 (s, len, stride, NULL, &varlen);
+
+  char *var = _libga68_malloc_internal (varlen + 1);
+  memcpy (var, varname, varlen);
+  var[varlen] = '\0';
+  char *val = getenv (var);
+  _libga68_free_internal (var);
+
+  if (val == NULL)
+    {
+      /* Return an empty string.  */
+      *r = NULL;
+      *rlen = 0;
+    }
+  else
+    *r = _libga68_u8_to_u32 (val, strlen (val), NULL, rlen);
+}
+
+/* Implementation of the posix prelude `posix puts'.  */
+
+void
+_libga68_posixputs (uint32_t *s, size_t len, size_t stride)
+{
+  (void) _libga68_posixfputs (1, s, len, stride);
+}
+
+/* Implementation of the posix prelude `posix fputs'.  */
+
+int
+_libga68_posixfputs (int fd, uint32_t *s, size_t len, size_t stride)
+{
+  size_t u8len;
+  uint8_t *u8str = _libga68_u32_to_u8 (s, len, stride, NULL, &u8len);
+
+  ssize_t ret = write (fd, u8str, u8len);
+  _libga68_errno = errno;
+  if (ret == -1)
+    return 0;
+  else
+    return u8len;
+}
+
+/* Implementation of the posix prelude `posix putc'.  */
+
+uint32_t
+_libga68_posixfputc (int fd, uint32_t c)
+{
+  uint8_t u8[6];
+
+  int u8len = _libga68_u8_uctomb (u8, c, 6);
+  if (u8len < 0)
+    return REPLACEMENT_CHARACTER;
+
+  ssize_t ret = write (fd, &u8, u8len);
+  if (ret == -1)
+    return REPLACEMENT_CHARACTER;
+  else
+    return c;
+}
+
+/* Implementation of the posix prelude `posix putchar'.  */
+
+uint32_t
+_libga68_posixputchar (uint32_t c)
+{
+  return _libga68_posixfputc (1, c);
+}
+
+/* Implementation of the posix prelude `posix fgetc'.  */
+
+uint32_t
+_libga68_posixfgetc (int fd)
+{
+  /* We need to read one char (byte) at a time from FD, until we complete a
+     full Unicode character.  Then we convert to UCS-4.  */
+
+  uint8_t c;
+  uint8_t u8c[6];
+  size_t morechars = 0;
+  size_t i;
+
+  /* Read first UTF-8 character.  This gives us the total length of the
+     character.  */
+  if (read (fd, &c, 1) != 1)
+    return REPLACEMENT_CHARACTER;
+
+  if (c < 128)
+    morechars = 0;
+  else if (c < 224)
+    morechars = 1;
+  else if (c < 240)
+    morechars = 2;
+  else
+    morechars = 3;
+
+  u8c[0] = c;
+  for (i = 0; i < morechars; ++i)
+    {
+      if (read (fd, &c, 1) != 1)
+	return REPLACEMENT_CHARACTER;
+      u8c[i + 1] = c;
+    }
+
+  uint32_t res;
+  int length = _libga68_u8_mbtouc (&res, (const uint8_t *) &u8c, 1);
+  if (res == REPLACEMENT_CHARACTER || length != 1)
+    return REPLACEMENT_CHARACTER;
+  else
+    return res;
+}
+
+/* Implementation of the posix prelude `posix getchar'.  */
+
+uint32_t
+_libga68_posixgetchar (void)
+{
+  return _libga68_posixfgetc (0);
+}
+
+/* Implementation of the posix prelude `posix fgets'.  */
+
+uint32_t *
+_libga68_posixfgets (int fd, int nchars, size_t *len)
+{
+  uint32_t *res = NULL;
+  int n = 0;
+  uint32_t uc;
+
+  if (nchars > 0)
+    {
+      /* Read exactly nchar or until EOF.  */
+      res = _libga68_malloc (nchars * sizeof (uint32_t));
+      do
+	{
+	  uc = _libga68_posixfgetc (fd);
+	  if (uc == REPLACEMENT_CHARACTER)
+	    break;
+	  res[n++] = uc;
+	}
+      while (n < nchars);
+    }
+  else
+    {
+      /* Read until newline or EOF.  */
+      size_t allocated = 80 * sizeof (uint32_t);
+      res = _libga68_malloc (allocated);
+      do
+	{
+	  uc = _libga68_posixfgetc (fd);
+	  if (uc != REPLACEMENT_CHARACTER)
+	    {
+	      if (n % 80 == 0)
+		res = _libga68_realloc (res, n * 80 * sizeof (uint32_t) + 80 * sizeof (uint32_t));
+	      res[n++] = uc;
+	    }
+	}
+      while (uc != NEWLINE && uc != REPLACEMENT_CHARACTER);
+      if (n > 0)
+	res = _libga68_realloc (res, n * 80 * sizeof (uint32_t));
+    }
+
+  *len = n;
+  return res;
+}
+
+/* Implementation of the posix prelude `posix gets'.  */
+
+uint32_t *
+_libga68_posixgets (int nchars, size_t *len)
+{
+  return _libga68_posixfgets (0, nchars, len);
+}
+
+/* Implementation of the posix prelude `fconnect'.  */
+
+int
+_libga68_posixfconnect (uint32_t *str, size_t len, size_t stride,
+			int port)
+{
+  size_t u8len;
+  uint8_t *u8host = _libga68_u32_to_u8 (str, len, stride, NULL, &u8len);
+
+  /* Create a stream socket.  */
+  int fd = socket (AF_INET, SOCK_STREAM, 0);
+  _libga68_errno = errno;
+  if (fd < 0)
+    goto error;
+
+  /* Lookup the specified host.  */
+  char *host = _libga68_malloc_internal (u8len + 1);
+  memcpy (host, u8host, u8len);
+  host[u8len] = '\0';
+  struct hostent *server = gethostbyname (host);
+  if (server == NULL)
+    {
+      _libga68_errno = h_errno;
+      goto close_fd_and_error;
+    }
+
+  /* Connect the socket to the server.  */
+  struct sockaddr_in serv_addr;
+  memset (&serv_addr, 0, sizeof (serv_addr));
+  serv_addr.sin_family = AF_INET;
+  serv_addr.sin_port = htons (port);
+  memcpy (&serv_addr.sin_addr.s_addr,
+	  server->h_addr,
+	  server->h_length);
+  int res = connect (fd, (struct sockaddr *) &serv_addr,
+		     sizeof (serv_addr));
+  _libga68_errno = errno;
+  if (res == -1)
+    goto close_fd_and_error;
+
+  _libga68_free_internal (host);
+  return fd;
+
+ close_fd_and_error:
+  close (fd);
+ error:
+  _libga68_free_internal (host);
+  return -1;
+}
+
+/* Implementation of the posix prelude `fsize'.  */
+
+long long int
+_libga68_posixfsize (int fd)
+{
+  struct stat stat;
+
+  if (fstat (fd, &stat) == -1)
+    {
+      _libga68_errno = errno;
+      return -1;
+    }
+
+  if (stat.st_size > LLONG_MAX)
+    {
+      _libga68_errno = EOVERFLOW;
+      return -1;
+    }
+
+  return (long int) stat.st_size;
+}
diff --git a/libga68/ga68-standenv.c b/libga68/ga68-standenv.c
new file mode 100644
index 00000000000..2c1b7979af1
--- /dev/null
+++ b/libga68/ga68-standenv.c
@@ -0,0 +1,48 @@
+/* Support run-time routines for the standard prelude.
+
+   Copyright (C) 2025 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/>.  */
+
+#include <stdlib.h> /* For rand.  */
+
+#include "ga68.h"
+
+/* Implementation of the standard prelude `random' function.  */
+
+float
+_libga68_random (void)
+{
+  float res = (float) rand () / (float) (RAND_MAX);
+  return res;
+}
+
+double
+_libga68_longrandom (void)
+{
+  double res = (double) rand () / (float) (RAND_MAX);
+  return res;
+}
+
+long double
+_libga68_longlongrandom (void)
+{
+  long double res = (long double) rand () / (float) (RAND_MAX);
+  return res;
+}
diff --git a/libga68/ga68-unistr.c b/libga68/ga68-unistr.c
new file mode 100644
index 00000000000..7f2cb97de70
--- /dev/null
+++ b/libga68/ga68-unistr.c
@@ -0,0 +1,615 @@
+/* libga68 unicode support routines.
+   Copyright (C) 2009-2025 Free Software Foundation, Inc.
+   Copyright (C) 2025 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/>.  */
+
+/* The code in this file has been copied from the unistr gnulib module, written
+   by Bruno Haible, and adapted to support strides.  */
+
+#include <stddef.h> /* For ptrdiff_t */
+#include <stdlib.h>
+#include <stdint.h>
+#include <errno.h>
+#include <string.h>
+
+#include "ga68.h"
+
+/* CMP (n1, n2) performs a three-valued comparison on n1 vs. n2, where
+   n1 and n2 are expressions without side effects, that evaluate to real
+   numbers (excluding NaN).
+   It returns
+     1  if n1 > n2
+     0  if n1 == n2
+     -1 if n1 < n2
+   The naïve code   (n1 > n2 ? 1 : n1 < n2 ? -1 : 0)  produces a conditional
+   jump with nearly all GCC versions up to GCC 10.
+   This variant     (n1 < n2 ? -1 : n1 > n2)  produces a conditional with many
+   GCC versions up to GCC 9.
+   The better code  (n1 > n2) - (n1 < n2)  from Hacker's Delight § 2-9
+   avoids conditional jumps in all GCC versions >= 3.4.  */
+
+#define CMP(n1, n2) (((n1) > (n2)) - ((n1) < (n2)))
+
+/* MIN(a,b) returns the minimum of A and B.  */
+
+#ifndef MIN
+# define MIN(a,b) ((a) < (b) ? (a) : (b))
+#endif
+
+/* Compare two UCS-4 strings of same lenght, lexicographically.
+   Return -1, 0 or 1.  */
+
+int
+_libga68_u32_cmp (const uint32_t *s1, size_t stride1,
+		  const uint32_t *s2, size_t stride2,
+		  size_t n)
+{
+  stride1 = stride1 / sizeof (uint32_t);
+  stride2 = stride2 / sizeof (uint32_t);
+  
+  for (; n > 0;)
+    {
+      uint32_t uc1 = *s1;
+      s1 += stride1;
+      uint32_t uc2 = *s2;
+      s2 += stride2;
+      if (uc1 == uc2)
+        {
+          n--;
+          continue;
+        }
+      /* Note that uc1 and uc2 each have at most 31 bits. */
+      return (int)uc1 - (int)uc2;
+      /* > 0 if uc1 > uc2, < 0 if uc1 < uc2. */
+    }
+  return 0;
+}
+
+/* Compare two UCS-4 strings of perhaps different lenghts, lexicographically.
+   Return -1, 0 or 1.  */
+
+int
+_libga68_u32_cmp2 (const uint32_t *s1, size_t n1, size_t stride1,
+		   const uint32_t *s2, size_t n2, size_t stride2)
+{
+  int cmp = _libga68_u32_cmp (s1, stride1, s2, stride2, MIN (n1, n2));
+
+  if (cmp == 0)
+    cmp = CMP (n1, n2);
+
+  return cmp;
+}
+
+/* Get the UCS code for the first character of a given UTF-8 string.  */
+
+int
+_libga68_u8_mbtouc (uint32_t *puc, const uint8_t *s, size_t n)
+{
+  uint8_t c = *s;
+
+  if (c < 0x80)
+    {
+      *puc = c;
+      return 1;
+    }
+  else if (c >= 0xc2)
+    {
+      if (c < 0xe0)
+        {
+          if (n >= 2)
+            {
+              if ((s[1] ^ 0x80) < 0x40)
+                {
+                  *puc = ((unsigned int) (c & 0x1f) << 6)
+                         | (unsigned int) (s[1] ^ 0x80);
+                  return 2;
+                }
+              /* invalid multibyte character */
+            }
+          else
+            {
+              /* incomplete multibyte character */
+              *puc = 0xfffd;
+              return 1;
+            }
+        }
+      else if (c < 0xf0)
+        {
+          if (n >= 3)
+            {
+              if ((s[1] ^ 0x80) < 0x40
+                  && (c >= 0xe1 || s[1] >= 0xa0)
+                  && (c != 0xed || s[1] < 0xa0))
+                {
+                  if ((s[2] ^ 0x80) < 0x40)
+                    {
+                      *puc = ((unsigned int) (c & 0x0f) << 12)
+                             | ((unsigned int) (s[1] ^ 0x80) << 6)
+                             | (unsigned int) (s[2] ^ 0x80);
+                      return 3;
+                    }
+                  /* invalid multibyte character */
+                  *puc = 0xfffd;
+                  return 2;
+                }
+              /* invalid multibyte character */
+              *puc = 0xfffd;
+              return 1;
+            }
+          else
+            {
+              *puc = 0xfffd;
+              if (n == 1)
+                {
+                  /* incomplete multibyte character */
+                  return 1;
+                }
+              else
+                {
+                  if ((s[1] ^ 0x80) < 0x40
+                      && (c >= 0xe1 || s[1] >= 0xa0)
+                      && (c != 0xed || s[1] < 0xa0))
+                    {
+                      /* incomplete multibyte character */
+                      return 2;
+                    }
+                  else
+                    {
+                      /* invalid multibyte character */
+                      return 1;
+                    }
+                }
+            }
+        }
+      else if (c <= 0xf4)
+        {
+          if (n >= 4)
+            {
+              if ((s[1] ^ 0x80) < 0x40
+                  && (c >= 0xf1 || s[1] >= 0x90)
+                  && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90)))
+                {
+                  if ((s[2] ^ 0x80) < 0x40)
+                    {
+                      if ((s[3] ^ 0x80) < 0x40)
+                        {
+                          *puc = ((unsigned int) (c & 0x07) << 18)
+                                 | ((unsigned int) (s[1] ^ 0x80) << 12)
+                                 | ((unsigned int) (s[2] ^ 0x80) << 6)
+                                 | (unsigned int) (s[3] ^ 0x80);
+                          return 4;
+                        }
+                      /* invalid multibyte character */
+                      *puc = 0xfffd;
+                      return 3;
+                    }
+                  /* invalid multibyte character */
+                  *puc = 0xfffd;
+                  return 2;
+                }
+              /* invalid multibyte character */
+              *puc = 0xfffd;
+              return 1;
+            }
+          else
+            {
+              *puc = 0xfffd;
+              if (n == 1)
+                {
+                  /* incomplete multibyte character */
+                  return 1;
+                }
+              else
+                {
+                  if ((s[1] ^ 0x80) < 0x40
+                      && (c >= 0xf1 || s[1] >= 0x90)
+                      && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90)))
+                    {
+                      if (n == 2)
+                        {
+                          /* incomplete multibyte character */
+                          return 2;
+                        }
+                      else
+                        {
+                          if ((s[2] ^ 0x80) < 0x40)
+                            {
+                              /* incomplete multibyte character */
+                              return 3;
+                            }
+                          else
+                            {
+                              /* invalid multibyte character */
+                              return 2;
+                            }
+                        }
+                    }
+                  else
+                    {
+                      /* invalid multibyte character */
+                      return 1;
+                    }
+                }
+            }
+        }
+    }
+  /* invalid multibyte character */
+  *puc = 0xfffd;
+  return 1;
+}
+
+/* Encode a given UCS code in UTF-8.  */
+
+int
+_libga68_u8_uctomb (uint8_t *s, uint32_t uc, ptrdiff_t n)
+{
+  if (uc < 0x80)
+    {
+      if (n > 0)
+        {
+          s[0] = uc;
+          return 1;
+        }
+      /* else return -2, below.  */
+    }
+  else
+    {
+      int count;
+
+      if (uc < 0x800)
+        count = 2;
+      else if (uc < 0x10000)
+        {
+          if (uc < 0xd800 || uc >= 0xe000)
+            count = 3;
+          else
+            return -1;
+        }
+      else if (uc < 0x110000)
+        count = 4;
+      else
+        return -1;
+
+      if (n >= count)
+        {
+          switch (count) /* note: code falls through cases! */
+            {
+            case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000;
+              /* Fallthrough.  */
+            case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800;
+	      /* Fallthrough.  */
+            case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0;
+          /*case 1:*/ s[0] = uc;
+            }
+          return count;
+        }
+    }
+  return -2;
+}
+
+/* Convert UCS-4 to UTF-8  */
+
+uint8_t *
+_libga68_u32_to_u8 (const uint32_t *s, size_t n, size_t stride,
+		    uint8_t *resultbuf, size_t *lengthp)
+{
+  const uint32_t *s_end;
+  /* Output string accumulator.  */
+  uint8_t *result;
+  size_t allocated;
+  size_t length;
+
+  stride = stride / sizeof (uint32_t);
+  s_end = s + (n * stride);
+  
+  if (resultbuf != NULL)
+    {
+      result = resultbuf;
+      allocated = *lengthp;
+    }
+  else
+    {
+      result = NULL;
+      allocated = 0;
+    }
+  length = 0;
+  /* Invariants:
+     result is either == resultbuf or == NULL or malloc-allocated.
+     If length > 0, then result != NULL.  */
+
+  while (s < s_end)
+    {
+      uint32_t uc;
+      int count;
+
+      /* Fetch a Unicode character from the input string.  */
+      uc = *s;
+      s += stride;
+      /* No need to call the safe variant u32_mbtouc, because
+         u8_uctomb will verify uc anyway.  */
+
+      /* Store it in the output string.  */
+      count = _libga68_u8_uctomb (result + length, uc, allocated - length);
+      if (count == -1)
+        {
+          if (!(result == resultbuf || result == NULL))
+            free (result);
+          errno = EILSEQ;
+          return NULL;
+        }
+      if (count == -2)
+        {
+          uint8_t *memory;
+
+          allocated = (allocated > 0 ? 2 * allocated : 12);
+          if (length + 6 > allocated)
+            allocated = length + 6;
+          if (result == resultbuf || result == NULL)
+	    memory = (uint8_t *) _libga68_malloc (allocated * sizeof (uint8_t));
+          else
+	    memory =
+	      (uint8_t *) _libga68_realloc (result, allocated * sizeof (uint8_t));
+
+          if (result == resultbuf && length > 0)
+            memcpy ((char *) memory, (char *) result,
+                    length * sizeof (uint8_t));
+          result = memory;
+          count = _libga68_u8_uctomb (result + length, uc, allocated - length);
+          if (count < 0)
+            abort ();
+        }
+      length += count;
+    }
+
+  if (length == 0)
+    {
+      if (result == NULL)
+        {
+          /* Return a non-NULL value.  NULL means error.  */
+          result = (uint8_t *) _libga68_malloc (1);
+          if (result == NULL)
+            {
+              errno = ENOMEM;
+              return NULL;
+            }
+        }
+    }
+  else if (result != resultbuf && length < allocated)
+    {
+      /* Shrink the allocated memory if possible.  */
+      uint8_t *memory;
+
+      memory = (uint8_t *) _libga68_realloc_unchecked (result, length * sizeof (uint8_t));
+      if (memory != NULL)
+        result = memory;
+    }
+
+  *lengthp = length;
+  return result;
+}
+
+/* Used by ga68_u8_to_u32 below.  */
+
+static int
+_libga68_u8_mbtoucr (uint32_t *puc, const uint8_t *s, size_t n)
+{
+  uint8_t c = *s;
+
+  if (c < 0x80)
+    {
+      *puc = c;
+      return 1;
+    }
+  else if (c >= 0xc2)
+    {
+      if (c < 0xe0)
+        {
+          if (n >= 2)
+            {
+              if ((s[1] ^ 0x80) < 0x40)
+                {
+                  *puc = ((unsigned int) (c & 0x1f) << 6)
+                         | (unsigned int) (s[1] ^ 0x80);
+                  return 2;
+                }
+              /* invalid multibyte character */
+            }
+          else
+            {
+              /* incomplete multibyte character */
+              *puc = 0xfffd;
+              return -2;
+            }
+        }
+      else if (c < 0xf0)
+        {
+          if (n >= 2)
+            {
+              if ((s[1] ^ 0x80) < 0x40
+                  && (c >= 0xe1 || s[1] >= 0xa0)
+                  && (c != 0xed || s[1] < 0xa0))
+                {
+                  if (n >= 3)
+                    {
+                      if ((s[2] ^ 0x80) < 0x40)
+                        {
+                          *puc = ((unsigned int) (c & 0x0f) << 12)
+                                 | ((unsigned int) (s[1] ^ 0x80) << 6)
+                                 | (unsigned int) (s[2] ^ 0x80);
+                          return 3;
+                        }
+                      /* invalid multibyte character */
+                    }
+                  else
+                    {
+                      /* incomplete multibyte character */
+                      *puc = 0xfffd;
+                      return -2;
+                    }
+                }
+              /* invalid multibyte character */
+            }
+          else
+            {
+              /* incomplete multibyte character */
+              *puc = 0xfffd;
+              return -2;
+            }
+        }
+      else if (c <= 0xf4)
+        {
+          if (n >= 2)
+            {
+              if ((s[1] ^ 0x80) < 0x40
+                  && (c >= 0xf1 || s[1] >= 0x90)
+                  && (c < 0xf4 || (/* c == 0xf4 && */ s[1] < 0x90)))
+                {
+                  if (n >= 3)
+                    {
+                      if ((s[2] ^ 0x80) < 0x40)
+                        {
+                          if (n >= 4)
+                            {
+                              if ((s[3] ^ 0x80) < 0x40)
+                                {
+                                  *puc = ((unsigned int) (c & 0x07) << 18)
+                                         | ((unsigned int) (s[1] ^ 0x80) << 12)
+                                         | ((unsigned int) (s[2] ^ 0x80) << 6)
+                                         | (unsigned int) (s[3] ^ 0x80);
+                                  return 4;
+                                }
+                              /* invalid multibyte character */
+                            }
+                          else
+                            {
+                              /* incomplete multibyte character */
+                              *puc = 0xfffd;
+                              return -2;
+                            }
+                        }
+                      /* invalid multibyte character */
+                    }
+                  else
+                    {
+                      /* incomplete multibyte character */
+                      *puc = 0xfffd;
+                      return -2;
+                    }
+                }
+              /* invalid multibyte character */
+            }
+          else
+            {
+              /* incomplete multibyte character */
+              *puc = 0xfffd;
+              return -2;
+            }
+        }
+    }
+  /* invalid multibyte character */
+  *puc = 0xfffd;
+  return -1;
+}
+
+/* Convert UTF-8 to UTF-32/UCS-4  */
+
+uint32_t *
+_libga68_u8_to_u32 (const uint8_t *s, size_t n, uint32_t *resultbuf, size_t *lengthp)
+{
+  const uint8_t *s_end = s + n;
+  /* Output string accumulator.  */
+  uint32_t *result;
+  size_t allocated;
+  size_t length;
+
+  if (resultbuf != NULL)
+    {
+      result = resultbuf;
+      allocated = *lengthp;
+    }
+  else
+    {
+      result = NULL;
+      allocated = 0;
+    }
+  length = 0;
+  /* Invariants:
+     result is either == resultbuf or == NULL or malloc-allocated.
+     If length > 0, then result != NULL.  */
+
+  while (s < s_end)
+    {
+      uint32_t uc;
+      int count;
+
+      /* Fetch a Unicode character from the input string.  */
+      count = _libga68_u8_mbtoucr (&uc, s, s_end - s);
+      if (count < 0)
+        {
+          if (!(result == resultbuf || result == NULL))
+            free (result);
+          errno = EILSEQ;
+          return NULL;
+        }
+      s += count;
+
+      /* Store it in the output string.  */
+      if (length + 1 > allocated)
+        {
+          uint32_t *memory;
+
+          allocated = (allocated > 0 ? 2 * allocated : 12);
+          if (length + 1 > allocated)
+            allocated = length + 1;
+          if (result == resultbuf || result == NULL)
+	    memory = (uint32_t *) _libga68_malloc (allocated * sizeof (uint32_t));
+          else
+	    memory =
+	      (uint32_t *) _libga68_realloc (result, allocated * sizeof (uint32_t));
+
+          if (result == resultbuf && length > 0)
+            memcpy ((char *) memory, (char *) result,
+                    length * sizeof (uint32_t));
+          result = memory;
+        }
+      result[length++] = uc;
+    }
+
+  if (length == 0)
+    {
+      if (result == NULL)
+        {
+          /* Return a non-NULL value.  NULL means error.  */
+          result = (uint32_t *) _libga68_malloc (1);
+        }
+    }
+  else if (result != resultbuf && length < allocated)
+    {
+      /* Shrink the allocated memory if possible.  */
+      uint32_t *memory;
+
+      memory = (uint32_t *) _libga68_realloc_unchecked (result, length * sizeof (uint32_t));
+      if (memory != NULL)
+        result = memory;
+    }
+
+  *lengthp = length;
+  return result;
+}
diff --git a/libga68/ga68.h b/libga68/ga68.h
new file mode 100644
index 00000000000..083c9315090
--- /dev/null
+++ b/libga68/ga68.h
@@ -0,0 +1,119 @@
+/* Definitions for libga68.
+   Copyright (C) 2025 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/>.  */
+
+#ifndef GA68_H
+#define GA68_H
+
+#include <stddef.h> /* For size_t.  */
+#include <stdint.h>
+#include <stdarg.h>
+#ifdef __has_include
+# if __has_include (<sys/types.h>)
+#  include <sys/types.h> /* For ssize_t.  */
+# endif
+#endif
+
+/* ga68-error.c  */
+
+void _libga68_abort (const char *fmt, ...);
+void _libga68_assert (const char *filename, unsigned int lineno);
+void _libga68_derefnil (const char *filename, unsigned int lineno);
+void _libga68_invalidcharerror (const char *filename, unsigned int lineno,
+				int c);
+
+void _libga68_bitsboundserror (const char *filename, unsigned int lineno,
+			       ssize_t pos);
+void _libga68_unreachable (const char *filename, unsigned int lineno);
+void _libga68_lower_bound (const char *filename, unsigned int lineno,
+			   ssize_t index, ssize_t lower_bound);
+void _libga68_upper_bound (const char *filename, unsigned int lineno,
+			   ssize_t index, ssize_t upper_bound);
+void _libga68_bounds (const char *filename, unsigned int lineno,
+		      ssize_t index, ssize_t lower_bound, ssize_t upper_bound);
+void _libga68_dim (const char *filename, unsigned int lineno,
+		   size_t dim, size_t index);
+void _libga68_bounds_mismatch (const char *filename, unsigned int lineno,
+			       size_t dim, ssize_t lb1, ssize_t ub1,
+			       ssize_t lb2, ssize_t ub2);
+
+/* ga68-alloc.c  */
+
+void _libga68_init_heap (void);
+void *_libga68_malloc (size_t size);
+void *_libga68_malloc_internal (size_t size);
+void *_libga68_realloc (void *ptr, size_t size);
+void *_libga68_realloc_unchecked (void *ptr, size_t size);
+void _libga68_free_internal (void *ptr);
+
+/* ga68-standenv.c  */
+
+float _libga68_random (void);
+double _libga68_longrandom (void);
+long double _libga68_longlongrandom (void);
+
+/* ga68-posix.c  */
+
+int _libga68_posixerrno (void);
+void _libga68_posixperror (uint32_t *s, size_t len, size_t stride);
+uint32_t *_libga68_posixstrerror (int errnum, size_t *len);
+long long int _libga68_posixfsize (int fd);
+int _libga68_posixfopen (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_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);
+uint32_t _libga68_posixputchar (uint32_t c);
+uint32_t _libga68_posixfputc (int fd, uint32_t c);
+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);
+
+int _libga68_posixfconnect (uint32_t *str, size_t len, size_t stride,
+			    int port);
+
+/* ga68-unistr.c  */
+
+int _libga68_u32_cmp (const uint32_t *s1, size_t stride1,
+		      const uint32_t *s2, size_t stride2,
+		      size_t n);
+int _libga68_u32_cmp2 (const uint32_t *s1, size_t n1, size_t stride1,
+		       const uint32_t *s2, size_t n2, size_t stride2);
+int _libga68_u8_uctomb (uint8_t *s, uint32_t uc, ptrdiff_t n);
+int _libga68_u8_mbtouc (uint32_t *puc, const uint8_t *s, size_t n);
+uint8_t *_libga68_u32_to_u8 (const uint32_t *s, size_t n, size_t stride,
+			     uint8_t *resultbuf, size_t *lengthp);
+uint32_t *_libga68_u8_to_u32 (const uint8_t *s, size_t n,
+			      uint32_t *resultbuf, size_t *lengthp);
+
+/* libga68.c  */
+
+extern int _libga68_argc;
+extern char **_libga68_argv;
+
+void _libga68_set_exit_status (int status);
+
+#endif /* ! GA68_H */
diff --git a/libga68/libga68.c b/libga68/libga68.c
new file mode 100644
index 00000000000..60f930a5333
--- /dev/null
+++ b/libga68/libga68.c
@@ -0,0 +1,52 @@
+/* GNU Algol Compiler run-time.
+   Copyright (C) 2025 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/>.  */
+
+#include "ga68.h"
+
+/* argc and argv are preserved in the following objects.  */
+
+int _libga68_argc;
+char **_libga68_argv;
+
+/* Exit status of the program reported to the OS upon exit.  */
+
+static int exit_status;
+
+void
+_libga68_set_exit_status (int status)
+{
+  exit_status = status;
+}
+
+/* Entry point for Algol 68 programs.  */
+
+void __algol68_main (void);
+
+int
+main (int argc, char **argv)
+{
+  _libga68_argc = argc;
+  _libga68_argv = argv;
+
+  _libga68_init_heap ();
+  __algol68_main ();
+  return exit_status;
+}
diff --git a/libga68/libga68.spec.in b/libga68/libga68.spec.in
new file mode 100644
index 00000000000..7b09f655a2b
--- /dev/null
+++ b/libga68/libga68.spec.in
@@ -0,0 +1,11 @@
+#
+# This spec file is read by ga68 when linking.
+# It is used to specify the libraries we need to link in, in the right
+# order.
+#
+
+%rename link linkorig_ga68_renamed
+*link: %(linkorig_ga68_renamed)
+
+%rename lib liborig_ga68_renamed
+*lib: %{noga68lib: ; :@SPEC_LIBGA68_DEPS@} %(liborig_ga68_renamed)
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 40/47] a68: libga68: build system
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (38 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 39/47] a68: libga68: sources, spec and misc files Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 41/47] a68: libga68: build system (generated files) Jose E. Marchesi
                   ` (7 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

ChangeLog

	* libga68/Makefile.am: New file.
	* libga68/configure.ac: Likewise.
	* libga68/Makefile.in: Generate.
	* libga68/aclocal.m4: Likewise.
---
 libga68/Makefile.am  |  122 +++++
 libga68/Makefile.in  |  906 +++++++++++++++++++++++++++++++
 libga68/aclocal.m4   | 1200 ++++++++++++++++++++++++++++++++++++++++++
 libga68/configure.ac |  420 +++++++++++++++
 4 files changed, 2648 insertions(+)
 create mode 100644 libga68/Makefile.am
 create mode 100644 libga68/Makefile.in
 create mode 100644 libga68/aclocal.m4
 create mode 100644 libga68/configure.ac

diff --git a/libga68/Makefile.am b/libga68/Makefile.am
new file mode 100644
index 00000000000..accdd910d8d
--- /dev/null
+++ b/libga68/Makefile.am
@@ -0,0 +1,122 @@
+# Makefile for libga68.
+#   Copyright (C) 2025 Jose E. Marchesi.
+#
+# This file 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 of the License, or
+# (at your option) any later version.
+#
+# This program 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 this program; see the file COPYING3.  If not see
+# <http://www.gnu.org/licenses/>.
+#
+#
+# if this file is changed then you need to run
+#
+# autoreconf2.69
+
+AUTOMAKE_OPTIONS = 1.8 foreign
+ACLOCAL_AMFLAGS = -I .. -I ../config
+# Multilib support.
+MAKEOVERRIDES=
+
+gcc_version := $(shell @get_gcc_base_ver@ $(top_srcdir)/../gcc/BASE-VER)
+TOP_GCCDIR := $(shell cd $(top_srcdir) && cd .. && pwd)
+
+GCC_DIR = $(TOP_GCCDIR)/gcc
+A68_SRC = $(GCC_DIR)/algol68
+
+toolexeclibdir=@toolexeclibdir@
+toolexecdir=@toolexecdir@
+A68_FOR_TARGET=@A68_FOR_TARGET@
+
+extra_darwin_ldflags_libga68=@extra_darwin_ldflags_libga68@
+
+if ENABLE_DARWIN_AT_RPATH
+extra_darwin_ldflags_libga68 += -Wc,-nodefaultrpaths
+extra_darwin_ldflags_libga68 += -Wl,-rpath,@loader_path
+endif
+
+A68_BUILDDIR := $(shell pwd)
+
+# Work around what appears to be a GNU make bug handling MAKEFLAGS
+# values defined in terms of make variables, as is the case for CC and
+# friends when we are called from the top level Makefile.
+AM_MAKEFLAGS = \
+        "GCC_DIR=$(GCC_DIR)" \
+        "A68_SRC=$(A68_SRC)" \
+	"AR_FLAGS=$(AR_FLAGS)" \
+	"CC_FOR_BUILD=$(CC_FOR_BUILD)" \
+	"CC_FOR_TARGET=$(CC_FOR_TARGET)" \
+	"A68_FOR_TARGET=$(A68_FOR_TARGET)" \
+	"CFLAGS=$(CFLAGS)" \
+	"CXXFLAGS=$(CXXFLAGS)" \
+	"CFLAGS_FOR_BUILD=$(CFLAGS_FOR_BUILD)" \
+	"CFLAGS_FOR_TARGET=$(CFLAGS_FOR_TARGET)" \
+        "CFLAGS_LONGDOUBLE=$(CFLAGS_LONGDOUBLE)" \
+	"EXPECT=$(EXPECT)" \
+	"INSTALL=$(INSTALL)" \
+	"INSTALL_DATA=$(INSTALL_DATA)" \
+	"INSTALL_PROGRAM=$(INSTALL_PROGRAM)" \
+	"INSTALL_SCRIPT=$(INSTALL_SCRIPT)" \
+	"LDFLAGS=$(LDFLAGS)" \
+	"LIBCFLAGS=$(LIBCFLAGS)" \
+	"LIBCFLAGS_FOR_TARGET=$(LIBCFLAGS_FOR_TARGET)" \
+	"MAKE=$(MAKE)" \
+	"MAKEINFO=$(MAKEINFO) $(MAKEINFOFLAGS)" \
+	"PICFLAG=$(PICFLAG)" \
+	"PICFLAG_FOR_TARGET=$(PICFLAG_FOR_TARGET)" \
+	"SHELL=$(SHELL)" \
+	"RUNTESTFLAGS=$(RUNTESTFLAGS)" \
+	"exec_prefix=$(exec_prefix)" \
+	"infodir=$(infodir)" \
+	"libdir=$(libdir)" \
+	"includedir=$(includedir)" \
+	"prefix=$(prefix)" \
+	"tooldir=$(tooldir)" \
+	"gxx_include_dir=$(gxx_include_dir)" \
+	"AR=$(AR)" \
+	"AS=$(AS)" \
+	"LD=$(LD)" \
+	"RANLIB=$(RANLIB)" \
+	"NM=$(NM)" \
+	"NM_FOR_BUILD=$(NM_FOR_BUILD)" \
+	"NM_FOR_TARGET=$(NM_FOR_TARGET)" \
+	"DESTDIR=$(DESTDIR)" \
+	"WERROR=$(WERROR)" \
+        "TARGET_LIB_PATH=$(TARGET_LIB_PATH)" \
+        "TARGET_LIB_PATH_libgm2=$(TARGET_LIB_PATH_libgm2)" \
+	"LIBTOOL=$(A68_BUILDDIR)/libtool" \
+	"DARWIN_AT_RPATH=$(DARWIN_AT_RPATH)"
+
+# Subdir rules rely on $(FLAGS_TO_PASS)
+FLAGS_TO_PASS = $(AM_MAKEFLAGS)
+
+gcc_objdir = $(MULTIBUILDTOP)../../$(host_subdir)/gcc
+
+toolexeclib_DATA = libga68.spec
+toolexeclib_LTLIBRARIES = libga68.la
+
+libga68_la_SOURCES = libga68.c \
+                     ga68-unistr.c \
+                     ga68-posix.c \
+                     ga68-alloc.c \
+                     ga68-error.c \
+                     ga68-standenv.c \
+                     ga68.h
+libga68_la_LIBTOOLFLAGS =
+libga68_la_CFLAGS = $(LIBGA68_GCFLAGS) $(LIBGA68_BOEHM_GC_INCLUDES)
+libga68_la_LDFLAGS = -version-info $(libga68_VERSION) \
+    $(extra_darwin_ldflags_libga68)
+libga68_la_DEPENDENCIES = libga68.spec
+libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS)
+
+# target overrides
+-include $(tmake_file)
+
+include $(top_srcdir)/../multilib.am
diff --git a/libga68/Makefile.in b/libga68/Makefile.in
new file mode 100644
index 00000000000..1a1f40c82c7
--- /dev/null
+++ b/libga68/Makefile.in
@@ -0,0 +1,906 @@
+# Makefile.in generated by automake 1.15.1 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994-2017 Free Software Foundation, Inc.
+
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+# Makefile for libga68.
+#   Copyright (C) 2025 Jose E. Marchesi.
+#
+# This file 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 of the License, or
+# (at your option) any later version.
+#
+# This program 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 this program; see the file COPYING3.  If not see
+# <http://www.gnu.org/licenses/>.
+#
+#
+# if this file is changed then you need to run
+#
+# autoreconf2.69
+
+
+VPATH = @srcdir@
+am__is_gnu_make = { \
+  if test -z '$(MAKELEVEL)'; then \
+    false; \
+  elif test -n '$(MAKE_HOST)'; then \
+    true; \
+  elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \
+    true; \
+  else \
+    false; \
+  fi; \
+}
+am__make_running_with_option = \
+  case $${target_option-} in \
+      ?) ;; \
+      *) echo "am__make_running_with_option: internal error: invalid" \
+              "target option '$${target_option-}' specified" >&2; \
+         exit 1;; \
+  esac; \
+  has_opt=no; \
+  sane_makeflags=$$MAKEFLAGS; \
+  if $(am__is_gnu_make); then \
+    sane_makeflags=$$MFLAGS; \
+  else \
+    case $$MAKEFLAGS in \
+      *\\[\ \	]*) \
+        bs=\\; \
+        sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \
+          | sed "s/$$bs$$bs[$$bs $$bs	]*//g"`;; \
+    esac; \
+  fi; \
+  skip_next=no; \
+  strip_trailopt () \
+  { \
+    flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \
+  }; \
+  for flg in $$sane_makeflags; do \
+    test $$skip_next = yes && { skip_next=no; continue; }; \
+    case $$flg in \
+      *=*|--*) continue;; \
+        -*I) strip_trailopt 'I'; skip_next=yes;; \
+      -*I?*) strip_trailopt 'I';; \
+        -*O) strip_trailopt 'O'; skip_next=yes;; \
+      -*O?*) strip_trailopt 'O';; \
+        -*l) strip_trailopt 'l'; skip_next=yes;; \
+      -*l?*) strip_trailopt 'l';; \
+      -[dEDm]) skip_next=yes;; \
+      -[JT]) skip_next=yes;; \
+    esac; \
+    case $$flg in \
+      *$$target_option*) has_opt=yes; break;; \
+    esac; \
+  done; \
+  test $$has_opt = yes
+am__make_dryrun = (target_option=n; $(am__make_running_with_option))
+am__make_keepgoing = (target_option=k; $(am__make_running_with_option))
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+target_triplet = @target@
+@ENABLE_DARWIN_AT_RPATH_TRUE@am__append_1 = -Wc,-nodefaultrpaths \
+@ENABLE_DARWIN_AT_RPATH_TRUE@	-Wl,-rpath,@loader_path
+subdir = .
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/../config/acx.m4 \
+	$(top_srcdir)/../config/depstand.m4 \
+	$(top_srcdir)/../config/lead-dot.m4 \
+	$(top_srcdir)/../config/multi.m4 \
+	$(top_srcdir)/../config/no-executables.m4 \
+	$(top_srcdir)/../config/override.m4 \
+	$(top_srcdir)/../libtool.m4 $(top_srcdir)/../ltoptions.m4 \
+	$(top_srcdir)/../ltsugar.m4 $(top_srcdir)/../ltversion.m4 \
+	$(top_srcdir)/../lt~obsolete.m4 $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+	$(ACLOCAL_M4)
+DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \
+	$(am__configure_deps)
+am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \
+ configure.lineno config.status.lineno
+mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
+CONFIG_HEADER = config.h
+CONFIG_CLEAN_FILES = libga68.spec
+CONFIG_CLEAN_VPATH_FILES =
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+    $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+    *) f=$$p;; \
+  esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+  srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+  for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+  for p in $$list; do echo "$$p $$p"; done | \
+  sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+  $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+    if (++n[$$2] == $(am__install_max)) \
+      { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+    END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+  sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+  sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__uninstall_files_from_dir = { \
+  test -z "$$files" \
+    || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \
+    || { echo " ( cd '$$dir' && rm -f" $$files ")"; \
+         $(am__cd) "$$dir" && rm -f $$files; }; \
+  }
+am__installdirs = "$(DESTDIR)$(toolexeclibdir)" \
+	"$(DESTDIR)$(toolexeclibdir)"
+LTLIBRARIES = $(toolexeclib_LTLIBRARIES)
+am__DEPENDENCIES_1 =
+am_libga68_la_OBJECTS = libga68_la-libga68.lo \
+	libga68_la-ga68-unistr.lo libga68_la-ga68-posix.lo \
+	libga68_la-ga68-alloc.lo libga68_la-ga68-error.lo \
+	libga68_la-ga68-standenv.lo
+libga68_la_OBJECTS = $(am_libga68_la_OBJECTS)
+AM_V_lt = $(am__v_lt_@AM_V@)
+am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@)
+am__v_lt_0 = --silent
+am__v_lt_1 = 
+libga68_la_LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC \
+	$(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=link $(CCLD) \
+	$(libga68_la_CFLAGS) $(CFLAGS) $(libga68_la_LDFLAGS) \
+	$(LDFLAGS) -o $@
+AM_V_P = $(am__v_P_@AM_V@)
+am__v_P_ = $(am__v_P_@AM_DEFAULT_V@)
+am__v_P_0 = false
+am__v_P_1 = :
+AM_V_GEN = $(am__v_GEN_@AM_V@)
+am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@)
+am__v_GEN_0 = @echo "  GEN     " $@;
+am__v_GEN_1 = 
+AM_V_at = $(am__v_at_@AM_V@)
+am__v_at_ = $(am__v_at_@AM_DEFAULT_V@)
+am__v_at_0 = @
+am__v_at_1 = 
+DEFAULT_INCLUDES = -I.@am__isrc@
+depcomp = $(SHELL) $(top_srcdir)/../depcomp
+am__depfiles_maybe = depfiles
+am__mv = mv -f
+COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+	$(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
+LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \
+	$(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \
+	$(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \
+	$(AM_CFLAGS) $(CFLAGS)
+AM_V_CC = $(am__v_CC_@AM_V@)
+am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@)
+am__v_CC_0 = @echo "  CC      " $@;
+am__v_CC_1 = 
+CCLD = $(CC)
+LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \
+	$(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \
+	$(AM_LDFLAGS) $(LDFLAGS) -o $@
+AM_V_CCLD = $(am__v_CCLD_@AM_V@)
+am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@)
+am__v_CCLD_0 = @echo "  CCLD    " $@;
+am__v_CCLD_1 = 
+SOURCES = $(libga68_la_SOURCES)
+am__can_run_installinfo = \
+  case $$AM_UPDATE_INFO_DIR in \
+    n|no|NO) false;; \
+    *) (install-info --version) >/dev/null 2>&1;; \
+  esac
+DATA = $(toolexeclib_DATA)
+am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) \
+	$(LISP)config.h.in
+# Read a list of newline-separated strings from the standard input,
+# and print each of them once, without duplicates.  Input order is
+# *not* preserved.
+am__uniquify_input = $(AWK) '\
+  BEGIN { nonempty = 0; } \
+  { items[$$0] = 1; nonempty = 1; } \
+  END { if (nonempty) { for (i in items) print i; }; } \
+'
+# Make sure the list of sources is unique.  This is necessary because,
+# e.g., the same source file might be shared among _SOURCES variables
+# for different programs/libraries.
+am__define_uniq_tagged_files = \
+  list='$(am__tagged_files)'; \
+  unique=`for i in $$list; do \
+    if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+  done | $(am__uniquify_input)`
+ETAGS = etags
+CTAGS = ctags
+CSCOPE = cscope
+AM_RECURSIVE_TARGETS = cscope
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCAS = @CCAS@
+CCASDEPMODE = @CCASDEPMODE@
+CCASFLAGS = @CCASFLAGS@
+CCDEPMODE = @CCDEPMODE@
+CC_FOR_BUILD = @CC_FOR_BUILD@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CXX = @CXX@
+CXXCPP = @CXXCPP@
+CXXDEPMODE = @CXXDEPMODE@
+CXXFLAGS = @CXXFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBGA68_BOEHM_GC_INCLUDES = @LIBGA68_BOEHM_GC_INCLUDES@
+LIBGA68_BOEHM_GC_LIBS = @LIBGA68_BOEHM_GC_LIBS@
+LIBGA68_GCFLAGS = @LIBGA68_GCFLAGS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIPO = @LIPO@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAINT = @MAINT@
+MAKEINFO = @MAKEINFO@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+SPEC_LIBGA68_DEPS = @SPEC_LIBGA68_DEPS@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_CXX = @ac_ct_CXX@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_libsubdir = @build_libsubdir@
+build_os = @build_os@
+build_subdir = @build_subdir@
+build_vendor = @build_vendor@
+builddir = @builddir@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+enable_shared = @enable_shared@
+enable_static = @enable_static@
+exec_prefix = @exec_prefix@
+extra_darwin_ldflags_libga68 = @extra_darwin_ldflags_libga68@ \
+	$(am__append_1)
+get_gcc_base_ver = @get_gcc_base_ver@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_noncanonical = @host_noncanonical@
+host_os = @host_os@
+host_subdir = @host_subdir@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+libga68_VERSION = @libga68_VERSION@
+localedir = @localedir@
+localstatedir = @localstatedir@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+multi_basedir = @multi_basedir@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+slibdir = @slibdir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target = @target@
+target_alias = @target_alias@
+target_cpu = @target_cpu@
+target_noncanonical = @target_noncanonical@
+target_os = @target_os@
+target_subdir = @target_subdir@
+target_vendor = @target_vendor@
+toolexecdir = @toolexecdir@
+toolexeclibdir = @toolexeclibdir@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+AUTOMAKE_OPTIONS = 1.8 foreign
+ACLOCAL_AMFLAGS = -I .. -I ../config
+# Multilib support.
+MAKEOVERRIDES = 
+gcc_version := $(shell @get_gcc_base_ver@ $(top_srcdir)/../gcc/BASE-VER)
+TOP_GCCDIR := $(shell cd $(top_srcdir) && cd .. && pwd)
+GCC_DIR = $(TOP_GCCDIR)/gcc
+A68_SRC = $(GCC_DIR)/algol68
+A68_FOR_TARGET = @A68_FOR_TARGET@
+A68_BUILDDIR := $(shell pwd)
+
+# Work around what appears to be a GNU make bug handling MAKEFLAGS
+# values defined in terms of make variables, as is the case for CC and
+# friends when we are called from the top level Makefile.
+AM_MAKEFLAGS = \
+        "GCC_DIR=$(GCC_DIR)" \
+        "A68_SRC=$(A68_SRC)" \
+	"AR_FLAGS=$(AR_FLAGS)" \
+	"CC_FOR_BUILD=$(CC_FOR_BUILD)" \
+	"CC_FOR_TARGET=$(CC_FOR_TARGET)" \
+	"A68_FOR_TARGET=$(A68_FOR_TARGET)" \
+	"CFLAGS=$(CFLAGS)" \
+	"CXXFLAGS=$(CXXFLAGS)" \
+	"CFLAGS_FOR_BUILD=$(CFLAGS_FOR_BUILD)" \
+	"CFLAGS_FOR_TARGET=$(CFLAGS_FOR_TARGET)" \
+        "CFLAGS_LONGDOUBLE=$(CFLAGS_LONGDOUBLE)" \
+	"EXPECT=$(EXPECT)" \
+	"INSTALL=$(INSTALL)" \
+	"INSTALL_DATA=$(INSTALL_DATA)" \
+	"INSTALL_PROGRAM=$(INSTALL_PROGRAM)" \
+	"INSTALL_SCRIPT=$(INSTALL_SCRIPT)" \
+	"LDFLAGS=$(LDFLAGS)" \
+	"LIBCFLAGS=$(LIBCFLAGS)" \
+	"LIBCFLAGS_FOR_TARGET=$(LIBCFLAGS_FOR_TARGET)" \
+	"MAKE=$(MAKE)" \
+	"MAKEINFO=$(MAKEINFO) $(MAKEINFOFLAGS)" \
+	"PICFLAG=$(PICFLAG)" \
+	"PICFLAG_FOR_TARGET=$(PICFLAG_FOR_TARGET)" \
+	"SHELL=$(SHELL)" \
+	"RUNTESTFLAGS=$(RUNTESTFLAGS)" \
+	"exec_prefix=$(exec_prefix)" \
+	"infodir=$(infodir)" \
+	"libdir=$(libdir)" \
+	"includedir=$(includedir)" \
+	"prefix=$(prefix)" \
+	"tooldir=$(tooldir)" \
+	"gxx_include_dir=$(gxx_include_dir)" \
+	"AR=$(AR)" \
+	"AS=$(AS)" \
+	"LD=$(LD)" \
+	"RANLIB=$(RANLIB)" \
+	"NM=$(NM)" \
+	"NM_FOR_BUILD=$(NM_FOR_BUILD)" \
+	"NM_FOR_TARGET=$(NM_FOR_TARGET)" \
+	"DESTDIR=$(DESTDIR)" \
+	"WERROR=$(WERROR)" \
+        "TARGET_LIB_PATH=$(TARGET_LIB_PATH)" \
+        "TARGET_LIB_PATH_libgm2=$(TARGET_LIB_PATH_libgm2)" \
+	"LIBTOOL=$(A68_BUILDDIR)/libtool" \
+	"DARWIN_AT_RPATH=$(DARWIN_AT_RPATH)"
+
+
+# Subdir rules rely on $(FLAGS_TO_PASS)
+FLAGS_TO_PASS = $(AM_MAKEFLAGS)
+gcc_objdir = $(MULTIBUILDTOP)../../$(host_subdir)/gcc
+toolexeclib_DATA = libga68.spec
+toolexeclib_LTLIBRARIES = libga68.la
+libga68_la_SOURCES = libga68.c \
+                     ga68-unistr.c \
+                     ga68-posix.c \
+                     ga68-alloc.c \
+                     ga68-error.c \
+                     ga68-standenv.c \
+                     ga68.h
+
+libga68_la_LIBTOOLFLAGS = 
+libga68_la_CFLAGS = $(LIBGA68_GCFLAGS) $(LIBGA68_BOEHM_GC_INCLUDES)
+libga68_la_LDFLAGS = -version-info $(libga68_VERSION) \
+    $(extra_darwin_ldflags_libga68)
+
+libga68_la_DEPENDENCIES = libga68.spec
+libga68_la_LIBADD = $(LIBGA68_BOEHM_GC_LIBS)
+MULTISRCTOP = 
+MULTIBUILDTOP = 
+MULTIDIRS = 
+MULTISUBDIR = 
+MULTIDO = true
+MULTICLEAN = true
+all: config.h
+	$(MAKE) $(AM_MAKEFLAGS) all-am
+
+.SUFFIXES:
+.SUFFIXES: .c .lo .o .obj
+am--refresh: Makefile
+	@:
+$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(top_srcdir)/../multilib.am $(am__configure_deps)
+	@for dep in $?; do \
+	  case '$(am__configure_deps)' in \
+	    *$$dep*) \
+	      echo ' cd $(srcdir) && $(AUTOMAKE) --foreign'; \
+	      $(am__cd) $(srcdir) && $(AUTOMAKE) --foreign \
+		&& exit 0; \
+	      exit 1;; \
+	  esac; \
+	done; \
+	echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign Makefile'; \
+	$(am__cd) $(top_srcdir) && \
+	  $(AUTOMAKE) --foreign Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+	@case '$?' in \
+	  *config.status*) \
+	    echo ' $(SHELL) ./config.status'; \
+	    $(SHELL) ./config.status;; \
+	  *) \
+	    echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \
+	    cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \
+	esac;
+$(top_srcdir)/../multilib.am $(am__empty):
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+	$(SHELL) ./config.status --recheck
+
+$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps)
+	$(am__cd) $(srcdir) && $(AUTOCONF)
+$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps)
+	$(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS)
+$(am__aclocal_m4_deps):
+
+config.h: stamp-h1
+	@test -f $@ || rm -f stamp-h1
+	@test -f $@ || $(MAKE) $(AM_MAKEFLAGS) stamp-h1
+
+stamp-h1: $(srcdir)/config.h.in $(top_builddir)/config.status
+	@rm -f stamp-h1
+	cd $(top_builddir) && $(SHELL) ./config.status config.h
+$(srcdir)/config.h.in: @MAINTAINER_MODE_TRUE@ $(am__configure_deps) 
+	($(am__cd) $(top_srcdir) && $(AUTOHEADER))
+	rm -f stamp-h1
+	touch $@
+
+distclean-hdr:
+	-rm -f config.h stamp-h1
+libga68.spec: $(top_builddir)/config.status $(srcdir)/libga68.spec.in
+	cd $(top_builddir) && $(SHELL) ./config.status $@
+
+install-toolexeclibLTLIBRARIES: $(toolexeclib_LTLIBRARIES)
+	@$(NORMAL_INSTALL)
+	@list='$(toolexeclib_LTLIBRARIES)'; test -n "$(toolexeclibdir)" || list=; \
+	list2=; for p in $$list; do \
+	  if test -f $$p; then \
+	    list2="$$list2 $$p"; \
+	  else :; fi; \
+	done; \
+	test -z "$$list2" || { \
+	  echo " $(MKDIR_P) '$(DESTDIR)$(toolexeclibdir)'"; \
+	  $(MKDIR_P) "$(DESTDIR)$(toolexeclibdir)" || exit 1; \
+	  echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 '$(DESTDIR)$(toolexeclibdir)'"; \
+	  $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL) $(INSTALL_STRIP_FLAG) $$list2 "$(DESTDIR)$(toolexeclibdir)"; \
+	}
+
+uninstall-toolexeclibLTLIBRARIES:
+	@$(NORMAL_UNINSTALL)
+	@list='$(toolexeclib_LTLIBRARIES)'; test -n "$(toolexeclibdir)" || list=; \
+	for p in $$list; do \
+	  $(am__strip_dir) \
+	  echo " $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f '$(DESTDIR)$(toolexeclibdir)/$$f'"; \
+	  $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=uninstall rm -f "$(DESTDIR)$(toolexeclibdir)/$$f"; \
+	done
+
+clean-toolexeclibLTLIBRARIES:
+	-test -z "$(toolexeclib_LTLIBRARIES)" || rm -f $(toolexeclib_LTLIBRARIES)
+	@list='$(toolexeclib_LTLIBRARIES)'; \
+	locs=`for p in $$list; do echo $$p; done | \
+	      sed 's|^[^/]*$$|.|; s|/[^/]*$$||; s|$$|/so_locations|' | \
+	      sort -u`; \
+	test -z "$$locs" || { \
+	  echo rm -f $${locs}; \
+	  rm -f $${locs}; \
+	}
+
+libga68.la: $(libga68_la_OBJECTS) $(libga68_la_DEPENDENCIES) $(EXTRA_libga68_la_DEPENDENCIES) 
+	$(AM_V_CCLD)$(libga68_la_LINK) -rpath $(toolexeclibdir) $(libga68_la_OBJECTS) $(libga68_la_LIBADD) $(LIBS)
+
+mostlyclean-compile:
+	-rm -f *.$(OBJEXT)
+
+distclean-compile:
+	-rm -f *.tab.c
+
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libga68_la-ga68-alloc.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libga68_la-ga68-error.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libga68_la-ga68-posix.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libga68_la-ga68-standenv.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libga68_la-ga68-unistr.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libga68_la-libga68.Plo@am__quote@
+
+.c.o:
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $<
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $<
+
+.c.obj:
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'`
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'`
+
+.c.lo:
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(LTCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $<
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(LTCOMPILE) -c -o $@ $<
+
+libga68_la-libga68.lo: libga68.c
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -MT libga68_la-libga68.lo -MD -MP -MF $(DEPDIR)/libga68_la-libga68.Tpo -c -o libga68_la-libga68.lo `test -f 'libga68.c' || echo '$(srcdir)/'`libga68.c
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/libga68_la-libga68.Tpo $(DEPDIR)/libga68_la-libga68.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='libga68.c' object='libga68_la-libga68.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -c -o libga68_la-libga68.lo `test -f 'libga68.c' || echo '$(srcdir)/'`libga68.c
+
+libga68_la-ga68-unistr.lo: ga68-unistr.c
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -MT libga68_la-ga68-unistr.lo -MD -MP -MF $(DEPDIR)/libga68_la-ga68-unistr.Tpo -c -o libga68_la-ga68-unistr.lo `test -f 'ga68-unistr.c' || echo '$(srcdir)/'`ga68-unistr.c
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/libga68_la-ga68-unistr.Tpo $(DEPDIR)/libga68_la-ga68-unistr.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='ga68-unistr.c' object='libga68_la-ga68-unistr.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -c -o libga68_la-ga68-unistr.lo `test -f 'ga68-unistr.c' || echo '$(srcdir)/'`ga68-unistr.c
+
+libga68_la-ga68-posix.lo: ga68-posix.c
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -MT libga68_la-ga68-posix.lo -MD -MP -MF $(DEPDIR)/libga68_la-ga68-posix.Tpo -c -o libga68_la-ga68-posix.lo `test -f 'ga68-posix.c' || echo '$(srcdir)/'`ga68-posix.c
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/libga68_la-ga68-posix.Tpo $(DEPDIR)/libga68_la-ga68-posix.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='ga68-posix.c' object='libga68_la-ga68-posix.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -c -o libga68_la-ga68-posix.lo `test -f 'ga68-posix.c' || echo '$(srcdir)/'`ga68-posix.c
+
+libga68_la-ga68-alloc.lo: ga68-alloc.c
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -MT libga68_la-ga68-alloc.lo -MD -MP -MF $(DEPDIR)/libga68_la-ga68-alloc.Tpo -c -o libga68_la-ga68-alloc.lo `test -f 'ga68-alloc.c' || echo '$(srcdir)/'`ga68-alloc.c
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/libga68_la-ga68-alloc.Tpo $(DEPDIR)/libga68_la-ga68-alloc.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='ga68-alloc.c' object='libga68_la-ga68-alloc.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -c -o libga68_la-ga68-alloc.lo `test -f 'ga68-alloc.c' || echo '$(srcdir)/'`ga68-alloc.c
+
+libga68_la-ga68-error.lo: ga68-error.c
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -MT libga68_la-ga68-error.lo -MD -MP -MF $(DEPDIR)/libga68_la-ga68-error.Tpo -c -o libga68_la-ga68-error.lo `test -f 'ga68-error.c' || echo '$(srcdir)/'`ga68-error.c
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/libga68_la-ga68-error.Tpo $(DEPDIR)/libga68_la-ga68-error.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='ga68-error.c' object='libga68_la-ga68-error.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -c -o libga68_la-ga68-error.lo `test -f 'ga68-error.c' || echo '$(srcdir)/'`ga68-error.c
+
+libga68_la-ga68-standenv.lo: ga68-standenv.c
+@am__fastdepCC_TRUE@	$(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -MT libga68_la-ga68-standenv.lo -MD -MP -MF $(DEPDIR)/libga68_la-ga68-standenv.Tpo -c -o libga68_la-ga68-standenv.lo `test -f 'ga68-standenv.c' || echo '$(srcdir)/'`ga68-standenv.c
+@am__fastdepCC_TRUE@	$(AM_V_at)$(am__mv) $(DEPDIR)/libga68_la-ga68-standenv.Tpo $(DEPDIR)/libga68_la-ga68-standenv.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	$(AM_V_CC)source='ga68-standenv.c' object='libga68_la-ga68-standenv.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@	DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@	$(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(libga68_la_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(libga68_la_CFLAGS) $(CFLAGS) -c -o libga68_la-ga68-standenv.lo `test -f 'ga68-standenv.c' || echo '$(srcdir)/'`ga68-standenv.c
+
+mostlyclean-libtool:
+	-rm -f *.lo
+
+clean-libtool:
+	-rm -rf .libs _libs
+
+distclean-libtool:
+	-rm -f libtool config.lt
+install-toolexeclibDATA: $(toolexeclib_DATA)
+	@$(NORMAL_INSTALL)
+	@list='$(toolexeclib_DATA)'; test -n "$(toolexeclibdir)" || list=; \
+	if test -n "$$list"; then \
+	  echo " $(MKDIR_P) '$(DESTDIR)$(toolexeclibdir)'"; \
+	  $(MKDIR_P) "$(DESTDIR)$(toolexeclibdir)" || exit 1; \
+	fi; \
+	for p in $$list; do \
+	  if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+	  echo "$$d$$p"; \
+	done | $(am__base_list) | \
+	while read files; do \
+	  echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(toolexeclibdir)'"; \
+	  $(INSTALL_DATA) $$files "$(DESTDIR)$(toolexeclibdir)" || exit $$?; \
+	done
+
+uninstall-toolexeclibDATA:
+	@$(NORMAL_UNINSTALL)
+	@list='$(toolexeclib_DATA)'; test -n "$(toolexeclibdir)" || list=; \
+	files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+	dir='$(DESTDIR)$(toolexeclibdir)'; $(am__uninstall_files_from_dir)
+
+ID: $(am__tagged_files)
+	$(am__define_uniq_tagged_files); mkid -fID $$unique
+tags: tags-am
+TAGS: tags
+
+tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files)
+	set x; \
+	here=`pwd`; \
+	$(am__define_uniq_tagged_files); \
+	shift; \
+	if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+	  test -n "$$unique" || unique=$$empty_fix; \
+	  if test $$# -gt 0; then \
+	    $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+	      "$$@" $$unique; \
+	  else \
+	    $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+	      $$unique; \
+	  fi; \
+	fi
+ctags: ctags-am
+
+CTAGS: ctags
+ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files)
+	$(am__define_uniq_tagged_files); \
+	test -z "$(CTAGS_ARGS)$$unique" \
+	  || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+	     $$unique
+
+GTAGS:
+	here=`$(am__cd) $(top_builddir) && pwd` \
+	  && $(am__cd) $(top_srcdir) \
+	  && gtags -i $(GTAGS_ARGS) "$$here"
+cscope: cscope.files
+	test ! -s cscope.files \
+	  || $(CSCOPE) -b -q $(AM_CSCOPEFLAGS) $(CSCOPEFLAGS) -i cscope.files $(CSCOPE_ARGS)
+clean-cscope:
+	-rm -f cscope.files
+cscope.files: clean-cscope cscopelist
+cscopelist: cscopelist-am
+
+cscopelist-am: $(am__tagged_files)
+	list='$(am__tagged_files)'; \
+	case "$(srcdir)" in \
+	  [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \
+	  *) sdir=$(subdir)/$(srcdir) ;; \
+	esac; \
+	for i in $$list; do \
+	  if test -f "$$i"; then \
+	    echo "$(subdir)/$$i"; \
+	  else \
+	    echo "$$sdir/$$i"; \
+	  fi; \
+	done >> $(top_builddir)/cscope.files
+
+distclean-tags:
+	-rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+	-rm -f cscope.out cscope.in.out cscope.po.out cscope.files
+check-am: all-am
+check: check-am
+all-am: Makefile $(LTLIBRARIES) $(DATA) config.h all-local
+installdirs:
+	for dir in "$(DESTDIR)$(toolexeclibdir)" "$(DESTDIR)$(toolexeclibdir)"; do \
+	  test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+	done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+	@$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+	if test -z '$(STRIP)'; then \
+	  $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+	    install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+	      install; \
+	else \
+	  $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+	    install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+	    "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \
+	fi
+mostlyclean-generic:
+
+clean-generic:
+
+distclean-generic:
+	-test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+	-test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+	@echo "This command is intended for maintainers to use"
+	@echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-generic clean-libtool clean-local \
+	clean-toolexeclibLTLIBRARIES mostlyclean-am
+
+distclean: distclean-am
+	-rm -f $(am__CONFIG_DISTCLEAN_FILES)
+	-rm -rf ./$(DEPDIR)
+	-rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+	distclean-hdr distclean-libtool distclean-local distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am:
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am: install-exec-local install-toolexeclibDATA \
+	install-toolexeclibLTLIBRARIES
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+	-rm -f $(am__CONFIG_DISTCLEAN_FILES)
+	-rm -rf $(top_srcdir)/autom4te.cache
+	-rm -rf ./$(DEPDIR)
+	-rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic \
+	maintainer-clean-local
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+	mostlyclean-libtool mostlyclean-local
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-toolexeclibDATA \
+	uninstall-toolexeclibLTLIBRARIES
+
+.MAKE: all install-am install-strip
+
+.PHONY: CTAGS GTAGS TAGS all all-am all-local am--refresh check \
+	check-am clean clean-cscope clean-generic clean-libtool \
+	clean-local clean-toolexeclibLTLIBRARIES cscope cscopelist-am \
+	ctags ctags-am distclean distclean-compile distclean-generic \
+	distclean-hdr distclean-libtool distclean-local distclean-tags \
+	dvi dvi-am html html-am info info-am install install-am \
+	install-data install-data-am install-dvi install-dvi-am \
+	install-exec install-exec-am install-exec-local install-html \
+	install-html-am install-info install-info-am install-man \
+	install-pdf install-pdf-am install-ps install-ps-am \
+	install-strip install-toolexeclibDATA \
+	install-toolexeclibLTLIBRARIES installcheck installcheck-am \
+	installdirs maintainer-clean maintainer-clean-generic \
+	maintainer-clean-local mostlyclean mostlyclean-compile \
+	mostlyclean-generic mostlyclean-libtool mostlyclean-local pdf \
+	pdf-am ps ps-am tags tags-am uninstall uninstall-am \
+	uninstall-toolexeclibDATA uninstall-toolexeclibLTLIBRARIES
+
+.PRECIOUS: Makefile
+
+
+# target overrides
+-include $(tmake_file)
+
+# GNU Make needs to see an explicit $(MAKE) variable in the command it
+# runs to enable its job server during parallel builds.  Hence the
+# comments below.
+all-multi:
+	$(MULTIDO) $(AM_MAKEFLAGS) DO=all multi-do # $(MAKE)
+install-multi:
+	$(MULTIDO) $(AM_MAKEFLAGS) DO=install multi-do # $(MAKE)
+mostlyclean-multi:
+	$(MULTICLEAN) $(AM_MAKEFLAGS) DO=mostlyclean multi-clean # $(MAKE)
+clean-multi:
+	$(MULTICLEAN) $(AM_MAKEFLAGS) DO=clean multi-clean # $(MAKE)
+distclean-multi:
+	$(MULTICLEAN) $(AM_MAKEFLAGS) DO=distclean multi-clean # $(MAKE)
+maintainer-clean-multi:
+	$(MULTICLEAN) $(AM_MAKEFLAGS) DO=maintainer-clean multi-clean # $(MAKE)
+
+.MAKE .PHONY: all-multi clean-multi distclean-multi install-am \
+	      install-multi maintainer-clean-multi mostlyclean-multi
+
+install-exec-local: install-multi
+
+all-local: all-multi
+mostlyclean-local: mostlyclean-multi
+clean-local: clean-multi
+distclean-local: distclean-multi
+maintainer-clean-local: maintainer-clean-multi
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/libga68/aclocal.m4 b/libga68/aclocal.m4
new file mode 100644
index 00000000000..832065fbb9b
--- /dev/null
+++ b/libga68/aclocal.m4
@@ -0,0 +1,1200 @@
+# generated automatically by aclocal 1.15.1 -*- Autoconf -*-
+
+# Copyright (C) 1996-2017 Free Software Foundation, Inc.
+
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])])
+m4_ifndef([AC_AUTOCONF_VERSION],
+  [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl
+m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.69],,
+[m4_warning([this file was generated for autoconf 2.69.
+You have another version of autoconf.  It may work, but is not guaranteed to.
+If you have problems, you may need to regenerate the build system entirely.
+To do so, use the procedure documented by the package, typically 'autoreconf'.])])
+
+# Copyright (C) 2002-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_AUTOMAKE_VERSION(VERSION)
+# ----------------------------
+# Automake X.Y traces this macro to ensure aclocal.m4 has been
+# generated from the m4 files accompanying Automake X.Y.
+# (This private macro should not be called outside this file.)
+AC_DEFUN([AM_AUTOMAKE_VERSION],
+[am__api_version='1.15'
+dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to
+dnl require some minimum version.  Point them to the right macro.
+m4_if([$1], [1.15.1], [],
+      [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl
+])
+
+# _AM_AUTOCONF_VERSION(VERSION)
+# -----------------------------
+# aclocal traces this macro to find the Autoconf version.
+# This is a private macro too.  Using m4_define simplifies
+# the logic in aclocal, which can simply ignore this definition.
+m4_define([_AM_AUTOCONF_VERSION], [])
+
+# AM_SET_CURRENT_AUTOMAKE_VERSION
+# -------------------------------
+# Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced.
+# This function is AC_REQUIREd by AM_INIT_AUTOMAKE.
+AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION],
+[AM_AUTOMAKE_VERSION([1.15.1])dnl
+m4_ifndef([AC_AUTOCONF_VERSION],
+  [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl
+_AM_AUTOCONF_VERSION(m4_defn([AC_AUTOCONF_VERSION]))])
+
+# Figure out how to run the assembler.                      -*- Autoconf -*-
+
+# Copyright (C) 2001-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_PROG_AS
+# ----------
+AC_DEFUN([AM_PROG_AS],
+[# By default we simply use the C compiler to build assembly code.
+AC_REQUIRE([AC_PROG_CC])
+test "${CCAS+set}" = set || CCAS=$CC
+test "${CCASFLAGS+set}" = set || CCASFLAGS=$CFLAGS
+AC_ARG_VAR([CCAS],      [assembler compiler command (defaults to CC)])
+AC_ARG_VAR([CCASFLAGS], [assembler compiler flags (defaults to CFLAGS)])
+_AM_IF_OPTION([no-dependencies],, [_AM_DEPENDENCIES([CCAS])])dnl
+])
+
+# AM_AUX_DIR_EXPAND                                         -*- Autoconf -*-
+
+# Copyright (C) 2001-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets
+# $ac_aux_dir to '$srcdir/foo'.  In other projects, it is set to
+# '$srcdir', '$srcdir/..', or '$srcdir/../..'.
+#
+# Of course, Automake must honor this variable whenever it calls a
+# tool from the auxiliary directory.  The problem is that $srcdir (and
+# therefore $ac_aux_dir as well) can be either absolute or relative,
+# depending on how configure is run.  This is pretty annoying, since
+# it makes $ac_aux_dir quite unusable in subdirectories: in the top
+# source directory, any form will work fine, but in subdirectories a
+# relative path needs to be adjusted first.
+#
+# $ac_aux_dir/missing
+#    fails when called from a subdirectory if $ac_aux_dir is relative
+# $top_srcdir/$ac_aux_dir/missing
+#    fails if $ac_aux_dir is absolute,
+#    fails when called from a subdirectory in a VPATH build with
+#          a relative $ac_aux_dir
+#
+# The reason of the latter failure is that $top_srcdir and $ac_aux_dir
+# are both prefixed by $srcdir.  In an in-source build this is usually
+# harmless because $srcdir is '.', but things will broke when you
+# start a VPATH build or use an absolute $srcdir.
+#
+# So we could use something similar to $top_srcdir/$ac_aux_dir/missing,
+# iff we strip the leading $srcdir from $ac_aux_dir.  That would be:
+#   am_aux_dir='\$(top_srcdir)/'`expr "$ac_aux_dir" : "$srcdir//*\(.*\)"`
+# and then we would define $MISSING as
+#   MISSING="\${SHELL} $am_aux_dir/missing"
+# This will work as long as MISSING is not called from configure, because
+# unfortunately $(top_srcdir) has no meaning in configure.
+# However there are other variables, like CC, which are often used in
+# configure, and could therefore not use this "fixed" $ac_aux_dir.
+#
+# Another solution, used here, is to always expand $ac_aux_dir to an
+# absolute PATH.  The drawback is that using absolute paths prevent a
+# configured tree to be moved without reconfiguration.
+
+AC_DEFUN([AM_AUX_DIR_EXPAND],
+[AC_REQUIRE([AC_CONFIG_AUX_DIR_DEFAULT])dnl
+# Expand $ac_aux_dir to an absolute path.
+am_aux_dir=`cd "$ac_aux_dir" && pwd`
+])
+
+# AM_CONDITIONAL                                            -*- Autoconf -*-
+
+# Copyright (C) 1997-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_CONDITIONAL(NAME, SHELL-CONDITION)
+# -------------------------------------
+# Define a conditional.
+AC_DEFUN([AM_CONDITIONAL],
+[AC_PREREQ([2.52])dnl
+ m4_if([$1], [TRUE],  [AC_FATAL([$0: invalid condition: $1])],
+       [$1], [FALSE], [AC_FATAL([$0: invalid condition: $1])])dnl
+AC_SUBST([$1_TRUE])dnl
+AC_SUBST([$1_FALSE])dnl
+_AM_SUBST_NOTMAKE([$1_TRUE])dnl
+_AM_SUBST_NOTMAKE([$1_FALSE])dnl
+m4_define([_AM_COND_VALUE_$1], [$2])dnl
+if $2; then
+  $1_TRUE=
+  $1_FALSE='#'
+else
+  $1_TRUE='#'
+  $1_FALSE=
+fi
+AC_CONFIG_COMMANDS_PRE(
+[if test -z "${$1_TRUE}" && test -z "${$1_FALSE}"; then
+  AC_MSG_ERROR([[conditional "$1" was never defined.
+Usually this means the macro was only invoked conditionally.]])
+fi])])
+
+# Copyright (C) 1999-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+
+# There are a few dirty hacks below to avoid letting 'AC_PROG_CC' be
+# written in clear, in which case automake, when reading aclocal.m4,
+# will think it sees a *use*, and therefore will trigger all it's
+# C support machinery.  Also note that it means that autoscan, seeing
+# CC etc. in the Makefile, will ask for an AC_PROG_CC use...
+
+
+# _AM_DEPENDENCIES(NAME)
+# ----------------------
+# See how the compiler implements dependency checking.
+# NAME is "CC", "CXX", "OBJC", "OBJCXX", "UPC", or "GJC".
+# We try a few techniques and use that to set a single cache variable.
+#
+# We don't AC_REQUIRE the corresponding AC_PROG_CC since the latter was
+# modified to invoke _AM_DEPENDENCIES(CC); we would have a circular
+# dependency, and given that the user is not expected to run this macro,
+# just rely on AC_PROG_CC.
+AC_DEFUN([_AM_DEPENDENCIES],
+[AC_REQUIRE([AM_SET_DEPDIR])dnl
+AC_REQUIRE([AM_OUTPUT_DEPENDENCY_COMMANDS])dnl
+AC_REQUIRE([AM_MAKE_INCLUDE])dnl
+AC_REQUIRE([AM_DEP_TRACK])dnl
+
+m4_if([$1], [CC],   [depcc="$CC"   am_compiler_list=],
+      [$1], [CXX],  [depcc="$CXX"  am_compiler_list=],
+      [$1], [OBJC], [depcc="$OBJC" am_compiler_list='gcc3 gcc'],
+      [$1], [OBJCXX], [depcc="$OBJCXX" am_compiler_list='gcc3 gcc'],
+      [$1], [UPC],  [depcc="$UPC"  am_compiler_list=],
+      [$1], [GCJ],  [depcc="$GCJ"  am_compiler_list='gcc3 gcc'],
+                    [depcc="$$1"   am_compiler_list=])
+
+AC_CACHE_CHECK([dependency style of $depcc],
+               [am_cv_$1_dependencies_compiler_type],
+[if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then
+  # We make a subdir and do the tests there.  Otherwise we can end up
+  # making bogus files that we don't know about and never remove.  For
+  # instance it was reported that on HP-UX the gcc test will end up
+  # making a dummy file named 'D' -- because '-MD' means "put the output
+  # in D".
+  rm -rf conftest.dir
+  mkdir conftest.dir
+  # Copy depcomp to subdir because otherwise we won't find it if we're
+  # using a relative directory.
+  cp "$am_depcomp" conftest.dir
+  cd conftest.dir
+  # We will build objects and dependencies in a subdirectory because
+  # it helps to detect inapplicable dependency modes.  For instance
+  # both Tru64's cc and ICC support -MD to output dependencies as a
+  # side effect of compilation, but ICC will put the dependencies in
+  # the current directory while Tru64 will put them in the object
+  # directory.
+  mkdir sub
+
+  am_cv_$1_dependencies_compiler_type=none
+  if test "$am_compiler_list" = ""; then
+     am_compiler_list=`sed -n ['s/^#*\([a-zA-Z0-9]*\))$/\1/p'] < ./depcomp`
+  fi
+  am__universal=false
+  m4_case([$1], [CC],
+    [case " $depcc " in #(
+     *\ -arch\ *\ -arch\ *) am__universal=true ;;
+     esac],
+    [CXX],
+    [case " $depcc " in #(
+     *\ -arch\ *\ -arch\ *) am__universal=true ;;
+     esac])
+
+  for depmode in $am_compiler_list; do
+    # Setup a source with many dependencies, because some compilers
+    # like to wrap large dependency lists on column 80 (with \), and
+    # we should not choose a depcomp mode which is confused by this.
+    #
+    # We need to recreate these files for each test, as the compiler may
+    # overwrite some of them when testing with obscure command lines.
+    # This happens at least with the AIX C compiler.
+    : > sub/conftest.c
+    for i in 1 2 3 4 5 6; do
+      echo '#include "conftst'$i'.h"' >> sub/conftest.c
+      # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with
+      # Solaris 10 /bin/sh.
+      echo '/* dummy */' > sub/conftst$i.h
+    done
+    echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf
+
+    # We check with '-c' and '-o' for the sake of the "dashmstdout"
+    # mode.  It turns out that the SunPro C++ compiler does not properly
+    # handle '-M -o', and we need to detect this.  Also, some Intel
+    # versions had trouble with output in subdirs.
+    am__obj=sub/conftest.${OBJEXT-o}
+    am__minus_obj="-o $am__obj"
+    case $depmode in
+    gcc)
+      # This depmode causes a compiler race in universal mode.
+      test "$am__universal" = false || continue
+      ;;
+    nosideeffect)
+      # After this tag, mechanisms are not by side-effect, so they'll
+      # only be used when explicitly requested.
+      if test "x$enable_dependency_tracking" = xyes; then
+	continue
+      else
+	break
+      fi
+      ;;
+    msvc7 | msvc7msys | msvisualcpp | msvcmsys)
+      # This compiler won't grok '-c -o', but also, the minuso test has
+      # not run yet.  These depmodes are late enough in the game, and
+      # so weak that their functioning should not be impacted.
+      am__obj=conftest.${OBJEXT-o}
+      am__minus_obj=
+      ;;
+    none) break ;;
+    esac
+    if depmode=$depmode \
+       source=sub/conftest.c object=$am__obj \
+       depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \
+       $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \
+         >/dev/null 2>conftest.err &&
+       grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 &&
+       grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 &&
+       grep $am__obj sub/conftest.Po > /dev/null 2>&1 &&
+       ${MAKE-make} -s -f confmf > /dev/null 2>&1; then
+      # icc doesn't choke on unknown options, it will just issue warnings
+      # or remarks (even with -Werror).  So we grep stderr for any message
+      # that says an option was ignored or not supported.
+      # When given -MP, icc 7.0 and 7.1 complain thusly:
+      #   icc: Command line warning: ignoring option '-M'; no argument required
+      # The diagnosis changed in icc 8.0:
+      #   icc: Command line remark: option '-MP' not supported
+      if (grep 'ignoring option' conftest.err ||
+          grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else
+        am_cv_$1_dependencies_compiler_type=$depmode
+        break
+      fi
+    fi
+  done
+
+  cd ..
+  rm -rf conftest.dir
+else
+  am_cv_$1_dependencies_compiler_type=none
+fi
+])
+AC_SUBST([$1DEPMODE], [depmode=$am_cv_$1_dependencies_compiler_type])
+AM_CONDITIONAL([am__fastdep$1], [
+  test "x$enable_dependency_tracking" != xno \
+  && test "$am_cv_$1_dependencies_compiler_type" = gcc3])
+])
+
+
+# AM_SET_DEPDIR
+# -------------
+# Choose a directory name for dependency files.
+# This macro is AC_REQUIREd in _AM_DEPENDENCIES.
+AC_DEFUN([AM_SET_DEPDIR],
+[AC_REQUIRE([AM_SET_LEADING_DOT])dnl
+AC_SUBST([DEPDIR], ["${am__leading_dot}deps"])dnl
+])
+
+
+# AM_DEP_TRACK
+# ------------
+AC_DEFUN([AM_DEP_TRACK],
+[AC_ARG_ENABLE([dependency-tracking], [dnl
+AS_HELP_STRING(
+  [--enable-dependency-tracking],
+  [do not reject slow dependency extractors])
+AS_HELP_STRING(
+  [--disable-dependency-tracking],
+  [speeds up one-time build])])
+if test "x$enable_dependency_tracking" != xno; then
+  am_depcomp="$ac_aux_dir/depcomp"
+  AMDEPBACKSLASH='\'
+  am__nodep='_no'
+fi
+AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno])
+AC_SUBST([AMDEPBACKSLASH])dnl
+_AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl
+AC_SUBST([am__nodep])dnl
+_AM_SUBST_NOTMAKE([am__nodep])dnl
+])
+
+# Generate code to set up dependency tracking.              -*- Autoconf -*-
+
+# Copyright (C) 1999-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+
+# _AM_OUTPUT_DEPENDENCY_COMMANDS
+# ------------------------------
+AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS],
+[{
+  # Older Autoconf quotes --file arguments for eval, but not when files
+  # are listed without --file.  Let's play safe and only enable the eval
+  # if we detect the quoting.
+  case $CONFIG_FILES in
+  *\'*) eval set x "$CONFIG_FILES" ;;
+  *)   set x $CONFIG_FILES ;;
+  esac
+  shift
+  for mf
+  do
+    # Strip MF so we end up with the name of the file.
+    mf=`echo "$mf" | sed -e 's/:.*$//'`
+    # Check whether this is an Automake generated Makefile or not.
+    # We used to match only the files named 'Makefile.in', but
+    # some people rename them; so instead we look at the file content.
+    # Grep'ing the first line is not enough: some people post-process
+    # each Makefile.in and add a new line on top of each file to say so.
+    # Grep'ing the whole file is not good either: AIX grep has a line
+    # limit of 2048, but all sed's we know have understand at least 4000.
+    if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then
+      dirpart=`AS_DIRNAME("$mf")`
+    else
+      continue
+    fi
+    # Extract the definition of DEPDIR, am__include, and am__quote
+    # from the Makefile without running 'make'.
+    DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"`
+    test -z "$DEPDIR" && continue
+    am__include=`sed -n 's/^am__include = //p' < "$mf"`
+    test -z "$am__include" && continue
+    am__quote=`sed -n 's/^am__quote = //p' < "$mf"`
+    # Find all dependency output files, they are included files with
+    # $(DEPDIR) in their names.  We invoke sed twice because it is the
+    # simplest approach to changing $(DEPDIR) to its actual value in the
+    # expansion.
+    for file in `sed -n "
+      s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \
+	 sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g'`; do
+      # Make sure the directory exists.
+      test -f "$dirpart/$file" && continue
+      fdir=`AS_DIRNAME(["$file"])`
+      AS_MKDIR_P([$dirpart/$fdir])
+      # echo "creating $dirpart/$file"
+      echo '# dummy' > "$dirpart/$file"
+    done
+  done
+}
+])# _AM_OUTPUT_DEPENDENCY_COMMANDS
+
+
+# AM_OUTPUT_DEPENDENCY_COMMANDS
+# -----------------------------
+# This macro should only be invoked once -- use via AC_REQUIRE.
+#
+# This code is only required when automatic dependency tracking
+# is enabled.  FIXME.  This creates each '.P' file that we will
+# need in order to bootstrap the dependency handling code.
+AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS],
+[AC_CONFIG_COMMANDS([depfiles],
+     [test x"$AMDEP_TRUE" != x"" || _AM_OUTPUT_DEPENDENCY_COMMANDS],
+     [AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir"])
+])
+
+# Do all the work for Automake.                             -*- Autoconf -*-
+
+# Copyright (C) 1996-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This macro actually does too much.  Some checks are only needed if
+# your package does certain things.  But this isn't really a big deal.
+
+dnl Redefine AC_PROG_CC to automatically invoke _AM_PROG_CC_C_O.
+m4_define([AC_PROG_CC],
+m4_defn([AC_PROG_CC])
+[_AM_PROG_CC_C_O
+])
+
+# AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE])
+# AM_INIT_AUTOMAKE([OPTIONS])
+# -----------------------------------------------
+# The call with PACKAGE and VERSION arguments is the old style
+# call (pre autoconf-2.50), which is being phased out.  PACKAGE
+# and VERSION should now be passed to AC_INIT and removed from
+# the call to AM_INIT_AUTOMAKE.
+# We support both call styles for the transition.  After
+# the next Automake release, Autoconf can make the AC_INIT
+# arguments mandatory, and then we can depend on a new Autoconf
+# release and drop the old call support.
+AC_DEFUN([AM_INIT_AUTOMAKE],
+[AC_PREREQ([2.65])dnl
+dnl Autoconf wants to disallow AM_ names.  We explicitly allow
+dnl the ones we care about.
+m4_pattern_allow([^AM_[A-Z]+FLAGS$])dnl
+AC_REQUIRE([AM_SET_CURRENT_AUTOMAKE_VERSION])dnl
+AC_REQUIRE([AC_PROG_INSTALL])dnl
+if test "`cd $srcdir && pwd`" != "`pwd`"; then
+  # Use -I$(srcdir) only when $(srcdir) != ., so that make's output
+  # is not polluted with repeated "-I."
+  AC_SUBST([am__isrc], [' -I$(srcdir)'])_AM_SUBST_NOTMAKE([am__isrc])dnl
+  # test to see if srcdir already configured
+  if test -f $srcdir/config.status; then
+    AC_MSG_ERROR([source directory already configured; run "make distclean" there first])
+  fi
+fi
+
+# test whether we have cygpath
+if test -z "$CYGPATH_W"; then
+  if (cygpath --version) >/dev/null 2>/dev/null; then
+    CYGPATH_W='cygpath -w'
+  else
+    CYGPATH_W=echo
+  fi
+fi
+AC_SUBST([CYGPATH_W])
+
+# Define the identity of the package.
+dnl Distinguish between old-style and new-style calls.
+m4_ifval([$2],
+[AC_DIAGNOSE([obsolete],
+             [$0: two- and three-arguments forms are deprecated.])
+m4_ifval([$3], [_AM_SET_OPTION([no-define])])dnl
+ AC_SUBST([PACKAGE], [$1])dnl
+ AC_SUBST([VERSION], [$2])],
+[_AM_SET_OPTIONS([$1])dnl
+dnl Diagnose old-style AC_INIT with new-style AM_AUTOMAKE_INIT.
+m4_if(
+  m4_ifdef([AC_PACKAGE_NAME], [ok]):m4_ifdef([AC_PACKAGE_VERSION], [ok]),
+  [ok:ok],,
+  [m4_fatal([AC_INIT should be called with package and version arguments])])dnl
+ AC_SUBST([PACKAGE], ['AC_PACKAGE_TARNAME'])dnl
+ AC_SUBST([VERSION], ['AC_PACKAGE_VERSION'])])dnl
+
+_AM_IF_OPTION([no-define],,
+[AC_DEFINE_UNQUOTED([PACKAGE], ["$PACKAGE"], [Name of package])
+ AC_DEFINE_UNQUOTED([VERSION], ["$VERSION"], [Version number of package])])dnl
+
+# Some tools Automake needs.
+AC_REQUIRE([AM_SANITY_CHECK])dnl
+AC_REQUIRE([AC_ARG_PROGRAM])dnl
+AM_MISSING_PROG([ACLOCAL], [aclocal-${am__api_version}])
+AM_MISSING_PROG([AUTOCONF], [autoconf])
+AM_MISSING_PROG([AUTOMAKE], [automake-${am__api_version}])
+AM_MISSING_PROG([AUTOHEADER], [autoheader])
+AM_MISSING_PROG([MAKEINFO], [makeinfo])
+AC_REQUIRE([AM_PROG_INSTALL_SH])dnl
+AC_REQUIRE([AM_PROG_INSTALL_STRIP])dnl
+AC_REQUIRE([AC_PROG_MKDIR_P])dnl
+# For better backward compatibility.  To be removed once Automake 1.9.x
+# dies out for good.  For more background, see:
+# <http://lists.gnu.org/archive/html/automake/2012-07/msg00001.html>
+# <http://lists.gnu.org/archive/html/automake/2012-07/msg00014.html>
+AC_SUBST([mkdir_p], ['$(MKDIR_P)'])
+# We need awk for the "check" target (and possibly the TAP driver).  The
+# system "awk" is bad on some platforms.
+AC_REQUIRE([AC_PROG_AWK])dnl
+AC_REQUIRE([AC_PROG_MAKE_SET])dnl
+AC_REQUIRE([AM_SET_LEADING_DOT])dnl
+_AM_IF_OPTION([tar-ustar], [_AM_PROG_TAR([ustar])],
+	      [_AM_IF_OPTION([tar-pax], [_AM_PROG_TAR([pax])],
+			     [_AM_PROG_TAR([v7])])])
+_AM_IF_OPTION([no-dependencies],,
+[AC_PROVIDE_IFELSE([AC_PROG_CC],
+		  [_AM_DEPENDENCIES([CC])],
+		  [m4_define([AC_PROG_CC],
+			     m4_defn([AC_PROG_CC])[_AM_DEPENDENCIES([CC])])])dnl
+AC_PROVIDE_IFELSE([AC_PROG_CXX],
+		  [_AM_DEPENDENCIES([CXX])],
+		  [m4_define([AC_PROG_CXX],
+			     m4_defn([AC_PROG_CXX])[_AM_DEPENDENCIES([CXX])])])dnl
+AC_PROVIDE_IFELSE([AC_PROG_OBJC],
+		  [_AM_DEPENDENCIES([OBJC])],
+		  [m4_define([AC_PROG_OBJC],
+			     m4_defn([AC_PROG_OBJC])[_AM_DEPENDENCIES([OBJC])])])dnl
+AC_PROVIDE_IFELSE([AC_PROG_OBJCXX],
+		  [_AM_DEPENDENCIES([OBJCXX])],
+		  [m4_define([AC_PROG_OBJCXX],
+			     m4_defn([AC_PROG_OBJCXX])[_AM_DEPENDENCIES([OBJCXX])])])dnl
+])
+AC_REQUIRE([AM_SILENT_RULES])dnl
+dnl The testsuite driver may need to know about EXEEXT, so add the
+dnl 'am__EXEEXT' conditional if _AM_COMPILER_EXEEXT was seen.  This
+dnl macro is hooked onto _AC_COMPILER_EXEEXT early, see below.
+AC_CONFIG_COMMANDS_PRE(dnl
+[m4_provide_if([_AM_COMPILER_EXEEXT],
+  [AM_CONDITIONAL([am__EXEEXT], [test -n "$EXEEXT"])])])dnl
+
+# POSIX will say in a future version that running "rm -f" with no argument
+# is OK; and we want to be able to make that assumption in our Makefile
+# recipes.  So use an aggressive probe to check that the usage we want is
+# actually supported "in the wild" to an acceptable degree.
+# See automake bug#10828.
+# To make any issue more visible, cause the running configure to be aborted
+# by default if the 'rm' program in use doesn't match our expectations; the
+# user can still override this though.
+if rm -f && rm -fr && rm -rf; then : OK; else
+  cat >&2 <<'END'
+Oops!
+
+Your 'rm' program seems unable to run without file operands specified
+on the command line, even when the '-f' option is present.  This is contrary
+to the behaviour of most rm programs out there, and not conforming with
+the upcoming POSIX standard: <http://austingroupbugs.net/view.php?id=542>
+
+Please tell bug-automake@gnu.org about your system, including the value
+of your $PATH and any error possibly output before this message.  This
+can help us improve future automake versions.
+
+END
+  if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then
+    echo 'Configuration will proceed anyway, since you have set the' >&2
+    echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2
+    echo >&2
+  else
+    cat >&2 <<'END'
+Aborting the configuration process, to ensure you take notice of the issue.
+
+You can download and install GNU coreutils to get an 'rm' implementation
+that behaves properly: <http://www.gnu.org/software/coreutils/>.
+
+If you want to complete the configuration process using your problematic
+'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM
+to "yes", and re-run configure.
+
+END
+    AC_MSG_ERROR([Your 'rm' program is bad, sorry.])
+  fi
+fi
+dnl The trailing newline in this macro's definition is deliberate, for
+dnl backward compatibility and to allow trailing 'dnl'-style comments
+dnl after the AM_INIT_AUTOMAKE invocation. See automake bug#16841.
+])
+
+dnl Hook into '_AC_COMPILER_EXEEXT' early to learn its expansion.  Do not
+dnl add the conditional right here, as _AC_COMPILER_EXEEXT may be further
+dnl mangled by Autoconf and run in a shell conditional statement.
+m4_define([_AC_COMPILER_EXEEXT],
+m4_defn([_AC_COMPILER_EXEEXT])[m4_provide([_AM_COMPILER_EXEEXT])])
+
+# When config.status generates a header, we must update the stamp-h file.
+# This file resides in the same directory as the config header
+# that is generated.  The stamp files are numbered to have different names.
+
+# Autoconf calls _AC_AM_CONFIG_HEADER_HOOK (when defined) in the
+# loop where config.status creates the headers, so we can generate
+# our stamp files there.
+AC_DEFUN([_AC_AM_CONFIG_HEADER_HOOK],
+[# Compute $1's index in $config_headers.
+_am_arg=$1
+_am_stamp_count=1
+for _am_header in $config_headers :; do
+  case $_am_header in
+    $_am_arg | $_am_arg:* )
+      break ;;
+    * )
+      _am_stamp_count=`expr $_am_stamp_count + 1` ;;
+  esac
+done
+echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count])
+
+# Copyright (C) 2001-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_PROG_INSTALL_SH
+# ------------------
+# Define $install_sh.
+AC_DEFUN([AM_PROG_INSTALL_SH],
+[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl
+if test x"${install_sh+set}" != xset; then
+  case $am_aux_dir in
+  *\ * | *\	*)
+    install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;;
+  *)
+    install_sh="\${SHELL} $am_aux_dir/install-sh"
+  esac
+fi
+AC_SUBST([install_sh])])
+
+# Add --enable-maintainer-mode option to configure.         -*- Autoconf -*-
+# From Jim Meyering
+
+# Copyright (C) 1996-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_MAINTAINER_MODE([DEFAULT-MODE])
+# ----------------------------------
+# Control maintainer-specific portions of Makefiles.
+# Default is to disable them, unless 'enable' is passed literally.
+# For symmetry, 'disable' may be passed as well.  Anyway, the user
+# can override the default with the --enable/--disable switch.
+AC_DEFUN([AM_MAINTAINER_MODE],
+[m4_case(m4_default([$1], [disable]),
+       [enable], [m4_define([am_maintainer_other], [disable])],
+       [disable], [m4_define([am_maintainer_other], [enable])],
+       [m4_define([am_maintainer_other], [enable])
+        m4_warn([syntax], [unexpected argument to AM@&t@_MAINTAINER_MODE: $1])])
+AC_MSG_CHECKING([whether to enable maintainer-specific portions of Makefiles])
+  dnl maintainer-mode's default is 'disable' unless 'enable' is passed
+  AC_ARG_ENABLE([maintainer-mode],
+    [AS_HELP_STRING([--]am_maintainer_other[-maintainer-mode],
+      am_maintainer_other[ make rules and dependencies not useful
+      (and sometimes confusing) to the casual installer])],
+    [USE_MAINTAINER_MODE=$enableval],
+    [USE_MAINTAINER_MODE=]m4_if(am_maintainer_other, [enable], [no], [yes]))
+  AC_MSG_RESULT([$USE_MAINTAINER_MODE])
+  AM_CONDITIONAL([MAINTAINER_MODE], [test $USE_MAINTAINER_MODE = yes])
+  MAINT=$MAINTAINER_MODE_TRUE
+  AC_SUBST([MAINT])dnl
+]
+)
+
+# Check to see how 'make' treats includes.	            -*- Autoconf -*-
+
+# Copyright (C) 2001-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_MAKE_INCLUDE()
+# -----------------
+# Check to see how make treats includes.
+AC_DEFUN([AM_MAKE_INCLUDE],
+[am_make=${MAKE-make}
+cat > confinc << 'END'
+am__doit:
+	@echo this is the am__doit target
+.PHONY: am__doit
+END
+# If we don't find an include directive, just comment out the code.
+AC_MSG_CHECKING([for style of include used by $am_make])
+am__include="#"
+am__quote=
+_am_result=none
+# First try GNU make style include.
+echo "include confinc" > confmf
+# Ignore all kinds of additional output from 'make'.
+case `$am_make -s -f confmf 2> /dev/null` in #(
+*the\ am__doit\ target*)
+  am__include=include
+  am__quote=
+  _am_result=GNU
+  ;;
+esac
+# Now try BSD make style include.
+if test "$am__include" = "#"; then
+   echo '.include "confinc"' > confmf
+   case `$am_make -s -f confmf 2> /dev/null` in #(
+   *the\ am__doit\ target*)
+     am__include=.include
+     am__quote="\""
+     _am_result=BSD
+     ;;
+   esac
+fi
+AC_SUBST([am__include])
+AC_SUBST([am__quote])
+AC_MSG_RESULT([$_am_result])
+rm -f confinc confmf
+])
+
+# Fake the existence of programs that GNU maintainers use.  -*- Autoconf -*-
+
+# Copyright (C) 1997-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_MISSING_PROG(NAME, PROGRAM)
+# ------------------------------
+AC_DEFUN([AM_MISSING_PROG],
+[AC_REQUIRE([AM_MISSING_HAS_RUN])
+$1=${$1-"${am_missing_run}$2"}
+AC_SUBST($1)])
+
+# AM_MISSING_HAS_RUN
+# ------------------
+# Define MISSING if not defined so far and test if it is modern enough.
+# If it is, set am_missing_run to use it, otherwise, to nothing.
+AC_DEFUN([AM_MISSING_HAS_RUN],
+[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl
+AC_REQUIRE_AUX_FILE([missing])dnl
+if test x"${MISSING+set}" != xset; then
+  case $am_aux_dir in
+  *\ * | *\	*)
+    MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;;
+  *)
+    MISSING="\${SHELL} $am_aux_dir/missing" ;;
+  esac
+fi
+# Use eval to expand $SHELL
+if eval "$MISSING --is-lightweight"; then
+  am_missing_run="$MISSING "
+else
+  am_missing_run=
+  AC_MSG_WARN(['missing' script is too old or missing])
+fi
+])
+
+# Helper functions for option handling.                     -*- Autoconf -*-
+
+# Copyright (C) 2001-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# _AM_MANGLE_OPTION(NAME)
+# -----------------------
+AC_DEFUN([_AM_MANGLE_OPTION],
+[[_AM_OPTION_]m4_bpatsubst($1, [[^a-zA-Z0-9_]], [_])])
+
+# _AM_SET_OPTION(NAME)
+# --------------------
+# Set option NAME.  Presently that only means defining a flag for this option.
+AC_DEFUN([_AM_SET_OPTION],
+[m4_define(_AM_MANGLE_OPTION([$1]), [1])])
+
+# _AM_SET_OPTIONS(OPTIONS)
+# ------------------------
+# OPTIONS is a space-separated list of Automake options.
+AC_DEFUN([_AM_SET_OPTIONS],
+[m4_foreach_w([_AM_Option], [$1], [_AM_SET_OPTION(_AM_Option)])])
+
+# _AM_IF_OPTION(OPTION, IF-SET, [IF-NOT-SET])
+# -------------------------------------------
+# Execute IF-SET if OPTION is set, IF-NOT-SET otherwise.
+AC_DEFUN([_AM_IF_OPTION],
+[m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])])
+
+# Copyright (C) 1999-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# _AM_PROG_CC_C_O
+# ---------------
+# Like AC_PROG_CC_C_O, but changed for automake.  We rewrite AC_PROG_CC
+# to automatically call this.
+AC_DEFUN([_AM_PROG_CC_C_O],
+[AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl
+AC_REQUIRE_AUX_FILE([compile])dnl
+AC_LANG_PUSH([C])dnl
+AC_CACHE_CHECK(
+  [whether $CC understands -c and -o together],
+  [am_cv_prog_cc_c_o],
+  [AC_LANG_CONFTEST([AC_LANG_PROGRAM([])])
+  # Make sure it works both with $CC and with simple cc.
+  # Following AC_PROG_CC_C_O, we do the test twice because some
+  # compilers refuse to overwrite an existing .o file with -o,
+  # though they will create one.
+  am_cv_prog_cc_c_o=yes
+  for am_i in 1 2; do
+    if AM_RUN_LOG([$CC -c conftest.$ac_ext -o conftest2.$ac_objext]) \
+         && test -f conftest2.$ac_objext; then
+      : OK
+    else
+      am_cv_prog_cc_c_o=no
+      break
+    fi
+  done
+  rm -f core conftest*
+  unset am_i])
+if test "$am_cv_prog_cc_c_o" != yes; then
+   # Losing compiler, so override with the script.
+   # FIXME: It is wrong to rewrite CC.
+   # But if we don't then we get into trouble of one sort or another.
+   # A longer-term fix would be to have automake use am__CC in this case,
+   # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)"
+   CC="$am_aux_dir/compile $CC"
+fi
+AC_LANG_POP([C])])
+
+# For backward compatibility.
+AC_DEFUN_ONCE([AM_PROG_CC_C_O], [AC_REQUIRE([AC_PROG_CC])])
+
+# Copyright (C) 2001-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_RUN_LOG(COMMAND)
+# -------------------
+# Run COMMAND, save the exit status in ac_status, and log it.
+# (This has been adapted from Autoconf's _AC_RUN_LOG macro.)
+AC_DEFUN([AM_RUN_LOG],
+[{ echo "$as_me:$LINENO: $1" >&AS_MESSAGE_LOG_FD
+   ($1) >&AS_MESSAGE_LOG_FD 2>&AS_MESSAGE_LOG_FD
+   ac_status=$?
+   echo "$as_me:$LINENO: \$? = $ac_status" >&AS_MESSAGE_LOG_FD
+   (exit $ac_status); }])
+
+# Check to make sure that the build environment is sane.    -*- Autoconf -*-
+
+# Copyright (C) 1996-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_SANITY_CHECK
+# ---------------
+AC_DEFUN([AM_SANITY_CHECK],
+[AC_MSG_CHECKING([whether build environment is sane])
+# Reject unsafe characters in $srcdir or the absolute working directory
+# name.  Accept space and tab only in the latter.
+am_lf='
+'
+case `pwd` in
+  *[[\\\"\#\$\&\'\`$am_lf]]*)
+    AC_MSG_ERROR([unsafe absolute working directory name]);;
+esac
+case $srcdir in
+  *[[\\\"\#\$\&\'\`$am_lf\ \	]]*)
+    AC_MSG_ERROR([unsafe srcdir value: '$srcdir']);;
+esac
+
+# Do 'set' in a subshell so we don't clobber the current shell's
+# arguments.  Must try -L first in case configure is actually a
+# symlink; some systems play weird games with the mod time of symlinks
+# (eg FreeBSD returns the mod time of the symlink's containing
+# directory).
+if (
+   am_has_slept=no
+   for am_try in 1 2; do
+     echo "timestamp, slept: $am_has_slept" > conftest.file
+     set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null`
+     if test "$[*]" = "X"; then
+	# -L didn't work.
+	set X `ls -t "$srcdir/configure" conftest.file`
+     fi
+     if test "$[*]" != "X $srcdir/configure conftest.file" \
+	&& test "$[*]" != "X conftest.file $srcdir/configure"; then
+
+	# If neither matched, then we have a broken ls.  This can happen
+	# if, for instance, CONFIG_SHELL is bash and it inherits a
+	# broken ls alias from the environment.  This has actually
+	# happened.  Such a system could not be considered "sane".
+	AC_MSG_ERROR([ls -t appears to fail.  Make sure there is not a broken
+  alias in your environment])
+     fi
+     if test "$[2]" = conftest.file || test $am_try -eq 2; then
+       break
+     fi
+     # Just in case.
+     sleep 1
+     am_has_slept=yes
+   done
+   test "$[2]" = conftest.file
+   )
+then
+   # Ok.
+   :
+else
+   AC_MSG_ERROR([newly created file is older than distributed files!
+Check your system clock])
+fi
+AC_MSG_RESULT([yes])
+# If we didn't sleep, we still need to ensure time stamps of config.status and
+# generated files are strictly newer.
+am_sleep_pid=
+if grep 'slept: no' conftest.file >/dev/null 2>&1; then
+  ( sleep 1 ) &
+  am_sleep_pid=$!
+fi
+AC_CONFIG_COMMANDS_PRE(
+  [AC_MSG_CHECKING([that generated files are newer than configure])
+   if test -n "$am_sleep_pid"; then
+     # Hide warnings about reused PIDs.
+     wait $am_sleep_pid 2>/dev/null
+   fi
+   AC_MSG_RESULT([done])])
+rm -f conftest.file
+])
+
+# Copyright (C) 2009-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_SILENT_RULES([DEFAULT])
+# --------------------------
+# Enable less verbose build rules; with the default set to DEFAULT
+# ("yes" being less verbose, "no" or empty being verbose).
+AC_DEFUN([AM_SILENT_RULES],
+[AC_ARG_ENABLE([silent-rules], [dnl
+AS_HELP_STRING(
+  [--enable-silent-rules],
+  [less verbose build output (undo: "make V=1")])
+AS_HELP_STRING(
+  [--disable-silent-rules],
+  [verbose build output (undo: "make V=0")])dnl
+])
+case $enable_silent_rules in @%:@ (((
+  yes) AM_DEFAULT_VERBOSITY=0;;
+   no) AM_DEFAULT_VERBOSITY=1;;
+    *) AM_DEFAULT_VERBOSITY=m4_if([$1], [yes], [0], [1]);;
+esac
+dnl
+dnl A few 'make' implementations (e.g., NonStop OS and NextStep)
+dnl do not support nested variable expansions.
+dnl See automake bug#9928 and bug#10237.
+am_make=${MAKE-make}
+AC_CACHE_CHECK([whether $am_make supports nested variables],
+   [am_cv_make_support_nested_variables],
+   [if AS_ECHO([['TRUE=$(BAR$(V))
+BAR0=false
+BAR1=true
+V=1
+am__doit:
+	@$(TRUE)
+.PHONY: am__doit']]) | $am_make -f - >/dev/null 2>&1; then
+  am_cv_make_support_nested_variables=yes
+else
+  am_cv_make_support_nested_variables=no
+fi])
+if test $am_cv_make_support_nested_variables = yes; then
+  dnl Using '$V' instead of '$(V)' breaks IRIX make.
+  AM_V='$(V)'
+  AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)'
+else
+  AM_V=$AM_DEFAULT_VERBOSITY
+  AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY
+fi
+AC_SUBST([AM_V])dnl
+AM_SUBST_NOTMAKE([AM_V])dnl
+AC_SUBST([AM_DEFAULT_V])dnl
+AM_SUBST_NOTMAKE([AM_DEFAULT_V])dnl
+AC_SUBST([AM_DEFAULT_VERBOSITY])dnl
+AM_BACKSLASH='\'
+AC_SUBST([AM_BACKSLASH])dnl
+_AM_SUBST_NOTMAKE([AM_BACKSLASH])dnl
+])
+
+# Copyright (C) 2001-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# AM_PROG_INSTALL_STRIP
+# ---------------------
+# One issue with vendor 'install' (even GNU) is that you can't
+# specify the program used to strip binaries.  This is especially
+# annoying in cross-compiling environments, where the build's strip
+# is unlikely to handle the host's binaries.
+# Fortunately install-sh will honor a STRIPPROG variable, so we
+# always use install-sh in "make install-strip", and initialize
+# STRIPPROG with the value of the STRIP variable (set by the user).
+AC_DEFUN([AM_PROG_INSTALL_STRIP],
+[AC_REQUIRE([AM_PROG_INSTALL_SH])dnl
+# Installed binaries are usually stripped using 'strip' when the user
+# run "make install-strip".  However 'strip' might not be the right
+# tool to use in cross-compilation environments, therefore Automake
+# will honor the 'STRIP' environment variable to overrule this program.
+dnl Don't test for $cross_compiling = yes, because it might be 'maybe'.
+if test "$cross_compiling" != no; then
+  AC_CHECK_TOOL([STRIP], [strip], :)
+fi
+INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s"
+AC_SUBST([INSTALL_STRIP_PROGRAM])])
+
+# Copyright (C) 2006-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# _AM_SUBST_NOTMAKE(VARIABLE)
+# ---------------------------
+# Prevent Automake from outputting VARIABLE = @VARIABLE@ in Makefile.in.
+# This macro is traced by Automake.
+AC_DEFUN([_AM_SUBST_NOTMAKE])
+
+# AM_SUBST_NOTMAKE(VARIABLE)
+# --------------------------
+# Public sister of _AM_SUBST_NOTMAKE.
+AC_DEFUN([AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE($@)])
+
+# Check how to create a tarball.                            -*- Autoconf -*-
+
+# Copyright (C) 2004-2017 Free Software Foundation, Inc.
+#
+# This file is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# _AM_PROG_TAR(FORMAT)
+# --------------------
+# Check how to create a tarball in format FORMAT.
+# FORMAT should be one of 'v7', 'ustar', or 'pax'.
+#
+# Substitute a variable $(am__tar) that is a command
+# writing to stdout a FORMAT-tarball containing the directory
+# $tardir.
+#     tardir=directory && $(am__tar) > result.tar
+#
+# Substitute a variable $(am__untar) that extract such
+# a tarball read from stdin.
+#     $(am__untar) < result.tar
+#
+AC_DEFUN([_AM_PROG_TAR],
+[# Always define AMTAR for backward compatibility.  Yes, it's still used
+# in the wild :-(  We should find a proper way to deprecate it ...
+AC_SUBST([AMTAR], ['$${TAR-tar}'])
+
+# We'll loop over all known methods to create a tar archive until one works.
+_am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none'
+
+m4_if([$1], [v7],
+  [am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -'],
+
+  [m4_case([$1],
+    [ustar],
+     [# The POSIX 1988 'ustar' format is defined with fixed-size fields.
+      # There is notably a 21 bits limit for the UID and the GID.  In fact,
+      # the 'pax' utility can hang on bigger UID/GID (see automake bug#8343
+      # and bug#13588).
+      am_max_uid=2097151 # 2^21 - 1
+      am_max_gid=$am_max_uid
+      # The $UID and $GID variables are not portable, so we need to resort
+      # to the POSIX-mandated id(1) utility.  Errors in the 'id' calls
+      # below are definitely unexpected, so allow the users to see them
+      # (that is, avoid stderr redirection).
+      am_uid=`id -u || echo unknown`
+      am_gid=`id -g || echo unknown`
+      AC_MSG_CHECKING([whether UID '$am_uid' is supported by ustar format])
+      if test $am_uid -le $am_max_uid; then
+         AC_MSG_RESULT([yes])
+      else
+         AC_MSG_RESULT([no])
+         _am_tools=none
+      fi
+      AC_MSG_CHECKING([whether GID '$am_gid' is supported by ustar format])
+      if test $am_gid -le $am_max_gid; then
+         AC_MSG_RESULT([yes])
+      else
+        AC_MSG_RESULT([no])
+        _am_tools=none
+      fi],
+
+  [pax],
+    [],
+
+  [m4_fatal([Unknown tar format])])
+
+  AC_MSG_CHECKING([how to create a $1 tar archive])
+
+  # Go ahead even if we have the value already cached.  We do so because we
+  # need to set the values for the 'am__tar' and 'am__untar' variables.
+  _am_tools=${am_cv_prog_tar_$1-$_am_tools}
+
+  for _am_tool in $_am_tools; do
+    case $_am_tool in
+    gnutar)
+      for _am_tar in tar gnutar gtar; do
+        AM_RUN_LOG([$_am_tar --version]) && break
+      done
+      am__tar="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$$tardir"'
+      am__tar_="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$tardir"'
+      am__untar="$_am_tar -xf -"
+      ;;
+    plaintar)
+      # Must skip GNU tar: if it does not support --format= it doesn't create
+      # ustar tarball either.
+      (tar --version) >/dev/null 2>&1 && continue
+      am__tar='tar chf - "$$tardir"'
+      am__tar_='tar chf - "$tardir"'
+      am__untar='tar xf -'
+      ;;
+    pax)
+      am__tar='pax -L -x $1 -w "$$tardir"'
+      am__tar_='pax -L -x $1 -w "$tardir"'
+      am__untar='pax -r'
+      ;;
+    cpio)
+      am__tar='find "$$tardir" -print | cpio -o -H $1 -L'
+      am__tar_='find "$tardir" -print | cpio -o -H $1 -L'
+      am__untar='cpio -i -H $1 -d'
+      ;;
+    none)
+      am__tar=false
+      am__tar_=false
+      am__untar=false
+      ;;
+    esac
+
+    # If the value was cached, stop now.  We just wanted to have am__tar
+    # and am__untar set.
+    test -n "${am_cv_prog_tar_$1}" && break
+
+    # tar/untar a dummy directory, and stop if the command works.
+    rm -rf conftest.dir
+    mkdir conftest.dir
+    echo GrepMe > conftest.dir/file
+    AM_RUN_LOG([tardir=conftest.dir && eval $am__tar_ >conftest.tar])
+    rm -rf conftest.dir
+    if test -s conftest.tar; then
+      AM_RUN_LOG([$am__untar <conftest.tar])
+      AM_RUN_LOG([cat conftest.dir/file])
+      grep GrepMe conftest.dir/file >/dev/null 2>&1 && break
+    fi
+  done
+  rm -rf conftest.dir
+
+  AC_CACHE_VAL([am_cv_prog_tar_$1], [am_cv_prog_tar_$1=$_am_tool])
+  AC_MSG_RESULT([$am_cv_prog_tar_$1])])
+
+AC_SUBST([am__tar])
+AC_SUBST([am__untar])
+]) # _AM_PROG_TAR
+
+m4_include([../config/acx.m4])
+m4_include([../config/depstand.m4])
+m4_include([../config/lead-dot.m4])
+m4_include([../config/multi.m4])
+m4_include([../config/no-executables.m4])
+m4_include([../config/override.m4])
+m4_include([../libtool.m4])
+m4_include([../ltoptions.m4])
+m4_include([../ltsugar.m4])
+m4_include([../ltversion.m4])
+m4_include([../lt~obsolete.m4])
diff --git a/libga68/configure.ac b/libga68/configure.ac
new file mode 100644
index 00000000000..8d8411c8c93
--- /dev/null
+++ b/libga68/configure.ac
@@ -0,0 +1,420 @@
+# Configure script for libga68.
+# Copyright (C) 2025 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/>.
+
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+
+# Process this file with autoreconf to produce a configure script.
+
+AC_INIT(package-unused, version-unused,,libga68)
+AC_CONFIG_SRCDIR(Makefile.am)
+AC_CONFIG_HEADER(config.h)
+
+AM_ENABLE_MULTILIB(, ..)
+
+GCC_NO_EXECUTABLES
+
+AC_USE_SYSTEM_EXTENSIONS
+
+# Do not delete or change the following two lines.  For why, see
+# http://gcc.gnu.org/ml/libstdc++/2003-07/msg00451.html
+AC_CANONICAL_SYSTEM
+target_alias=${target_alias-$host_alias}
+AC_SUBST(target_alias)
+
+if test "$build" != "$host"; then
+  # We are being configured with some form of cross compiler.
+  GLIBCXX_IS_NATIVE=false
+  case "$host","$target" in
+    # Darwin crosses can use the host system's libraries and headers,
+    # because of the fat library support.  Of course, it must be the
+    # same version of Darwin on both sides.  Allow the user to
+    # just say --target=foo-darwin without a version number to mean
+    # "the version on this system".
+      *-*-darwin*,*-*-darwin*)
+	hostos=`echo $host | sed 's/.*-darwin/darwin/'`
+	targetos=`echo $target | sed 's/.*-darwin/darwin/'`
+	if test $hostos = $targetos || test $targetos = darwin ; then
+	  GLIBCXX_IS_NATIVE=true
+	fi
+	;;
+
+      *)
+	GCC_NO_EXECUTABLES
+	;;
+  esac
+else
+  GLIBCXX_IS_NATIVE=true
+fi
+
+# Runs configure.host, and assorted other critical bits.  Sets
+# up critical shell variables.
+GLIBCXX_CONFIGURE
+
+AM_INIT_AUTOMAKE([1.15.1 no-define foreign no-dist -Wall -Wno-portability])
+
+AH_TEMPLATE(PACKAGE, [Name of package])
+AH_TEMPLATE(VERSION, [Version number of package])
+
+AC_ARG_WITH(cross-host,
+[  --with-cross-host=HOST           Configuring with a cross compiler])
+
+# Checks for header files.
+AC_CHECK_HEADERS(malloc.h)
+
+AC_CANONICAL_HOST
+ACX_NONCANONICAL_HOST
+ACX_NONCANONICAL_TARGET
+GCC_TOPLEV_SUBDIRS
+
+AC_MSG_CHECKING([for --enable-version-specific-runtime-libs])
+AC_ARG_ENABLE(version-specific-runtime-libs,
+[  --enable-version-specific-runtime-libs    Specify that runtime libraries should be installed in a compiler-specific directory ],
+[case "$enableval" in
+ yes) version_specific_libs=yes ;;
+ no)  version_specific_libs=no ;;
+ *)   AC_MSG_ERROR([Unknown argument to enable/disable version-specific libs]);;
+ esac],
+[version_specific_libs=no])
+AC_MSG_RESULT($version_specific_libs)
+
+AC_ARG_WITH(slibdir,
+[  --with-slibdir=DIR      shared libraries in DIR [LIBDIR]],
+slibdir="$with_slibdir",
+if test "${version_specific_libs}" = yes; then
+  slibdir='$(libsubdir)'
+elif test -n "$with_cross_host" && test x"$with_cross_host" != x"no"; then
+  slibdir='$(exec_prefix)/$(host_noncanonical)/lib'
+else
+  slibdir='$(libdir)'
+fi)
+AC_SUBST(slibdir)
+
+# Command-line options.
+# Very limited version of AC_MAINTAINER_MODE.
+AC_ARG_ENABLE([maintainer-mode],
+  [AC_HELP_STRING([--enable-maintainer-mode],
+                 [enable make rules and dependencies not useful (and
+                  sometimes confusing) to the casual installer])],
+  [case ${enable_maintainer_mode} in
+     yes) MAINT='' ;;
+     no) MAINT='#' ;;
+     *) AC_MSG_ERROR([--enable-maintainer-mode must be yes or no]) ;;
+   esac
+   maintainer_mode=${enableval}],
+  [MAINT='#'])
+AC_SUBST([MAINT])dnl
+
+toolexecdir=no
+toolexeclibdir=no
+
+# Calculate toolexeclibdir
+# Also toolexecdir, though it's only used in toolexeclibdir
+case ${version_specific_libs} in
+  yes)
+    # Need the gcc compiler version to know where to install libraries
+    # and header files if --enable-version-specific-runtime-libs option
+    # is selected.
+    toolexecdir='$(libdir)/gcc/$(target_noncanonical)'
+    toolexeclibdir='$(toolexecdir)/$(gcc_version)$(MULTISUBDIR)'
+    ;;
+  no)
+    if test -n "$with_cross_host" &&
+       test x"$with_cross_host" != x"no"; then
+      # Install a library built with a cross compiler in tooldir, not libdir.
+      toolexecdir='$(exec_prefix)/$(target_noncanonical)'
+      toolexeclibdir='$(toolexecdir)/lib'
+    else
+      toolexecdir='$(libdir)/gcc-lib/$(target_noncanonical)'
+      toolexeclibdir='$(libdir)'
+    fi
+    multi_os_directory=`$CC -print-multi-os-directory`
+    case $multi_os_directory in
+      .) ;; # Avoid trailing /.
+      *) toolexeclibdir=$toolexeclibdir/$multi_os_directory ;;
+    esac
+    ;;
+esac
+
+AC_SUBST(toolexecdir)
+AC_SUBST(toolexeclibdir)
+
+AH_TEMPLATE(PACKAGE, [Name of package])
+AH_TEMPLATE(VERSION, [Version number of package])
+
+AM_MAINTAINER_MODE
+
+# Check the compiler.
+# The same as in boehm-gc and libstdc++. Have to borrow it from there.
+# We must force CC to /not/ be precious variables; otherwise
+# the wrong, non-multilib-adjusted value will be used in multilibs.
+# As a side effect, we have to subst CFLAGS ourselves.
+
+m4_rename([_AC_ARG_VAR_PRECIOUS],[real_PRECIOUS])
+m4_define([_AC_ARG_VAR_PRECIOUS],[])
+AC_PROG_CC
+AC_PROG_CXX
+AM_PROG_AS
+m4_rename_force([real_PRECIOUS],[_AC_ARG_VAR_PRECIOUS])
+
+AC_SUBST(CFLAGS)
+
+# In order to override CFLAGS_FOR_TARGET, all of our special flags go
+# in XCFLAGS.  But we need them in CFLAGS during configury.  So put them
+# in both places for now and restore CFLAGS at the end of config.
+save_CFLAGS="$CFLAGS"
+
+# Find other programs we need.
+AC_CHECK_TOOL(AR, ar)
+AC_CHECK_TOOL(NM, nm)
+AC_CHECK_TOOL(RANLIB, ranlib, ranlib-not-found-in-path-error)
+AC_PROG_MAKE_SET
+AC_PROG_INSTALL
+
+AM_PROG_LIBTOOL
+LT_INIT
+AC_LIBTOOL_DLOPEN
+
+AM_CONDITIONAL([ENABLE_DARWIN_AT_RPATH], [test x$enable_darwin_at_rpath = xyes])
+
+AC_SUBST(enable_shared)
+AC_SUBST(enable_static)
+
+if test "${multilib}" = "yes"; then
+  multilib_arg="--enable-multilib"
+else
+  multilib_arg=
+fi
+
+AC_LANG_C
+# Check the compiler.
+# The same as in boehm-gc and libstdc++. Have to borrow it from there.
+# We must force CC to /not/ be precious variables; otherwise
+# the wrong, non-multilib-adjusted value will be used in multilibs.
+# As a side effect, we have to subst CFLAGS ourselves.
+
+m4_rename([_AC_ARG_VAR_PRECIOUS],[real_PRECIOUS])
+m4_define([_AC_ARG_VAR_PRECIOUS],[])
+AC_PROG_CC
+m4_rename_force([real_PRECIOUS],[_AC_ARG_VAR_PRECIOUS])
+
+AC_SUBST(CFLAGS)
+
+CC_FOR_BUILD=${CC_FOR_BUILD:-gcc}
+AC_SUBST(CC_FOR_BUILD)
+
+AC_SEARCH_LIBS([malloc], [c])
+AC_SEARCH_LIBS([cosf], [m])
+AC_SEARCH_LIBS([clock_gettime], [rt])
+
+# Add dependencies for libga68.spec file
+SPEC_LIBGA68_DEPS="$LIBS"
+AC_SUBST(SPEC_LIBGA68_DEPS)
+
+# libga68 soname version
+libga68_VERSION=1:0:0
+AC_SUBST(libga68_VERSION)
+
+# The Boehm GC
+
+AC_ARG_ENABLE(algol68-gc,
+[AS_HELP_STRING([--enable-algol68-gc],
+		[enable use of Boehm's garbage collector with the
+		 GNU Algol runtime])],,enable_algol68_gc=no)
+AC_ARG_WITH([target-bdw-gc],
+[AS_HELP_STRING([--with-target-bdw-gc=PATHLIST],
+		[specify prefix directory for installed bdw-gc package.
+		 Equivalent to --with-target-bdw-gc-include=PATH/include
+		 plus --with-target-bdw-gc-lib=PATH/lib])])
+AC_ARG_WITH([target-bdw-gc-include],
+[AS_HELP_STRING([--with-target-bdw-gc-include=PATHLIST],
+		[specify directories for installed bdw-gc include files])])
+AC_ARG_WITH([target-bdw-gc-lib],
+[AS_HELP_STRING([--with-target-bdw-gc-lib=PATHLIST],
+		[specify directories for installed bdw-gc library])])
+
+bdw_lib_dir=
+case "$enable_algol68_gc" in
+no)
+  use_bdw_gc=no
+  ;;
+*)
+  AC_MSG_CHECKING([for bdw garbage collector])
+  if test "x$with_target_bdw_gc$with_target_bdw_gc_include$with_target_bdw_gc_lib" = x; then
+    dnl no bdw-gw options, assuming bdw-gc in default locations
+    BDW_GC_CFLAGS=
+    BDW_GC_LIBS="-lgc"
+  else
+    dnl bdw-gw options passed by configure flags
+    if test "x$with_target_bdw_gc_include" = x && test "x$with_target_bdw_gc_lib" != x; then
+      AC_MSG_ERROR([found --with-target-bdw-gc-lib but --with-target-bdw-gc-include missing])
+    elif test "x$with_target_bdw_gc_include" != x && test "x$with_target_bdw_gc_lib" = x; then
+      AC_MSG_ERROR([found --with-target-bdw-gc-include but --with-target-bdw-gc-lib missing])
+    else
+      AC_MSG_RESULT([using paths configured with --with-target-bdw-gc options])
+    fi
+    mldir=`${CC-gcc} --print-multi-directory 2>/dev/null`
+    bdw_val=
+    if test "x$with_target_bdw_gc" != x; then
+      for i in `echo $with_target_bdw_gc | tr ',' ' '`; do
+        case "$i" in
+          *=*) sd=${i%%=*}; d=${i#*=} ;;
+          *) sd=.; d=$i ;;
+        esac
+        if test "$mldir" = "$sd"; then
+          bdw_val=$d
+        fi
+      done
+      if test "x$bdw_val" = x; then
+        AC_MSG_ERROR([no multilib path ($mldir) found in --with-target-bdw-gc])
+      fi
+      bdw_inc_dir="$bdw_val/include"
+      bdw_lib_dir="$bdw_val/lib"
+    fi
+    bdw_val=
+    if test "x$with_target_bdw_gc_include" != x; then
+      for i in `echo $with_target_bdw_gc_include | tr ',' ' '`; do
+        case "$i" in
+          *=*) sd=${i%%=*}; d=${i#*=} ;;
+          *) sd=.; d=$i; fallback=$i ;;
+        esac
+        if test "$mldir" = "$sd"; then
+          bdw_val=$d
+        fi
+      done
+      if test "x$bdw_val" = x && test "x$bdw_inc_dir" = x && test "x$fallback" != x; then
+        bdw_inc_dir="$fallback"
+      elif test "x$bdw_val" = x; then
+        AC_MSG_ERROR([no multilib path ($mldir) found in --with-target-bdw-gc-include])
+      else
+        bdw_inc_dir="$bdw_val"
+      fi
+    fi
+    bdw_val=
+    if test "x$with_target_bdw_gc_lib" != x; then
+      for i in `echo $with_target_bdw_gc_lib | tr ',' ' '`; do
+        case "$i" in
+          *=*) sd=${i%%=*}; d=${i#*=} ;;
+          *) sd=.; d=$i ;;
+        esac
+        if test "$mldir" = "$sd"; then
+          bdw_val=$d
+        fi
+      done
+      if test "x$bdw_val" = x; then
+        AC_MSG_ERROR([no multilib path ($mldir) found in --with-target-bdw-gc-lib])
+      fi
+      bdw_lib_dir="$bdw_val"
+    fi
+    if test "x$bdw_inc_dir" = x; then
+      AC_MSG_ERROR([no multilib path ($mldir) found in --with-target-bdw-gc-include])
+    fi
+    if test "x$bdw_lib_dir" = x; then
+      AC_MSG_ERROR([no multilib path ($mldir) found in --with-target-bdw-gc-lib])
+    fi
+    BDW_GC_CFLAGS="-I$bdw_inc_dir"
+    if test -f $bdw_lib_dir/libgc.la; then
+      BDW_GC_LIBS="$bdw_lib_dir/libgc.la"
+    else
+      BDW_GC_LIBS="-L$bdw_lib_dir -lgc"
+    fi
+    AC_MSG_RESULT([found])
+  fi
+
+  case "$BDW_GC_LIBS" in
+  *libgc.la)
+    use_bdw_gc=yes
+    ;;
+  *)
+    AC_MSG_CHECKING([for system boehm-gc])
+    save_CFLAGS=$CFLAGS
+    save_LIBS=$LIBS
+    CFLAGS="$CFLAGS $BDW_GC_CFLAGS"
+    LIBS="$LIBS $BDW_GC_LIBS"
+    dnl the link test is not good enough for ARM32 multilib detection,
+    dnl first check to link, then to run
+    AC_LINK_IFELSE(
+      [AC_LANG_PROGRAM([#include <gc/gc.h>],[GC_init()])],
+      [
+        AC_RUN_IFELSE([AC_LANG_SOURCE([[
+          #include <gc/gc.h>
+          int main() {
+            GC_init();
+            return 0;
+          }
+          ]])],
+          [system_bdw_gc_found=yes],
+          [system_bdw_gc_found=no],
+          dnl assume no system boehm-gc for cross builds ...
+          [system_bdw_gc_found=no]
+        )
+      ],
+      [system_bdw_gc_found=no])
+    CFLAGS=$save_CFLAGS
+    LIBS=$save_LIBS
+    if test x$enable_algol68_gc = xauto && test x$system_bdw_gc_found = xno; then
+      AC_MSG_WARN([system bdw-gc not found, building libga68 with no GC support])
+      use_bdw_gc=no
+    elif test x$enable_algol68_gc = xyes && test x$system_bdw_gc_found = xno; then
+      AC_MSG_ERROR([system bdw-gc required but not found])
+    else
+      use_bdw_gc=yes
+      AC_MSG_RESULT([found])
+    fi
+  esac
+esac
+
+if test "$use_bdw_gc" = no; then
+  LIBGA68_GCFLAGS=''
+  LIBGA68_BOEHM_GC_INCLUDES=''
+  LIBGA68_BOEHM_GC_LIBS=''
+else
+  LIBGA68_GCFLAGS='-DLIBGA68_WITH_GC=1'
+  LIBGA68_BOEHM_GC_INCLUDES=$BDW_GC_CFLAGS
+  LIBGA68_BOEHM_GC_LIBS=$BDW_GC_LIBS
+  SPEC_LIBGA68_DEPS="$SPEC_LIBGA68_DEPS $BDW_GC_LIBS"
+fi
+
+# Determine what GCC version number to use in filesystem paths.
+GCC_BASE_VER
+
+extra_darwin_ldflags_libga68=
+case $host in
+  *-*-darwin*)
+     extra_darwin_ldflags_libga68=-Wl,-U,___algol68_main
+     if test -f $bdw_lib_dir/libgc.a; then
+       # Darwin wants to link this statically into the library
+       LIBGA68_BOEHM_GC_LIBS="$bdw_lib_dir/libgc.a"
+       # No spec entry.
+       BDW_GC_LIBS=
+     fi
+     ;;
+  *) ;;
+esac
+AC_SUBST(extra_darwin_ldflags_libga68)
+
+AC_SUBST(LIBGA68_GCFLAGS)
+AC_SUBST(LIBGA68_BOEHM_GC_INCLUDES)
+AC_SUBST(LIBGA68_BOEHM_GC_LIBS)
+
+AC_CONFIG_SRCDIR([Makefile.am])
+AC_CONFIG_FILES([Makefile])
+AC_CONFIG_FILES(libga68.spec)
+
+AC_MSG_NOTICE([libga68 has been configured.])
+
+AC_OUTPUT
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 41/47] a68: libga68: build system (generated files)
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (39 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 40/47] a68: libga68: build system Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 42/47] a68: testsuite: infrastructure Jose E. Marchesi
                   ` (6 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

ChangeLog

	* libga68/config.h.in: Regenerate.
	* libga68/configure: Likewise.
---

  -*- snip, please see the a68-v4 branch -*-

^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 42/47] a68: testsuite: infrastructure
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (40 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 41/47] a68: libga68: build system (generated files) Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 43/47] a68: testsuite: execution tests 1/2 Jose E. Marchesi
                   ` (5 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/testsuite/ChangeLog

	* lib/algol68-dg.exp: New file.
	* lib/algol68-torture.exp: Likewise.
	* lib/algol68.exp: Likewise.
---
 gcc/testsuite/lib/algol68-dg.exp      |  57 ++++
 gcc/testsuite/lib/algol68-torture.exp | 430 ++++++++++++++++++++++++++
 gcc/testsuite/lib/algol68.exp         | 217 +++++++++++++
 3 files changed, 704 insertions(+)
 create mode 100644 gcc/testsuite/lib/algol68-dg.exp
 create mode 100644 gcc/testsuite/lib/algol68-torture.exp
 create mode 100644 gcc/testsuite/lib/algol68.exp

diff --git a/gcc/testsuite/lib/algol68-dg.exp b/gcc/testsuite/lib/algol68-dg.exp
new file mode 100644
index 00000000000..d012bb07352
--- /dev/null
+++ b/gcc/testsuite/lib/algol68-dg.exp
@@ -0,0 +1,57 @@
+# Copyright (C) 1997-2024 Free Software Foundation, Inc.
+
+# This program 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 of the License, or
+# (at your option) any later version.
+#
+# This program 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/>.
+
+load_lib gcc-dg.exp
+
+# Define ALGOL68 callbacks for dg.exp.
+
+proc algol68-dg-test { prog do_what extra_tool_flags } {
+    return [gcc-dg-test-1 algol68_target_compile $prog $do_what $extra_tool_flags]
+}
+
+proc algol68-dg-prune { system text } {
+    return [gcc-dg-prune $system $text]
+}
+
+# Modified dg-runtest that can cycle through a list of optimization options
+# as c-torture does.
+proc algol68-dg-runtest { testcases flags default-extra-flags } {
+    global runtests
+    global TORTURE_OPTIONS
+
+    foreach test $testcases {
+	# If we're only testing specific files and this isn't one of
+	# them, skip it.
+	if ![runtest_file_p $runtests $test] {
+	    continue
+        }
+
+	# look if this is dg-do-run test, in which case
+	# we cycle through the option list, otherwise we don't
+	if [expr [search_for $test "dg-do run"]] {
+	    set option_list $TORTURE_OPTIONS
+	} else {
+	    set option_list [list { -O2 } ]
+	}
+
+	set nshort [file tail [file dirname $test]]/[file tail $test]
+
+	foreach flags_t $option_list {
+	    verbose "Testing $nshort, $flags $flags_t" 1
+	    dg-test $test "$flags $flags_t" ${default-extra-flags}
+	}
+    }
+}
diff --git a/gcc/testsuite/lib/algol68-torture.exp b/gcc/testsuite/lib/algol68-torture.exp
new file mode 100644
index 00000000000..269b53d5bd7
--- /dev/null
+++ b/gcc/testsuite/lib/algol68-torture.exp
@@ -0,0 +1,430 @@
+# Copyright (C) 2009-2024 Free Software Foundation, Inc.
+
+# This program 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 of the License, or
+# (at your option) any later version.
+# 
+# This program 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/>.
+
+# Please email any bugs, comments, and/or additions to this file to
+# the author.
+
+load_lib dg.exp
+
+load_lib target-supports.exp
+
+load_lib target-utils.exp
+
+# The default option list can be overridden by
+# TORTURE_OPTIONS="{ { list1 } ... { listN } }"
+
+if ![info exists TORTURE_OPTIONS] {
+    set TORTURE_OPTIONS [list \
+	{ -O0 } { -O1 } { -O2 } \
+	{ -O2 -fomit-frame-pointer -finline-functions } \
+	{ -O2 -fomit-frame-pointer -finline-functions -funroll-loops } \
+	{ -O2 -fcheck=bounds } \
+	{ -O2 -fcheck=nil } \
+	{ -O3 -g } \
+	{ -Os }]
+
+    if [check_effective_target_lto] {
+	set TORTURE_OPTIONS \
+	    [concat $TORTURE_OPTIONS [list {-flto}]]
+    }
+}
+
+#
+# algol68-torture-compile -- compile an algol68/execute/torture testcase.
+#
+# SRC is the full pathname of the testcase.
+# OPTION is the specific compiler flag we're testing (eg: -O2).
+#
+proc algol68-torture-compile { src option } {
+    global output
+    global srcdir tmpdir
+    global host_triplet
+
+    set output "$tmpdir/[file tail [file rootname $src]].o"
+
+    regsub "(?q)$srcdir/" $src "" testcase
+
+    # If we couldn't rip $srcdir out of `src' then just do the best we can.
+    # The point is to reduce the unnecessary noise in the logs.  Don't strip
+    # out too much because different testcases with the same name can confuse
+    # `test-tool'.
+    if [string match "/*" $testcase] {
+	set testcase "[file tail [file dirname $src]]/[file tail $src]"
+    }
+
+    verbose "Testing $testcase, $option" 1
+
+    # Run the compiler and get results in comp_output.
+    set options ""
+    lappend options "additional_flags=-w $option"
+
+    set comp_output [algol68_target_compile "$src" "$output" object $options]
+    
+    # See if we got something bad.
+    set fatal_signal "*algol68*: Internal compiler error: program*got fatal signal"
+ 
+    if [string match "$fatal_signal 6" $comp_output] then {
+	algol68_fail $testcase "Got Signal 6, $option"
+	catch { remote_file build delete $output }
+	return
+    }
+
+    if [string match "$fatal_signal 11" $comp_output] then {
+	algol68_fail $testcase "Got Signal 11, $option"
+	catch { remote_file build delete $output }
+	return
+    }
+
+    if [regexp -line -- "internal compiler error.*" $comp_output ice] then {
+	algol68_fail $testcase "$option ($ice)"
+	catch { remote_file build delete $output }
+	return
+    }
+
+    # We shouldn't get these because of -w, but just in case.
+    if [string match "*algol68*:*warning:*" $comp_output] then {
+	warning "$testcase: (with warnings) $option"
+	send_log "$comp_output\n"
+	unresolved "$testcase, $option"
+	catch { remote_file build delete $output }
+	return
+    }
+
+    # Prune warnings we know are unwanted.
+    set comp_output [prune_warnings $comp_output]
+
+    # Report if the testcase is not supported.
+    set unsupported_message [algol68_check_unsupported_p $comp_output]
+    if { $unsupported_message != "" } {
+	unsupported "$testcase: $unsupported_message"
+	catch { remote_file build delete $output }
+	return
+    }
+
+    # remove any leftover LF/CR to make sure any output is legit
+    regsub -all -- "\[\r\n\]*" $comp_output "" comp_output
+
+    # If any message remains, we fail.
+    if ![string match "" $comp_output] then {
+	algol68_fail $testcase $option
+	catch { remote_file build delete $output }
+	return
+    }
+
+    algol68_pass $testcase $option
+    catch { remote_file build delete $output }
+}
+
+
+#
+# algol68-torture-execute -- compile and execute a testcase.
+#
+# SRC is the full pathname of the testcase.
+#
+# If the testcase has an associated .x file, we source that to run the
+# test instead.  We use .x so that we don't lengthen the existing filename
+# to more than 14 chars.
+#
+proc algol68-torture-execute { src } {
+    global output
+    global srcdir tmpdir
+    global tool
+    global compiler_conditional_xfail_data
+    global TORTURE_OPTIONS
+    global errorCode errorInfo
+    global algol68_compile_args
+    global algol68_execute_args
+    global dg-extra-tool-flags
+
+    set dg-excess-errors-flag 0
+    set dg-messages ""
+    set dg-extra-tool-flags ""
+    set dg-final-code ""
+
+    # `dg-output-text' is a list of two elements: pass/fail and text.
+    # Leave second element off for now (indicates "don't perform test")
+    set dg-output-text "P"
+
+    set tmp [dg-get-options $src]
+    foreach op $tmp {
+        verbose "Processing option: $op" 3
+        set status [catch $op errmsg]
+        if { $status != 0 } {
+            if { 0 && [info exists errorInfo] } {
+                # This also prints a backtrace which will just confuse
+                # testcase writers, so it's disabled.
+                perror "$src: $errorInfo\n"
+            } else {
+                perror "$src: $errmsg for \"$op\"\n"
+            }
+            perror "$src: $errmsg for \"$op\"" 0
+            return
+        }
+    }
+
+    # Check for alternate driver.
+    set additional_flags ""
+    if [file exists [file rootname $src].x] {
+	verbose "Using alternate driver [file rootname [file tail $src]].x" 2
+	set done_p 0
+	catch "set done_p \[source [file rootname $src].x\]"
+	if { $done_p } {
+	    return
+	}
+    }
+
+    # Setup the options for the testcase run.
+    set option_list $TORTURE_OPTIONS
+    set executable $tmpdir/[file tail [file rootname $src].x]
+    regsub "(?q)$srcdir/" $src "" testcase
+
+    if { ! [info exists algol68_compile_args] } {
+	set algol68_compile_args ""
+    }
+    if { ! [info exists algol68_execute_args] } {
+	set algol68_execute_args ""
+    }
+
+    # If we couldn't rip $srcdir out of `src' then just do the best we can.
+    # The point is to reduce the unnecessary noise in the logs.  Don't strip
+    # out too much because different testcases with the same name can confuse
+    # `test-tool'.
+    if [string match "/*" $testcase] {
+	set testcase "[file tail [file dirname $src]]/[file tail $src]"
+    }
+
+    # Walk the list of options and compile and run the testcase for all
+    # options that are not explicitly disabled by the .x script (if present).
+    foreach option $option_list {
+
+	# Torture_{compile,execute}_xfail are set by the .x script.
+	if [info exists torture_compile_xfail] {
+	    setup_xfail $torture_compile_xfail
+	}
+
+	# Torture_execute_before_{compile,execute} can be set by the .x script.
+	if [info exists torture_eval_before_compile] {
+            set ignore_me [eval $torture_eval_before_compile]
+	}
+
+	# FIXME: We should make sure that the modules required by this testcase
+	# exist.  If not, the testcase should XFAIL.
+
+	# Compile the testcase.
+	catch { remote_file build delete $executable }
+	verbose "Testing $testcase, $option" 1
+
+	set options ""
+	lappend options "additional_flags=-w $option"
+	if { ${dg-extra-tool-flags} != "" } {
+	    lappend options "additional_flags=${dg-extra-tool-flags}"
+	}
+	if { $additional_flags != "" } {
+	    lappend options "additional_flags=$additional_flags"
+	}
+	if { $algol68_compile_args != "" } {
+	    lappend options "additional_flags=$algol68_compile_args"
+	}
+	set comp_output [algol68_target_compile "$src" "$executable" executable $options]
+
+	# See if we got something bad.
+	set fatal_signal "*algol68*: Internal compiler error: program*got fatal signal"
+	
+	if [string match "$fatal_signal 6" $comp_output] then {
+	    algol68_fail $testcase "Got Signal 6, $option"
+	    catch { remote_file build delete $executable }
+	    continue
+	}
+	
+	if [string match "$fatal_signal 11" $comp_output] then {
+	    algol68_fail $testcase "Got Signal 11, $option"
+	    catch { remote_file build delete $executable }
+	    continue
+	}
+
+	if [regexp -line -- "internal compiler error.*" $comp_output ice] then {
+	    algol68_fail $testcase "$option ($ice)"
+	    catch { remote_file build delete $executable }
+	    continue
+	}
+	
+	# We shouldn't get these because of -w, but just in case.
+	if [string match "*algol68*:*warning:*" $comp_output] then {
+	    warning "$testcase: (with warnings) $option"
+	    send_log "$comp_output\n"
+	    unresolved "$testcase, $option"
+	    catch { remote_file build delete $executable }
+	    continue
+	}
+	
+	# Prune warnings we know are unwanted.
+	set comp_output [prune_warnings $comp_output]
+
+	# Report if the testcase is not supported.
+	set unsupported_message [algol68_check_unsupported_p $comp_output]
+	if { $unsupported_message != "" } {
+	    unsupported "$testcase: $unsupported_message"
+	    continue
+	} elseif ![file exists $executable] {
+	    if ![is3way] {
+		fail "$testcase compilation, $option"
+		untested "$testcase execution, $option"
+		continue
+	    } else {
+		# FIXME: since we can't test for the existence of a remote
+		# file without short of doing an remote file list, we assume
+		# that since we got no output, it must have compiled.
+		pass "$testcase compilation, $option"		
+	    }
+	} else {
+	    pass "$testcase compilation, $option"
+	}
+
+	if [info exists torture_execute_xfail] {
+	    setup_xfail $torture_execute_xfail
+	}
+
+	if [info exists torture_eval_before_execute] {
+            set ignore_me [eval $torture_eval_before_execute]
+	}
+
+	# Run the testcase, and analyse the output.
+	set result [algol68_load "$executable" "$algol68_execute_args" ""]
+	set status [lindex $result 0]
+	set output [lindex $result 1]
+	if { $status eq "pass" } {
+	    pass "$testcase execution test, $option"
+	    verbose "Exec succeeded." 3
+	    if { [llength ${dg-output-text}] > 1 } {
+		if { [lindex ${dg-output-text} 0] eq "F" } {
+		    setup_xfail "*-*-*"
+		}
+		set texttmp [lindex ${dg-output-text} 1]
+		if { ![regexp -- $texttmp $output] } {
+		    fail "$testcase output pattern test, $option"
+		    send_log "Output was:\n${output}\nShould match:\n$texttmp\n"
+		    verbose "Failed test for output pattern $texttmp" 3
+		} else {
+		    pass "$testcase output pattern test, $option"
+		    verbose "Passed test for output pattern $texttmp" 3
+		}
+		unset texttmp
+	    }
+	} elseif { $status eq "fail" } {
+	    if {[info exists errorCode]} {
+		verbose "Exec failed, errorCode: $errorCode" 3
+	    } else {
+		verbose "Exec failed, errorCode not defined!" 3
+	    }
+	    fail "$testcase execution test, $option"
+	} else {
+	    $status "$testcase execution, $option"
+	}
+	catch { remote_file build delete $executable }
+    }
+}
+
+
+#
+# search_for_re -- looks for a string match in a file
+#
+proc search_for_re { file pattern } {
+    set fd [open $file r]
+    while { [gets $fd cur_line]>=0 } {
+	set lower [string tolower $cur_line]
+	if [regexp "$pattern" $lower] then {
+	    close $fd
+	    return 1
+	}
+    }
+    close $fd
+    return 0
+}
+
+
+#
+# algol68-torture -- the algol68-torture testcase source file processor
+#
+# This runs compilation only tests (no execute tests).
+#
+# SRC is the full pathname of the testcase, or just a file name in which
+# case we prepend $srcdir/$subdir.
+#
+# If the testcase has an associated .x file, we source that to run the
+# test instead.  We use .x so that we don't lengthen the existing filename
+# to more than 14 chars.
+#
+proc algol68-torture { args } {
+    global srcdir subdir
+    global compiler_conditional_xfail_data
+    global TORTURE_OPTIONS
+
+    set src [lindex $args 0]
+    if { [llength $args] > 1 } {
+	set options [lindex $args 1]
+    } else {
+	set options ""
+    }
+
+    # Prepend $srdir/$subdir if missing.
+    if ![string match "*/*" $src] {
+	set src "$srcdir/$subdir/$src"
+    }
+
+    # Check for alternate driver.
+    if [file exists [file rootname $src].x] {
+	verbose "Using alternate driver [file rootname [file tail $src]].x" 2
+	set done_p 0
+	catch "set done_p \[source [file rootname $src].x\]"
+	if { $done_p } {
+	    return
+	}
+    }
+   
+    # loop through all the options
+    set option_list $TORTURE_OPTIONS
+    foreach option $option_list {
+
+	# torture_compile_xfail is set by the .x script (if present)
+	if [info exists torture_compile_xfail] {
+	    setup_xfail $torture_compile_xfail
+	}
+
+	# torture_execute_before_compile is set by the .x script (if present)
+	if [info exists torture_eval_before_compile] {
+            set ignore_me [eval $torture_eval_before_compile]
+	}
+
+	algol68-torture-compile $src "$option $options"
+    }
+}
+
+#
+# add-ieee-options -- add options necessary for 100% ieee conformance.
+#
+proc add-ieee-options { } {
+    # Ensure that excess precision does not cause problems.
+    if { [istarget i?86-*-*]
+	 || [istarget m68k-*-*] } then {
+      uplevel 1 lappend additional_flags "-ffloat-store"
+    }
+
+    # Enable full IEEE compliance mode.
+    if { [istarget alpha*-*-*]
+         || [istarget sh*-*-*] } then {
+      uplevel 1 lappend additional_flags "-mieee"
+    }
+}
diff --git a/gcc/testsuite/lib/algol68.exp b/gcc/testsuite/lib/algol68.exp
new file mode 100644
index 00000000000..9102ab9e668
--- /dev/null
+++ b/gcc/testsuite/lib/algol68.exp
@@ -0,0 +1,217 @@
+# Copyright (C) 2012-2024 Free Software Foundation, Inc.
+
+# This program 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 of the License, or
+# (at your option) any later version.
+#
+# This program 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/>.
+
+#
+# ALGOL68 support library routines
+#
+
+load_lib prune.exp
+load_lib gcc-defs.exp
+load_lib timeout.exp
+load_lib target-libpath.exp
+
+#
+# ALGOL68_UNDER_TEST is the compiler under test.
+#
+
+set algol68_compile_options ""
+
+
+#
+# algol68_include_flags -- include flags for the gcc tree structure
+#
+
+proc algol68_include_flags { paths } {
+    global srcdir
+    global TESTING_IN_BUILD_TREE
+
+    set flags ""
+
+    if { [is_remote host] || ![info exists TESTING_IN_BUILD_TREE] } {
+	return "${flags}"
+    }
+
+    set gccpath ${paths}
+
+    return "$flags"
+}
+
+#
+# algol68_link_flags -- linker flags for the gcc tree structure
+#
+
+proc algol68_link_flags { paths } {
+    global srcdir
+    global ld_library_path
+    global shlib_ext
+    global SHARED_OPTION
+    global ALGOL68_UNDER_TEST
+
+    set gccpath ${paths}
+    set libio_dir ""
+    set flags ""
+    set ld_library_path "."
+    set shlib_ext [get_shlib_extension]
+    set SHARED_OPTION ""
+    verbose "shared lib extension: $shlib_ext"
+
+    # We need to add options to locate libga68.
+    set target_wants_B_option 0
+    if { [istarget *-*-darwin9* ] || [istarget *-*-darwin\[12\]* ] } {
+      set target_wants_B_option 1
+    }
+
+    if { $gccpath != "" } {
+	# Path to libga68.spec.
+	append flags "-B${gccpath}/libga68 "
+	if { [file exists "${gccpath}/libga68/.libs/libga68.a"] \
+	     || [file exists "${gccpath}/libga68/.libs/libga68.${shlib_ext}"] } {
+	    if { $target_wants_B_option } {
+		append flags "-B${gccpath}/libga68/.libs "
+	    } else {
+		append flags "-L${gccpath}/libga68/.libs "
+	    }
+	    append ld_library_path ":${gccpath}/libga68/.libs"
+	}
+	# Static linking is default. If only the shared lib is available adjust
+	# flags to always use it. If both are available, set SHARED_OPTION which
+	# will be added to PERMUTE_ARGS
+	if { [file exists "${gccpath}/libga68/src/.libs/libga68.${shlib_ext}"] } {
+	    if { [file exists "${gccpath}/libga68/src/.libs/libga68.a"] } {
+		set SHARED_OPTION "-shared-libga68"
+	    } else {
+#		append flags "-shared-libga68 "
+	    }
+	}
+	if [file exists "${gccpath}/libiberty/libiberty.a"] {
+	    append flags "-L${gccpath}/libiberty "
+	}
+	append ld_library_path [gcc-set-multilib-library-path $ALGOL68_UNDER_TEST]
+    }
+
+    set_ld_library_path_env_vars
+
+    return "$flags"
+}
+
+#
+# algol68_init -- called at the start of each subdir of tests
+#
+
+proc algol68_init { args } {
+    global subdir
+    global algol68_initialized
+    global base_dir
+    global tmpdir
+    global libdir
+    global gluefile wrap_flags
+    global objdir srcdir
+    global ALWAYS_ALGOL68FLAGS
+    global TOOL_EXECUTABLE TOOL_OPTIONS
+    global ALGOL68_UNDER_TEST
+    global TESTING_IN_BUILD_TREE
+    global gcc_warning_prefix
+    global gcc_error_prefix
+
+    # We set LC_ALL and LANG to C so that we get the same error messages as expected.
+    setenv LC_ALL C
+    setenv LANG C
+
+    if ![info exists ALGOL68_UNDER_TEST] then {
+	if [info exists TOOL_EXECUTABLE] {
+	    set ALGOL68_UNDER_TEST $TOOL_EXECUTABLE
+	} else {
+	    if { [is_remote host] || ! [info exists TESTING_IN_BUILD_TREE] } {
+		set ALGOL68_UNDER_TEST [transform ga68]
+	    } else {
+		set ALGOL68_UNDER_TEST [findfile $base_dir/../../ga68 "$base_dir/../../ga68 -B$base_dir/../../" [findfile $base_dir/ga68 "$base_dir/ga68 -B$base_dir/" [transform ga68]]]
+	    }
+	}
+    }
+
+    if ![is_remote host] {
+	if { [which $ALGOL68_UNDER_TEST] == 0 } then {
+	    perror "ALGOL68_UNDER_TEST ($ALGOL68_UNDER_TEST) does not exist"
+	    exit 1
+	}
+    }
+
+    if ![info exists tmpdir] {
+	set tmpdir "/tmp"
+    }
+
+    if [info exists gluefile] {
+	unset gluefile
+    }
+
+    set gcc_warning_prefix "warning:"
+    set gcc_error_prefix "(fatal )?error:"
+
+    verbose "algol68 is initialized" 3
+}
+
+#
+# algol68_target_compile -- compile a source file
+#
+
+proc algol68_target_compile { source dest type options } {
+    global tmpdir
+    global gluefile wrap_flags
+    global ALWAYS_ALGOL68FLAGS
+    global ALGOL68_UNDER_TEST
+    global individual_timeout
+    global TEST_ALWAYS_FLAGS
+
+    # HACK: guard against infinite loops in the compiler
+    set individual_timeout 20
+
+    if { [target_info needs_status_wrapper] != "" && [info exists gluefile] } {
+	lappend options "libs=${gluefile}"
+	lappend options "ldflags=${wrap_flags}"
+    }
+
+    set ALWAYS_ALGOL68FLAGS ""
+
+    # TEST_ALWAYS_FLAGS are flags that should be passed to every
+    # compilation.  They are passed first to allow individual
+    # tests to override them.
+    if [info exists TEST_ALWAYS_FLAGS] {
+	lappend ALWAYS_ALGOL68FLAGS "additional_flags=$TEST_ALWAYS_FLAGS"
+    }
+
+    if ![is_remote host] {
+	if [info exists TOOL_OPTIONS] {
+	    lappend ALWAYS_ALGOL68FLAGS "additional_flags=[algol68_include_flags [get_multilibs ${TOOL_OPTIONS}] ]"
+	    lappend ALWAYS_ALGOL68FLAGS "ldflags=[algol68_link_flags [get_multilibs ${TOOL_OPTIONS}] ]"
+	} else {
+	    lappend ALWAYS_ALGOL68FLAGS "additional_flags=[algol68_include_flags [get_multilibs] ]"
+	    lappend ALWAYS_ALGOL68FLAGS "ldflags=[algol68_link_flags [get_multilibs] ]"
+	}
+    }
+
+    if [info exists TOOL_OPTIONS] {
+	lappend ALWAYS_ALGOL68FLAGS "additional_flags=$TOOL_OPTIONS"
+    }
+
+    verbose -log "ALWAYS_ALGOL68FLAGS set to $ALWAYS_ALGOL68FLAGS"
+
+    lappend options "timeout=[timeout_value]"
+    lappend options "compiler=$ALGOL68_UNDER_TEST"
+
+    set options [concat "$ALWAYS_ALGOL68FLAGS" $options]
+    set options [dg-additional-files-options $options $source $dest $type]
+    return [target_compile $source $dest $type $options]
+}
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 43/47] a68: testsuite: execution tests 1/2
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (41 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 42/47] a68: testsuite: infrastructure Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 44/47] a68: testsuite: execution tests 2/2 Jose E. Marchesi
                   ` (4 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/testsuite/ChangeLog

	* algol68/execute/abs-bits-1.a68: New file.
	* algol68/execute/abs-bool-1.a68: Likewise.
	* algol68/execute/abs-char-1.a68: Likewise.
	* algol68/execute/abs-int-1.a68: Likewise.
	* algol68/execute/abs-int-negative-1.a68: Likewise.
	* algol68/execute/abs-int-negative-gnu-1.a68: Likewise.
	* algol68/execute/acos-1.a68: Likewise.
	* algol68/execute/affirm-int-1.a68: Likewise.
	* algol68/execute/and-bits-1.a68: Likewise.
	* algol68/execute/andf-1.a68: Likewise.
	* algol68/execute/ascription-1.a68: Likewise.
	* algol68/execute/asin-1.a68: Likewise.
	* algol68/execute/assert-1.a68: Likewise.
	* algol68/execute/assignation-char-1.a68: Likewise.
	* algol68/execute/assignation-int-1.a68: Likewise.
	* algol68/execute/assignation-int-2.a68: Likewise.
	* algol68/execute/assignation-int-3.a68: Likewise.
	* algol68/execute/assignation-int-4.a68: Likewise.
	* algol68/execute/assignation-int-5.a68: Likewise.
	* algol68/execute/assignation-multiple-1.a68: Likewise.
	* algol68/execute/assignation-multiple-2.a68: Likewise.
	* algol68/execute/assignation-struct-1.a68: Likewise.
	* algol68/execute/assignation-struct-2.a68: Likewise.
	* algol68/execute/atan-1.a68: Likewise.
	* algol68/execute/balancing-1.a68: Likewise.
	* algol68/execute/balancing-rows-1.a68: Likewise.
	* algol68/execute/bin-1.a68: Likewise.
	* algol68/execute/bin-negative-1.a68: Likewise.
	* algol68/execute/bin-negative-gnu-1.a68: Likewise.
	* algol68/execute/boolops-1.a68: Likewise.
	* algol68/execute/call-1.a68: Likewise.
	* algol68/execute/call-2.a68: Likewise.
	* algol68/execute/case-clause-1.a68: Likewise.
	* algol68/execute/case-clause-2.a68: Likewise.
	* algol68/execute/case-clause-3.a68: Likewise.
	* algol68/execute/case-clause-4.a68: Likewise.
	* algol68/execute/closed-clause-1.a68: Likewise.
	* algol68/execute/closed-clause-2.a68: Likewise.
	* algol68/execute/collateral-clause-1.a68: Likewise.
	* algol68/execute/collateral-clause-2.a68: Likewise.
	* algol68/execute/collateral-clause-3.a68: Likewise.
	* algol68/execute/collateral-clause-4.a68: Likewise.
	* algol68/execute/collateral-clause-5.a68: Likewise.
	* algol68/execute/collateral-clause-6.a68: Likewise.
	* algol68/execute/completer-1.a68: Likewise.
	* algol68/execute/completer-10.a68: Likewise.
	* algol68/execute/completer-2.a68: Likewise.
	* algol68/execute/completer-3.a68: Likewise.
	* algol68/execute/completer-4.a68: Likewise.
	* algol68/execute/completer-5.a68: Likewise.
	* algol68/execute/completer-6.a68: Likewise.
	* algol68/execute/completer-7.a68: Likewise.
	* algol68/execute/completer-8.a68: Likewise.
	* algol68/execute/completer-9.a68: Likewise.
	* algol68/execute/cond-clause-1.a68: Likewise.
	* algol68/execute/cond-clause-2.a68: Likewise.
	* algol68/execute/cond-clause-3.a68: Likewise.
	* algol68/execute/cond-clause-4.a68: Likewise.
	* algol68/execute/cond-clause-5.a68: Likewise.
	* algol68/execute/cond-clause-6.a68: Likewise.
	* algol68/execute/cond-clause-7.a68: Likewise.
	* algol68/execute/cond-clause-8.a68: Likewise.
	* algol68/execute/cond-clause-9.a68: Likewise.
	* algol68/execute/conformity-clause-1.a68: Likewise.
	* algol68/execute/conformity-clause-2.a68: Likewise.
	* algol68/execute/conformity-clause-3.a68: Likewise.
	* algol68/execute/conformity-clause-4.a68: Likewise.
	* algol68/execute/conformity-clause-5.a68: Likewise.
	* algol68/execute/conformity-clause-6.a68: Likewise.
	* algol68/execute/conformity-clause-7.a68: Likewise.
	* algol68/execute/conformity-clause-8.a68: Likewise.
	* algol68/execute/conformity-clause-9.a68: Likewise.
	* algol68/execute/conj-1.a68: Likewise.
	* algol68/execute/cos-1.a68: Likewise.
	* algol68/execute/declarer-1.a68: Likewise.
	* algol68/execute/declarer-2.a68: Likewise.
	* algol68/execute/deprocedure-1.a68: Likewise.
	* algol68/execute/deprocedure-2.a68: Likewise.
	* algol68/execute/deref-1.a68: Likewise.
	* algol68/execute/deref-2.a68: Likewise.
	* algol68/execute/deref-3.a68: Likewise.
	* algol68/execute/deref-4.a68: Likewise.
	* algol68/execute/deref-5.a68: Likewise.
	* algol68/execute/deref-6.a68: Likewise.
	* algol68/execute/deref-7.a68: Likewise.
	* algol68/execute/deref-8.a68: Likewise.
	* algol68/execute/div-int-1.a68: Likewise.
	* algol68/execute/divab-real-1.a68: Likewise.
	* algol68/execute/elem-bits-1.a68: Likewise.
	* algol68/execute/elems-1.a68: Likewise.
	* algol68/execute/elems-2.a68: Likewise.
	* algol68/execute/entier-1.a68: Likewise.
	* algol68/execute/environment-enquiries-1.a68: Likewise.
	* algol68/execute/environment-enquiries-2.a68: Likewise.
	* algol68/execute/environment-enquiries-3.a68: Likewise.
	* algol68/execute/environment-enquiries-4.a68: Likewise.
	* algol68/execute/environment-enquiries-5.a68: Likewise.
	* algol68/execute/environment-enquiries-6.a68: Likewise.
	* algol68/execute/environment-enquiries-7.a68: Likewise.
	* algol68/execute/environment-enquiries-8.a68: Likewise.
	* algol68/execute/eq-bits-1.a68: Likewise.
	* algol68/execute/eq-char-char-1.a68: Likewise.
	* algol68/execute/eq-int-1.a68: Likewise.
	* algol68/execute/eq-string-1.a68: Likewise.
	* algol68/execute/eq-string-stride-1.a68: Likewise.
	* algol68/execute/execute.exp: Likewise.
	* algol68/execute/factorial-1.a68: Likewise.
	* algol68/execute/flat-assignation-1.a68: Likewise.
	* algol68/execute/flat-assignation-2.a68: Likewise.
	* algol68/execute/flex-1.a68: Likewise.
	* algol68/execute/flex-2.a68: Likewise.
	* algol68/execute/flex-3.a68: Likewise.
	* algol68/execute/flex-4.a68: Likewise.
	* algol68/execute/flex-5.a68: Likewise.
	* algol68/execute/formula-1.a68: Likewise.
	* algol68/execute/formula-2.a68: Likewise.
	* algol68/execute/fsize-1.a68: Likewise.
	* algol68/execute/ge-int-1.a68: Likewise.
	* algol68/execute/ge-string-stride-1.a68: Likewise.
	* algol68/execute/gen-flex-1.a68: Likewise.
	* algol68/execute/gen-heap-1.a68: Likewise.
	* algol68/execute/gen-heap-2.a68: Likewise.
	* algol68/execute/gen-heap-3.a68: Likewise.
	* algol68/execute/gen-heap-bool-1.a68: Likewise.
	* algol68/execute/gen-heap-int-1.a68: Likewise.
	* algol68/execute/gen-heap-real-1.a68: Likewise.
	* algol68/execute/gen-heap-struct-1.a68: Likewise.
	* algol68/execute/gen-heap-struct-2.a68: Likewise.
	* algol68/execute/gen-heap-struct-3.a68: Likewise.
	* algol68/execute/gen-loc-1.a68: Likewise.
	* algol68/execute/gen-loc-2.a68: Likewise.
	* algol68/execute/gen-loc-3.a68: Likewise.
	* algol68/execute/gen-loc-4.a68: Likewise.
	* algol68/execute/gen-multiple-1.a68: Likewise.
	* algol68/execute/gen-union-1.a68: Likewise.
	* algol68/execute/gen-union-2.a68: Likewise.
	* algol68/execute/gen-union-3.a68: Likewise.
	* algol68/execute/goto-1.a68: Likewise.
	* algol68/execute/goto-2.a68: Likewise.
	* algol68/execute/goto-3.a68: Likewise.
	* algol68/execute/goto-4.a68: Likewise.
	* algol68/execute/goto-5.a68: Likewise.
	* algol68/execute/gt-int-1.a68: Likewise.
	* algol68/execute/gt-string-stride-1.a68: Likewise.
	* algol68/execute/i-1.a68: Likewise.
	* algol68/execute/i-2.a68: Likewise.
	* algol68/execute/identification-1.a68: Likewise.
	* algol68/execute/identification-2.a68: Likewise.
	* algol68/execute/identity-declaration-1.a68: Likewise.
	* algol68/execute/identity-declaration-2.a68: Likewise.
	* algol68/execute/identity-declaration-3.a68: Likewise.
	* algol68/execute/identity-declaration-4.a68: Likewise.
	* algol68/execute/identity-declaration-5.a68: Likewise.
	* algol68/execute/identity-declaration-multiple-1.a68: Likewise.
	* algol68/execute/identity-declaration-multiple-2.a68: Likewise.
	* algol68/execute/identity-declaration-multiple-3.a68: Likewise.
	* algol68/execute/identity-declaration-multiple-5.a68: Likewise.
	* algol68/execute/identity-declaration-multiple-empty-1.a68: Likewise.
	* algol68/execute/identity-declaration-multiple-empty-2.a68: Likewise.
	* algol68/execute/identity-declaration-multiple-empty-3.a68: Likewise.
	* algol68/execute/identity-declaration-multiple-empty-4.a68: Likewise.
	* algol68/execute/identity-declaration-struct-1.a68: Likewise.
	* algol68/execute/infinity-1.a68: Likewise.
	* algol68/execute/le-ge-bits-1.a68: Likewise.
	* algol68/execute/le-int-1.a68: Likewise.
	* algol68/execute/le-string-stride-1.a68: Likewise.
	* algol68/execute/leng-shorten-bits-1.a68: Likewise.
	* algol68/execute/leng-shorten-ints-1.a68: Likewise.
	* algol68/execute/leng-shorten-reals-1.a68: Likewise.
	* algol68/execute/lengths-shorths-1.a68: Likewise.
	* algol68/execute/lisp-1.a68: Likewise.
	* algol68/execute/lisp-2.a68: Likewise.
	* algol68/execute/ln-1.a68: Likewise.
	* algol68/execute/log-1.a68: Likewise.
	* algol68/execute/loop-1.a68: Likewise.
	* algol68/execute/loop-10.a68: Likewise.
	* algol68/execute/loop-11.a68: Likewise.
	* algol68/execute/loop-12.a68: Likewise.
	* algol68/execute/loop-13.a68: Likewise.
	* algol68/execute/loop-14.a68: Likewise.
	* algol68/execute/loop-2.a68: Likewise.
	* algol68/execute/loop-3.a68: Likewise.
	* algol68/execute/loop-4.a68: Likewise.
	* algol68/execute/loop-5.a68: Likewise.
	* algol68/execute/loop-6.a68: Likewise.
---
 gcc/testsuite/algol68/execute/abs-bits-1.a68  |   7 +
 gcc/testsuite/algol68/execute/abs-bool-1.a68  |   4 +
 gcc/testsuite/algol68/execute/abs-char-1.a68  |   3 +
 gcc/testsuite/algol68/execute/abs-int-1.a68   |  10 ++
 .../algol68/execute/abs-int-negative-1.a68    |   4 +
 .../execute/abs-int-negative-gnu-1.a68        |   4 +
 gcc/testsuite/algol68/execute/acos-1.a68      |   8 +
 .../algol68/execute/affirm-int-1.a68          |  10 ++
 gcc/testsuite/algol68/execute/and-bits-1.a68  |  18 ++
 gcc/testsuite/algol68/execute/andf-1.a68      |   4 +
 .../algol68/execute/ascription-1.a68          |  12 ++
 gcc/testsuite/algol68/execute/asin-1.a68      |   8 +
 gcc/testsuite/algol68/execute/assert-1.a68    |   3 +
 .../algol68/execute/assignation-char-1.a68    |   5 +
 .../algol68/execute/assignation-int-1.a68     |   5 +
 .../algol68/execute/assignation-int-2.a68     |   5 +
 .../algol68/execute/assignation-int-3.a68     |   6 +
 .../algol68/execute/assignation-int-4.a68     |   5 +
 .../algol68/execute/assignation-int-5.a68     |   6 +
 .../execute/assignation-multiple-1.a68        |   4 +
 .../execute/assignation-multiple-2.a68        |  15 ++
 .../algol68/execute/assignation-struct-1.a68  |   6 +
 .../algol68/execute/assignation-struct-2.a68  |   8 +
 gcc/testsuite/algol68/execute/atan-1.a68      |   8 +
 gcc/testsuite/algol68/execute/balancing-1.a68 |  12 ++
 .../algol68/execute/balancing-rows-1.a68      |   4 +
 gcc/testsuite/algol68/execute/bin-1.a68       |   6 +
 .../algol68/execute/bin-negative-1.a68        |   3 +
 .../algol68/execute/bin-negative-gnu-1.a68    |   3 +
 gcc/testsuite/algol68/execute/boolops-1.a68   |  18 ++
 gcc/testsuite/algol68/execute/call-1.a68      |  19 ++
 gcc/testsuite/algol68/execute/call-2.a68      |  21 +++
 .../algol68/execute/case-clause-1.a68         |  10 ++
 .../algol68/execute/case-clause-2.a68         |   8 +
 .../algol68/execute/case-clause-3.a68         |   7 +
 .../algol68/execute/case-clause-4.a68         |   5 +
 .../algol68/execute/closed-clause-1.a68       |  10 ++
 .../algol68/execute/closed-clause-2.a68       |   9 +
 .../algol68/execute/collateral-clause-1.a68   |   4 +
 .../algol68/execute/collateral-clause-2.a68   |   9 +
 .../algol68/execute/collateral-clause-3.a68   |  11 ++
 .../algol68/execute/collateral-clause-4.a68   |   3 +
 .../algol68/execute/collateral-clause-5.a68   |   5 +
 .../algol68/execute/collateral-clause-6.a68   |   8 +
 gcc/testsuite/algol68/execute/completer-1.a68 |   9 +
 .../algol68/execute/completer-10.a68          |   7 +
 gcc/testsuite/algol68/execute/completer-2.a68 |   7 +
 gcc/testsuite/algol68/execute/completer-3.a68 |   4 +
 gcc/testsuite/algol68/execute/completer-4.a68 |   4 +
 gcc/testsuite/algol68/execute/completer-5.a68 |   5 +
 gcc/testsuite/algol68/execute/completer-6.a68 |   5 +
 gcc/testsuite/algol68/execute/completer-7.a68 |   5 +
 gcc/testsuite/algol68/execute/completer-8.a68 |   5 +
 gcc/testsuite/algol68/execute/completer-9.a68 |   6 +
 .../algol68/execute/cond-clause-1.a68         |   5 +
 .../algol68/execute/cond-clause-2.a68         |   5 +
 .../algol68/execute/cond-clause-3.a68         |   7 +
 .../algol68/execute/cond-clause-4.a68         |   3 +
 .../algol68/execute/cond-clause-5.a68         |   3 +
 .../algol68/execute/cond-clause-6.a68         |  23 +++
 .../algol68/execute/cond-clause-7.a68         |  23 +++
 .../algol68/execute/cond-clause-8.a68         |  20 +++
 .../algol68/execute/cond-clause-9.a68         |  23 +++
 .../algol68/execute/conformity-clause-1.a68   |  10 ++
 .../algol68/execute/conformity-clause-2.a68   |  11 ++
 .../algol68/execute/conformity-clause-3.a68   |  11 ++
 .../algol68/execute/conformity-clause-4.a68   |   7 +
 .../algol68/execute/conformity-clause-5.a68   |  14 ++
 .../algol68/execute/conformity-clause-6.a68   |   8 +
 .../algol68/execute/conformity-clause-7.a68   |   7 +
 .../algol68/execute/conformity-clause-8.a68   |  11 ++
 .../algol68/execute/conformity-clause-9.a68   |  10 ++
 gcc/testsuite/algol68/execute/conj-1.a68      |   9 +
 gcc/testsuite/algol68/execute/cos-1.a68       |   8 +
 gcc/testsuite/algol68/execute/declarer-1.a68  |   9 +
 gcc/testsuite/algol68/execute/declarer-2.a68  |   6 +
 .../algol68/execute/deprocedure-1.a68         |   5 +
 .../algol68/execute/deprocedure-2.a68         |   6 +
 gcc/testsuite/algol68/execute/deref-1.a68     |   5 +
 gcc/testsuite/algol68/execute/deref-2.a68     |   6 +
 gcc/testsuite/algol68/execute/deref-3.a68     |  11 ++
 gcc/testsuite/algol68/execute/deref-4.a68     |   8 +
 gcc/testsuite/algol68/execute/deref-5.a68     |  42 +++++
 gcc/testsuite/algol68/execute/deref-6.a68     |  48 +++++
 gcc/testsuite/algol68/execute/deref-7.a68     |  48 +++++
 gcc/testsuite/algol68/execute/deref-8.a68     |  53 ++++++
 gcc/testsuite/algol68/execute/div-int-1.a68   |   7 +
 .../algol68/execute/divab-real-1.a68          |  11 ++
 gcc/testsuite/algol68/execute/elem-bits-1.a68 |  18 ++
 gcc/testsuite/algol68/execute/elems-1.a68     |   6 +
 gcc/testsuite/algol68/execute/elems-2.a68     |   7 +
 gcc/testsuite/algol68/execute/entier-1.a68    |   8 +
 .../execute/environment-enquiries-1.a68       |  10 ++
 .../execute/environment-enquiries-2.a68       |  12 ++
 .../execute/environment-enquiries-3.a68       |   9 +
 .../execute/environment-enquiries-4.a68       |   7 +
 .../execute/environment-enquiries-5.a68       |   5 +
 .../execute/environment-enquiries-6.a68       |   7 +
 .../execute/environment-enquiries-7.a68       |  15 ++
 .../execute/environment-enquiries-8.a68       |   6 +
 gcc/testsuite/algol68/execute/eq-bits-1.a68   |  10 ++
 .../algol68/execute/eq-char-char-1.a68        |   4 +
 gcc/testsuite/algol68/execute/eq-int-1.a68    |  10 ++
 gcc/testsuite/algol68/execute/eq-string-1.a68 |  16 ++
 .../algol68/execute/eq-string-stride-1.a68    |   6 +
 gcc/testsuite/algol68/execute/execute.exp     |  37 ++++
 gcc/testsuite/algol68/execute/factorial-1.a68 | 170 ++++++++++++++++++
 .../algol68/execute/flat-assignation-1.a68    |   7 +
 .../algol68/execute/flat-assignation-2.a68    |   8 +
 gcc/testsuite/algol68/execute/flex-1.a68      |   5 +
 gcc/testsuite/algol68/execute/flex-2.a68      |   8 +
 gcc/testsuite/algol68/execute/flex-3.a68      |   7 +
 gcc/testsuite/algol68/execute/flex-4.a68      |   6 +
 gcc/testsuite/algol68/execute/flex-5.a68      |  12 ++
 gcc/testsuite/algol68/execute/formula-1.a68   |   9 +
 gcc/testsuite/algol68/execute/formula-2.a68   |   7 +
 gcc/testsuite/algol68/execute/fsize-1.a68     |   2 +
 gcc/testsuite/algol68/execute/ge-int-1.a68    |  10 ++
 .../algol68/execute/ge-string-stride-1.a68    |   7 +
 gcc/testsuite/algol68/execute/gen-flex-1.a68  |  10 ++
 gcc/testsuite/algol68/execute/gen-heap-1.a68  |   6 +
 gcc/testsuite/algol68/execute/gen-heap-2.a68  |   6 +
 gcc/testsuite/algol68/execute/gen-heap-3.a68  |   5 +
 .../algol68/execute/gen-heap-bool-1.a68       |   6 +
 .../algol68/execute/gen-heap-int-1.a68        |   4 +
 .../algol68/execute/gen-heap-real-1.a68       |   4 +
 .../algol68/execute/gen-heap-struct-1.a68     |   4 +
 .../algol68/execute/gen-heap-struct-2.a68     |   5 +
 .../algol68/execute/gen-heap-struct-3.a68     |   5 +
 gcc/testsuite/algol68/execute/gen-loc-1.a68   |   6 +
 gcc/testsuite/algol68/execute/gen-loc-2.a68   |   6 +
 gcc/testsuite/algol68/execute/gen-loc-3.a68   |   5 +
 gcc/testsuite/algol68/execute/gen-loc-4.a68   |   8 +
 .../algol68/execute/gen-multiple-1.a68        |   5 +
 gcc/testsuite/algol68/execute/gen-union-1.a68 |  17 ++
 gcc/testsuite/algol68/execute/gen-union-2.a68 |  20 +++
 gcc/testsuite/algol68/execute/gen-union-3.a68 |  14 ++
 gcc/testsuite/algol68/execute/goto-1.a68      |   7 +
 gcc/testsuite/algol68/execute/goto-2.a68      |   5 +
 gcc/testsuite/algol68/execute/goto-3.a68      |   9 +
 gcc/testsuite/algol68/execute/goto-4.a68      |   9 +
 gcc/testsuite/algol68/execute/goto-5.a68      |  20 +++
 gcc/testsuite/algol68/execute/gt-int-1.a68    |  10 ++
 .../algol68/execute/gt-string-stride-1.a68    |   7 +
 gcc/testsuite/algol68/execute/i-1.a68         |   6 +
 gcc/testsuite/algol68/execute/i-2.a68         |   6 +
 .../algol68/execute/identification-1.a68      |   6 +
 .../algol68/execute/identification-2.a68      |  14 ++
 .../execute/identity-declaration-1.a68        |   6 +
 .../execute/identity-declaration-2.a68        |   6 +
 .../execute/identity-declaration-3.a68        |   6 +
 .../execute/identity-declaration-4.a68        |   5 +
 .../execute/identity-declaration-5.a68        |   5 +
 .../identity-declaration-multiple-1.a68       |   4 +
 .../identity-declaration-multiple-2.a68       |   4 +
 .../identity-declaration-multiple-3.a68       |   6 +
 .../identity-declaration-multiple-5.a68       |   4 +
 .../identity-declaration-multiple-empty-1.a68 |   6 +
 .../identity-declaration-multiple-empty-2.a68 |  12 ++
 .../identity-declaration-multiple-empty-3.a68 |   4 +
 .../identity-declaration-multiple-empty-4.a68 |   4 +
 .../execute/identity-declaration-struct-1.a68 |  10 ++
 gcc/testsuite/algol68/execute/infinity-1.a68  |   4 +
 .../algol68/execute/le-ge-bits-1.a68          |  17 ++
 gcc/testsuite/algol68/execute/le-int-1.a68    |  10 ++
 .../algol68/execute/le-string-stride-1.a68    |   7 +
 .../algol68/execute/leng-shorten-bits-1.a68   |   7 +
 .../algol68/execute/leng-shorten-ints-1.a68   |  27 +++
 .../algol68/execute/leng-shorten-reals-1.a68  |  17 ++
 .../algol68/execute/lengths-shorths-1.a68     |   8 +
 gcc/testsuite/algol68/execute/lisp-1.a68      |  25 +++
 gcc/testsuite/algol68/execute/lisp-2.a68      |  21 +++
 gcc/testsuite/algol68/execute/ln-1.a68        |   8 +
 gcc/testsuite/algol68/execute/log-1.a68       |   8 +
 gcc/testsuite/algol68/execute/loop-1.a68      |   6 +
 gcc/testsuite/algol68/execute/loop-10.a68     |   5 +
 gcc/testsuite/algol68/execute/loop-11.a68     |   6 +
 gcc/testsuite/algol68/execute/loop-12.a68     |   5 +
 gcc/testsuite/algol68/execute/loop-13.a68     |   6 +
 gcc/testsuite/algol68/execute/loop-14.a68     |   7 +
 gcc/testsuite/algol68/execute/loop-2.a68      |   7 +
 gcc/testsuite/algol68/execute/loop-3.a68      |  14 ++
 gcc/testsuite/algol68/execute/loop-4.a68      |  13 ++
 gcc/testsuite/algol68/execute/loop-5.a68      |   7 +
 gcc/testsuite/algol68/execute/loop-6.a68      |   7 +
 185 files changed, 1893 insertions(+)
 create mode 100644 gcc/testsuite/algol68/execute/abs-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-bool-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-int-negative-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/abs-int-negative-gnu-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/acos-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/affirm-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/and-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/andf-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ascription-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/asin-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assert-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-int-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-multiple-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-struct-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/assignation-struct-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/atan-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/balancing-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/balancing-rows-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/bin-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/bin-negative-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/bin-negative-gnu-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/boolops-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/call-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/call-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/case-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/case-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/case-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/case-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/closed-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/closed-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/collateral-clause-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/completer-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/cond-clause-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/conformity-clause-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/conj-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/cos-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/declarer-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/declarer-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/deprocedure-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/deprocedure-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/deref-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/div-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/divab-real-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/elem-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/elems-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/elems-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/entier-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/environment-enquiries-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-char-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/eq-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/execute.exp
 create mode 100644 gcc/testsuite/algol68/execute/factorial-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/flat-assignation-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/flat-assignation-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/flex-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/formula-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/formula-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/fsize-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ge-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ge-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-flex-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-bool-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-real-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-struct-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-struct-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-heap-struct-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-loc-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-loc-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-loc-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-loc-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-union-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-union-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/gen-union-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/goto-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/gt-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/gt-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/i-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/i-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identification-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/identification-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/identity-declaration-struct-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/infinity-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/le-ge-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/le-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/le-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/leng-shorten-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/leng-shorten-ints-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/leng-shorten-reals-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lengths-shorths-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lisp-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lisp-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/ln-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/log-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-11.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-12.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-13.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-14.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-6.a68

diff --git a/gcc/testsuite/algol68/execute/abs-bits-1.a68 b/gcc/testsuite/algol68/execute/abs-bits-1.a68
new file mode 100644
index 00000000000..bdb3a1bef52
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/abs-bits-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# ABS for SIZETY BITS #
+BEGIN ASSERT (255 = ABS 16rff);
+      ASSERT (LONG 255 = ABS LONG 16rff);
+      ASSERT (LONG LONG 255 = ABS LONG LONG 16rff)
+      # XXX test ABS of negative numbers (extension).  #
+END
diff --git a/gcc/testsuite/algol68/execute/abs-bool-1.a68 b/gcc/testsuite/algol68/execute/abs-bool-1.a68
new file mode 100644
index 00000000000..90ea0d685a3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/abs-bool-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (ABS TRUE /= 0);
+      ASSERT (ABS FALSE = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/abs-char-1.a68 b/gcc/testsuite/algol68/execute/abs-char-1.a68
new file mode 100644
index 00000000000..124fb3d473f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/abs-char-1.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (ABS "a" = 97)
+END
diff --git a/gcc/testsuite/algol68/execute/abs-int-1.a68 b/gcc/testsuite/algol68/execute/abs-int-1.a68
new file mode 100644
index 00000000000..fa8125a1587
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/abs-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (ABS 10 = 10);
+      ASSERT (ABS -10 = 10);
+      ASSERT (ABS SHORT 10 = SHORT 10);
+      ASSERT (ABS - SHORT 10 = SHORT 10);
+      ASSERT (ABS - SHORT SHORT 10 = SHORT SHORT 10);
+      ASSERT (ABS LONG 10 = LONG 10);
+      ASSERT (ABS - LONG 10 = LONG 10);
+      ASSERT (ABS - LONG LONG 10 = LONG LONG 10)
+END
diff --git a/gcc/testsuite/algol68/execute/abs-int-negative-1.a68 b/gcc/testsuite/algol68/execute/abs-int-negative-1.a68
new file mode 100644
index 00000000000..77973ad220f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/abs-int-negative-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper -std=algol68" }  #
+BEGIN SHORT SHORT BITS b = BIN - SHORT SHORT 2;
+      ASSERT (ABS b = SHORT SHORT INT (SKIP))
+END
diff --git a/gcc/testsuite/algol68/execute/abs-int-negative-gnu-1.a68 b/gcc/testsuite/algol68/execute/abs-int-negative-gnu-1.a68
new file mode 100644
index 00000000000..4afe25679e0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/abs-int-negative-gnu-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper -std=gnu68" }  #
+BEGIN SHORT SHORT BITS b = BIN - SHORT SHORT 2;
+      ASSERT (ABS b = - SHORT SHORT 2)
+END
diff --git a/gcc/testsuite/algol68/execute/acos-1.a68 b/gcc/testsuite/algol68/execute/acos-1.a68
new file mode 100644
index 00000000000..6a985cc8a23
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/acos-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r = 1.0;
+      LONG REAL rr = LONG 45.0;
+      LONG LONG REAL rrr = LONG LONG 60.0;
+      ASSERT (arccos (r) = 0.0);
+      long arccos (rr);
+      long long arccos (rrr)
+END
diff --git a/gcc/testsuite/algol68/execute/affirm-int-1.a68 b/gcc/testsuite/algol68/execute/affirm-int-1.a68
new file mode 100644
index 00000000000..4cd065fa235
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/affirm-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+      SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10;
+      ASSERT (+i = 10);
+      ASSERT (+ii  = LONG 10);
+      ASSERT (+iii = LONG LONG 10);
+      ASSERT (+ss  = SHORT 10);
+      ASSERT (+sss = SHORT SHORT 10)
+END
diff --git a/gcc/testsuite/algol68/execute/and-bits-1.a68 b/gcc/testsuite/algol68/execute/and-bits-1.a68
new file mode 100644
index 00000000000..e6530bcdfb0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/and-bits-1.a68
@@ -0,0 +1,18 @@
+# { dg-options "-fstropping=upper" }  #
+# AND for SIZETY BITS.  #
+BEGIN BITS b = 16r0f0f0;
+      ASSERT ((b AND 16r0f0f) = 16r0);
+      ASSERT ((b AND 16r00ff) = 16rf0);
+      LONG BITS bb = LONG 16r0f0f0;
+      ASSERT ((bb AND LONG 16r0f0f) = LONG 16r0);
+      ASSERT ((bb AND LONG 16r00ff) = LONG 16rf0);
+      LONG LONG BITS bbb = LONG LONG 16r0f0f0;
+      ASSERT ((bbb AND LONG LONG 16r0f0f) = LONG LONG 16r0);
+      ASSERT ((bbb AND LONG LONG 16r00ff) = LONG LONG 16rf0);
+      SHORT BITS ss = SHORT 16r0f0f0;
+      ASSERT ((ss AND SHORT 16r0f0f) = SHORT 16r0);
+      ASSERT ((ss AND SHORT 16r00ff) = SHORT 16rf0);
+      SHORT SHORT BITS sss = SHORT SHORT 16r0f0f0;
+      ASSERT ((sss AND SHORT SHORT 16r0f0f) = SHORT SHORT 16r0);
+      ASSERT ((sss AND SHORT SHORT 16r00ff) = SHORT SHORT 16rf0)
+END
diff --git a/gcc/testsuite/algol68/execute/andf-1.a68 b/gcc/testsuite/algol68/execute/andf-1.a68
new file mode 100644
index 00000000000..72667a653bd
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/andf-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10;
+      ASSERT (i /= 0 ANDTH i = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/ascription-1.a68 b/gcc/testsuite/algol68/execute/ascription-1.a68
new file mode 100644
index 00000000000..f6744e322f9
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/ascription-1.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+# Make sure structs are copied when ascribed.  #
+BEGIN MODE BAR = STRUCT (INT j, REAL r);
+      MODE FOO = STRUCT (INT i, BAR bar);
+
+      FOO f1 := (10, (20, 3.14));
+      FOO f2 = f1;
+
+      j OF bar OF f1 := 200;
+      ASSERT (j OF bar OF f1 = 200);
+      ASSERT (j OF bar OF f2 = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/asin-1.a68 b/gcc/testsuite/algol68/execute/asin-1.a68
new file mode 100644
index 00000000000..114518edfa2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/asin-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r = 0.0;
+      LONG REAL rr = LONG 45.0;
+      LONG LONG REAL rrr = LONG LONG 60.0;
+      ASSERT (arcsin (r) = 0.0);
+      long arcsin (rr);
+      long long arcsin (rrr)
+END
diff --git a/gcc/testsuite/algol68/execute/assert-1.a68 b/gcc/testsuite/algol68/execute/assert-1.a68
new file mode 100644
index 00000000000..2ed6ea40e7e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assert-1.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (TRUE)
+END
diff --git a/gcc/testsuite/algol68/execute/assignation-char-1.a68 b/gcc/testsuite/algol68/execute/assignation-char-1.a68
new file mode 100644
index 00000000000..5558ccc140d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-char-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN CHAR c;
+      c := "x";
+      ASSERT (c = "x")
+END
diff --git a/gcc/testsuite/algol68/execute/assignation-int-1.a68 b/gcc/testsuite/algol68/execute/assignation-int-1.a68
new file mode 100644
index 00000000000..139d7436ebd
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-int-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i;
+      i := 20;
+      ASSERT (i = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/assignation-int-2.a68 b/gcc/testsuite/algol68/execute/assignation-int-2.a68
new file mode 100644
index 00000000000..cfd38407631
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-int-2.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN x := 100;
+      INT x;
+      ASSERT (x = 100)
+END
diff --git a/gcc/testsuite/algol68/execute/assignation-int-3.a68 b/gcc/testsuite/algol68/execute/assignation-int-3.a68
new file mode 100644
index 00000000000..9b60f7e0a36
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-int-3.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REF INT j = LOC INT;
+      INT i;
+      i := j := 20;
+      ASSERT (i + j = 40)
+END
diff --git a/gcc/testsuite/algol68/execute/assignation-int-4.a68 b/gcc/testsuite/algol68/execute/assignation-int-4.a68
new file mode 100644
index 00000000000..2aeb35b1147
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-int-4.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REF INT xx;
+      INT x := 10;
+      ASSERT ((xx := (x)) = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/assignation-int-5.a68 b/gcc/testsuite/algol68/execute/assignation-int-5.a68
new file mode 100644
index 00000000000..2b67b21fae2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-int-5.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx := x;
+      x := 20;
+      ASSERT ((xx := (INT j; x)) = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/assignation-multiple-1.a68 b/gcc/testsuite/algol68/execute/assignation-multiple-1.a68
new file mode 100644
index 00000000000..cf8d78020ef
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-multiple-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRUCT ([2:3]INT m, [1:5]REAL g) s;
+      g OF s:= (1.0, 2.0, 3.0, 4.0, 5.0)
+END
diff --git a/gcc/testsuite/algol68/execute/assignation-multiple-2.a68 b/gcc/testsuite/algol68/execute/assignation-multiple-2.a68
new file mode 100644
index 00000000000..22ff7e11942
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-multiple-2.a68
@@ -0,0 +1,15 @@
+begin [5]struct(char i, real r) foo;
+
+      { The stride in the single dimension of the multiple resulting
+        from the selection is not the size of a 'char'.  }
+      i of foo := ("a","b","c","d","e");
+      puts ((i of foo) + "'n");
+      { Via indexing then selection.  }
+      assert (i of foo[1] = "a");
+      assert (i of foo[2] = "b");
+      assert (i of foo[3] = "c");
+      assert (i of foo[4] = "d");
+      assert (i of foo[5] = "e");
+      { Via selection of multiple.  }
+      assert (i of foo = "abcde");
+end
diff --git a/gcc/testsuite/algol68/execute/assignation-struct-1.a68 b/gcc/testsuite/algol68/execute/assignation-struct-1.a68
new file mode 100644
index 00000000000..a2d661b1837
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-struct-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE NODE = STRUCT (INT one, two, three);
+      NODE top;
+      top := (10,20,30);
+      ASSERT (two OF top = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/assignation-struct-2.a68 b/gcc/testsuite/algol68/execute/assignation-struct-2.a68
new file mode 100644
index 00000000000..61734cc0db6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/assignation-struct-2.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Struct containing a multiple, which must be copied when
+  the struct value is assigned.  #
+BEGIN MODE FOO = STRUCT (STRING s, INT i);
+      FOO f1;
+      f1 := ("foo", 10);
+      ASSERT (i OF f1 = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/atan-1.a68 b/gcc/testsuite/algol68/execute/atan-1.a68
new file mode 100644
index 00000000000..bc710c5cdfd
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/atan-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r = 0.0;
+      LONG REAL rr = LONG 45.0;
+      LONG LONG REAL rrr = LONG LONG 60.0;
+      ASSERT (arctan (r) = 0.0);
+      long arctan (rr);
+      long long arctan (rrr)
+END
diff --git a/gcc/testsuite/algol68/execute/balancing-1.a68 b/gcc/testsuite/algol68/execute/balancing-1.a68
new file mode 100644
index 00000000000..418b0e4efb9
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/balancing-1.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL x, y;
+      REF REAL xx, yy;
+      xx := yy := x;
+
+      ASSERT (xx :=: x);
+      ASSERT (x :=: xx);
+      ASSERT (xx :/=: yy);
+      ASSERT (REF REAL (xx) :=: yy);
+      ASSERT (xx :=: REF REAL (yy));
+      ASSERT (REF REAL (xx) :=: REF REAL (yy))
+END
diff --git a/gcc/testsuite/algol68/execute/balancing-rows-1.a68 b/gcc/testsuite/algol68/execute/balancing-rows-1.a68
new file mode 100644
index 00000000000..1f69d47259a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/balancing-rows-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (UPB IF FALSE THEN []INT (1) ELSE [,]REAL (1) FI = 1);
+      ASSERT (2 UPB CASE 2 IN []INT (1), [,]REAL (1) ESAC = 1)
+END
diff --git a/gcc/testsuite/algol68/execute/bin-1.a68 b/gcc/testsuite/algol68/execute/bin-1.a68
new file mode 100644
index 00000000000..4fb095fb5dd
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/bin-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# BIN for SIZETY INTs #
+BEGIN ASSERT (BIN 255 = 16rff);
+      ASSERT (BIN LONG 255 = LONG 16rff);
+      ASSERT (BIN LONG LONG 255 = LONG LONG 16rff)
+END
diff --git a/gcc/testsuite/algol68/execute/bin-negative-1.a68 b/gcc/testsuite/algol68/execute/bin-negative-1.a68
new file mode 100644
index 00000000000..97c2cf000c3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/bin-negative-1.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper -std=algol68" }  #
+BEGIN ASSERT (BIN - SHORT SHORT 2 = SHORT SHORT 2r0)
+END
diff --git a/gcc/testsuite/algol68/execute/bin-negative-gnu-1.a68 b/gcc/testsuite/algol68/execute/bin-negative-gnu-1.a68
new file mode 100644
index 00000000000..41d95533f3c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/bin-negative-gnu-1.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper -std=gnu68" }  #
+BEGIN ASSERT (BIN - SHORT SHORT 2 = SHORT SHORT 2r11111110)
+END
diff --git a/gcc/testsuite/algol68/execute/boolops-1.a68 b/gcc/testsuite/algol68/execute/boolops-1.a68
new file mode 100644
index 00000000000..82600fc2f9a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/boolops-1.a68
@@ -0,0 +1,18 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BOOL t := TRUE;
+      BOOL f := FALSE;
+      ASSERT (NOT t = FALSE);
+      ASSERT (~t = FALSE);
+      ASSERT ((t AND t) = TRUE);
+      ASSERT ((t AND f) = FALSE);
+      ASSERT ((f AND f) = FALSE);
+      ASSERT ((f AND t) = FALSE);
+      ASSERT ((t OR t) = TRUE);
+      ASSERT ((t OR f) = TRUE);
+      ASSERT ((f OR f) = FALSE);
+      ASSERT ((f OR t) = TRUE);
+      ASSERT ((t XOR t) = FALSE);
+      ASSERT ((t XOR f) = TRUE);
+      ASSERT ((f XOR f) = FALSE);
+      ASSERT ((f XOR t) = TRUE)
+END
diff --git a/gcc/testsuite/algol68/execute/call-1.a68 b/gcc/testsuite/algol68/execute/call-1.a68
new file mode 100644
index 00000000000..f77113dcc46
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/call-1.a68
@@ -0,0 +1,19 @@
+# { dg-options "-fstropping=upper" }  #
+# Calling a procedure that gets a row of united values.  #
+BEGIN INT num ints := 0, num reals := 0, num strings := 0;
+      PROC foo = ([]UNION(INT,REAL,STRING) d) VOID:
+      BEGIN FOR i TO UPB d
+            DO CASE d[i]
+               IN (STRING): num strings +:= 1,
+                  (INT): num ints +:= 1,
+                  (REAL): num reals +:= 1
+               ESAC
+            OD
+      END;
+      foo (());
+      foo (10);
+      ASSERT (num ints = 1 AND num reals = 0 AND num strings = 0);
+      num ints := 0;
+      foo (("baz", 1, 3.14, 2, 0.0, "foo"));
+      ASSERT (num ints = 2 AND num reals = 2 AND num strings = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/call-2.a68 b/gcc/testsuite/algol68/execute/call-2.a68
new file mode 100644
index 00000000000..21a6b252028
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/call-2.a68
@@ -0,0 +1,21 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT control := 0;
+      PROC set control = (PROC(INT)VOID p) VOID: p (100);
+      PROC setter = (INT i) VOID: control := i;
+      PROC(INT)VOID setter 2 = (INT i) VOID: control := i + 1;
+      PROC(INT)VOID setter 3 := setter 2;
+      PROC(INT)VOID setter 4 := (INT i) VOID: control := i + 2;
+      REF PROC(INT)VOID setter 5 := setter 4;
+      set control (setter);
+      ASSERT (control = 100);
+      set control (setter 2);
+      ASSERT (control = 101);
+      control := 0;
+      set control (setter 3);
+      ASSERT (control = 101);
+      set control (setter 4);
+      ASSERT (control = 102);
+      control := 0;
+      set control (setter 5);
+      ASSERT (control = 102)
+END
diff --git a/gcc/testsuite/algol68/execute/case-clause-1.a68 b/gcc/testsuite/algol68/execute/case-clause-1.a68
new file mode 100644
index 00000000000..71566edf915
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/case-clause-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT j := 1;
+      ASSERT ((j|10,20,30|40) = 10);
+      j := 2;
+      ASSERT ((j|10,20,30|40) = 20);
+      j := 3;
+      ASSERT ((j|10,20,30|40) = 30);
+      j := 100;
+      ASSERT ((j|10,20,30|40) = 40)
+END
diff --git a/gcc/testsuite/algol68/execute/case-clause-2.a68 b/gcc/testsuite/algol68/execute/case-clause-2.a68
new file mode 100644
index 00000000000..971bdb56207
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/case-clause-2.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 2;
+      ASSERT (CASE INT x = 10; i
+              IN x + 1,
+                 x + 2,
+                 x + 3
+              ESAC = 12)
+END
diff --git a/gcc/testsuite/algol68/execute/case-clause-3.a68 b/gcc/testsuite/algol68/execute/case-clause-3.a68
new file mode 100644
index 00000000000..3355cefc080
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/case-clause-3.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT days, INT month = 2, year = 2024;
+      days := CASE month
+              IN 31, (year MOD 4 = 0 AND year MOD 100 /= 0 OR year MOD 400 = 0 | 29 | 28),
+                 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ESAC;
+      ASSERT (days = 29)
+END
diff --git a/gcc/testsuite/algol68/execute/case-clause-4.a68 b/gcc/testsuite/algol68/execute/case-clause-4.a68
new file mode 100644
index 00000000000..cd69069fa84
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/case-clause-4.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT day = 3;
+      STRING day name = (day | "MONDAY", "TUESDAY", "WEDNESDAY", "THURSDAY", "FRIDAY", "SATURDAY", "SUNDAY");
+      ASSERT (day name[1] = "W")
+END
diff --git a/gcc/testsuite/algol68/execute/closed-clause-1.a68 b/gcc/testsuite/algol68/execute/closed-clause-1.a68
new file mode 100644
index 00000000000..d7602e1ae86
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/closed-clause-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL pie, my small real := 0.001;
+      PROC my sqrt = (REAL r) REAL: r;
+      BEGIN REAL w := 0, INT i := 1, REAL z = my sqrt (my small real / 2);
+      loop: w := w + 2 / (i * (i + 2));
+            i := i + 4;
+            IF 1/i > z THEN GO TO loop FI;
+            pie := 4 * w
+      END
+END
diff --git a/gcc/testsuite/algol68/execute/closed-clause-2.a68 b/gcc/testsuite/algol68/execute/closed-clause-2.a68
new file mode 100644
index 00000000000..c6acec88ebd
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/closed-clause-2.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL my small real := 0.001;
+      PROC my sqrt = (REAL r) REAL: r;
+      REAL res = 4 * (REAL w := 0, INT i := 1; REAL z = my sqrt (my small real / 2);
+                      loop: w := w + 2/(i * (i + 2)); i := i + 4;
+                      IF 1/i > z THEN loop FI;
+                      w);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/collateral-clause-1.a68 b/gcc/testsuite/algol68/execute/collateral-clause-1.a68
new file mode 100644
index 00000000000..d467a424aa2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/collateral-clause-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10;
+      (i, i + 1, i + 2)
+END
diff --git a/gcc/testsuite/algol68/execute/collateral-clause-2.a68 b/gcc/testsuite/algol68/execute/collateral-clause-2.a68
new file mode 100644
index 00000000000..8d9aa6eeb74
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/collateral-clause-2.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10;
+      (
+         BEGIN
+            (i + 1, i +:= 1, i + 2)
+         END
+      );
+      ASSERT (i = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/collateral-clause-3.a68 b/gcc/testsuite/algol68/execute/collateral-clause-3.a68
new file mode 100644
index 00000000000..9af00e7c2db
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/collateral-clause-3.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10;
+      (
+         i +:= 1;
+         BEGIN
+            (i + 1, (i +:= 1, i + 10, i + 11, SKIP), i + 2)
+         END;
+         i +:= i
+      );
+      ASSERT (i = 24)
+END
diff --git a/gcc/testsuite/algol68/execute/collateral-clause-4.a68 b/gcc/testsuite/algol68/execute/collateral-clause-4.a68
new file mode 100644
index 00000000000..2e64fb1787e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/collateral-clause-4.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN (SKIP,SKIP)
+END
diff --git a/gcc/testsuite/algol68/execute/collateral-clause-5.a68 b/gcc/testsuite/algol68/execute/collateral-clause-5.a68
new file mode 100644
index 00000000000..c1375a96677
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/collateral-clause-5.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x, y, z;
+      (x := 1, y := 2, z := 3);
+      ASSERT (x = 1 AND y = 2 AND z = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/collateral-clause-6.a68 b/gcc/testsuite/algol68/execute/collateral-clause-6.a68
new file mode 100644
index 00000000000..57599afb20e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/collateral-clause-6.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i;
+      PROC side = INT: (i := 1; i := 2; i);
+      PROC add = (INT ii, INT jj) INT: ii + jj;
+      INT res = add (side, side);
+      # can be 3 or 4 due to collateral evaluation of arguments.  #
+      ASSERT (res = 3 OR res = 4)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-1.a68 b/gcc/testsuite/algol68/execute/completer-1.a68
new file mode 100644
index 00000000000..e3b488a7dd0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i;
+      BEGIN (i := 20 EXIT
+cont:        i := 30
+            );
+            i +:= 1
+      END;
+      ASSERT (i = 21)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-10.a68 b/gcc/testsuite/algol68/execute/completer-10.a68
new file mode 100644
index 00000000000..18d4f937cf3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-10.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 20;
+      REF INT xx := x;
+      REF REF INT xxx;
+      REF INT i := (x := 10; xxx := xx EXIT foo: xxx EXIT bar: xxx := xx);
+      ASSERT (i = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-2.a68 b/gcc/testsuite/algol68/execute/completer-2.a68
new file mode 100644
index 00000000000..fac329ab4bf
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-2.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = (foo;
+               10 EXIT
+foo:           20 EXIT
+bar:           30);
+      ASSERT (i = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-3.a68 b/gcc/testsuite/algol68/execute/completer-3.a68
new file mode 100644
index 00000000000..6514f2ddc60
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-3.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = ((((foo; 10 EXIT foo: 20 EXIT bar: 30))));
+      ASSERT (i = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-4.a68 b/gcc/testsuite/algol68/execute/completer-4.a68
new file mode 100644
index 00000000000..1291e733d73
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-4.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := (foo; 10 EXIT foo: 20 EXIT bar: 30);
+      ASSERT (i = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-5.a68 b/gcc/testsuite/algol68/execute/completer-5.a68
new file mode 100644
index 00000000000..f6bc6f42719
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-5.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x;
+      REF INT i := (foo; x := 10 EXIT foo: x := 20 EXIT bar: x := 30);
+      ASSERT (i = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-6.a68 b/gcc/testsuite/algol68/execute/completer-6.a68
new file mode 100644
index 00000000000..aaf512f4bab
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-6.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 20;
+      REF INT i := (foo; x := 10 EXIT foo: x EXIT bar: x := 30);
+      ASSERT (i = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-7.a68 b/gcc/testsuite/algol68/execute/completer-7.a68
new file mode 100644
index 00000000000..9ef0e27f674
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-7.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 20;
+      REF INT i := (x := 10 EXIT foo: x EXIT bar: x := 30);
+      ASSERT (i = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-8.a68 b/gcc/testsuite/algol68/execute/completer-8.a68
new file mode 100644
index 00000000000..b73fd13f4c3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-8.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 20;
+      REF INT i := (x EXIT foo: x EXIT bar: x := 30);
+      ASSERT (i = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/completer-9.a68 b/gcc/testsuite/algol68/execute/completer-9.a68
new file mode 100644
index 00000000000..b84f0103981
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/completer-9.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 20;
+      REF INT xx := x;
+      REF INT i := (xx EXIT foo: xx EXIT bar: xx := x);
+      ASSERT (i = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/cond-clause-1.a68 b/gcc/testsuite/algol68/execute/cond-clause-1.a68
new file mode 100644
index 00000000000..059bb8a6117
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cond-clause-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10, x;
+      IF i > 5 THEN x := i FI;
+      ASSERT (x = i)
+END
diff --git a/gcc/testsuite/algol68/execute/cond-clause-2.a68 b/gcc/testsuite/algol68/execute/cond-clause-2.a68
new file mode 100644
index 00000000000..f8e5d5f0371
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cond-clause-2.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10, x;
+      IF i < 5 THEN x = i FI;
+      ASSERT (x /= i)
+END
diff --git a/gcc/testsuite/algol68/execute/cond-clause-3.a68 b/gcc/testsuite/algol68/execute/cond-clause-3.a68
new file mode 100644
index 00000000000..4e9c685c55f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cond-clause-3.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 5;
+      IF i = 5
+      THEN 0
+      ELSE ASSERT (FALSE); 1
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/cond-clause-4.a68 b/gcc/testsuite/algol68/execute/cond-clause-4.a68
new file mode 100644
index 00000000000..0e650414fb0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cond-clause-4.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+# Declarations in enquiry clause.  #
+(INT i; i := 3 ; i := 2; i /= i | ASSERT (FALSE); 1 | 0)
diff --git a/gcc/testsuite/algol68/execute/cond-clause-5.a68 b/gcc/testsuite/algol68/execute/cond-clause-5.a68
new file mode 100644
index 00000000000..2164c75dc81
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cond-clause-5.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+# Closed clauses in enquiry clause.  #
+((INT i; (i := 3 ; i := 2); ((i /= i))) | ASSERT (FALSE); 1 | 0)
diff --git a/gcc/testsuite/algol68/execute/cond-clause-6.a68 b/gcc/testsuite/algol68/execute/cond-clause-6.a68
new file mode 100644
index 00000000000..39b4bda31a1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cond-clause-6.a68
@@ -0,0 +1,23 @@
+# { dg-options "-fstropping=upper" }  #
+# Nested conditional clauses  #
+BEGIN
+   INT i = 10;
+   IF i > 5 THEN
+      IF i < 15 THEN
+         IF i > 11 THEN
+            ASSERT (FALSE);
+            1
+         ELSE
+            0
+         FI
+      FI
+   ELSE
+      IF i > 100 THEN
+         ASSERT (FALSE);
+         1
+      ELSE
+         ASSERT (FALSE);
+         1
+      FI
+   FI
+END
diff --git a/gcc/testsuite/algol68/execute/cond-clause-7.a68 b/gcc/testsuite/algol68/execute/cond-clause-7.a68
new file mode 100644
index 00000000000..3a5af2bdbb0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cond-clause-7.a68
@@ -0,0 +1,23 @@
+# { dg-options "-fstropping=upper" }  #
+# Nested conditional clauses  #
+BEGIN
+   INT i = 12;
+   IF i > 5 THEN
+      IF i < 15 THEN
+         IF i > 11 THEN
+            0
+         ELSE
+            ASSERT (FALSE);
+            1
+         FI
+      FI
+   ELSE
+      IF i > 100 THEN
+         ASSERT (FALSE);
+         1
+      ELSE
+         ASSERT (FALSE);
+         1
+      FI
+   FI
+END
diff --git a/gcc/testsuite/algol68/execute/cond-clause-8.a68 b/gcc/testsuite/algol68/execute/cond-clause-8.a68
new file mode 100644
index 00000000000..0b3ca04fccb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cond-clause-8.a68
@@ -0,0 +1,20 @@
+# { dg-options "-fstropping=upper" }  #
+# ELIF  #
+BEGIN
+   INT i = 12;
+   IF i > 20 THEN
+      1
+   ELIF i > 5 THEN
+      BEGIN
+         IF FALSE THEN
+            ASSERT (FALSE);
+            1
+         ELSE
+            0
+         FI
+      END
+   ELIF i < 10 THEN
+      ASSERT (FALSE);
+      1
+   FI
+END
diff --git a/gcc/testsuite/algol68/execute/cond-clause-9.a68 b/gcc/testsuite/algol68/execute/cond-clause-9.a68
new file mode 100644
index 00000000000..d0f70e88302
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cond-clause-9.a68
@@ -0,0 +1,23 @@
+# { dg-options "-fstropping=upper" }  #
+# ELIF with ELSE #
+BEGIN
+   INT i = 12;
+   IF i > 20 THEN
+      1
+   ELIF i > 12 THEN
+      BEGIN
+         IF FALSE THEN
+            ASSERT (FALSE);
+            1
+         ELSE
+            ASSERT (FALSE);
+            1
+         FI
+      END
+   ELIF i < 10 THEN
+      ASSERT (FALSE);
+      1
+   ELSE
+      0
+   FI
+END
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-1.a68 b/gcc/testsuite/algol68/execute/conformity-clause-1.a68
new file mode 100644
index 00000000000..d34b7cfeabf
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE DATUM = UNION(INT,REAL,CHAR);
+      DATUM datum := 10;
+      INT i = CASE datum
+              IN (REAL): 2,
+                 (INT i): i + 1,
+                 (CHAR): 3
+              ESAC;
+      ASSERT (i = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-2.a68 b/gcc/testsuite/algol68/execute/conformity-clause-2.a68
new file mode 100644
index 00000000000..bfa28bba3d7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-2.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE DATUM = UNION(INT,REAL,CHAR);
+      DATUM datum := "X";
+      INT i = CASE datum
+              IN (REAL): 2,
+                 (INT val): val + 1
+              OUT INT x = 100;
+                  x + 10
+              ESAC;
+      ASSERT (i = 110)
+END
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-3.a68 b/gcc/testsuite/algol68/execute/conformity-clause-3.a68
new file mode 100644
index 00000000000..d0703de0c8c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-3.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE DATUM = UNION(INT,REAL,CHAR);
+      DATUM datum := 20;
+      INT i = CASE INT i = 10; datum
+              IN (REAL): 2,
+                 (INT val): val + i
+              OUT INT x = 100;
+                  x + 10
+              ESAC;
+      ASSERT (i = 30)
+END
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-4.a68 b/gcc/testsuite/algol68/execute/conformity-clause-4.a68
new file mode 100644
index 00000000000..2cac20d5083
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-4.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []UNION(INT,STRING,REAL) datum = (10, 3.14, "foo", 200);
+      ASSERT (CASE datum[1] IN (INT): 100 ESAC = 100);
+      ASSERT (CASE datum[2] IN (REAL): 200 ESAC = 200);
+      ASSERT (CASE datum[3] IN (STRING): 300 ESAC = 300);
+      ASSERT (CASE datum[4] IN (INT): 400 ESAC = 400)
+END
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-5.a68 b/gcc/testsuite/algol68/execute/conformity-clause-5.a68
new file mode 100644
index 00000000000..eb6f41ea22e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-5.a68
@@ -0,0 +1,14 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN UNION(CHAR,BOOL,INT,REAL) cbira := "X";
+      IF CASE cbira
+         IN (BOOL b): b,
+            (INT i): i > 0,
+            (REAL r): r > 0
+         OUT FALSE
+         ESAC
+      THEN # We get here if cbira was not a CHAR and was otherwise
+             TRUE or >0, as the case may be.
+           #
+         ASSERT (FALSE)
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-6.a68 b/gcc/testsuite/algol68/execute/conformity-clause-6.a68
new file mode 100644
index 00000000000..b3d3d6cf329
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-6.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN UNION (CHAR,BOOL,REAL) cbra = 3.14, UNION (INT,REAL) ira = 10;
+      IF (cbra | (CHAR): FALSE, (BOOL b): b
+          |: ira | (INT i): i > 0, (REAL r): r > 0)
+      THEN SKIP
+      ELSE ASSERT (FALSE)
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-7.a68 b/gcc/testsuite/algol68/execute/conformity-clause-7.a68
new file mode 100644
index 00000000000..18122a3dd70
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-7.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN UNION (CHAR,BOOL,REAL) cbra = 3.14, UNION (INT,REAL) ira = -10;
+      IF (cbra | (CHAR): FALSE, (BOOL b): b
+          |: ira | (INT i): i > 0, (REAL r): r > 0)
+      THEN ASSERT (FALSE)
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-8.a68 b/gcc/testsuite/algol68/execute/conformity-clause-8.a68
new file mode 100644
index 00000000000..2da55f9abdf
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-8.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE JORL = STRUCT (UNION(INT,REAL) i, REF JORL next);
+      REF JORL p := HEAP JORL := (10, HEAP JORL := (20.0, NIL));
+      p := HEAP JORL := (30, p);
+      INT num ints := 0, num reals := 0;
+      WHILE REF JORL (p) ISNT NIL
+      DO CASE i OF p IN (INT): num ints +:= 1, (REAL): num reals +:= 1 ESAC;
+         p := next OF p
+      OD;
+      ASSERT (num ints = 2 AND num reals = 1)
+END
diff --git a/gcc/testsuite/algol68/execute/conformity-clause-9.a68 b/gcc/testsuite/algol68/execute/conformity-clause-9.a68
new file mode 100644
index 00000000000..55f1fc3eb88
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conformity-clause-9.a68
@@ -0,0 +1,10 @@
+begin union (int, bool, string) foo = 666;
+      case foo
+      in (union(int,string) bar):
+            case bar
+            in (int i): assert (i = 666),
+               (string s): assert (false)
+            esac,
+         (bool baz): assert (false)
+      esac
+end
diff --git a/gcc/testsuite/algol68/execute/conj-1.a68 b/gcc/testsuite/algol68/execute/conj-1.a68
new file mode 100644
index 00000000000..1954d38bf1d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/conj-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN COMPL z = 4.0I5.0;
+      CONJ z;
+      LONG COMPL zz = LONG 4.0 I LONG 6.0;
+      CONJ zz;
+      LONG LONG COMPL zzz = LONG LONG 4.0 I LONG LONG 7.0;
+      CONJ zzz;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/cos-1.a68 b/gcc/testsuite/algol68/execute/cos-1.a68
new file mode 100644
index 00000000000..e6b0f69279a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/cos-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r = 0.0;
+      LONG REAL rr = LONG 45.0;
+      LONG LONG REAL rrr = LONG LONG 60.0;
+      ASSERT (cos (r) = 1.0);
+      long cos (rr);
+      long long cos (rrr)
+END
diff --git a/gcc/testsuite/algol68/execute/declarer-1.a68 b/gcc/testsuite/algol68/execute/declarer-1.a68
new file mode 100644
index 00000000000..61af0816c83
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/declarer-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+# Tests a jump out of the elaboration of a declarer.  #
+BEGIN STRING month = CASE 13
+                     IN "Jan", "Feb","March","April","May","June",
+		        "July","Aug","Sept", "Oct",  "Nov","Dec",
+                        stop
+                     ESAC;
+      ASSERT (FALSE)
+END
diff --git a/gcc/testsuite/algol68/execute/declarer-2.a68 b/gcc/testsuite/algol68/execute/declarer-2.a68
new file mode 100644
index 00000000000..b474e3e516e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/declarer-2.a68
@@ -0,0 +1,6 @@
+begin int n := 1;
+      { The actual-declarer below should be
+        elaborated only once.  }
+      [1: n +:= 1]real a, b;
+      assert (n = 2)
+end
diff --git a/gcc/testsuite/algol68/execute/deprocedure-1.a68 b/gcc/testsuite/algol68/execute/deprocedure-1.a68
new file mode 100644
index 00000000000..17834f48109
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deprocedure-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x = 100;
+      PROC foo = INT: (INT i = 10, j = 20; PROC bar = INT: 100; i + j + bar);
+      ASSERT (foo = 130)
+END
diff --git a/gcc/testsuite/algol68/execute/deprocedure-2.a68 b/gcc/testsuite/algol68/execute/deprocedure-2.a68
new file mode 100644
index 00000000000..1f501cf7ab2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deprocedure-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Procedure variables.  #
+BEGIN INT x = 100;
+      PROC foo := INT: (INT i = 10, j = 20; PROC bar := INT: 100; i + j + bar);
+      ASSERT (foo = 130)
+END
diff --git a/gcc/testsuite/algol68/execute/deref-1.a68 b/gcc/testsuite/algol68/execute/deref-1.a68
new file mode 100644
index 00000000000..5bb4d5d373a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deref-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      INT res := (REF INT xx := x; xx);
+      ASSERT (res = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/deref-2.a68 b/gcc/testsuite/algol68/execute/deref-2.a68
new file mode 100644
index 00000000000..d49dc4a6987
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deref-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx := x;
+      x := 20;
+      ASSERT (xx = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/deref-3.a68 b/gcc/testsuite/algol68/execute/deref-3.a68
new file mode 100644
index 00000000000..8c077e079ba
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deref-3.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      INT y := 20;
+      REF INT xx := x;
+      CO This makes xx to refer to y
+         REF REF INT := REF INT
+      CO
+      xx := y;
+      y := 30;
+      ASSERT (xx = 30)
+END
diff --git a/gcc/testsuite/algol68/execute/deref-4.a68 b/gcc/testsuite/algol68/execute/deref-4.a68
new file mode 100644
index 00000000000..59639fd8612
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deref-4.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      INT y := 20;
+      REF INT xx := x;
+      # This sets x to the current value of y #
+      REF INT (xx) := y;
+      ASSERT (x = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/deref-5.a68 b/gcc/testsuite/algol68/execute/deref-5.a68
new file mode 100644
index 00000000000..804947f3dd2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deref-5.a68
@@ -0,0 +1,42 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx := x;
+      REF REF INT xxx := xx;
+      ASSERT (x = 10);
+      ASSERT (xx = 10);
+      ASSERT (xxx = 10);
+      ASSERT ((x) = 10);
+      ASSERT ((xx) = 10);
+      ASSERT ((xxx) = 10);
+      ASSERT (x + 1 = 11);
+      ASSERT (xx + 1 = 11);
+      ASSERT (xxx + 1 = 11);
+      ASSERT ((x + 1) = 11);
+      ASSERT ((xx + 1) = 11);
+      ASSERT ((xxx + 1) = 11);
+      ASSERT ((x := x) = 10);
+      ASSERT ((xx := x) = 10);
+      ASSERT ((xxx := xx) = 10);
+      ASSERT ((x := x) + 1 = 11);
+      ASSERT ((xx := x) + 1 = 11);
+      ASSERT ((xxx := xx) + 1 = 11);
+      x := 20;
+      ASSERT (x = 20);
+      ASSERT (xx = 20);
+      ASSERT (xxx = 20);
+      ASSERT ((x) = 20);
+      ASSERT ((xx) = 20);
+      ASSERT ((xxx) = 20);
+      ASSERT (x + 1 = 21);
+      ASSERT (xx + 1 = 21);
+      ASSERT (xxx + 1 = 21);
+      ASSERT ((x + 1) = 21);
+      ASSERT ((xx + 1) = 21);
+      ASSERT ((xxx + 1) = 21);
+      ASSERT ((x := x) = 20);
+      ASSERT ((xx := x) = 20);
+      ASSERT ((xxx := xx) = 20);
+      ASSERT ((x := x) + 1 = 21);
+      ASSERT ((xx := x) + 1 = 21);
+      ASSERT ((xxx := xx) + 1 = 21)
+END
diff --git a/gcc/testsuite/algol68/execute/deref-6.a68 b/gcc/testsuite/algol68/execute/deref-6.a68
new file mode 100644
index 00000000000..88754d2f58e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deref-6.a68
@@ -0,0 +1,48 @@
+# { dg-options "-fstropping=upper" }  #
+# Dereferencing of struct fields.  #
+BEGIN MODE S = STRUCT (REF INT x, REF REF INT xx, REF REF REF INT xxx);
+
+      INT x := 10;
+      REF INT xx := x;
+      REF REF INT xxx := xx;
+
+      S s = (x, xx, xxx);
+
+      ASSERT (x OF s = 10);
+      ASSERT (xx OF s = 10);
+      ASSERT (xxx OF s = 10);
+      ASSERT ((x) = 10);
+      ASSERT ((xx) = 10);
+      ASSERT ((xxx) = 10);
+      ASSERT (x OF s + 1 = 11);
+      ASSERT (xx OF s + 1 = 11);
+      ASSERT (xxx OF s + 1 = 11);
+      ASSERT ((x OF s + 1) = 11);
+      ASSERT ((xx OF s + 1) = 11);
+      ASSERT ((xxx OF s + 1) = 11);
+      ASSERT ((x OF s := x) = 10);
+      ASSERT ((xx OF s := x) = 10);
+      ASSERT ((xxx OF s := xx) = 10);
+      ASSERT ((x OF s := x) + 1 = 11);
+      ASSERT ((xx OF s := x) + 1 = 11);
+      ASSERT ((xxx OF s := xx) + 1 = 11);
+      x OF s := 20;
+      ASSERT (x OF s = 20);
+      ASSERT (xx OF s = 20);
+      ASSERT (xxx OF s = 20);
+      ASSERT ((x) = 20);
+      ASSERT ((xx) = 20);
+      ASSERT ((xxx) = 20);
+      ASSERT (x OF s + 1 = 21);
+      ASSERT (xx OF s + 1 = 21);
+      ASSERT (xxx OF s + 1 = 21);
+      ASSERT ((x OF s + 1) = 21);
+      ASSERT ((xx OF s + 1) = 21);
+      ASSERT ((xxx OF s + 1) = 21);
+      ASSERT ((x OF s := x) = 20);
+      ASSERT ((xx OF s := x) = 20);
+      ASSERT ((xxx OF s := xx) = 20);
+      ASSERT ((x OF s := x) + 1 = 21);
+      ASSERT ((xx OF s := x) + 1 = 21);
+      ASSERT ((xxx OF s := xx) + 1 = 21)
+END
diff --git a/gcc/testsuite/algol68/execute/deref-7.a68 b/gcc/testsuite/algol68/execute/deref-7.a68
new file mode 100644
index 00000000000..b2acec98f8d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deref-7.a68
@@ -0,0 +1,48 @@
+# { dg-options "-fstropping=upper" }  #
+# Dereferencing of struct fields.  Version with sub-names.  #
+BEGIN MODE S = STRUCT (INT x, REF INT xx, REF REF INT xxx);
+
+      INT x := 10;
+      REF INT xx := x;
+      REF REF INT xxx := xx;
+
+      S s := (x, xx, xxx);
+
+      ASSERT (x OF s = 10);
+      ASSERT (xx OF s = 10);
+      ASSERT (xxx OF s = 10);
+      ASSERT ((x) = 10);
+      ASSERT ((xx) = 10);
+      ASSERT ((xxx) = 10);
+      ASSERT (x OF s + 1 = 11);
+      ASSERT (xx OF s + 1 = 11);
+      ASSERT (xxx OF s + 1 = 11);
+      ASSERT ((x OF s + 1) = 11);
+      ASSERT ((xx OF s + 1) = 11);
+      ASSERT ((xxx OF s + 1) = 11);
+      ASSERT ((x OF s := x) = 10);
+      ASSERT ((xx OF s := xx) = 10);
+      ASSERT ((xxx OF s := xxx) = 10);
+      ASSERT ((x OF s := x) + 1 = 11);
+      ASSERT ((xx OF s := xx) + 1 = 11);
+      ASSERT ((xxx OF s := xxx) + 1 = 11);
+      x := 20;
+      ASSERT (x OF s = 10);
+      ASSERT (xx OF s = 20);
+      ASSERT (xxx OF s = 20);
+      ASSERT ((x) = 20);
+      ASSERT ((xx) = 20);
+      ASSERT ((xxx) = 20);
+      ASSERT (x OF s + 1 = 11);
+      ASSERT (xx OF s + 1 = 21);
+      ASSERT (xxx OF s + 1 = 21);
+      ASSERT ((x OF s + 1) = 11);
+      ASSERT ((xx OF s + 1) = 21);
+      ASSERT ((xxx OF s + 1) = 21);
+      ASSERT ((x OF s := x) = 20);
+      ASSERT ((xx OF s := xx) = 20);
+      ASSERT ((xxx OF s := xxx) = 20);
+      ASSERT ((x OF s := x) + 1 = 21);
+      ASSERT ((xx OF s := xx) + 1 = 21);
+      ASSERT ((xxx OF s := xxx) + 1 = 21)
+END
diff --git a/gcc/testsuite/algol68/execute/deref-8.a68 b/gcc/testsuite/algol68/execute/deref-8.a68
new file mode 100644
index 00000000000..6d57086a5e1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/deref-8.a68
@@ -0,0 +1,53 @@
+# { dg-options "-fstropping=upper" }  #
+# Dereferencing of struct fields.  Version with sub-names and
+  explicit assignations instead of initialization in variable declaration.  #
+BEGIN MODE S = STRUCT (INT x, REF INT xx, REF REF INT xxx);
+
+      INT x := 10;
+      REF INT xx := x;
+      REF REF INT xxx := xx;
+
+      S s;
+
+      x OF s := x;
+      xx OF s := xx;
+      xxx OF s := xxx;
+
+      ASSERT (x OF s = 10);
+      ASSERT (xx OF s = 10);
+      ASSERT (xxx OF s = 10);
+      ASSERT ((x) = 10);
+      ASSERT ((xx) = 10);
+      ASSERT ((xxx) = 10);
+      ASSERT (x OF s + 1 = 11);
+      ASSERT (xx OF s + 1 = 11);
+      ASSERT (xxx OF s + 1 = 11);
+      ASSERT ((x OF s + 1) = 11);
+      ASSERT ((xx OF s + 1) = 11);
+      ASSERT ((xxx OF s + 1) = 11);
+      ASSERT ((x OF s := x) = 10);
+      ASSERT ((xx OF s := xx) = 10);
+      ASSERT ((xxx OF s := xxx) = 10);
+      ASSERT ((x OF s := x) + 1 = 11);
+      ASSERT ((xx OF s := xx) + 1 = 11);
+      ASSERT ((xxx OF s := xxx) + 1 = 11);
+      x := 20;
+      ASSERT (x OF s = 10);
+      ASSERT (xx OF s = 20);
+      ASSERT (xxx OF s = 20);
+      ASSERT ((x) = 20);
+      ASSERT ((xx) = 20);
+      ASSERT ((xxx) = 20);
+      ASSERT (x OF s + 1 = 11);
+      ASSERT (xx OF s + 1 = 21);
+      ASSERT (xxx OF s + 1 = 21);
+      ASSERT ((x OF s + 1) = 11);
+      ASSERT ((xx OF s + 1) = 21);
+      ASSERT ((xxx OF s + 1) = 21);
+      ASSERT ((x OF s := x) = 20);
+      ASSERT ((xx OF s := xx) = 20);
+      ASSERT ((xxx OF s := xxx) = 20);
+      ASSERT ((x OF s := x) + 1 = 21);
+      ASSERT ((xx OF s := xx) + 1 = 21);
+      ASSERT ((xxx OF s := xxx) + 1 = 21)
+END
diff --git a/gcc/testsuite/algol68/execute/div-int-1.a68 b/gcc/testsuite/algol68/execute/div-int-1.a68
new file mode 100644
index 00000000000..6a26a7bef02
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/div-int-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+      ASSERT (i / 2 = 5.0);
+      ASSERT (ii / LONG 2 = LONG 5.0);
+      ASSERT (iii / LONG LONG 2 = LONG LONG 5.0)
+END
diff --git a/gcc/testsuite/algol68/execute/divab-real-1.a68 b/gcc/testsuite/algol68/execute/divab-real-1.a68
new file mode 100644
index 00000000000..830ae2e5f8d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/divab-real-1.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r := 3.14;
+      r DIVAB 2.0;
+      r /:= 2.0;
+      LONG REAL rr := LONG 3.14;
+      rr DIVAB LONG 2.0;
+      rr /:= LONG 2.0;
+      LONG LONG REAL rrr := LONG LONG 3.14;
+      rrr DIVAB LONG LONG 2.0;
+      rrr /:= LONG LONG 2.0
+END
diff --git a/gcc/testsuite/algol68/execute/elem-bits-1.a68 b/gcc/testsuite/algol68/execute/elem-bits-1.a68
new file mode 100644
index 00000000000..1529b595e74
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/elem-bits-1.a68
@@ -0,0 +1,18 @@
+# { dg-options "-fstropping=upper" }  #
+# ELEM for SIZETY BITS #
+BEGIN BITS b = 2r1010;
+      ASSERT ((bits width - 1) ELEM b);
+      ASSERT (NOT ((bits width - 2) ELEM b));
+      LONG BITS bb = LONG 2r1010;
+      ASSERT ((long bits width - 1) ELEM bb);
+      ASSERT (NOT ((long bits width - 2) ELEM bb));
+      LONG LONG BITS bbb = LONG LONG 2r1010;
+      ASSERT ((long long bits width - 1) ELEM bbb);
+      ASSERT (NOT ((long long bits width - 2) ELEM bbb));
+      SHORT BITS ss = SHORT 2r1010;
+      ASSERT ((short bits width - 1) ELEM ss);
+      ASSERT (NOT ((short bits width - 2) ELEM ss));
+      SHORT SHORT BITS sss = SHORT SHORT 2r1010;
+      ASSERT ((short short bits width - 1) ELEM sss);
+      ASSERT (NOT ((short short bits width - 2) ELEM sss))
+END
diff --git a/gcc/testsuite/algol68/execute/elems-1.a68 b/gcc/testsuite/algol68/execute/elems-1.a68
new file mode 100644
index 00000000000..da538fcf24d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/elems-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (ELEMS "foo" = 3);
+      ASSERT (ELEMS "" = 0);
+      ASSERT (1 ELEMS "foo" = 3);
+      ASSERT (1 ELEMS "" = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/elems-2.a68 b/gcc/testsuite/algol68/execute/elems-2.a68
new file mode 100644
index 00000000000..0545f4ec67d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/elems-2.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Flat and ultra-flat multiples.  #
+BEGIN [3,10:3]INT arr;
+      ASSERT (2 ELEMS arr = 0);
+      [1:0]INT arr2;
+      ASSERT (ELEMS arr2 = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/entier-1.a68 b/gcc/testsuite/algol68/execute/entier-1.a68
new file mode 100644
index 00000000000..d7c84e23d3e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/entier-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL x = 3.14, y = 3.80;
+      LONG REAL xx = LONG 3.14, yy = LONG 3.80;
+      LONG LONG REAL xxx = LONG LONG 3.14, yyy = LONG LONG 3.80;
+      ASSERT (ENTIER x = 3 AND ENTIER y = 3);
+      ASSERT (ENTIER xx = LONG 3 AND ENTIER yy = LONG 3);
+      ASSERT (ENTIER xxx = LONG LONG 3 AND ENTIER yyy = LONG LONG 3)
+END
diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-1.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-1.a68
new file mode 100644
index 00000000000..1601ac09972
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/environment-enquiries-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+# Environment enquiries for SIZETY INTs #
+BEGIN ASSERT (max int /= 0);
+      (INT max int = 10; ASSERT (max int = 10));
+      ASSERT (long max int >= LENG max int);
+      ASSERT (long long max int >= LENG long max int);
+      ASSERT (min int /= 0);
+      ASSERT (long min int <= LENG min int);
+      ASSERT (long long min int <= LENG long min int)
+END
diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-2.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-2.a68
new file mode 100644
index 00000000000..9f9d5fc0b68
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/environment-enquiries-2.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+# Environment enquiries for SIZETY REALs #
+BEGIN ASSERT (max real /= 0.0);
+      ASSERT (long max real >= LENG max real);
+      ASSERT (long long max real >= LENG long max real);
+      ASSERT (min real /= 0.0);
+      ASSERT (long min real <= LENG min real);
+      ASSERT (long long min real <= LENG long min real);
+      ASSERT (small real > 0.0);
+      ASSERT (long small real > LONG 0.0);
+      ASSERT (long long small real > LONG LONG 0.0)
+END
diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-3.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-3.a68
new file mode 100644
index 00000000000..7aba4cd4cb1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/environment-enquiries-3.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+# Environment enquiries for SIZETY BITS #
+BEGIN ASSERT (bits width > 0);
+      ASSERT (long bits width >= bits width);
+      ASSERT (long long bits width >= long bits width);
+      ASSERT (short bits width <= bits width);
+      ASSERT (short short bits width <= short bits width)
+END
+
diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-4.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-4.a68
new file mode 100644
index 00000000000..b053ed14347
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/environment-enquiries-4.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Environment enquiries for pi constants.  #
+BEGIN ASSERT (pi > 3.0 AND pi < 4.0);
+      ASSERT (long pi > LONG 3.0 AND long pi < LONG 4.0);
+      ASSERT (long long pi > LONG LONG 3.0 AND long long pi < LONG LONG 4.0)
+END
+
diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-5.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-5.a68
new file mode 100644
index 00000000000..a46879857b6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/environment-enquiries-5.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Environment enquiries for certain particular characters.  #
+BEGIN ASSERT (null character /= blank);
+      ASSERT (max abs char = ABS 16r10ffff)
+END
diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-6.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-6.a68
new file mode 100644
index 00000000000..a37dd4c2e42
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/environment-enquiries-6.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Environment enquiries for SIZETY BITs #
+BEGIN ASSERT (max bits /= 10r0);
+      # XXX use LENG max bits below #
+      ASSERT (long max bits >= LONG 10r0);
+      ASSERT (long long max bits >= LONG LONG 10r0)
+END
diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-7.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-7.a68
new file mode 100644
index 00000000000..d64a68f28d3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/environment-enquiries-7.a68
@@ -0,0 +1,15 @@
+# { dg-options "-fstropping=upper" }  #
+# Environment enquiries for widths #
+BEGIN ASSERT (int width > 0);
+      ASSERT (long int width > 0);
+      ASSERT (long long int width > 0);
+      ASSERT (short int width > 0);
+      ASSERT (short short int width > 0);
+      ASSERT (real width > 0);
+      ASSERT (long real width > 0);
+      ASSERT (long long real width > 0)
+CO      exp width;
+        long exp width;
+        long long exp width;
+CO
+END
diff --git a/gcc/testsuite/algol68/execute/environment-enquiries-8.a68 b/gcc/testsuite/algol68/execute/environment-enquiries-8.a68
new file mode 100644
index 00000000000..d464a49d990
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/environment-enquiries-8.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (flip = "T");
+      ASSERT (flop = "F");
+      ASSERT (error char = "*");
+      ASSERT (ABS invalid char = ABS 16rfffd)
+END
diff --git a/gcc/testsuite/algol68/execute/eq-bits-1.a68 b/gcc/testsuite/algol68/execute/eq-bits-1.a68
new file mode 100644
index 00000000000..b26df33d8b1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/eq-bits-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BITS b, LONG BITS bb = LONG 16rff,  LONG LONG BITS bbb;
+      SHORT BITS ss = SHORT 16rff, SHORT SHORT BITS sss;
+      ASSERT (b = 2r0);
+      ASSERT (bb EQ LONG 8r377);
+      ASSERT (bbb = LONG LONG 8r0);
+      ASSERT (ss EQ SHORT 8r377);
+      ASSERT (sss = SHORT SHORT 8r0)
+END
+
diff --git a/gcc/testsuite/algol68/execute/eq-char-char-1.a68 b/gcc/testsuite/algol68/execute/eq-char-char-1.a68
new file mode 100644
index 00000000000..eb520d2d6a8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/eq-char-char-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT ("a" = "a")
+END
+
diff --git a/gcc/testsuite/algol68/execute/eq-int-1.a68 b/gcc/testsuite/algol68/execute/eq-int-1.a68
new file mode 100644
index 00000000000..399b91aeab7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/eq-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 12;
+      LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+      SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+      ASSERT (12 = i);
+      ASSERT (ii = LONG 12);
+      ASSERT (iii = LONG LONG 12);
+      ASSERT (s = SHORT 12);
+      ASSERT (ss = SHORT SHORT 12)
+END
diff --git a/gcc/testsuite/algol68/execute/eq-string-1.a68 b/gcc/testsuite/algol68/execute/eq-string-1.a68
new file mode 100644
index 00000000000..0242f02bafb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/eq-string-1.a68
@@ -0,0 +1,16 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING foo = "foo", bar = "bar", quux = "quux";
+      # =  #
+      ASSERT ("" = "");
+      ASSERT ("foo" = foo);
+      ASSERT (NOT (foo = bar));
+      ASSERT (NOT (foo = quux));
+      ASSERT (NOT (quux = foo));
+      # EQ  #
+      ASSERT ("" EQ "");
+      ASSERT ("foo" EQ foo);
+      ASSERT (NOT (foo EQ bar));
+      ASSERT (NOT (foo EQ quux));
+      ASSERT (NOT (quux EQ foo))
+END
+
diff --git a/gcc/testsuite/algol68/execute/eq-string-stride-1.a68 b/gcc/testsuite/algol68/execute/eq-string-stride-1.a68
new file mode 100644
index 00000000000..6e9cec79a45
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/eq-string-stride-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]CHAR matrix = (("1", "2", "3"),
+                        ("4", "5", "6"),
+                        ("7", "8", "9"));
+      ASSERT (matrix[1:3,2] = "258")
+END
diff --git a/gcc/testsuite/algol68/execute/execute.exp b/gcc/testsuite/algol68/execute/execute.exp
new file mode 100644
index 00000000000..60722c7ad09
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/execute.exp
@@ -0,0 +1,37 @@
+# Copyright (C) 2024 Free Software Foundation, Inc.
+
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+# 
+# This program 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/>.
+
+# Execute tests, torture testing.
+
+if $tracelevel then {
+    strace $tracelevel
+}
+
+load_lib algol68-torture.exp
+load_lib torture-options.exp
+
+torture-init
+set-torture-options $TORTURE_OPTIONS
+
+foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] {
+    # If we're only testing specific files and this isn't one of them, skip it.
+    if ![runtest_file_p $runtests $testcase] then {
+	continue
+    }
+    algol68-torture-execute $testcase
+    set algol68_compile_args ""
+}
+
+torture-finish
diff --git a/gcc/testsuite/algol68/execute/factorial-1.a68 b/gcc/testsuite/algol68/execute/factorial-1.a68
new file mode 100644
index 00000000000..f1fa920ae20
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/factorial-1.a68
@@ -0,0 +1,170 @@
+# { dg-options "-fstropping=upper" }  #
+# The Most Contrived Factorial Program
+  By John P. Baker
+  University of Bristol.
+
+  Published in the Algol Bulletin 42.
+  http://jemarch.net/algol-bulletin-42.pdf
+
+  Version adapted for GCC.
+#
+
+BEGIN INT one = 1, two = 2, three = 3, four = 4, five = 5,
+          six = 6, seven = 7, eight = 8, nine = 9, ten = 10,
+          eleven = 11, twelve = 12;
+      INT a = one;
+      PRIO ME=5, LOVE=7, MY=7, LORDS=7, LADIES=7,
+           PIPERS=7, DRUMMERS=7, MAIDS=7, SWANS=7, GEESE=7,
+           GOLD=7, COLLY=7, FRENCH=7, TURTLE=7, PARTRIDGE=6;
+      BOOL sent to := TRUE;
+      OP THE = (BOOL a) BOOL: a,
+         TWELFTH = (INT a) BOOL: a = twelve,
+         ELEVENTH = (INT a) BOOL: a = eleven,
+         TENTH = (INT a) BOOL: a = ten,
+         NINTH = (INT a) BOOL: a = nine,
+         EIGHTH = (INT a) BOOL: a = eight,
+         SEVENTH = (INT a) BOOL: a = seven,
+         SIXTH = (INT a) BOOL: a = six,
+         FIFTH = (INT a) BOOL: a = five,
+         FOURTH = (INT a) BOOL: a = four,
+         THIRD = (INT a) BOOL: a = three,
+         SECOND = (INT a) BOOL: a = two,
+         FIRST = (INT a) BOOL: a = one;
+      OP ME = (BOOL a, INT b) VOID: SKIP; # XXX when transput done (a|print(b)) #
+      OP LOVE = (BOOL a, b) BOOL: (a|b|FALSE),
+         MY = (BOOL a, b) BOOL: a LOVE b;
+      OP AND = (INT a) INT: a;
+      MODE DATE = STRUCT (INT day, month);
+      LOC DATE christmas := (25, 12);
+      OP LORDS = (INT a, b) INT: a * b,
+         LADIES = (INT a, b) INT: a * b,
+         PIPERS = (INT a, b) INT: a * b,
+         DRUMMERS = (INT a, b) INT: a * b,
+         MAIDS = (INT a, b) INT: a * b,
+         SWANS = (INT a, b) INT: a * b,
+         GEESE = (INT a, b) INT: a * b,
+         GOLD = (INT a, b) INT: a * b,
+         COLLY = (INT a, b) INT: a * b,
+         FRENCH = (INT a, b) INT: a * b,
+         TURTLE = (INT a, b) INT: a * b;
+      OP LEAPING = (INT a) INT: a,
+         DANCING = (INT a) INT: a,
+         PIPING = (INT a) INT: a,
+         DRUMMING = (INT a) INT: a,
+         MILKING = (INT a) INT: a,
+         SWIMMING = (INT a) INT: a,
+         LAYING = (INT a) INT: a,
+         RINGS = (INT a) INT: a,
+         BIRDS = (INT a) INT: a,
+         HENS = (INT a) INT: a,
+         DOVES = (INT a) INT: a;
+      OP PARTRIDGE = (INT a, b) INT: a + b;
+      INT in a pear tree = 0;
+
+      # Now we are ready...  #
+
+       THE FIRST day OF christmas MY TRUE LOVE sent to ME
+      a PARTRIDGE in a pear tree;
+
+       THE SECOND day OF christmas MY TRUE LOVE sent to ME
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE THIRD day OF christmas MY TRUE LOVE sent to ME
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE FOURTH day OF christmas MY TRUE LOVE sent to ME
+      four COLLY BIRDS
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE FIFTH day OF christmas MY TRUE LOVE sent to ME
+      five GOLD RINGS
+      four COLLY BIRDS
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE SIXTH day OF christmas MY TRUE LOVE sent to ME
+      six GEESE LAYING
+      five GOLD RINGS
+      four COLLY BIRDS
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE SEVENTH day OF christmas MY TRUE LOVE sent to ME
+      seven SWANS SWIMMING
+      six GEESE LAYING
+      five GOLD RINGS
+      four COLLY BIRDS
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE EIGHTH day OF christmas MY TRUE LOVE sent to ME
+      eight MAIDS MILKING
+      seven SWANS SWIMMING
+      six GEESE LAYING
+      five GOLD RINGS
+      four COLLY BIRDS
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE NINTH day OF christmas MY TRUE LOVE sent to ME
+      nine DRUMMERS DRUMMING
+      eight MAIDS MILKING
+      seven SWANS SWIMMING
+      six GEESE LAYING
+      five GOLD RINGS
+      four COLLY BIRDS
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE TENTH day OF christmas MY TRUE LOVE sent to ME
+      ten PIPERS PIPING
+      nine DRUMMERS DRUMMING
+      eight MAIDS MILKING
+      seven SWANS SWIMMING
+      six GEESE LAYING
+      five GOLD RINGS
+      four COLLY BIRDS
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE ELEVENTH day OF christmas MY TRUE LOVE sent to ME
+      eleven LADIES DANCING
+      ten PIPERS PIPING
+      nine DRUMMERS DRUMMING
+      eight MAIDS MILKING
+      seven SWANS SWIMMING
+      six GEESE LAYING
+      five GOLD RINGS
+      four COLLY BIRDS
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+       THE TWELFTH day OF christmas MY TRUE LOVE sent to ME
+      twelve LORDS LEAPING
+      eleven LADIES DANCING
+      ten PIPERS PIPING
+      nine DRUMMERS DRUMMING
+      eight MAIDS MILKING
+      seven SWANS SWIMMING
+      six GEESE LAYING
+      five GOLD RINGS
+      four COLLY BIRDS
+      three FRENCH HENS
+      two TURTLE DOVES AND
+      a PARTRIDGE in a pear tree;
+
+   SKIP
+END
+
diff --git a/gcc/testsuite/algol68/execute/flat-assignation-1.a68 b/gcc/testsuite/algol68/execute/flat-assignation-1.a68
new file mode 100644
index 00000000000..bf973564b1f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/flat-assignation-1.a68
@@ -0,0 +1,7 @@
+{ Assigning to the flexible name replaces the descriptor
+  as well as the elements.  }
+begin [10:0]int flat1;
+      flex[10:-10]int flat2;
+      flat2 := flat1;
+      assert (UPB flat2 = 0 AND LWB flat2 = 10)
+end
diff --git a/gcc/testsuite/algol68/execute/flat-assignation-2.a68 b/gcc/testsuite/algol68/execute/flat-assignation-2.a68
new file mode 100644
index 00000000000..fb7fa82ba68
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/flat-assignation-2.a68
@@ -0,0 +1,8 @@
+{ Assigning to the flexible name replaces the descriptor
+  as well as the elements.  }
+begin [1:20,10:0]int flat1;
+      flex[100:200,10:-10]int flat2;
+      flat2 := flat1;
+      assert (1 UPB flat2 = 20 AND 1 LWB flat2 = 1);
+      assert (2 UPB flat2 = 0  AND 2 LWB flat2 = 10)
+end
diff --git a/gcc/testsuite/algol68/execute/flex-1.a68 b/gcc/testsuite/algol68/execute/flex-1.a68
new file mode 100644
index 00000000000..4e2bc315097
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/flex-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN FLEX[3]INT list := (1,2,3);
+      list[2] := 20;
+      ASSERT (list[2] = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/flex-2.a68 b/gcc/testsuite/algol68/execute/flex-2.a68
new file mode 100644
index 00000000000..4f18674bc88
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/flex-2.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Rowing to flexible rows.  #
+BEGIN FLEX[]INT list = 10;
+      ASSERT (list[1] = 10);
+      FLEX[,]INT table = 10;
+      ASSERT (table[1,1] = 10)
+END
+
diff --git a/gcc/testsuite/algol68/execute/flex-3.a68 b/gcc/testsuite/algol68/execute/flex-3.a68
new file mode 100644
index 00000000000..8ee38855727
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/flex-3.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Slicing flexible names.  #
+BEGIN FLEX[]INT list = (1,2,3);
+      FLEX[]INT sliced = list[2:3];
+      ASSERT (LWB sliced = 1 AND UPB sliced = 2);
+      ASSERT (sliced[1] = 2 AND sliced[2] = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/flex-4.a68 b/gcc/testsuite/algol68/execute/flex-4.a68
new file mode 100644
index 00000000000..d4d7c998f7d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/flex-4.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Rowing to flexible rows.  #
+BEGIN FLEX[3]INT list := (1,2,3);
+      list := (10,20,30,40);
+      ASSERT (list[4] = 40)
+END
diff --git a/gcc/testsuite/algol68/execute/flex-5.a68 b/gcc/testsuite/algol68/execute/flex-5.a68
new file mode 100644
index 00000000000..9f9dccc3664
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/flex-5.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN FLEX[1:0]INT a;
+      ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0);
+      a := (1,2,3);
+      ASSERT (LWB a = 1 AND UPB a = 3 AND a[1] = 1 AND a[2] = 2 AND a[3] = 3);
+      a := (10,a[2],a[3]);
+      ASSERT (LWB a = 1 AND UPB a = 3 AND a[1] = 10 AND a[2] = 2 AND a[3] = 3);
+      a := 100;
+      ASSERT (LWB a = 1 AND UPB a = 1 AND a[1] = 100);
+      a := ();
+      ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/formula-1.a68 b/gcc/testsuite/algol68/execute/formula-1.a68
new file mode 100644
index 00000000000..6d2ba4ef82d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/formula-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN OP JORL = (INT a, b) INT: a + b;
+      OP JORL = (REAL a, b) REAL: a + b;
+      OP JORL = ([]CHAR s) INT: ELEMS s;
+      PRIO JORL = 6;
+      ASSERT (10 JORL 20 = 30);
+      ASSERT (REAL r = 3.14 JORL REAL (1); r > 4.13 AND r < 4.15);
+      ASSERT (JORL "foo" = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/formula-2.a68 b/gcc/testsuite/algol68/execute/formula-2.a68
new file mode 100644
index 00000000000..5b09f3d870f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/formula-2.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i;
+      PROC side = INT: (i := 1; i := 2; i);
+      INT res = side + side;
+      # Can be either due to collateral elaboration in the formula above.  #
+      ASSERT (res = 3 OR res = 4)
+END
diff --git a/gcc/testsuite/algol68/execute/fsize-1.a68 b/gcc/testsuite/algol68/execute/fsize-1.a68
new file mode 100644
index 00000000000..17e3ef2ba9e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/fsize-1.a68
@@ -0,0 +1,2 @@
+begin assert (fsize (-1) = - long long 1)
+end
diff --git a/gcc/testsuite/algol68/execute/ge-int-1.a68 b/gcc/testsuite/algol68/execute/ge-int-1.a68
new file mode 100644
index 00000000000..9ed95321c09
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/ge-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 12;
+      LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+      SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+      ASSERT (i >= 10);
+      ASSERT (ii GE LONG 10);
+      ASSERT (iii >= LONG LONG 12);
+      ASSERT (s >= SHORT 12);
+      ASSERT (ss >= SHORT SHORT 10)
+END
diff --git a/gcc/testsuite/algol68/execute/ge-string-stride-1.a68 b/gcc/testsuite/algol68/execute/ge-string-stride-1.a68
new file mode 100644
index 00000000000..4f51d6ba6fc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/ge-string-stride-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]CHAR matrix = (("1", "0", "1"),
+                        ("4", "0", "4"),
+                        ("7", "0", "7"));
+      ASSERT (matrix[1:3,1] >= matrix[1:3,3]);
+      ASSERT (("1","4","7") >= matrix[1:3,3])
+END
diff --git a/gcc/testsuite/algol68/execute/gen-flex-1.a68 b/gcc/testsuite/algol68/execute/gen-flex-1.a68
new file mode 100644
index 00000000000..ce993df27d2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-flex-1.a68
@@ -0,0 +1,10 @@
+begin flex[10:-10]int je;
+      int num_fields = 3;
+      assert (UPB je = -10 AND LWB je = 10 AND ELEMS je = 0);
+
+      [1:num_fields][1:num_fields]string fields;
+      for i to num_fields
+      do for j to num_fields
+         do assert (fields[i][j] = "") od
+      od
+end
diff --git a/gcc/testsuite/algol68/execute/gen-heap-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-1.a68
new file mode 100644
index 00000000000..fdf8df23c6e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-heap-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT jorl;
+      REF INT var = HEAP INT;
+      var := jorl := 10;
+      ASSERT (var = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-heap-2.a68 b/gcc/testsuite/algol68/execute/gen-heap-2.a68
new file mode 100644
index 00000000000..80e3a77676c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-heap-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT jorl;
+      REF INT var := HEAP INT;
+      var := jorl := 10;
+      ASSERT (var = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-heap-3.a68 b/gcc/testsuite/algol68/execute/gen-heap-3.a68
new file mode 100644
index 00000000000..e2c026b2bc8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-heap-3.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT jorl;
+      INT var := HEAP INT := 15; # The generated name goes away #
+      ASSERT (var = 15)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-heap-bool-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-bool-1.a68
new file mode 100644
index 00000000000..d4494f0d753
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-heap-bool-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REF BOOL x = HEAP BOOL;
+      ASSERT (x = FALSE);
+      x := TRUE;
+      ASSERT (x = TRUE)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-heap-int-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-int-1.a68
new file mode 100644
index 00000000000..8500d792cba
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-heap-int-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REF INT x = HEAP INT := 4;
+      ASSERT (x = 4)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-heap-real-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-real-1.a68
new file mode 100644
index 00000000000..3ea6dcb7edf
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-heap-real-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REF REAL x = HEAP REAL := 4;
+      ASSERT (x > 3.9 AND x < 4.1)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-heap-struct-1.a68 b/gcc/testsuite/algol68/execute/gen-heap-struct-1.a68
new file mode 100644
index 00000000000..2c2f9744371
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-heap-struct-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN HEAP STRUCT(INT i, REAL r) foo;
+      ASSERT (i OF foo = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-heap-struct-2.a68 b/gcc/testsuite/algol68/execute/gen-heap-struct-2.a68
new file mode 100644
index 00000000000..0803204d2d8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-heap-struct-2.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN HEAP STRUCT([10]INT i, REAL r) foo;
+      FOR i FROM LWB i OF foo TO UPB i OF foo
+      DO ASSERT ((i OF foo)[i] = 0) OD
+END
diff --git a/gcc/testsuite/algol68/execute/gen-heap-struct-3.a68 b/gcc/testsuite/algol68/execute/gen-heap-struct-3.a68
new file mode 100644
index 00000000000..849bbbd6234
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-heap-struct-3.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN HEAP STRUCT([10]INT i, STRING s) foo;
+      FOR i FROM LWB i OF foo TO UPB i OF foo
+      DO ASSERT ((i OF foo)[i] = 0) OD
+END
diff --git a/gcc/testsuite/algol68/execute/gen-loc-1.a68 b/gcc/testsuite/algol68/execute/gen-loc-1.a68
new file mode 100644
index 00000000000..1a61bbea0a1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-loc-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT jorl;
+      REF INT var = LOC INT;
+      var := jorl := 10;
+      ASSERT (var = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-loc-2.a68 b/gcc/testsuite/algol68/execute/gen-loc-2.a68
new file mode 100644
index 00000000000..fce63efec69
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-loc-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT jorl;
+      REF INT var := LOC INT;
+      var := jorl := 10;
+      ASSERT (var = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-loc-3.a68 b/gcc/testsuite/algol68/execute/gen-loc-3.a68
new file mode 100644
index 00000000000..66c3cf1ea0c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-loc-3.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT jorl;
+      INT var := LOC INT := 15; # The generated name goes away #
+      ASSERT (var = 15)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-loc-4.a68 b/gcc/testsuite/algol68/execute/gen-loc-4.a68
new file mode 100644
index 00000000000..6aeb30008e0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-loc-4.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE NODE = STRUCT (INT code, REF NODE next);
+
+      NODE top := (10, NIL);
+      next OF top := LOC NODE := (20, NIL);
+      ASSERT (code OF top = 10);
+      ASSERT (code OF next OF top = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-multiple-1.a68 b/gcc/testsuite/algol68/execute/gen-multiple-1.a68
new file mode 100644
index 00000000000..2be0d96e77e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-multiple-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE JORL = [(INT x; x + 1)]INT;
+      JORL xx;
+      ASSERT (ELEMS xx = 1 AND xx[1] = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-union-1.a68 b/gcc/testsuite/algol68/execute/gen-union-1.a68
new file mode 100644
index 00000000000..893da222906
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-union-1.a68
@@ -0,0 +1,17 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN UNION(INT,REAL,[]INT,CHAR) datux;
+      ASSERT (CASE datux
+              IN (INT): 10,
+                 (REAL): 20,
+                 (CHAR): 30,
+                 ([]INT): 40
+              ESAC = 0);
+      []INT ja = (1,2,3);
+      datux := ja;
+      ASSERT (CASE datux
+              IN (INT): 10,
+                 (REAL): 20,
+                 (CHAR): 30,
+                 ([]INT): 40
+              ESAC = 40)
+END
diff --git a/gcc/testsuite/algol68/execute/gen-union-2.a68 b/gcc/testsuite/algol68/execute/gen-union-2.a68
new file mode 100644
index 00000000000..27ab7a8aeb1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-union-2.a68
@@ -0,0 +1,20 @@
+# { dg-options "-fstropping=upper" }  #
+# pr UPPER pr  #
+BEGIN [10]UNION(INT,REAL,[]INT,CHAR) datux;
+      FOR i FROM LWB datux TO UPB datux
+      DO ASSERT (CASE datux[i]
+                 IN (INT): 10,
+                    (REAL): 20,
+                    (CHAR): 30,
+                    ([]INT): 40
+                 ESAC = 0);
+         []INT ja = (1,2,3);
+         datux[i] := ja;
+         ASSERT (CASE datux[i]
+                 IN (INT): 10,
+                    (REAL): 20,
+                    (CHAR): 30,
+                    ([]INT): 40
+                 ESAC = 40)
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/gen-union-3.a68 b/gcc/testsuite/algol68/execute/gen-union-3.a68
new file mode 100644
index 00000000000..78c5d058584
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gen-union-3.a68
@@ -0,0 +1,14 @@
+# { dg-options "-fstropping=upper" }  #
+# An union generated from SKIP has -1 as overhead.  #
+BEGIN MODE JSONVAL = UNION (JSONOBJ,JSONSTR),
+           JSONSTR = STRING,
+           JSONOBJ = STRUCT (REF JSONFLD fields),
+           JSONFLD = STRUCT (JSONVAL value, REF JSONFLD next);
+
+      JSONFLD fields;
+      ASSERT (CASE value OF fields
+              IN (JSONSTR s): "string",
+                 (JSONOBJ o): "object"
+              OUT "fuckyou"
+              ESAC = "fuckyou")
+END
diff --git a/gcc/testsuite/algol68/execute/goto-1.a68 b/gcc/testsuite/algol68/execute/goto-1.a68
new file mode 100644
index 00000000000..7f61575efb2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/goto-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 0;
+beg:  IF (i < 5)
+      THEN i +:= 1;
+           GOTO beg
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/goto-2.a68 b/gcc/testsuite/algol68/execute/goto-2.a68
new file mode 100644
index 00000000000..7f78215af28
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/goto-2.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN GOTO end;
+      ASSERT(FALSE);
+end:  SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/goto-3.a68 b/gcc/testsuite/algol68/execute/goto-3.a68
new file mode 100644
index 00000000000..47573d2f8c1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/goto-3.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN
+   INT i := 0;
+   beginning:
+   IF (i < 5) THEN
+      i +:= 1;
+      GO TO beginning
+   FI
+END
diff --git a/gcc/testsuite/algol68/execute/goto-4.a68 b/gcc/testsuite/algol68/execute/goto-4.a68
new file mode 100644
index 00000000000..c374ca86c1b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/goto-4.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN
+   INT i := 0;
+   beginning:
+   IF (i < 5) THEN
+      i +:= 1;
+      beginning
+   FI
+END
diff --git a/gcc/testsuite/algol68/execute/goto-5.a68 b/gcc/testsuite/algol68/execute/goto-5.a68
new file mode 100644
index 00000000000..a5c720e3e63
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/goto-5.a68
@@ -0,0 +1,20 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC is prime = (INT m) BOOL:
+      BEGIN IF m < 2
+            THEN puts ("program terminated because m is less than 2\n");
+                 GOTO stop
+            FI;
+
+            BOOL factor found := NOT (ODD m OR m = 2);
+            FOR i FROM 3 BY 2 TO m - 1 WHILE NOT factor found
+            DO factor found := m MOD i = 0 OD;
+            factor found
+      END;
+
+      ASSERT (is prime (1));
+      ASSERT (is prime (3));
+      ASSERT (is prime (71));
+      ASSERT (is prime (97));
+      is prime (0);
+      ASSERT (FALSE) # Should jump to stop in the standard postlude.  #
+END
diff --git a/gcc/testsuite/algol68/execute/gt-int-1.a68 b/gcc/testsuite/algol68/execute/gt-int-1.a68
new file mode 100644
index 00000000000..cd5437b9ff8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gt-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 12;
+      LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+      SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+      ASSERT (i > 10);
+      ASSERT (ii GT LONG 10);
+      ASSERT (iii > LONG LONG 10);
+      ASSERT (s > SHORT 10);
+      ASSERT (ss > SHORT SHORT 10)
+END
diff --git a/gcc/testsuite/algol68/execute/gt-string-stride-1.a68 b/gcc/testsuite/algol68/execute/gt-string-stride-1.a68
new file mode 100644
index 00000000000..3f0565cf271
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/gt-string-stride-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]CHAR matrix = (("1", "0", "1"),
+                        ("4", "0", "4"),
+                        ("7", "0", "6"));
+      ASSERT (matrix[1:3,1] > matrix[1:3,3]);
+      ASSERT (("1","4","7") > matrix[1:3,3])
+END
diff --git a/gcc/testsuite/algol68/execute/i-1.a68 b/gcc/testsuite/algol68/execute/i-1.a68
new file mode 100644
index 00000000000..87b6979c600
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/i-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN COMPL z = 4I5;
+      LONG COMPL zz = LONG 4 I LONG 6;
+      LONG LONG COMPL zzz = LONG LONG 4 I LONG LONG7;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/i-2.a68 b/gcc/testsuite/algol68/execute/i-2.a68
new file mode 100644
index 00000000000..455f0096e2e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/i-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN COMPL z = 4.0I5.0;
+      LONG COMPL zz = LONG 4.0 I LONG 6.0;
+      LONG LONG COMPL zzz = LONG LONG 4.0 I LONG LONG 7.0;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/identification-1.a68 b/gcc/testsuite/algol68/execute/identification-1.a68
new file mode 100644
index 00000000000..71cc808cff4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identification-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC a = REAL: b := c;
+      REAL b := 1, c := 2;
+      REAL x := a;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/identification-2.a68 b/gcc/testsuite/algol68/execute/identification-2.a68
new file mode 100644
index 00000000000..8292063373a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identification-2.a68
@@ -0,0 +1,14 @@
+# { dg-options "-fstropping=upper" }  #
+# The identification of c in the assignation marked with XXX works.
+  In some Algol 68 systems the assignation may fail or result in UB,
+  because the storage of the REF REAL c doesn't exist yet.  In GNU
+  Algol 68 this works and the value yielded by c is guaranteed to be
+  zero.
+#
+
+BEGIN REAL b;
+      b := c; # XXX #
+      ASSERT (b = 0);
+      REAL c;
+      c := b
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-1.a68 b/gcc/testsuite/algol68/execute/identity-declaration-1.a68
new file mode 100644
index 00000000000..ddfa8f28bcb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx = x := 20;
+      ASSERT (xx = 20);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-2.a68 b/gcc/testsuite/algol68/execute/identity-declaration-2.a68
new file mode 100644
index 00000000000..28ba62a9c64
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx = x;
+      ASSERT (xx = 10);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-3.a68 b/gcc/testsuite/algol68/execute/identity-declaration-3.a68
new file mode 100644
index 00000000000..a694c3a640e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-3.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx = (x := 20);
+      ASSERT (xx = 20);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-4.a68 b/gcc/testsuite/algol68/execute/identity-declaration-4.a68
new file mode 100644
index 00000000000..d60867eff32
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-4.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx = ((x));
+      ASSERT (xx = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-5.a68 b/gcc/testsuite/algol68/execute/identity-declaration-5.a68
new file mode 100644
index 00000000000..7c29de1b92b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-5.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE FOO = STRUCT (STRING s, INT i);
+      FOO f1 = ("foo", 10);
+      ASSERT (i OF f1 = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-1.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-1.a68
new file mode 100644
index 00000000000..9864ab97594
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT foo = (1,2,3);
+      ASSERT (ELEMS foo = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-2.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-2.a68
new file mode 100644
index 00000000000..6fd973ee445
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-2.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [][]INT foo = ((1,2,3),(4,5,6));
+      ASSERT (ELEMS foo = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-3.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-3.a68
new file mode 100644
index 00000000000..2d3b8f3c7be
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-3.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [3]INT a := (1,2,3);
+      REF[]INT nn = a; # No copy happens here.  #
+      nn[1] := 200;
+      ASSERT (a[1] = 200)
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-5.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-5.a68
new file mode 100644
index 00000000000..005a3c6c4fb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-5.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [:]INT foo = (1,2,3);
+      ASSERT (ELEMS foo = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-1.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-1.a68
new file mode 100644
index 00000000000..c8890c27c3d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT a = ();
+      ASSERT (UPB a = 0);
+      ASSERT (LWB a = 1);
+      ASSERT (ELEMS a = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-2.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-2.a68
new file mode 100644
index 00000000000..67b5294d15b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-2.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,,]INT a = ();
+      ASSERT (1 UPB a = 0);
+      ASSERT (1 LWB a = 1);
+      ASSERT (1 ELEMS a = 0);
+      ASSERT (2 UPB a = 0);
+      ASSERT (2 LWB a = 1);
+      ASSERT (2 ELEMS a = 0);
+      ASSERT (3 UPB a = 0);
+      ASSERT (3 LWB a = 1);
+      ASSERT (3 ELEMS a = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-3.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-3.a68
new file mode 100644
index 00000000000..b74761f7473
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-3.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC foo = ([]INT a) VOID: (ASSERT (ELEMS a = 0));
+      foo ([]INT())
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-4.a68 b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-4.a68
new file mode 100644
index 00000000000..69bd760298a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-multiple-empty-4.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC foo = ([]INT a) VOID: (ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0));
+      foo (())
+END
diff --git a/gcc/testsuite/algol68/execute/identity-declaration-struct-1.a68 b/gcc/testsuite/algol68/execute/identity-declaration-struct-1.a68
new file mode 100644
index 00000000000..58e26b057d0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/identity-declaration-struct-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+# An identity declaration shall make a copy of the struct value being
+  ascribed.  #
+BEGIN MODE FOO = STRUCT (STRING s, INT n);
+      FOO f1 := ("foo", 10);
+      FOO f2 = f1;
+      f1 := ("bar", 20);
+      ASSERT (n OF f1 = 20);
+      ASSERT (n OF f2 = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/infinity-1.a68 b/gcc/testsuite/algol68/execute/infinity-1.a68
new file mode 100644
index 00000000000..a7c4fb29ca3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/infinity-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN infinity;
+      minus infinity
+END
diff --git a/gcc/testsuite/algol68/execute/le-ge-bits-1.a68 b/gcc/testsuite/algol68/execute/le-ge-bits-1.a68
new file mode 100644
index 00000000000..8b355f1ba45
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/le-ge-bits-1.a68
@@ -0,0 +1,17 @@
+# { dg-options "-fstropping=upper" }  #
+# <= and => for SIZETY BITS #
+BEGIN ASSERT (16rff <= 16rffff);
+      ASSERT (2r101 LE 2r111);
+      ASSERT (2r111 >= 2r101);
+      ASSERT (16rffff GE 16rff);
+
+      ASSERT (LONG 16rff <= LONG 16rffff);
+      ASSERT (LONG 2r101 LE LONG 2r111);
+      ASSERT (LONG 2r111 >= LONG 2r101);
+      ASSERT (LONG 16rffff GE LONG 16rff);
+
+      ASSERT (LONG LONG 16rff <= LONG LONG 16rffff);
+      ASSERT (LONG LONG 2r101 LE LONG LONG 2r111);
+      ASSERT (LONG LONG 2r111 >= LONG LONG 2r101);
+      ASSERT (LONG LONG 16rffff GE LONG LONG 16rff)
+END
diff --git a/gcc/testsuite/algol68/execute/le-int-1.a68 b/gcc/testsuite/algol68/execute/le-int-1.a68
new file mode 100644
index 00000000000..7ad17d308a3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/le-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 12;
+      LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+      SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+      ASSERT (i <= 13);
+      ASSERT (ii LE LONG 13);
+      ASSERT (iii <= LONG LONG 13);
+      ASSERT (s <= SHORT 12);
+      ASSERT (ss <= SHORT SHORT 13)
+END
diff --git a/gcc/testsuite/algol68/execute/le-string-stride-1.a68 b/gcc/testsuite/algol68/execute/le-string-stride-1.a68
new file mode 100644
index 00000000000..b0fab2af55d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/le-string-stride-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]CHAR matrix = (("1", "Z", "1"),
+                        ("4", "Y", "4"),
+                        ("7", "X", "9"));
+      ASSERT (matrix[1:3,1] <= matrix[1:3,3]);
+      ASSERT (("1","4","9") <= matrix[1:3,3])
+END
diff --git a/gcc/testsuite/algol68/execute/leng-shorten-bits-1.a68 b/gcc/testsuite/algol68/execute/leng-shorten-bits-1.a68
new file mode 100644
index 00000000000..58b5d00efa5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/leng-shorten-bits-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# SHORTEN and LENG on SIZETY BITS #
+BEGIN ASSERT (LENG 16rff = LONG 16rff);
+      ASSERT (SHORTEN LONG 16rffff = 16rffff);
+      ASSERT (LENG LONG 16rffff = LONG LONG 16rffff);
+      ASSERT (SHORTEN LONG LONG 16rffff = LONG 16rffff)
+END
diff --git a/gcc/testsuite/algol68/execute/leng-shorten-ints-1.a68 b/gcc/testsuite/algol68/execute/leng-shorten-ints-1.a68
new file mode 100644
index 00000000000..d615f40c2fa
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/leng-shorten-ints-1.a68
@@ -0,0 +1,27 @@
+# { dg-options "-fstropping=upper" }  #
+# Environment enquiries for SIZETY INTs #
+BEGIN # LENG  #
+      (SHORT SHORT INT iii = short short max int; ASSERT (LENG iii = LENG short short max int));
+      (SHORT INT ii = short max int; ASSERT (LENG ii = LENG short max int));
+      (INT i = max int; ASSERT (LENG i = LENG max int));
+      (LONG INT ii = long max int; ASSERT (LENG ii = LENG long max int));
+      # SHORTEN  #
+      (SHORT INT i = SHORT 10; SHORT SHORT INT ii = SHORT SHORT 100; ASSERT (ii + SHORTEN i = SHORT SHORT 110));
+      IF int shorths > 2
+      THEN (SHORT INT ii = LENG short short max int - SHORT 2;
+            ASSERT (SHORTEN ii = short short max int - SHORT SHORT 2));
+           (SHORT INT ii = LENG short short max int + SHORT 1; ASSERT (SHORTEN ii = short short max int));
+           (SHORT INT ii = LENG short short min int - SHORT 1; ASSERT (SHORTEN ii = short short min int))
+      FI;
+      (INT i = LENG short max int - 2; ASSERT (SHORTEN i = SHORTEN max int - SHORT 2));
+      (INT i = LENG short max int + 1; ASSERT (SHORTEN i = SHORTEN max int));
+      (INT i = LENG short min int - 1; ASSERT (SHORTEN i = SHORTEN min int));
+      (LONG INT ii = LENG max int - LONG 2; ASSERT (SHORTEN ii = max int - 2));
+      (LONG INT ii = LENG max int + LONG 1; ASSERT (SHORTEN ii = max int));
+      (LONG INT ii = LENG min int - LONG 1; ASSERT (SHORTEN ii = min int));
+      IF int lengths > 2
+      THEN (LONG LONG INT ii = LENG long max int - LONG LONG 2; ASSERT (SHORTEN ii = long max int - LONG 2));
+           (LONG LONG INT ii = LENG long max int + LONG LONG 1; ASSERT (SHORTEN ii = long max int));
+           (LONG LONG INT ii = LENG long min int - LONG LONG 1; ASSERT (SHORTEN ii = long min int))
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/leng-shorten-reals-1.a68 b/gcc/testsuite/algol68/execute/leng-shorten-reals-1.a68
new file mode 100644
index 00000000000..dd6ed8c590e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/leng-shorten-reals-1.a68
@@ -0,0 +1,17 @@
+# { dg-options "-fstropping=upper" }  #
+# Environment enquiries for SIZETY REALs #
+BEGIN # LENG  #
+      (REAL i = max real; ASSERT (LENG i = LENG max real));
+      (LONG REAL ii = long max real; ASSERT (LENG ii = LENG long max real));
+
+      # SHORTEN  #
+      (LONG REAL ii = LENG max real - LONG 2.0; ASSERT (SHORTEN ii = max real - 2.0));
+      (LONG REAL ii = LENG max real + LONG 1.0; ASSERT (SHORTEN ii = max real));
+      (LONG REAL ii = LENG min real - LONG 1.0; ASSERT (SHORTEN ii = min real));
+      IF (long long max real > LENG long max real)
+      THEN (LONG LONG REAL ii = LENG long max real - LONG LONG 2.0;
+            ASSERT (SHORTEN ii = long max real - LONG 2.0));
+           (LONG LONG REAL ii = LENG long max real + LONG LONG 1.0; ASSERT (SHORTEN ii = long max real));
+           (LONG LONG REAL ii = LENG long min real - LONG LONG 1.0; ASSERT (SHORTEN ii = long min real))
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/lengths-shorths-1.a68 b/gcc/testsuite/algol68/execute/lengths-shorths-1.a68
new file mode 100644
index 00000000000..f1c89235424
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/lengths-shorths-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (int lengths > 0);
+      ASSERT (int shorths > 0);
+      ASSERT (bits lengths > 0);
+      ASSERT (bits shorths > 0);
+      ASSERT (real lengths > 0);
+      ASSERT (real shorths > 0)
+END
diff --git a/gcc/testsuite/algol68/execute/lisp-1.a68 b/gcc/testsuite/algol68/execute/lisp-1.a68
new file mode 100644
index 00000000000..8cec7f6e94e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/lisp-1.a68
@@ -0,0 +1,25 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT num ints := 0, num chars := 0;
+      PROC collect stats = (REF CONS tree) VOID:
+      BEGIN REF CONS e := tree;
+            WHILE REF CONS (e) ISNT NIL
+            DO CASE car OF e
+               IN (CHAR c): num chars +:= 1,
+                  (INT): num ints +:= 1,
+                  (REF CONS s): collect stats (s)
+               ESAC;
+               e := cdr OF e
+            OD
+      END;
+      MODE ATOM = UNION (CHAR, INT);
+      MODE CONS = STRUCT (UNION (ATOM, REF CONS) car, REF CONS cdr);
+      PROC list = ([]UNION (ATOM, REF CONS) item) REF CONS:
+      BEGIN REF CONS a := NIL;
+            FOR i FROM UPB item BY -1 TO 1
+            DO a := HEAP CONS := (item[i], a) OD;
+            a
+      END;
+      REF CONS expression := list (("X", "+", list (("Y", "x", 2))));
+      collect stats (expression);
+      ASSERT (num ints = 1 AND num chars = 4)
+END
diff --git a/gcc/testsuite/algol68/execute/lisp-2.a68 b/gcc/testsuite/algol68/execute/lisp-2.a68
new file mode 100644
index 00000000000..79ae697fd17
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/lisp-2.a68
@@ -0,0 +1,21 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT num constants := 0, num vars := 0, num operators := 0;
+      PROC collect stats = (REF EXPRESSION expr) VOID:
+      BEGIN CASE left OF expr
+            IN (INT): num constants +:= 1,
+               (CHAR): num vars +:= 1,
+               (REF EXPRESSION s): collect stats (s)
+            ESAC;
+            num operators +:= 1;
+            CASE right OF expr
+            IN (INT): num constants +:= 1,
+               (CHAR): num vars +:= 1,
+               (REF EXPRESSION s): collect stats (s)
+            ESAC
+      END;
+      MODE OPERAND = UNION (CHAR,INT,REF EXPRESSION),
+           EXPRESSION = STRUCT (OPERAND left, CHAR operator, OPERAND right);
+      REF EXPRESSION expression := HEAP EXPRESSION := ("X", "+", HEAP EXPRESSION := ("Y", "x", 2));
+      collect stats (expression);
+      ASSERT (num constants = 1 AND num vars = 2 AND num operators = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/ln-1.a68 b/gcc/testsuite/algol68/execute/ln-1.a68
new file mode 100644
index 00000000000..5c569711bb4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/ln-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r = 1.0;
+      LONG REAL rr = LONG 2.0;
+      LONG LONG REAL rrr = LONG LONG 60.0;
+      ASSERT (ln (r) = 0.0);
+      long ln (rr);
+      long long ln (rrr)
+END
diff --git a/gcc/testsuite/algol68/execute/log-1.a68 b/gcc/testsuite/algol68/execute/log-1.a68
new file mode 100644
index 00000000000..b1a8d8d11ca
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/log-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r = 1.0;
+      LONG REAL rr = LONG 2.0;
+      LONG LONG REAL rrr = LONG LONG 60.0;
+      ASSERT (log (r) = 0.0);
+      long log (rr);
+      long long log (rrr)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-1.a68 b/gcc/testsuite/algol68/execute/loop-1.a68
new file mode 100644
index 00000000000..91e47c09b57
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 0;
+      DO i +:= 1; IF i = 5 THEN exit FI
+      OD;
+exit: ASSERT (i = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-10.a68 b/gcc/testsuite/algol68/execute/loop-10.a68
new file mode 100644
index 00000000000..53e382356fb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-10.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 0, n := 2;
+      FOR a FROM n BY 2 TO n + 2 DO i +:= a OD;
+      ASSERT (i = 2 + 4)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-11.a68 b/gcc/testsuite/algol68/execute/loop-11.a68
new file mode 100644
index 00000000000..eecaade529b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-11.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Negative steps towards minus infinity.  #
+BEGIN INT i := 0, n := -5;
+      BY -1 TO n - 1 DO i -:= 1 OD;
+      ASSERT (i = -8)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-12.a68 b/gcc/testsuite/algol68/execute/loop-12.a68
new file mode 100644
index 00000000000..ffd34a5945a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-12.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 0, n := 5;
+      FOR a TO n WHILE a < 3 DO i +:= 1 OD;
+      ASSERT (i = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-13.a68 b/gcc/testsuite/algol68/execute/loop-13.a68
new file mode 100644
index 00000000000..dbbd9b966c8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-13.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 0;
+      FOR a FROM 2 BY 1 WHILE a <= 10
+      DO i +:= 1 OD;
+      ASSERT (i = 9)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-14.a68 b/gcc/testsuite/algol68/execute/loop-14.a68
new file mode 100644
index 00000000000..bf06f986adc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-14.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# The while-part shall not be elaborated if the iterator is exhausted.  #
+BEGIN STRING s = "abc", INT j := 0;
+      FOR i TO UPB s WHILE s[i] /= "x"
+      DO j +:= 1 OD;
+      ASSERT (j = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-2.a68 b/gcc/testsuite/algol68/execute/loop-2.a68
new file mode 100644
index 00000000000..a92efb39875
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-2.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# While loop.  #
+BEGIN INT i := 0;
+      WHILE INT j = 5; i < j
+      DO i +:= 1 OD;
+      ASSERT (i = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-3.a68 b/gcc/testsuite/algol68/execute/loop-3.a68
new file mode 100644
index 00000000000..63b3e203a52
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-3.a68
@@ -0,0 +1,14 @@
+# { dg-options "-fstropping=upper" }  #
+# Nested loops.  #
+BEGIN INT i := 10, res := 0;
+      WHILE i > 0
+      DO INT j := 10;
+         WHILE j > 0
+         DO res +:= 1;
+            j -:= 1
+         OD;
+         ASSERT (j = 0);
+         i -:= 1;
+      OD;
+      ASSERT (i = 0 AND res = 100)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-4.a68 b/gcc/testsuite/algol68/execute/loop-4.a68
new file mode 100644
index 00000000000..491e569b2b9
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-4.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+# Nested loops and j on outside range.  #
+BEGIN INT i := 10, j := 10, res := 0;
+      WHILE i > 0
+      DO j := 10;
+         WHILE j > 0
+         DO res +:= 1;
+            j -:= 1
+         OD;
+         i -:= 1
+      OD;
+      ASSERT (i = 0 AND j = 0 AND res = 100)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-5.a68 b/gcc/testsuite/algol68/execute/loop-5.a68
new file mode 100644
index 00000000000..ca0cae64430
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-5.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Skip in loop.  #
+BEGIN INT i := 0;
+      WHILE i +:= 1; i < 10
+      DO SKIP OD;
+      ASSERT (i = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-6.a68 b/gcc/testsuite/algol68/execute/loop-6.a68
new file mode 100644
index 00000000000..216a5643aec
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-6.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# The range of the while-part shall cover the do-part.  #
+BEGIN INT i := 0;
+      WHILE INT incr = 2; i < 10
+      DO i +:= incr OD;
+      ASSERT (i = 10)
+END
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 44/47] a68: testsuite: execution tests 2/2
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (42 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 43/47] a68: testsuite: execution tests 1/2 Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 45/47] a68: testsuite: compilation tests Jose E. Marchesi
                   ` (3 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/testsuite/ChangeLog

	* algol68/execute/loop-7.a68: New file.
	* algol68/execute/loop-8.a68: Likewise.
	* algol68/execute/loop-9.a68: Likewise.
	* algol68/execute/loop-overflow-underflow.a68: Likewise.
	* algol68/execute/lt-int-1.a68: Likewise.
	* algol68/execute/lt-string-stride-1.a68: Likewise.
	* algol68/execute/lwb-1.a68: Likewise.
	* algol68/execute/minus-int-1.a68: Likewise.
	* algol68/execute/minusab-1.a68: Likewise.
	* algol68/execute/minusab-2.a68: Likewise.
	* algol68/execute/minusab-3.a68: Likewise.
	* algol68/execute/minusab-4.a68: Likewise.
	* algol68/execute/mod-int-1.a68: Likewise.
	* algol68/execute/modab-1.a68: Likewise.
	* algol68/execute/modab-2.a68: Likewise.
	* algol68/execute/mode-indication-1.a68: Likewise.
	* algol68/execute/mult-char-1.a68: Likewise.
	* algol68/execute/mult-int-1.a68: Likewise.
	* algol68/execute/mult-string-1.a68: Likewise.
	* algol68/execute/mult-string-2.a68: Likewise.
	* algol68/execute/mult-string-3.a68: Likewise.
	* algol68/execute/mult-string-4.a68: Likewise.
	* algol68/execute/multab-1.a68: Likewise.
	* algol68/execute/multab-2.a68: Likewise.
	* algol68/execute/multab-3.a68: Likewise.
	* algol68/execute/mutual-recursion-1.a68: Likewise.
	* algol68/execute/ne-bits-1.a68: Likewise.
	* algol68/execute/ne-char-char-1.a68: Likewise.
	* algol68/execute/ne-int-1.a68: Likewise.
	* algol68/execute/ne-string-1.a68: Likewise.
	* algol68/execute/neg-int-1.a68: Likewise.
	* algol68/execute/not-bits-1.a68: Likewise.
	* algol68/execute/odd-1.a68: Likewise.
	* algol68/execute/op-1.a68: Likewise.
	* algol68/execute/op-2.a68: Likewise.
	* algol68/execute/op-3.a68: Likewise.
	* algol68/execute/operator-declaration-1.a68: Likewise.
	* algol68/execute/or-bits-1.a68: Likewise.
	* algol68/execute/orf-1.a68: Likewise.
	* algol68/execute/over-int-1.a68: Likewise.
	* algol68/execute/overab-1.a68: Likewise.
	* algol68/execute/overab-2.a68: Likewise.
	* algol68/execute/particular-program-1.a68: Likewise.
	* algol68/execute/plus-char-1.a68: Likewise.
	* algol68/execute/plus-int-1.a68: Likewise.
	* algol68/execute/plus-string-1.a68: Likewise.
	* algol68/execute/plus-string-2.a68: Likewise.
	* algol68/execute/plus-string-stride-1.a68: Likewise.
	* algol68/execute/plusab-1.a68: Likewise.
	* algol68/execute/plusab-2.a68: Likewise.
	* algol68/execute/plusab-3.a68: Likewise.
	* algol68/execute/plusab-4.a68: Likewise.
	* algol68/execute/plusab-string-1.a68: Likewise.
	* algol68/execute/plusto-char-1.a68: Likewise.
	* algol68/execute/plusto-string-1.a68: Likewise.
	* algol68/execute/posix-argc-argv-1.a68: Likewise.
	* algol68/execute/posix-fopen-1.a68: Likewise.
	* algol68/execute/posix-fputc-fputs-1.a68: Likewise.
	* algol68/execute/posix-getenv-1.a68: Likewise.
	* algol68/execute/posix-perror-1.a68: Likewise.
	* algol68/execute/posix-putchar-1.a68: Likewise.
	* algol68/execute/posix-stdinouterr-1.a68: Likewise.
	* algol68/execute/posix-strerror-1.a68: Likewise.
	* algol68/execute/posix-stride-1.a68: Likewise.
	* algol68/execute/pow-int-1.a68: Likewise.
	* algol68/execute/pow-real-1.a68: Likewise.
	* algol68/execute/proc-1.a68: Likewise.
	* algol68/execute/proc-10.a68: Likewise.
	* algol68/execute/proc-12.a68: Likewise.
	* algol68/execute/proc-13.a68: Likewise.
	* algol68/execute/proc-14.a68: Likewise.
	* algol68/execute/proc-15.a68: Likewise.
	* algol68/execute/proc-16.a68: Likewise.
	* algol68/execute/proc-17.a68: Likewise.
	* algol68/execute/proc-18.a68: Likewise.
	* algol68/execute/proc-19.a68: Likewise.
	* algol68/execute/proc-2.a68: Likewise.
	* algol68/execute/proc-20.a68: Likewise.
	* algol68/execute/proc-21.a68: Likewise.
	* algol68/execute/proc-22.a68: Likewise.
	* algol68/execute/proc-23.a68: Likewise.
	* algol68/execute/proc-25.a68: Likewise.
	* algol68/execute/proc-26.a68: Likewise.
	* algol68/execute/proc-27.a68: Likewise.
	* algol68/execute/proc-28.a68: Likewise.
	* algol68/execute/proc-29.a68: Likewise.
	* algol68/execute/proc-3.a68: Likewise.
	* algol68/execute/proc-4.a68: Likewise.
	* algol68/execute/proc-5.a68: Likewise.
	* algol68/execute/proc-6.a68: Likewise.
	* algol68/execute/proc-7.a68: Likewise.
	* algol68/execute/proc-8.a68: Likewise.
	* algol68/execute/procedured-goto-1.a68: Likewise.
	* algol68/execute/quine.a68: Likewise.
	* algol68/execute/random-1.a68: Likewise.
	* algol68/execute/re-im-1.a68: Likewise.
	* algol68/execute/rela-string-1.a68: Likewise.
	* algol68/execute/repr-1.a68: Likewise.
	* algol68/execute/round-1.a68: Likewise.
	* algol68/execute/row-display-1.a68: Likewise.
	* algol68/execute/row-display-2.a68: Likewise.
	* algol68/execute/row-display-3.a68: Likewise.
	* algol68/execute/row-display-4.a68: Likewise.
	* algol68/execute/row-display-5.a68: Likewise.
	* algol68/execute/rowing-1.a68: Likewise.
	* algol68/execute/rowing-10.a68: Likewise.
	* algol68/execute/rowing-11.a68: Likewise.
	* algol68/execute/rowing-12.a68: Likewise.
	* algol68/execute/rowing-13.a68: Likewise.
	* algol68/execute/rowing-2.a68: Likewise.
	* algol68/execute/rowing-3.a68: Likewise.
	* algol68/execute/rowing-4.a68: Likewise.
	* algol68/execute/rowing-5.a68: Likewise.
	* algol68/execute/rowing-6.a68: Likewise.
	* algol68/execute/rowing-7.a68: Likewise.
	* algol68/execute/rowing-8.a68: Likewise.
	* algol68/execute/rowing-9.a68: Likewise.
	* algol68/execute/selection-1.a68: Likewise.
	* algol68/execute/selection-2.a68: Likewise.
	* algol68/execute/selection-3.a68: Likewise.
	* algol68/execute/selection-4.a68: Likewise.
	* algol68/execute/selection-5.a68: Likewise.
	* algol68/execute/selection-multiple-1.a68: Likewise.
	* algol68/execute/selection-multiple-2.a68: Likewise.
	* algol68/execute/serial-clause-1.a68: Likewise.
	* algol68/execute/serial-clause-10.a68: Likewise.
	* algol68/execute/serial-clause-2.a68: Likewise.
	* algol68/execute/serial-clause-3.a68: Likewise.
	* algol68/execute/serial-clause-4.a68: Likewise.
	* algol68/execute/serial-clause-5.a68: Likewise.
	* algol68/execute/serial-clause-6.a68: Likewise.
	* algol68/execute/serial-clause-7.a68: Likewise.
	* algol68/execute/serial-clause-8.a68: Likewise.
	* algol68/execute/serial-clause-9.a68: Likewise.
	* algol68/execute/serial-dsa-1.a68: Likewise.
	* algol68/execute/serial-dsa-2.a68: Likewise.
	* algol68/execute/serial-dsa-3.a68: Likewise.
	* algol68/execute/serial-dsa-4.a68: Likewise.
	* algol68/execute/serial-dsa-5.a68: Likewise.
	* algol68/execute/serial-dsa-6.a68: Likewise.
	* algol68/execute/sign-int-1.a68: Likewise.
	* algol68/execute/sign-real-1.a68: Likewise.
	* algol68/execute/sin-1.a68: Likewise.
	* algol68/execute/skip-1.a68: Likewise.
	* algol68/execute/skip-2.a68: Likewise.
	* algol68/execute/skip-struct-1.a68: Likewise.
	* algol68/execute/slice-indexing-1.a68: Likewise.
	* algol68/execute/slice-indexing-2.a68: Likewise.
	* algol68/execute/slice-indexing-3.a68: Likewise.
	* algol68/execute/slice-indexing-4.a68: Likewise.
	* algol68/execute/slice-indexing-5.a68: Likewise.
	* algol68/execute/slice-indexing-6.a68: Likewise.
	* algol68/execute/slice-indexing-7.a68: Likewise.
	* algol68/execute/sqrt-1.a68: Likewise.
	* algol68/execute/string-1.a68: Likewise.
	* algol68/execute/string-2.a68: Likewise.
	* algol68/execute/string-4.a68: Likewise.
	* algol68/execute/string-break-1.a68: Likewise.
	* algol68/execute/struct-self-1.a68: Likewise.
	* algol68/execute/struct-self-2.a68: Likewise.
	* algol68/execute/struct-self-3.a68: Likewise.
	* algol68/execute/structure-display-1.a68: Likewise.
	* algol68/execute/structure-display-2.a68: Likewise.
	* algol68/execute/structure-display-3.a68: Likewise.
	* algol68/execute/structure-display-4.a68: Likewise.
	* algol68/execute/structure-display-5.a68: Likewise.
	* algol68/execute/tan-1.a68: Likewise.
	* algol68/execute/timesab-string-1.a68: Likewise.
	* algol68/execute/trimmer-1.a68: Likewise.
	* algol68/execute/trimmer-10.a68: Likewise.
	* algol68/execute/trimmer-2.a68: Likewise.
	* algol68/execute/trimmer-3.a68: Likewise.
	* algol68/execute/trimmer-4.a68: Likewise.
	* algol68/execute/trimmer-5.a68: Likewise.
	* algol68/execute/trimmer-6.a68: Likewise.
	* algol68/execute/trimmer-7.a68: Likewise.
	* algol68/execute/trimmer-8.a68: Likewise.
	* algol68/execute/trimmer-9.a68: Likewise.
	* algol68/execute/trimmer-matrix-1.a68: Likewise.
	* algol68/execute/trimmer-matrix-2.a68: Likewise.
	* algol68/execute/trimmer-matrix-3.a68: Likewise.
	* algol68/execute/trimmer-matrix-4.a68: Likewise.
	* algol68/execute/trimmer-matrix-5.a68: Likewise.
	* algol68/execute/trimmer-matrix-6.a68: Likewise.
	* algol68/execute/trimmer-name-1.a68: Likewise.
	* algol68/execute/undefined-1.a68: Likewise.
	* algol68/execute/undefined-2.a68: Likewise.
	* algol68/execute/undefined-3.a68: Likewise.
	* algol68/execute/undefined-4.a68: Likewise.
	* algol68/execute/undefined-5.a68: Likewise.
	* algol68/execute/uniting-1.a68: Likewise.
	* algol68/execute/uniting-2.a68: Likewise.
	* algol68/execute/uniting-3.a68: Likewise.
	* algol68/execute/uniting-4.a68: Likewise.
	* algol68/execute/up-down-bits-1.a68: Likewise.
	* algol68/execute/upb-1.a68: Likewise.
	* algol68/execute/vacuum-1.a68: Likewise.
	* algol68/execute/variable-declaration-1.a68: Likewise.
	* algol68/execute/variable-declaration-2.a68: Likewise.
	* algol68/execute/variable-declaration-3.a68: Likewise.
	* algol68/execute/variable-declaration-4.a68: Likewise.
	* algol68/execute/variable-declaration-5.a68: Likewise.
	* algol68/execute/variable-declaration-6.a68: Likewise.
	* algol68/execute/variable-declaration-heap-1.a68: Likewise.
	* algol68/execute/variable-declaration-heap-2.a68: Likewise.
	* algol68/execute/variable-declaration-multiple-1.a68: Likewise.
	* algol68/execute/variable-declaration-multiple-2.a68: Likewise.
	* algol68/execute/variable-declaration-multiple-3.a68: Likewise.
	* algol68/execute/variable-declaration-multiple-4.a68: Likewise.
	* algol68/execute/variable-declaration-multiple-5.a68: Likewise.
	* algol68/execute/variable-declaration-multiple-6.a68: Likewise.
	* algol68/execute/variable-declaration-multiple-7.a68: Likewise.
	* algol68/execute/variable-declaration-multiple-8.a68: Likewise.
	* algol68/execute/variable-declaration-multiple-9.a68: Likewise.
	* algol68/execute/voiding-1.a68: Likewise.
	* algol68/execute/widening-1.a68: Likewise.
	* algol68/execute/widening-2.a68: Likewise.
	* algol68/execute/widening-bits-1.a68: Likewise.
	* algol68/execute/widening-bits-2.a68: Likewise.
	* algol68/execute/widening-bits-3.a68: Likewise.
	* algol68/execute/xor-bits-1.a68: Likewise.
---
 gcc/testsuite/algol68/execute/loop-7.a68      |  5 ++
 gcc/testsuite/algol68/execute/loop-8.a68      |  5 ++
 gcc/testsuite/algol68/execute/loop-9.a68      |  5 ++
 .../execute/loop-overflow-underflow.a68       | 55 +++++++++++++++++++
 gcc/testsuite/algol68/execute/lt-int-1.a68    | 10 ++++
 .../algol68/execute/lt-string-stride-1.a68    |  7 +++
 gcc/testsuite/algol68/execute/lwb-1.a68       |  6 ++
 gcc/testsuite/algol68/execute/minus-int-1.a68 | 10 ++++
 gcc/testsuite/algol68/execute/minusab-1.a68   | 32 +++++++++++
 gcc/testsuite/algol68/execute/minusab-2.a68   | 20 +++++++
 gcc/testsuite/algol68/execute/minusab-3.a68   |  5 ++
 gcc/testsuite/algol68/execute/minusab-4.a68   |  6 ++
 gcc/testsuite/algol68/execute/mod-int-1.a68   | 10 ++++
 gcc/testsuite/algol68/execute/modab-1.a68     | 10 ++++
 gcc/testsuite/algol68/execute/modab-2.a68     |  5 ++
 .../algol68/execute/mode-indication-1.a68     | 10 ++++
 gcc/testsuite/algol68/execute/mult-char-1.a68 |  5 ++
 gcc/testsuite/algol68/execute/mult-int-1.a68  | 10 ++++
 .../algol68/execute/mult-string-1.a68         | 13 +++++
 .../algol68/execute/mult-string-2.a68         | 13 +++++
 .../algol68/execute/mult-string-3.a68         | 13 +++++
 .../algol68/execute/mult-string-4.a68         |  4 ++
 gcc/testsuite/algol68/execute/multab-1.a68    | 31 +++++++++++
 gcc/testsuite/algol68/execute/multab-2.a68    | 31 +++++++++++
 gcc/testsuite/algol68/execute/multab-3.a68    |  6 ++
 .../algol68/execute/mutual-recursion-1.a68    |  6 ++
 gcc/testsuite/algol68/execute/ne-bits-1.a68   |  9 +++
 .../algol68/execute/ne-char-char-1.a68        |  3 +
 gcc/testsuite/algol68/execute/ne-int-1.a68    | 10 ++++
 gcc/testsuite/algol68/execute/ne-string-1.a68 | 15 +++++
 gcc/testsuite/algol68/execute/neg-int-1.a68   | 10 ++++
 gcc/testsuite/algol68/execute/not-bits-1.a68  | 13 +++++
 gcc/testsuite/algol68/execute/odd-1.a68       |  8 +++
 gcc/testsuite/algol68/execute/op-1.a68        |  5 ++
 gcc/testsuite/algol68/execute/op-2.a68        |  4 ++
 gcc/testsuite/algol68/execute/op-3.a68        |  9 +++
 .../execute/operator-declaration-1.a68        | 13 +++++
 gcc/testsuite/algol68/execute/or-bits-1.a68   | 18 ++++++
 gcc/testsuite/algol68/execute/orf-1.a68       |  4 ++
 gcc/testsuite/algol68/execute/over-int-1.a68  | 10 ++++
 gcc/testsuite/algol68/execute/overab-1.a68    | 12 ++++
 gcc/testsuite/algol68/execute/overab-2.a68    |  5 ++
 .../algol68/execute/particular-program-1.a68  |  4 ++
 gcc/testsuite/algol68/execute/plus-char-1.a68 |  4 ++
 gcc/testsuite/algol68/execute/plus-int-1.a68  | 10 ++++
 .../algol68/execute/plus-string-1.a68         | 11 ++++
 .../algol68/execute/plus-string-2.a68         | 11 ++++
 .../algol68/execute/plus-string-stride-1.a68  |  7 +++
 gcc/testsuite/algol68/execute/plusab-1.a68    | 34 ++++++++++++
 gcc/testsuite/algol68/execute/plusab-2.a68    | 20 +++++++
 gcc/testsuite/algol68/execute/plusab-3.a68    |  5 ++
 gcc/testsuite/algol68/execute/plusab-4.a68    |  6 ++
 .../algol68/execute/plusab-string-1.a68       |  7 +++
 .../algol68/execute/plusto-char-1.a68         |  7 +++
 .../algol68/execute/plusto-string-1.a68       |  6 ++
 .../algol68/execute/posix-argc-argv-1.a68     |  7 +++
 .../algol68/execute/posix-fopen-1.a68         |  4 ++
 .../algol68/execute/posix-fputc-fputs-1.a68   |  8 +++
 .../algol68/execute/posix-getenv-1.a68        |  4 ++
 .../algol68/execute/posix-perror-1.a68        |  8 +++
 .../algol68/execute/posix-putchar-1.a68       |  6 ++
 .../algol68/execute/posix-stdinouterr-1.a68   |  5 ++
 .../algol68/execute/posix-strerror-1.a68      |  4 ++
 .../algol68/execute/posix-stride-1.a68        | 14 +++++
 gcc/testsuite/algol68/execute/pow-int-1.a68   | 10 ++++
 gcc/testsuite/algol68/execute/pow-real-1.a68  |  7 +++
 gcc/testsuite/algol68/execute/proc-1.a68      |  4 ++
 gcc/testsuite/algol68/execute/proc-10.a68     |  4 ++
 gcc/testsuite/algol68/execute/proc-12.a68     |  6 ++
 gcc/testsuite/algol68/execute/proc-13.a68     |  6 ++
 gcc/testsuite/algol68/execute/proc-14.a68     |  8 +++
 gcc/testsuite/algol68/execute/proc-15.a68     |  8 +++
 gcc/testsuite/algol68/execute/proc-16.a68     |  8 +++
 gcc/testsuite/algol68/execute/proc-17.a68     | 11 ++++
 gcc/testsuite/algol68/execute/proc-18.a68     |  6 ++
 gcc/testsuite/algol68/execute/proc-19.a68     |  5 ++
 gcc/testsuite/algol68/execute/proc-2.a68      |  6 ++
 gcc/testsuite/algol68/execute/proc-20.a68     |  5 ++
 gcc/testsuite/algol68/execute/proc-21.a68     |  8 +++
 gcc/testsuite/algol68/execute/proc-22.a68     |  7 +++
 gcc/testsuite/algol68/execute/proc-23.a68     |  8 +++
 gcc/testsuite/algol68/execute/proc-25.a68     |  8 +++
 gcc/testsuite/algol68/execute/proc-26.a68     |  6 ++
 gcc/testsuite/algol68/execute/proc-27.a68     |  5 ++
 gcc/testsuite/algol68/execute/proc-28.a68     | 10 ++++
 gcc/testsuite/algol68/execute/proc-29.a68     |  5 ++
 gcc/testsuite/algol68/execute/proc-3.a68      |  4 ++
 gcc/testsuite/algol68/execute/proc-4.a68      |  5 ++
 gcc/testsuite/algol68/execute/proc-5.a68      |  5 ++
 gcc/testsuite/algol68/execute/proc-6.a68      |  6 ++
 gcc/testsuite/algol68/execute/proc-7.a68      |  5 ++
 gcc/testsuite/algol68/execute/proc-8.a68      |  4 ++
 .../algol68/execute/procedured-goto-1.a68     | 11 ++++
 gcc/testsuite/algol68/execute/quine.a68       |  2 +
 gcc/testsuite/algol68/execute/random-1.a68    |  7 +++
 gcc/testsuite/algol68/execute/re-im-1.a68     |  8 +++
 .../algol68/execute/rela-string-1.a68         |  7 +++
 gcc/testsuite/algol68/execute/repr-1.a68      |  3 +
 gcc/testsuite/algol68/execute/round-1.a68     |  8 +++
 .../algol68/execute/row-display-1.a68         | 13 +++++
 .../algol68/execute/row-display-2.a68         | 13 +++++
 .../algol68/execute/row-display-3.a68         | 15 +++++
 .../algol68/execute/row-display-4.a68         | 16 ++++++
 .../algol68/execute/row-display-5.a68         | 10 ++++
 gcc/testsuite/algol68/execute/rowing-1.a68    |  5 ++
 gcc/testsuite/algol68/execute/rowing-10.a68   |  8 +++
 gcc/testsuite/algol68/execute/rowing-11.a68   |  9 +++
 gcc/testsuite/algol68/execute/rowing-12.a68   |  6 ++
 gcc/testsuite/algol68/execute/rowing-13.a68   |  6 ++
 gcc/testsuite/algol68/execute/rowing-2.a68    |  6 ++
 gcc/testsuite/algol68/execute/rowing-3.a68    |  7 +++
 gcc/testsuite/algol68/execute/rowing-4.a68    |  8 +++
 gcc/testsuite/algol68/execute/rowing-5.a68    |  8 +++
 gcc/testsuite/algol68/execute/rowing-6.a68    |  5 ++
 gcc/testsuite/algol68/execute/rowing-7.a68    |  6 ++
 gcc/testsuite/algol68/execute/rowing-8.a68    | 12 ++++
 gcc/testsuite/algol68/execute/rowing-9.a68    |  7 +++
 gcc/testsuite/algol68/execute/selection-1.a68 |  7 +++
 gcc/testsuite/algol68/execute/selection-2.a68 | 14 +++++
 gcc/testsuite/algol68/execute/selection-3.a68 | 12 ++++
 gcc/testsuite/algol68/execute/selection-4.a68 | 19 +++++++
 gcc/testsuite/algol68/execute/selection-5.a68 |  6 ++
 .../algol68/execute/selection-multiple-1.a68  | 12 ++++
 .../algol68/execute/selection-multiple-2.a68  | 18 ++++++
 .../algol68/execute/serial-clause-1.a68       |  8 +++
 .../algol68/execute/serial-clause-10.a68      |  5 ++
 .../algol68/execute/serial-clause-2.a68       |  7 +++
 .../algol68/execute/serial-clause-3.a68       |  5 ++
 .../algol68/execute/serial-clause-4.a68       |  7 +++
 .../algol68/execute/serial-clause-5.a68       |  7 +++
 .../algol68/execute/serial-clause-6.a68       | 10 ++++
 .../algol68/execute/serial-clause-7.a68       | 10 ++++
 .../algol68/execute/serial-clause-8.a68       | 10 ++++
 .../algol68/execute/serial-clause-9.a68       |  9 +++
 .../algol68/execute/serial-dsa-1.a68          | 18 ++++++
 .../algol68/execute/serial-dsa-2.a68          |  5 ++
 .../algol68/execute/serial-dsa-3.a68          | 12 ++++
 .../algol68/execute/serial-dsa-4.a68          |  4 ++
 .../algol68/execute/serial-dsa-5.a68          |  3 +
 .../algol68/execute/serial-dsa-6.a68          |  4 ++
 gcc/testsuite/algol68/execute/sign-int-1.a68  | 28 ++++++++++
 gcc/testsuite/algol68/execute/sign-real-1.a68 | 17 ++++++
 gcc/testsuite/algol68/execute/sin-1.a68       |  8 +++
 gcc/testsuite/algol68/execute/skip-1.a68      | 13 +++++
 gcc/testsuite/algol68/execute/skip-2.a68      |  7 +++
 .../algol68/execute/skip-struct-1.a68         |  7 +++
 .../algol68/execute/slice-indexing-1.a68      | 10 ++++
 .../algol68/execute/slice-indexing-2.a68      | 10 ++++
 .../algol68/execute/slice-indexing-3.a68      | 10 ++++
 .../algol68/execute/slice-indexing-4.a68      | 10 ++++
 .../algol68/execute/slice-indexing-5.a68      |  4 ++
 .../algol68/execute/slice-indexing-6.a68      |  5 ++
 .../algol68/execute/slice-indexing-7.a68      |  4 ++
 gcc/testsuite/algol68/execute/sqrt-1.a68      |  8 +++
 gcc/testsuite/algol68/execute/string-1.a68    |  6 ++
 gcc/testsuite/algol68/execute/string-2.a68    | 13 +++++
 gcc/testsuite/algol68/execute/string-4.a68    |  6 ++
 .../algol68/execute/string-break-1.a68        |  8 +++
 .../algol68/execute/struct-self-1.a68         |  5 ++
 .../algol68/execute/struct-self-2.a68         |  6 ++
 .../algol68/execute/struct-self-3.a68         |  7 +++
 .../algol68/execute/structure-display-1.a68   |  9 +++
 .../algol68/execute/structure-display-2.a68   |  6 ++
 .../algol68/execute/structure-display-3.a68   |  7 +++
 .../algol68/execute/structure-display-4.a68   |  8 +++
 .../algol68/execute/structure-display-5.a68   | 10 ++++
 gcc/testsuite/algol68/execute/tan-1.a68       |  8 +++
 .../algol68/execute/timesab-string-1.a68      |  7 +++
 gcc/testsuite/algol68/execute/trimmer-1.a68   |  7 +++
 gcc/testsuite/algol68/execute/trimmer-10.a68  | 14 +++++
 gcc/testsuite/algol68/execute/trimmer-2.a68   |  7 +++
 gcc/testsuite/algol68/execute/trimmer-3.a68   |  7 +++
 gcc/testsuite/algol68/execute/trimmer-4.a68   |  7 +++
 gcc/testsuite/algol68/execute/trimmer-5.a68   |  7 +++
 gcc/testsuite/algol68/execute/trimmer-6.a68   |  7 +++
 gcc/testsuite/algol68/execute/trimmer-7.a68   |  7 +++
 gcc/testsuite/algol68/execute/trimmer-8.a68   |  9 +++
 gcc/testsuite/algol68/execute/trimmer-9.a68   |  7 +++
 .../algol68/execute/trimmer-matrix-1.a68      |  8 +++
 .../algol68/execute/trimmer-matrix-2.a68      |  8 +++
 .../algol68/execute/trimmer-matrix-3.a68      |  9 +++
 .../algol68/execute/trimmer-matrix-4.a68      |  9 +++
 .../algol68/execute/trimmer-matrix-5.a68      |  9 +++
 .../algol68/execute/trimmer-matrix-6.a68      |  9 +++
 .../algol68/execute/trimmer-name-1.a68        |  7 +++
 gcc/testsuite/algol68/execute/undefined-1.a68 | 10 ++++
 gcc/testsuite/algol68/execute/undefined-2.a68 |  9 +++
 gcc/testsuite/algol68/execute/undefined-3.a68 |  6 ++
 gcc/testsuite/algol68/execute/undefined-4.a68 |  8 +++
 gcc/testsuite/algol68/execute/undefined-5.a68 |  9 +++
 gcc/testsuite/algol68/execute/uniting-1.a68   | 11 ++++
 gcc/testsuite/algol68/execute/uniting-2.a68   | 11 ++++
 gcc/testsuite/algol68/execute/uniting-3.a68   | 11 ++++
 gcc/testsuite/algol68/execute/uniting-4.a68   |  5 ++
 .../algol68/execute/up-down-bits-1.a68        | 33 +++++++++++
 gcc/testsuite/algol68/execute/upb-1.a68       |  6 ++
 gcc/testsuite/algol68/execute/vacuum-1.a68    |  4 ++
 .../execute/variable-declaration-1.a68        |  5 ++
 .../execute/variable-declaration-2.a68        |  5 ++
 .../execute/variable-declaration-3.a68        |  5 ++
 .../execute/variable-declaration-4.a68        |  5 ++
 .../execute/variable-declaration-5.a68        |  5 ++
 .../execute/variable-declaration-6.a68        |  5 ++
 .../execute/variable-declaration-heap-1.a68   |  4 ++
 .../execute/variable-declaration-heap-2.a68   |  4 ++
 .../variable-declaration-multiple-1.a68       |  5 ++
 .../variable-declaration-multiple-2.a68       |  6 ++
 .../variable-declaration-multiple-3.a68       |  6 ++
 .../variable-declaration-multiple-4.a68       |  6 ++
 .../variable-declaration-multiple-5.a68       |  8 +++
 .../variable-declaration-multiple-6.a68       |  8 +++
 .../variable-declaration-multiple-7.a68       |  8 +++
 .../variable-declaration-multiple-8.a68       | 10 ++++
 .../variable-declaration-multiple-9.a68       |  4 ++
 gcc/testsuite/algol68/execute/voiding-1.a68   |  4 ++
 gcc/testsuite/algol68/execute/widening-1.a68  |  6 ++
 gcc/testsuite/algol68/execute/widening-2.a68  |  6 ++
 .../algol68/execute/widening-bits-1.a68       |  7 +++
 .../algol68/execute/widening-bits-2.a68       |  7 +++
 .../algol68/execute/widening-bits-3.a68       |  7 +++
 gcc/testsuite/algol68/execute/xor-bits-1.a68  | 18 ++++++
 221 files changed, 1933 insertions(+)
 create mode 100644 gcc/testsuite/algol68/execute/loop-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/loop-overflow-underflow.a68
 create mode 100644 gcc/testsuite/algol68/execute/lt-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lt-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/lwb-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/minus-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/minusab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/minusab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/minusab-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/minusab-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/mod-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/modab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/modab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/mode-indication-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-string-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-string-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/mult-string-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/multab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/multab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/multab-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/mutual-recursion-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ne-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ne-char-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ne-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/ne-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/neg-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/not-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/odd-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/op-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/op-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/op-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/operator-declaration-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/or-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/orf-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/over-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/overab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/overab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/particular-program-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-string-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/plus-string-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusab-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusto-char-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/plusto-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-argc-argv-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-fopen-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-fputc-fputs-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-getenv-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-perror-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-putchar-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-stdinouterr-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-strerror-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/posix-stride-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/pow-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/pow-real-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-12.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-13.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-14.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-15.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-16.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-17.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-18.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-19.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-20.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-21.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-22.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-23.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-25.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-26.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-27.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-28.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-29.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/proc-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/procedured-goto-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/quine.a68
 create mode 100644 gcc/testsuite/algol68/execute/random-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/re-im-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/rela-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/repr-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/round-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/row-display-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-11.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-12.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-13.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/rowing-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/selection-multiple-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-clause-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/sign-int-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/sign-real-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/sin-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/skip-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/skip-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/skip-struct-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/slice-indexing-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/sqrt-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/string-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/string-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/string-break-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/struct-self-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/struct-self-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/struct-self-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/structure-display-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/tan-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/timesab-string-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-10.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-matrix-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/trimmer-name-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/undefined-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/uniting-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/uniting-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/uniting-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/uniting-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/up-down-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/upb-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/vacuum-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-heap-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-heap-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-4.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-5.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-6.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-7.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-8.a68
 create mode 100644 gcc/testsuite/algol68/execute/variable-declaration-multiple-9.a68
 create mode 100644 gcc/testsuite/algol68/execute/voiding-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-bits-1.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-bits-2.a68
 create mode 100644 gcc/testsuite/algol68/execute/widening-bits-3.a68
 create mode 100644 gcc/testsuite/algol68/execute/xor-bits-1.a68

diff --git a/gcc/testsuite/algol68/execute/loop-7.a68 b/gcc/testsuite/algol68/execute/loop-7.a68
new file mode 100644
index 00000000000..3d5112e1b4b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-7.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 0, n := 5;
+      TO n + 1 DO i +:= 1 OD;
+      ASSERT (i = 6)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-8.a68 b/gcc/testsuite/algol68/execute/loop-8.a68
new file mode 100644
index 00000000000..e7d090160ae
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-8.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 0, n := 2;
+      FOR a TO n + 1 DO i +:= a OD;
+      ASSERT (i = 1 + 2 + 3)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-9.a68 b/gcc/testsuite/algol68/execute/loop-9.a68
new file mode 100644
index 00000000000..a101db250f9
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-9.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 0, n := 2;
+      FOR a FROM n TO n + 2 DO i +:= a OD;
+      ASSERT (i = 2 + 3 + 4)
+END
diff --git a/gcc/testsuite/algol68/execute/loop-overflow-underflow.a68 b/gcc/testsuite/algol68/execute/loop-overflow-underflow.a68
new file mode 100644
index 00000000000..1ace68aff0f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/loop-overflow-underflow.a68
@@ -0,0 +1,55 @@
+{ Test for overflow/underflow in loops with implicit and explicit
+  iterators. }
+
+begin int count;
+
+      { Overflow.  }
+      count := 0;
+      by 1 while true do count +:= 1 od;
+      assert (count = max_int);
+
+      count := 0;
+      from max_int do count +:= 1 od;
+      assert (count = 1);
+      count := 0;
+
+      by max_int do count +:= 1 od;
+      assert (count = 1);
+
+      count := 0;
+      for i by max_int do count +:= 1 od;
+      assert (count = 1);
+
+      count := 0;
+      by max_int % 2 do count +:= 1 od;
+      assert (count = 3);
+
+      count := 0;
+      by max_int - 1 do count +:= 1 od;
+      assert (count = 2);
+
+      { Underflow.  }
+      count := 0;
+      by -1 while true do count +:= 1 od;
+      assert (count = -min_int + 2);
+
+      count := 0;
+      from min_int by -1 do count +:= 1 od;
+      assert (count = 1);
+      count := 0;
+
+      by min_int do count +:= 1 od;
+      assert (count = 2);
+
+      count := 0;
+      for i by min_int do count +:= 1 od;
+      assert (count = 2);
+
+      count := 0;
+      by min_int % 2 do count +:= 1 od;
+      assert (count = 3);
+
+      count := 0;
+      by min_int + 1 do count +:= 1 od;
+      assert (count = 2)
+end
diff --git a/gcc/testsuite/algol68/execute/lt-int-1.a68 b/gcc/testsuite/algol68/execute/lt-int-1.a68
new file mode 100644
index 00000000000..c0e93028aa3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/lt-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 12;
+      LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+      SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+      ASSERT (i < 13);
+      ASSERT (ii LT LONG 13);
+      ASSERT (iii < LONG LONG 13);
+      ASSERT (s < SHORT 13);
+      ASSERT (ss < SHORT SHORT 13)
+END
diff --git a/gcc/testsuite/algol68/execute/lt-string-stride-1.a68 b/gcc/testsuite/algol68/execute/lt-string-stride-1.a68
new file mode 100644
index 00000000000..9109f6751a9
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/lt-string-stride-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]CHAR matrix = (("1", "Z", "1"),
+                        ("4", "Y", "4"),
+                        ("7", "X", "9"));
+      ASSERT (matrix[1:3,1] < matrix[1:3,3]);
+      ASSERT (("1","4","0") < matrix[1:3,3])
+END
diff --git a/gcc/testsuite/algol68/execute/lwb-1.a68 b/gcc/testsuite/algol68/execute/lwb-1.a68
new file mode 100644
index 00000000000..c3dd5940bb1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/lwb-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (LWB "foo" = 1);
+      ASSERT (LWB "" = 1);
+      ASSERT (1 LWB "foo" = 1);
+      ASSERT (1 LWB "" = 1)
+END
diff --git a/gcc/testsuite/algol68/execute/minus-int-1.a68 b/gcc/testsuite/algol68/execute/minus-int-1.a68
new file mode 100644
index 00000000000..abaf1229ebe
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/minus-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+      SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10;
+      ASSERT (i - 2 = 8);
+      ASSERT (ii - LONG 2 = LONG 8);
+      ASSERT (iii - LONG LONG 2 = LONG LONG 8);
+      ASSERT (ss - SHORT 2 = SHORT 8);
+      ASSERT (sss - SHORT SHORT 2 = SHORT SHORT 8)
+END
diff --git a/gcc/testsuite/algol68/execute/minusab-1.a68 b/gcc/testsuite/algol68/execute/minusab-1.a68
new file mode 100644
index 00000000000..0eb1661cb98
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/minusab-1.a68
@@ -0,0 +1,32 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BEGIN INT i := 10;
+            i -:= 2;
+            ASSERT (i = 8);
+            i MINUSAB 2;
+            ASSERT (i = 6)
+      END;
+      BEGIN LONG INT i := LONG 1000;
+            i -:= LONG 100;
+            ASSERT (i = LONG 900);
+            i MINUSAB LONG 100;
+            ASSERT (i = LONG 800)
+      END;
+      BEGIN LONG LONG INT i := LONG LONG 10000;
+            i -:= LONG LONG 1000;
+            ASSERT (i = LONG LONG 9000);
+            i MINUSAB LONG LONG 1000;
+            ASSERT (i = LONG LONG 8000)
+      END;
+      BEGIN SHORT INT i := SHORT 100;
+            i -:= SHORT 10;
+            ASSERT (i = SHORT 90);
+            i MINUSAB SHORT 10;
+            ASSERT (i = SHORT 80)
+      END;
+      BEGIN SHORT SHORT INT i := SHORT SHORT 10;
+            i -:= SHORT SHORT 1;
+            ASSERT (i = SHORT SHORT 9);
+            i MINUSAB SHORT SHORT 2;
+            ASSERT (i = SHORT SHORT 7)
+      END
+END
diff --git a/gcc/testsuite/algol68/execute/minusab-2.a68 b/gcc/testsuite/algol68/execute/minusab-2.a68
new file mode 100644
index 00000000000..2fee755bf6e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/minusab-2.a68
@@ -0,0 +1,20 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BEGIN REAL i := 10.0;
+            i -:= 2.0;
+            ASSERT (i = 8.0);
+            i MINUSAB 2.0;
+            ASSERT (i = 6.0)
+      END;
+      BEGIN LONG REAL i := LONG 1000.0;
+            i -:= LONG 100.0;
+            ASSERT (i = LONG 900.0);
+            i MINUSAB LONG 100.0;
+            ASSERT (i = LONG 800.0)
+      END;
+      BEGIN LONG LONG REAL i := LONG LONG 10000.0;
+            i -:= LONG LONG 1000.0;
+            ASSERT (i = LONG LONG 9000.0);
+            i MINUSAB LONG LONG 1000.0;
+            ASSERT (i = LONG LONG 8000.0)
+      END
+END
diff --git a/gcc/testsuite/algol68/execute/minusab-3.a68 b/gcc/testsuite/algol68/execute/minusab-3.a68
new file mode 100644
index 00000000000..08d020d3f20
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/minusab-3.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := 10;
+      (((n -:= 1))) := 5;
+      ASSERT (n = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/minusab-4.a68 b/gcc/testsuite/algol68/execute/minusab-4.a68
new file mode 100644
index 00000000000..4330908f58f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/minusab-4.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT num ints := 10;
+      num ints -:= 1;
+      ASSERT (num ints = 9);
+      ASSERT ((LOC INT -:= 12) = -12)
+END
diff --git a/gcc/testsuite/algol68/execute/mod-int-1.a68 b/gcc/testsuite/algol68/execute/mod-int-1.a68
new file mode 100644
index 00000000000..0d8cfe415e4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mod-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+      SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10;
+      ASSERT (i %* 3 = 1);
+      ASSERT (ii %* LONG 3 = LONG 1);
+      ASSERT (iii %* LONG LONG 3 = LONG LONG 1);
+      ASSERT (ss %* SHORT 3 = SHORT 1);
+      ASSERT (sss MOD SHORT SHORT 3 = SHORT SHORT 1)
+END
diff --git a/gcc/testsuite/algol68/execute/modab-1.a68 b/gcc/testsuite/algol68/execute/modab-1.a68
new file mode 100644
index 00000000000..41c49b08992
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/modab-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN (SHORT SHORT INT i := SHORT SHORT 11; i MODAB SHORT SHORT 2; ASSERT (i = SHORT SHORT 1));
+      (SHORT INT i := SHORT 11; i MODAB SHORT 2; ASSERT (i = SHORT 1));
+      (INT i := 11; i MODAB 2; ASSERT (i = 1));
+      (INT i := 11; i %*:= 2; ASSERT (i = 1));
+      (LONG INT i := LONG 11; i MODAB LONG 2; ASSERT (i = LONG 1));
+      (LONG INT i := LONG 11; i %*:= LONG 2; ASSERT (i = LONG 1));
+      (LONG LONG INT i := LONG LONG 11; i MODAB LONG LONG 2; ASSERT (i = LONG LONG 1));
+      (LONG LONG INT i := LONG LONG 11; i %*:= LONG LONG 2; ASSERT (i = LONG LONG 1))
+END
diff --git a/gcc/testsuite/algol68/execute/modab-2.a68 b/gcc/testsuite/algol68/execute/modab-2.a68
new file mode 100644
index 00000000000..52fc9a12a54
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/modab-2.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := 10;
+      (((n MODAB 1))) := 5;
+      ASSERT (n = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/mode-indication-1.a68 b/gcc/testsuite/algol68/execute/mode-indication-1.a68
new file mode 100644
index 00000000000..f1dd8c28c92
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mode-indication-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT j; REAL y;
+      MODE R = REAL;
+      BEGIN MODE R = INT;
+            R i := j;
+            SKIP
+      END;
+      R x := y;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mult-char-1.a68 b/gcc/testsuite/algol68/execute/mult-char-1.a68
new file mode 100644
index 00000000000..0e3c1f4b93f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mult-char-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT ("a" * 3 = "aaa");
+      ASSERT ("" * 1 = "");
+      ASSERT ("x" * 0 = "x")
+END
diff --git a/gcc/testsuite/algol68/execute/mult-int-1.a68 b/gcc/testsuite/algol68/execute/mult-int-1.a68
new file mode 100644
index 00000000000..2da29883779
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mult-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+      SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10;
+      ASSERT (i * 2 = 20);
+      ASSERT (ii * LONG 2 = LONG 20);
+      ASSERT (iii * LONG LONG 2 = LONG LONG 20);
+      ASSERT (ss * SHORT 2 = SHORT 20);
+      ASSERT (sss * SHORT SHORT 2 = SHORT SHORT 20)
+END
diff --git a/gcc/testsuite/algol68/execute/mult-string-1.a68 b/gcc/testsuite/algol68/execute/mult-string-1.a68
new file mode 100644
index 00000000000..b0d49178bd1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mult-string-1.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING foo = "foo";
+      ASSERT (foo * -10 = "foo");
+      ASSERT (-10 * foo = "foo");
+      ASSERT (foo * 0 = "foo");
+      ASSERT (0 * foo = "foo");
+      ASSERT (foo * 1 = "foo");
+      ASSERT (1 * foo = "foo");
+      ASSERT (foo * 2 = "foofoo");
+      ASSERT (2 * foo = "foofoo");
+      ASSERT (foo * 3 = "foofoofoo");
+      ASSERT (3 * foo = "foofoofoo")
+END
diff --git a/gcc/testsuite/algol68/execute/mult-string-2.a68 b/gcc/testsuite/algol68/execute/mult-string-2.a68
new file mode 100644
index 00000000000..670dcbf16d6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mult-string-2.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []CHAR foo = ("f","o","o");
+      ASSERT (foo * -10 = "foo");
+      ASSERT (-10 * foo = "foo");
+      ASSERT (foo * 0 = "foo");
+      ASSERT (0 * foo = "foo");
+      ASSERT (foo * 1 = "foo");
+      ASSERT (1 * foo = "foo");
+      ASSERT (foo * 2 = "foofoo");
+      ASSERT (2 * foo = "foofoo");
+      ASSERT (foo * 3 = "foofoofoo");
+      ASSERT (3 * foo = "foofoofoo")
+END
diff --git a/gcc/testsuite/algol68/execute/mult-string-3.a68 b/gcc/testsuite/algol68/execute/mult-string-3.a68
new file mode 100644
index 00000000000..a8d3726d0df
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mult-string-3.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN FLEX[3]CHAR foo := ("f","o","o");
+      ASSERT (foo * -10 = "foo");
+      ASSERT (-10 * foo = "foo");
+      ASSERT (foo * 0 = "foo");
+      ASSERT (0 * foo = "foo");
+      ASSERT (foo * 1 = "foo");
+      ASSERT (1 * foo = "foo");
+      ASSERT (foo * 2 = "foofoo");
+      ASSERT (2 * foo = "foofoo");
+      ASSERT (foo * 3 = "foofoofoo");
+      ASSERT (3 * foo = "foofoofoo")
+END
diff --git a/gcc/testsuite/algol68/execute/mult-string-4.a68 b/gcc/testsuite/algol68/execute/mult-string-4.a68
new file mode 100644
index 00000000000..d5e1adb66a3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mult-string-4.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING foo = "abc";
+      ASSERT (foo[] * 2 = "abcabc")
+END
diff --git a/gcc/testsuite/algol68/execute/multab-1.a68 b/gcc/testsuite/algol68/execute/multab-1.a68
new file mode 100644
index 00000000000..355129baf65
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/multab-1.a68
@@ -0,0 +1,31 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 2;
+      i *:= 2;
+      ASSERT (i = 4);
+      i *:= 2;
+      ASSERT (i = 8);
+
+      SHORT INT s := SHORT 2;
+      s *:= SHORT 2;
+      ASSERT (s = SHORT 4);
+      s *:= SHORT 3;
+      ASSERT (s = SHORT 12);
+
+      SHORT SHORT INT ss := SHORT SHORT 2;
+      ss *:= SHORT SHORT 2;
+      ASSERT (ss = SHORT SHORT 4);
+      ss *:= SHORT SHORT 3;
+      ASSERT (ss = SHORT SHORT 12);
+
+      REF LONG INT ii = HEAP LONG INT := LONG 2;
+      ii *:= LONG 2;
+      ASSERT (ii = LONG 4);
+      ii *:= LONG 2;
+      ASSERT (ii = LONG 8);
+
+      LONG LONG INT iii := LONG LONG 2;
+      iii *:= LONG LONG 2;
+      ASSERT (iii = LONG LONG 4);
+      iii *:= LONG LONG 2;
+      ASSERT (iii = LONG LONG 8)
+END
diff --git a/gcc/testsuite/algol68/execute/multab-2.a68 b/gcc/testsuite/algol68/execute/multab-2.a68
new file mode 100644
index 00000000000..dc1485991cd
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/multab-2.a68
@@ -0,0 +1,31 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 2;
+      i TIMESAB 2;
+      ASSERT (i = 4);
+      i TIMESAB 2;
+      ASSERT (i = 8);
+
+      REF SHORT INT ss = HEAP SHORT INT := SHORT 2;
+      ss TIMESAB SHORT 2;
+      ASSERT (ss = SHORT 4);
+      ss TIMESAB SHORT 2;
+      ASSERT (ss = SHORT 8);
+
+      SHORT SHORT INT sss := SHORT SHORT 2;
+      sss TIMESAB SHORT SHORT 2;
+      ASSERT (sss = SHORT SHORT 4);
+      sss TIMESAB SHORT SHORT 2;
+      ASSERT (sss = SHORT SHORT 8);
+      
+      REF LONG INT ii = HEAP LONG INT := LONG 2;
+      ii TIMESAB LONG 2;
+      ASSERT (ii = LONG 4);
+      ii TIMESAB LONG 2;
+      ASSERT (ii = LONG 8);
+
+      LONG LONG INT iii := LONG LONG 2;
+      iii TIMESAB LONG LONG 2;
+      ASSERT (iii = LONG LONG 4);
+      iii TIMESAB LONG LONG 2;
+      ASSERT (iii = LONG LONG 8)
+END
diff --git a/gcc/testsuite/algol68/execute/multab-3.a68 b/gcc/testsuite/algol68/execute/multab-3.a68
new file mode 100644
index 00000000000..87d7f42b80b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/multab-3.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT num ints := 10;
+      num ints *:= 2;
+      ASSERT (num ints = 20);
+      ASSERT ((LOC INT *:= 12) = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/mutual-recursion-1.a68 b/gcc/testsuite/algol68/execute/mutual-recursion-1.a68
new file mode 100644
index 00000000000..06e01f947ff
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mutual-recursion-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC is even = (INT n) BOOL: (n = 0 | TRUE | is odd (n - 1));
+      PROC is odd = (INT n) BOOL: (n = 0 | FALSE | is even (n - 1));
+      ASSERT (is even (20));
+      ASSERT (is odd (13))
+END
diff --git a/gcc/testsuite/algol68/execute/ne-bits-1.a68 b/gcc/testsuite/algol68/execute/ne-bits-1.a68
new file mode 100644
index 00000000000..49ef81061ae
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/ne-bits-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BITS b, LONG BITS bb = LONG 16rff,  LONG LONG BITS bbb;
+      SHORT BITS ss = SHORT 16rff, SHORT SHORT BITS sss;
+      ASSERT (b /= 2r1);
+      ASSERT (bb NE LONG 8r477);
+      ASSERT (bbb /= LONG LONG 8r2);
+      ASSERT (ss NE SHORT 8r477);
+      ASSERT (sss /= SHORT SHORT 8r2)
+END
diff --git a/gcc/testsuite/algol68/execute/ne-char-char-1.a68 b/gcc/testsuite/algol68/execute/ne-char-char-1.a68
new file mode 100644
index 00000000000..2a5b44fe83c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/ne-char-char-1.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT ("x" /= "a")
+END
diff --git a/gcc/testsuite/algol68/execute/ne-int-1.a68 b/gcc/testsuite/algol68/execute/ne-int-1.a68
new file mode 100644
index 00000000000..2c26bd563c5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/ne-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 12;
+      LONG INT ii = LONG 12, LONG LONG INT iii = LONG LONG 12;
+      SHORT INT s = SHORT 12, SHORT SHORT INT ss = SHORT SHORT 12;
+      ASSERT (13 /= i);
+      ASSERT (ii NE LONG 13);
+      ASSERT (iii /= LONG LONG 13);
+      ASSERT (s /= SHORT 13);
+      ASSERT (ss /= SHORT SHORT 13)
+END
diff --git a/gcc/testsuite/algol68/execute/ne-string-1.a68 b/gcc/testsuite/algol68/execute/ne-string-1.a68
new file mode 100644
index 00000000000..95bd212dce3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/ne-string-1.a68
@@ -0,0 +1,15 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING foo = "foo", bar = "bar", quux = "quux";
+      # /=  #
+      ASSERT (NOT ("" /= ""));
+      ASSERT (NOT ("foo" /= foo));
+      ASSERT (foo /= bar);
+      ASSERT (foo /= quux);
+      ASSERT (quux /= foo);
+      # NE  #
+      ASSERT (NOT ("" NE ""));
+      ASSERT (NOT ("foo" NE foo));
+      ASSERT (foo NE bar);
+      ASSERT (foo NE quux);
+      ASSERT (quux NE foo)
+END
diff --git a/gcc/testsuite/algol68/execute/neg-int-1.a68 b/gcc/testsuite/algol68/execute/neg-int-1.a68
new file mode 100644
index 00000000000..0e66149ef28
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/neg-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+      SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10;
+      ASSERT (-i = -10);
+      ASSERT (-ii  = - LONG 10);
+      ASSERT (-iii = - LONG LONG 10);
+      ASSERT (-ss  = - SHORT 10);
+      ASSERT (-sss = - SHORT SHORT 10)
+END
diff --git a/gcc/testsuite/algol68/execute/not-bits-1.a68 b/gcc/testsuite/algol68/execute/not-bits-1.a68
new file mode 100644
index 00000000000..8334f7f7a7f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/not-bits-1.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+# NOT for SIZETY BITS.  #
+BEGIN BITS b = 16rf0f0;
+      ASSERT ((NOT b AND 16rffff) = 16r0f0f);
+      LONG BITS bb = LONG 16rf0f0;
+      ASSERT ((NOT bb AND LONG 16rffff) = LONG 16r0f0f);
+      LONG LONG BITS bbb = LONG LONG 16rf0f0;
+      ASSERT ((NOT bbb AND LONG LONG 16rffff) = LONG LONG 16r0f0f);
+      SHORT BITS ss = SHORT 16rf0f0;
+      ASSERT ((NOT ss AND SHORT 16rffff) = SHORT 16r0f0f);
+      SHORT SHORT BITS sss = SHORT SHORT 16rf0f0;
+      ASSERT ((NOT sss AND SHORT SHORT 16rffff) = SHORT SHORT 16r0f0f)
+END
diff --git a/gcc/testsuite/algol68/execute/odd-1.a68 b/gcc/testsuite/algol68/execute/odd-1.a68
new file mode 100644
index 00000000000..893bf0479d0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/odd-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT a = 1;
+      ASSERT (ODD a);
+      ASSERT (ODD LONG 3);
+      ASSERT (NOT ODD LONG LONG 4);
+      ASSERT (ODD SHORT 3);
+      ASSERT (NOT ODD SHORT SHORT 4)
+END
diff --git a/gcc/testsuite/algol68/execute/op-1.a68 b/gcc/testsuite/algol68/execute/op-1.a68
new file mode 100644
index 00000000000..3b63c323ca2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/op-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN OP ONEOVER = (REAL a) REAL: 1/a;
+      REAL x;
+      x := ONEOVER 3.14
+END
diff --git a/gcc/testsuite/algol68/execute/op-2.a68 b/gcc/testsuite/algol68/execute/op-2.a68
new file mode 100644
index 00000000000..c7721719a56
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/op-2.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN OP + = (INT a, b) INT: a - -b;
+      ASSERT (10 + 30 = 40)
+END
diff --git a/gcc/testsuite/algol68/execute/op-3.a68 b/gcc/testsuite/algol68/execute/op-3.a68
new file mode 100644
index 00000000000..9889a64a353
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/op-3.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN OP MIN = (REAL a, b) REAL: (a < b | a | b),
+         MIN = (INT a, REAL b) REAL: (a < b | a | b),
+         MIN = (REAL a, INT b) REAL: a MIN REAL (b);
+      PRIO MIN = 6;
+      ASSERT (10.0 MIN 20.0 > 9.9 AND 10.0 MIN 20.0 < 10.1);
+      ASSERT (10.0 MIN 100 > 9.9 AND 10.0 MIN 100 < 10.1);
+      ASSERT (100.0 MIN 10 > 9.9 AND 100.0 MIN 10 < 10.1)
+END
diff --git a/gcc/testsuite/algol68/execute/operator-declaration-1.a68 b/gcc/testsuite/algol68/execute/operator-declaration-1.a68
new file mode 100644
index 00000000000..61f8fa9986b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/operator-declaration-1.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n = 10;
+      # Note that the priority for the monadic operators gets ignored.  #
+      PRIO JORL = 6, JURL = 6, XXX = 6, YYY = 6;
+      OP(INT)INT JORL = (n > 10 | (INT a) INT: a + 1 | (INT a) INT: a - 1),
+                 JURL = (n <= 10 | (INT a) INT: a + 1 | (INT a) INT: a - 1);
+      OP(INT,INT)INT XXX = (INT a, b) INT: a + b,
+                     YYY = (n > 10 | (INT a,b) INT: a * b | (INT a,b) INT: a - b);
+      ASSERT (JORL 10 = 9);
+      ASSERT (JURL 10 = 11);
+      ASSERT (2 XXX 3 = 5);
+      ASSERT (2 YYY 3 = -1);
+END
diff --git a/gcc/testsuite/algol68/execute/or-bits-1.a68 b/gcc/testsuite/algol68/execute/or-bits-1.a68
new file mode 100644
index 00000000000..4fc1b06225d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/or-bits-1.a68
@@ -0,0 +1,18 @@
+# { dg-options "-fstropping=upper" }  #
+# OR for SIZETY BITS.  #
+BEGIN BITS b = 16rf0f0;
+      ASSERT ((b OR 16r0f0f) = 16rffff);
+      ASSERT ((b OR 16r00ff) = 16rf0ff);
+      LONG BITS bb = LONG 16rf0f0;
+      ASSERT ((bb OR LONG 16r0f0f) = LONG 16rffff);
+      ASSERT ((bb OR LONG 16r00ff) = LONG 16rf0ff);
+      LONG LONG BITS bbb = LONG LONG 16rf0f0;
+      ASSERT ((bbb OR LONG LONG 16r0f0f) = LONG LONG 16rffff);
+      ASSERT ((bbb OR LONG LONG 16r00ff) = LONG LONG 16rf0ff);
+      SHORT BITS ss = SHORT 16rf0f0;
+      ASSERT ((ss OR SHORT 16r0f0f) = SHORT 16rffff);
+      ASSERT ((ss OR SHORT 16r00ff) = SHORT 16rf0ff);
+      SHORT SHORT BITS sss = SHORT SHORT 16rf0f0;
+      ASSERT ((sss OR SHORT SHORT 16r0f0f) = SHORT SHORT 16rffff);
+      ASSERT ((sss OR SHORT SHORT 16r00ff) = SHORT SHORT 16rf0ff)
+END
diff --git a/gcc/testsuite/algol68/execute/orf-1.a68 b/gcc/testsuite/algol68/execute/orf-1.a68
new file mode 100644
index 00000000000..10f052128bc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/orf-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10;
+      ASSERT (i = 0 OREL i = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/over-int-1.a68 b/gcc/testsuite/algol68/execute/over-int-1.a68
new file mode 100644
index 00000000000..871effb61a0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/over-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+      SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10;
+      ASSERT (i % 2 = 5);
+      ASSERT (ii % LONG 2 = LONG 5);
+      ASSERT (iii % LONG LONG 2 = LONG LONG 5);
+      ASSERT (ss % SHORT 2 = SHORT 5);
+      ASSERT (sss % SHORT SHORT 2 = SHORT SHORT 5)
+END
diff --git a/gcc/testsuite/algol68/execute/overab-1.a68 b/gcc/testsuite/algol68/execute/overab-1.a68
new file mode 100644
index 00000000000..8edfa1e5fab
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/overab-1.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN (INT i := 11; i OVERAB 2; ASSERT (i = 5));
+      (INT i := 11; i %:= 2; ASSERT (i = 5));
+      (SHORT INT i := SHORT 11; i OVERAB SHORT 2; ASSERT (i = SHORT 5));
+      (SHORT INT i := SHORT 11; i %:= SHORT 2; ASSERT (i = SHORT 5));
+      (SHORT SHORT INT i := SHORT SHORT 11; i OVERAB SHORT SHORT 2; ASSERT (i = SHORT SHORT 5));
+      (SHORT SHORT INT i := SHORT SHORT 11; i %:= SHORT SHORT 2; ASSERT (i = SHORT SHORT 5));
+      (LONG INT i := LONG 11; i OVERAB LONG 2; ASSERT (i = LONG 5));
+      (LONG INT i := LONG 11; i %:= LONG 2; ASSERT (i = LONG 5));
+      (LONG LONG INT i := LONG LONG 11; i OVERAB LONG LONG 2; ASSERT (i = LONG LONG 5));
+      (LONG LONG INT i := LONG LONG 11; i %:= LONG LONG 2; ASSERT (i = LONG LONG 5))
+END
diff --git a/gcc/testsuite/algol68/execute/overab-2.a68 b/gcc/testsuite/algol68/execute/overab-2.a68
new file mode 100644
index 00000000000..eec8a1cbfdc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/overab-2.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := 10;
+      (((n OVERAB 1))) := 5;
+      ASSERT (n = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/particular-program-1.a68 b/gcc/testsuite/algol68/execute/particular-program-1.a68
new file mode 100644
index 00000000000..2c490afce04
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/particular-program-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+# Particular program with preceding labels.  #
+jo: ju:
+BEGIN SKIP END
diff --git a/gcc/testsuite/algol68/execute/plus-char-1.a68 b/gcc/testsuite/algol68/execute/plus-char-1.a68
new file mode 100644
index 00000000000..d017fe08ab8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plus-char-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT ("a" + "b" = "ab");
+      ASSERT ("" + "x" = "x")
+END
diff --git a/gcc/testsuite/algol68/execute/plus-int-1.a68 b/gcc/testsuite/algol68/execute/plus-int-1.a68
new file mode 100644
index 00000000000..93ea00445dd
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plus-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      LONG INT ii = LONG 10, LONG LONG INT iii = LONG LONG 10;
+      SHORT INT ss = SHORT 10, SHORT SHORT INT sss = SHORT SHORT 10;
+      ASSERT (i + 2 = 12);
+      ASSERT (ii + LONG 2 = LONG 12);
+      ASSERT (iii + LONG LONG 2 = LONG LONG 12);
+      ASSERT (ss + SHORT 2 = SHORT 12);
+      ASSERT (sss + SHORT SHORT 2 = SHORT SHORT 12)
+END
diff --git a/gcc/testsuite/algol68/execute/plus-string-1.a68 b/gcc/testsuite/algol68/execute/plus-string-1.a68
new file mode 100644
index 00000000000..be9edf79de2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plus-string-1.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING foo = "foo", bar = "bar", quux = "quux";
+      ASSERT ("" + "" = "");
+      ASSERT ("" + foo = "foo");
+      ASSERT (bar + "" = "bar");
+      ASSERT (foo + bar = "foobar");
+      STRING res = foo + bar;
+      ASSERT (LWB res = 1 AND UPB res = 6);
+      STRING empty = "" + "";
+      ASSERT (LWB empty = 1 AND UPB empty = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/plus-string-2.a68 b/gcc/testsuite/algol68/execute/plus-string-2.a68
new file mode 100644
index 00000000000..6399ee1cf22
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plus-string-2.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC rec parse comment = VOID:
+      BEGIN STRING content;
+            done;
+            100;
+      done:
+            ASSERT (content + "x" = "x")
+      END;
+
+      rec parse comment
+END
diff --git a/gcc/testsuite/algol68/execute/plus-string-stride-1.a68 b/gcc/testsuite/algol68/execute/plus-string-stride-1.a68
new file mode 100644
index 00000000000..07fdf79537c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plus-string-stride-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]CHAR matrix = (("1","H","3"),
+                        ("4","O","6"),
+                        ("7","M","9"),
+                        ("8","E","2"));
+      ASSERT (matrix[1:2,1] + matrix[3:4,3] = "1492")
+END
diff --git a/gcc/testsuite/algol68/execute/plusab-1.a68 b/gcc/testsuite/algol68/execute/plusab-1.a68
new file mode 100644
index 00000000000..8de4e97b046
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plusab-1.a68
@@ -0,0 +1,34 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BEGIN INT i := 10;
+            i +:= 2;
+            ASSERT (i = 12);
+            i PLUSAB 2;
+            ASSERT (i = 14)
+      END;
+
+      BEGIN SHORT INT i := SHORT 1000;
+            i +:= SHORT 100;
+            ASSERT (i = SHORT 1100);
+            i PLUSAB SHORT 100;
+            ASSERT (i = SHORT 1200)
+      END;
+      BEGIN SHORT SHORT INT i := SHORT SHORT 10000;
+            i +:= SHORT SHORT 1000;
+            ASSERT (i = SHORT SHORT 11000);
+            i PLUSAB SHORT SHORT 1000;
+            ASSERT (i = SHORT SHORT 12000)
+      END;
+
+      BEGIN LONG INT i := LONG 1000;
+            i +:= LONG 100;
+            ASSERT (i = LONG 1100);
+            i PLUSAB LONG 100;
+            ASSERT (i = LONG 1200)
+      END;
+      BEGIN LONG LONG INT i := LONG LONG 10000;
+            i +:= LONG LONG 1000;
+            ASSERT (i = LONG LONG 11000);
+            i PLUSAB LONG LONG 1000;
+            ASSERT (i = LONG LONG 12000)
+      END
+END
diff --git a/gcc/testsuite/algol68/execute/plusab-2.a68 b/gcc/testsuite/algol68/execute/plusab-2.a68
new file mode 100644
index 00000000000..6db46864d8a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plusab-2.a68
@@ -0,0 +1,20 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BEGIN REAL i := 10.0;
+            i +:= 2.0;
+            ASSERT (i > 11.9);
+            i PLUSAB 2.0;
+            ASSERT (i > 13.9)
+      END;
+      BEGIN LONG REAL i := LONG 1000.0;
+            i +:= LONG 100.0;
+            ASSERT (i > LONG 1099.9);
+            i PLUSAB LONG 100.0;
+            ASSERT (i > LONG 1199.9)
+      END;
+      BEGIN LONG LONG REAL i := LONG LONG 10000.0;
+            i +:= LONG LONG 1000.0;
+            ASSERT (i > LONG LONG 10999.9);
+            i PLUSAB LONG LONG 1000.0;
+            ASSERT (i > LONG LONG 11999.9)
+      END
+END
diff --git a/gcc/testsuite/algol68/execute/plusab-3.a68 b/gcc/testsuite/algol68/execute/plusab-3.a68
new file mode 100644
index 00000000000..beb63060135
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plusab-3.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := 0;
+      (((n +:= 1))) := 5;
+      ASSERT (n = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/plusab-4.a68 b/gcc/testsuite/algol68/execute/plusab-4.a68
new file mode 100644
index 00000000000..adfbc9f7a07
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plusab-4.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT num ints := 0;
+      num ints +:= 1;
+      ASSERT (num ints = 1);
+      ASSERT ((LOC INT +:= 12) = 12)
+END
diff --git a/gcc/testsuite/algol68/execute/plusab-string-1.a68 b/gcc/testsuite/algol68/execute/plusab-string-1.a68
new file mode 100644
index 00000000000..ec1bd3c45fb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plusab-string-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING foo := "";
+      foo +:= "foo";
+      ASSERT (LWB foo = 1 AND UPB foo = 3 AND foo = "foo");
+      foo PLUSAB "bar";
+      ASSERT (LWB foo = 1 AND UPB foo = 6 AND foo = "foobar")
+END
diff --git a/gcc/testsuite/algol68/execute/plusto-char-1.a68 b/gcc/testsuite/algol68/execute/plusto-char-1.a68
new file mode 100644
index 00000000000..79881c07d10
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plusto-char-1.a68
@@ -0,0 +1,7 @@
+begin string foo := "foo";
+      char c := "x";
+      c PLUSTO foo;
+      assert (foo = "xfoo");
+      c +=: foo;
+      assert (foo = "xxfoo")
+end
diff --git a/gcc/testsuite/algol68/execute/plusto-string-1.a68 b/gcc/testsuite/algol68/execute/plusto-string-1.a68
new file mode 100644
index 00000000000..7d5894b0cd4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/plusto-string-1.a68
@@ -0,0 +1,6 @@
+begin string foo := "foo";
+      "bar" PLUSTO foo;
+      assert (foo = "barfoo");
+      "quux" +=: foo;
+      assert (foo = "quuxbarfoo")
+end
diff --git a/gcc/testsuite/algol68/execute/posix-argc-argv-1.a68 b/gcc/testsuite/algol68/execute/posix-argc-argv-1.a68
new file mode 100644
index 00000000000..a6380380ffe
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/posix-argc-argv-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (argc >= 1);
+      ASSERT (argv (1000) = "");
+      ASSERT (argv (-1) = "");
+      FOR i TO argc
+      DO puts (argv (i)) OD
+END
diff --git a/gcc/testsuite/algol68/execute/posix-fopen-1.a68 b/gcc/testsuite/algol68/execute/posix-fopen-1.a68
new file mode 100644
index 00000000000..d2a0c406f2b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/posix-fopen-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT fd = fopen ("doesn''t exist", file o default);
+      ASSERT (fd = -1)
+END
diff --git a/gcc/testsuite/algol68/execute/posix-fputc-fputs-1.a68 b/gcc/testsuite/algol68/execute/posix-fputc-fputs-1.a68
new file mode 100644
index 00000000000..bf0af6e6e22
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/posix-fputc-fputs-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN fputc (stdout, "X");
+      ASSERT (fputs (stdout, "foo") = 3);
+      fputs (stdout, fputc (stdout, "Y") + "T");
+      fputc (stdout, "Z");
+      ASSERT (fputs (stdout, "") = 0);
+      puts ("")
+END
diff --git a/gcc/testsuite/algol68/execute/posix-getenv-1.a68 b/gcc/testsuite/algol68/execute/posix-getenv-1.a68
new file mode 100644
index 00000000000..d1e69056812
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/posix-getenv-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (getenv ("") = "");
+      ASSERT (getenv ("DOESNT EXIST FOR SURE") = "")
+END
diff --git a/gcc/testsuite/algol68/execute/posix-perror-1.a68 b/gcc/testsuite/algol68/execute/posix-perror-1.a68
new file mode 100644
index 00000000000..a349dd72ad8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/posix-perror-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# { dg-output "^something unique: " }  #
+BEGIN INT fd = fopen ("doesn''t exist", file o default);
+      IF fd = -1 THEN
+         ASSERT (strerror (errno) /= "");
+         perror ("something unique")
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/posix-putchar-1.a68 b/gcc/testsuite/algol68/execute/posix-putchar-1.a68
new file mode 100644
index 00000000000..01bfbbd371e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/posix-putchar-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN putchar ("X");
+      putchar ("Y");
+      putchar ("Z");
+      puts ("\n")
+END
diff --git a/gcc/testsuite/algol68/execute/posix-stdinouterr-1.a68 b/gcc/testsuite/algol68/execute/posix-stdinouterr-1.a68
new file mode 100644
index 00000000000..dc5b373d938
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/posix-stdinouterr-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (stdin = 0);
+      ASSERT (stdout = 1);
+      ASSERT (stderr = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/posix-strerror-1.a68 b/gcc/testsuite/algol68/execute/posix-strerror-1.a68
new file mode 100644
index 00000000000..607e40d0b9d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/posix-strerror-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT fd = fopen ("doesn''t exist", file o default);
+      IF fd = -1 THEN ASSERT (strerror (errno) /= "") FI
+END
diff --git a/gcc/testsuite/algol68/execute/posix-stride-1.a68 b/gcc/testsuite/algol68/execute/posix-stride-1.a68
new file mode 100644
index 00000000000..6e7a79d2640
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/posix-stride-1.a68
@@ -0,0 +1,14 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]CHAR matrix = (("1","H","3"),
+                        ("4","O","6"),
+                        ("7","M","9"),
+                        ("8","E","0"));
+      []CHAR column = matrix[1:4,2];
+      puts (column);
+      fputs (stdout, matrix[3,2:3]);
+      puts ("\n");
+      fputs (stdout, matrix[1:3,1]);
+      puts ("\n");
+      puts (getenv (matrix[,2]));
+      perror (matrix[,3])
+END
diff --git a/gcc/testsuite/algol68/execute/pow-int-1.a68 b/gcc/testsuite/algol68/execute/pow-int-1.a68
new file mode 100644
index 00000000000..7d929d714ff
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/pow-int-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 2;
+      LONG INT ii = LONG 2, LONG LONG INT iii = LONG LONG 2;
+      SHORT INT ss = SHORT 2, SHORT SHORT INT sss = SHORT SHORT 2;
+      ASSERT (i ** 2 = 4);
+      ASSERT (ii ** 2 = LONG 4);
+      ASSERT (iii ** 2 = LONG LONG 4);
+      ASSERT (ss ** 2 = SHORT 4);
+      ASSERT (sss ** 2 = SHORT SHORT 4)
+END
diff --git a/gcc/testsuite/algol68/execute/pow-real-1.a68 b/gcc/testsuite/algol68/execute/pow-real-1.a68
new file mode 100644
index 00000000000..81028706485
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/pow-real-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r0 = 2.0; LONG REAL rr0 = LONG 2.0; LONG LONG REAL rrr0 = LONG LONG 2.0;
+      REAL r1 = r0 ^ 2; REAL r2 = r0 ^ 3.0;
+      LONG REAL rr1 = rr0 ^ LONG 2; LONG REAL rr2 = rr0 ^ LONG 3.0;
+      LONG LONG REAL rrr1 = rrr0 ^ LONG LONG 2; LONG LONG REAL rrr2 = rrr0 ^ LONG LONG 3.0;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/proc-1.a68 b/gcc/testsuite/algol68/execute/proc-1.a68
new file mode 100644
index 00000000000..3085f4b7360
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC foo = INT: 100;
+      ASSERT (foo = 100)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-10.a68 b/gcc/testsuite/algol68/execute/proc-10.a68
new file mode 100644
index 00000000000..bcc86d85140
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-10.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC(INT,INT)INT foo = (INT i, j) INT: i + j;
+      ASSERT (foo (10, 20) = 30)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-12.a68 b/gcc/testsuite/algol68/execute/proc-12.a68
new file mode 100644
index 00000000000..be75e7948db
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-12.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC(INT)INT foo = baz;
+      PROC bar = (INT i) INT: i + 1;
+      PROC baz = (INT i) INT: i - 1;
+      ASSERT (foo (10) = 9)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-13.a68 b/gcc/testsuite/algol68/execute/proc-13.a68
new file mode 100644
index 00000000000..c23c08612c9
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-13.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC is even := (INT n) BOOL: n %* 2 = 0;
+      ASSERT (is even (40));
+      PROC no args := BOOL: TRUE;
+      ASSERT (no args)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-14.a68 b/gcc/testsuite/algol68/execute/proc-14.a68
new file mode 100644
index 00000000000..b653bbe148b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-14.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC is even := (INT n) BOOL: n %* 2 = 0;
+      PROC is odd := (INT n) BOOL: n %* 2 /= 0;
+      PROC(INT)BOOL f = is even;
+      PROC(INT)BOOL g = is odd;
+      ASSERT (f (40));
+      ASSERT (g (3))
+END
diff --git a/gcc/testsuite/algol68/execute/proc-15.a68 b/gcc/testsuite/algol68/execute/proc-15.a68
new file mode 100644
index 00000000000..63c5a557704
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-15.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Nested procedures.  #
+BEGIN PROC foo = (INT i) INT:
+      BEGIN PROC bar = (INT i) INT: i - 1;
+            bar (i) * 10
+      END;
+      ASSERT (foo (10) = 90)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-16.a68 b/gcc/testsuite/algol68/execute/proc-16.a68
new file mode 100644
index 00000000000..bb1b1e25d89
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-16.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC bar = (INT i) INT: i - 1;
+      PROC foo = (INT i) INT:
+      BEGIN
+            bar (i) * 10
+      END;
+      ASSERT (foo (10) = 90)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-17.a68 b/gcc/testsuite/algol68/execute/proc-17.a68
new file mode 100644
index 00000000000..24ac5a8c5ed
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-17.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+# Identity declarations and procedures.  #
+BEGIN PROC foo = (INT i) INT: i + 1;
+      ASSERT (foo (10) = 11);
+      PROC(INT)INT bar = (INT i) INT: i + 1;
+      ASSERT (bar (10) = 11);
+      PROC(INT)INT baz = foo;
+      ASSERT (baz (10) = 11);
+      PROC(INT)INT quux = IF 10 > 1 THEN baz ELSE foo FI;
+      ASSERT (quux (10) = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-18.a68 b/gcc/testsuite/algol68/execute/proc-18.a68
new file mode 100644
index 00000000000..34568828be7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-18.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC foo = (INT i) INT: i + 1;
+      PROC(INT)INT bar;
+      bar := foo;
+      ASSERT (bar (10) = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-19.a68 b/gcc/testsuite/algol68/execute/proc-19.a68
new file mode 100644
index 00000000000..0846fdca8da
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-19.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC foo = (INT i) INT: i + 1;
+      PROC(INT)INT bar := foo;
+      ASSERT (bar (10) = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-2.a68 b/gcc/testsuite/algol68/execute/proc-2.a68
new file mode 100644
index 00000000000..39346fe3567
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Call a non-variable procedure before declaration.  #
+BEGIN ASSERT (foo = 100);
+      PROC foo = INT: 100;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/proc-20.a68 b/gcc/testsuite/algol68/execute/proc-20.a68
new file mode 100644
index 00000000000..3bf66eea53a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-20.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC foo := (INT i) INT: i + 1;
+      PROC(INT)INT bar := foo;
+      ASSERT (bar (10) = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-21.a68 b/gcc/testsuite/algol68/execute/proc-21.a68
new file mode 100644
index 00000000000..c1ac9807c23
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-21.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# REF REF PROC  #
+BEGIN PROC foo = (INT i) INT: i + 1;
+      PROC(INT)INT bar := foo;
+      REF PROC(INT)INT baz;
+      baz := bar;
+      ASSERT (baz (10) = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-22.a68 b/gcc/testsuite/algol68/execute/proc-22.a68
new file mode 100644
index 00000000000..fa23d531aa5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-22.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# REF REF PROC  #
+BEGIN PROC foo = (INT i) INT: i + 1;
+      PROC(INT)INT bar := foo;
+      REF PROC(INT)INT baz := bar;
+      ASSERT (baz (10) = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-23.a68 b/gcc/testsuite/algol68/execute/proc-23.a68
new file mode 100644
index 00000000000..7fa1257eca7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-23.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC increment = (INT a) INT: a + 1;
+      PROC getproc = PROC(INT)INT:
+      BEGIN increment
+      END;
+      # getproc below gets deprocedured to yield increment.  #
+      ASSERT (getproc (10) = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-25.a68 b/gcc/testsuite/algol68/execute/proc-25.a68
new file mode 100644
index 00000000000..5b46e8914e6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-25.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC increment := (INT a) INT: a + 1;
+      PROC getproc := PROC(INT)INT:
+      BEGIN increment
+      END;
+      # getproc below gets deprocedured to yield increment.  #
+      ASSERT (getproc (10) = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-26.a68 b/gcc/testsuite/algol68/execute/proc-26.a68
new file mode 100644
index 00000000000..833cbb34a4b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-26.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC sum = (INT a, b) INT: a + b,
+           minus = (INT a, b) INT: a - b;
+      ASSERT (sum (1, 2) = 3);
+      ASSERT (minus (1, 2) = -1)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-27.a68 b/gcc/testsuite/algol68/execute/proc-27.a68
new file mode 100644
index 00000000000..49c4c6a242c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-27.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC reciprocal = (REAL a) REAL: 1/a;
+      REAL x;
+      x := reciprocal (3.14)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-28.a68 b/gcc/testsuite/algol68/execute/proc-28.a68
new file mode 100644
index 00000000000..d909219d72a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-28.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC hcf = (INT m, n) INT:
+         IF m < n
+         THEN hcf (n, m)
+         ELIF n = 0
+         THEN m
+         ELSE hcf (n, m MOD n)
+         FI;
+      ASSERT (hcf (10, 20) = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-29.a68 b/gcc/testsuite/algol68/execute/proc-29.a68
new file mode 100644
index 00000000000..51ea5fccf93
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-29.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# A heap proc variable.  #
+BEGIN HEAP PROC foo := INT: 666;
+      ASSERT (foo = 666)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-3.a68 b/gcc/testsuite/algol68/execute/proc-3.a68
new file mode 100644
index 00000000000..bd9ce053485
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-3.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC foo = (INT i, j) INT: i + j + 1;
+      ASSERT (foo (10, 11) = 22)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-4.a68 b/gcc/testsuite/algol68/execute/proc-4.a68
new file mode 100644
index 00000000000..bce68cf3f16
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-4.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (foo (10, 11) = 22);
+      PROC foo = (INT i, j) INT: i + j + 1;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/proc-5.a68 b/gcc/testsuite/algol68/execute/proc-5.a68
new file mode 100644
index 00000000000..1893dc35179
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-5.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Recursive function.  #
+BEGIN PROC foo = (INT i) INT: (i > 0 | i + foo (i - 1) | 0);
+      ASSERT (foo (10) = 55)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-6.a68 b/gcc/testsuite/algol68/execute/proc-6.a68
new file mode 100644
index 00000000000..894f53e0525
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-6.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Recursive function, used before declared.  #
+BEGIN ASSERT (foo (10) = 55);
+      PROC foo = (INT i) INT: BEGIN (i > 0 | i + foo (i - 1) | 0) END;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/proc-7.a68 b/gcc/testsuite/algol68/execute/proc-7.a68
new file mode 100644
index 00000000000..9f39e2d0d04
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-7.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC foo = (INT i) INT: i + 1;
+      PROC(INT)INT bar = foo;
+      ASSERT (bar (10) = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/proc-8.a68 b/gcc/testsuite/algol68/execute/proc-8.a68
new file mode 100644
index 00000000000..ee548c6b374
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/proc-8.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC INT foo = INT: 100;
+      ASSERT (foo = 100)
+END
diff --git a/gcc/testsuite/algol68/execute/procedured-goto-1.a68 b/gcc/testsuite/algol68/execute/procedured-goto-1.a68
new file mode 100644
index 00000000000..8d3dc21c782
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/procedured-goto-1.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 4;
+beg:  WHILE i > 0
+      DO []PROC VOID table = (l3,l1,l2,end);
+         table[i];
+l1:      puts ("uno\n"); i -:= 1; beg;
+l2:      puts ("dos\n"); i -:= 1; beg;
+l3:      puts ("tres\n"); i -:= 1; beg;
+end:     puts ("cuatro\n"); i -:= 1; beg
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/quine.a68 b/gcc/testsuite/algol68/execute/quine.a68
new file mode 100644
index 00000000000..9fd9e422fdc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/quine.a68
@@ -0,0 +1,2 @@
+# { dg-options "-fstropping=upper" }  #
+(STRING a="(STRING a="";puts(2*a[:19]+2*a[19:]);0)";puts(2*a[:19]+2*a[19:]))
diff --git a/gcc/testsuite/algol68/execute/random-1.a68 b/gcc/testsuite/algol68/execute/random-1.a68
new file mode 100644
index 00000000000..82cc6e3a576
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/random-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN IF random > 0.5 THEN puts ("yes\n") ELSE puts ("no\n") FI;
+      LONG REAL rr = long random;
+      IF rr > LONG 0.5 THEN puts ("long yes\n") ELSE puts ("long no\n") FI;
+      LONG LONG REAL rrr = long long random;
+      IF rrr > LONG LONG 0.5 THEN puts ("long long yes\n") ELSE puts ("long long no\n") FI
+END
diff --git a/gcc/testsuite/algol68/execute/re-im-1.a68 b/gcc/testsuite/algol68/execute/re-im-1.a68
new file mode 100644
index 00000000000..7801b769057
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/re-im-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN COMPL z = 4.0I5.0;
+      ASSERT (RE z = 4.0 AND IM z = 5.0);
+      LONG COMPL zz = LONG 4.0 I LONG 6.0;
+      ASSERT (RE zz = LONG 4.0 AND IM zz = LONG 6.0);
+      LONG LONG COMPL zzz = LONG LONG 4.0 I LONG LONG 7.0;
+      ASSERT (RE zzz = LONG LONG 4.0 AND IM zzz = LONG LONG 7.0)
+END
diff --git a/gcc/testsuite/algol68/execute/rela-string-1.a68 b/gcc/testsuite/algol68/execute/rela-string-1.a68
new file mode 100644
index 00000000000..92648578dab
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rela-string-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT ("" >= "");
+      ASSERT ("" <= "");
+      ASSERT ("zzz" > "aaa");
+      ASSERT ("zzz" >= "aaa");
+      ASSERT ("HelloA" < "HelloB")
+END
diff --git a/gcc/testsuite/algol68/execute/repr-1.a68 b/gcc/testsuite/algol68/execute/repr-1.a68
new file mode 100644
index 00000000000..2b92a3e7de0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/repr-1.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (REPR ABS "x" = "x")
+END
diff --git a/gcc/testsuite/algol68/execute/round-1.a68 b/gcc/testsuite/algol68/execute/round-1.a68
new file mode 100644
index 00000000000..632e3822332
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/round-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL x = 3.14, y = 3.80;
+      LONG REAL xx = LONG 3.14, yy = LONG 3.80;
+      LONG LONG REAL xxx = LONG LONG 3.14, yyy = LONG LONG 3.80;
+      ASSERT (ROUND x = 3 AND ROUND y = 4);
+      ASSERT (ROUND xx = LONG 3 AND ROUND yy = LONG 4);
+      ASSERT (ROUND xxx = LONG LONG 3 AND ROUND yyy = LONG LONG 4)
+END
diff --git a/gcc/testsuite/algol68/execute/row-display-1.a68 b/gcc/testsuite/algol68/execute/row-display-1.a68
new file mode 100644
index 00000000000..82540d700dc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/row-display-1.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT foo = (7,8,9);
+      [,]INT bar = ((1,2,3),(4,5,6),foo);
+      ASSERT (bar[1,1] = 1);
+      ASSERT (bar[1,2] = 2);
+      ASSERT (bar[1,3] = 3);
+      ASSERT (bar[2,1] = 4);
+      ASSERT (bar[2,2] = 5);
+      ASSERT (bar[2,3] = 6);
+      ASSERT (bar[3,1] = 7);
+      ASSERT (bar[3,2] = 8);
+      ASSERT (bar[3,3] = 9)
+END
diff --git a/gcc/testsuite/algol68/execute/row-display-2.a68 b/gcc/testsuite/algol68/execute/row-display-2.a68
new file mode 100644
index 00000000000..f8a07a4d162
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/row-display-2.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT foo = (7,8,9);
+      [3,3]INT bar := ((1,2,3),(4,5,6),foo);
+      ASSERT (bar[1,1] = 1);
+      ASSERT (bar[1,2] = 2);
+      ASSERT (bar[1,3] = 3);
+      ASSERT (bar[2,1] = 4);
+      ASSERT (bar[2,2] = 5);
+      ASSERT (bar[2,3] = 6);
+      ASSERT (bar[3,1] = 7);
+      ASSERT (bar[3,2] = 8);
+      ASSERT (bar[3,3] = 9)
+END
diff --git a/gcc/testsuite/algol68/execute/row-display-3.a68 b/gcc/testsuite/algol68/execute/row-display-3.a68
new file mode 100644
index 00000000000..73f3ff82a46
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/row-display-3.a68
@@ -0,0 +1,15 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE FOO = STRUCT (INT i, STRING s);
+      [,]FOO matrix = (((10, "foo"), (20, "bar"), (30, "baz")),
+                       ((40, "uno"), (50, "dos"), (60, "tres")),
+                       ((70, "cuatro"), (80, "cinco"), (90, "seis")));
+      ASSERT (i OF matrix[1,1] = 10);
+      ASSERT (i OF matrix[1,2] = 20);
+      ASSERT (i OF matrix[1,3] = 30);
+      ASSERT (i OF matrix[2,1] = 40);
+      ASSERT (i OF matrix[2,2] = 50);
+      ASSERT (i OF matrix[2,3] = 60);
+      ASSERT (i OF matrix[3,1] = 70);
+      ASSERT (i OF matrix[3,2] = 80);
+      ASSERT (i OF matrix[3,3] = 90)
+END
diff --git a/gcc/testsuite/algol68/execute/row-display-4.a68 b/gcc/testsuite/algol68/execute/row-display-4.a68
new file mode 100644
index 00000000000..464d6fb48e7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/row-display-4.a68
@@ -0,0 +1,16 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,][]INT duples = (((1,2), (3,4), (5,6)),
+                         ((7,8), (9,10), (11,12)));
+      ASSERT (duples[1,1][1] = 1);
+      ASSERT (duples[1,1][2] = 2);
+      ASSERT (duples[1,2][1] = 3);
+      ASSERT (duples[1,2][2] = 4);
+      ASSERT (duples[1,3][1] = 5);
+      ASSERT (duples[1,3][2] = 6);
+      ASSERT (duples[2,1][1] = 7);
+      ASSERT (duples[2,1][2] = 8);
+      ASSERT (duples[2,2][1] = 9);
+      ASSERT (duples[2,2][2] = 10);
+      ASSERT (duples[2,3][1] = 11);
+      ASSERT (duples[2,3][2] = 12)
+END
diff --git a/gcc/testsuite/algol68/execute/row-display-5.a68 b/gcc/testsuite/algol68/execute/row-display-5.a68
new file mode 100644
index 00000000000..9d6b34bd0f7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/row-display-5.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT list1 = (1,2,3),
+            list2 = (4,5,6),
+            list3 = (7,8,9);
+      [,]INT matrix = (list1, list2, list3);
+      [,,]INT cube = (matrix, matrix, matrix);
+      ASSERT (cube[1,1,1] = 1);
+      ASSERT (cube[2,2,2] = 5);
+      ASSERT (cube[3,3,3] = 9)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-1.a68 b/gcc/testsuite/algol68/execute/rowing-1.a68
new file mode 100644
index 00000000000..792b7afbb84
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT a = 10;
+      ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1);
+      ASSERT (a[1] = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-10.a68 b/gcc/testsuite/algol68/execute/rowing-10.a68
new file mode 100644
index 00000000000..8ae0caae95d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-10.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10;
+      REF[,]INT a = i;
+      ASSERT (1 LWB a = 1 AND 1 UPB a = 1 AND 1 ELEMS a = 1);
+      ASSERT (2 LWB a = 1 AND 2 UPB a = 1 AND 2 ELEMS a = 1);
+      a[1,1] := a[1,1] + 1;
+      ASSERT (a[1,1] = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-11.a68 b/gcc/testsuite/algol68/execute/rowing-11.a68
new file mode 100644
index 00000000000..c34342cf2d4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-11.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10;
+      REF[,,]INT a = i;
+      ASSERT (1 LWB a = 1 AND 1 UPB a = 1 AND 1 ELEMS a = 1);
+      ASSERT (2 LWB a = 1 AND 2 UPB a = 1 AND 2 ELEMS a = 1);
+      ASSERT (3 LWB a = 1 AND 3 UPB a = 1 AND 3 ELEMS a = 1);
+      a[1,1,1] := a[1,1,1] + 1;
+      ASSERT (a[1,1,1] = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-12.a68 b/gcc/testsuite/algol68/execute/rowing-12.a68
new file mode 100644
index 00000000000..d0bb7b4d7d3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-12.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Rowing of NIL yields NIL.  #
+BEGIN REF INT i = NIL;
+      REF[]INT a = i;
+      ASSERT (a :=: NIL)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-13.a68 b/gcc/testsuite/algol68/execute/rowing-13.a68
new file mode 100644
index 00000000000..9ac2517b3b1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-13.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Rowing of NIL yields NIL.  #
+BEGIN REF INT i = (NIL);
+      REF[,,]INT a = (i);
+      ASSERT (a :=: NIL)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-2.a68 b/gcc/testsuite/algol68/execute/rowing-2.a68
new file mode 100644
index 00000000000..d8c66deaa5e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [][]INT a = 10;
+      ASSERT (a[1][1] = 10);
+      ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1);
+      ASSERT (LWB a[1] = 1 AND UPB a[1] = 1 AND ELEMS a[1] = 1)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-3.a68 b/gcc/testsuite/algol68/execute/rowing-3.a68
new file mode 100644
index 00000000000..bfb8fd30af4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-3.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [][][]INT a = 10;
+      ASSERT (a[1][1][1] = 10);
+      ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1);
+      ASSERT (LWB a[1] = 1 AND UPB a[1] = 1 AND ELEMS a[1] = 1);
+      ASSERT (LWB a[1][1] = 1 AND UPB a[1][1] = 1 AND ELEMS a[1][1] = 1)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-4.a68 b/gcc/testsuite/algol68/execute/rowing-4.a68
new file mode 100644
index 00000000000..0dd540d28d7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-4.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE FOO = STRUCT (INT i, REAL r);
+      FOO foo = (10, 3.14);
+      [][]FOO a = foo;
+      ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1);
+      ASSERT (LWB a[1] = 1 AND UPB a[1] = 1 AND ELEMS a[1] = 1);
+      ASSERT (i OF a[1][1] = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-5.a68 b/gcc/testsuite/algol68/execute/rowing-5.a68
new file mode 100644
index 00000000000..2172617b640
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-5.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Rowing of a name.  #
+BEGIN INT i := 10;
+      REF[]INT a = i;
+      ASSERT (LWB a = 1 AND UPB a = 1 AND ELEMS a = 1);
+      a[1] := a[1] + 1;
+      ASSERT (a[1] = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-6.a68 b/gcc/testsuite/algol68/execute/rowing-6.a68
new file mode 100644
index 00000000000..9fb050ab586
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-6.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Rowing of NIL yields NIL.  #
+BEGIN REF[]INT a = REF INT(NIL);
+      ASSERT (a :=: NIL)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-7.a68 b/gcc/testsuite/algol68/execute/rowing-7.a68
new file mode 100644
index 00000000000..dde8392f253
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-7.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]INT a = 10;
+      ASSERT (1 LWB a = 1 AND 1 UPB a = 1 AND 1 ELEMS a = 1);
+      ASSERT (2 LWB a = 1 AND 2 UPB a = 1 AND 2 ELEMS a = 1);
+      ASSERT (a[1,1] = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-8.a68 b/gcc/testsuite/algol68/execute/rowing-8.a68
new file mode 100644
index 00000000000..069ee3e21c9
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-8.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT a = 10;
+      ASSERT (1 LWB a = 1 AND 1 UPB a = 1 AND 1 ELEMS a = 1);
+      [,]INT aa = a;
+      ASSERT (1 LWB aa = 1 AND 1 UPB aa = 1 AND 1 ELEMS aa = 1);
+      ASSERT (2 LWB aa = 1 AND 2 UPB aa = 1 AND 2 ELEMS aa = 1);
+      [,,]INT aaa = aa;
+      ASSERT (1 LWB aaa = 1 AND 1 UPB aaa = 1 AND 1 ELEMS aaa = 1);
+      ASSERT (2 LWB aaa = 1 AND 2 UPB aaa = 1 AND 2 ELEMS aaa = 1);
+      ASSERT (3 LWB aaa = 1 AND 3 UPB aaa = 1 AND 3 ELEMS aaa = 1);
+      ASSERT (aaa[1,1,1] = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/rowing-9.a68 b/gcc/testsuite/algol68/execute/rowing-9.a68
new file mode 100644
index 00000000000..5e347216d30
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/rowing-9.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,,]INT aaa = 10;
+      ASSERT (1 LWB aaa = 1 AND 1 UPB aaa = 1 AND 1 ELEMS aaa = 1);
+      ASSERT (2 LWB aaa = 1 AND 2 UPB aaa = 1 AND 2 ELEMS aaa = 1);
+      ASSERT (3 LWB aaa = 1 AND 3 UPB aaa = 1 AND 3 ELEMS aaa = 1);
+      ASSERT (aaa[1,1,1] = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/selection-1.a68 b/gcc/testsuite/algol68/execute/selection-1.a68
new file mode 100644
index 00000000000..c7087b2eeab
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/selection-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Selecting a struct results in a sub-value.  #
+BEGIN MODE PERSON = STRUCT (INT age, REAL income, INT num children);
+      PERSON person = (44, 999.99, 0);
+      ASSERT (age OF person = 44);
+      ASSERT (num children OF person = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/selection-2.a68 b/gcc/testsuite/algol68/execute/selection-2.a68
new file mode 100644
index 00000000000..0d7b6c6730b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/selection-2.a68
@@ -0,0 +1,14 @@
+# { dg-options "-fstropping=upper" }  #
+# Selecting a struct name results in sub-names.  #
+BEGIN MODE PERSON = STRUCT (INT age, REAL income, INT num children);
+      PERSON person;
+      age OF person := 44;
+      income OF person := 999.99;
+      num children OF person := 0;
+      ASSERT (age OF person = 44);
+      ASSERT (num children OF person = 0);
+      REF INT ptr to age := age OF person;
+      ASSERT (ptr to age = 44);
+      age OF person := 55;
+      ASSERT (ptr to age = 55)
+END
diff --git a/gcc/testsuite/algol68/execute/selection-3.a68 b/gcc/testsuite/algol68/execute/selection-3.a68
new file mode 100644
index 00000000000..8648003ad23
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/selection-3.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+# Structs can be nested in other structs.  #
+BEGIN MODE INCOME = STRUCT (REAL salary, stock, INT code);
+      MODE PERSON = STRUCT (INT age, INCOME income, INT num children);
+
+      PERSON person = (44, (999.99, 0.0, 10), 3);
+
+      ASSERT (age OF person = 44);
+      ASSERT (code OF income OF person = 10);
+      ASSERT (num children OF person = 3);
+      ASSERT (num children OF person * code OF income OF person = 30)
+END
diff --git a/gcc/testsuite/algol68/execute/selection-4.a68 b/gcc/testsuite/algol68/execute/selection-4.a68
new file mode 100644
index 00000000000..9e81db222c1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/selection-4.a68
@@ -0,0 +1,19 @@
+# { dg-options "-fstropping=upper" }  #
+# Structs can be nested in other structs.  Version with subnames.  #
+BEGIN MODE INCOME = STRUCT (REAL salary, stock, INT code);
+      MODE PERSON = STRUCT (INT age, INCOME income, INT num children);
+
+      PERSON person;
+
+      age OF person := 44;
+      salary OF income OF person := 999.99;
+      stock OF income OF person := 0.0;
+      num children OF person := 3;
+      code OF income OF person := num children OF person;
+
+      ASSERT (age OF person = 44);
+      ASSERT (code OF income OF person = num children OF person);
+      ASSERT (code OF income OF person = 3);
+      ASSERT (num children OF person = 3);
+      ASSERT (num children OF person * code OF income OF person = 9)
+END
diff --git a/gcc/testsuite/algol68/execute/selection-5.a68 b/gcc/testsuite/algol68/execute/selection-5.a68
new file mode 100644
index 00000000000..fde72d53ade
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/selection-5.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# pr UPPER pr  #
+BEGIN MODE JORL = STRUCT (INT i, REAL r);
+      REF JORL jorl = LOC JORL := (10, 3.14);
+      ASSERT (i OF jorl = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/selection-multiple-1.a68 b/gcc/testsuite/algol68/execute/selection-multiple-1.a68
new file mode 100644
index 00000000000..1dc67eae28e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/selection-multiple-1.a68
@@ -0,0 +1,12 @@
+begin [10]struct (int age, string name) persons;
+
+      for i to UPB persons
+      do age of persons[i] := 20 + i;
+         name of persons[i] := "x" * i
+      od;
+
+      for i to UPB name of persons
+      do assert ((age of persons)[i] = 20 + i);
+         assert ((name of persons)[i] = "x" * i)
+      od
+end
diff --git a/gcc/testsuite/algol68/execute/selection-multiple-2.a68 b/gcc/testsuite/algol68/execute/selection-multiple-2.a68
new file mode 100644
index 00000000000..89f848df60b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/selection-multiple-2.a68
@@ -0,0 +1,18 @@
+begin [10,5]struct (int age, string name) persons;
+
+      for i to 1 UPB persons
+      do for j to 2 UPB persons
+         do age of persons[i,j] := 20 + i + j;
+            name of persons[i,j] := "x" * (i + j)
+         od
+      od;
+
+      assert (1 UPB name of persons = 10);
+      assert (2 UPB name of persons = 5);
+      for i to 1 UPB name of persons
+      do for j to 2 UPB name of persons
+         do assert ((age of persons)[i,j] = 20 + i + j);
+            assert ((name of persons)[i,j] = "x" * (i + j))
+         od
+      od
+end
diff --git a/gcc/testsuite/algol68/execute/serial-clause-1.a68 b/gcc/testsuite/algol68/execute/serial-clause-1.a68
new file mode 100644
index 00000000000..7253f3f4af1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      BEGIN INT i = 20; # { dg-warning "hides" } #
+            ASSERT (i = 20);
+            i
+      END;
+      ASSERT (i = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/serial-clause-10.a68 b/gcc/testsuite/algol68/execute/serial-clause-10.a68
new file mode 100644
index 00000000000..294fc6c7295
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-10.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# NIL is not voided and can appear in a context requiring VOID.  #
+BEGIN (NIL);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/serial-clause-2.a68 b/gcc/testsuite/algol68/execute/serial-clause-2.a68
new file mode 100644
index 00000000000..e333c5c2231
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-2.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BEGIN ASSERT (i = 0);
+            i
+      END;
+      INT i = 10;
+      ASSERT (i = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/serial-clause-3.a68 b/gcc/testsuite/algol68/execute/serial-clause-3.a68
new file mode 100644
index 00000000000..821c4dc9a79
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-3.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (i = 0);
+      INT i = 10;
+      ASSERT (i = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/serial-clause-4.a68 b/gcc/testsuite/algol68/execute/serial-clause-4.a68
new file mode 100644
index 00000000000..2a03f65a8a1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-4.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 10;
+      BEGIN ASSERT (i = 10);
+            i +:= 1
+      END;
+      ASSERT (i = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/serial-clause-5.a68 b/gcc/testsuite/algol68/execute/serial-clause-5.a68
new file mode 100644
index 00000000000..89ab26e38f9
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-5.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BEGIN ASSERT (i = 0);
+            i
+      END;
+      INT i := 10;
+      ASSERT (i = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/serial-clause-6.a68 b/gcc/testsuite/algol68/execute/serial-clause-6.a68
new file mode 100644
index 00000000000..13a132f404c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-6.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT ((INT y := 10;
+               INT x := 20;
+               REF INT yy;
+               (REF INT xx := x;
+                yy := y;
+                xx := yy
+               )
+              ) = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/serial-clause-7.a68 b/gcc/testsuite/algol68/execute/serial-clause-7.a68
new file mode 100644
index 00000000000..a33da4adea4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-7.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT ((INT y := 10;
+               INT x := 20;
+               REF INT yy;
+               (REF INT xx := x;
+                yy := y;
+                xx + yy
+               )
+              ) = 30)
+END
diff --git a/gcc/testsuite/algol68/execute/serial-clause-8.a68 b/gcc/testsuite/algol68/execute/serial-clause-8.a68
new file mode 100644
index 00000000000..9d32e85285c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-8.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT ((INT y := 10;
+               INT x := 20;
+               REF INT yy;
+               (REF INT xx := x;
+                yy := y;
+                xx
+               )
+              ) = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/serial-clause-9.a68 b/gcc/testsuite/algol68/execute/serial-clause-9.a68
new file mode 100644
index 00000000000..d8fe7c4d40d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-clause-9.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+# Serial clause with jump at the end.  #
+
+BEGIN INT i := BEGIN BOOL cont := TRUE;
+               back: cont := FALSE;
+                     IF cont THEN GOTO back FI
+               END;
+      ASSERT (i = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/serial-dsa-1.a68 b/gcc/testsuite/algol68/execute/serial-dsa-1.a68
new file mode 100644
index 00000000000..b27ad8c7793
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-dsa-1.a68
@@ -0,0 +1,18 @@
+{ This tests stack management for DSA serial clauses.
+  If it fails a stack overflow happens.  }
+begin { DSA due to stack allocated multiple.  }
+      to 10000
+      do [10000]int foo;
+         skip
+      od;
+      { DSA due to stack allocated multiple.  Explicit loc.  }
+      to 10000
+      do loc[10000]int foo;
+         skip
+      od;
+      { DSA due to loc generator.  }
+      to 10000
+      do ref[]int jorl = loc [10000]int;
+         skip
+      od
+end
diff --git a/gcc/testsuite/algol68/execute/serial-dsa-2.a68 b/gcc/testsuite/algol68/execute/serial-dsa-2.a68
new file mode 100644
index 00000000000..45ad0497ea8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-dsa-2.a68
@@ -0,0 +1,5 @@
+{ Check value yielding of DSA serial clauses.  }
+begin assert ((ref int foo = loc int := 100;
+               foo) = 100);
+      assert (([10000]int foo; foo[10] := 666; foo)[10] = 666)
+end
diff --git a/gcc/testsuite/algol68/execute/serial-dsa-3.a68 b/gcc/testsuite/algol68/execute/serial-dsa-3.a68
new file mode 100644
index 00000000000..7cb96dde3c6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-dsa-3.a68
@@ -0,0 +1,12 @@
+{ The jump to leak should not leak stack.  }
+begin by 10000
+      do
+         by 10000
+         do [10000]int foo;
+            skip;
+            goto leak
+         od;
+      leak:
+         skip
+      od
+end
diff --git a/gcc/testsuite/algol68/execute/serial-dsa-4.a68 b/gcc/testsuite/algol68/execute/serial-dsa-4.a68
new file mode 100644
index 00000000000..b132af8ba1d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-dsa-4.a68
@@ -0,0 +1,4 @@
+begin (ref int a = loc int := 10; goto leak; a);
+leak:
+      skip
+end
diff --git a/gcc/testsuite/algol68/execute/serial-dsa-5.a68 b/gcc/testsuite/algol68/execute/serial-dsa-5.a68
new file mode 100644
index 00000000000..fb57d5ef1e5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-dsa-5.a68
@@ -0,0 +1,3 @@
+begin assert ((ref int a = loc int := 10; a) + 1 = 11);
+      skip
+end
diff --git a/gcc/testsuite/algol68/execute/serial-dsa-6.a68 b/gcc/testsuite/algol68/execute/serial-dsa-6.a68
new file mode 100644
index 00000000000..fb17d2d6442
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-dsa-6.a68
@@ -0,0 +1,4 @@
+{ DSA and completers in a serial clause.  }
+begin assert ((ref int a = loc int := 10; a exit foo: a +:= 1) + 1 = 11);
+      skip
+end
diff --git a/gcc/testsuite/algol68/execute/sign-int-1.a68 b/gcc/testsuite/algol68/execute/sign-int-1.a68
new file mode 100644
index 00000000000..3c6d317e063
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/sign-int-1.a68
@@ -0,0 +1,28 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT zero = 0;
+      SHORT INT short zero = SHORT 0;
+      SHORT SHORT INT short short zero = SHORT SHORT 0;
+      LONG INT long zero = LONG 0;
+      LONG LONG INT long long zero = LONG LONG 0;
+      INT ten = 10;
+      SHORT INT short ten = SHORT 10;
+      SHORT SHORT INT short short ten = SHORT SHORT 10;
+      LONG INT long ten = LONG 10;
+      LONG LONG INT long long ten = LONG LONG 10;
+      ASSERT (SIGN zero = 0);
+      ASSERT (SIGN short zero = 0);
+      ASSERT (SIGN short short zero = 0);
+      ASSERT (SIGN long zero = 0);
+      ASSERT (SIGN long long zero = 0);
+      ASSERT (SIGN ten = 1);
+      ASSERT (SIGN short ten = 1);
+      ASSERT (SIGN short short ten = 1);
+      ASSERT (SIGN long ten = 1);
+      ASSERT (SIGN long long ten = 1);
+      ASSERT (SIGN -ten = -1);
+      ASSERT (SIGN -short ten = -1);
+      ASSERT (SIGN -short short ten = -1);
+      ASSERT (SIGN -long ten = -1);
+      ASSERT (SIGN -long long ten = -1)
+END
+
diff --git a/gcc/testsuite/algol68/execute/sign-real-1.a68 b/gcc/testsuite/algol68/execute/sign-real-1.a68
new file mode 100644
index 00000000000..f15fe963c23
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/sign-real-1.a68
@@ -0,0 +1,17 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL zero = 0.0;
+      LONG REAL long zero = LONG 0.0;
+      LONG LONG REAL long long zero = LONG LONG 0.0;
+      REAL ten = 10.0;
+      LONG REAL long ten = LONG 10.0;
+      LONG LONG REAL long long ten = LONG LONG 10.0;
+      ASSERT (SIGN zero = 0);
+      ASSERT (SIGN long zero = 0);
+      ASSERT (SIGN long long zero = 0);
+      ASSERT (SIGN ten = 1);
+      ASSERT (SIGN long ten = 1);
+      ASSERT (SIGN long long ten = 1);
+      ASSERT (SIGN -ten = -1);
+      ASSERT (SIGN -long ten = -1);
+      ASSERT (SIGN -long long ten = -1)
+END
diff --git a/gcc/testsuite/algol68/execute/sin-1.a68 b/gcc/testsuite/algol68/execute/sin-1.a68
new file mode 100644
index 00000000000..aac74f98b02
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/sin-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r = 0.0;
+      LONG REAL rr = LONG 45.0;
+      LONG LONG REAL rrr = LONG LONG 60.0;
+      ASSERT (sin (r) = 0.0);
+      long sin (rr);
+      long long sin (rrr)
+END
diff --git a/gcc/testsuite/algol68/execute/skip-1.a68 b/gcc/testsuite/algol68/execute/skip-1.a68
new file mode 100644
index 00000000000..a36de4ff6a4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/skip-1.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+# Check SKIPs for INT modes #
+BEGIN INT int skip = SKIP;
+      ASSERT (int skip = 0);
+      SHORT INT short int skip = SKIP;
+      ASSERT (short int skip = SHORT 0);
+      SHORT SHORT INT short short int skip = SKIP;
+      ASSERT (short short int skip = SHORT SHORT 0);
+      LONG INT long int skip = SKIP;
+      ASSERT (long int skip = LONG 0);
+      LONG LONG INT long long int skip = SKIP;
+      ASSERT (long long int skip = LONG LONG 0)
+END
diff --git a/gcc/testsuite/algol68/execute/skip-2.a68 b/gcc/testsuite/algol68/execute/skip-2.a68
new file mode 100644
index 00000000000..5cefe400b9c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/skip-2.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Check SKIP values for BOOL and CHAR. #
+BEGIN BOOL bool skip = SKIP;
+      ASSERT (bool skip = FALSE);
+      CHAR char skip = SKIP;
+      ASSERT (char skip = " ")
+END
diff --git a/gcc/testsuite/algol68/execute/skip-struct-1.a68 b/gcc/testsuite/algol68/execute/skip-struct-1.a68
new file mode 100644
index 00000000000..72e9a1137e6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/skip-struct-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE INCOME = STRUCT (REAL salary, stock, INT jorl);
+      MODE PERSON = STRUCT (INT age, INCOME income, INT num children);
+      PERSON person = SKIP;
+      ASSERT (age OF person = 0);
+      ASSERT (jorl OF income OF person = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/slice-indexing-1.a68 b/gcc/testsuite/algol68/execute/slice-indexing-1.a68
new file mode 100644
index 00000000000..53d14fa982f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/slice-indexing-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING foo = "foo";
+      ASSERT (foo[1] = "f");
+      ASSERT (foo[2] = "o");
+      ASSERT (foo[3] = "o");
+      STRING bar := "foo";
+      ASSERT (bar[1] = "f");
+      ASSERT (bar[2] = "o");
+      ASSERT (bar[3] = "o")
+END
diff --git a/gcc/testsuite/algol68/execute/slice-indexing-2.a68 b/gcc/testsuite/algol68/execute/slice-indexing-2.a68
new file mode 100644
index 00000000000..defb675d3a3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/slice-indexing-2.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT foo = (1,2,3);
+      ASSERT (foo[1] = 1);
+      ASSERT (foo[2] = 2);
+      ASSERT (foo[3] = 3);
+      [3]INT bar := (1,2,3);
+      ASSERT (bar[1] = 1);
+      ASSERT (bar[2] = 2);
+      ASSERT (bar[3] = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/slice-indexing-3.a68 b/gcc/testsuite/algol68/execute/slice-indexing-3.a68
new file mode 100644
index 00000000000..593bd71766e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/slice-indexing-3.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT foo = (10,20,30);
+      ASSERT (foo[1] = 10);
+      ASSERT (foo[2] = 20);
+      ASSERT (foo[3] = 30);
+      [3]INT bar := (100,200,300);
+      ASSERT (bar[1] = 100);
+      ASSERT (bar[2] = 200);
+      ASSERT (bar[3] = 300)
+END
diff --git a/gcc/testsuite/algol68/execute/slice-indexing-4.a68 b/gcc/testsuite/algol68/execute/slice-indexing-4.a68
new file mode 100644
index 00000000000..bf3a3b18d70
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/slice-indexing-4.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE PERSON = STRUCT (INT i, STRING s);
+      []PERSON persons = ((10, "foo"), (20, "barbar"), (30, "baz"));
+      puts (s OF persons[1]);
+      puts (s OF persons[2]);
+      puts (s OF persons[3]);
+      ASSERT (i OF persons[1] = 10);
+      ASSERT (i OF persons[2] = 20);
+      ASSERT (i OF persons[3] = 30)
+END
diff --git a/gcc/testsuite/algol68/execute/slice-indexing-5.a68 b/gcc/testsuite/algol68/execute/slice-indexing-5.a68
new file mode 100644
index 00000000000..f236eeffd15
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/slice-indexing-5.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRUCT([]INT i, REAL r) s = ((1,2,3), 3.14);
+      ASSERT ((i OF s)[1] = 1)
+END
diff --git a/gcc/testsuite/algol68/execute/slice-indexing-6.a68 b/gcc/testsuite/algol68/execute/slice-indexing-6.a68
new file mode 100644
index 00000000000..8d795560dee
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/slice-indexing-6.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT rsp := 5;
+      [10]INT run stack;
+      run stack [(rsp -:= 1) + 1]
+END
diff --git a/gcc/testsuite/algol68/execute/slice-indexing-7.a68 b/gcc/testsuite/algol68/execute/slice-indexing-7.a68
new file mode 100644
index 00000000000..d3870f6119f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/slice-indexing-7.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING s := "foo";
+      s[2] := "x"
+END
diff --git a/gcc/testsuite/algol68/execute/sqrt-1.a68 b/gcc/testsuite/algol68/execute/sqrt-1.a68
new file mode 100644
index 00000000000..725a7727112
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/sqrt-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r = 100.0;
+      LONG REAL rr = LONG 25.0;
+      LONG LONG REAL rrr = LONG LONG 25.0;
+      ASSERT (sqrt (r) = 10.0);
+      ASSERT (long sqrt (rr) = LONG 5.0);
+      ASSERT (long long sqrt (rrr) = LONG LONG 5.0)
+END
diff --git a/gcc/testsuite/algol68/execute/string-1.a68 b/gcc/testsuite/algol68/execute/string-1.a68
new file mode 100644
index 00000000000..28e44fe18fe
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/string-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING s = "";
+      ASSERT (LWB s = 1 AND UPB s = 0);
+      STRING t = ();
+      ASSERT (LWB t = 1 AND UPB t = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/string-2.a68 b/gcc/testsuite/algol68/execute/string-2.a68
new file mode 100644
index 00000000000..b0b898a51ef
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/string-2.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING s;
+      ASSERT (LWB s = 1 AND UPB s = 0 AND ELEMS s = 0);
+      s := "foo";
+      puts (s);
+      ASSERT (LWB s = 1 AND UPB s = 3 AND s[1] = "f" AND s[2] = "o" AND s[3] = "o");
+      s := "bar";
+      puts (s);
+      ASSERT (LWB s = 1 AND UPB s = 3 AND s[1] = "b" AND s[2] = "a" AND s[3] = "r");
+      s := "x";
+      ASSERT (LWB s = 1 AND UPB s = 1 AND s[1] = "x");
+      puts (s)
+END
diff --git a/gcc/testsuite/algol68/execute/string-4.a68 b/gcc/testsuite/algol68/execute/string-4.a68
new file mode 100644
index 00000000000..984d6625d90
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/string-4.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING s;
+      ASSERT (LWB s = 1 AND UPB s = 0 AND ELEMS s = 0);
+      s +:= "foo";
+      ASSERT (LWB s = 1 AND UPB s = 3 AND ELEMS s = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/string-break-1.a68 b/gcc/testsuite/algol68/execute/string-break-1.a68
new file mode 100644
index 00000000000..e99cfe9ebad
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/string-break-1.a68
@@ -0,0 +1,8 @@
+begin assert (UPB "foo'nbar" = 7 AND "foo'nbar"[4] = REPR 10);
+      assert (UPB "foo'tbar" = 7 AND "foo'tbar"[4] = REPR 9);
+      assert (UPB "foo'rbar" = 7 AND "foo'rbar"[4] = REPR 13);
+      assert (UPB "foo'fbar" = 7 AND "foo'fbar"[4] = REPR 12);
+      assert (UPB "foo''bar" = 7 AND "foo''bar"[4] = REPR 39);
+      assert ("'(u0048,u0065,U0000006c,u006c,U0000006f)" = "Hello");
+      assert ("'( u0048,   u0065,   U0000006c,u006c,     U0000006f  )" = "Hello")
+end
diff --git a/gcc/testsuite/algol68/execute/struct-self-1.a68 b/gcc/testsuite/algol68/execute/struct-self-1.a68
new file mode 100644
index 00000000000..94622aaecd2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/struct-self-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE NODE = STRUCT (INT code, REF NODE next);
+      NODE top;
+      ASSERT (next OF top :=: REF NODE (NIL))
+END
diff --git a/gcc/testsuite/algol68/execute/struct-self-2.a68 b/gcc/testsuite/algol68/execute/struct-self-2.a68
new file mode 100644
index 00000000000..a1127ebf3b8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/struct-self-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE NODE = STRUCT (INT code, REF NODE next);
+      NODE top = (20, NIL);
+      ASSERT (code OF top = 20);
+      ASSERT (next OF top :=: NIL)
+END
diff --git a/gcc/testsuite/algol68/execute/struct-self-3.a68 b/gcc/testsuite/algol68/execute/struct-self-3.a68
new file mode 100644
index 00000000000..3829daf6848
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/struct-self-3.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE NODE = STRUCT (INT code, REF NODE next);
+      NODE top := (10, NIL);
+      NODE next := (20, NIL);
+      next OF top := next;
+      ASSERT (code OF next OF top = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/structure-display-1.a68 b/gcc/testsuite/algol68/execute/structure-display-1.a68
new file mode 100644
index 00000000000..a53c247e1af
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/structure-display-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE INCOME = STRUCT (REAL salary, stock, INT code);
+      MODE PERSON = STRUCT (INT age, INCOME income, INT num children);
+      INCOME income = (100.0, 200.0, 300);
+      ASSERT (code OF income = 300);
+      PERSON person := (24, (1000.0, 2000.0, 3000), 3);
+      ASSERT (code OF income OF person = 3000);
+      ASSERT (num children OF person = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/structure-display-2.a68 b/gcc/testsuite/algol68/execute/structure-display-2.a68
new file mode 100644
index 00000000000..563f979e321
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/structure-display-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE NODE = STRUCT (INT code, REF INT next);
+      INT val := 20;
+      NODE top = (10, val);
+      ASSERT (val = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/structure-display-3.a68 b/gcc/testsuite/algol68/execute/structure-display-3.a68
new file mode 100644
index 00000000000..178463f60dc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/structure-display-3.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE FOO = STRUCT (INT i, REF INT j);
+      INT x := 10;
+      FOO foo;
+      foo := (10, x);
+      ASSERT (j OF foo = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/structure-display-4.a68 b/gcc/testsuite/algol68/execute/structure-display-4.a68
new file mode 100644
index 00000000000..2a69172b880
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/structure-display-4.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE FOO = STRUCT (INT i, REF INT j);
+      INT x := 10;
+      REF INT xx;
+      FOO foo;
+      foo := (10, xx := x);
+      ASSERT (j OF foo = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/structure-display-5.a68 b/gcc/testsuite/algol68/execute/structure-display-5.a68
new file mode 100644
index 00000000000..0b99113f160
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/structure-display-5.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE VEC = STRUCT (REAL xcoord, ycoord, zcoord);
+      VEC v1, v2, v3;
+      v1 := (1,1,1);
+      ASSERT (xcoord OF v1 = 1);
+      ASSERT (ycoord OF v1 = 1);
+      ASSERT (zcoord OF v1 = 1);
+      REAL x = 3.14, i = 3;
+      v2 := (x + 2, 3.4, i - 3)
+END
diff --git a/gcc/testsuite/algol68/execute/tan-1.a68 b/gcc/testsuite/algol68/execute/tan-1.a68
new file mode 100644
index 00000000000..a7aede69749
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/tan-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL r = 0.0;
+      LONG REAL rr = LONG 50.0;
+      LONG LONG REAL rrr = LONG LONG 50.0;
+      ASSERT (tan (r) = 0.0);
+      long tan (rr);
+      long long tan (rrr)
+END
diff --git a/gcc/testsuite/algol68/execute/timesab-string-1.a68 b/gcc/testsuite/algol68/execute/timesab-string-1.a68
new file mode 100644
index 00000000000..3ff48fe91f5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/timesab-string-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING foo := "foo";
+      foo TIMESAB 1;
+      ASSERT (foo = "foo");
+      foo *:= 3;
+      ASSERT (foo = "foofoofoo")
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-1.a68 b/gcc/testsuite/algol68/execute/trimmer-1.a68
new file mode 100644
index 00000000000..feae4cefb78
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
+      ASSERT (arr[3] = 2 AND arr[4] = 3);
+      []INT jorl = arr[2:3@20];
+      ASSERT (LWB jorl = 20 AND UPB jorl = 21);
+      ASSERT (jorl[20] = 1 AND jorl [21] = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-10.a68 b/gcc/testsuite/algol68/execute/trimmer-10.a68
new file mode 100644
index 00000000000..66db83af5fb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-10.a68
@@ -0,0 +1,14 @@
+# { dg-options "-fstropping=upper" }  #
+# Trimming with flat descriptors should lead to flat multiples.  #
+BEGIN []INT a = (1,2,3);
+
+      ASSERT (UPB a[2:1] < LWB a[2:1]);
+      ASSERT (UPB a[20:2] < LWB a[20:2]);
+
+      [,]INT aa = ((1,2,3),
+                   (4,5,6),
+                   (7,8,9));
+      
+      ASSERT ((1 UPB aa[1,2:1]) < ((1 LWB aa[1,2:1])));
+      ASSERT ((1 UPB aa[1,20:]) < ((1 LWB aa[1,20:])))
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-2.a68 b/gcc/testsuite/algol68/execute/trimmer-2.a68
new file mode 100644
index 00000000000..68996d22bc1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-2.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
+      ASSERT (arr[3] = 2 AND arr[4] = 3);
+      []INT jorl = arr[2:3];
+      ASSERT (LWB jorl = 1 AND UPB jorl = 2);
+      ASSERT (jorl[1] = 1 AND jorl [2] = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-3.a68 b/gcc/testsuite/algol68/execute/trimmer-3.a68
new file mode 100644
index 00000000000..8af69db6b8d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-3.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
+      ASSERT (arr[3] = 2 AND arr[4] = 3);
+      []INT jorl = arr[:@20];
+      ASSERT (LWB jorl = 20 AND UPB jorl = 22);
+      ASSERT (jorl[20] = 1 AND jorl[21] = 2 AND jorl[22] = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-4.a68 b/gcc/testsuite/algol68/execute/trimmer-4.a68
new file mode 100644
index 00000000000..fdcd37094d6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-4.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
+      ASSERT (arr[3] = 2 AND arr[4] = 3);
+      []INT jorl = arr[3:];
+      ASSERT (LWB jorl = 1 AND UPB jorl = 2);
+      ASSERT (jorl[1] = 2 AND jorl[2] = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-5.a68 b/gcc/testsuite/algol68/execute/trimmer-5.a68
new file mode 100644
index 00000000000..892fea7d269
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-5.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
+      ASSERT (arr[3] = 2 AND arr[4] = 3);
+      []INT jorl = arr[:3 AT 10];
+      ASSERT (LWB jorl = 10 AND UPB jorl = 11);
+      ASSERT (jorl[10] = 1 AND jorl[11] = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-6.a68 b/gcc/testsuite/algol68/execute/trimmer-6.a68
new file mode 100644
index 00000000000..3e9f293e015
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-6.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
+      ASSERT (arr[3] = 2 AND arr[4] = 3);
+      []INT jorl = arr[:3@10];
+      ASSERT (LWB jorl = 10 AND UPB jorl = 11);
+      ASSERT (jorl[10] = 1 AND jorl[11] = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-7.a68 b/gcc/testsuite/algol68/execute/trimmer-7.a68
new file mode 100644
index 00000000000..8d3ebf9293f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-7.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT arr = (1,2,3);
+      ASSERT (arr[2] = 2 AND arr[3] = 3);
+      []INT jorl = arr[2:3@20];
+      ASSERT (LWB jorl = 20 AND UPB jorl = 21);
+      ASSERT (jorl[20] = 2 AND jorl [21] = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-8.a68 b/gcc/testsuite/algol68/execute/trimmer-8.a68
new file mode 100644
index 00000000000..50842efb27e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-8.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [2:4]INT arr := []INT(1,2,3)[@2];
+      ASSERT (arr[3] = 2 AND arr[4] = 3);
+      [10:11]INT jorl := arr[:3 AT 10];
+      ASSERT (LWB jorl = 10 AND UPB jorl = 11);
+      ASSERT (jorl[10] = 1 AND jorl[11] = 2);
+      jorl[10] := 100;
+      ASSERT (jorl[10] = 100 AND jorl[11] = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-9.a68 b/gcc/testsuite/algol68/execute/trimmer-9.a68
new file mode 100644
index 00000000000..aa0d52d2a08
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-9.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT arr = (1,2,3);
+      ASSERT (arr[2] = 2 AND arr[3] = 3);
+      []INT jorl = arr[@20];
+      ASSERT (LWB jorl = 20 AND UPB jorl = 22);
+      ASSERT (jorl[20] = 1 AND jorl [21] = 2 AND jorl [22] = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-1.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-1.a68
new file mode 100644
index 00000000000..2cec8a858e7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-matrix-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]INT matrix = ((1,2,3),
+                       (4,5,6),
+                       (7,8,9));
+      [2]INT column := matrix[3,2:3];
+      ASSERT (column[1] = 8);
+      ASSERT (column[2] = 9)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-2.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-2.a68
new file mode 100644
index 00000000000..6ca961fe1be
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-matrix-2.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]INT matrix = ((1,2,3),
+                       (4,5,6),
+                       (7,8,9));
+      [2]INT column := matrix[2,1:2];
+      ASSERT (column[1] = 4);
+      ASSERT (column[2] = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-3.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-3.a68
new file mode 100644
index 00000000000..5de2bee3a37
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-matrix-3.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]INT matrix = ((1,2,3),
+                       (4,5,6),
+                       (7,8,9));
+      [3]INT column := matrix[2,1:3];
+      ASSERT (column[1] = 4);
+      ASSERT (column[2] = 5);
+      ASSERT (column[3] = 6)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-4.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-4.a68
new file mode 100644
index 00000000000..71168ad6df8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-matrix-4.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]INT matrix = ((1,2,3),
+                       (4,5,6),
+                       (7,8,9));
+      []INT column = matrix[1:3,2];
+      ASSERT (LWB column = 1);
+      ASSERT (UPB column = 3);
+      ASSERT (column[1] = 2 AND column[2] = 5 AND column[3] = 8)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-5.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-5.a68
new file mode 100644
index 00000000000..6d5f69bc53e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-matrix-5.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]INT matrix = ((1,2,3),
+                       (4,5,6),
+                       (7,8,9));
+      []INT column = matrix[2:3,2];
+      ASSERT (LWB column = 1);
+      ASSERT (UPB column = 2);
+      ASSERT (column[1] = 5 AND column[2] = 8)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-matrix-6.a68 b/gcc/testsuite/algol68/execute/trimmer-matrix-6.a68
new file mode 100644
index 00000000000..59a33896bf6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-matrix-6.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [,]INT matrix = ((1,2,3),
+                       (4,5,6),
+                       (7,8,9));
+      []INT row = matrix[3,1:3];
+      ASSERT (LWB row = 1);
+      ASSERT (UPB row = 3);
+      ASSERT (row[1] = 7 AND row[2] = 8 AND row[3] = 9)
+END
diff --git a/gcc/testsuite/algol68/execute/trimmer-name-1.a68 b/gcc/testsuite/algol68/execute/trimmer-name-1.a68
new file mode 100644
index 00000000000..6b4601c64c7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/trimmer-name-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REF[]CHAR t;
+      PROC foo = VOID: (HEAP[3]CHAR ss := ("1","2","3"); t := ss[1:3]);
+      foo;
+      ASSERT (LWB t = 1 AND UPB t = 3);
+      ASSERT (t[1] = "1" AND t[2] = "2" AND t[3] = "3")
+END
diff --git a/gcc/testsuite/algol68/execute/undefined-1.a68 b/gcc/testsuite/algol68/execute/undefined-1.a68
new file mode 100644
index 00000000000..af97a0c0e83
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/undefined-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+# j's value is undefined (defined to be 0 in GNU Algol)  #
+BEGIN INT x := 0;
+      FOR i TO 5
+      DO ASSERT (j = 0);
+         IF j > 20 THEN stop FI;
+         INT j = x + i;
+         x +:= 1
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/undefined-2.a68 b/gcc/testsuite/algol68/execute/undefined-2.a68
new file mode 100644
index 00000000000..54addde1fd0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/undefined-2.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+# The undefined value of the multiple `a' is an empty multiple. #
+BEGIN ASSERT (i = 0);
+      ASSERT (LWB a = 1 AND UPB a = 0 AND ELEMS a = 0);
+      []INT a = (1, 2, 3);
+      INT i = 10;
+      ASSERT (i = 10);
+      ASSERT (LWB a = 1 AND UPB a = 3 AND ELEMS a = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/undefined-3.a68 b/gcc/testsuite/algol68/execute/undefined-3.a68
new file mode 100644
index 00000000000..2a746ad7eb4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/undefined-3.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (sum = 1);
+      PROC sum = INT: i + 1;
+      INT i = 10;
+      ASSERT (sum = 11)
+END
diff --git a/gcc/testsuite/algol68/execute/undefined-4.a68 b/gcc/testsuite/algol68/execute/undefined-4.a68
new file mode 100644
index 00000000000..c602c052bfc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/undefined-4.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC is even = (INT n) BOOL: (n = zero | TRUE | is odd (n - 1));
+      PROC is odd = (INT n) BOOL: (n = zero | FALSE | is even (n - 1));
+      ASSERT (is even (20));
+      ASSERT (is odd (13));
+      INT zero := 0;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/undefined-5.a68 b/gcc/testsuite/algol68/execute/undefined-5.a68
new file mode 100644
index 00000000000..3cbb41416d2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/undefined-5.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN PROC is even = (INT n) BOOL: (n = zero | TRUE | is odd (DECR n));
+      PROC is odd = (INT n) BOOL: (n = zero | FALSE | is even (DECR n));
+      OP DECR = (INT a) INT:  a - 1;
+      ASSERT (is even (20));
+      ASSERT (is odd (13));
+      INT zero := 0;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/uniting-1.a68 b/gcc/testsuite/algol68/execute/uniting-1.a68
new file mode 100644
index 00000000000..dee0b50b282
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/uniting-1.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN UNION(INT,REAL,CHAR) datum := 3.14;
+      UNION(INT,REAL,[]INT,CHAR) datux;
+      datux := datum;
+      ASSERT (CASE datux
+              IN (INT): 10,
+                 (REAL): 20,
+                 (CHAR c): 30
+              ESAC = 20);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/uniting-2.a68 b/gcc/testsuite/algol68/execute/uniting-2.a68
new file mode 100644
index 00000000000..565005010e3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/uniting-2.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN UNION(INT,REAL,CHAR) datum := "X";
+      UNION(INT,REAL,[]INT,CHAR) datux;
+      datux := datum;
+      ASSERT (CASE datux
+              IN (INT): 10,
+                 (REAL): 20,
+                 (CHAR c): 30
+              ESAC = 30);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/uniting-3.a68 b/gcc/testsuite/algol68/execute/uniting-3.a68
new file mode 100644
index 00000000000..cb73c2f8531
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/uniting-3.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN UNION(INT,REAL,CHAR) datum := 10;
+      UNION(INT,REAL,[]INT,CHAR) datux;
+      datux := datum;
+      ASSERT (CASE datux
+              IN (INT): 10,
+                 (REAL): 20,
+                 (CHAR c): 30
+              ESAC = 10);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/uniting-4.a68 b/gcc/testsuite/algol68/execute/uniting-4.a68
new file mode 100644
index 00000000000..c7b82b8310c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/uniting-4.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Uniting STRING to ROWS.  #
+BEGIN PROC strlen = (STRING s) INT: ELEMS s;
+      ASSERT (strlen ("foo") = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/up-down-bits-1.a68 b/gcc/testsuite/algol68/execute/up-down-bits-1.a68
new file mode 100644
index 00000000000..b13c05599e5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/up-down-bits-1.a68
@@ -0,0 +1,33 @@
+# { dg-options "-fstropping=upper" }  #
+# SHORTEN and LENG on SIZETY BITS #
+BEGIN BITS b = 16rff;
+      ASSERT (b UP 4 = 16rff0);
+      ASSERT (b SHL 4 = 16rff0);
+      ASSERT (b DOWN 4 = 16r0f);
+      ASSERT (b SHR 4 = 16r0f);
+
+      LONG BITS bb = LONG 16rff;
+      ASSERT (bb UP 4 = LONG 16rff0);
+      ASSERT (bb SHL 4 = LONG 16rff0);
+      ASSERT (bb DOWN 4 = LONG 16r0f);
+      ASSERT (bb SHR 4 = LONG 16r0f);
+
+      LONG LONG BITS bbb = LONG LONG 16rff;
+      ASSERT (bbb UP 4 = LONG LONG 16rff0);
+      ASSERT (bbb SHL 4 = LONG LONG 16rff0);
+      ASSERT (bbb DOWN 4 = LONG LONG 16r0f);
+      ASSERT (bbb SHR 4 = LONG LONG 16r0f);
+
+      SHORT BITS ss = SHORT 16rff;
+      ASSERT (ss UP 4 = SHORT 16rff0);
+      ASSERT (ss SHL 4 = SHORT 16rff0);
+      ASSERT (ss DOWN 4 = SHORT 16r0f);
+      ASSERT (ss SHR 4 = SHORT 16r0f);
+
+      SHORT SHORT BITS sss = SHORT SHORT 16r0f;
+      ASSERT (sss UP 4 = SHORT SHORT 16rf0);
+      ASSERT (sss SHL 4 = SHORT SHORT 16rf0);
+      ASSERT (sss DOWN 2 = SHORT SHORT 16r03);
+      ASSERT (sss SHR 2 = SHORT SHORT 16r03)
+END
+
diff --git a/gcc/testsuite/algol68/execute/upb-1.a68 b/gcc/testsuite/algol68/execute/upb-1.a68
new file mode 100644
index 00000000000..d74ffa5b33b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/upb-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (UPB "foo" = 3);
+      ASSERT (1 UPB "foo" = 3);
+      ASSERT (UPB "" = 0);
+      ASSERT ((INT i = 1; UPB "") = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/vacuum-1.a68 b/gcc/testsuite/algol68/execute/vacuum-1.a68
new file mode 100644
index 00000000000..c4472c53c1f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/vacuum-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT a = ();
+      ASSERT (LWB a = 1 AND UPB a = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-1.a68 b/gcc/testsuite/algol68/execute/variable-declaration-1.a68
new file mode 100644
index 00000000000..0b1f4fce83b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx := x := 20;
+      ASSERT (xx = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-2.a68 b/gcc/testsuite/algol68/execute/variable-declaration-2.a68
new file mode 100644
index 00000000000..6b80f7b8214
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-2.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx := x;
+      ASSERT (xx = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-3.a68 b/gcc/testsuite/algol68/execute/variable-declaration-3.a68
new file mode 100644
index 00000000000..4b1f0802347
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-3.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx := (x := 20);
+      ASSERT (xx = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-4.a68 b/gcc/testsuite/algol68/execute/variable-declaration-4.a68
new file mode 100644
index 00000000000..0c66d9e1fb0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-4.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF INT xx := ((x));
+      ASSERT (xx = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-5.a68 b/gcc/testsuite/algol68/execute/variable-declaration-5.a68
new file mode 100644
index 00000000000..993bbe7c1fc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-5.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT x := 10;
+      REF REF INT xx := LOC REF INT := x := 20;
+      ASSERT (xx = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-6.a68 b/gcc/testsuite/algol68/execute/variable-declaration-6.a68
new file mode 100644
index 00000000000..4f8b1c37ec2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-6.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE FOO = STRUCT (STRING s, INT i);
+      FOO f1 := ("foo", 10);
+      ASSERT (i OF f1 = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-heap-1.a68 b/gcc/testsuite/algol68/execute/variable-declaration-heap-1.a68
new file mode 100644
index 00000000000..e7b40a19a99
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-heap-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN HEAP INT a := 10;
+      ASSERT (a = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-heap-2.a68 b/gcc/testsuite/algol68/execute/variable-declaration-heap-2.a68
new file mode 100644
index 00000000000..406e8c570d6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-heap-2.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN HEAP INT x, y;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-1.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-1.a68
new file mode 100644
index 00000000000..17864f9293f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [10,3]INT arr;
+      ASSERT (1 LWB arr = 1 AND 1 UPB arr = 10 AND 1 ELEMS arr = 10);
+      ASSERT (2 LWB arr = 1 AND 2 UPB arr = 3 AND 2 ELEMS arr = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-2.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-2.a68
new file mode 100644
index 00000000000..d400ee87dfd
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n = 10;
+      [n,3]INT arr;
+      ASSERT (1 LWB arr = 1 AND 1 UPB arr = 10 AND 1 ELEMS arr = 10);
+      ASSERT (2 LWB arr = 1 AND 2 UPB arr = 3 AND 2 ELEMS arr = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-3.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-3.a68
new file mode 100644
index 00000000000..a006feddce5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-3.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := 10, m := 3;
+      [n,m]INT arr;
+      ASSERT (1 LWB arr = 1 AND 1 UPB arr = 10 AND 1 ELEMS arr = 10);
+      ASSERT (2 LWB arr = 1 AND 2 UPB arr = 3 AND 2 ELEMS arr = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-4.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-4.a68
new file mode 100644
index 00000000000..8e0467b965f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-4.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := -4, m := 0;
+      [n:m,2]INT arr;
+      ASSERT (1 LWB arr = -4 AND 1 UPB arr = 0 AND 1 ELEMS arr = 5);
+      ASSERT (2 LWB arr = 1 AND 2 UPB arr = 2 AND 2 ELEMS arr = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-5.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-5.a68
new file mode 100644
index 00000000000..0a1889f55cc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-5.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := -4, m := 0;
+      [n:m,2]INT arr;
+      FOR i FROM 1 LWB arr TO 1 UPB arr
+      DO FOR j FROM 2 LWB arr TO 2 UPB arr
+         DO ASSERT (arr[i,j] = INT(SKIP)) OD
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-6.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-6.a68
new file mode 100644
index 00000000000..3dde91c5ffc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-6.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := -4, m := 0;
+      [n:m,2]REF INT arr;
+      FOR i FROM 1 LWB arr TO 1 UPB arr
+      DO FOR j FROM 2 LWB arr TO 2 UPB arr
+         DO ASSERT (REF INT (arr[i,j]) :=: REF INT(SKIP)) OD
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-7.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-7.a68
new file mode 100644
index 00000000000..75ee9a4516f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-7.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := 2, m := 3;
+      [n][m]INT arr;
+      FOR i FROM LWB arr TO UPB arr
+      DO FOR j FROM LWB arr[i] TO UPB arr[i]
+         DO ASSERT (arr[i][j] = INT(SKIP)) OD
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-8.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-8.a68
new file mode 100644
index 00000000000..391d282a9cb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-8.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := -4, m := 0;
+      [10][n:m,2]INT arr;
+      FOR k FROM LWB arr TO UPB arr
+      DO FOR i FROM 1 LWB arr[k] TO 1 UPB arr[k]
+         DO FOR j FROM 2 LWB arr[k] TO 2 UPB arr[k]
+            DO ASSERT (arr[k][i,j] = INT(SKIP)) OD
+         OD
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/variable-declaration-multiple-9.a68 b/gcc/testsuite/algol68/execute/variable-declaration-multiple-9.a68
new file mode 100644
index 00000000000..21c20eaed2b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/variable-declaration-multiple-9.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [4]INT x, y;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/voiding-1.a68 b/gcc/testsuite/algol68/execute/voiding-1.a68
new file mode 100644
index 00000000000..ec6088d88fe
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/voiding-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i;
+      2 = i
+END
diff --git a/gcc/testsuite/algol68/execute/widening-1.a68 b/gcc/testsuite/algol68/execute/widening-1.a68
new file mode 100644
index 00000000000..642b226926e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/widening-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 10;
+      REAL foo = i;
+      ASSERT (foo > 9.9);
+      ASSERT (foo < 10.1)
+END
diff --git a/gcc/testsuite/algol68/execute/widening-2.a68 b/gcc/testsuite/algol68/execute/widening-2.a68
new file mode 100644
index 00000000000..9ac6aae5396
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/widening-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN LONG INT i = LONG 10;
+      LONG REAL foo = i;
+      ASSERT (foo > LONG 9.9);
+      ASSERT (foo < LONG 10.1)
+END
diff --git a/gcc/testsuite/algol68/execute/widening-bits-1.a68 b/gcc/testsuite/algol68/execute/widening-bits-1.a68
new file mode 100644
index 00000000000..6940a23cb36
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/widening-bits-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# XXX use environment enquiry for actual size of BITS #
+BEGIN []BOOL foo = 16rffff;
+      ASSERT (LWB foo = 1 AND UPB foo = 32);
+      FOR i TO 16 DO ASSERT (foo[i] = FALSE) OD;
+      FOR i FROM 17 TO 32 DO ASSERT (foo[i] = TRUE) OD
+END
diff --git a/gcc/testsuite/algol68/execute/widening-bits-2.a68 b/gcc/testsuite/algol68/execute/widening-bits-2.a68
new file mode 100644
index 00000000000..ea47b7051b1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/widening-bits-2.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# XXX use environment enquiry for actual size of LONG BITS #
+BEGIN []BOOL foo = LONG 16rffffffff;
+      ASSERT (LWB foo = 1 AND UPB foo = 64);
+      FOR i TO 32 DO ASSERT (foo[i] = FALSE) OD;
+      FOR i FROM 33 TO 64 DO ASSERT (foo[i] = TRUE) OD
+END
diff --git a/gcc/testsuite/algol68/execute/widening-bits-3.a68 b/gcc/testsuite/algol68/execute/widening-bits-3.a68
new file mode 100644
index 00000000000..61e49da41e4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/widening-bits-3.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# XXX use environment enquiry for actual size of LONG LONG BITS #
+BEGIN []BOOL foo = LONG LONG 16rffffffff;
+      ASSERT (LWB foo = 1 AND UPB foo = 64);
+      FOR i TO 32 DO ASSERT (foo[i] = FALSE) OD;
+      FOR i FROM 33 TO 64 DO ASSERT (foo[i] = TRUE) OD
+END
diff --git a/gcc/testsuite/algol68/execute/xor-bits-1.a68 b/gcc/testsuite/algol68/execute/xor-bits-1.a68
new file mode 100644
index 00000000000..beeafb592fb
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/xor-bits-1.a68
@@ -0,0 +1,18 @@
+# { dg-options "-fstropping=upper" }  #
+# XOR for SIZETY BITS.  #
+BEGIN BITS b = 16rf0f0;
+      ASSERT ((b XOR 16r0f0f) = 16rffff);
+      ASSERT ((b XOR 16r00ff) = 16rf00f);
+      LONG BITS bb = LONG 16rf0f0;
+      ASSERT ((bb XOR LONG 16r0f0f) = LONG 16rffff);
+      ASSERT ((bb XOR LONG 16r00ff) = LONG 16rf00f);
+      LONG LONG BITS bbb = LONG LONG 16rf0f0;
+      ASSERT ((bbb XOR LONG LONG 16r0f0f) = LONG LONG 16rffff);
+      ASSERT ((bbb XOR LONG LONG 16r00ff) = LONG LONG 16rf00f);
+      SHORT BITS ss = SHORT 16rf0f0;
+      ASSERT ((ss XOR SHORT 16r0f0f) = SHORT 16rffff);
+      ASSERT ((ss XOR SHORT 16r00ff) = SHORT 16rf00f);
+      SHORT SHORT BITS sss = SHORT SHORT 16rf0;
+      ASSERT ((sss XOR SHORT SHORT 16r0f) = SHORT SHORT 16rff);
+      ASSERT ((sss XOR SHORT SHORT 16rff) = SHORT SHORT 16r0f)
+END
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 45/47] a68: testsuite: compilation tests
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (43 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 44/47] a68: testsuite: execution tests 2/2 Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 46/47] a68: testsuite: revised MC Algol 68 test set Jose E. Marchesi
                   ` (2 subsequent siblings)
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/testsuite/ChangeLog

	* algol68/compile/a68includes/goodbye-supper.a68
	* algol68/compile/a68includes/goodbye.a68: Likewise.
	* algol68/compile/a68includes/hello-supper.a68: Likewise.
	* algol68/compile/a68includes/hello.a68: Likewise.
	* algol68/compile/actual-bounds-expected-1.a68: Likewise.
	* algol68/compile/actual-bounds-expected-2.a68: Likewise.
	* algol68/compile/actual-bounds-expected-3.a68: Likewise.
	* algol68/compile/balancing-1.a68: Likewise.
	* algol68/compile/bold-nestable-comment-1.a68: Likewise.
	* algol68/compile/bold-taggle-1.a68: Likewise.
	* algol68/compile/brief-nestable-comment-1.a68: Likewise.
	* algol68/compile/brief-nestable-comment-2.a68: Likewise.
	* algol68/compile/char-break-1.a68: Likewise.
	* algol68/compile/compile.exp: Likewise.
	* algol68/compile/conditional-clause-1.a68: Likewise.
	* algol68/compile/error-bold-taggle-1.a68: Likewise.
	* algol68/compile/error-coercion-1.a68: Likewise.
	* algol68/compile/error-coercion-2.a68: Likewise.
	* algol68/compile/error-coercion-flex-1.a68: Likewise.
	* algol68/compile/error-conformance-clause-1.a68: Likewise.
	* algol68/compile/error-contraction-1.a68: Likewise.
	* algol68/compile/error-contraction-2.a68: Likewise.
	* algol68/compile/error-incestuous-union-1.a68: Likewise.
	* algol68/compile/error-label-after-decl-1.a68: Likewise.
	* algol68/compile/error-nestable-comments-1.a68: Likewise.
	* algol68/compile/error-nested-comment-1.a68: Likewise.
	* algol68/compile/error-no-bounds-allowed-1.a68: Likewise.
	* algol68/compile/error-string-break-1.a68: Likewise.
	* algol68/compile/error-string-break-2.a68: Likewise.
	* algol68/compile/error-string-break-3.a68: Likewise.
	* algol68/compile/error-string-break-4.a68: Likewise.
	* algol68/compile/error-string-break-5.a68: Likewise.
	* algol68/compile/error-string-break-6.a68: Likewise.
	* algol68/compile/error-string-break-7.a68: Likewise.
	* algol68/compile/error-supper-1.a68: Likewise.
	* algol68/compile/error-supper-2.a68: Likewise.
	* algol68/compile/error-supper-3.a68: Likewise.
	* algol68/compile/error-supper-4.a68: Likewise.
	* algol68/compile/error-supper-5.a68: Likewise.
	* algol68/compile/error-supper-6.a68: Likewise.
	* algol68/compile/error-underscore-in-mode-1.a68: Likewise.
	* algol68/compile/error-underscore-in-tag-1.a68: Likewise.
	* algol68/compile/error-upper-1.a68: Likewise.
	* algol68/compile/error-widening-1.a68: Likewise.
	* algol68/compile/error-widening-2.a68: Likewise.
	* algol68/compile/error-widening-3.a68: Likewise.
	* algol68/compile/error-widening-4.a68: Likewise.
	* algol68/compile/error-widening-5.a68: Likewise.
	* algol68/compile/error-widening-6.a68: Likewise.
	* algol68/compile/error-widening-7.a68: Likewise.
	* algol68/compile/error-widening-8.a68: Likewise.
	* algol68/compile/error-widening-9.a68: Likewise.
	* algol68/compile/hidden-operators-1.a68: Likewise.
	* algol68/compile/implicit-widening-1.a68: Likewise.
	* algol68/compile/include-supper.a68: Likewise.
	* algol68/compile/include.a68: Likewise.
	* algol68/compile/labeled-unit-1.a68: Likewise.
	* algol68/compile/nested-comment-1.a68: Likewise.
	* algol68/compile/nested-comment-2.a68: Likewise.
	* algol68/compile/operators-firmly-related.a68: Likewise.
	* algol68/compile/recursive-modes-1.a68: Likewise.
	* algol68/compile/recursive-modes-2.a68: Likewise.
	* algol68/compile/serial-clause-jump-1.a68: Likewise.
	* algol68/compile/snobol.a68: Likewise.
	* algol68/compile/supper-1.a68: Likewise.
	* algol68/compile/supper-10.a68: Likewise.
	* algol68/compile/supper-11.a68: Likewise.
	* algol68/compile/supper-12.a68: Likewise.
	* algol68/compile/supper-13.a68: Likewise.
	* algol68/compile/supper-2.a68: Likewise.
	* algol68/compile/supper-3.a68: Likewise.
	* algol68/compile/supper-4.a68: Likewise.
	* algol68/compile/supper-5.a68: Likewise.
	* algol68/compile/supper-6.a68: Likewise.
	* algol68/compile/supper-7.a68: Likewise.
	* algol68/compile/supper-8.a68: Likewise.
	* algol68/compile/supper-9.a68: Likewise.
	* algol68/compile/uniting-1.a68: Likewise.
	* algol68/compile/upper-1.a68: Likewise.
	* algol68/compile/warning-scope-1.a68: Likewise.
	* algol68/compile/warning-scope-2.a68: Likewise.
	* algol68/compile/warning-scope-3.a68: Likewise.
	* algol68/compile/warning-scope-4.a68: Likewise.
	* algol68/compile/warning-scope-5.a68: Likewise.
	* algol68/compile/warning-scope-6.a68: Likewise.
	* algol68/compile/warning-scope-7.a68: Likewise.
	* algol68/compile/warning-voiding-1.a68: Likewise.
	* algol68/compile/warning-voiding-2.a68: Likewise.
---
 .../compile/a68includes/goodbye-supper.a68    |    4 +
 .../algol68/compile/a68includes/goodbye.a68   |    8 +
 .../compile/a68includes/hello-supper.a68      |    5 +
 .../algol68/compile/a68includes/hello.a68     |    8 +
 .../compile/actual-bounds-expected-1.a68      |    4 +
 .../compile/actual-bounds-expected-2.a68      |    4 +
 .../compile/actual-bounds-expected-3.a68      |    6 +
 gcc/testsuite/algol68/compile/balancing-1.a68 |    7 +
 .../compile/bold-nestable-comment-1.a68       |    7 +
 .../algol68/compile/bold-taggle-1.a68         |    6 +
 .../compile/brief-nestable-comment-1.a68      |    4 +
 .../compile/brief-nestable-comment-2.a68      |    6 +
 .../algol68/compile/char-break-1.a68          |   11 +
 gcc/testsuite/algol68/compile/compile.exp     |   34 +
 .../algol68/compile/conditional-clause-1.a68  |    9 +
 .../algol68/compile/error-bold-taggle-1.a68   |    6 +
 .../algol68/compile/error-coercion-1.a68      |    5 +
 .../algol68/compile/error-coercion-2.a68      |    6 +
 .../algol68/compile/error-coercion-flex-1.a68 |    8 +
 .../compile/error-conformance-clause-1.a68    |    8 +
 .../algol68/compile/error-contraction-1.a68   |    6 +
 .../algol68/compile/error-contraction-2.a68   |    8 +
 .../compile/error-incestuous-union-1.a68      |    8 +
 .../compile/error-label-after-decl-1.a68      |    8 +
 .../compile/error-nestable-comments-1.a68     |    9 +
 .../compile/error-nested-comment-1.a68        |    6 +
 .../compile/error-no-bounds-allowed-1.a68     |   15 +
 .../algol68/compile/error-string-break-1.a68  |    4 +
 .../algol68/compile/error-string-break-2.a68  |    2 +
 .../algol68/compile/error-string-break-3.a68  |    2 +
 .../algol68/compile/error-string-break-4.a68  |    2 +
 .../algol68/compile/error-string-break-5.a68  |    2 +
 .../algol68/compile/error-string-break-6.a68  |    2 +
 .../algol68/compile/error-string-break-7.a68  |    2 +
 .../algol68/compile/error-supper-1.a68        |    3 +
 .../algol68/compile/error-supper-2.a68        |    5 +
 .../algol68/compile/error-supper-3.a68        |    5 +
 .../algol68/compile/error-supper-4.a68        |    5 +
 .../algol68/compile/error-supper-5.a68        |    5 +
 .../algol68/compile/error-supper-6.a68        |    6 +
 .../compile/error-underscore-in-mode-1.a68    |    7 +
 .../compile/error-underscore-in-tag-1.a68     |    7 +
 .../algol68/compile/error-upper-1.a68         |    3 +
 .../algol68/compile/error-widening-1.a68      |    6 +
 .../algol68/compile/error-widening-2.a68      |    6 +
 .../algol68/compile/error-widening-3.a68      |   10 +
 .../algol68/compile/error-widening-4.a68      |   10 +
 .../algol68/compile/error-widening-5.a68      |    6 +
 .../algol68/compile/error-widening-6.a68      |    6 +
 .../algol68/compile/error-widening-7.a68      |    6 +
 .../algol68/compile/error-widening-8.a68      |    6 +
 .../algol68/compile/error-widening-9.a68      |   10 +
 .../algol68/compile/hidden-operators-1.a68    |   11 +
 .../algol68/compile/implicit-widening-1.a68   |   10 +
 .../algol68/compile/include-supper.a68        |   16 +
 gcc/testsuite/algol68/compile/include.a68     |   19 +
 .../algol68/compile/labeled-unit-1.a68        |    7 +
 .../algol68/compile/nested-comment-1.a68      |    4 +
 .../algol68/compile/nested-comment-2.a68      |    6 +
 .../compile/operators-firmly-related.a68      |    7 +
 .../algol68/compile/recursive-modes-1.a68     |   33 +
 .../algol68/compile/recursive-modes-2.a68     |    7 +
 .../algol68/compile/serial-clause-jump-1.a68  |    7 +
 gcc/testsuite/algol68/compile/snobol.a68      | 1100 +++++++++++++++++
 gcc/testsuite/algol68/compile/supper-1.a68    |   11 +
 gcc/testsuite/algol68/compile/supper-10.a68   |    6 +
 gcc/testsuite/algol68/compile/supper-11.a68   |    6 +
 gcc/testsuite/algol68/compile/supper-12.a68   |    6 +
 gcc/testsuite/algol68/compile/supper-13.a68   |    7 +
 gcc/testsuite/algol68/compile/supper-2.a68    |    5 +
 gcc/testsuite/algol68/compile/supper-3.a68    |    5 +
 gcc/testsuite/algol68/compile/supper-4.a68    |    5 +
 gcc/testsuite/algol68/compile/supper-5.a68    |    6 +
 gcc/testsuite/algol68/compile/supper-6.a68    |    5 +
 gcc/testsuite/algol68/compile/supper-7.a68    |    5 +
 gcc/testsuite/algol68/compile/supper-8.a68    |    6 +
 gcc/testsuite/algol68/compile/supper-9.a68    |    6 +
 gcc/testsuite/algol68/compile/uniting-1.a68   |    8 +
 gcc/testsuite/algol68/compile/upper-1.a68     |   11 +
 .../algol68/compile/warning-scope-1.a68       |    9 +
 .../algol68/compile/warning-scope-2.a68       |    8 +
 .../algol68/compile/warning-scope-3.a68       |    3 +
 .../algol68/compile/warning-scope-4.a68       |    3 +
 .../algol68/compile/warning-scope-5.a68       |    8 +
 .../algol68/compile/warning-scope-6.a68       |    6 +
 .../algol68/compile/warning-scope-7.a68       |   12 +
 .../algol68/compile/warning-voiding-1.a68     |    5 +
 .../algol68/compile/warning-voiding-2.a68     |    6 +
 88 files changed, 1729 insertions(+)
 create mode 100644 gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68
 create mode 100644 gcc/testsuite/algol68/compile/a68includes/goodbye.a68
 create mode 100644 gcc/testsuite/algol68/compile/a68includes/hello-supper.a68
 create mode 100644 gcc/testsuite/algol68/compile/a68includes/hello.a68
 create mode 100644 gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/balancing-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/bold-taggle-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/char-break-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/compile.exp
 create mode 100644 gcc/testsuite/algol68/compile/conditional-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-bold-taggle-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-coercion-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-coercion-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-coercion-flex-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-conformance-clause-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-contraction-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-contraction-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-incestuous-union-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-label-after-decl-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-nestable-comments-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-nested-comment-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-string-break-7.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-supper-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-upper-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-7.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-8.a68
 create mode 100644 gcc/testsuite/algol68/compile/error-widening-9.a68
 create mode 100644 gcc/testsuite/algol68/compile/hidden-operators-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/implicit-widening-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/include-supper.a68
 create mode 100644 gcc/testsuite/algol68/compile/include.a68
 create mode 100644 gcc/testsuite/algol68/compile/labeled-unit-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/nested-comment-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/nested-comment-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/operators-firmly-related.a68
 create mode 100644 gcc/testsuite/algol68/compile/recursive-modes-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/recursive-modes-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/serial-clause-jump-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/snobol.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-10.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-11.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-12.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-13.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-7.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-8.a68
 create mode 100644 gcc/testsuite/algol68/compile/supper-9.a68
 create mode 100644 gcc/testsuite/algol68/compile/uniting-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/upper-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-2.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-3.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-4.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-5.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-6.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-scope-7.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-voiding-1.a68
 create mode 100644 gcc/testsuite/algol68/compile/warning-voiding-2.a68

diff --git a/gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68 b/gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68
new file mode 100644
index 00000000000..c287d6a9309
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/a68includes/goodbye-supper.a68
@@ -0,0 +1,4 @@
+proc goodbye = (string name) string:
+begin string msg := "Goodbye " + name;
+      msg
+end;
diff --git a/gcc/testsuite/algol68/compile/a68includes/goodbye.a68 b/gcc/testsuite/algol68/compile/a68includes/goodbye.a68
new file mode 100644
index 00000000000..19c3acc5779
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/a68includes/goodbye.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# PR UPPER PR #
+
+PROC goodbye = (STRING name) STRING:
+BEGIN
+    STRING msg := "Goodbye " + name;
+    msg
+END;
diff --git a/gcc/testsuite/algol68/compile/a68includes/hello-supper.a68 b/gcc/testsuite/algol68/compile/a68includes/hello-supper.a68
new file mode 100644
index 00000000000..2af568bcb01
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/a68includes/hello-supper.a68
@@ -0,0 +1,5 @@
+proc hello = (string name) string:
+begin string msg := "Hello " + name;
+      msg
+end;
+
diff --git a/gcc/testsuite/algol68/compile/a68includes/hello.a68 b/gcc/testsuite/algol68/compile/a68includes/hello.a68
new file mode 100644
index 00000000000..aa72e282d2c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/a68includes/hello.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# PR UPPER PR #
+
+PROC hello = (STRING name) STRING:
+BEGIN
+    STRING msg := "Hello " + name;
+    msg
+END;
diff --git a/gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68 b/gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68
new file mode 100644
index 00000000000..58309db74fd
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/actual-bounds-expected-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []INT a := (1,2,3); # { dg-error "actual bounds expected" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68 b/gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68
new file mode 100644
index 00000000000..e80e8cb45c0
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/actual-bounds-expected-2.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN LOC[]INT a := (1,2,3); # { dg-error "actual bounds expected" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68 b/gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68
new file mode 100644
index 00000000000..26ddd279f05
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/actual-bounds-expected-3.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN LOC[]INT a := (1,2,3), # { dg-error "actual bounds expected" }  #
+               b := (4);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/balancing-1.a68 b/gcc/testsuite/algol68/compile/balancing-1.a68
new file mode 100644
index 00000000000..62d1221f675
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/balancing-1.a68
@@ -0,0 +1,7 @@
+mode Word = union (void,real),
+     Rules = union (void,string);
+
+op LEN = (Word w) int: skip,
+LEN = (Rules r) int: skip;
+
+skip
diff --git a/gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68 b/gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68
new file mode 100644
index 00000000000..0820c3d20c2
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/bold-nestable-comment-1.a68
@@ -0,0 +1,7 @@
+# { dg-options {-fstropping=upper} }  #
+# pr UPPER pr  #
+BEGIN NOTE This is a
+           NOTE nestable ETON comment in bold style.
+      ETON
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/bold-taggle-1.a68 b/gcc/testsuite/algol68/compile/bold-taggle-1.a68
new file mode 100644
index 00000000000..77ce9e7c2fa
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/bold-taggle-1.a68
@@ -0,0 +1,6 @@
+# { dg-options {-std=gnu68 -fstropping=upper} }  #
+
+BEGIN MODE FOO_BAR = INT;
+      FOO_BAR foo_bar = 10;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68 b/gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68
new file mode 100644
index 00000000000..045b9b56d57
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/brief-nestable-comment-1.a68
@@ -0,0 +1,4 @@
+begin { This is a
+        { nestable } comment in brief style.  }
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68 b/gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68
new file mode 100644
index 00000000000..a4e5d3ebb87
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/brief-nestable-comment-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN NOTE This is a
+        { nestable } comment in brief style.
+      ETON
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/char-break-1.a68 b/gcc/testsuite/algol68/compile/char-break-1.a68
new file mode 100644
index 00000000000..8a43364919f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/char-break-1.a68
@@ -0,0 +1,11 @@
+{ Make sure char denotations with string breaks work.  }
+begin prio % = 9;
+      op % = (char a) char: a;
+      assert (ABS %"'n" = 10);
+      assert (ABS %"'f" = 12);
+      assert (ABS %"'t" = 9);
+      assert (ABS %"'r" = 13);
+      assert (%"'(  u0061)" = "a");
+      assert (%"'(U00000061  )" = "a");
+      assert (%"'(u1234)" = invalid_char)
+end
diff --git a/gcc/testsuite/algol68/compile/compile.exp b/gcc/testsuite/algol68/compile/compile.exp
new file mode 100644
index 00000000000..68fa5fa2625
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/compile.exp
@@ -0,0 +1,34 @@
+# Copyright (C) 2024 Free Software Foundation, Inc.
+
+# This program 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 of the License, or
+# (at your option) any later version.
+# 
+# This program 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/>.
+
+# Compile tests, no torture testing.
+#
+# These tests raise errors in the front end; torture testing doesn't apply.
+
+load_lib algol68-dg.exp
+
+# Initialize `dg'.
+dg-init
+
+# Main loop.
+set saved-dg-do-what-default ${dg-do-what-default}
+
+set dg-do-what-default "compile"
+algol68-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] "" ""
+set dg-do-what-default ${saved-dg-do-what-default}
+
+# All done.
+dg-finish
diff --git a/gcc/testsuite/algol68/compile/conditional-clause-1.a68 b/gcc/testsuite/algol68/compile/conditional-clause-1.a68
new file mode 100644
index 00000000000..a727bc21e58
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/conditional-clause-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN INT i := 26;
+      IF INT ii = i * 2; ii > 50 THEN
+         ii
+      ELIF i = 10 THEN
+         100
+      FI
+END
diff --git a/gcc/testsuite/algol68/compile/error-bold-taggle-1.a68 b/gcc/testsuite/algol68/compile/error-bold-taggle-1.a68
new file mode 100644
index 00000000000..d813e55e5ba
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-bold-taggle-1.a68
@@ -0,0 +1,6 @@
+# { dg-options {-std=algol68 -fstropping=upper} }  #
+
+BEGIN MODE FOO_BAR = INT; # { dg-error "unworthy" }  #
+      FOO_BAR foo_bar = 10;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-coercion-1.a68 b/gcc/testsuite/algol68/compile/error-coercion-1.a68
new file mode 100644
index 00000000000..d0e24821f27
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-coercion-1.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN INT a;
+      a := "foo" # { dg-error "cannot be coerced" } #
+END
diff --git a/gcc/testsuite/algol68/compile/error-coercion-2.a68 b/gcc/testsuite/algol68/compile/error-coercion-2.a68
new file mode 100644
index 00000000000..bb8de3064b5
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-coercion-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+# This is Example 4.2.6c in McGETTRICK[78].  #
+BEGIN []STRUCT([]INT a) r = (1,2,3); # { dg-error "cannot be coerced" } #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-coercion-flex-1.a68 b/gcc/testsuite/algol68/compile/error-coercion-flex-1.a68
new file mode 100644
index 00000000000..c556d703b40
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-coercion-flex-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Coercing from REF FLEX[]REAL to REF[]REAL is not allowed, since
+  flexibility shall match #
+BEGIN FLEX[1:0] REAL rowvar := SKIP;
+      REF [] REAL xlm = rowvar; # { dg-error "FLEX.*cannot be coerced" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-conformance-clause-1.a68 b/gcc/testsuite/algol68/compile/error-conformance-clause-1.a68
new file mode 100644
index 00000000000..e6cb738a2c9
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-conformance-clause-1.a68
@@ -0,0 +1,8 @@
+{ This is an invalid program.  }
+begin case
+           if true then "foo" else 10 fi { dg-error "not a united mode" }
+      in (string): skip,
+         (int): skip
+      esac
+end
+   
diff --git a/gcc/testsuite/algol68/compile/error-contraction-1.a68 b/gcc/testsuite/algol68/compile/error-contraction-1.a68
new file mode 100644
index 00000000000..f2bce73ff17
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-contraction-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Contracting mixed collateral variable and constant declarations is
+  not allowed.
+#
+(INT foo = 100, bar := 200) # { dg-error "mixed" } #
diff --git a/gcc/testsuite/algol68/compile/error-contraction-2.a68 b/gcc/testsuite/algol68/compile/error-contraction-2.a68
new file mode 100644
index 00000000000..2115a4cbfab
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-contraction-2.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Contracting mixed collateral variable and constant declarations is
+  not allowed.  #
+BEGIN PROC x = VOID: SKIP,
+      y := VOID: SKIP; # { dg-error "mixed" } #
+      x
+END
diff --git a/gcc/testsuite/algol68/compile/error-incestuous-union-1.a68 b/gcc/testsuite/algol68/compile/error-incestuous-union-1.a68
new file mode 100644
index 00000000000..519cb8a9af1
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-incestuous-union-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Union modes shall not contain modes which are firmly related, i.e.
+  it shall not be possible to coerce from one mode to another in a
+  firm context. #
+BEGIN UNION(INT, REF INT) incestuous; # { dg-error "has firmly related components" } #
+      incestuous
+END
diff --git a/gcc/testsuite/algol68/compile/error-label-after-decl-1.a68 b/gcc/testsuite/algol68/compile/error-label-after-decl-1.a68
new file mode 100644
index 00000000000..670f8908af1
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-label-after-decl-1.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN GOTO end;
+      ASSERT(FALSE);
+end:  0;
+      INT i = 10; # { dg-error "declaration cannot follow" }  #
+      i
+END
diff --git a/gcc/testsuite/algol68/compile/error-nestable-comments-1.a68 b/gcc/testsuite/algol68/compile/error-nestable-comments-1.a68
new file mode 100644
index 00000000000..df00a1a9970
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-nestable-comments-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" } #
+# pr UPPER pr  #
+BEGIN NOTE This is a
+        NOTE nestable ETON comment in brief style.
+      ETON
+      { Another { comment }.  }
+      NOTE invalid { nesting ETON of comments } # { dg-error "" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-nested-comment-1.a68 b/gcc/testsuite/algol68/compile/error-nested-comment-1.a68
new file mode 100644
index 00000000000..3c78f34a51a
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-nested-comment-1.a68
@@ -0,0 +1,6 @@
+{ The string in nested comment is in one logical line.  }
+begin
+      { puts ("{'n { dg-error {} }
+"); { this prints foo }}
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68 b/gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68
new file mode 100644
index 00000000000..75d66bc1715
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-no-bounds-allowed-1.a68
@@ -0,0 +1,15 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN [1:10]INT i,
+      [1:10]STRUCT(REF[]INT i, BOOL j) k,
+      [1:10]STRUCT([1:10]INT i, BOOL j) l,
+      [1:10]REF[]INT p;
+      # formal, so no bounds allowed:  #
+      [1:10]PROC[1:10]INT q, # { dg-error "formal bounds expected" }  #
+      STRUCT(REF[1:10]INT i, BOOLj) m, # { dg-error "virtual bounds expected" }  #
+      [1:10]REF[1:10]INT mn, # { dg-error "virtual bounds expected" }  #
+      PROC([1:10]INT)VOID pp, # { dg-error "formal bounds expected" }  #
+      UNION([1:10] INT, BOOL) nm, # { dg-error "formal bounds expected" }  #
+      [1:10]INT u = (1); # { dg-error "formal bounds expected" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-string-break-1.a68 b/gcc/testsuite/algol68/compile/error-string-break-1.a68
new file mode 100644
index 00000000000..fd8e765ab48
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-1.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN puts ("hello '_ world") # { dg-error "invalid string break sequence" }  #
+END
diff --git a/gcc/testsuite/algol68/compile/error-string-break-2.a68 b/gcc/testsuite/algol68/compile/error-string-break-2.a68
new file mode 100644
index 00000000000..465f8f80404
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-2.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(U0000) world") # { dg-error "eight" }  #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-3.a68 b/gcc/testsuite/algol68/compile/error-string-break-3.a68
new file mode 100644
index 00000000000..e4cf8f6f1a3
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-3.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(u00) world") # { dg-error "four" }  #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-4.a68 b/gcc/testsuite/algol68/compile/error-string-break-4.a68
new file mode 100644
index 00000000000..76adff9b2bc
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-4.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(u) world") # { dg-error "four" }  #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-5.a68 b/gcc/testsuite/algol68/compile/error-string-break-5.a68
new file mode 100644
index 00000000000..c42589fde7c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-5.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(u0010u0020) world") # { dg-error "" }  #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-6.a68 b/gcc/testsuite/algol68/compile/error-string-break-6.a68
new file mode 100644
index 00000000000..fed7d84b221
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-6.a68
@@ -0,0 +1,2 @@
+begin puts ("hello '(u0010'/) world") # { dg-error "" }  #
+end
diff --git a/gcc/testsuite/algol68/compile/error-string-break-7.a68 b/gcc/testsuite/algol68/compile/error-string-break-7.a68
new file mode 100644
index 00000000000..58545e01ce1
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-string-break-7.a68
@@ -0,0 +1,2 @@
+begin puts ("'") # { dg-error "" }  #
+end
diff --git a/gcc/testsuite/algol68/compile/error-supper-1.a68 b/gcc/testsuite/algol68/compile/error-supper-1.a68
new file mode 100644
index 00000000000..f2646c41b7b
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-1.a68
@@ -0,0 +1,3 @@
+# { dg-options {-fstropping=upper} }  #
+
+begin ~ end # { dg-error "" }  #
diff --git a/gcc/testsuite/algol68/compile/error-supper-2.a68 b/gcc/testsuite/algol68/compile/error-supper-2.a68
new file mode 100644
index 00000000000..f8c6c284b20
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-2.a68
@@ -0,0 +1,5 @@
+# { dg-options {-fstropping=supper} }  #
+
+begin int foo__bar = 10; # { dg-error "unworthy" }  #
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-supper-3.a68 b/gcc/testsuite/algol68/compile/error-supper-3.a68
new file mode 100644
index 00000000000..a35730ce1f7
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-3.a68
@@ -0,0 +1,5 @@
+# { dg-options {-fstropping=supper} }  #
+
+begin int _bar = 10; # { dg-error "unworthy" }  #
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-supper-4.a68 b/gcc/testsuite/algol68/compile/error-supper-4.a68
new file mode 100644
index 00000000000..726f80638d6
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-4.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin int foo bar = 10; { dg-error "" }
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-supper-5.a68 b/gcc/testsuite/algol68/compile/error-supper-5.a68
new file mode 100644
index 00000000000..0cf51c519de
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-5.a68
@@ -0,0 +1,5 @@
+# { dg-options {-fstropping=supper} }  #
+
+begin int foo__ = 10; # { dg-error "unworthy" }  #
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-supper-6.a68 b/gcc/testsuite/algol68/compile/error-supper-6.a68
new file mode 100644
index 00000000000..c013b4894b3
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-supper-6.a68
@@ -0,0 +1,6 @@
+# { dg-options {-fstropping=supper} }  #
+
+begin mode foo_Invalid = int; # { dg-error "Invalid" }  #
+      foo_Invalid some_int = 10; # { dg-error "Invalid" }  #
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68 b/gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68
new file mode 100644
index 00000000000..2aa294d1f02
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-underscore-in-mode-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Underscores are unworthy characters if they are not trailing
+  either a taggle or, in UPPER stropping, a bold word.  #
+BEGIN INT invalid_tag__; # { dg-error "unworthy character" } #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68 b/gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68
new file mode 100644
index 00000000000..a5dcb86b6e1
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-underscore-in-tag-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Underscores are unworthy characters if they are not trailing a
+  taggle or, in UPPER stropping, a bold word..  #
+BEGIN MODE INVALID_BOLD_WORD__; # { dg-error "unworthy character" } #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/error-upper-1.a68 b/gcc/testsuite/algol68/compile/error-upper-1.a68
new file mode 100644
index 00000000000..053846972ac
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-upper-1.a68
@@ -0,0 +1,3 @@
+# { dg-options {-fstropping=supper} }  #
+
+BEGIN ~ END # { dg-error "" }  #
diff --git a/gcc/testsuite/algol68/compile/error-widening-1.a68 b/gcc/testsuite/algol68/compile/error-widening-1.a68
new file mode 100644
index 00000000000..38ea59afb28
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-1.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN INT a := 10;
+      LONG REAL l := a; # { dg-error "coerced" } #
+      l
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-2.a68 b/gcc/testsuite/algol68/compile/error-widening-2.a68
new file mode 100644
index 00000000000..3165d1b7113
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN INT a := 10;
+      LONG INT l := a; # { dg-error "coerced" } #
+      l
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-3.a68 b/gcc/testsuite/algol68/compile/error-widening-3.a68
new file mode 100644
index 00000000000..c4ffb305a62
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-3.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN INT d := 0;
+      INT y := 10;
+      LONG REAL x;
+      2
+        + (d > 0 | x | # { dg-error "" }  #
+           y
+          )
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-4.a68 b/gcc/testsuite/algol68/compile/error-widening-4.a68
new file mode 100644
index 00000000000..fa5b2072e17
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-4.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN
+   INT d := 0;
+   LONG REAL x;
+   2
+     + (d > 0 | x | # { dg-error "" }  #
+          10
+       )
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-5.a68 b/gcc/testsuite/algol68/compile/error-widening-5.a68
new file mode 100644
index 00000000000..a6198669c45
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-5.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN
+   LONG INT d := 0; # { dg-error "coerced" }  #
+   d
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-6.a68 b/gcc/testsuite/algol68/compile/error-widening-6.a68
new file mode 100644
index 00000000000..09512e21678
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-6.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN
+   LONG LONG INT d := LONG 0; # { dg-error "coerced" }  #
+   d
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-7.a68 b/gcc/testsuite/algol68/compile/error-widening-7.a68
new file mode 100644
index 00000000000..09352081583
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-7.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN
+   LONG REAL d := 3.14; # { dg-error "coerced" }  #
+   d
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-8.a68 b/gcc/testsuite/algol68/compile/error-widening-8.a68
new file mode 100644
index 00000000000..098f6c3b615
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-8.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN
+   LONG LONG REAL d := LONG 3.14; # { dg-error "coerced" }  #
+   d
+END
diff --git a/gcc/testsuite/algol68/compile/error-widening-9.a68 b/gcc/testsuite/algol68/compile/error-widening-9.a68
new file mode 100644
index 00000000000..4d092386b61
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/error-widening-9.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN
+   INT d := 0;
+   LONG LONG REAL x;
+   2
+     + (d > 0 | x | # { dg-error "" }  #
+          10
+       )
+END
diff --git a/gcc/testsuite/algol68/compile/hidden-operators-1.a68 b/gcc/testsuite/algol68/compile/hidden-operators-1.a68
new file mode 100644
index 00000000000..d66242d67a6
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/hidden-operators-1.a68
@@ -0,0 +1,11 @@
+{ dg-options {-Whidden-declarations} }
+
+begin mode Trilean = union (void,bool);
+
+      Trilean unknown = empty;
+      op NOT = (Trilean a) Trilean: { dg-warning "hides" }
+         skip;
+      op AND = (Trilean a,b) Trilean: { dg-warning "hides" }
+         skip;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/implicit-widening-1.a68 b/gcc/testsuite/algol68/compile/implicit-widening-1.a68
new file mode 100644
index 00000000000..2fa010c12a7
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/implicit-widening-1.a68
@@ -0,0 +1,10 @@
+# { dg-options "-Wextensions -fstropping=upper" }  #
+
+# This program shall compile without warning, because
+  widening from INT to REAL is legal in the strict language,
+  since they have the same size.  #
+
+BEGIN BOOL cond;
+      REAL x, y;
+      y + (cond | x | 10)
+END
diff --git a/gcc/testsuite/algol68/compile/include-supper.a68 b/gcc/testsuite/algol68/compile/include-supper.a68
new file mode 100644
index 00000000000..af0521be101
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/include-supper.a68
@@ -0,0 +1,16 @@
+{ dg-options "-I$srcdir/algol68/compile/a68includes" }
+{ dg-additional-files "$srcdir/algol68/compile/a68includes/hello-supper.a68 $srcdir/algol68/compile/a68includes/goodbye-supper.a68" }
+
+begin string name := "Algol68 with supper!";
+      { Both files are in `./a68includes'.
+        The first one will be included because we uwed `-I.
+        The second one will be included because of the relative path. }
+      pr include "hello-supper.a68" pr
+      pr include "a68includes/goodbye-supper.a68" pr
+
+      string bye := goodbye(name);
+      string hi := hello(name);
+
+      puts(hi + "\n");
+      puts(bye  + "\n")
+end
diff --git a/gcc/testsuite/algol68/compile/include.a68 b/gcc/testsuite/algol68/compile/include.a68
new file mode 100644
index 00000000000..6f4855b33da
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/include.a68
@@ -0,0 +1,19 @@
+# { dg-options "-I$srcdir/algol68/compile/a68includes -fstropping=upper" } #
+# { dg-additional-files "$srcdir/algol68/compile/a68includes/hello.a68 $srcdir/algol68/compile/a68includes/goodbye.a68" } #
+
+# PR UPPER PR  #
+
+BEGIN STRING name := "Algol68!";
+      # Both files are in `./a68includes'.
+        The first one will be included because we used `-I'.
+        The second one will be included because of the relative path.
+      #
+      PR include "hello.a68" PR
+      PR include "a68includes/goodbye.a68" PR
+
+      STRING bye := goodbye(name);
+      STRING hi := hello(name);
+
+      puts(hi + "\n");
+      puts(bye  + "\n")
+END
diff --git a/gcc/testsuite/algol68/compile/labeled-unit-1.a68 b/gcc/testsuite/algol68/compile/labeled-unit-1.a68
new file mode 100644
index 00000000000..d3dbd8c40d7
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/labeled-unit-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+
+# This tests that the mode of the value yielded by a labeled unit is
+  the mode of the unit.  #
+BEGIN 10;
+jorl: 20
+END
diff --git a/gcc/testsuite/algol68/compile/nested-comment-1.a68 b/gcc/testsuite/algol68/compile/nested-comment-1.a68
new file mode 100644
index 00000000000..f5752435a0e
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/nested-comment-1.a68
@@ -0,0 +1,4 @@
+{ Comment delimiters within strings get ignored.  }
+begin { puts { ("{""'n"); } }
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/nested-comment-2.a68 b/gcc/testsuite/algol68/compile/nested-comment-2.a68
new file mode 100644
index 00000000000..9fc912f2687
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/nested-comment-2.a68
@@ -0,0 +1,6 @@
+{ The string in nested comment is in one logical line.  }
+begin
+      { puts ("{'n\
+"); { this prints foo }}
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/operators-firmly-related.a68 b/gcc/testsuite/algol68/compile/operators-firmly-related.a68
new file mode 100644
index 00000000000..a7efe750219
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/operators-firmly-related.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN PRIO MIN = 6;
+      OP MIN = (REF REAL a, b) REF REAL: (a < b | a | b), # { dg-error "firmly related" }  #
+         MIN = (REAL a, b) REAL: (a < b | a | b); # { dg-error "firmly related" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/recursive-modes-1.a68 b/gcc/testsuite/algol68/compile/recursive-modes-1.a68
new file mode 100644
index 00000000000..4a77a5646be
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/recursive-modes-1.a68
@@ -0,0 +1,33 @@
+# { dg-options "-fstropping=upper" }  #
+
+# This program triggered a bug related to incomplete modes.  #
+BEGIN MODE REC_MSET = STRUCT (REF REC_MSET_ELM head, tail,
+                              INT num elems,
+                              PROC(REC_MSET_DATA)BOOL gate),
+           REC_MSET_ELM = STRUCT (REC_MSET_DATA data, BOOL mark, REF REC_MSET_ELM next),
+           REC_MSET_DATA = UNION (REC_RSET,REC_RECORD,REC_FIELD,REC_CMNT),
+           REC_RSET = STRUCT (REC_MSET mset,
+                              INT min size, max size,
+                              REF REC_RECORD descriptor),
+           REC_RECORD = STRUCT (REC_LOC loc, REC_MSET mset, INT foo),
+           REC_CMNT = STRUCT (REC_LOC loc, STRING content),
+           REC_FIELD = STRUCT (REC_LOC loc, STRING name, value),
+           REC_LOC = STRUCT (STRING source, INT line, char);
+
+      PROC rec loc unknown = REC_LOC:
+         ("unknown", 0, 0);
+      PROC rec record gate = (REC_MSET_DATA d) BOOL:
+         (d | (REC_FIELD): TRUE, (REC_CMNT): TRUE | FALSE);
+      REF REC_MSET_ELM rec no mset elm = NIL;
+      
+      PROC rec mset new = (PROC(REC_MSET_DATA)BOOL gate) REC_MSET:
+         (HEAP REC_MSET := (rec no mset elm, rec no mset elm,
+                            0, gate));
+
+      REF REC_RECORD rec no record = NIL;
+
+      PROC rec record new = REF REC_RECORD:
+         HEAP REC_RECORD := (rec loc unknown, rec mset new (rec record gate), 0);
+      
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/recursive-modes-2.a68 b/gcc/testsuite/algol68/compile/recursive-modes-2.a68
new file mode 100644
index 00000000000..f79b214d075
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/recursive-modes-2.a68
@@ -0,0 +1,7 @@
+begin mode Word = union (int, struct (ref Word w)),
+           Value = union (void,Word),
+           Stack = struct (ref Stack prev, Value val);
+
+      struct (Word a) qs;  { type_2 has no size! }
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/serial-clause-jump-1.a68 b/gcc/testsuite/algol68/compile/serial-clause-jump-1.a68
new file mode 100644
index 00000000000..f4e3773ba53
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/serial-clause-jump-1.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+
+# This is an infinite loop, but it should compile just fine an yield
+  an integer after infinite time.  #
+
+BEGIN foo: foo
+END
diff --git a/gcc/testsuite/algol68/compile/snobol.a68 b/gcc/testsuite/algol68/compile/snobol.a68
new file mode 100644
index 00000000000..9b6c4fc824f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/snobol.a68
@@ -0,0 +1,1100 @@
+# { dg-options "-fstropping=upper" }  #
+
+# This is Frank Pagan's SNOBOL4 Interpreter in ALGOL 68 (1976),
+  fetched from Dick Grune's page https://dickgrune.com/CS/Algol68/
+
+  The interpreter described in "Algol 68 as an Implementation Language\
+  for Portable Interpreters", ACM SIGPLAN Notices - Proceedings of the
+  Strathclyde ALGOL 68 conference, Volume 12 Issue 6, June 1977,
+  pp. 54 - 62, and "A Highly-Structured Interpreter for a SNOBOL4
+  Subset", Software: Practice and Experience, Vol. 9, 4,
+  pp. 281-312, April 1979.
+
+  Modifications by Jose E. Marchesi:
+  - Use the simple POSIX-like transput provided by GCC.
+  - Read programs from lines rather than from cards.
+  - Add command-line option -l (listing).
+#
+
+BEGIN PROC itoa = (INT i) STRING:
+      BEGIN IF i = 0
+            THEN "0"
+            ELSE INT n := ABS i;
+                 STRING res;
+                 WHILE n /= 0
+                 DO INT rem = n %* 10;
+                    res := REPR (rem > 9 | (rem - 10) + ABS "a" | rem + ABS "0") + res;
+                    n %:= 10
+                 OD;
+                 (i < 0 | "-" + res | res)
+            FI
+      END;
+
+      CHAR sharp = REPR 35; # Sharp character,
+                              to avoid confusing Emacs.  #
+
+      # Input file.  #
+      INT filein;
+
+      # IMPLEMENTATION RESTRICTIONS #
+      INT spoolsize = 400,
+          stlim = 50,
+          arglim = 5,
+          rslim = 80,
+          pslim = 20,
+          ftlim = 10;
+
+      # ABSTRACT MACHINE #
+      MODE ITEM = UNION (INT, REF STRINGITEM, PATTERN),
+           STRINGITEM = STRUCT (STRING val, REF ITEM ref),
+           PATTERN = REF[]COMPONENT,
+           COMPONENT = STRUCT (INT routine, subsequent, alternate, extra,
+                               REF ITEM arg),
+           PSENTRY = STRUCT (INT cursor, alternate),
+           RSENTRY = REF ITEM,
+           FTENTRY = STRUCT (REF ITEM fnname, entry name,
+                             REF[]REF ITEM params, locals);
+
+      [1:spoolsize] REF ITEM spool;
+      [1:pslim] PSENTRY pattern stack;
+      [1:rslim] RSENTRY run stack;
+      [1:ftlim] FTENTRY function table;
+
+      BOOL failed := FALSE;
+      INT nin, psp, rsp := 0, ftp := 0;
+      INT mstr = 1, mlen = 2, mbrk = 3, mspn = 4, many = 5, mnul = 6,
+          miv1 = 7, miv2 = 8, m1 = 9, mat = 10, mpos = 11, mtab = 12,
+          mrpos = 13, mrtab = 14, mnty = 15;
+
+      # INTERNAL FORM OF PROGRAMS #
+
+      MODE STMT = STRUCT (REF IDR label,
+                          UNION (REF ASMT, REF MATCH,
+                                 REF REPL, REF EXPR) stmt core,
+                          REF GOTOFIELD goto),
+           IDR = STRUCT (REF ITEM idr addr),
+           NUM = STRUCT (REF ITEM num addr),
+           LSTR = STRUCT (REF ITEM lstr addr),
+           ASMT = STRUCT (REF EXPR subject, object),
+           MATCH = STRUCT (REF EXPR subject, pattern),
+           REPL = STRUCT (REF EXPR subject, pattern, object),
+           EXPR = UNION (REF UNARYEXPR, REF BINARYEXPR, IDR, NUM,
+                         LSTR, REF CALL),
+           GOTOFIELD = STRUCT (REF DEST upart, spart, fpart),
+           DEST = UNION (REF EXPR, CHAR),
+           UNARYEXPR = STRUCT (REF EXPR operand, CHAR operator),
+           BINARYEXPR = STRUCT (REF EXPR operand1, operand2,
+                                CHAR operator),
+           CALL = STRUCT (IDR fnname, REF[]REF EXPR args);
+
+      REF[]STMT t;
+      REF ITEM prog entry := NIL;
+
+      PROC error = (STRING mess) VOID:
+         (puts ("error: " + mess + "'n"); stop);
+
+      # TRANSLATION PHASE #
+
+      BEGIN # DECLARATIONS FOR SCANNER #
+            STRING card, INT cp,       # SOURCE LINE AND POINTER #
+            CHAR ch,                   # SOURCE CHARACTER #
+            [1:80]CHAR str, INT sp,    # STRING BUFFER AND POINTER #
+            CHAR tok,                  # TOKEN CODE #
+            REF ITEM psn,              # POSITION OF A CREATED VALUE #
+            INT nv,                    # NUMERIC VALUE OF CONSTANT #
+            INT stn,                   # SOURCE STATEMENT NUMBER #
+            BOOL listing,              # FLAG FOR SOURCE LISTING #
+            CHAR c;                    # TEMPORARY #
+
+            # TOKEN MNEMONICS #
+            CHAR doll    = "$",    bdoll   = "D",
+                 plus    = "+",    bplus   = "P",
+                 minus   = "-",    bminus  = "M",
+                 at      = "@",    bbar    = "!",
+                 bstar   = "*",    bslash  = "/",
+                 lpar    = "(",    rpar    = ")",
+                 comma   = ",",    colon   = ":",
+                 equal   = "=",    blank   = " ",
+                 eos     = ";",    name    = "A",
+                 lstring = "L",    number  = "U",
+                 endt    = "E",    ret     = "R",
+                 fret    = "F",    stok    = "Y",
+                 ftok    = "Z";
+
+            PROC get card = VOID:
+            BEGIN cp := 0;
+                  WHILE card := fgets (filein, 80);
+                        IF UPB card = 0 THEN exit FI;
+                        c := card[1];
+                        IF c /= "." AND c /= "+" AND c /= "-" AND c /= "*"
+                        THEN stn := stn + 1 FI;
+                        IF listing THEN puts (itoa (stn) + "    " + card + "'n") FI;
+                        IF c = "-"
+                        THEN IF card[2:5] = "LIST"
+                             THEN listing := TRUE
+                             ELIF card[2:7] = "UNLIST"
+                             THEN listing := FALSE
+                             FI
+                        FI;
+                        c = "-" OR c = "*"
+                  DO SKIP OD;
+            exit: SKIP
+            END;
+
+            PROC next ch = VOID:
+               IF cp = UPB card
+               THEN get card;
+                    IF c = "." OR c = "+"
+                    THEN ch := " "; cp := 1
+                    ELSE ch := sharp   # END OF LINE AND STATEMENT #
+                    FI
+               ELSE ch := card[cp +:= 1]
+               FI;
+
+            PROC lookup = (STRING sv) REF ITEM : (
+               INT i := 0, BOOL nf := TRUE;
+               WHILE IF (i +:= 1) <= nin
+                     THEN nf := sv /= val OF (spool[i] | (REF STRINGITEM s) : s)
+                     ELSE FALSE
+                     FI
+               DO SKIP OD;
+               IF nf
+               THEN IF nin = spoolsize THEN error ("too many strings") FI;
+                    spool[nin +:= 1] := HEAP ITEM := HEAP STRINGITEM :=
+                       (sv, NIL)
+               FI;
+               spool[i]);
+
+            PROC scan = VOID:
+               IF ch = " " # BLANKS AND BINARY OPERATORS #
+               THEN WHILE next ch; ch = " " DO SKIP OD;
+                    # IGNORE TRAILING BLANKS IN A STATEMENT #
+                    IF ch = ";" THEN next ch; stn := stn + 1; tok := eos
+                    ELIF ch = sharp THEN next ch; tok := eos
+                    ELIF ch = "!" OR ch = "$" OR ch = "+" OR ch = "-"
+                         OR ch = "*" OR ch = "/"
+                    THEN IF card[cp+1] = " "
+                         THEN c := ch;
+                              WHILE next ch; ch = " " DO SKIP OD ;
+                              tok := (c = "!" | bbar
+                                      |: c = "$" | bdoll
+                                      |: c = "-" | bminus
+                                      |: c = "+" | bplus
+                                      |: c = "*" | bstar
+                                      | bslash)
+                         ELSE tok := blank
+                         FI
+                    ELSE tok := blank
+                    FI
+               ELIF ch = "''" OR ch = """" # LITERAL STRINGS #
+               THEN c := ch; sp := 0;
+                    WHILE next ch;
+                          IF ch = sharp THEN error ("UNTERMINATED LITERAL") FI;
+                          (str[sp +:= 1] := ch) /= c
+                    DO SKIP OD ;
+                    next ch;
+                    tok := lstring;
+                    IF sp = 1
+                    THEN psn := NIL
+                    ELSE STRING s = str[1:sp-1] ;
+                         psn := lookup (s)
+                    FI
+               ELIF ch >= "0" AND ch <= "9" # NUMBERS #
+               THEN nv := 0 ;
+                    WHILE nv := nv * 10 + ABS ch - ABS "0";
+                          next ch;
+                          ch >= "0" AND ch <= "9"
+                    DO SKIP OD ;
+                    tok := number;
+                    psn := HEAP ITEM := nv
+               ELIF ch >= "A" AND ch <= "Z" # NAMES #
+               THEN sp := 0;
+                    WHILE str[sp +:= 1] := ch;
+                          next ch;
+                          ch = "." OR ch >= "A" AND ch <= "Z"
+                          OR ch >= "0" AND ch <= "9"
+                    DO SKIP OD ;
+                    STRING s = str[1:sp];
+                    tok := (s = "S" | stok
+                            |: s = "F" | ftok
+                            |: s = "END" | endt
+                            |: s = "RETURN" | ret
+                            |: s = "FRETURN" | fret
+                            | psn := lookup (s);  name)
+               ELIF ch = ";"
+               THEN next ch;  stn := stn + 1; tok := eos
+               ELIF ch = sharp
+               THEN next ch;  tok := eos
+               ELSE #  ( ) , : = @ $ + -  #
+                  tok := ch; next ch
+               FI;
+
+            PROC init = VOID:
+            BEGIN stn := 0;
+                  spool[nin := 1] := HEAP ITEM := HEAP STRINGITEM :=
+                     ("ARB", HEAP ITEM := HEAP[1:3]COMPONENT :=
+                                ((mnul, 2, 0, SKIP, NIL),
+                                 (mnul, 0, 3, SKIP, NIL),
+                                 (m1, 2, 0, SKIP, NIL)));
+                  get card;
+                  next ch;
+                  scan
+            END;
+
+            PROC verify = (CHAR token) VOID:
+               IF tok = token THEN scan
+               ELSE STRING s := "TOKEN "" "" DOES NOT OCCUR WHERE EXPECTED";
+                    s[8] := token;
+                    error (s)
+               FI;
+
+            PROC translate = VOID:
+            BEGIN HEAP[1:stlim]STMT ss, INT ssc := 0;
+                  WHILE IF ssc = stlim THEN error ("TOO MANY STATEMENTS") FI;
+                        tok /= endt
+                  DO ss[ssc +:= 1] := trans stmt OD;
+                  scan;
+                  IF tok = blank
+                  THEN scan;
+                       IF tok = name THEN prog entry := psn FI
+                  FI;
+                  t := ss[1:ssc]
+            END;
+
+            PROC trans stmt = STMT:
+            BEGIN
+               REF IDR lab := NIL;
+               REF EXPR subj, pat, obj := NIL;
+               REF GOTOFIELD go := NIL;
+               BOOL asgn;
+
+               PROC move to obj = STMT:
+               BEGIN
+                  IF tok = blank
+                  THEN scan;
+                       IF tok = colon
+                       THEN go := trans gofield
+                       ELSE obj := trans expr;
+                            IF tok = colon
+                            THEN go := trans gofield
+                            ELSE verify (eos)
+                            FI
+                       FI
+                  ELSE verify (eos)
+                  FI ;
+                  IF asgn
+                  THEN STMT (lab, HEAP ASMT := (subj, obj), go)
+                  ELSE STMT (lab, HEAP REPL := (subj, pat, obj), go)
+                  FI
+               END;
+
+               PROC move to subj = STMT:
+               BEGIN scan;
+                     IF tok = colon
+                     THEN STMT (lab, REF EXPR (NIL), trans gofield)
+                     ELSE subj := trans elem;
+                          IF tok = blank
+                          THEN scan;
+                               IF tok = colon
+                               THEN STMT (lab, REF EXPR (subj), trans gofield)
+                               ELIF tok = equal
+                               THEN asgn := TRUE; scan;  move to obj
+                               ELSE pat := trans expr;
+                                    IF tok = colon
+                                    THEN STMT (lab, HEAP MATCH := (subj, pat), trans gofield)
+                                    ELIF tok = equal
+                                    THEN asgn := FALSE; scan; move to obj
+                                    ELSE verify (eos);
+                                         STMT (lab, HEAP MATCH := (subj, pat), NIL)
+                                    FI
+                               FI
+                          ELSE verify (eos);
+                               STMT (lab, REF EXPR (subj), NIL)
+                          FI
+                     FI
+               END;
+
+               # Body of trans stmt. #
+               IF tok = name
+               THEN lab := HEAP IDR; idr addr OF lab := psn; scan;
+                    IF tok = blank
+                    THEN move to subj
+                    ELSE verify (eos);
+                         STMT (lab, REF EXPR (NIL), NIL)
+                    FI
+               ELIF tok = blank
+               THEN move to subj
+               ELSE verify (eos);
+                    STMT (lab, REF EXPR (NIL), NIL)
+               FI
+            END;
+
+            PROC trans gofield = REF GOTOFIELD:
+            BEGIN PROC where = REF DEST:
+                  BEGIN HEAP DEST d;
+                        verify (lpar);
+                        IF tok = blank THEN scan FI;
+                        d := (tok = endt | scan; "E"
+                              |: tok = ret | scan; "R"
+                              |: tok = fret | scan; "F"
+                              | trans expr);
+                        verify (rpar);
+                        d
+                  END;
+
+                  REF DEST uncond := NIL, succ := NIL, fail := NIL;
+                  scan; IF tok = blank THEN scan FI;
+                  IF tok = stok
+                  THEN scan; succ := where;
+                       IF tok = blank THEN scan FI;
+                       IF tok = ftok THEN scan; fail := where FI;
+                       verify (eos)
+                  ELIF tok = ftok
+                  THEN scan; fail := where;
+                       IF tok = blank THEN scan FI;
+                       IF tok = stok THEN scan; succ := where FI;
+                       verify (eos)
+                  ELSE uncond := where; verify (eos)
+                  FI;
+                  HEAP GOTOFIELD := (uncond, succ, fail)
+            END;
+
+            PROC trans expr = REF EXPR:
+            BEGIN REF EXPR e := trans expr1;
+                  WHILE tok = bbar
+                  DO scan;
+                     e := HEAP EXPR := HEAP BINARYEXPR := (e, trans expr1, "!")
+                  OD;
+                  e
+            END;
+
+            PROC trans expr1 = REF EXPR:
+            BEGIN REF EXPR e := trans expr2;
+                  WHILE tok = blank
+                  DO scan;
+                     IF tok /= colon AND tok /= rpar AND tok /= comma AND tok /= equal
+                     THEN e := HEAP EXPR := HEAP BINARYEXPR := (e, trans expr2, "C")
+                     FI
+                  OD;
+                  e
+            END;
+
+            PROC trans expr2 = REF EXPR:
+            BEGIN REF EXPR e := trans term;
+                  CHAR opr;
+                  WHILE tok = bplus OR tok = bminus
+                  DO opr := (tok = bplus | "+" | "-");
+                     scan;
+                     e := HEAP EXPR := HEAP BINARYEXPR := (e, trans term, opr)
+                  OD;
+                  e
+            END;
+
+            PROC trans term = REF EXPR:
+            BEGIN REF EXPR e := trans term1;
+                  WHILE tok = bslash
+                  DO scan;
+                     e := HEAP EXPR := HEAP BINARYEXPR := (e, trans term1, "/")
+                  OD;
+                  e
+            END;
+
+            PROC trans term1 = REF EXPR:
+            BEGIN REF EXPR e := trans term2;
+                  WHILE tok = bstar
+                  DO scan;
+                     e := HEAP EXPR := HEAP BINARYEXPR := (e, trans term2, "*")
+                  OD;
+                  e
+            END;
+
+            PROC trans term2 = REF EXPR:
+            BEGIN REF EXPR e := trans elem;
+                  WHILE tok = bdoll
+                  DO scan;
+                     e := HEAP EXPR := HEAP BINARYEXPR := (e, trans elem, "$")
+                  OD;
+                  e
+            END;
+
+            PROC trans elem = REF EXPR:
+               IF tok = doll OR tok = plus OR tok = minus OR tok = at
+               THEN CHAR opr = tok;
+                    scan;
+                    HEAP EXPR := HEAP UNARYEXPR := (trans element, opr)
+               ELSE trans element
+               FI;
+
+            PROC trans element = REF EXPR:
+               IF tok = name
+               THEN IDR n;
+                    idr addr OF n := psn;
+                    scan;
+                    IF tok /= lpar
+                    THEN HEAP EXPR := n
+                    ELSE HEAP[1:arglim]REF EXPR a, INT ac := 0;
+                         WHILE scan;
+                               IF tok = blank THEN scan FI;
+                               IF ac = arglim
+                               THEN error ("TOO MANY ARGUMENTS IN FUNCTION CALL")
+                               FI;
+                               IF NOT (ac = 0 AND tok = rpar)
+                               THEN a[ac +:= 1] := (tok = comma OR tok = rpar | NIL | trans expr)
+                               FI;
+                               IF tok /= comma AND tok /= rpar
+                               THEN error ("ERROR IN ARGUMENT LIST")
+                               FI;
+                               tok = comma
+                         DO SKIP OD;
+                         scan;
+                         HEAP EXPR := HEAP CALL := (n, a[1:ac])
+                    FI
+               ELIF tok = lstring
+               THEN LSTR ls;
+                    lstr addr OF ls := psn;
+                    scan;
+                    HEAP EXPR := ls
+               ELIF tok = number
+               THEN NUM nu;  num addr OF nu := psn;
+                    scan;
+                    HEAP EXPR := nu
+               ELSE verify (lpar);
+                    IF tok = blank THEN scan FI;
+                    REF EXPR e = trans expr;
+                    verify (rpar);
+                    e
+               FI;
+
+            PROC usage = VOID:
+            BEGIN puts ("Usage: snobol [-l] FILE'n");
+                  stop
+            END;
+
+            listing := FALSE;
+            IF argc < 2 THEN usage FI;
+            FOR i FROM 2 TO argc
+            DO IF argv (i) = "-l" THEN listing := TRUE
+               ELIF filein = 0
+               THEN filein := fopen (argv (i), file o rdonly);
+                    IF (filein = -1)
+                    THEN error ("opening " + argv (i) + ": " + strerror (errno)) FI
+               ELSE usage
+               FI
+            OD;
+            init;
+            translate
+      END; # TRANSLATION PHASE #
+
+      BEGIN # INTERPRETATION PHASE #
+
+            OP INTG = (REF ITEM a) INT: (a | (INT i) : i),
+               STR = (REF ITEM a) REF STRINGITEM: (a | (REF STRINGITEM s): s),
+               PAT = (REF ITEM a) PATTERN: (a | (PATTERN p) : p);
+            BOOL fn success;
+
+            PROC interpret = (INT stmt no) VOID:
+            BEGIN INT sn := stmt no; BOOL cycling := TRUE;
+
+                  PROC jump = (REF DEST dest) VOID:
+                  BEGIN failed := FALSE;
+                        CASE dest
+                        IN (REF EXPR e): sn := find label (eval softly (e)),
+                           (CHAR c): IF c = "E" THEN sn := UPB t + 1
+                                     ELIF c = "R" THEN fn success := TRUE;
+                                                       cycling := FALSE
+                                     ELSE # c = "F" # fn success := cycling := FALSE
+                                     FI
+                        ESAC
+                  END;
+
+                  WHILE cycling
+                  DO IF sn > UPB t THEN stop FI;
+                     failed := FALSE;
+
+                     # EXECUTE STATEMENT CORE #
+                     CASE stmt core OF t[sn]
+                     IN (REF ASMT a):
+                           (REF ITEM sp = eval softly (subject OF a);
+                            assign (sp, eval strongly (object OF a))),
+                        (REF MATCH m):
+                           (REF ITEM svp = eval strongly (subject OF m);
+                            match (convert to str (svp),
+                                   convert to pat (eval strongly (pattern OF m)))),
+                        (REF REPL r):
+                           (REF ITEM sp = eval softly (subject OF r);
+                            REF ITEM pp = convert to pat (eval strongly (pattern OF r));
+                            REF ITEM svp = convert to str (ref OF (STR sp));
+                            INT c = match (svp, pp);
+                            REF ITEM b = (svp IS NIL | NIL | make str ((val OF (STR svp))[c+1:]));
+                            REF ITEM obp = eval strongly (object OF r);
+                            assign (sp, concatenate (obp, b))),
+                        (REF EXPR e):
+                           eval strongly (e)
+                     ESAC;
+
+                     # PROCESS GOTO FIELD #
+                     REF GOTOFIELD go = goto OF t[sn];
+                     IF go IS NIL THEN sn := sn + 1
+                     ELIF REF DEST (upart OF go) ISNT NIL
+                     THEN jump (upart OF go)
+                     ELIF NOT failed AND (REF DEST (spart OF go) ISNT NIL)
+                     THEN jump (spart OF go)
+                     ELIF failed AND (REF DEST (fpart OF go) ISNT NIL)
+                     THEN jump (fpart OF go)
+                     ELSE sn := sn + 1
+                     FI
+                  OD
+            END; # END OF INTERPRET #
+
+            PROC find label = (REF ITEM label ptr) INT:
+            BEGIN INT stmt no := 0;
+                  IF failed THEN error ("FAILURE IN GOTO FIELD") FI;
+                  FOR i TO UPB t WHILE stmt no = 0
+                  DO IF (REF IDR (label OF t[i]) IS NIL
+                         | FALSE
+                         | label ptr IS idr addr OF label OF t[i])
+                     THEN stmt no := i
+                     FI
+                  OD;
+                  IF stmt no = 0 THEN error ("UNDEFINED LABEL") FI;
+                  stmt no
+            END;
+
+            PROC match = (REF ITEM subject ptr, pattern ptr) INT:
+               IF failed
+               THEN 0
+               ELSE PATTERN p = PAT pattern ptr;
+                    STRING subj = (subject ptr IS NIL | "" | val OF (STR subject ptr));
+                    INT u = UPB subj;
+                    INT iarg,       # INTEGER COMPONENT ARGUMENT #
+                    STRING sarg,    # STRING COMPONENT ARGUMENT #
+                    INT l;          # LENGTH OF SARG #
+                    INT cn := 1,    # COMPONENT NUMBER #
+                        c := 0,     # CURSOR #
+                        code;       # NEW CURSOR OR -1 IF COMPONENT NO-MATCH #
+                    BOOL matching := TRUE;
+
+                    psp := 0;       # CLEAR PATTERN STACK #
+                    WHILE matching
+                    DO IF alternate OF p[cn] /= 0
+                       THEN # PUSH PATTERN STACK #
+                            pattern stack[psp +:= 1] := (c, alternate OF p[cn])
+                       FI;
+                       IF REF ITEM (arg OF p[cn]) ISNT NIL
+                       THEN CASE arg OF p[cn]
+                            IN (INT i) : iarg := i,
+                               (REF STRINGITEM s):
+                                  (sarg := val OF s;  l := UPB sarg)
+                            ESAC
+                       FI;
+
+                       # EXECUTE INDICATED MATCHING ROUTINE #
+                       CASE routine OF p[cn]
+                       IN # MSTR #
+                          IF REF ITEM (arg OF p[cn]) IS NIL
+                          THEN code := c
+                          ELIF c + l > u THEN code := -1
+                          ELSE code := (sarg = subj[c+1:c+l] | c + l | -1)
+                          FI,
+                          # MLEN #
+                          code := (iarg <= u - c | c + iarg | -1),
+                          # MBRK #
+                          IF c >= u THEN code := -1
+                          ELSE INT n = break scan (subj[c+1:], sarg);
+                               code := (n < u - c | c + n | -1)
+                          FI,
+                          # MSPN #
+                          IF c >= u THEN code := -1
+                          ELIF any (sarg, subj[c+1])
+                          THEN INT j := c + 1;
+                               FOR i FROM c + 2 TO u WHILE any (sarg, subj[i])
+                               DO j := i OD;
+                               code := j
+                          ELSE code := -1
+                          FI,
+                          # MANY #
+                          IF c >= u
+                          THEN code := -1
+                          ELSE code := (any (sarg, subj[c+1]) | c + 1 | -1)
+                          FI,
+                          # MNUL #
+                          code := c,
+                          # MIV1 #
+                          code := extra OF p[cn] := c,
+                          # MIV2 #
+                          (INT m = extra OF p[cn - extra OF p[cn]] + 1;
+                           assign (arg OF p[cn], make str (subj[m:c]));
+                           code := c),
+                          # M1 #
+                          code := (1 <= u - c | c + 1 | -1),
+                          # MAT #
+                          (assign (arg OF p[cn], make int (c));
+                           code := c),
+                          # MPOS #
+                          code := (c = iarg | c | -1),
+                          # MTAB #
+                          code := (c <= iarg AND iarg <= u | iarg | -1),
+                          # MRPOS #
+                          code := (u - c = iarg | c | -1),
+                          # MRTAB #
+                          code := (u - c >= iarg | u - iarg | -1),
+                          # MNTY #
+                          IF c >= u
+                          THEN code := -1
+                          ELSE code := (any (sarg, subj[c+1]) | -1 | c + 1)
+                          FI
+                       ESAC;
+
+                       # DECIDE WHAT TO DO NEXT #
+                       IF code >= 0
+                       THEN IF subsequent OF p[cn] = 0
+                            THEN matching := FALSE #SUCCESSFUL TERMINATION #
+                            ELSE cn := subsequent OF p[cn];
+                                 c := code  # CONTINUE #
+                            FI
+                       ELIF psp = 0
+                       THEN failed := TRUE;
+                            matching := FALSE  # STMT FAILURE #
+                       ELSE  # POP PATTERN STACK TO BACKTRACK #
+                             cn := alternate OF pattern stack[psp];
+                             c := cursor OF pattern stack[psp];
+                             psp := psp - 1
+                       FI
+                    OD;
+                    (failed | 0 | code)
+               FI; # END OF MATCH PROCEDURE #
+
+            PROC assign = (REF ITEM subject ptr, object ptr) VOID:
+               IF failed THEN SKIP
+               ELSE REF STRINGITEM s = STR subject ptr;
+                    ref OF s := object ptr;
+                    IF val OF s = "OUTPUT"
+                    THEN IF object ptr IS NIL
+                         THEN puts ("'n")
+                         ELSE CASE object ptr
+                              IN (REF STRINGITEM r): puts ((val OF r) + "'n"),
+                                 (INT i): puts (itoa (i) + "'n"),
+                                 (PATTERN): (error ("ATTEMPT TO OUTPUT PATTERN"); SKIP)
+                              ESAC
+                         FI
+                    FI
+               FI;
+
+            PROC eval softly = (REF EXPR expression) REF ITEM:
+               IF failed THEN SKIP
+               ELSE CASE expression # CAN NEVER BE NIL #
+                    IN (IDR id): idr addr OF id,
+                       (REF UNARYEXPR ue):
+                          IF operator OF ue = "$"
+                          THEN REF ITEM r = convert to str (eval strongly (operand OF ue));
+                               IF r IS NIL
+                               THEN error ("NULL RESULT WHERE VAR REQUIRED");
+                                    SKIP
+                               ELSE r
+                               FI
+                          ELSE error ("INAPPROPRIATE UNARY EXPR WHERE VAR REQUIRED");
+                               SKIP
+                          FI
+                    OUT error ("INAPPROPRIATE EXPR WHERE VAR REQUIRED");
+                        SKIP
+                    ESAC
+               FI;
+
+            PROC eval strongly = (REF EXPR expression) REF ITEM:
+               IF failed THEN SKIP
+               ELIF expression IS NIL THEN NIL
+               ELSE CASE expression
+                    IN (IDR id):
+                          (REF STRINGITEM s = STR (idr addr OF id);
+                           IF val OF s = "INPUT"
+                           THEN STRING line;
+                                # SNOBOL programs read data from stdin.  #
+                                line := gets (80);
+                                IF (line = "") THEN failed := TRUE; eof FI;
+                                assign (idr addr OF id, make str (line));
+                                eof: SKIP
+                           FI;
+                           ref OF s),
+                       (NUM nbr):
+                          num addr OF nbr,
+                       (LSTR ls):
+                          lstr addr OF ls,
+                       (REF UNARYEXPR ue):
+                          (REF ITEM arg ptr = (operator OF ue = "@"
+                                               | eval softly (operand OF ue)
+                                               | eval strongly (operand OF ue));
+                           eval unary (arg ptr, operator OF ue)),
+                       (REF BINARYEXPR be):
+                          (REF ITEM arg1 ptr = eval strongly (operand1 OF be);
+                           REF ITEM arg2 ptr = (operator OF be = "$"
+                                                | eval softly (operand2 OF be)
+                                                | eval strongly (operand2 OF be));
+                           eval binary (arg1 ptr, arg2 ptr, operator OF be)),
+                       (REF CALL cl):
+                          (INT n = UPB args OF cl;
+                           [1:n]REF ITEM arglist;
+                           FOR i TO n
+                           DO arglist[i] := eval strongly ((args OF cl)[i]) OD;
+                           eval call (idr addr OF fnname OF cl, arglist))
+                    ESAC
+               FI;
+
+            PROC eval unary = (REF ITEM arg ptr, CHAR opr) REF ITEM:
+               IF failed THEN SKIP
+               ELSE IF opr = "$"
+                    THEN IF arg ptr IS NIL
+                         THEN error ("INDIRECTION APPLIED TO NULL STRING");
+                              SKIP
+                         ELSE ref OF (STR convert to str (arg ptr))
+                         FI
+                    ELIF opr = "+"
+                    THEN convert to int (arg ptr)
+                    ELIF opr = "-"
+                    THEN INT k = INTG convert to int (arg ptr);
+                         make int (-k)
+                    ELSE # OPR = "@" #
+                         make pat comp (mat, arg ptr)
+                    FI
+               FI;
+
+            PROC eval binary = (REF ITEM arg1 ptr, arg2 ptr, CHAR opr) REF ITEM:
+               IF failed THEN SKIP
+               ELSE IF opr = "$"
+                    THEN REF ITEM c = concatenate (make pat comp (miv1, NIL),
+                                                   arg1 ptr);
+                         concatenate (c, make pat comp (miv2, arg2 ptr))
+                    ELIF opr = "*" OR opr = "/" OR opr = "+" OR opr = "-"
+                    THEN INT m = INTG convert to int (arg1 ptr),
+                         n = INTG convert to int (arg2 ptr);
+                         make int ((opr = "*" | m * n
+                                    |: opr = "/" | m OVER n
+                                    |: opr = "+" | m + n | m - n))
+                    ELIF opr = "C"
+                    THEN concatenate (arg1 ptr, arg2 ptr)
+                    ELSE # OPR = "!" #
+                         PATTERN p1 = PAT convert to pat (arg1 ptr),
+                         p2 = PAT convert to pat (arg2 ptr);
+                         INT u1 = UPB p1, u2 = UPB p2;
+                         PATTERN p = HEAP[u1 + u2]COMPONENT,
+                         INT offset = u1 + 1, INT j := 1;
+                         p[1:u1] := p1[1:u1];
+                         WHILE alternate OF p[j] /= 0
+                         DO j := alternate OF p[j] OD;
+                         alternate OF p[j] := offset;
+                         FOR i FROM offset TO u1 + u2
+                         DO p[i] := p2 [i - u1];
+                            IF subsequent OF p[i] /= 0
+                            THEN subsequent OF p[i] +:= u1
+                            FI;
+                            IF alternate OF p[i] /= 0
+                            THEN alternate OF p[i] +:= u1
+                            FI
+                         OD;
+                         HEAP ITEM := p
+                    FI
+               FI;
+
+            PROC eval call = (REF ITEM name ptr, REF[]REF ITEM arglist) REF ITEM:
+               IF failed THEN SKIP
+               ELSE # SEARCH FUNCTION TABLE FOR NAME #
+                    BOOL not found := TRUE, INT j;
+                    FOR i TO ftp WHILE not found
+                    DO IF name ptr IS fnname OF function table[i]
+                       THEN j := i; not found := FALSE
+                       FI
+                    OD;
+                    IF not found
+                    THEN exec prim fn (name ptr, arglist)
+                    ELSE #PROGRAMMER-DEFINED FUNCTION #
+
+                         PROC stack = (REF ITEM a) VOID:
+                            (IF rsp = rslim THEN error ("RUN STACK OVERFLOW") FI;
+                             run stack [rsp +:= 1] := a);
+
+                         PROC unstack = REF ITEM:
+                            (IF rsp = 0 THEN error ("RETURN FROM LEVEL 0") FI;
+                             run stack [(rsp -:= 1) + 1]);
+
+                         REF STRINGITEM name = STR name ptr;
+
+                         # ENTRY PROTOCOL #
+                         stack (ref OF name);
+                         assign (name ptr, NIL);
+                         REF[]REF ITEM params = params OF function table[j],
+                         INT n = UPB arglist;
+                         IF UPB params /= n
+                         THEN error ("WRONG NUMBER OF ARGUMENTS IN CALL")
+                         FI;
+                         FOR i TO n
+                         DO stack (ref OF (STR params[i]));
+                            assign (params[i], arglist[i])
+                         OD;
+                         REF[]REF ITEM locals = locals OF function table[j];
+                         FOR i TO UPB locals
+                         DO stack (ref OF (STR locals[i]));
+                            assign (locals[i], NIL)
+                         OD;
+
+                         interpret (find label (entry name OF function table[j]));
+
+                         # RETURN PROTOCOL #
+                         FOR i FROM UPB locals BY -1 TO 1
+                         DO assign (locals[i], unstack) OD;
+                         FOR i FROM n BY -1 TO 1
+                         DO assign (params[i], unstack) OD;
+                         REF ITEM result = ref OF name;
+                         assign (name ptr, unstack);
+                         (fn success | result | failed := TRUE ; SKIP)
+                    FI
+               FI;
+
+            PROC exec prim fn = (REF ITEM name ptr,
+                                 REF[]REF ITEM arglist) REF ITEM:
+            BEGIN
+                  PROC gen1 = (INT routine) REF ITEM:
+                  BEGIN # CREATE PATTERN COMPONENT WITH STRING ARGUMENT #
+                        REF ITEM arg = convert to str (arglist[1]);
+                        IF arg IS NIL
+                        THEN error ("NULL ARG FOR PATTERN-VALUED PRIMITIVE FUNCTION" )
+                        FI;
+                        make pat comp (routine, arg)
+                  END;
+
+                  PROC gen2 = (INT routine) REF ITEM:
+                  BEGIN # CREATE PATTERN COMPONENT WITH INTEGER ARGUMENT #
+                        REF ITEM arg = convert to int (arglist[1]);
+                        IF INTG arg < 0
+                        THEN error ("NEGATIVE ARG FOR PATTERN-VALUED PRIMITIVE FUNCTION")
+                        FI;
+                        make pat comp (routine, arg)
+                  END;
+
+                  STRING fn = val OF (STR name ptr), INT n = UPB arglist;
+                  IF fn = "LE" AND n = 2
+                  THEN IF INTG convert to int (arglist[1])
+                          <= INTG convert to int (arglist[2])
+                       THEN NIL
+                       ELSE failed := TRUE;
+                            SKIP
+                       FI
+                  ELIF fn = "EQ" AND n = 2
+                  THEN IF INTG convert to int (arglist[1])
+                          = INTG convert to int (arglist[2])
+                       THEN NIL
+                       ELSE failed := TRUE;
+                            SKIP
+                       FI
+                  ELIF fn = "NE" AND n = 2
+                  THEN IF INTG convert to int (arglist[1])
+                          /= INTG convert to int (arglist[2])
+                       THEN NIL
+                       ELSE failed := TRUE;
+                            SKIP
+                       FI
+                  ELIF fn = "IDENT" AND n = 2
+                  THEN IF REF ITEM (arglist[1]) IS arglist[2]
+                       THEN NIL
+                       ELSE failed := TRUE;
+                            SKIP
+                       FI
+                  ELIF fn = "DIFFER" AND n = 2
+                  THEN IF REF ITEM (arglist[1]) ISNT arglist[2]
+                       THEN NIL
+                       ELSE failed := TRUE;
+                            SKIP
+                       FI
+                  ELIF fn = "ANY" AND n = 1 THEN gen1 (many)
+                  ELIF fn = "LEN" AND n = 1 THEN gen2 (mlen)
+                  ELIF fn = "POS" AND n = 1 THEN gen2 (mpos)
+                  ELIF fn = "TAB" AND n = 1 THEN gen2 (mtab)
+                  ELIF fn = "SPAN" AND n = 1 THEN gen1 (mspn)
+                  ELIF fn = "RPOS" AND n = 1 THEN gen2 (mrpos)
+                  ELIF fn = "RTAB" AND n = 1 THEN gen2 (mrtab)
+                  ELIF fn = "BREAK" AND n = 1 THEN gen1 (mbrk)
+                  ELIF fn = "NOTANY" AND n = 1 THEN gen1 (mnty)
+                  ELIF fn = "SIZE" AND n = 1
+                  THEN make int (UPB val OF (STR convert to str (arglist[1])))
+                  ELIF fn = "DEFINE" AND n = 2
+                  THEN IF REF ITEM (arglist[1]) IS NIL
+                       THEN error ("NULL PROTOTYPE") FI;
+                       STRING prototype = val OF (STR convert to str (arglist[1]));
+                       REF ITEM entry = convert to str (arglist[2]);
+                       IF entry IS NIL THEN error ("NULL ENTRY LABEL") FI;
+
+                       PROC check and find = (STRING str) REF ITEM:
+                       BEGIN IF UPB str = 0 THEN error ("ILLEGAL PROTOTYPE") FI;
+                             STRING an = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.";
+                             IF NOT any (an[:26], str[1])
+                             THEN error ("ILLEGAL PROTOTYPE") FI;
+                             FOR i FROM 2 TO UPB str
+                             DO IF NOT any (an, str[i])
+                                THEN error ("ILLEGAL PROTOTYPE")
+                                FI
+                             OD;
+                             make str (str)
+                       END;
+
+                       PROC breakup = (STRING str) REF[]REF ITEM:
+                       BEGIN #ANALYZE A LIST OF IDENTIFIERS #
+                             [1:arglim]REF ITEM r, INT p := 0, a := 1, b;
+                             WHILE a <= UPB str
+                             DO b := break scan (str[a:], ",");
+                                IF p >= arglim
+                                THEN error ("TOO MANY PARAMETERS OR LOCALS IN PROTOTYPE") FI;
+                                r[p +:= 1] := check and find (str[a:a+b-1]);
+                                a := a + b + 1
+                             OD;
+                             HEAP[1:p]REF ITEM := r[:p]
+                       END;
+
+                       INT lp = UPB prototype;
+                       INT a = break scan (prototype, "(");
+                       IF a >= lp THEN error ("ILLEGAL PROTOTYPE") FI;
+                       REF ITEM name ptr = check and find (prototype[:a]);
+                       INT b = break scan (prototype[a+2:], ")");
+                       IF b >= lp - a - 1 THEN error ("ILLEGAL PROTOTYPE") FI;
+                       REF[]REF ITEM params = breakup (prototype[a+2:a+1+b]);
+                       REF[]REF ITEM locals = breakup (prototype[a+b+3:]);
+
+                       BOOL not found := TRUE;
+                       FOR i TO ftp WHILE not found
+                       DO IF name ptr IS fnname OF function table[i]
+                          THEN not found := FALSE;
+                               function table[i] := (name ptr, entry, params, locals)
+                          FI
+                       OD;
+                       IF not found
+                       THEN IF ftp = ftlim
+                            THEN error ("FUNCTION TABLE OVERFLOW") FI;
+                            function table [ftp +:= 1] := (name ptr, entry, params, locals)
+                       FI;
+                       NIL # RESULT OF DEFINE(...) #
+                  ELSE error ("ILLEGAL FUNCTION CALL");
+                       SKIP
+                  FI
+            END;
+
+            PROC concatenate = (REF ITEM ptr1, ptr2) REF ITEM:
+            BEGIN
+
+                  PROC concat patterns = (PATTERN p1, p2) REF ITEM:
+                  BEGIN INT u1 = UPB p1, u2 = UPB p2;
+                        PATTERN p = HEAP[u1 + u2]COMPONENT;
+                        INT offset = u1 + 1;
+                        FOR i TO u1
+                        DO p[i] := p1[i];
+                           IF subsequent OF p[i] = 0
+                           THEN subsequent OF p[i] := offset FI
+                        OD;
+                        FOR i FROM offset TO u1 + u2
+                        DO p[i] := p2[i - u1];
+                           IF subsequent OF p[i] /= 0
+                           THEN subsequent OF p[i] +:= u1 FI;
+                           IF alternate OF p[i] /= 0
+                           THEN alternate OF p[i] +:= u1 FI
+                        OD;
+                        IF u2 = 1 AND routine OF p[offset] = miv2
+                        THEN extra OF p[offset] := u1 FI;
+                        HEAP ITEM := p
+                  END;
+
+                  IF failed THEN SKIP
+                  ELSE IF ptr1 IS NIL THEN ptr2
+                       ELIF ptr2 IS NIL THEN ptr1
+                       ELSE CASE ptr1
+                            IN (PATTERN p1):
+                                concat patterns (p1, PAT convert to pat (ptr2))
+                            OUSE ptr2
+                            IN (PATTERN p2):
+                                concat patterns (PAT convert to pat (ptr1), p2)
+                            OUT STRING s1 = val OF (STR convert to str (ptr1));
+                                make str (s1 + val OF (STR convert to str (ptr2)))
+                            ESAC
+                       FI
+                  FI
+            END;
+
+            PROC convert to int = (REF ITEM ptr) REF ITEM:
+               IF failed THEN SKIP
+               ELSE IF ptr IS NIL THEN make int (0)
+                    ELSE CASE ptr
+                         IN (INT): ptr,
+                            (PATTERN): (error ("PATTERN VALUE WHERE INTEGER REQUIRED"); SKIP),
+                            (REF STRINGITEM s):
+                               (INT n := 0, d, z := ABS "0";
+                                FOR i TO UPB val OF s
+                                DO d := ABS (val OF s)[i] - z;
+                                   IF d < 0 OR d > 9
+                                   THEN error ("STRING NOT CONVERTIBLE TO INTEGER") FI;
+                                   n := n * 10 + d
+                                OD;
+                                make int (n))
+                         ESAC
+                    FI
+               FI;
+
+            PROC convert to pat = (REF ITEM ptr) REF ITEM:
+               IF failed THEN SKIP
+               ELSE IF ptr IS NIL
+                    THEN make pat comp (mstr, NIL)
+                    ELSE CASE ptr
+                         IN (PATTERN): ptr
+                         OUT make pat comp (mstr, convert to str (ptr))
+                         ESAC
+                    FI
+               FI;
+
+            PROC convert to str = (REF ITEM ptr) REF ITEM:
+               IF failed THEN SKIP
+               ELSE IF ptr IS NIL THEN ptr
+                    ELSE CASE ptr
+                         IN (REF STRINGITEM): ptr,
+                            (PATTERN): (error ("PATTERN VALUE WHERE STRING REQUIRED"); SKIP),
+                            (INT i): make str (itoa (i))
+                         ESAC
+                    FI
+               FI;
+
+            PROC make int = (INT val) REF ITEM:
+               IF failed THEN SKIP
+               ELSE HEAP ITEM := val
+               FI;
+
+            PROC make pat comp = (INT routine, REF ITEM arg) REF ITEM:
+               IF failed THEN SKIP
+               ELSE HEAP ITEM := HEAP[1:1]COMPONENT := COMPONENT (routine, 0, 0, SKIP, arg)
+               FI;
+
+            PROC make str = (STRING val) REF ITEM:
+               IF failed THEN SKIP
+               ELIF UPB val = 0 THEN NIL
+               ELSE INT i := 0, BOOL nf := TRUE;
+                    WHILE IF (i +:= 1) <= nin
+                          THEN nf := val /= val OF (STR spool [i])
+                          ELSE FALSE
+                          FI
+                    DO SKIP OD;
+                    IF nf
+                    THEN IF nin = spoolsize THEN error ("TOO MANY STRINGS") FI;
+                         spool[nin +:= 1] := HEAP ITEM := HEAP STRINGITEM := (val, NIL)
+                    FI;
+                    spool[i]
+               FI;
+
+            PROC break scan = (STRING str, arg) INT:
+            BEGIN # RESULT = UPB STR IF NO BREAK CHAR, LESS OTHERWISE #
+                  INT j := 0;
+                  FOR i TO UPB str WHILE NOT any (arg, str[i])
+                  DO j := i OD;
+                  j
+            END;
+
+            PROC any = (STRING str, CHAR ch) BOOL:
+            BEGIN BOOL nf;
+                  FOR i TO UPB str WHILE nf := ch /= str[i] DO SKIP OD;
+                  NOT nf
+            END;
+
+            interpret ((REF ITEM (prog entry) IS NIL | 1 | find label (prog entry)))
+      END # INTERPRETATION PHASE #
+END
diff --git a/gcc/testsuite/algol68/compile/supper-1.a68 b/gcc/testsuite/algol68/compile/supper-1.a68
new file mode 100644
index 00000000000..a572f1e929f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-1.a68
@@ -0,0 +1,11 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode Some_Mode = real;
+      Some_Mode some_real := random;
+
+      puts ("Hello time for SUPPER!\n");
+      if some_real > 0.5
+      then puts ("YES\n")
+      else puts ("NO\n")
+      fi
+end
diff --git a/gcc/testsuite/algol68/compile/supper-10.a68 b/gcc/testsuite/algol68/compile/supper-10.a68
new file mode 100644
index 00000000000..5c661a677f4
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-10.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode BEGIN = int;
+      BEGIN some_int = 10;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-11.a68 b/gcc/testsuite/algol68/compile/supper-11.a68
new file mode 100644
index 00000000000..5c661a677f4
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-11.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode BEGIN = int;
+      BEGIN some_int = 10;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-12.a68 b/gcc/testsuite/algol68/compile/supper-12.a68
new file mode 100644
index 00000000000..497a88a2e66
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-12.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin for i while i < 10
+      do puts ("lala\n")
+      od
+end
diff --git a/gcc/testsuite/algol68/compile/supper-13.a68 b/gcc/testsuite/algol68/compile/supper-13.a68
new file mode 100644
index 00000000000..5e17fb4832c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-13.a68
@@ -0,0 +1,7 @@
+{ dg-options "-fstropping=supper" }
+
+{ mode_ should not be recognized as a symbol.  }
+
+begin int mode_ = 10;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-2.a68 b/gcc/testsuite/algol68/compile/supper-2.a68
new file mode 100644
index 00000000000..04d5f0f461f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-2.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin int foo_bar = 10;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-3.a68 b/gcc/testsuite/algol68/compile/supper-3.a68
new file mode 100644
index 00000000000..4cc711b9132
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-3.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin int foo_bar_ = 10;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-4.a68 b/gcc/testsuite/algol68/compile/supper-4.a68
new file mode 100644
index 00000000000..283be9a4735
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-4.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin int foo_ = 10;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-5.a68 b/gcc/testsuite/algol68/compile/supper-5.a68
new file mode 100644
index 00000000000..b3ffd899e5c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-5.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode Foo_bar = int;
+      Foo_bar some_int = 10;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-6.a68 b/gcc/testsuite/algol68/compile/supper-6.a68
new file mode 100644
index 00000000000..37fc5e6f3c2
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-6.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin go to done;
+done: skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-7.a68 b/gcc/testsuite/algol68/compile/supper-7.a68
new file mode 100644
index 00000000000..a3741748b4c
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-7.a68
@@ -0,0 +1,5 @@
+{ dg-options {-fstropping=supper} }
+
+begin goto done;
+done: skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-8.a68 b/gcc/testsuite/algol68/compile/supper-8.a68
new file mode 100644
index 00000000000..363d9b483ca
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-8.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode Int = int;
+      Int some_int = 10;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/supper-9.a68 b/gcc/testsuite/algol68/compile/supper-9.a68
new file mode 100644
index 00000000000..5c661a677f4
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/supper-9.a68
@@ -0,0 +1,6 @@
+{ dg-options {-fstropping=supper} }
+
+begin mode BEGIN = int;
+      BEGIN some_int = 10;
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/uniting-1.a68 b/gcc/testsuite/algol68/compile/uniting-1.a68
new file mode 100644
index 00000000000..057c4f85838
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/uniting-1.a68
@@ -0,0 +1,8 @@
+{ dg-options {-fstropping=supper} }
+begin mode JSON_Val = union (int,ref JSON_Obj),
+           JSON_Obj = struct (int je),
+
+      proc json_new_obj = JSON_Val:
+         (JSON_Obj o; o);
+      skip
+end
diff --git a/gcc/testsuite/algol68/compile/upper-1.a68 b/gcc/testsuite/algol68/compile/upper-1.a68
new file mode 100644
index 00000000000..6fb7871301f
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/upper-1.a68
@@ -0,0 +1,11 @@
+# { dg-options {-fstropping=upper} }  #
+
+BEGIN MODE SOME_MODE = REAL;
+      SOME_MODE some_real := random;
+
+      puts ("Hello time for SUPPER!\n");
+      IF some_real > 0.5
+      THEN puts ("YES\n")
+      ELSE puts ("NO\n")
+      FI
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-1.a68 b/gcc/testsuite/algol68/compile/warning-scope-1.a68
new file mode 100644
index 00000000000..99ae973fe90
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-1.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Potential scope violation warnings are disabled by default.  #
+BEGIN PROC increase = (REF INT i) REF INT:
+      BEGIN INT j := i;
+            j # Inhibited warning.  #
+      END;
+      increase (LOC INT)
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-2.a68 b/gcc/testsuite/algol68/compile/warning-scope-2.a68
new file mode 100644
index 00000000000..5bbc0b37126
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-2.a68
@@ -0,0 +1,8 @@
+# { dg-options {-Wscope -fstropping=upper} }  #
+BEGIN PROC increase = (REF INT i) REF INT:
+      BEGIN
+         INT j := i;
+         j # { dg-warning "scope violation" } #
+      END;
+      increase (LOC INT)
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-3.a68 b/gcc/testsuite/algol68/compile/warning-scope-3.a68
new file mode 100644
index 00000000000..c5dd29562c0
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-3.a68
@@ -0,0 +1,3 @@
+# { dg-options {-Wscope -fstropping=upper} }  #
+(REF INT xx;
+ xx := (INT x; x := 3)) # { dg-warning "scope violation" }  #
diff --git a/gcc/testsuite/algol68/compile/warning-scope-4.a68 b/gcc/testsuite/algol68/compile/warning-scope-4.a68
new file mode 100644
index 00000000000..ae0592ed743
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-4.a68
@@ -0,0 +1,3 @@
+# { dg-options {-Wscope -fstropping=upper} }  #
+(REF INT xx;
+ (INT x; xx:= x; x := 3)) # { dg-warning "scope violation" }  #
diff --git a/gcc/testsuite/algol68/compile/warning-scope-5.a68 b/gcc/testsuite/algol68/compile/warning-scope-5.a68
new file mode 100644
index 00000000000..2bb5b4afe88
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-5.a68
@@ -0,0 +1,8 @@
+# { dg-options {-Wscope -fstropping=upper} }  #
+# The scope violation here is due to the routine text, which is copied
+  to P, referring to a value whose range doesn't exist anymore: X #
+BEGIN (PROC REAL p;
+       (REAL x;
+        p := REAL: x * 2); # { dg-warning "scope violation" }  #
+       p)
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-6.a68 b/gcc/testsuite/algol68/compile/warning-scope-6.a68
new file mode 100644
index 00000000000..fa3888d6528
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-6.a68
@@ -0,0 +1,6 @@
+# { dg-options {-Wscope -fstropping=upper} }  #
+BEGIN (PROC REAL p; REAL mypi := 3.14;
+       (REAL x;
+        p := REAL: mypi * 2); # No scope violation here.  #
+       p)
+END
diff --git a/gcc/testsuite/algol68/compile/warning-scope-7.a68 b/gcc/testsuite/algol68/compile/warning-scope-7.a68
new file mode 100644
index 00000000000..b99fa85ddff
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-scope-7.a68
@@ -0,0 +1,12 @@
+# { dg-options {-Wscope -fstropping=upper} }  #
+# N,M below represent pairs of insc, outsc  #
+BEGIN (INT x;
+       REF INT xx;
+       (REF INT yy;
+        INT y;
+        xx := yy; # 0,0 := 1,0. Dynamic check.  #
+        yy := y;  # 1,1 := 1,1. OK  #
+        xx := y   # 0,0 := 1,1. { dg-warning "scope violation" } #
+       )
+      )
+END
diff --git a/gcc/testsuite/algol68/compile/warning-voiding-1.a68 b/gcc/testsuite/algol68/compile/warning-voiding-1.a68
new file mode 100644
index 00000000000..f34787c2979
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-voiding-1.a68
@@ -0,0 +1,5 @@
+# { dg-options {-Wvoiding -fstropping=upper} }  #
+BEGIN PROC sum = (INT a, INT b) INT:
+         ( a + b );
+      sum (10, 20) # { dg-warning "will be voided" } #
+END
diff --git a/gcc/testsuite/algol68/compile/warning-voiding-2.a68 b/gcc/testsuite/algol68/compile/warning-voiding-2.a68
new file mode 100644
index 00000000000..e3c98792c91
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/warning-voiding-2.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN PROC sum = (INT a, INT b) INT:
+         ( a + b );
+      sum (10, 20) # Voiding warning won't be emitted by default.  #
+END
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 46/47] a68: testsuite: revised MC Algol 68 test set
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (44 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 45/47] a68: testsuite: compilation tests Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-18 21:51 ` [PATCH V4 47/47] a68: testsuite: mcgt tests Jose E. Marchesi
  2025-10-19 18:37 ` [PATCH V4 00/47] Algol 68 GCC Front-End Sam James
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

gcc/testsuite/ChangeLog

	* algol68/README.mcts: New file.
	* algol68/compile/mcts/compile.exp: Likewise.
	* algol68/compile/mcts/decl06.a68: Likewise.
	* algol68/compile/mcts/idef10.a68: Likewise.
	* algol68/compile/mcts/mdeq01.a68: Likewise.
	* algol68/compile/mcts/mdeq03.a68: Likewise.
	* algol68/compile/mcts/mdeq05.a68: Likewise.
	* algol68/compile/mcts/mdeq06.a68: Likewise.
	* algol68/compile/mcts/oper05.a68: Likewise.
	* algol68/compile/mcts/oper06.a68: Likewise.
	* algol68/compile/mcts/oper12.a68: Likewise.
	* algol68/compile/mcts/oper15.a68: Likewise.
	* algol68/execute/mcts/clau02.a68: Likewise.
	* algol68/execute/mcts/clau04.a68: Likewise.
	* algol68/execute/mcts/clau05.a68: Likewise.
	* algol68/execute/mcts/clau07.a68: Likewise.
	* algol68/execute/mcts/clau08.a68: Likewise.
	* algol68/execute/mcts/clau09.a68: Likewise.
	* algol68/execute/mcts/coer01.a68: Likewise.
	* algol68/execute/mcts/coer02.a68: Likewise.
	* algol68/execute/mcts/coer03.a68: Likewise.
	* algol68/execute/mcts/coer07.a68: Likewise.
	* algol68/execute/mcts/coer08.a68: Likewise.
	* algol68/execute/mcts/coer09.a68: Likewise.
	* algol68/execute/mcts/coer10.a68: Likewise.
	* algol68/execute/mcts/coer11.a68: Likewise.
	* algol68/execute/mcts/coer13.a68: Likewise.
	* algol68/execute/mcts/coer14.a68: Likewise.
	* algol68/execute/mcts/decl01.a68: Likewise.
	* algol68/execute/mcts/decl03.a68: Likewise.
	* algol68/execute/mcts/decl04.a68: Likewise.
	* algol68/execute/mcts/decl05.a68: Likewise.
	* algol68/execute/mcts/execute.exp: Likewise.
	* algol68/execute/mcts/flex01.a68: Likewise.
	* algol68/execute/mcts/flex02.a68: Likewise.
	* algol68/execute/mcts/idef01.a68: Likewise.
	* algol68/execute/mcts/idef02.a68: Likewise.
	* algol68/execute/mcts/idef03.a68: Likewise.
	* algol68/execute/mcts/idef04.a68: Likewise.
	* algol68/execute/mcts/idef05.a68: Likewise.
	* algol68/execute/mcts/idef06.a68: Likewise.
	* algol68/execute/mcts/idef07.a68: Likewise.
	* algol68/execute/mcts/idef11.a68: Likewise.
	* algol68/execute/mcts/idef12.a68: Likewise.
	* algol68/execute/mcts/idrl01.a68: Likewise.
	* algol68/execute/mcts/jump01.a68: Likewise.
	* algol68/execute/mcts/jump02.a68: Likewise.
	* algol68/execute/mcts/jump03.a68: Likewise.
	* algol68/execute/mcts/jump04.a68: Likewise.
	* algol68/execute/mcts/mdeq02.a68: Likewise.
	* algol68/execute/mcts/mdeq04.a68: Likewise.
	* algol68/execute/mcts/misc07.a68: Likewise.
	* algol68/execute/mcts/null01.a68: Likewise.
	* algol68/execute/mcts/null02.a68: Likewise.
	* algol68/execute/mcts/null03.a68: Likewise.
	* algol68/execute/mcts/null04.a68: Likewise.
	* algol68/execute/mcts/null05.a68: Likewise.
	* algol68/execute/mcts/null06.a68: Likewise.
	* algol68/execute/mcts/null07.a68: Likewise.
	* algol68/execute/mcts/null08.a68: Likewise.
	* algol68/execute/mcts/null09.a68: Likewise.
	* algol68/execute/mcts/numr07.a68: Likewise.
	* algol68/execute/mcts/oper01.a68: Likewise.
	* algol68/execute/mcts/oper02.a68: Likewise.
	* algol68/execute/mcts/oper03.a68: Likewise.
	* algol68/execute/mcts/oper04.a68: Likewise.
	* algol68/execute/mcts/oper05.a68: Likewise.
	* algol68/execute/mcts/oper07.a68: Likewise.
	* algol68/execute/mcts/oper08.a68: Likewise.
	* algol68/execute/mcts/oper09.a68: Likewise.
	* algol68/execute/mcts/oper10.a68: Likewise.
	* algol68/execute/mcts/oper11.a68: Likewise.
	* algol68/execute/mcts/oper14.a68: Likewise.
	* algol68/execute/mcts/oper16.a68: Likewise.
	* algol68/execute/mcts/simp01.a68: Likewise.
	* algol68/execute/mcts/simp02.a68: Likewise.
	* algol68/execute/mcts/simp03.a68: Likewise.
	* algol68/execute/mcts/simp04.a68: Likewise.
	* algol68/execute/mcts/simp05.a68: Likewise.
	* algol68/execute/mcts/simp07.a68: Likewise.
	* algol68/execute/mcts/simp08.a68: Likewise.
	* algol68/execute/mcts/simp09.a68: Likewise.
	* algol68/execute/mcts/simp10.a68: Likewise.
	* algol68/execute/mcts/simp11.a68: Likewise.
	* algol68/execute/mcts/simp13.a68: Likewise.
	* algol68/execute/mcts/stow02.a68: Likewise.
	* algol68/execute/mcts/stow06.a68: Likewise.
---
 gcc/testsuite/algol68/README.mcts             |  37 +
 .../algol68/compile/mcts/compile.exp          |  34 +
 gcc/testsuite/algol68/compile/mcts/decl06.a68 | 258 ++++++
 gcc/testsuite/algol68/compile/mcts/idef10.a68 |   6 +
 gcc/testsuite/algol68/compile/mcts/mdeq01.a68 |   6 +
 gcc/testsuite/algol68/compile/mcts/mdeq03.a68 |   8 +
 gcc/testsuite/algol68/compile/mcts/mdeq05.a68 |   8 +
 gcc/testsuite/algol68/compile/mcts/mdeq06.a68 |  18 +
 gcc/testsuite/algol68/compile/mcts/oper05.a68 |   8 +
 gcc/testsuite/algol68/compile/mcts/oper06.a68 |   6 +
 gcc/testsuite/algol68/compile/mcts/oper12.a68 |  13 +
 gcc/testsuite/algol68/compile/mcts/oper15.a68 |   7 +
 gcc/testsuite/algol68/execute/mcts/clau02.a68 |  23 +
 gcc/testsuite/algol68/execute/mcts/clau04.a68 |  11 +
 gcc/testsuite/algol68/execute/mcts/clau05.a68 |  11 +
 gcc/testsuite/algol68/execute/mcts/clau07.a68 |  21 +
 gcc/testsuite/algol68/execute/mcts/clau08.a68 | 159 ++++
 gcc/testsuite/algol68/execute/mcts/clau09.a68 |  82 ++
 gcc/testsuite/algol68/execute/mcts/coer01.a68 |   4 +
 gcc/testsuite/algol68/execute/mcts/coer02.a68 |  20 +
 gcc/testsuite/algol68/execute/mcts/coer03.a68 |  53 ++
 gcc/testsuite/algol68/execute/mcts/coer07.a68 |  14 +
 gcc/testsuite/algol68/execute/mcts/coer08.a68 |   9 +
 gcc/testsuite/algol68/execute/mcts/coer09.a68 |  16 +
 gcc/testsuite/algol68/execute/mcts/coer10.a68 |  62 ++
 gcc/testsuite/algol68/execute/mcts/coer11.a68 |  37 +
 gcc/testsuite/algol68/execute/mcts/coer13.a68 |  19 +
 gcc/testsuite/algol68/execute/mcts/coer14.a68 |   4 +
 gcc/testsuite/algol68/execute/mcts/decl01.a68 |   8 +
 gcc/testsuite/algol68/execute/mcts/decl03.a68 |  40 +
 gcc/testsuite/algol68/execute/mcts/decl04.a68 |   3 +
 gcc/testsuite/algol68/execute/mcts/decl05.a68 |   7 +
 .../algol68/execute/mcts/execute.exp          |  29 +
 gcc/testsuite/algol68/execute/mcts/flex01.a68 |  10 +
 gcc/testsuite/algol68/execute/mcts/flex02.a68 |  11 +
 gcc/testsuite/algol68/execute/mcts/idef01.a68 |   6 +
 gcc/testsuite/algol68/execute/mcts/idef02.a68 |   6 +
 gcc/testsuite/algol68/execute/mcts/idef03.a68 |   7 +
 gcc/testsuite/algol68/execute/mcts/idef04.a68 |  11 +
 gcc/testsuite/algol68/execute/mcts/idef05.a68 |   4 +
 gcc/testsuite/algol68/execute/mcts/idef06.a68 |  23 +
 gcc/testsuite/algol68/execute/mcts/idef07.a68 |   8 +
 gcc/testsuite/algol68/execute/mcts/idef11.a68 |  17 +
 gcc/testsuite/algol68/execute/mcts/idef12.a68 |  52 ++
 gcc/testsuite/algol68/execute/mcts/idrl01.a68 |   7 +
 gcc/testsuite/algol68/execute/mcts/jump01.a68 |   9 +
 gcc/testsuite/algol68/execute/mcts/jump02.a68 |   7 +
 gcc/testsuite/algol68/execute/mcts/jump03.a68 |   5 +
 gcc/testsuite/algol68/execute/mcts/jump04.a68 |  11 +
 gcc/testsuite/algol68/execute/mcts/mdeq02.a68 |   8 +
 gcc/testsuite/algol68/execute/mcts/mdeq04.a68 |  17 +
 gcc/testsuite/algol68/execute/mcts/misc07.a68 | 207 +++++
 gcc/testsuite/algol68/execute/mcts/null01.a68 |   5 +
 gcc/testsuite/algol68/execute/mcts/null02.a68 |   3 +
 gcc/testsuite/algol68/execute/mcts/null03.a68 |   4 +
 gcc/testsuite/algol68/execute/mcts/null04.a68 |   2 +
 gcc/testsuite/algol68/execute/mcts/null05.a68 |   2 +
 gcc/testsuite/algol68/execute/mcts/null06.a68 |   4 +
 gcc/testsuite/algol68/execute/mcts/null07.a68 |   2 +
 gcc/testsuite/algol68/execute/mcts/null08.a68 |   3 +
 gcc/testsuite/algol68/execute/mcts/null09.a68 |   3 +
 gcc/testsuite/algol68/execute/mcts/numr07.a68 |  81 ++
 gcc/testsuite/algol68/execute/mcts/oper01.a68 |   8 +
 gcc/testsuite/algol68/execute/mcts/oper02.a68 |   6 +
 gcc/testsuite/algol68/execute/mcts/oper03.a68 |  12 +
 gcc/testsuite/algol68/execute/mcts/oper04.a68 |  21 +
 gcc/testsuite/algol68/execute/mcts/oper05.a68 |   8 +
 gcc/testsuite/algol68/execute/mcts/oper07.a68 |  12 +
 gcc/testsuite/algol68/execute/mcts/oper08.a68 |  18 +
 gcc/testsuite/algol68/execute/mcts/oper09.a68 |  65 ++
 gcc/testsuite/algol68/execute/mcts/oper10.a68 |  87 ++
 gcc/testsuite/algol68/execute/mcts/oper11.a68 | 141 +++
 gcc/testsuite/algol68/execute/mcts/oper14.a68 |  32 +
 gcc/testsuite/algol68/execute/mcts/oper16.a68 | 866 ++++++++++++++++++
 gcc/testsuite/algol68/execute/mcts/simp01.a68 |   8 +
 gcc/testsuite/algol68/execute/mcts/simp02.a68 |  13 +
 gcc/testsuite/algol68/execute/mcts/simp03.a68 |  12 +
 gcc/testsuite/algol68/execute/mcts/simp04.a68 |  46 +
 gcc/testsuite/algol68/execute/mcts/simp05.a68 |  28 +
 gcc/testsuite/algol68/execute/mcts/simp07.a68 |  14 +
 gcc/testsuite/algol68/execute/mcts/simp08.a68 |  35 +
 gcc/testsuite/algol68/execute/mcts/simp09.a68 |  17 +
 gcc/testsuite/algol68/execute/mcts/simp10.a68 |   6 +
 gcc/testsuite/algol68/execute/mcts/simp11.a68 |  36 +
 gcc/testsuite/algol68/execute/mcts/simp13.a68 |  13 +
 gcc/testsuite/algol68/execute/mcts/stow02.a68 |  15 +
 gcc/testsuite/algol68/execute/mcts/stow06.a68 |  30 +
 87 files changed, 3125 insertions(+)
 create mode 100644 gcc/testsuite/algol68/README.mcts
 create mode 100644 gcc/testsuite/algol68/compile/mcts/compile.exp
 create mode 100644 gcc/testsuite/algol68/compile/mcts/decl06.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/idef10.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/mdeq01.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/mdeq03.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/mdeq05.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/mdeq06.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/oper05.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/oper06.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/oper12.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcts/oper15.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/clau09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer10.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer11.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer13.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/coer14.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/decl01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/decl03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/decl04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/decl05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/execute.exp
 create mode 100644 gcc/testsuite/algol68/execute/mcts/flex01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/flex02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef06.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef11.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idef12.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/idrl01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/jump01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/jump02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/jump03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/jump04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/mdeq02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/mdeq04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/misc07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null06.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/null09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/numr07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper10.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper11.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper14.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/oper16.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp01.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp03.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp04.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp05.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp07.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp08.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp09.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp10.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp11.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/simp13.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/stow02.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcts/stow06.a68

diff --git a/gcc/testsuite/algol68/README.mcts b/gcc/testsuite/algol68/README.mcts
new file mode 100644
index 00000000000..dc3c50b35c4
--- /dev/null
+++ b/gcc/testsuite/algol68/README.mcts
@@ -0,0 +1,37 @@
+The tests in compile/mcts and execute/mcts have been adapted from:
+
+  The Revised MC Algol 68 Test Set, version 3
+
+edited by Dick Grüne in 1973 and originally published by the
+Mathematisch Centrum in Amsterdam, a non-profit institution founded in
+1946 aiming at the promotion of pure mathematics and its applications.
+
+The WG 2.1 blessed the test set with this authorized statement:
+
+  "This ALGOL68 Test Set has been reviewed by the IFIP Working Group
+   2.1, which considers it as a valuable means of testing
+   implementations of ALGOL68."
+
+The test set explores all odd corners of Algol 68.
+
+The tests have been modified in order to accommodate the GNU Algol 68
+implementation.  Some general adaptations are:
+
+- Many tests in the original MC test set print out expected results so
+  they can be verified visually.  We check for them programmatically
+  instead making use of the ASSERT construct.
+
+Additional particular modifications are explained and justified in the
+source files of the corresponding tests.
+
+The tests fall in the following categories:
+
+Null programs (nullNN.a68)
+  Various forms of empty enclosed-clauses.
+
+Simple tests (simpNN.a68)
+  Contains almost all language features of the language used in
+  simple ways.
+
+Declarers tests (declNN.a68)
+  Declarers and their well-formedness.
diff --git a/gcc/testsuite/algol68/compile/mcts/compile.exp b/gcc/testsuite/algol68/compile/mcts/compile.exp
new file mode 100644
index 00000000000..68fa5fa2625
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/compile.exp
@@ -0,0 +1,34 @@
+# Copyright (C) 2024 Free Software Foundation, Inc.
+
+# This program 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 of the License, or
+# (at your option) any later version.
+# 
+# This program 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/>.
+
+# Compile tests, no torture testing.
+#
+# These tests raise errors in the front end; torture testing doesn't apply.
+
+load_lib algol68-dg.exp
+
+# Initialize `dg'.
+dg-init
+
+# Main loop.
+set saved-dg-do-what-default ${dg-do-what-default}
+
+set dg-do-what-default "compile"
+algol68-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] "" ""
+set dg-do-what-default ${saved-dg-do-what-default}
+
+# All done.
+dg-finish
diff --git a/gcc/testsuite/algol68/compile/mcts/decl06.a68 b/gcc/testsuite/algol68/compile/mcts/decl06.a68
new file mode 100644
index 00000000000..f91e0d326ec
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/decl06.a68
@@ -0,0 +1,258 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN # 1. Actual declaration.  #
+      # 1.a Without bounds.  #
+
+      # primitive  #
+      BEGIN INT x1,
+            INT x2, x3,
+            INT x4, x5, x6,
+            REAL x7, x8, x9, x10, x11, x12,
+            LONG INT x13,
+            LONG REAL x14,
+            BOOL x15,
+            CHAR x16;
+            SKIP
+      END;
+
+      # ref + primitive  #
+      BEGIN REF INT x1,
+            REF REF REF REAL x2,
+            REF REF REF REF LONG REAL x3,
+            REF REF REF REF REF BOOL x4,
+            REF REF REF REF REF REF CHAR x5,
+            REF REF PROC VOID x6;
+            SKIP
+      END;
+
+      # proc  #
+      BEGIN PROC VOID x1,
+            PROC PROC REAL x2,
+            PROC PROC PROC PROC LONG REAL x3,
+            PROC PROC PROC PROC PROC BOOL x4,
+            PROC PROC PROC PROC PROC PROC CHAR x5,
+            PROC PROC PROC VOID x6;
+            SKIP
+      END;
+
+      # ref + proc  #
+      BEGIN REF REF REF REF REF REF PROC VOID x1,
+            PROC REF REAL x2,
+            PROC REF PROC REF LONG REAL x3,
+            PROC REF PROC REF PROC BOOL x4,
+            REF PROC REF PROC REF PROC CHAR x5,
+            PROC REF PROC VOID x6;
+            SKIP
+      END;
+
+      # proc with one parameter which is primitive or ref + primitive  #
+      BEGIN PROC(INT)VOID x1,
+            PROC(REF REF REF LONG INT)VOID x2,
+            PROC(BOOL)VOID x3,
+            PROC(REF CHAR)VOID x4,
+            PROC(LONG REAL)VOID x5,
+            PROC(REF REF REF BOOL)VOID x6,
+            PROC(PROC VOID)VOID x7,
+            PROC(REF REF PROC VOID)VOID x8;
+            SKIP
+      END;
+
+      # ref + proc with one parameter which is primitive or ref + primitive  #
+      BEGIN REF PROC(INT)VOID x1,
+            REF REF PROC(LONG REAL)VOID x2, x3,
+            REF REF REF REF PROC(REF CHAR)VOID x4,
+            REF PROC(PROC VOID)VOID x5,
+            REF REF PROC(REF PROC VOID)VOID x6;
+            SKIP
+      END;
+
+      # ref * proc with more than one parameter which are ref * primitive  #
+      BEGIN PROC(INT,LONG INT)VOID x1,
+            PROC(REAL,REF LONG REAL,REF REF BOOL)VOID x2,
+            PROC(REF REF REF CHAR,INT,LONG INT,REAL,REAL,INT)VOID x3,
+            REF PROC(INT,INT,INT,REF CHAR)VOID x4,
+            REF REF REF PROC(PROC VOID,REF REF PROC VOID,INT)VOID x5;
+            SKIP
+      END;
+
+      # ref + row of * ref * primitive  #
+      BEGIN REF[]INT x1,
+            REF[,]REAL x2,
+            REF REF[,,,]LONG REAL x3,
+            REF REF REF[,,,,,]REF BOOL x4,
+            REF[]REF REF REF LONG INT x5,
+            REF REF[,,,,]REF REF CHAR x6,
+            REF[]PROC VOID x7,
+            REF[,]REF REF PROC VOID x8;
+            SKIP
+      END;
+
+      # ref + row of * ref * proc  #
+      BEGIN REF[] PROC VOID x1,
+            REF REF[,] PROC(REF INT)VOID x2,
+            REF REF REF[]PROC(INT, REF REF INT)VOID x3,
+            REF[]REF PROC(REF LONG REAL, REF REF REF CHAR, REF LONG LONG REAL)VOID x4,
+            REF REF[,,,]REF REF REF PROC(REF INT, LONG LONG LONG INT)VOID x5;
+            REF[]PROC(PROC VOID,REF PROC VOID)VOID x6;
+            SKIP
+      END;
+
+      # ref * proc with row of parameters  #
+      BEGIN PROC([]REAL)VOID x1,
+            REF PROC(INT, []LONG REAL)VOID x2,
+            REF REF PROC([,]INT, []REF REF BOOL)VOID x3,
+            REF REF REF REF PROC(REF[]INT, REF REF[]REF REF LONG REAL)VOID x4,
+            PROC(REF REF[,,,]REF REF REF REAL)VOID x5,
+            PROC([]REF REAL, [,,,]REF CHAR, REF[,]BOOL)VOID x6,
+            PROC([]REF PROC VOID, REF[,,]PROC VOID, REF REF[,]REF REF PROC VOID)VOID x7;
+            SKIP
+      END;
+
+      # nested rows  #
+      BEGIN REF[,,,]REF[,]INT x1,
+            REF[]REF[]PROC VOID x2,
+            REF[]REF REF[]REF BOOL x3,
+            REF[,,,]REF[,,,]REF REF REF PROC VOID x4,
+            REF REF[]REF[]INT x5,
+            REF[]REF[]REF[]REF[]REF[]LONG REAL x6;
+            SKIP
+      END;
+
+      # nested procs  #
+      BEGIN PROC(PROC(PROC (PROC VOID)VOID)VOID)VOID x1,
+            PROC(INT,
+                 PROC(REF REF PROC VOID,
+                      REAL,
+                      REF PROC(REF LONG INT, PROC VOID)VOID,
+                      INT) VOID)VOID x2,
+            PROC(INT,
+                 PROC VOID,
+                 PROC (INT,
+                       PROC VOID,
+                       REF REAL,
+                       REF PROC VOID)VOID)VOID x3,
+            PROC(INT,
+                 PROC (INT,INT) VOID,
+                 PROC (INT) VOID,
+                 REAL)VOID x4;
+            SKIP
+      END;
+
+      # mixed rows and procs  #
+      BEGIN REF[]PROC([,]INT,PROC([]PROC VOID) VOID,
+                      [,] PROC(PROC VOID, INT) VOID,
+                      REF[]PROC VOID)VOID x1;
+            SKIP
+      END;
+
+      # 1.b. With bounds.  #
+      BEGIN [1:1]INT x1,
+            [1:1,1:1]REF LONG REAL x2,
+            [1:1,1:1,1:1]REF REF PROC VOID x3,
+            [1:1]PROC VOID x4,
+            [1:1]PROC(INT)VOID x5,
+            [1:1]PROC(INT,REAL,REF PROC VOID)VOID x6,
+            [1:1,1:1,1:1,1:1]REF REF PROC(INT)VOID x7,
+            [1:1]REF[]INT x8,
+            [1:1]REF[,,,]REF PROC VOID x9,
+            [1:1]REF PROC([]INT)VOID x10,
+            [1:1]PROC([]REF PROC VOID, REF[,,]PROC VOID,
+                      REF REF REF REF[,]REF REF REF PROC VOID)VOID x11,
+            [1:1]REF[]REF[,,]REF REF[]LONG REAL x12,
+            [1:1]PROC(REF[]PROC VOID, []PROC VOID, []REF INT)VOID x13;
+            SKIP
+      END;
+
+      # 2. Variable and constant declarations.  #
+
+      BEGIN PROC VOID a; PROC(INT)VOID b;
+            PROC VOID c, d; REAL e; REAL f, g;
+            SKIP; SKIP; SKIP; SKIP
+      END;
+
+      # 3. Declarations of routines.  #
+
+      BEGIN INT i;
+            PROC a = VOID: SKIP;
+            PROC(INT)VOID b = (INT c) VOID: SKIP;
+            PROC(INT,REAL)VOID c = (INT e, REAL f) VOID: SKIP;
+            BEGIN PROC c = VOID: a; # no error  # SKIP END
+      END;
+
+      # 4. Call without parameters.  #
+
+      BEGIN PROC VOID a = VOID: SKIP;
+            PROC VOID b := a;
+            REF PROC VOID c := b;
+            REF REF PROC VOID d = c;
+
+            a; # without deref  #
+            b; # with deref  #
+            c; # with deref  #
+            d; # with deref  #
+
+            SKIP
+      END;
+
+      # 5. Call with parameters.  #
+      BEGIN INT int; REAL real;
+            PROC(INT)VOID dcs1,
+            PROC(INT,REAL)VOID dcs2;
+            PROC(INT)VOID a = (INT a) VOID: SKIP;
+            PROC(INT)VOID b;
+            REF PROC(INT)VOID c = b;
+            REF PROC(INT)VOID d;
+            PROC(INT,REAL)VOID e = (INT a, REAL b) VOID: SKIP;
+
+            a (int);
+            dcs1 (int);
+            dcs2 (int, real);
+            e (int, real);
+            b (int);
+            c (int);
+            d (int);
+            BEGIN REF REF REF REF REF REF REF REF REF REF
+                  REF REF REF REF REF REF REF REF REF REF
+                  PROC(INT)VOID a; a (int); SKIP
+            END;
+            BEGIN # No error  #
+               PROC(REF INT, REF REAL)VOID a;
+               a (int, real)
+            END;
+
+            BEGIN PROC(INT)VOID a; a (int) END;
+            BEGIN PROC(INT)VOID a; a (int); SKIP END
+      END;
+
+      # 6. Assignation with an identifier as destination.  #
+
+      BEGIN INT a; REF INT b = a; PROC(REAL)REAL c;
+            a := 1;
+            b := a;
+         CO   c := sin; XXX CO
+            SKIP
+      END;
+
+      # 7. Assignation with a slice as destination.  #
+
+      BEGIN INT i, j, k, l;
+            [i:i]REAL a1;
+            [i:i,j:j]REAL a2;
+            REF[]REAL a3 = a1;
+            REF[,]REAL a4;
+            REF[,,]REAL a5 = a4;
+            [,,,]REF REAL a6 = a3[i];
+
+            a1[i] := 3;
+            a2[i,j] := 3;
+            a3[i] := 3;
+            a4[i,j] := 3;
+            a5[i,j,k] := 3;
+            a6[i,j,k,l] := 3;
+            BEGIN REF REF REF REF REF REF REF REF REF REF
+                  REF REF REF REF REF REF REF REF REF REF
+                  []REAL x;
+                  x[i] := 3.0
+            END
+      END
+END
diff --git a/gcc/testsuite/algol68/compile/mcts/idef10.a68 b/gcc/testsuite/algol68/compile/mcts/idef10.a68
new file mode 100644
index 00000000000..b195923ec58
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/idef10.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN INT count := 0;
+      FOR i FROM 1 BY i DO count +:= 1 OD; # { dg-error "" }  #
+      ASSERT (count = 0)
+END
diff --git a/gcc/testsuite/algol68/compile/mcts/mdeq01.a68 b/gcc/testsuite/algol68/compile/mcts/mdeq01.a68
new file mode 100644
index 00000000000..4e297abf4c2
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/mdeq01.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Mode equivalencing.  #
+BEGIN MODE N = UNION(STRUCT(REAL re, im), COMPL); # { dg-error "" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/mcts/mdeq03.a68 b/gcc/testsuite/algol68/compile/mcts/mdeq03.a68
new file mode 100644
index 00000000000..eb607cc1792
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/mdeq03.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Mode equivalencing.  #
+BEGIN MODE M = PROC(M)M,
+           N = PROC(N)N,
+           O = UNION(N,M); # { dg-error "" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/mcts/mdeq05.a68 b/gcc/testsuite/algol68/compile/mcts/mdeq05.a68
new file mode 100644
index 00000000000..499a3925620
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/mdeq05.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Mode equivalencing.  #
+BEGIN MODE N = UNION (BYTES, BITS, REF BITS); # { dg-error "" }  #
+      MODE SZEREDI = UNION (INT,REAL,REF UNION (INT, REAL)); # { dg-error "" }  #
+      # Szeredi - ambiguity.  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/mcts/mdeq06.a68 b/gcc/testsuite/algol68/compile/mcts/mdeq06.a68
new file mode 100644
index 00000000000..b2472b18d78
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/mdeq06.a68
@@ -0,0 +1,18 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Some equivalencing.  #
+BEGIN MODE A = STRUCT (REF A l, REF A r),
+           B = STRUCT (REF B l, REF B r),
+           C = STRUCT (REF D l, REF E r),
+           D = STRUCT (REF E l, REF C r),
+           E = STRUCT (REF C l, REF D r),
+           F = STRUCT (REF STRUCT (REF A l, REF B r) l,
+                       REF STRUCT (REF STRUCT (REF C l, REF D r) l,
+                                   REF STRUCT (REF E l, REF F r) r
+                                  ) r
+                      );
+
+      # error - all modes are the same  #
+      MODE M = UNION (A,B,C,D,E,F); # { dg-error "" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/mcts/oper05.a68 b/gcc/testsuite/algol68/compile/mcts/oper05.a68
new file mode 100644
index 00000000000..ab3a9c811b1
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/oper05.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Operator test, mutual recursion.  #
+BEGIN PRIO +>=1, +<=1;
+      OP +> = (INT a, b) INT: a+<b;
+      OP +< = (INT a, b) INT: a+>b;
+      1+>2
+END
diff --git a/gcc/testsuite/algol68/compile/mcts/oper06.a68 b/gcc/testsuite/algol68/compile/mcts/oper06.a68
new file mode 100644
index 00000000000..ddaf3c05ae6
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/oper06.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN OP + = (REAL a, b) REAL: a - b; # { dg-error "" } #
+      OP + = (REF REAL a, b) REAL: a - b; # { dg-error "" } #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/mcts/oper12.a68 b/gcc/testsuite/algol68/compile/mcts/oper12.a68
new file mode 100644
index 00000000000..7651ea4edf8
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/oper12.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Operator test, illegal operator.  #
+BEGIN OP   += = (INT a) INT: -a;
+      OP  +:= = (INT a) INT: -a;
+      OP -/:= = (INT a) INT: -a;
+      OP +==: = (INT a) INT: -a;
+
+      # Correct version.  #
+      +=+:=-/:=+==:+==:+=+:=+==:1;
+      # Bad version.  #
+      +=+:=-/:=+==:+==+=+:=+==:=1 # { dg-error "" }  #
+END
diff --git a/gcc/testsuite/algol68/compile/mcts/oper15.a68 b/gcc/testsuite/algol68/compile/mcts/oper15.a68
new file mode 100644
index 00000000000..24d03c7ca17
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcts/oper15.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Incorrect, since not all declarers are of the mode row-of  #
+BEGIN UPB UNION ([]INT,BOOL) ([]INT (1)); # { dg-error "" }  #
+      LWB UNION (REF[,]STRING,STRING) ("ab"); # { dg-error "" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/clau02.a68 b/gcc/testsuite/algol68/execute/mcts/clau02.a68
new file mode 100644
index 00000000000..04f0359d8b3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/clau02.a68
@@ -0,0 +1,23 @@
+{ Case conformity.  }
+begin mode M = union ([]int, bool, string);
+      proc prpm = ref proc M: heap proc M := M: "aap ";
+
+      int control := 0;
+      for n to 4
+      do case case n
+              in true,
+                 if false then "aa" else "b " fi,
+                 prpm { Gets deprocedured twice to yield a string.  }
+              out loc[1:1]int := 1 { Gets dereferenced then copied.  }
+              esac
+         in (union(string, bool) sb):
+               (control +:= 1;
+                (sb | (bool b): assert (b), (string s): assert (s = "b " OR s = "aap "))),
+            ([]int i):
+               (control +:= 1;
+                assert (i[1] = 1))
+         out assert (false)
+         esac
+      od;
+      assert (control = 4)
+end
diff --git a/gcc/testsuite/algol68/execute/mcts/clau04.a68 b/gcc/testsuite/algol68/execute/mcts/clau04.a68
new file mode 100644
index 00000000000..7889b0a13e8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/clau04.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+# Vacuum.  #
+BEGIN ASSERT (LWB []INT BEGIN END = 1);
+      ASSERT (UPB []INT() = 0);
+      CO XXX trimmer ASSERT (UPB([]INT())[1:0] = 0); CO
+      ASSERT (2UPB[,]INT([]INT(puts("here");())) = 0);
+      ASSERT (1UPB[,]INT([]INT(puts("there");())) = 1);
+      ASSERT (2UPB[,]INT(()) = 0);
+      CO runtime error: wrong length CO
+      CO 2UPB[,]INT((),(1)) CO
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/clau05.a68 b/gcc/testsuite/algol68/execute/mcts/clau05.a68
new file mode 100644
index 00000000000..0fde17b7e75
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/clau05.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+# Test vaccum as string.  #
+BEGIN PROC p = (STRING s) VOID:
+      BEGIN ASSERT (LWB s = 1);
+            ASSERT (UPB s = 0)
+      END;
+
+      p ("");
+      p (());
+      p (BEGIN END)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/clau07.a68 b/gcc/testsuite/algol68/execute/mcts/clau07.a68
new file mode 100644
index 00000000000..f29c06428b3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/clau07.a68
@@ -0,0 +1,21 @@
+# { dg-options "-fstropping=upper" }  #
+# If-, case- and ucase-clauses.  #
+BEGIN FOR i
+      DO (i = 1 | 1 |: i = 2 | 2 |: i = 3 | 3 | eo if) OD;
+eo if:
+
+      FOR i
+      DO (i | 4, 5 |: i - 2 | 6, 7 | eo case) OD;
+eo case:
+
+      FOR i
+      DO ( (UNION (INT,REAL,CHAR,STRING,BOOL)
+            (i | 1, 1.0, "a", "", TRUE)
+           | (INT): 8, (REAL): 9
+           |: UNION (CHAR,STRING,BOOL) (i - 2 | "a", "", TRUE)
+           | (CHAR): 10, (STRING): 11
+           | eo ucase) )
+      OD;
+eo ucase:
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/clau08.a68 b/gcc/testsuite/algol68/execute/mcts/clau08.a68
new file mode 100644
index 00000000000..5002140e821
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/clau08.a68
@@ -0,0 +1,159 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN  stop;   # no errors, but loops if not stopped here #
+
+# A:  Statements in the context of a BEGIN block #
+
+BEGIN  label : SKIP;
+        l1:BEGIN SKIP; SKIP END;
+
+        BEGIN GOTO label; GO TO label END;
+
+        BEGIN INT a1, a2, a3;
+        l4:FOR i FROM a1BY a2TO a3 DO SKIP OD;
+        FOR i FROM a1BY a2TO a3 DO SKIP OD
+        END;
+
+        l2:BEGIN BOOL a;
+            IF a THEN SKIP FI;
+            l5:IF a THEN SKIP FI
+        END;
+
+        BEGIN PROC VOID a; l6: a; a END;
+
+        l3 : BEGIN PROC (INT) VOID a; INT b;
+            a(b); l7 : a(b)
+        END;
+
+        BEGIN REAL a; a:= a; a:= a END;
+
+        BEGIN REF[]REAL a; INT i;
+            l8 : a[i]:=i; a[i]:=i
+        END;
+
+        BEGIN BEGIN SKIP END;
+            BEGIN SKIP END
+        END
+END;
+
+# B:  Statements in the context of a ( block #
+
+(  label : SKIP;
+        l1:( SKIP; SKIP );
+
+        ( GOTO label; GO TO label );
+
+        ( INT a1, a2, a3;
+        l4:FOR i FROM a1BY a2TO a3 DO SKIP OD;
+        FOR i FROM a1BY a2TO a3 DO SKIP OD
+        );
+
+        l2:( BOOL a;
+            IF a THEN SKIP FI;
+            l5:IF a THEN SKIP FI
+        );
+
+        ( PROC VOID a; l6: a; a );
+
+        l3 : ( PROC (INT) VOID a; INT b;
+            a(b); l7 : a(b)
+        );
+
+        ( REAL a; a:= a; a:= a );
+
+        ( REF[]REAL a; INT i;
+            l8 : a[i]:=i; a[i]:=i
+        );
+
+        ( ( SKIP );
+            ( SKIP )
+        )
+);
+
+# C:  Statements in the context of IF statement #
+
+BEGIN BOOL true;
+
+    IF true THEN SKIP; SKIP FI;
+
+    IF true THEN SKIP ELSE SKIP; SKIP FI;
+
+    IF true THEN IF true THEN SKIP FI
+            FI;
+
+    IF true THEN IF true THEN SKIP FI
+            ELSE SKIP FI;
+
+    IF true THEN IF true THEN SKIP ELSE SKIP FI
+            FI;
+
+    IF true THEN IF true THEN SKIP ELSE SKIP FI
+            ELSE SKIP FI;
+
+    IF true THEN SKIP
+            ELSE IF true THEN SKIP FI
+            FI;
+
+    IF true THEN SKIP
+            ELSE IF true THEN SKIP ELSE SKIP FI;
+                IF true THEN SKIP FI; SKIP
+            FI
+
+END;
+
+# D:  Statements in the context of a FOR statement #
+
+BEGIN INT a1, a2, a3; BOOL true;
+        PROC VOID proc1; PROC (INT) VOID proc2;
+        REAL aa; REF[]REAL bb;
+
+    FOR i FROM a1 BY a2 TO a3
+            DO SKIP; SKIP OD;
+
+    FOR i FROM a1 BY a2 TO a3
+            DO GOTO stop; GOTO stop OD;
+
+    FOR i FROM a1 BY a2 TO a3
+            DO IF true THEN SKIP FI;
+            IF true THEN SKIP FI OD;
+
+    FOR i FROM a1 BY a2 TO a3
+        DO FOR i FROM a1 BY a2 TO a3
+                DO SKIP OD;
+            FOR i FROM a1 BY a2 TO a3
+                DO SKIP OD OD;
+
+    FOR i FROM a1 BY a2 TO a3
+            DO proc1; proc1 OD;
+
+    FOR i FROM a1 BY a2 TO a3
+            DO proc2(a1); proc2(a1) OD;
+
+    FOR i FROM a1 BY a2 TO a3
+            DO aa := aa; aa := aa OD;
+
+    FOR i FROM a1 BY a2 TO a3
+            DO bb [i] := a1; bb[i] := a1 OD;
+
+    FOR i FROM a1 BY a2 TO a3
+            DO BEGIN SKIP END;
+                BEGIN SKIP END OD
+
+END;
+
+# E:  Statements in the context of a routine declaration #
+
+BEGIN BOOL true; INT a1, a2, a3;
+        REF[]INT a4 = a1; REAL a5;
+    PROC a = VOID:SKIP;
+    PROC b = VOID: IF TRUE THEN SKIP FI;
+    PROC c = VOID: FOR i FROM a1 BY a2 TO a3 DO SKIP
+                OD;
+    PROC d = VOID: d;
+    PROC (INT) VOID e = (INT f) VOID: e(f);
+    PROC f = VOID: a5:=a5;
+    PROC g = VOID: a4[a1] := a1;
+    PROC h = VOID: BEGIN SKIP END;
+
+    SKIP
+END
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/clau09.a68 b/gcc/testsuite/algol68/execute/mcts/clau09.a68
new file mode 100644
index 00000000000..be5ee4fbf77
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/clau09.a68
@@ -0,0 +1,82 @@
+# { dg-options "-fstropping=upper" }  #
+# Optimisation correct?  #
+BEGIN
+      PROC itoa = (INT i) STRING:
+      BEGIN IF i = 0
+            THEN "0"
+            ELSE INT n := i;
+                 STRING res := (i < 0 | n := -n; "-");
+                 WHILE n /= 0
+                 DO INT rem = n %* 10;
+                    res +:= REPR (rem > 9 | (rem - 10) + ABS "a" | rem + ABS "0");
+                    n %:= 10
+                 OD;
+                 res
+            FI
+      END;
+   
+    puts("\nPrints errors only\n");
+
+    PROC puti = (INT i, INT p, q) VOID:
+    IF p /= q THEN puts (itoa (i) + "," + itoa (p) + "," + itoa (q)) FI;
+
+    PROC putr = (INT i, REAL p, q) VOID:
+    IF p /= q THEN puts (itoa (i) + ", p /= q") FI;
+
+BEGIN
+    [1:3]INT a;
+    a[1]:=2; a[2]:=3; a[3]:=1;
+    putr(1, 44.9104,
+        (-1.0+(-2.0+(-3.0+(-4.0+2))))
+        +(
+        (-5.0+(-2.0-(-5.0+(-2.0-7))))
+        -(
+        a[a[a[a[a[2]]]]]
+        +(
+        a[a[a[a[a[1]]]]]
+        -(
+        a[a[a[a[a[3]]]]]
+        + (
+        (-1.0*(-2.0*(-3.0*(-4.0*2))))
+        -  (
+        (-5.0*(-2.0*(-5.0*(-2.0*7))))
+        *     (
+    128*(-1.0/(-2.0/(-4.0/(-4.0/2))))
+        /    (
+        (-10.0/(-5.0/(-5.0/(-2.0/2))))
+        **
+        a[a[a[a[a[2]]]]]
+        **
+        a[a[a[a[a[1]]]]]
+        **
+        a[a[a[a[a[3]]]]]
+        ))))))))
+    )
+END;
+
+BEGIN REAL x; [1:20]REAL a;
+    FOR i FROM 1 BY 1 TO 20
+    DO a[i] := i-10 OD;
+    x := a[1]+(a[2]+(a[3]+(a[4]+(a[5]+(a[6]+(a[7]+(a[8]+(a[9]+
+        (a[10]+(a[11]+(a[12]+(a[13]+(a[14]+(a[15]+(a[16]+
+        (a[17]+(a[18]+(a[19]+(a[20])))))))))))))))))))-9.0;
+    putr(2, 1.0, x)
+END;
+
+BEGIN
+
+    [1:10]INT a;
+
+    FOR i FROM 1 BY 1 TO 9 DO a[i]:=i+1 OD;
+    a[10]:=1;
+
+    FOR i FROM 1 BY 1 TO 10
+    DO puti(3, i, a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[a[i
+            ]]]]]]]]]]]]]]]]]]]]
+        )
+    OD
+END;
+
+    puts ("\nEnd of tests\n");
+END
+
diff --git a/gcc/testsuite/algol68/execute/mcts/coer01.a68 b/gcc/testsuite/algol68/execute/mcts/coer01.a68
new file mode 100644
index 00000000000..f2f9535d52a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer01.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT ((REAL x := 0; REF[]REAL (x) := 1; x) = 1.0);
+      ASSERT ((INT n := 0; n +:= 1 := 5) = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/coer02.a68 b/gcc/testsuite/algol68/execute/mcts/coer02.a68
new file mode 100644
index 00000000000..98ac280a4dc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer02.a68
@@ -0,0 +1,20 @@
+# { dg-options "-fstropping=upper" }  #
+# Widening #
+BEGIN
+  FOR i TO 2 DO
+  ASSERT (
+    CASE i IN TRUE,     2r1    OUT []BOOL(TRUE) ESAC
+   [CASE i IN  1  , bits width OUT     SKIP     ESAC]
+    ) OD;                                    # TT #
+
+  INT n := 1;
+  ASSERT ((re OF CASE n IN 1, 2.0, 3 I 5 ESAC) = 1.0);
+  ASSERT ((im OF CASE n IN 1, 2.0, 3 I 5 ESAC) = 0.0);
+  n := 2;
+  ASSERT ((re OF CASE n IN 1, 2.0, 3 I 5 ESAC) = 2.0);
+  ASSERT ((im OF CASE n IN 1, 2.0, 3 I 5 ESAC) = 0.0);
+  n := 3;
+  ASSERT ((re OF CASE n IN 1, 2.0, 3 I 5 ESAC) = 3.0);
+  ASSERT ((im OF CASE n IN 1, 2.0, 3 I 5 ESAC) = 5.0)
+                                       # 1.0 0.0, 2.0 0.0, 3.0 5.0 #
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/coer03.a68 b/gcc/testsuite/algol68/execute/mcts/coer03.a68
new file mode 100644
index 00000000000..f39666b3335
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer03.a68
@@ -0,0 +1,53 @@
+# { dg-options "-fstropping=upper" }  #
+# Morf versus comorf.  #
+BEGIN BOOL canary := FALSE;
+      PROC right = VOID: canary := TRUE,
+           wrong = VOID: (ASSERT (FALSE)),
+           check = VOID: (ASSERT (canary); canary := FALSE);
+
+      PROC deproc = (STRING mcm) VOID:
+         (puts (mcm); puts ("deproc:"));
+      PROC nodeproc = (STRING mcm) VOID:
+         (puts (mcm); puts ("nodeproc:"));
+
+      deproc ("selection");
+      proc OF STRUCT(PROC VOID proc, INT d)(right, SKIP);
+      check;
+
+      deproc ("slice");
+      []PROC VOID(right)[1];
+      check;
+
+      deproc ("routine text");
+      PROC VOID: right;
+      check;
+
+      deproc ("formula");
+      OP + = (INT i) PROC VOID: right; +1;
+      check;
+
+      deproc ("call");
+      ((INT i) PROC VOID: right)(1);
+      check;
+
+      deproc ("identifier");
+      right;
+      check;
+
+      nodeproc ("assignation");
+      LOC PROC VOID := wrong;
+
+      nodeproc ("cast");
+      PROC VOID (wrong);
+
+      nodeproc ("generator");
+      LOC PROC VOID;
+
+      FOR i TO 2
+      DO IF i = 1
+         THEN deproc ("balance"); right
+         ELSE nodeproc ("balance"); PROC VOID(wrong)
+         FI;
+         IF i = 1 THEN check FI
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/coer07.a68 b/gcc/testsuite/algol68/execute/mcts/coer07.a68
new file mode 100644
index 00000000000..ad39fc30eb2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer07.a68
@@ -0,0 +1,14 @@
+# { dg-options "-fstropping=upper" }  #
+# Weak balance.  #
+BEGIN COMPL c := (COMPL x:=1;
+                  CASE 2
+                  IN NIL,
+                     IF [] BOOL (TRUE, FALSE)[2]
+                     THEN REF REF [] COMPL: NIL
+                     ELSE x
+                     FI,
+                     LOC PROC REF [] STRUCT (REAL re,im)
+                  ESAC # REF [] COMPL = x # [1]:=3; x);
+      ASSERT (re OF c = 3.0);
+      ASSERT (im OF c = 0.0)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/coer08.a68 b/gcc/testsuite/algol68/execute/mcts/coer08.a68
new file mode 100644
index 00000000000..4d6c7461249
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer08.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+# Soft balance.  #
+BEGIN ASSERT ((HEAP INT x := 314;
+               CASE 3
+               IN SKIP,
+                  IF x < 0 THEN GOTO stop ELSE REF[]INT: NIL FI,
+                  IF x > 0 THEN x ELSE x +:= 1 FI
+               ESAC := 200)[1] = 200)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/coer09.a68 b/gcc/testsuite/algol68/execute/mcts/coer09.a68
new file mode 100644
index 00000000000..4e1ab083c0c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer09.a68
@@ -0,0 +1,16 @@
+# { dg-options "-fstropping=upper" }  #
+# Soft balance.  #
+BEGIN ASSERT (CASE 2
+              IN SKIP,
+                 NIL,
+                 IF BOOL (SKIP)
+                 THEN GOTO stop
+                 ELSE PROC REF[]INT (SKIP)
+                 FI
+              ESAC :=: CASE 3
+                       IN LOC REF REF []INT,
+                          LOC INT,
+                          NIL
+                       ESAC)
+      # TRUE, would you believe.  #
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/coer10.a68 b/gcc/testsuite/algol68/execute/mcts/coer10.a68
new file mode 100644
index 00000000000..7cc60658146
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer10.a68
@@ -0,0 +1,62 @@
+# { dg-options "-fstropping=upper" }  #
+# Union with VOID #
+BEGIN OP TOPROCINT = (INT i) PROC INT : INT : 1;
+      OP TOVOID = (INT i) VOID : 1;
+
+      STRING proc int = "proc int", void = "void",
+             before = "before ", after = " after",
+             newline = "\n";
+
+      puts ("Results must be:" + newline +
+            void + newline +
+            proc int + after + " 1 " + newline +
+            before +  void + newline +
+            before + void + newline +
+            before + void + newline +
+            proc int + " 1 " + newline +
+            void + newline +
+            proc int + " 1 " + newline +
+            proc int + after + " 1 " + newline +
+            before + void + newline + 
+            newline + "Results are:" + newline);
+
+      UNION(PROC INT, VOID) upiv := EMPTY;
+      PROC pupiv = VOID:
+         (upiv
+             |(PROC INT pi) : (puts (proc int + " pi " + newline))
+             | puts (void + newline));
+
+      pupiv;
+      upiv:= INT : (puts(after); 1);
+      pupiv;
+
+      upiv:= VOID : (puts(before); 1);
+      pupiv;
+
+      upiv:= VOID ((puts(before); 1));
+      pupiv;
+
+      # firm void position #
+      upiv:= puts(before);
+      pupiv;
+
+      upiv:= TOPROCINT 1;
+      pupiv;
+
+      upiv:= TOVOID 1;
+      pupiv;
+
+      upiv:= INT : 1;
+      upiv:= label # must jump before assigning #; puts("Error 1");
+label:
+      pupiv;
+
+      FOR i TO 2
+      DO upiv:=
+            CASE i IN
+               INT : (puts(after); 1),
+               VOID : (puts(before); 1)
+            ESAC;
+         pupiv
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/coer11.a68 b/gcc/testsuite/algol68/execute/mcts/coer11.a68
new file mode 100644
index 00000000000..1fc3c7910ae
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer11.a68
@@ -0,0 +1,37 @@
+# { dg-options "-fstropping=upper" }  #
+# Contains all possible two-member coercion sequences.  #
+BEGIN UNION(INT, BOOL) ib:= 1;
+
+      []REAL(1);
+      []REAL(INT : 1);
+      []REAL(REAL : 1);
+
+      [,]COMPL (1);
+      [] [,]COMPL (LOC INT:= 1);
+      [] [,]COMPL ([]COMPL(1, 2));
+
+      [,,] [] BOOL (16 r f);
+      [,,] [] [,] BOOL (16 r f);
+      [,,] [] BOOL (BITS : 16 r f);
+      [,,] [] [,] BOOL (BITS : 16 r f);
+
+COMMENT XXX bytes pack not supported yet
+      [,] [] CHAR (bytes pack ("ab"));
+      [,] [] [,] CHAR (bytes pack ("ab"));
+      [,] [] CHAR (LOC BYTES:= bytes pack("ab"));
+      [,] [] [,] CHAR(LOC BYTES:= bytes pack("ab"));
+COMMENT
+      
+      REF[]INT(REF INT : HEAP INT:= 1);
+      REF[,]INT(REF[]INT : HEAP[1]INT:= 1);
+
+      UNION(INT, REAL, BOOL) (ib);
+      [] REF [] [,] [] [] INT
+          (LOC PROC REF INT:= REF INT : HEAP INT:= 1) [1];
+
+      []UNION(INT, REAL) (LOC INT:= 1) [1];
+      []UNION(INT, REAL) (REAL : 1) [1];
+      []UNION(INT, REAL, BOOL) (ib) [1];
+
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/coer13.a68 b/gcc/testsuite/algol68/execute/mcts/coer13.a68
new file mode 100644
index 00000000000..4ada6e39ae1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer13.a68
@@ -0,0 +1,19 @@
+# { dg-options "-fstropping=upper" }  #
+# Soft balance with EXIT's.  #
+BEGIN INT i; [ 1 : 1 ]INT ri, rj;
+      PROC pri = REF[]INT : rj;
+
+      FOR c TO 3
+      DO
+         ([]PROC VOID switch = ( lrri, li, lpri);
+          switch[c]; SKIP                        # hip #
+         EXIT lrri: LOC REF[]INT := ri           # deref #
+         EXIT li: i                              # row #
+         EXIT lpri: pri                          # deproc #
+         ) := c
+      OD;
+
+      ASSERT (ri[1] = 1);
+      ASSERT (i = 2);
+      ASSERT (pri[1] = 3)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/coer14.a68 b/gcc/testsuite/algol68/execute/mcts/coer14.a68
new file mode 100644
index 00000000000..13077b0402a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/coer14.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+# Rowing of NIL yields NIL.  #
+BEGIN ASSERT (REF[]INT(NIL) :=: REF INT(NIL))
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/decl01.a68 b/gcc/testsuite/algol68/execute/mcts/decl01.a68
new file mode 100644
index 00000000000..5027837bcfa
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/decl01.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Some declarers.  #
+BEGIN [1:10]INT i,
+      [1:10]STRUCT(REF[]INT i, BOOL j) k,
+      [1:10]STRUCT([1:10]INT i, BOOL j) l,
+      [1:10]REF[]INT p;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/decl03.a68 b/gcc/testsuite/algol68/execute/mcts/decl03.a68
new file mode 100644
index 00000000000..2364bf15124
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/decl03.a68
@@ -0,0 +1,40 @@
+# { dg-options "-fstropping=upper" }  #
+# P.G. Hibbard, Proc. Int. Conf. A68 III, Winnipeg, June 1974:
+  applied occurrence of mode-indication in actual-bounds
+  of its actual-declarer
+#
+BEGIN PROC itoa = (INT i) STRING:
+      BEGIN IF i = 0
+            THEN "0"
+            ELSE INT n := i;
+                 STRING res := (i < 0 | n := -n; "-");
+                 WHILE n /= 0
+                 DO INT rem = n %* 10;
+                    res +:= REPR (rem > 9 | (rem - 10) + ABS "a" | rem + ABS "0");
+                    n %:= 10
+                 OD;
+                 res
+            FI
+      END;
+
+      INT n := 4;
+      CHAR a := "a", b := "b", c := "c", d;
+
+      PROC swap = (REF CHAR c1, c2) VOID:
+         (d := c1; c1 := c2; c2 := d);
+
+      MODE HANOI =
+              [IF n > 0
+               THEN n -:= 1;
+                    swap (b, c);
+                    HANOI h1;
+                    swap (b, c);
+                    puts ("move " + itoa (LWB h1 + 1) + " from " + a + " to " + c);
+                    swap (a, b);
+                    HANOI h2;
+                    swap (a, b);
+                    n +:= 1
+               ELSE 0
+               FI : 1] INT;
+      LOC HANOI
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/decl04.a68 b/gcc/testsuite/algol68/execute/mcts/decl04.a68
new file mode 100644
index 00000000000..1fa36e0d70d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/decl04.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+(MODE U = UNION(INT,REAL);
+ LOC UNION(U) # no list needed  # u := 1; SKIP)
diff --git a/gcc/testsuite/algol68/execute/mcts/decl05.a68 b/gcc/testsuite/algol68/execute/mcts/decl05.a68
new file mode 100644
index 00000000000..84cc2b8424c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/decl05.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Application of a virtually useless mode.  #
+BEGIN puts ("Result should be ppp");
+      MODE P = PROC (P) P;
+      P p = (P p) P: (puts ("p"); p);
+      (p(p(p(p))))
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/execute.exp b/gcc/testsuite/algol68/execute/mcts/execute.exp
new file mode 100644
index 00000000000..f07333f483a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/execute.exp
@@ -0,0 +1,29 @@
+# Copyright (C) 2024 Free Software Foundation, Inc.
+
+# This program 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 of the License, or
+# (at your option) any later version.
+# 
+# This program 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/>.
+
+if $tracelevel then {
+    strace $tracelevel
+}
+
+load_lib algol68-torture.exp
+
+foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] {
+    # If we're only testing specific files and this isn't one of them, skip it.
+    if ![runtest_file_p $runtests $testcase] then {
+	continue
+    }
+    algol68-torture-execute $testcase
+}
diff --git a/gcc/testsuite/algol68/execute/mcts/flex01.a68 b/gcc/testsuite/algol68/execute/mcts/flex01.a68
new file mode 100644
index 00000000000..359fc3cd7c8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/flex01.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN MODE S = FLEX[1:0]CHAR, T = [1:0]CHAR;
+      REF STRING n = LOC STRING := "Next line will be empty, then a";
+      UNION (REF S, REF T) f = LOC T := "";
+      UNION (STRING, CHAR) u = UNION (S,CHAR) ("a");
+
+      puts (n);
+      puts ((f | (REF S s): s, (REF T t): t));
+      puts ((u | (STRING s): s, (CHAR c): c))
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/flex02.a68 b/gcc/testsuite/algol68/execute/mcts/flex02.a68
new file mode 100644
index 00000000000..ced08bbcbad
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/flex02.a68
@@ -0,0 +1,11 @@
+{ Transiency tests.  }
+begin bool b = true, y = false;
+
+      assert ((if b then loc char else (loc string)[1] fi := "a")
+              = "a");
+      assert ((if b then loc[1:3]char else (loc string)[] fi := "bcd")
+              = "bcd");
+      { XXX original says loc string but parser doesn't like it.
+        probably parser bug }
+      if y then loc char else loc[1:1,1:3]char fi := "efg"
+end
diff --git a/gcc/testsuite/algol68/execute/mcts/idef01.a68 b/gcc/testsuite/algol68/execute/mcts/idef01.a68
new file mode 100644
index 00000000000..b94a136c6ff
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idef01.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN IF INT i := 1; FALSE
+      THEN INT i := 2; ASSERT (i = 2)
+      ELSE ASSERT (i = 1)
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/idef02.a68 b/gcc/testsuite/algol68/execute/mcts/idef02.a68
new file mode 100644
index 00000000000..80d0a1d2d1d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idef02.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN IF INT i := 1; TRUE
+      THEN INT i := 2; ASSERT (i = 2)
+      ELSE ASSERT (i = 1)
+      FI
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/idef03.a68 b/gcc/testsuite/algol68/execute/mcts/idef03.a68
new file mode 100644
index 00000000000..9825a274129
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idef03.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i = 1;
+
+      PROC a = INT: (INT i = 2; b);
+      PROC b = INT: i;
+      ASSERT (a = 1)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/idef04.a68 b/gcc/testsuite/algol68/execute/mcts/idef04.a68
new file mode 100644
index 00000000000..ce92b72eccc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idef04.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 1, j := -1;
+
+      PROC a = VOID: (INT i = 2, j = -2; b);
+      PROC b = VOID: (INT j = -3;
+                      PROC c = VOID: (ASSERT (i + j = -2));
+                      d (c));
+      PROC d = (PROC VOID e) VOID:
+         (INT i = 4, j = -4; e);
+      a
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/idef05.a68 b/gcc/testsuite/algol68/execute/mcts/idef05.a68
new file mode 100644
index 00000000000..98ada10bbec
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idef05.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 2;
+      (INT i = i; ASSERT (i = 0))
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/idef06.a68 b/gcc/testsuite/algol68/execute/mcts/idef06.a68
new file mode 100644
index 00000000000..aff65b42c6a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idef06.a68
@@ -0,0 +1,23 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRING int = "INT", real = "REAL", rreal = "[]REAL";
+
+      OP AA = (UNION(INT,REAL,[]REAL) p) UNION(REAL,[]REAL):
+         CASE p
+         IN (INT i): AA REAL (i),
+            (REAL r): AA []REAL (r)
+         OUSE p
+         IN ([]REAL rr): CASE ROUND rr[1] IN 3.0, rr OUT 4.0 ESAC
+         OUT error
+         ESAC;
+
+      FOR i TO 3
+      DO AA AA CASE i
+               IN UNION(REAL,INT)(1),
+                  UNION(INT,[]REAL)([]REAL(2)),
+                  AA 3
+               ESAC
+      OD;
+      0 EXIT
+error:
+     puts ("Error in united-case clause");
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/idef07.a68 b/gcc/testsuite/algol68/execute/mcts/idef07.a68
new file mode 100644
index 00000000000..4a51f344f87
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idef07.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Redeclaring LWB.  #
+BEGIN OP LWB = ([]INT a) REAL: a[1] + a[2];
+      OP LWB = ([]REAL a) REAL: a[1] - a[2];
+
+      ASSERT (LWB (1| (8, 2), 3, []INT: SKIP) = 10);
+      ASSERT (LWB (1| (8, 2), 3, []REAL: SKIP) = 6.0)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/idef11.a68 b/gcc/testsuite/algol68/execute/mcts/idef11.a68
new file mode 100644
index 00000000000..71b7d994063
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idef11.a68
@@ -0,0 +1,17 @@
+# { dg-options "-fstropping=upper" }  #
+# More operators and uniting.  #
+BEGIN MODE UN = UNION (INT, REAL);
+      OP + = (UNION (REF UN, REF CHAR) a) VOID:
+      BEGIN CASE a
+            IN (REF UN ru): (ru |
+                             (INT i): (puts ("integer"); SKIP),
+                             (REAL r): (puts ("real"); SKIP)
+                            ),
+               (REF CHAR ch): (puts ("char"); SKIP)
+            ESAC
+      END;
+
+      +(HEAP UN := 1);
+      +(HEAP UN := 2.0);
+      +(HEAP CHAR := "3")
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/idef12.a68 b/gcc/testsuite/algol68/execute/mcts/idef12.a68
new file mode 100644
index 00000000000..e77ec3f64c6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idef12.a68
@@ -0,0 +1,52 @@
+# { dg-options "-fstropping=upper" }  #
+# Priorities and weird constructions #
+BEGIN
+WHILE INT n:= 0;
+    OP + = (REF INT i, CHAR c) STRING: "ab";
+  ( WHILE DO GOTO skip OD; TRUE DO SKIP OD;
+    PRIO + = 1; SKIP
+    EXIT skid:
+        (HEAP INT +:= 1 + "1" +=: (HEAP STRING := "c")) = "abc"
+    EXIT skip: GOTO skid
+  )
+DO DO
+    # The implicit structure of the formulas is
+            ( a O1 ( b + ( c O2 d)))
+      which is only achieved if   pr(O1) < pr(+) < pr(O2)
+    #
+
+    PRIO + = 2;
+
+    OP + = (INT i, BOOL b) STRING: (puts("corr"); "ect,");
+    OP + = (REAL x, BOOL b) BOOL: (puts("Line "); FALSE);
+    OP + = (CHAR c, BOOL b) BOOL: (puts("two "); FALSE);
+    OP + = (BITS b, INT i) STRING: (puts("one "); "Nope ");
+    OP + = (REF BYTES b, REAL x) INT: (puts("is "); -(n+:=1));
+    OP + = (STRING s, COMPL c) BITS: (puts("sho"); drop);
+
+     puts((HEAP STRING +:=
+         ABS
+         IF PRIO + = 3;
+             ODD n OR 2.0 + "a" = "b"
+         THEN PRIO + = 4;
+             TRUE AND "a" + 2 < 3
+         ELSE PRIO + = 5;
+             "prio" = 2r1 + 2 - 3
+         FI
+
+         +              # prio 2 #
+
+         CASE PRIO + = 7;
+             0 - LOC BYTES + 3.0 ** 5
+         IN TRUE, FALSE
+         OUT PRIO + = 8;
+             3 ELEM "prio" + 2.0 I 3.0
+         ESAC
+
+         AND random < .5) + "\n")
+     OD
+     EXIT drop:
+         puts("rter than line three." + "\n" + "End of test");
+         stop
+OD
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/idrl01.a68 b/gcc/testsuite/algol68/execute/mcts/idrl01.a68
new file mode 100644
index 00000000000..0ef35335296
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/idrl01.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Identity relations.  #
+BEGIN REAL x; REF REAL y := x;
+      ASSERT ((x :=: y) AND (y :=: x));
+      ASSERT (x :=: REF[]REAL(x)[1]);
+      ASSERT (x :/=: REF[]REAL(x))
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/jump01.a68 b/gcc/testsuite/algol68/execute/mcts/jump01.a68
new file mode 100644
index 00000000000..5076300fecd
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/jump01.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+# Simple jumps and EXITs.  #
+BEGIN INT control := 0;
+      FOR i TO 2
+      DO IF i = 2 THEN GOTO l FI; control +:= 10 EXIT
+      l: control +:= 3
+      OD;
+      ASSERT (control = 13)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/jump02.a68 b/gcc/testsuite/algol68/execute/mcts/jump02.a68
new file mode 100644
index 00000000000..3c4e8809e04
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/jump02.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL a;
+      GOTO l;
+      INT i := 1;
+      # The declaration of `i' has not been elaborated.  #
+l:    ASSERT (i = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/jump03.a68 b/gcc/testsuite/algol68/execute/mcts/jump03.a68
new file mode 100644
index 00000000000..5a2fdea713c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/jump03.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT i := 1, j := 2;
+      i := j := (GOTO l; 3);
+l:    ASSERT (i = 1 AND j = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/jump04.a68 b/gcc/testsuite/algol68/execute/mcts/jump04.a68
new file mode 100644
index 00000000000..f6070123857
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/jump04.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+# Jump out of procedure.  #
+BEGIN # Directly  #
+      (PROC jump = VOID: (GOTO l; ASSERT (FALSE));
+       jump; ASSERT (FALSE);
+       l: SKIP);
+      # Indirectly  #
+      (MODE HIDE = PROC VOID;
+       HIDE p = (TRUE | GOTO m);
+       p; ASSERT (FALSE); m: SKIP)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/mdeq02.a68 b/gcc/testsuite/algol68/execute/mcts/mdeq02.a68
new file mode 100644
index 00000000000..6ed7d8bd260
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/mdeq02.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Mode equivalencing.  #
+BEGIN MODE N = PROC(M)M, M = PROC(N)N;
+      # Both okay, since M and N are the same.  #
+      PROC M(PROC N(SKIP));
+      PROC N(PROC M(SKIP));
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/mdeq04.a68 b/gcc/testsuite/algol68/execute/mcts/mdeq04.a68
new file mode 100644
index 00000000000..bb3c19f72ab
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/mdeq04.a68
@@ -0,0 +1,17 @@
+# { dg-options "-fstropping=upper" }  #
+# Unions.  #
+BEGIN MODE N = UNION (REAL, UNION (BOOL, INT)),
+           M = UNION (UNION (REAL, BOOL), INT);
+      # Both okay, since M and N are the same.  #
+      PROC M (PROC N (SKIP));
+      PROC N (PROC M (SKIP));
+
+      MODE U = UNION (INT, PROC(U)INT),
+           V = UNION (U, PROC(V)INT);
+      # Both okay, since U and V are the same.  #
+      PROC U (PROC V (SKIP));
+      PROC V (PROC U (SKIP));
+
+      SKIP
+END
+
diff --git a/gcc/testsuite/algol68/execute/mcts/misc07.a68 b/gcc/testsuite/algol68/execute/mcts/misc07.a68
new file mode 100644
index 00000000000..27d59ab743b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/misc07.a68
@@ -0,0 +1,207 @@
+# { dg-options "-fstropping=upper" }  #
+# 100 nested proc declarations; prints 100 100 #
+(INT i := 0; INT j := (INT a =
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+(PROC a = INT:
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+i+:=1; a);
+a);
+ASSERT (i = j);
+ASSERT (i = 100 AND j = 100)
+)
diff --git a/gcc/testsuite/algol68/execute/mcts/null01.a68 b/gcc/testsuite/algol68/execute/mcts/null01.a68
new file mode 100644
index 00000000000..a56a65109be
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/null01.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# The original test uses just SKIP, but this compiler requires an
+  enclosed clause.  #
+
+(SKIP)
diff --git a/gcc/testsuite/algol68/execute/mcts/null02.a68 b/gcc/testsuite/algol68/execute/mcts/null02.a68
new file mode 100644
index 00000000000..0b64d1cb178
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/null02.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+(0)
+
diff --git a/gcc/testsuite/algol68/execute/mcts/null03.a68 b/gcc/testsuite/algol68/execute/mcts/null03.a68
new file mode 100644
index 00000000000..8f31b578e56
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/null03.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN DO stop OD
+END
+
diff --git a/gcc/testsuite/algol68/execute/mcts/null04.a68 b/gcc/testsuite/algol68/execute/mcts/null04.a68
new file mode 100644
index 00000000000..39a7ed33f9f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/null04.a68
@@ -0,0 +1,2 @@
+# { dg-options "-fstropping=upper" }  #
+((SKIP,SKIP))
diff --git a/gcc/testsuite/algol68/execute/mcts/null05.a68 b/gcc/testsuite/algol68/execute/mcts/null05.a68
new file mode 100644
index 00000000000..44ed6f86423
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/null05.a68
@@ -0,0 +1,2 @@
+# { dg-options "-fstropping=upper" }  #
+(PAR (SKIP,SKIP))
diff --git a/gcc/testsuite/algol68/execute/mcts/null06.a68 b/gcc/testsuite/algol68/execute/mcts/null06.a68
new file mode 100644
index 00000000000..190379e6cd2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/null06.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN BY 0 DO stop OD
+END
+
diff --git a/gcc/testsuite/algol68/execute/mcts/null07.a68 b/gcc/testsuite/algol68/execute/mcts/null07.a68
new file mode 100644
index 00000000000..317c696c1c5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/null07.a68
@@ -0,0 +1,2 @@
+# { dg-options "-fstropping=upper" }  #
+IF BOOL (SKIP) THEN SKIP FI
diff --git a/gcc/testsuite/algol68/execute/mcts/null08.a68 b/gcc/testsuite/algol68/execute/mcts/null08.a68
new file mode 100644
index 00000000000..990f3aea39f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/null08.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+CASE INT(SKIP) IN SKIP, SKIP ESAC
+
diff --git a/gcc/testsuite/algol68/execute/mcts/null09.a68 b/gcc/testsuite/algol68/execute/mcts/null09.a68
new file mode 100644
index 00000000000..aba939a98d4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/null09.a68
@@ -0,0 +1,3 @@
+# { dg-options "-fstropping=upper" }  #
+CASE UNION(BOOL, VOID)(SKIP) IN (VOID): SKIP ESAC
+
diff --git a/gcc/testsuite/algol68/execute/mcts/numr07.a68 b/gcc/testsuite/algol68/execute/mcts/numr07.a68
new file mode 100644
index 00000000000..0c3b4ddb243
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/numr07.a68
@@ -0,0 +1,81 @@
+# { dg-options "-fstropping=upper" }  #
+#JKok, 730612, test Choleski decomposition#
+BEGIN OP * = ([]REAL a, b) REAL :
+         (REAL s:= 0; FOR i TO UPB a DO s +:= a[i] * b[i] OD;s);
+
+      PROC decsym= (REF [,] REAL a, REF [] INT p, REAL aux)
+            INT :
+         IF INT n = 1 UPB a;
+            2 UPB a /= n OR UPB p /= n THEN 0
+         ELSE REAL max:= 0, epsnorm, ukk, uki, aii, INT pk:= 1, r:= 0;
+
+              PROC ichvec= (REF [] REAL a, b) VOID :
+                 IF INT n= UPB a; n > 0 THEN
+                    [] REAL h= a; a:= b; b:= h
+                 FI # interchange two vectors#;
+
+              FOR k TO n
+              DO IF a[k,k] > max THEN max:= a[k,k]; pk:= k FI OD;
+              epsnorm:= aux * max;
+              FOR k TO n WHILE max > epsnorm
+              DO INT k1 = k + 1;
+                 p[k]:= pk; r:= k;
+                 IF pk /= k
+                 THEN ichvec(a[ :k-1,k], a[ :k-1,pk]);
+                      ichvec(a[k,k1:pk - 1], a[k1:pk - 1,pk]);
+                      ichvec(a[k,pk + 1: ], a[pk,pk + 1: ]);
+                      a[pk,pk]:= a[k,k]
+                 FI;
+                 ukk:= a[k,k]:= sqrt(max); max:= 0; pk:= k1;
+                 FOR i FROM k1 TO n
+                 DO uki:= a[k,i]:= (a[k,i] - a[ :k-1,k]*a[ :k-1,i]) / ukk;
+                    aii:= a[i,i] -:= uki * uki;
+                    IF aii > max THEN max:= aii; pk:= i FI
+                 OD
+              OD;
+              r
+         FI # Choleski decomposition with diagonal pivoting#,
+
+      PROC solsym= ([,] REAL a,[] INT p,REF [] REAL b) VOID:
+         IF INT n = 1 UPB a;
+            2 UPBa = n AND UPB p = n AND UPB b = n
+         THEN INT pk, REAL r;
+              FOR k TO n
+              DO r:= b[k]; pk:= p[k];
+                 b[k]:= (b[pk] - a[ :k - 1,k] * b[ :k - 1]) / a[k,k];
+                 IF pk /= k THEN b[pk]:= r FI
+              OD;
+              FOR k FROM n BY - 1 TO 1
+              DO b[k]:= (b[k] - a[k,k+1: ] * b[k+1: ]) / a[k,k] OD;
+              FOR k FROM n BY - 1 TO 1
+              DO IF pk:= p[k]; pk /= k
+                 THEN r:= b[k]; b[k]:= b[pk]; b[pk]:= r FI
+              OD
+         FI # solution of Choleski decomposed system #;
+
+      puts ("Value,  expected,  difference\n\n");
+
+      FOR n TO 8
+      DO [1:n, 1:n] REAL a, aa, [1:n]REAL b, c, [1:n]INT piv;
+         FOR i TO n DO FOR j TO n
+                       DO a[i,j]:= aa[i,j]:= 1 / (2 * n + 1 - i - j) OD OD;
+         FOR i TO n DO b[i]:= 2 ** (n - i) OD;
+         IF decsym (a, piv, 1e-13) = n
+         THEN solsym(a, piv, b);
+              FOR i TO n
+              DO
+                 CO puts (aa[i,] * b, REAL(2 ** (n - i)),
+                    aa[i,] * b - 2 ** (n - i));
+                 CO
+                 puts ("term\n")
+              OD
+         ELSE puts ("Coefficients matrix is not positive definite")
+         FI;
+         puts ("\n")
+     OD
+    #Output approximately: 1
+                           2  1
+                           4  2  1
+                           . . .
+                           128   64   . . .   1 #
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper01.a68 b/gcc/testsuite/algol68/execute/mcts/oper01.a68
new file mode 100644
index 00000000000..4fd76270e97
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper01.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Operator test.  #
+BEGIN OP +:= = (INT a, b) INT: a + b;
+      OP +:= = (INT a, REAL b) INT: ROUND (a - b);
+
+      ASSERT ((2+:=1) = 3);
+      ASSERT ((2+:=1.0) = 1)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper02.a68 b/gcc/testsuite/algol68/execute/mcts/oper02.a68
new file mode 100644
index 00000000000..f8ca85e356b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper02.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Operator and balancing.  #
+BEGIN OP + = (UNION(INT,BOOL) a) INT: (a|(BOOL):1,(INT):2);
+      ASSERT (+IF TRUE THEN TRUE ELSE 0 FI = 1);
+      ASSERT (+IF FALSE THEN TRUE ELSE 0 FI = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper03.a68 b/gcc/testsuite/algol68/execute/mcts/oper03.a68
new file mode 100644
index 00000000000..18af29408a6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper03.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+# Operator priorities.  #
+BEGIN PRIO + = 7;
+      ASSERT ((1+2*3) = 9);
+      BEGIN PRIO + = 6;
+            ASSERT ((1+2*3) = 7);
+            FOR i TO 1 WHILE PRIO + = 7; TRUE
+            DO ASSERT ((1+2*3) = 9); OD;
+            ASSERT ((1+2*3) = 7)
+      END;
+      ASSERT ((1+2*3) = 9)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper04.a68 b/gcc/testsuite/algol68/execute/mcts/oper04.a68
new file mode 100644
index 00000000000..0753a0da533
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper04.a68
@@ -0,0 +1,21 @@
+# { dg-options "-fstropping=upper" }  #
+# Operator identification.  #
+BEGIN MODE M = UNION ([]INT, BOOL, STRING);
+
+      OP + = (REAL a) INT: 2;
+      OP + = (CHAR a) INT: 3;
+      OP + = (M    a) INT: 1;
+
+      PROC prpm = REF PROC M: HEAP PROC M := M : "aap";
+      UNION (BOOL, STRING) b = "b ";
+
+      FOR n TO 5
+      DO ASSERT ((+ CASE n
+                    IN SKIP,
+                       TRUE,
+                       IF FALSE THEN "aa" ELSE b FI,
+                       prpm
+                    OUT LOC[1:1]INT := 1
+                    ESAC) = 1)
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper05.a68 b/gcc/testsuite/algol68/execute/mcts/oper05.a68
new file mode 100644
index 00000000000..1497b049997
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper05.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Operator test, mutual recursion.  #
+BEGIN PRIO +> = 1, +< = 1;
+      INT cnt := 0;
+      OP +> = (INT a, b) INT: IF (cnt +:= 1) = 10 THEN stop ELSE a +< b FI;
+      OP +< = (INT a, b) INT: IF (cnt +:= 1) = 10 THEN stop ELSE a +> b FI;
+      1 +> 2 # loop  #
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper07.a68 b/gcc/testsuite/algol68/execute/mcts/oper07.a68
new file mode 100644
index 00000000000..6533cf3fcee
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper07.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+# Operator declarations.  #
+BEGIN OP SQ = (REAL x) REAL: x * x,
+         RD = (INT x) REAL: random,
+      OP (REAL)REAL SIN = (puts ("Print ten times 1\n"); sin),
+                    COS  = cos;
+
+      puts ("\n");
+      TO 10
+      DO REAL x = RD 1; SQ SIN x + SQ COS x OD;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper08.a68 b/gcc/testsuite/algol68/execute/mcts/oper08.a68
new file mode 100644
index 00000000000..a14d742a177
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper08.a68
@@ -0,0 +1,18 @@
+# { dg-options "-fstropping=upper" }  #
+# A complicated formula relying totally on priorities.  #
+(
+  OP I= (INT i, j) COMPL : (i, j);
+  OP ** = (INT i, COMPL z) INT : ROUND(i + RE z + IM z);
+  OP <  = (INT i, j) INT : (i - j) * 2;
+  OP =  = (INT i, j) INT : (i + j) * 2;
+  OP AND= (INT i, j) INT : (i + i - j) * 3;
+  OP OR= (INT i, j) INT : (i - j - j) * 3;
+
+  INT loc int;
+  # Note: all operators are followed by their priorities #
+  ASSERT (((loc int := 0) -:= 1 OR 2 AND 3 = 4 < 5 + 6 * 7 ** 8 I 9
+          -:= 1 ** 8 OR 2 * 7 AND 3 + 6 = 4 < 5) EQ 10650)
+  # The implied parenthesis structure is :
+    (1(2(3(4(5(6(7(8(9)))))))))1((8)2((7)3((6)4(5))))
+    and it yields 10650 #
+)
diff --git a/gcc/testsuite/algol68/execute/mcts/oper09.a68 b/gcc/testsuite/algol68/execute/mcts/oper09.a68
new file mode 100644
index 00000000000..61b560dd408
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper09.a68
@@ -0,0 +1,65 @@
+# { dg-options "-fstropping=upper" }  #
+# Monadic operators, non-bold monads.  #
+BEGIN INT decls := 0;
+      OP    += (INT a) INT: a + 1; decls +:= 1;
+      OP   +<= (INT a) INT: a + 1; decls +:= 1;
+      OP   +>= (INT a) INT: a + 1; decls +:= 1;
+      OP   +/= (INT a) INT: a + 1; decls +:= 1;
+      OP   +== (INT a) INT: a + 1; decls +:= 1;
+      OP   +*= (INT a) INT: a + 1; decls +:= 1;
+      OP  +:== (INT a) INT: a + 1; decls +:= 1;
+      OP +<:== (INT a) INT: a + 1; decls +:= 1;
+      OP +>:== (INT a) INT: a + 1; decls +:= 1;
+      OP +/:== (INT a) INT: a + 1; decls +:= 1;
+      OP +=:== (INT a) INT: a + 1; decls +:= 1;
+      OP +*:== (INT a) INT: a + 1; decls +:= 1;
+      OP  +=:= (INT a) INT: a + 1; decls +:= 1;
+      OP +<=:= (INT a) INT: a + 1; decls +:= 1;
+      OP +>=:= (INT a) INT: a + 1; decls +:= 1;
+      OP +/=:= (INT a) INT: a + 1; decls +:= 1;
+      OP +==:= (INT a) INT: a + 1; decls +:= 1;
+      OP +*=:= (INT a) INT: a + 1; decls +:= 1;
+
+      OP    -= (INT a) INT: a + 1; decls +:= 1;
+      OP   -<= (INT a) INT: a + 1; decls +:= 1;
+      OP   ->= (INT a) INT: a + 1; decls +:= 1;
+      OP   -/= (INT a) INT: a + 1; decls +:= 1;
+      OP   -== (INT a) INT: a + 1; decls +:= 1;
+      OP   -*= (INT a) INT: a + 1; decls +:= 1;
+      OP  -:== (INT a) INT: a + 1; decls +:= 1;
+      OP -<:== (INT a) INT: a + 1; decls +:= 1;
+      OP ->:== (INT a) INT: a + 1; decls +:= 1;
+      OP -/:== (INT a) INT: a + 1; decls +:= 1;
+      OP -=:== (INT a) INT: a + 1; decls +:= 1;
+      OP -*:== (INT a) INT: a + 1; decls +:= 1;
+      OP  -=:= (INT a) INT: a + 1; decls +:= 1;
+      OP -<=:= (INT a) INT: a + 1; decls +:= 1;
+      OP ->=:= (INT a) INT: a + 1; decls +:= 1;
+      OP -/=:= (INT a) INT: a + 1; decls +:= 1;
+      OP -==:= (INT a) INT: a + 1; decls +:= 1;
+      OP -*=:= (INT a) INT: a + 1; decls +:= 1;
+
+      OP    %= (INT a) INT: a + 1; decls +:= 1;
+      OP   %<= (INT a) INT: a + 1; decls +:= 1;
+      OP   %>= (INT a) INT: a + 1; decls +:= 1;
+      OP   %/= (INT a) INT: a + 1; decls +:= 1;
+      OP   %== (INT a) INT: a + 1; decls +:= 1;
+      OP   %*= (INT a) INT: a + 1; decls +:= 1;
+      OP  %:== (INT a) INT: a + 1; decls +:= 1;
+      OP %<:== (INT a) INT: a + 1; decls +:= 1;
+      OP %>:== (INT a) INT: a + 1; decls +:= 1;
+      OP %/:== (INT a) INT: a + 1; decls +:= 1;
+      OP %=:== (INT a) INT: a + 1; decls +:= 1;
+      OP %*:== (INT a) INT: a + 1; decls +:= 1;
+      OP  %=:= (INT a) INT: a + 1; decls +:= 1;
+      OP %<=:= (INT a) INT: a + 1; decls +:= 1;
+      OP %>=:= (INT a) INT: a + 1; decls +:= 1;
+      OP %/=:= (INT a) INT: a + 1; decls +:= 1;
+      OP %==:= (INT a) INT: a + 1; decls +:= 1;
+      OP %*=:= (INT a) INT: a + 1; decls +:= 1;
+
+      ASSERT (++<+>+/+=+*+:=+<:=+>:=+/:=+=:=+*:=+=:+<=:+>=:+/=:+==:+*=:
+              --<->-/-=-*-:=-<:=->:=-/:=-=:=-*:=-=:-<=:->=:-/=:-==:-*=:
+              %%<%>%/%=%*%:=%<:=%>:=%/:=%=:=%*:=%=:%<=:%>=:%/=:%==:%*=: 0 = decls)
+END
+
diff --git a/gcc/testsuite/algol68/execute/mcts/oper10.a68 b/gcc/testsuite/algol68/execute/mcts/oper10.a68
new file mode 100644
index 00000000000..d6714a9bb43
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper10.a68
@@ -0,0 +1,87 @@
+# { dg-options "-fstropping=upper" }  #
+# Dyadic operators, non-bold monads #
+BEGIN # the first declaration is different to avoid a recursive loop #
+      INT decls := 0;
+      OP     += (INT a, b) INT: (INT c:= a; c PLUSAB b);
+      decls PLUSAB 1;
+      OP    +<= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    +>= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    +/= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    +== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    +*= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP   +:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +<:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +>:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +/:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +=:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +*:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP   +=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +<=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +>=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +/=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +==:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  +*=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+
+      OP     -= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    -<= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    ->= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    -/= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    -== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    -*= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP   -:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  -<:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  ->:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  -/:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  -=:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  -*:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP   -=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  -<=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  ->=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  -/=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  -==:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  -*=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+
+      OP     %= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    %<= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    %>= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    %/= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    %== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP    %*= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP   %:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %<:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %>:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %/:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %=:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %*:== (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP   %=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %<=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %>=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %/=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %==:= (INT a, b) INT: a + b; decls PLUSAB 1;
+      OP  %*=:= (INT a, b) INT: a + b; decls PLUSAB 1;
+
+      PRIO
+      +=1, +<=1, +>=1, +/=1, +==1, +*=1,
+      +:==1, +<:==1, +>:==1, +/:==1, +=:==1, +*:==1,
+      +=:=1, +<=:=1, +>=:=1, +/=:=1, +==:=1, +*=:=1,
+
+      -=1, -<=1, ->=1, -/=1, -==1, -*=1,
+      -:==1, -<:==1, ->:==1, -/:==1, -=:==1, -*:==1,
+      -=:=1, -<=:=1, ->=:=1, -/=:=1, -==:=1, -*=:=1,
+
+      %=1, %<=1, %>=1, %/=1, %==1, %*=1,
+      %:==1, %<:==1, %>:==1, %/:==1, %=:==1, %*:==1,
+      %=:=1, %<=:=1, %>=:=1, %/=:=1, %==:=1, %*=:=1;
+
+    ASSERT ((+ 1  +< 1  +> 1  +/ 1  += 1  +* 1
+    +:= 1  +<:= 1  +>:= 1  +/:= 1  +=:= 1  +*:= 1
+    +=: 1  +<=: 1  +>=: 1  +/=: 1  +==: 1  +*=: 1
+
+    - 1  -< 1  -> 1  -/ 1  -= 1  -* 1
+    -:= 1  -<:= 1  ->:= 1  -/:= 1  -=:= 1  -*:= 1
+    -=: 1  -<=: 1  ->=: 1  -/=: 1  -==: 1  -*=: 1
+
+    % 1  %< 1  %> 1  %/ 1  %= 1  %* 1
+    %:= 1  %<:= 1  %>:= 1  %/:= 1  %=:= 1  %*:= 1
+    %=: 1  %<=: 1  %>=: 1  %/=: 1  %==: 1  %*=: 1) EQ decls)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper11.a68 b/gcc/testsuite/algol68/execute/mcts/oper11.a68
new file mode 100644
index 00000000000..ce234efede1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper11.a68
@@ -0,0 +1,141 @@
+# { dg-options "-fstropping=upper" }  #
+# Dyadic operators, non-bold nomads # 
+BEGIN INT decls := 0;
+
+      OP    <= (INT a, b) INT: a + b; decls +:= 1;
+      OP   <<= (INT a, b) INT: a + b; decls +:= 1;
+      OP   <>= (INT a, b) INT: a + b; decls +:= 1;
+      OP   </= (INT a, b) INT: a + b; decls +:= 1;
+      OP   <== (INT a, b) INT: a + b; decls +:= 1;
+      OP   <*= (INT a, b) INT: a + b; decls +:= 1;
+      OP  <:== (INT a, b) INT: a + b; decls +:= 1;
+      OP <<:== (INT a, b) INT: a + b; decls +:= 1;
+      OP <>:== (INT a, b) INT: a + b; decls +:= 1;
+      OP </:== (INT a, b) INT: a + b; decls +:= 1;
+      OP <=:== (INT a, b) INT: a + b; decls +:= 1;
+      OP <*:== (INT a, b) INT: a + b; decls +:= 1;
+      OP  <=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP <<=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP <>=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP </=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP <==:= (INT a, b) INT: a + b; decls +:= 1;
+      OP <*=:= (INT a, b) INT: a + b; decls +:= 1;
+
+      OP    >= (INT a, b) INT: a + b; decls +:= 1;
+      OP   ><= (INT a, b) INT: a + b; decls +:= 1;
+      OP   >>= (INT a, b) INT: a + b; decls +:= 1;
+      OP   >/= (INT a, b) INT: a + b; decls +:= 1;
+      OP   >== (INT a, b) INT: a + b; decls +:= 1;
+      OP   >*= (INT a, b) INT: a + b; decls +:= 1;
+      OP  >:== (INT a, b) INT: a + b; decls +:= 1;
+      OP ><:== (INT a, b) INT: a + b; decls +:= 1;
+      OP >>:== (INT a, b) INT: a + b; decls +:= 1;
+      OP >/:== (INT a, b) INT: a + b; decls +:= 1;
+      OP >=:== (INT a, b) INT: a + b; decls +:= 1;
+      OP >*:== (INT a, b) INT: a + b; decls +:= 1;
+      OP  >=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP ><=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP >>=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP >/=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP >==:= (INT a, b) INT: a + b; decls +:= 1;
+      OP >*=:= (INT a, b) INT: a + b; decls +:= 1;
+
+      OP    /= (INT a, b) INT: a + b; decls +:= 1;
+      OP   /<= (INT a, b) INT: a + b; decls +:= 1;
+      OP   />= (INT a, b) INT: a + b; decls +:= 1;
+      OP   //= (INT a, b) INT: a + b; decls +:= 1;
+      OP   /== (INT a, b) INT: a + b; decls +:= 1;
+      OP   /*= (INT a, b) INT: a + b; decls +:= 1;
+      OP  /:== (INT a, b) INT: a + b; decls +:= 1;
+      OP /<:== (INT a, b) INT: a + b; decls +:= 1;
+      OP />:== (INT a, b) INT: a + b; decls +:= 1;
+      OP //:== (INT a, b) INT: a + b; decls +:= 1;
+      OP /=:== (INT a, b) INT: a + b; decls +:= 1;
+      OP /*:== (INT a, b) INT: a + b; decls +:= 1;
+      OP  /=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP /<=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP />=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP //=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP /==:= (INT a, b) INT: a + b; decls +:= 1;
+      OP /*=:= (INT a, b) INT: a + b; decls +:= 1;
+
+      OP    == (INT a, b) INT: a + b; decls +:= 1;
+      OP   =<= (INT a, b) INT: a + b; decls +:= 1;
+      OP   =>= (INT a, b) INT: a + b; decls +:= 1;
+      OP   =/= (INT a, b) INT: a + b; decls +:= 1;
+      OP   === (INT a, b) INT: a + b; decls +:= 1;
+      OP   =*= (INT a, b) INT: a + b; decls +:= 1;
+      OP  =:== (INT a, b) INT: a + b; decls +:= 1;
+      OP =<:== (INT a, b) INT: a + b; decls +:= 1;
+      OP =>:== (INT a, b) INT: a + b; decls +:= 1;
+      OP =/:== (INT a, b) INT: a + b; decls +:= 1;
+      OP ==:== (INT a, b) INT: a + b; decls +:= 1;
+      OP =*:== (INT a, b) INT: a + b; decls +:= 1;
+      OP  ==:= (INT a, b) INT: a + b; decls +:= 1;
+      OP =<=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP =>=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP =/=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP ===:= (INT a, b) INT: a + b; decls +:= 1;
+      OP =*=:= (INT a, b) INT: a + b; decls +:= 1;
+
+      OP    *= (INT a, b) INT: a + b; decls +:= 1;
+      OP   *<= (INT a, b) INT: a + b; decls +:= 1;
+      OP   *>= (INT a, b) INT: a + b; decls +:= 1;
+      OP   */= (INT a, b) INT: a + b; decls +:= 1;
+      OP   *== (INT a, b) INT: a + b; decls +:= 1;
+      OP   **= (INT a, b) INT: a + b; decls +:= 1;
+      OP  *:== (INT a, b) INT: a + b; decls +:= 1;
+      OP *<:== (INT a, b) INT: a + b; decls +:= 1;
+      OP *>:== (INT a, b) INT: a + b; decls +:= 1;
+      OP */:== (INT a, b) INT: a + b; decls +:= 1;
+      OP *=:== (INT a, b) INT: a + b; decls +:= 1;
+      OP **:== (INT a, b) INT: a + b; decls +:= 1;
+      OP  *=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP *<=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP *>=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP */=:= (INT a, b) INT: a + b; decls +:= 1;
+      OP *==:= (INT a, b) INT: a + b; decls +:= 1;
+      OP **=:= (INT a, b) INT: a + b; decls +:= 1;
+
+      PRIO
+      <=1, <<=1, <>=1, </=1, <==1, <*=1,
+      <:==1, <<:==1, <>:==1, </:==1, <=:==1, <*:==1,
+      <=:=1, <<=:=1, <>=:=1, </=:=1, <==:=1, <*=:=1,
+
+      >=1, ><=1, >>=1, >/=1, >==1, >*=1,
+      >:==1, ><:==1, >>:==1, >/:==1, >=:==1, >*:==1,
+      >=:=1, ><=:=1, >>=:=1, >/=:=1, >==:=1, >*=:=1,
+
+      /=1, /<=1, />=1, //=1, /==1, /*=1,
+      /:==1, /<:==1, />:==1, //:==1, /=:==1, /*:==1,
+      /=:=1, /<=:=1, />=:=1, //=:=1, /==:=1, /*=:=1,
+
+      ==1, =<=1, =>=1, =/=1, ===1, =*=1,
+      =:==1, =<:==1, =>:==1, =/:==1, ==:==1, =*:==1,
+      ==:=1, =<=:=1, =>=:=1, =/=:=1, ===:=1, =*=:=1,
+
+      *=1, *<=1, *>=1, */=1, *==1, **=1,
+      *:==1, *<:==1, *>:==1, */:==1, *=:==1, **:==1,
+      *=:=1, *<=:=1, *>=:=1, */=:=1, *==:=1, **=:=1;
+
+    ASSERT ((0
+    < 1  << 1  <> 1  </ 1  <= 1  <* 1
+    <:= 1  <<:= 1  <>:= 1  </:= 1  <=:= 1  <*:= 1
+    <=: 1  <<=: 1  <>=: 1  </=: 1  <==: 1  <*=: 1
+
+    > 1  >< 1  >> 1  >/ 1  >= 1  >* 1
+    >:= 1  ><:= 1  >>:= 1  >/:= 1  >=:= 1  >*:= 1
+    >=: 1  ><=: 1  >>=: 1  >/=: 1  >==: 1  >*=: 1
+
+    / 1  /< 1  /> 1  // 1  /= 1  /* 1
+    /:= 1  /<:= 1  />:= 1  //:= 1  /=:= 1  /*:= 1
+    /=: 1  /<=: 1  />=: 1  //=: 1  /==: 1  /*=: 1
+
+    = 1  =< 1  => 1  =/ 1  == 1  =* 1
+    =:= 1  =<:= 1  =>:= 1  =/:= 1  ==:= 1  =*:= 1
+    ==: 1  =<=: 1  =>=: 1  =/=: 1  ===: 1  =*=: 1
+
+    * 1  *< 1  *> 1  */ 1  *= 1  ** 1
+    *:= 1  *<:= 1  *>:= 1  */:= 1  *=:= 1  **:= 1
+    *=: 1  *<=: 1  *>=: 1  */=: 1  *==: 1  **=: 1) EQ decls)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper14.a68 b/gcc/testsuite/algol68/execute/mcts/oper14.a68
new file mode 100644
index 00000000000..9630e8c62c3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper14.a68
@@ -0,0 +1,32 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN ASSERT (UPB []INT(1,2,3,4) = 4);
+      ASSERT (UPB "abcde" = 5);
+      ASSERT (UPB []INT(SKIP,SKIP)[1:1@5] = 5);
+      ASSERT (2 UPB [,]INT(1,2)[,@4] = 4);
+
+      # All declarers are of the mode row-of, so UPB/LWB
+        should work.
+      #
+      ASSERT (UPB UNION([]INT,[,]INT)([]INT (1)) = 1);
+      ASSERT (UPB UNION([]INT,[,]INT)([,]INT (1,1)) = 2);
+      ASSERT (UPB UNION([]STRING,STRING)("ab") = 2);
+      ASSERT (LWB UNION([]INT,[,]INT)([]INT (1)) = 1);
+      ASSERT (LWB UNION([]INT,[,]INT)([,]INT (1,1)) = 1);
+      ASSERT (LWB UNION([]STRING,STRING)("ab") = 1);
+
+      ASSERT (1 UPB [,,]CHAR ("abc", "def") = 2);
+      ASSERT (2 UPB [,,]CHAR ("abc", "def") = 1);
+      ASSERT (3 UPB [,,]CHAR ("abc", "def") = 3);
+
+      ASSERT (LWB LOC STRING LWB LOC STRING = 1);
+
+      # Balance.  #
+      FOR n TO 4
+      DO n UPB CASE n
+               IN []INT (1),
+                  [,]REAL (1),
+                  UNION([]INT,[,,]BOOL) ([,,]BOOL (TRUE)),
+                  UNION([]INT,UNION([,]REAL,[,,,]CHAR))([,,,]CHAR ("a"))
+               ESAC
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/oper16.a68 b/gcc/testsuite/algol68/execute/mcts/oper16.a68
new file mode 100644
index 00000000000..cd1e040109e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/oper16.a68
@@ -0,0 +1,866 @@
+# { dg-options "-fstropping=upper" }  #
+# Tests  on  operators.  #
+BEGIN
+      PROC itoa = (INT i) STRING:
+      BEGIN IF i = 0
+            THEN "0"
+            ELSE INT n := ABS i;
+                 STRING res;
+                 WHILE n /= 0
+                 DO INT rem = n %* 10;
+                    res := REPR (rem > 9
+                                 | (rem - 10) + ABS "a"
+                                 | rem + ABS "0") + res;
+                    n %:= 10
+                 OD;
+                 (i < 0 | "-" + res | res)
+            FI
+      END;
+
+    INT errors := 0;
+    PROC error = (INT i) VOID:
+       (puts("Error in test " + itoa (i)); errors +:= 1);
+
+    PROC tste = (INT i) VOID:
+    BEGIN error(i);
+          puts ("; wrong branch taken\n")
+    END;
+
+    PROC tsti = (INT i, INT p, q) VOID:
+    IF p = q THEN SKIP
+    ELSE error(i);
+         puts ("; value is: " + itoa (q) + ", must be: " + itoa (p) + "\n")
+    FI;
+
+    PROC tstr = (INT i, REAL p, q) VOID:
+    # two reals are considered equal if their difference is negligible
+      compared to one of them
+    #
+    IF p + (p-q)/8 = p THEN SKIP
+    ELSE error(i);
+         errors -:= 1; # XXX Optimizations make comparisons to fail.  #
+         puts ("; real values are not equal\n")
+    FI;
+
+    PROC tstb = (INT i, BOOL p, q) VOID:
+    BEGIN
+        IF p THEN IF q THEN SKIP ELSE GOTO bad FI
+               ELSE IF q THEN GOTO bad ELSE SKIP FI
+        FI
+    EXIT bad:
+        error(i);
+        puts ("; boolean values are not equal\n")
+    END;
+
+    PROC tstc = (INT i, CHAR p, q) VOID:
+    IF p = q THEN SKIP
+    ELSE error(i);
+         puts ("; value is: " + q + ", must be: " + p + "\n")
+    FI;
+
+    PROC tstli = (INT i, LONG INT p, q) VOID:
+    IF p = q THEN SKIP
+    ELSE error(i);
+         puts ("; long int values are not equal\n")
+    FI;
+
+    PROC tstlr = (INT i, LONG REAL p, q) VOID:
+    IF p + (p-q)/LONG 8 = p THEN SKIP
+    ELSE error(i);
+         errors -:= 1; # XXX Optimizations make comparisons to fail.  #
+         puts ("; long real values are not equal\n")
+    FI;
+
+puts("Test: REPR, ABS\n");
+BEGIN
+    INT b1; LONG INT b2;
+    INT b0 = 44;
+    [1:2]CHAR a;
+    a[2]:="a";
+    tstc(1, "a", REPR ABS"a");
+    tstc(2, "a", REPR ABS a[2]);
+    tsti(3, +43, ABS(REPR 43));
+    tsti(4, +44, ABS(REPR b0));
+    b1:=45;
+    tsti(5, +45, ABS(REPR b1));
+    tsti(6, +46, ABS(REPR (46+0)));
+    b2:=LONG 43;
+    tsti(7, +43, ABS(REPR SHORTEN b2));
+    tsti(8, +46, ABS REPR SHORTEN LONG 46)
+END;
+
+puts("Test: LWB, UPB\n");
+BEGIN
+    REF[]CHAR b;
+    [-5:-3, -1:3]REF[ , ]REAL a;
+    tsti(9, -5, 1 LWB a);
+    tsti(10, -5, LWB a);
+    tsti(11, -1, 2 LWB a);
+    tsti(12, -3, 1 UPB a);
+    tsti(13, -3, UPB a);
+    tsti(14, +3, 2 UPB a);
+    FOR i FROM LWB a BY 1 TO UPB a DO
+    FOR j FROM 2 LWB a BY 1 TO 2 UPB a DO
+        BEGIN
+            [i:j, -j:-i]REAL b;
+            a[i, j] := b;
+            tsti(15,  i, 1 LWB a[i, j]);
+            tsti(16,  j, UPB a[i, j]);
+            tsti(17, -j, 2 LWB a[i, j]);
+            tsti(18, -i, 2 UPB a[i, j])
+        END
+    OD OD
+END;
+
+BEGIN
+    [1:3, 2:4, 3:5]INT a aaaaa;
+    INT jjjjjj;
+    FOR i FROM 1 BY 1 TO 3
+    DO tsti(19, i, i LWB aaaaaa);
+            tsti(20, i+2, i UPB aaaaaa)
+    OD;
+    FOR i FROM-3BY 1 TO-1
+    DO tsti(21, -i, -i LWB aaaaaa);
+            tsti(22, 2-i, -i UPB aaaaaa)
+    OD;
+    jjjjjj:=2; tsti(23, +2, jjjjjj LWB aaaaaa);
+               tsti(24, +4, jjjjjj UPB aaaaaa);
+    tsti(25, +1, LWB"abc");
+    tsti(26, +3, UPB"cde");
+    tsti(27, +1, (1+0) LWB"abc");
+    tsti(28, +3, 1 UPB"efg")
+END;
+
+puts("Test: OR, AND\n");
+BEGIN
+    BOOL t = TRUE; BOOL f = FALSE;
+    BOOL a;
+    a:=t OR t; tstb(29, TRUE, a);
+    a:=t OR f; tstb(30, TRUE, a);
+    a:=f OR t; tstb(31, TRUE, a);
+    a:=f OR f; tstb(32, FALSE, a);
+    a:=t AND t; tstb(33, TRUE, a);
+    a:=t AND f; tstb(34, FALSE, a);
+    a:=f AND t; tstb(35, FALSE, a);
+    a:=f AND f; tstb(36, FALSE, a);
+    a:=NOT t AND t; tstb(37, FALSE, a);
+    a:=NOT f AND t; tstb(38, TRUE, a);
+    a:=NOT t AND f; tstb(39, FALSE, a);
+    a:=NOT f AND f; tstb(40, FALSE, a);
+    a:=NOT t OR t; tstb(41, TRUE, a);
+    a:=NOT f OR t; tstb(42, TRUE, a);
+    a:=NOT t OR f; tstb(43, FALSE, a);
+    a:=NOT f OR f; tstb(44, TRUE, a);
+    a:=t AND NOT t; tstb(45, FALSE, a);
+    a:=t AND NOT f; tstb(46, TRUE, a);
+    a:=f AND NOT t; tstb(47, FALSE, a);
+    a:=f AND NOT f; tstb(48, FALSE, a);
+    a:=t OR NOT t; tstb(49, TRUE, a);
+    a:=t OR NOT f; tstb(50, TRUE, a);
+    a:=f OR NOT t; tstb(51, FALSE, a);
+    a:=f OR NOT f; tstb(52, TRUE, a);
+    a:=NOT t AND NOT t; tstb(53, FALSE, a);
+    a:=NOT t AND NOT f; tstb(54, FALSE, a);
+    a:=NOT f AND NOT t; tstb(55, FALSE, a);
+    a:=NOT f AND NOT f; tstb(56, TRUE, a);
+    a:=NOT t OR NOT t; tstb(57, FALSE, a);
+    a:=NOT t OR NOT f; tstb(58, TRUE, a);
+    a:=NOT f OR NOT t; tstb(59, TRUE, a);
+    a:=NOT f OR NOT f; tstb(60, TRUE, a);
+
+    a:=t; tstb(61, TRUE, a);
+    a:=a AND t; tstb(62, TRUE, a);
+    a:=a OR t; tstb(63, TRUE, a);
+    a:=a OR f; tstb(64, TRUE, a);
+    a:=a AND f; tstb(65, FALSE, a);
+    a:=a AND f; tstb(66, FALSE, a);
+    a:=a AND t; tstb(67, FALSE, a);
+    a:=a OR f; tstb(68, FALSE, a);
+    a:=a OR t; tstb(69, TRUE, a);
+    a:=t; tstb(70, TRUE, a);
+    a:=t AND a; tstb(71, TRUE, a);
+    a:=t OR a; tstb(72, TRUE, a);
+    a:=f OR a; tstb(73, TRUE, a);
+    a:=f AND a; tstb(74, FALSE, a);
+    a:=f AND a; tstb(75, FALSE, a);
+    a:=t AND a; tstb(76, FALSE, a);
+    a:=f OR a; tstb(77, FALSE, a);
+    a:=t OR a; tstb(78, TRUE, a);
+    SKIP
+END;
+
+BEGIN
+    BOOL t = TRUE; BOOL f = FALSE;
+    tstb(79, TRUE, t OR f);
+    tstb(80, TRUE, t OR t);
+    tstb(81, TRUE, f OR t);
+    tstb(82, FALSE, f OR f);
+    tstb(83, TRUE, NOT (f OR f));
+    tstb(84, TRUE, NOT (f AND f));
+    tstb(85, TRUE, t AND t);
+    tstb(86, FALSE, t AND f);
+    tstb(87, FALSE, f AND t);
+    tstb(88, FALSE, f AND f);
+    tstb(89, TRUE, (t OR t) OR (f OR f));
+    tstb(90, FALSE, (t OR t) AND (f OR f));
+    tstb(91, TRUE, t OR (f OR f));
+    tstb(92, TRUE, NOT (t AND (f OR f)));
+    tstb(93, FALSE, NOT NOT ((f OR f) OR f));
+    tstb(94, TRUE, NOT NOT NOT ((f OR f) AND f));
+    IF t OR f THEN SKIP ELSE tste(95) FI;
+    IF t OR t THEN SKIP ELSE tste(96) FI;
+    IF f OR t THEN SKIP ELSE tste(97) FI;
+    IF f OR f THEN tste(98) FI;
+    IF NOT (f OR f) THEN SKIP ELSE tste(99) FI;
+    IF NOT (f AND f) THEN SKIP ELSE tste(100) FI;
+    IF t AND t THEN SKIP ELSE tste(101) FI;
+    IF t AND f THEN tste(102) FI;
+    IF f AND t THEN tste(103) FI;
+    IF f AND f THEN tste(104) FI;
+    IF (t OR t) AND (t OR t) THEN SKIP ELSE tste(105) FI;
+    IF (t OR t) OR (t OR t) THEN SKIP ELSE tste(106) FI;
+    IF (t OR t) OR f THEN SKIP ELSE tste(107) FI;
+    IF (t OR t) AND t THEN SKIP ELSE tste(108) FI;
+    IF t OR (t OR t) THEN SKIP ELSE tste(109) FI;
+    IF t AND (t OR f) THEN SKIP ELSE tste(110) FI;
+    BOOL a1; a1:=t AND f; tstb(111, FALSE, a1);
+    BOOL a2; a2:=NOT (t OR f); tstb(112, FALSE, a2);
+    BEGIN
+        BOOL t; t := TRUE;
+        BOOL f; f:=FALSE;
+        IF (NOT (NOT ((t OR t) AND (t OR t)) OR
+                ((f OR f) OR f) AND (t OR f AND f)) AND f)
+                OR NOT t
+        THEN tste(113) ELSE SKIP FI;
+        BOOL x; x:=
+            (NOT (NOT ((t OR t) AND (t OR t)) OR
+            ((f OR f) OR f) AND (t OR (f AND f))) AND f)
+            OR NOT t;
+        tstb(114, FALSE, x);
+        BOOL y =
+            (NOT (NOT ((t OR t) AND (t OR t)) OR
+            ((f OR f) OR f) AND (t OR (f AND f))) AND f)
+            OR NOT t;
+        tstb(115, FALSE, y)
+    END
+END;
+
+puts("Test: NE, EQ for booleans\n");
+BEGIN
+    BOOL t = TRUE; BOOL f = FALSE;
+    tstb(116, TRUE, t NE f);
+    tstb(117, FALSE, t NE t);
+    tstb(118, TRUE, f NE t);
+    tstb(119, FALSE, f NE f);
+    tstb(120, TRUE, NOT (f NE f));
+    tstb(121, FALSE, NOT (f EQ f));
+    tstb(122, TRUE, t EQ t);
+    tstb(123, FALSE, t EQ f);
+    tstb(124, FALSE, f EQ t);
+    tstb(125, TRUE, f EQ f);
+    tstb(126, FALSE, (t NE t) NE (f NE f));
+    tstb(127, TRUE, (t NE t) EQ (f NE f));
+    tstb(128, TRUE, t NE (f NE f));
+    tstb(129, TRUE, NOT (t EQ (f NE f)));
+    tstb(130, FALSE, NOT NOT ((f NE f) NE f));
+    tstb(131, FALSE, NOT NOT NOT ((f NE f) EQ f));
+    IF t NE f THEN SKIP ELSE tste(132) FI;
+    IF t NE t THEN tste(133) FI;
+    IF f NE t THEN SKIP ELSE tste(134) FI;
+    IF f NE f THEN tste(135) FI;
+    IF NOT (f NE f) THEN SKIP ELSE tste(136) FI;
+    IF NOT (f EQ f) THEN tste(137) FI;
+    IF t EQ t THEN SKIP ELSE tste(138) FI;
+    IF t EQ f THEN tste(139) FI;
+    IF f EQ t THEN tste(140) FI;
+    IF f EQ f THEN SKIP ELSE tste(141) FI;
+    IF (t NE t) EQ (t NE t) THEN SKIP ELSE tste(142) FI;
+    IF (t NE t) NE (t NE t) THEN tste(143) FI;
+    IF (t NE t) NE f THEN tste(144) FI;
+    IF (t NE t) EQ t THEN tste(145) FI;
+    IF t NE (t NE t) THEN SKIP ELSE tste(146) FI;
+    IF t EQ (t NE f) THEN SKIP ELSE tste(147) FI;
+    BOOL a1; a1:=t EQ f; tstb(148, FALSE, a1);
+    BOOL a2; a2:=NOT (t NE f); tstb(149, FALSE, a2);
+    BEGIN
+        BOOL t; t := TRUE;
+        BOOL f; f:=FALSE;
+        IF (NOT (NOT ((t NE t) EQ (t NE t)) NE
+                ((f NE f) NE f) EQ (t NE f EQ f)) EQ f)
+                NE NOT t
+        THEN SKIP ELSE tste(150) FI;
+        BOOL x; x:=
+            (NOT (NOT ((t NE t) EQ (t NE t)) NE
+            ((f NE f) NE f) EQ (t NE (f EQ f))) EQ f)
+            NE NOT t;
+        tstb(151, TRUE, x);
+        BOOL y =
+            (NOT (NOT ((t NE t) EQ (t NE t)) NE
+            ((f NE f) NE f) EQ (t NE (f EQ f))) EQ f)
+            NE NOT t;
+        tstb(152, TRUE, y)
+    END
+END;
+
+puts("Test: NOT\n");
+BEGIN
+    BOOL a1, a2, a3, b1, b2, b3;
+    BOOL a4=NOT FALSE; BOOL a5=NOT NOT FALSE;
+    BOOL a6=NOT NOT NOT FALSE;
+    BOOL a7=NOT a6; BOOL a8=NOT a7; BOOL a9=NOT NOT a8;
+    BOOL a10=NOT NOT NOT a9;
+    IF NOT TRUE THEN tste(153) FI;
+    IF NOT NOT TRUE THEN SKIP ELSE tste(154) FI;
+    IF NOT NOT NOT TRUE THEN tste(155) FI;
+    a1:=NOT TRUE; a2:=NOT NOT FALSE;
+    a3:=NOT NOT NOT TRUE;
+    b1:=NOT TRUE AND FALSE;
+    b2:=NOT NOT TRUE AND FALSE;
+    b3:=TRUE OR NOT NOT NOT TRUE OR FALSE;
+    tstb(156, FALSE, a1);
+    tstb(157, FALSE, a2);
+    tstb(158, FALSE, a3);
+    tstb(159, TRUE, a4);
+    tstb(160, FALSE, a5);
+    tstb(161, TRUE, a6);
+    tstb(162, FALSE, a7);
+    tstb(163, TRUE, a8);
+    tstb(164, TRUE, a9);
+    tstb(165, FALSE, a10);
+    tstb(166, FALSE, b1);
+    tstb(167, FALSE, b2);
+    tstb(168, TRUE, b3)
+END;
+
+puts("Test: EQ, NE, LT, LE, GT, GE\n");
+BEGIN
+    IF -1=-1 THEN SKIP ELSE tste(169) FI;
+    tstb(170, TRUE, -LONG 1=-LONG 1);
+    IF -1/=1 THEN SKIP ELSE tste(171) FI;
+    tstb(172, TRUE, -LONG 1/=LONG 1);
+    IF 1 /= -1 THEN SKIP ELSE tste(173) FI;
+    tstb(174, TRUE, LONG 1/=-LONG 1);
+    IF 1 =1 THEN SKIP ELSE tste(175) FI;
+    tstb(176, TRUE, LONG 1=LONG 1);
+    IF 0=0.0 THEN SKIP ELSE tste(177) FI;
+    tstb(178, TRUE, LONG 0=LONG 0.0);
+    IF 1.0=1 THEN SKIP ELSE tste(179) FI;
+    tstb(180, TRUE, LONG 1.0=LONG 1);
+    IF -1.0=-1.0 THEN SKIP ELSE tste(181) FI;
+    tstb(182, TRUE, -LONG 1.0=-LONG 1.0);
+    IF -1.0/=1.0 THEN SKIP ELSE tste(183) FI;
+    tstb(184, TRUE, LENG-1.0/=LONG 1.0);
+    IF 1.0/= -1.0 THEN SKIP ELSE tste(185) FI;
+    tstb(186, TRUE, LONG 1.0/=LENG-1.0);
+    BOOL
+    a1=1=1, a2=1/=1, a3=1>1,
+    a4=1<1, a5=1<= 1, a6=1>=0,
+    a7=1.0=2.0, a8=1.0/=2.0, a9=1.0<2.0,
+    a10=1.0>0.0, a11=1.0<=1.0,
+    a12=1.0>=-1.0;
+    tstb(187, TRUE, a1);
+    tstb(188, FALSE, a2);
+    tstb(189, FALSE, a3);
+    tstb(190, FALSE, a4);
+    tstb(191, TRUE, a5);
+    tstb(192, TRUE, a6);
+    tstb(193, FALSE, a7);
+    tstb(194, TRUE, a8);
+    tstb(195, TRUE, a9);
+    tstb(196, TRUE, a10);
+    tstb(197, TRUE, a11);
+    tstb(198, TRUE, a12);
+    IF 1 = 1 THEN SKIP ELSE tste(199) FI;
+    tstb(200, TRUE, 1=1);
+    IF NOT (1/=1) THEN SKIP ELSE tste(201) FI;
+    tstb(202, TRUE, NOT NOT NOT (1/=1));
+    IF 1/=2 AND 2/=3 AND 4/=5 THEN SKIP ELSE tste(203) FI
+END;
+
+BEGIN
+    REAL j;
+    [-3 : 3] BOOL lt0;
+    lt0[-3]:= lt0[-2]:= lt0[-1]:= TRUE;
+    lt0[0]:= lt0[1]:= lt0[2]:= lt0[3]:= FALSE;
+    FOR i FROM -3 BY 1 TO 3
+    DO
+        tstb(204, NOT(lt0[i] OR lt0[-i]), i=0);
+        tstb(205, lt0[i] OR lt0[-i], i/=0);
+        tstb(206, lt0[-i], i>0);
+        tstb(207, NOT lt0[i], i>=0);
+        tstb(208, lt0[i], i<0);
+        tstb(209, NOT lt0[-i], i<=0);
+        j:=i;
+        tstb(210, NOT(lt0[i] OR lt0[-i]), j=0);
+        tstb(211, lt0[i] OR lt0[-i], j/=0);
+        tstb(212, lt0[-i], j>0);
+        tstb(213, NOT lt0[i], j>=0);
+        tstb(214, lt0[i], j<0);
+        tstb(215, NOT lt0[-i], j<=0)
+    OD
+END;
+
+puts("Test: monadic -\n");
+BEGIN
+    INT x0, x1, x2, x3; LONG INT z0, z1, z2, z3;
+    REAL y0, y1, y2, y3; LONG REAL t0, t1, t2, t3;
+    INT x4 = 10; LONG INT z4 = LONG 10;
+    REAL y4 = x4; LONG REAL t4 = z4;
+    z0 := --LONG 38; z1 := -LONG 1000000000; z2 := -z1;
+    x0:=--79; x1 := -1; x2 := -x1; x3 := -SHORTEN z0;
+    t0 := --LONG 8.7; t1 := -LONG 79.99e-2; t2 := -t1;
+    y0 := --6.7e-4; y1 := -39.47e-2; y2 := -y1; y3 := -SHORTEN t2;
+    tsti(216, +79, x0);
+    tsti(217, -1, x1);
+    tsti(218, +1, x2);
+    tsti(219, -38, x3);
+    tsti(220, +10, x4);
+    tstli(221, +LONG 38, z0);
+    tstli(222, -LONG 1000000000, z1);
+    tstli(223, +LONG 1000000000, z2);
+    tstli(224, +LONG 10, z4);
+    tstr(225, +6.7e-4, y0);
+    tstr(226, -3.947e-1, y1);
+    tstr(227, +3.947e-1, y2);
+    tstr(228, -7.999e-1, y3);
+    tstr(229, +1e+1, y4);
+    tstlr(230, +LONG 8.7e+0, t0);
+    tstlr(231, -LONG 7.999e-1, t1);
+    tstlr(232, +LONG 7.999e-1, t2);
+    tstlr(233, +LONG 10e+0, t4)
+END;
+
+puts("Test: dyadic -\n");
+BEGIN
+    tsti(234, -2, 1-3);
+    tstli(235, +LONG 4, LONG 7-LONG 3);
+    tsti(236, -4, -1-3);
+    tstli(237, -LONG 13, -LONG 8-LONG 5);
+    tsti(238, +4, 1--3);
+    tstli(239, +LONG 7, LONG 4--LONG 3);
+    tsti(240, +2, -1--3);
+    tstli(241, -LONG 10, -LONG 5--LENG-5);
+
+    tstr(242, -6.4e+0, 1-7.4);
+    tstlr(243, +LONG 8e+0, LONG 4-LENG-4.0);
+    tstr(244, +6.4e+0, 7.4-1);
+    tstlr(245, -LONG 1.2e+1, -LONG 6.0-LONG 6);
+    tstr(246, +1.22e+1, 6.1--6.1);
+    tstlr(247, +LONG 8.6e+0, LONG 4.3--LONG 4.3);
+
+    tsti(248, +29999, 30000-1);
+    tstli(249, +LONG 999999998, LONG 1000000000-LONG 2);
+
+    tstr(250, +1e+0, -1.0-(-1.0-(-1.0-(-1.0-1))));
+    tstlr(251, +LONG 0e+0,
+        -LONG 1.0-(-LONG 1.0-(-LONG 1.0-(-LONG 1.0
+        -(LONG 1-LONG 1.0)))))
+END;
+
+puts("Test: dyadic +\n");
+BEGIN
+    tsti(252, +4, 1+3);
+    tstli(253, +LONG 10, LONG 7+LONG 3);
+    tsti(254, +2, -1+3);
+    tstli(255, -LONG 3, -LONG 8+LONG 5);
+    tsti(256, -2, 1+-3);
+    tstli(257, +LONG 1, LONG 4+-LONG 3);
+    tsti(258, -4, -1+-3);
+    tstli(259, +LONG 0, -LONG 5+-LENG-5);
+
+    tstr(260, +8.4e+0, 1+7.4);
+    tstlr(261, +LONG 0e+0, LONG 4+LENG-4.0);
+    tstr(262, +8.4e+0, 7.4+1);
+    tstlr(263, +LONG 0e+0, -LONG 6.0+LONG 6);
+    tstr(264, +0e+0, 6.1+-6.1);
+    tstlr(265, +LONG 0e+0, LONG 4.3+-LONG 4.3);
+
+    tsti(266, -29999, -30000+1);
+    tstli(267, -LONG 999999998, -LONG 1000000000+LONG 2);
+
+    tstr(268, -3e+0, -1.0+(-1.0+(-1.0+(-1.0+1))));
+    tstlr(269, -LONG 2e+0,
+        -LONG 1.0+(-LONG 1.0+(-LONG 1.0+(-LONG 1.0
+        +(LONG 1+LONG 1.0)))))
+END;
+
+puts("Test: ABS\n");
+BEGIN
+    tsti(270, +19, ABS 19);
+    tsti(271, +19, ABS-19);
+    tsti(272, +0, ABS 0);
+    tsti(273, +32, SHORTEN ABS LONG 32);
+    tsti(274, +43, SHORTEN ABS-LONG 43);
+    tsti(275, +0, SHORTEN ABS LONG 0);
+    tstr(276, +1.97e+2, ABS 197.0);
+    tstr(277, +4.97e+1, ABS-49.7);
+    tstr(278, +0e+0, ABS .0);
+    tstr(279, +1e+0, SHORTEN ABS LONG 1.0);
+    tstr(280, +0e+0, SHORTEN ABS LONG 0.0e+7);
+    tstr(281, +1.9e+0, SHORTEN ABS-LONG 1.9)
+END;
+
+puts("Test: * for integers\n");
+BEGIN
+    tsti(282, +6, 2*3);
+    tsti(283, -6, -2*3);
+    tsti(284, -6, 2*-3);
+    tsti(285, +6, -2*-3);
+    tsti(286, +6, SHORTEN(-LONG 2*-LONG 3));
+    tsti(287, -6, SHORTEN(LONG 2*-LONG 3));
+    tsti(288, -6, SHORTEN(-LONG 2*LONG 3));
+    tsti(289, +6, SHORTEN(LONG 2*LONG 3));
+    tsti(290, +0, 0*10);
+    tstli(291, +LONG 0, LONG 0*-LONG 10);
+    tsti(292, +0, 10*0);
+    tstli(293, +LONG 0, -LONG 10*LENG 0);
+    tsti(294, +3, 1*3);
+    tstli(295, +LONG 3, LONG 3*LONG 1);
+    tsti (296, +16384, 2*(2*(2*(2*(2*(2*(2*(2*(2*(2*(2*(2*(2*(2
+        ))))))))))))))
+END;
+
+puts("Test: * mixed\n");
+BEGIN
+    REAL a1=1.0; LONG REAL a2=-LONG 1.0;
+    REAL a3; LONG REAL a4;
+    tstr(297, +4.2e+1, 6.0*7.0);
+    tstlr(298, +LONG 2.6e+1, LONG 13.0*LONG 2.0);
+    tstr(299, -4.2e+1, -6.0*7.0);
+    tstlr(300, -LONG 6e+0, -LONG 2.0*LONG 3.0);
+    tstr(301, -5.6e+1, 7.0*-8.0);
+    tstlr(302, -LONG 4.8e+1, LONG 16.0*-LENG 3.0);
+    tstr(303, +5.6e+1, -8.0*-7.0);
+    tstlr(304, +LONG 2.5e+1, -LENG 5.0*-LONG 5.0);
+
+    tstr(305, +4.2e+1, 7*6.0);
+    tstlr(306, +LONG 2.1e+1, LONG 3*LONG 7.0);
+    tstr(307, +4.2e+1, 6.0*7);
+    tstlr(308, +LONG 3.6e+1, LONG 6.0*LONG 6);
+    tstr(309, +4.2e+1, -7*-6.0);
+    tstlr(310, +LONG 2.25e+2, -LONG 15*-LONG 15.0);
+    tstr(311, +4.2e+1, -6.0*-7);
+    tstlr(312, +LONG 1.9e+1, -LONG 19.0*-LONG 1);
+
+    a3:=14.0; a4:=LENG-13.0;
+    tstr(313, +1.4e+1, a3*a1);
+    tstlr(314, +LONG 1.3e+1, a2*a4);
+    tstr(315, +10e-43, 1.0e-20*1.0e-22);
+    tstlr(316, +LONG 10e+39, LONG 1.0e+20*LONG 1.0e+20)
+END;
+
+puts("Test: OVER, MOD\n");
+BEGIN
+    tsti(317, +2, 12 OVER 6);
+    tsti(318, -5, -20 OVER 4);
+    tsti(319, -25, 100 OVER -4);
+    tsti(320, +10, -10 OVER -1);
+    tsti(321, +2, 7 OVER 3);
+    tsti(322, -2, -8 OVER 3);
+    tsti(323, -1, 10 OVER -7);
+    tsti(324, +1, -49 OVER -27);
+    tsti(325, +3, SHORTEN(LONG 10 OVER LONG 3));
+    tsti(326, -1, SHORTEN(-LONG 50 OVER LONG 50));
+    tsti(327, -1, -12 OVER 7);
+    tsti(328, -1, 12 OVER -7);
+    tsti(329, -1, SHORTEN(-LONG 50 OVER LONG 50));
+    tsti(330, +0, SHORTEN(LONG 0 OVER -LONG 25));
+    tsti(331, +0, 12 MOD 6);
+    tsti(332, +0, -20 MOD 4);
+    tsti(333, +0, 100 MOD -4);
+    tsti(334, +0, -10 MOD -1);
+    tsti(335, +1, 7 MOD 3);
+    tsti(336, +1, -8 MOD 3);
+    tsti(337, +3, 10 MOD -7);
+    tsti(338, +5, -49 MOD -27);
+    tsti(339, +1, SHORTEN(LONG 10 MOD LONG 3));
+    tsti(340, +0, SHORTEN(-LONG 50 MOD LONG 50));
+    tsti(341, +2, -12 MOD 7);
+    tsti(342, +5, 12 MOD -7);
+    tsti(343, +0, SHORTEN(-LONG 50 MOD LONG 50));
+    tsti(344, +0, SHORTEN(LONG 0 MOD -LONG 25))
+END;
+
+puts("Test: /\n");
+BEGIN
+    REAL a, b; LONG REAL c, d; REAL x = 127.0;
+    FOR i FROM -3 BY 1 TO 3 DO
+    FOR j FROM -3 BY 1 TO 3 DO
+        IF j /= 0 THEN
+            a:=i/j;
+            tstr(345, i, a*j);
+            a:=i; a:=a/j;
+            tstr(346, i, a*j);
+            a:=j; a :=i/a;
+            tstr(347, i, a*j);
+            a := i; b := j; a := a/b;
+            tstr(348, i, a*j);
+            c := LENG i/LENG j;
+            tstlr(349, LENG i, c*LENG j);
+            c := LENG i; c := c/LENG j;
+            tstlr(350, LENG i, c*LENG j);
+            c := LENG j; c :=LENG i/c;
+            tstlr(351, LENG i, c*LENG j);
+            c := LENG i; d:=LENG j; c:=c/d;
+            tstlr(352, LENG i, c*LENG j)
+        FI
+    OD OD;
+    tstr(353, -1e+0, 1.9e-7/-1.9e-7);
+    a:=19.74e+2;
+    tstr(354, +1e+0, 19.74e+2/a);
+    tstr(355, +10e-5, 19.74e-2/19.74e+2);
+    tstr(356, +1e+3, 127000.0/x);
+    tstr(357, +1e+2, x/1.27);
+    tstr(358, -1e+1, x/-12.7);
+    tstr(359, +1e+0, x/x);
+    a:=1270.0;
+    tstr(360, +10e-2, x/a);
+    a:=0.0149; tstr(361, +1e+0, a/149e-4);
+    tstr(362, +1e+0, a/a);
+    tstr(363, +1.173228346456693e-4, a/x);
+    tstr(364, -1e-2, a/-1.49);
+    tstr(365, +1.27e+2, -x/-1.0);
+    tstr(366, -1e+0, -x/x);
+    tstr(367, -8.523489932885906e+3, -x/a);
+    tstr(368, +1e+0, -x/-x)
+END;
+
+puts("Test: **\n");
+BEGIN
+    INT a;
+    tsti(369, +1, 1**0);
+    tsti(370, +1, 10**0);
+    tsti(371, +1, -20**0);
+    tsti(372, +1, 1**1);
+    tsti(373, +10, 10**1);
+    tsti(374, -10, -10**1);
+    tsti(375, +0, 0**1);
+    tsti(376, +0, 0**30000);
+    tsti(377, +1, 0**0);
+    tsti(378, +49, 7**2);
+    tsti(379, +1, 1**2);
+    tsti(380, +9, -3**2);
+    tsti(381, -27, -3**3);
+    tsti(382, +32, 2**5);
+    tsti(383, +81, SHORTEN(LONG 9**2));
+    tsti(384, -19683, SHORTEN(-LONG 27**3));
+    tstr(385, +2.7e+1, 3.0**3);
+    tstr(386, +6.5536e+4, 2.0**16);
+    tstr(387, -3.2768e+4, -2.0**15);
+    tstr(388, +3.6e+1, -6.0**2);
+    tstr(389, +2.5e-1, 2.0**-2);
+    tstr(390, -10e-4, -10.0**-3);
+    tstr(391, +1e+0, 3.0**-0);
+    tstr(392, +1e+0, 3.0**-0);
+    tstr(393, +4.9e+1, SHORTEN(LONG 7.0**2));
+    tstr(394, +3.969e+1, SHORTEN(-LONG 6.3**2));
+    tstr(395, +1.385019350059107e-8, SHORTEN(LONG 37.3**-5));
+    a:= 1;
+    FOR i FROM 1 BY 1 TO 10
+    DO  tsti(396, a, (-1)**(i-1)); a:= -a OD;
+    a:= 0;
+    FOR i FROM 1 BY 1 TO 10
+    DO a := a + 1**30000 OD;
+    tsti(397, +10, a)
+END;
+
+puts("Test: SHORTEN, LENG\n");
+BEGIN
+    LONG INT a1 = LONG 128; LONG INT a2;
+    LONG REAL a3 = LONG 1.9999999999; LONG REAL a4;
+    REAL a6;
+    INT a5; a5 := 30000;
+    a6 := 2/3;
+    tstli(398, +LONG 179, LENG 179);
+    tsti(399, +19, SHORTEN LONG 19);
+    tsti(400, +30000, SHORTEN LONG 30000);
+    tsti(401, -27, SHORTEN-LONG 27);
+    tsti(402, -30000, SHORTEN-LONG 30000);
+    tsti(403, +128, SHORTEN a1);
+    a2:=LONG 0;
+    tsti(404, +0, SHORTEN a2);
+    tsti(405, +30000, SHORTEN LENG a5);
+    tstr(406, +1.234566666e-1, SHORTEN LONG .1234566666);
+    tstr(407, +1.9999999999e+0, SHORTEN a3);
+    a4:=LONG .1111111111; tstr(408, +1.111111111e-1, SHORTEN a4);
+    tstr(409, -3.333333333333333e-1, SHORTEN-LENG (1/3));
+    tstr(410, +6.666666666666667e-1, SHORTEN LENG a6)
+END;
+
+puts("Test: ODD\n");
+BEGIN
+    IF ODD-1 THEN SKIP ELSE tste(411) FI;
+    tstb(412, FALSE, ODD 2);
+    IF NOT ODD-LONG 2 THEN SKIP ELSE tste(413) FI;
+    tstb(414, TRUE, ODD LONG 1);
+    BOOL a1, a2;
+    a1:= FALSE;
+    FOR i FROM -10 BY 1 TO 10
+    DO tstb(415, a1, ODD i); a1:= NOT a1 OD;
+    a1:=ODD-3;
+    a2:=ODD-LONG 0;
+    BOOL b1 = NOT ODD -13;
+    BOOL b2 = NOT NOT ODD -LONG 16;
+    tstb(416, TRUE, a1);
+    tstb(417, FALSE, a2);
+    tstb(418, FALSE, b1);
+    tstb(419, FALSE, b2);
+    tstb(420, FALSE, NOT NOT NOT ODD 55);
+    tstb(421, FALSE, NOT NOT NOT ODD LONG 1)
+END;
+
+puts("Test: SIGN\n");
+BEGIN
+    tsti(422, +1, SIGN 7);
+    tsti(423, +0, SIGN 0);
+    tsti(424, -1, SIGN-7);
+    tsti(425, +1, SIGN LONG 1000000000);
+    tsti(426, +0, SIGN LONG 0);
+    tsti(427, -1, SIGN-LONG 8);
+    tsti(428, +1, SIGN 1.9);
+    tsti(429, +0, SIGN 0.0);
+    tsti(430, -1, SIGN-3.6);
+    tsti(431, +1, SIGN LONG 67.0);
+    tsti(432, +0, SIGN LONG 0.0);
+    tsti(433, -1, SIGN-LONG 37.0)
+END;
+
+puts("Test: ROUND, ENTIER\n");
+BEGIN
+    REAL a1 = 1.7; LONG REAL a2 = LONG 27.7;
+    REAL a3; LONG REAL a4;
+    tstli(434, -LONG 28, LENG ROUND-27.7);
+    tstli(435, -LONG 28, LENG ENTIER-27.7);
+    tstli(436, +LONG 2, LENG ROUND a1);
+    tstli(437, +LONG 1, LENG ENTIER a1);
+    tstli(438, +LONG 13, LENG ROUND 12.9);
+    tstli(439, +LONG 12, LENG ENTIER 12.994);
+    a3:=134e+2; a4:=LONG 135.1e-1;
+    tstli(440, +LONG 13400, LENG ROUND a3);
+    tstli(441, +LONG 13400, LENG ENTIER a3);
+    tstli(442, +LONG 14, LENG ROUND SHORTEN a4);
+    tstli(443, +LONG 13, LENG ENTIER SHORTEN a4);
+    tstli(444, -LONG 1, ROUND-LENG 127e-2);
+    tstli(445, +LONG 1, ENTIER--LONG 127e-2);
+    tstli(446, +LONG 28, ROUND a2);
+    tstli(447, +LONG 27, ENTIER a2);
+    tstli(448, +LONG 13, ROUND LONG 12.87);
+    tstli(449, +LONG 12, ENTIER LONG 12.87);
+    tstli(450, +LONG 14, ROUND a4);
+    tstli(451, +LONG 13, ENTIER a4);
+    tstli(452, -LONG 2, ROUND-LONG 1.5001);
+    tstli(453, -LONG 2, ENTIER-LENG 1.5001);
+    tstli(454, +LONG 6, LENG ROUND 6.499)
+END;
+
+puts("Test: EQ, NE, LT, LE, GT, GE for chars\n");
+BEGIN
+    CHAR a = "1"; CHAR b = "2"; CHAR c; c := "1";
+    [1:1]CHAR d; d[1]:="$";
+    INT abs0 = ABS"0", abs1 = ABS"1", abs2 = ABS"2";
+
+    tstb(455, TRUE, "1"="1");
+    tstb(456, FALSE, "1"/="1");
+    tstb(457, TRUE, "1"<="1");
+    tstb(458, FALSE, "1"<"1");
+    tstb(459, TRUE, "1">="1");
+    tstb(460, FALSE, "1">"1");
+    tstb(461, FALSE, "1"="2");
+    tstb(462, TRUE, "1"/="2");
+    tstb(463, TRUE, "1"<="2");
+    tstb(464, TRUE, "1"<"2");
+    tstb(465, FALSE, "1">="2");
+    tstb(466, FALSE, "1">"2");
+    tstb(467, FALSE, "2"="1");
+    tstb(468, TRUE, "2"/="1");
+    tstb(469, FALSE, "2"<="1");
+    tstb(470, FALSE, "2"<"1");
+    tstb(471, TRUE, "2">="1");
+    tstb(472, TRUE, "2">"1");
+
+    tstb(473, TRUE, a=a);
+    tstb(474, FALSE, a/=a);
+    tstb(475, TRUE, a<=a);
+    tstb(476, FALSE, a<a);
+    tstb(477, TRUE, a>=a);
+    tstb(478, FALSE, a>a);
+    tstb(479, FALSE, a=b);
+    tstb(480, TRUE, a/=b);
+    tstb(481, TRUE, a<=b);
+    tstb(482, TRUE, a<b);
+    tstb(483, FALSE, a>=b);
+    tstb(484, FALSE, a>b);
+    tstb(485, FALSE, b=a);
+    tstb(486, TRUE, b/=a);
+    tstb(487, FALSE, b<=a);
+    tstb(488, FALSE, b<a);
+    tstb(489, TRUE, b>=a);
+    tstb(490, TRUE, b>a);
+
+    tstb(491, TRUE, REPR abs1=REPR abs1);
+    tstb(492, FALSE, REPR abs1/=REPR abs1);
+    tstb(493, TRUE, REPR abs1<=REPR abs1);
+    tstb(494, FALSE, REPR abs1<REPR abs1);
+    tstb(495, TRUE, REPR abs1>=REPR abs1);
+    tstb(496, FALSE, REPR abs1>REPR abs1);
+    tstb(497, FALSE, REPR abs1=REPR abs2);
+    tstb(498, TRUE, REPR abs1/=REPR abs2);
+    tstb(499, TRUE, REPR abs1<=REPR abs2);
+    tstb(500, TRUE, REPR abs1<REPR abs2);
+    tstb(501, FALSE, REPR abs1>=REPR abs2);
+    tstb(502, FALSE, REPR abs1>REPR abs2);
+    tstb(503, FALSE, REPR abs2=REPR abs1);
+    tstb(504, TRUE, REPR abs2/=REPR abs1);
+    tstb(505, FALSE, REPR abs2<=REPR abs1);
+    tstb(506, FALSE, REPR abs2<REPR abs1);
+    tstb(507, TRUE, REPR abs2>=REPR abs1);
+    tstb(508, TRUE, REPR abs2>REPR abs1);
+
+    tstb(509, TRUE, REPR abs1=c);
+    tstb(510, FALSE, REPR abs1/=c);
+    tstb(511, TRUE, REPR abs1<=c);
+    tstb(512, FALSE, REPR abs1<c);
+    tstb(513, TRUE, REPR abs1>=c);
+    tstb(514, FALSE, REPR abs1>c);
+    tstb(515, FALSE, REPR abs0=c);
+    tstb(516, TRUE, REPR abs0/=c);
+    tstb(517, TRUE, REPR abs0<=c);
+    tstb(518, TRUE, REPR abs0<c);
+    tstb(519, FALSE, REPR abs0>=c);
+    tstb(520, FALSE, REPR abs0>c);
+    tstb(521, FALSE, REPR abs2=c);
+    tstb(522, TRUE, REPR abs2/=c);
+    tstb(523, FALSE, REPR abs2<=c);
+    tstb(524, FALSE, REPR abs2<c);
+    tstb(525, TRUE, REPR abs2>=c);
+    tstb(526, TRUE, REPR abs2>c);
+
+    tstb(527, TRUE, c=REPR abs1);
+    tstb(528, FALSE, c/=REPR abs1);
+    tstb(529, TRUE, c<=REPR abs1);
+    tstb(530, FALSE, c<REPR abs1);
+    tstb(531, TRUE, c>=REPR abs1);
+    tstb(532, FALSE, c>REPR abs1);
+    tstb(533, FALSE, c=REPR abs0);
+    tstb(534, TRUE, c/=REPR abs0);
+    tstb(535, FALSE, c<=REPR abs0);
+    tstb(536, FALSE, c<REPR abs0);
+    tstb(537, TRUE, c>=REPR abs0);
+    tstb(538, TRUE, c>REPR abs0);
+    tstb(539, FALSE, c=REPR abs2);
+    tstb(540, TRUE, c/=REPR abs2);
+    tstb(541, TRUE, c<=REPR abs2);
+    tstb(542, TRUE, c<REPR abs2);
+    tstb(543, FALSE, c>=REPR abs2);
+    tstb(544, FALSE, c>REPR abs2);
+
+    tstb(545, TRUE, "$"=d[1]);
+    tstb(546, FALSE, "$"/=d[1]);
+    tstb(547, TRUE, "$"<=d[1]);
+    tstb(548, FALSE, "$"<d[1]);
+    tstb(549, TRUE, "$">=d[1]);
+    tstb(550, FALSE, "$">d[1]);
+    tstb(551, TRUE, "$"=d[1])
+END;
+   ASSERT (errors = 0)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/simp01.a68 b/gcc/testsuite/algol68/execute/mcts/simp01.a68
new file mode 100644
index 00000000000..d200be83d3b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp01.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# ALGOL68 test to see if the compiler exists #
+BEGIN INT i, j, k;
+      INT s := 17, INT t := 3;
+      i := 0;
+      FOR l FROM 0 BY 2 TO 13 DO i +:= l OD;
+      ASSERT (i = 42)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/simp02.a68 b/gcc/testsuite/algol68/execute/mcts/simp02.a68
new file mode 100644
index 00000000000..3e7c3027087
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp02.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+# Test that ranges are correct  #
+range_of_variables:
+BEGIN INT i, j;
+      i := 3; j := 4;
+      BEGIN INT i, k;
+            i := 2; k := 5;
+            ASSERT (i = 2);
+            ASSERT (k = 5)
+      END;
+      ASSERT (i = 3);
+      ASSERT (j = 4)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/simp03.a68 b/gcc/testsuite/algol68/execute/mcts/simp03.a68
new file mode 100644
index 00000000000..2fb0ca3c8f6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp03.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+# Referencing and dereferencing.  #
+BEGIN INT i1 := 1;
+      INT i2 := 2;
+      INT i3 := 3;
+      INT ii1 := i1;
+      INT ii2 := i2;
+      REF INT iii1 := ii1;
+      ASSERT (iii1 = 1);
+      iii1 := ii2;
+      ASSERT (iii1 = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/simp04.a68 b/gcc/testsuite/algol68/execute/mcts/simp04.a68
new file mode 100644
index 00000000000..0ca59a36fb0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp04.a68
@@ -0,0 +1,46 @@
+# { dg-options "-fstropping=upper" }  #
+# Multiple values.  #
+multiples:
+structures:
+BEGIN [1:100]INT i, j, k;
+      FOR l TO 100 DO i[l] := j[l] := k[l] := l OD;
+      FOR l TO 100
+      DO IF i[l] /= l OR j[l] /= l OR k[l] /= l
+         THEN ASSERT (FALSE)
+         FI
+      OD;
+      [1:100]REAL p;
+      p[1] := 1.0;
+      p[1:5] := (2.0, 3.0, 4.0, 5.0, 6.0);
+      FOR i FROM 1 TO 5 DO ASSERT (p[i] = REAL(i) + 1.0) OD;
+      # Test the @ workings  #
+      p[2:6 # Implicit @1 #] := (2.0, 3.0, 4.0, 5.0, 6.0);
+      FOR i FROM 2 TO 6 DO ASSERT (p[i] = REAL(i)) OD;
+      p[2:3@8] := p[3:4@8];
+      ASSERT (UPB p[1:3@9] = 11 AND UPB p[1:0@5] = 4);
+      [1:10,1:10] INT l;
+      FOR i TO 10 DO FOR j TO 10 DO l[i,j] := 10 OD OD;
+      FOR i TO  2 DO FOR j TO 10 DO l[1:2,1:10][i,j] := 11 OD OD;
+      FOR i TO 10 DO FOR j TO 10
+                     DO IF i >= 1 AND i <= 2
+                        THEN ASSERT (l[i,j] = 11)
+                        ELSE ASSERT (l[i,j] = 10)
+                        FI
+                     OD
+      OD;
+      # Structures.  #
+      STRUCT ([1:2] INT m,
+              [1:i[5] # Whose value is 5 from above.  #]REAL g,
+              BOOL t) s1, s2;
+      t OF s1 := t OF s2 := l[1,1] = l[1:1,1:2][1,1];
+      ASSERT (t OF s1 AND t OF s2);
+      FOR m TO UPB m OF s1
+      DO (m OF s1)[m] := ((m OF s2)[3-m] := 50) + 1 OD;
+      g OF s1 := (g OF s2)[] := (1.0, 2.0, 3.0, 4.0, 5.0);
+      ASSERT ((m OF s1)[1] = 51 AND (m OF s1)[2] = 51);
+      # REF STRUCT's  #
+      [1:2]REF STRUCT ([]INT m, []REAL g, BOOL t) ss1 := (s1, s2);
+      t OF ss1[2] := FALSE;
+      ASSERT (t OF s1 = TRUE);
+      ASSERT (t OF s2 = FALSE)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/simp05.a68 b/gcc/testsuite/algol68/execute/mcts/simp05.a68
new file mode 100644
index 00000000000..26092723a39
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp05.a68
@@ -0,0 +1,28 @@
+# { dg-options "-fstropping=upper" }  #
+# Simple jumps.  #
+(INT j:= 0, i;
+ k: i:= j;
+ IF i >= 2 THEN GOTO l FI;
+ puts ("0");
+ m: IF i >= 1 THEN n FI;
+ puts ("0");
+ o: GOTO p;
+ l: puts ("1"); i := i - 2; m;
+ n: puts ("1"); o;
+ p: puts ("");
+ j := j + 1;
+ IF j <= 3 THEN k FI)
+CO
+Result:
+  0
+  0
+
+  0
+  1
+
+  1
+  0
+
+  1
+  1
+CO
diff --git a/gcc/testsuite/algol68/execute/mcts/simp07.a68 b/gcc/testsuite/algol68/execute/mcts/simp07.a68
new file mode 100644
index 00000000000..308ce3affe6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp07.a68
@@ -0,0 +1,14 @@
+# { dg-options "-fstropping=upper" }  #
+# loops.  #
+BEGIN INT i = 5, INT c := 0;
+      FOR i TO i DO c +:= 1 OD;
+      ASSERT (c = 5);
+      INT s = 8;
+      FOR a FROM s BY 1 WHILE INT b = a - s + 1; a <= 2 * s
+      DO INT q := 0, r := a;
+         WHILE r >= b DO (q +:= 1, r -:=  b) OD;
+         IF a /= b * q +  r OR r >= b
+         THEN ASSERT (FALSE)
+         FI
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/simp08.a68 b/gcc/testsuite/algol68/execute/mcts/simp08.a68
new file mode 100644
index 00000000000..94e128e1a5e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp08.a68
@@ -0,0 +1,35 @@
+# { dg-options "-fstropping=upper" }  #
+# Simple coercions.  #
+BEGIN [1:3]INT ia := (1, 2, 3);
+      PROC get ia = REF[]INT: ia;
+      # Dereferencing.  #
+      INT i := LOC REF INT := ia[1]; # Twice dereferenced, at the right moment.  #
+      ASSERT (i = 1);
+      REF INT ri := ia[2]; # No deref  #
+      REF INT (ri) := -2;
+      ASSERT (ia[1] = 1 AND ia[2] = -2 AND ia[3] = 3);
+      # Deproceduring.  #
+      PROC pri = REF INT: ia[3]; pri := -3; # Soft deproc.  #
+      ASSERT (ia[1] = 1 AND ia[2] = -2 AND ia[3] = -3);
+      PROC pria = REF[]INT: ia; pria[1] := pria[2];
+      ASSERT (ia[1] = -2 AND ia[2] = -2 AND ia[3] = -3);
+      # Uniting.  #
+      UNION(REAL,[]INT,[,]INT) unia = # some uniting  #
+         UNION(REAL,[]INT) # cast  # # one uniting  # (ia); # deref  #
+      ia := (3,2,1); # spoil ia  #
+      CASE unia
+      IN ([]INT ia): (ASSERT (ia[1] = -2 AND ia[2] = -2 AND ia[3] = -3);
+                      ASSERT (get ia[1] = 3 AND get ia[2] = 2 AND get ia[3] = 1))
+      OUT SKIP
+      ESAC;
+      # Widening.  #
+      REAL x = ia[1];
+      ASSERT (x > 2.9 AND x < 3.1);
+      # Rowing.  #
+      [1:1,1:3] INT iaa; FOR i TO 3 DO iaa[1,i] := 5 + i OD;
+      # Hipping.  #
+      REF INT p = NIL, q = NIL;
+      ASSERT (p :=: q);
+      ia := (5, SKIP, 7); ia[2] := 6;
+      ASSERT (ia[1] = 5 AND ia[2] = 6 AND ia[3] = 7)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/simp09.a68 b/gcc/testsuite/algol68/execute/mcts/simp09.a68
new file mode 100644
index 00000000000..b71a57d2cdc
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp09.a68
@@ -0,0 +1,17 @@
+# { dg-options "-fstropping=upper" }  #
+# In "situ" permutation  #
+BEGIN PROC permvec = (REF[]INT vec, []INT p) VOID:
+         FOR j TO UPB p
+         DO INT k := p[j];
+            WHILE k > j DO k := p[k] OD;
+            IF k = j
+            THEN INT h = vec[j], INT l := p[k];
+                 WHILE l NE j
+                 DO vec[k] := vec[l]; k := l; l := p[k] OD;
+                 vec[k] := h
+            FI
+         OD,
+      [1:5]INT x := (4, 5, 1, 3, 2);
+      permvec (x, (3,5,4,1,2));
+      ASSERT (x[1] = 1 AND x[2] = 2 AND x[3] = 3 AND x[4] = 4 AND x[5] = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/simp10.a68 b/gcc/testsuite/algol68/execute/mcts/simp10.a68
new file mode 100644
index 00000000000..144df4b3647
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp10.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+(INT i := 1;
+    PROC a = (INT j) INT: i + j;
+    (INT i := 2; ASSERT (a(10) = 11)
+    )
+   )
diff --git a/gcc/testsuite/algol68/execute/mcts/simp11.a68 b/gcc/testsuite/algol68/execute/mcts/simp11.a68
new file mode 100644
index 00000000000..9fae8a392b7
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp11.a68
@@ -0,0 +1,36 @@
+# { dg-options "-fstropping=upper" }  #
+# Translation decimal number to Roman notation and vice versa  #
+BEGIN PROC roman = (INT number) STRING:
+      BEGIN INT n := number, STRING result;
+            []STRUCT(INT value, STRING r) table =
+               ((1000, "M"), (900, "CM"), (500, "D"), (400, "DC"),
+                (100, "C"), (90, "XC"), (50, "L"), (40, "XL"),
+                (10, "X"), (9, "IX"), (5, "V"), (4, "IV"), (1, "I"));
+            FOR i TO UPB table
+            DO INT v = value OF table[i], STRING r = r OF table[i];
+               WHILE v LE n DO (result +:= r, n -:= v) OD
+            OD;
+            result
+      END;
+
+      PROC value of roman = (STRING text) INT:
+      IF text = ""
+      THEN 0
+      ELSE OP ABS = (CHAR s) INT:
+              CASE INT p; char in string (s, p, "IVXLCDM"); p
+              IN 1, 5, 10, 50, 100, 500, 1000
+              ESAC,
+           PROC char in string = (CHAR c, REF INT i, STRING s) BOOL:
+              (FOR k TO UPB s DO (c = s[k] | i := k; l) OD; FALSE EXIT l: TRUE);
+           INT v, maxv := 0, maxp;
+           FOR p TO UPB text
+           DO IF (v := ABS text[p]) > maxv
+              THEN maxp := p; maxv := v
+              FI
+           OD;
+           maxv - value of roman (text[: maxp-1])+ value of roman (text[maxp + 1:])
+      FI;
+
+      ASSERT (roman (1968) = "MCMLXVIII");
+      ASSERT (value of roman ("MCMLXXIII") = 1973)
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/simp13.a68 b/gcc/testsuite/algol68/execute/mcts/simp13.a68
new file mode 100644
index 00000000000..9c2e204bbe5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/simp13.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+# Continued fraction.  #
+BEGIN OP / = ([]REAL a, b) REAL:
+         (UPB a = 0 | 0 | a[1]/(b[1] + a[2:]/b[2:])),
+      [1:20]REAL x,y;
+
+      FOR i TO 20
+      DO x[i] := (i-1)**2; y[i] := 2*i-1 OD;
+      x[1] := 1;
+      FOR i TO 20
+      DO 4 * (x[1:i]/y[1:i]) # Approximations of PI  #
+      OD
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/stow02.a68 b/gcc/testsuite/algol68/execute/mcts/stow02.a68
new file mode 100644
index 00000000000..e020cf9c5a1
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/stow02.a68
@@ -0,0 +1,15 @@
+# { dg-options "-fstropping=upper" }  #
+# Some slices #
+BEGIN [0:7][0:15] INT a;
+      INT n:= 0;
+
+      FOR i TO 8 DO FOR j TO 16 DO a[i-1][j-1]:= n+:=1OD OD;
+      ASSERT (a[0][15] = 16);
+      ASSERT (a[0:0 AT 0][0][15] = 16);
+      ASSERT (a[0:0 AT 0][0:0 AT 0][0][3:15][11:13 AT 2][4] = 16);
+CO XXX run-time error
+      []INT k = a[0:0][15] # wrong, a[0:0] has bounds [1:1][0:15],
+                             so there occurs overflow #;
+CO
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcts/stow06.a68 b/gcc/testsuite/algol68/execute/mcts/stow06.a68
new file mode 100644
index 00000000000..127914da5e4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcts/stow06.a68
@@ -0,0 +1,30 @@
+# { dg-options "-fstropping=upper" }  #
+# Against over-optimization of string comparison.  #
+BEGIN
+    STRING newline = "'n";
+    STRING str = "string with step > 1"; STRING ref str:= str;
+    [1:UPB str] STRUCT(REAL flub, CHAR c) rst;
+
+    puts ("Result must be:"
+           + newline + str + "." + newline + str + "." + newline
+           + "First test OK" + newline + "Second test OK" + newline
+           + newline + "Result is:" + newline);
+
+    FOR i TO UPB str DO c OF rst[i]:= ref str[i] OD;
+    puts (c OF rst +  "." + newline + ref str + "." + newline);
+
+    IF c OF rst = str AND c OF rst = ref str
+    THEN puts ("First test OK" + newline)
+    ELSE puts ("Erroneous string, is: " + c OF rst
+               + " , must be: " + str + newline);
+         ASSERT (FALSE)
+    FI;
+
+    c OF rst:= str;
+    IF c OF rst /= str OR c OF rst /= ref str
+    THEN puts ("Erroneous string, is: " + c OF rst
+               + " , must be: " + str + newline);
+         ASSERT (FALSE)
+    ELSE puts ("Second test OK" + newline)
+    FI
+END
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* [PATCH V4 47/47] a68: testsuite: mcgt tests
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (45 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 46/47] a68: testsuite: revised MC Algol 68 test set Jose E. Marchesi
@ 2025-10-18 21:51 ` Jose E. Marchesi
  2025-10-19 18:37 ` [PATCH V4 00/47] Algol 68 GCC Front-End Sam James
  47 siblings, 0 replies; 50+ messages in thread
From: Jose E. Marchesi @ 2025-10-18 21:51 UTC (permalink / raw)
  To: gcc-patches

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

gcc/testsuite/ChangeLog

	* algol68/compile/mcgt-1.3b.a68: New file.
	* algol68/compile/mcgt-7.1.3a-bis.a68: Likewise.
	* algol68/compile/mcgt-7.1.3a.a68: Likewise.
	* algol68/execute/mcgt/execute.exp: Likewise.
	* algol68/execute/mcgt/mcgt-1.3a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-1.3c.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.2.1a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.2.2a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.2.3a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.3a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.3b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.3c.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.3e.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.4.2a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.4.2b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.4.2c.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.4.3a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.6a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.6b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.7d.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.7e.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.8a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.8b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-2.9.1a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-3.5.1a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-3.5d.a68: Likewise.
	* algol68/execute/mcgt/mcgt-3.7.2a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-3.8.2a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-3.9.1b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.1.2a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.1.3a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.1.6a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.1.6b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.1.6c.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.2.6a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.2.6b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.2.6d.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.3.1a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.3.1b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-4.3.2a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-5.1.2a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-5.1.3a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-5.1.3c.a68: Likewise.
	* algol68/execute/mcgt/mcgt-5.1.5a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-6.2.2a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-6.2.2b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-6.2.2c.a68: Likewise.
	* algol68/execute/mcgt/mcgt-7.1.1a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-7.1.1b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-7.1.3a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-7.3.2a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-7.3.6a.a68: Likewise.
	* algol68/execute/mcgt/mcgt-7.3.6b.a68: Likewise.
	* algol68/execute/mcgt/mcgt-7.5.3a.a68: Likewise.
---
 gcc/testsuite/algol68/compile/mcgt-1.3b.a68   |  5 ++++
 .../algol68/compile/mcgt-7.1.3a-bis.a68       |  8 +++++
 gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68 |  8 +++++
 .../algol68/execute/mcgt/execute.exp          | 29 +++++++++++++++++++
 .../algol68/execute/mcgt/mcgt-1.3a.a68        |  4 +++
 .../algol68/execute/mcgt/mcgt-1.3c.a68        |  4 +++
 .../algol68/execute/mcgt/mcgt-2.2.1a.a68      |  4 +++
 .../algol68/execute/mcgt/mcgt-2.2.2a.a68      |  5 ++++
 .../algol68/execute/mcgt/mcgt-2.2.3a.a68      |  4 +++
 .../algol68/execute/mcgt/mcgt-2.3a.a68        |  5 ++++
 .../algol68/execute/mcgt/mcgt-2.3b.a68        |  5 ++++
 .../algol68/execute/mcgt/mcgt-2.3c.a68        |  6 ++++
 .../algol68/execute/mcgt/mcgt-2.3e.a68        |  5 ++++
 .../algol68/execute/mcgt/mcgt-2.4.2a.a68      |  6 ++++
 .../algol68/execute/mcgt/mcgt-2.4.2b.a68      | 11 +++++++
 .../algol68/execute/mcgt/mcgt-2.4.2c.a68      |  9 ++++++
 .../algol68/execute/mcgt/mcgt-2.4.3a.a68      |  4 +++
 .../algol68/execute/mcgt/mcgt-2.6a.a68        |  6 ++++
 .../algol68/execute/mcgt/mcgt-2.6b.a68        |  5 ++++
 .../algol68/execute/mcgt/mcgt-2.7d.a68        |  5 ++++
 .../algol68/execute/mcgt/mcgt-2.7e.a68        |  5 ++++
 .../algol68/execute/mcgt/mcgt-2.8a.a68        |  6 ++++
 .../algol68/execute/mcgt/mcgt-2.8b.a68        |  5 ++++
 .../algol68/execute/mcgt/mcgt-2.9.1a.a68      |  6 ++++
 .../algol68/execute/mcgt/mcgt-3.5.1a.a68      | 10 +++++++
 .../algol68/execute/mcgt/mcgt-3.5d.a68        |  9 ++++++
 .../algol68/execute/mcgt/mcgt-3.7.2a.a68      |  5 ++++
 .../algol68/execute/mcgt/mcgt-3.8.2a.a68      | 13 +++++++++
 .../algol68/execute/mcgt/mcgt-3.9.1b.a68      | 16 ++++++++++
 .../algol68/execute/mcgt/mcgt-4.1.2a.a68      |  7 +++++
 .../algol68/execute/mcgt/mcgt-4.1.3a.a68      |  9 ++++++
 .../algol68/execute/mcgt/mcgt-4.1.6a.a68      |  8 +++++
 .../algol68/execute/mcgt/mcgt-4.1.6b.a68      |  7 +++++
 .../algol68/execute/mcgt/mcgt-4.1.6c.a68      |  7 +++++
 .../algol68/execute/mcgt/mcgt-4.2.6a.a68      |  7 +++++
 .../algol68/execute/mcgt/mcgt-4.2.6b.a68      |  7 +++++
 .../algol68/execute/mcgt/mcgt-4.2.6d.a68      | 11 +++++++
 .../algol68/execute/mcgt/mcgt-4.3.1a.a68      |  7 +++++
 .../algol68/execute/mcgt/mcgt-4.3.1b.a68      | 15 ++++++++++
 .../algol68/execute/mcgt/mcgt-4.3.2a.a68      |  5 ++++
 .../algol68/execute/mcgt/mcgt-5.1.2a.a68      | 15 ++++++++++
 .../algol68/execute/mcgt/mcgt-5.1.3a.a68      | 12 ++++++++
 .../algol68/execute/mcgt/mcgt-5.1.3c.a68      | 29 +++++++++++++++++++
 .../algol68/execute/mcgt/mcgt-5.1.5a.a68      | 19 ++++++++++++
 .../algol68/execute/mcgt/mcgt-6.2.2a.a68      |  5 ++++
 .../algol68/execute/mcgt/mcgt-6.2.2b.a68      |  6 ++++
 .../algol68/execute/mcgt/mcgt-6.2.2c.a68      |  6 ++++
 .../algol68/execute/mcgt/mcgt-7.1.1a.a68      |  8 +++++
 .../algol68/execute/mcgt/mcgt-7.1.1b.a68      | 11 +++++++
 .../algol68/execute/mcgt/mcgt-7.1.3a.a68      |  8 +++++
 .../algol68/execute/mcgt/mcgt-7.3.2a.a68      | 11 +++++++
 .../algol68/execute/mcgt/mcgt-7.3.6a.a68      | 23 +++++++++++++++
 .../algol68/execute/mcgt/mcgt-7.3.6b.a68      | 12 ++++++++
 .../algol68/execute/mcgt/mcgt-7.5.3a.a68      |  8 +++++
 54 files changed, 476 insertions(+)
 create mode 100644 gcc/testsuite/algol68/compile/mcgt-1.3b.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcgt-7.1.3a-bis.a68
 create mode 100644 gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/execute.exp
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-1.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-1.3c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.3b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.3c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.3e.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.6a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.6b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.7d.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.7e.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.8a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.8b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-2.9.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.5.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.5d.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.7.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.8.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-3.9.1b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6d.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.5a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2c.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.3a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.2a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6a.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6b.a68
 create mode 100644 gcc/testsuite/algol68/execute/mcgt/mcgt-7.5.3a.a68

diff --git a/gcc/testsuite/algol68/compile/mcgt-1.3b.a68 b/gcc/testsuite/algol68/compile/mcgt-1.3b.a68
new file mode 100644
index 00000000000..80fc4a1c976
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcgt-1.3b.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+
+BEGIN REAL r := 10.0, circum, area;
+      circum := 2 * pi * r; area := pi * r * r
+END
diff --git a/gcc/testsuite/algol68/compile/mcgt-7.1.3a-bis.a68 b/gcc/testsuite/algol68/compile/mcgt-7.1.3a-bis.a68
new file mode 100644
index 00000000000..132f0c57972
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcgt-7.1.3a-bis.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Transient references and declarations.  #
+BEGIN FLEX[4,6]INT p;
+      # Illegal, cannot remember transient name.  #
+      REF[]INT q2 = p[3,]; # { dg-error "" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68 b/gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68
new file mode 100644
index 00000000000..be3f12ac7e3
--- /dev/null
+++ b/gcc/testsuite/algol68/compile/mcgt-7.1.3a.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+
+# Transient references and declarations.  #
+BEGIN FLEX[4,6]INT p;
+      # Illegal.  p cannot be deflexed since it is a REF FLEX.  #
+      REF[,]INT q3 = p; # { dg-error "" }  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/execute.exp b/gcc/testsuite/algol68/execute/mcgt/execute.exp
new file mode 100644
index 00000000000..f07333f483a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/execute.exp
@@ -0,0 +1,29 @@
+# Copyright (C) 2024 Free Software Foundation, Inc.
+
+# This program 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 of the License, or
+# (at your option) any later version.
+# 
+# This program 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/>.
+
+if $tracelevel then {
+    strace $tracelevel
+}
+
+load_lib algol68-torture.exp
+
+foreach testcase [lsort [glob -nocomplain $srcdir/$subdir/*.a68]] {
+    # If we're only testing specific files and this isn't one of them, skip it.
+    if ![runtest_file_p $runtests $testcase] then {
+	continue
+    }
+    algol68-torture-execute $testcase
+}
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3a.a68
new file mode 100644
index 00000000000..c99c25feb88
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3a.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN REAL e = 2.7182818284; REAL circum;
+      circum := 2 * pi * e
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3c.a68
new file mode 100644
index 00000000000..883d4e918ae
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-1.3c.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := 10, result;
+      result := n * (n + 1) * (2 * n + 1)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.1a.a68
new file mode 100644
index 00000000000..4179a8221d4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.1a.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+# Integer denotations.  #
+BEGIN 000; 43; 456; 0
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.2a.a68
new file mode 100644
index 00000000000..3bd34667dde
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.2a.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Real denotations.  #
+BEGIN .5; 0.5; 2.0; .001;
+      2.3e1; 2e0; 2e+0; 2e-0
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.3a.a68
new file mode 100644
index 00000000000..a9aa44c3199
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.2.3a.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+# Character denotations.  #
+BEGIN "X"; "a"; "1"; "."; " "
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3a.a68
new file mode 100644
index 00000000000..e8f403b119b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3a.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Identifiers.  #
+BEGIN INT circum, r, ibm, a1, log2, begin;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3b.a68
new file mode 100644
index 00000000000..be7368f24a9
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3b.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Identity declarations.  #
+BEGIN REAL e = 2.7182818284, log2 = 0.618, INT ten = 10, g = 32;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3c.a68
new file mode 100644
index 00000000000..676f9892bd8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3c.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Equivalent declarations.  #
+BEGIN REAL x = 2.34;
+      REF INT n = LOC INT, REF INT m = LOC INT;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3e.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3e.a68
new file mode 100644
index 00000000000..1a0dffe1e4b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.3e.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Initialisation.  #
+BEGIN CHAR firstchar := "A", lastchar := "Z", currentchar;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2a.a68
new file mode 100644
index 00000000000..f304b8f21b6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2a.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Ordinary division.  #
+BEGIN ASSERT (4/2 = 2.0);
+      INT a = 4, b = 7;
+      a/b # Yields a value of mode REAL.  #
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2b.a68
new file mode 100644
index 00000000000..ed0b0c48676
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2b.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+# Integer division.  The operator OVER (%) performs integer
+  division with truncation.  #
+BEGIN ASSERT (4 % 2 = 2);
+      ASSERT (4 OVER 2 = 2);
+      ASSERT (5 % 3 = 1);
+      ASSERT (5 OVER 3 = 1);
+      INT n = -5, m = -3;
+      ASSERT (n % 3 = -1);
+      ASSERT (n % m = 1)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2c.a68
new file mode 100644
index 00000000000..a63eb7eeb5c
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.2c.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+# Integer modulus.  The operator MOD (%*) performs integer modulus
+  with truncation.  #
+BEGIN ASSERT (0 MOD 4 = 0);
+      ASSERT (0 %* 4 = 0);
+      ASSERT (5 %* 3 = 2);
+      INT m = 5, n = -3;
+      ASSERT (m MOD n = 2)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.3a.a68
new file mode 100644
index 00000000000..d8707ee83a4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.4.3a.a68
@@ -0,0 +1,4 @@
+# { dg-options "-fstropping=upper" }  #
+# Exponentiation.  #
+BEGIN ASSERT (2 ** 3 = 8)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6a.a68
new file mode 100644
index 00000000000..68f8ee13ea4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6a.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Comparison operators.  #
+BEGIN REAL x = 2.7, y = 3.6, z = 4.7;
+      ASSERT (x < y);
+      ASSERT ("B" /= "C")
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6b.a68
new file mode 100644
index 00000000000..c61342f3ac0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.6b.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Comparison operators and boolean operators.  #
+BEGIN INT a = 4, b = 5, c = 9, REAL x = 4.7, y = 5.7, z = 6.7;
+      ASSERT (NOT (x + y < z) AND a + b = c)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7d.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7d.a68
new file mode 100644
index 00000000000..aa035f264e3
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7d.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Widening.  #
+BEGIN REAL x := 4, y := 7, z := 2.7;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7e.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7e.a68
new file mode 100644
index 00000000000..ad423a5a81e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.7e.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Dereferencing and widening.  #
+BEGIN INT n, REAL x = n;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8a.a68
new file mode 100644
index 00000000000..23d5e5158d4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8a.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Examples of assignations.  #
+BEGIN REAL pi = 3.14, e = 2.71, INT n = 10, REAL circum, INT result;
+      circum := 2 * pi * e;
+      result := n * (n + 1) * ( 2 * n + 1)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8b.a68
new file mode 100644
index 00000000000..1b5d642b8f8
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.8b.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Coercions and assignations.  #
+BEGIN REAL y, INT n, m := 1;
+      y := n % m
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-2.9.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.9.1a.a68
new file mode 100644
index 00000000000..e5e2e781591
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-2.9.1a.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Arithmetical assignment operators.  #
+BEGIN INT m, n := 4;
+      n PLUSAB 1;
+      ASSERT (n = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5.1a.a68
new file mode 100644
index 00000000000..85080ea3201
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5.1a.a68
@@ -0,0 +1,10 @@
+# { dg-options "-fstropping=upper" }  #
+# Equivalence.  #
+BEGIN INT m := 3; REF INT p = m;
+      ASSERT (m = 3 AND p = 3);
+      BEGIN INT m := 100;
+            ASSERT (m = 100 AND p = 3);
+            m -:= 1; p +:= 1
+      END;
+      ASSERT (m = 4 AND p = 4)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5d.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5d.a68
new file mode 100644
index 00000000000..5f02498ec82
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.5d.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+# On the availability and accessibility of space.  #
+BEGIN INT m := 3, INT five = 5;
+      ASSERT (m = 3);
+      BEGIN INT m := 100; CHAR five = "5";
+            m +:= 1
+      END;
+      ASSERT (m = 3 AND five = 5)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.7.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.7.2a.a68
new file mode 100644
index 00000000000..b6514eb8afe
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.7.2a.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT p := 10, q := 12;
+      FROM p TO q DO (p +:= 1, q +:= 1) OD;
+      ASSERT (p = 13 AND q = 15)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.8.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.8.2a.a68
new file mode 100644
index 00000000000..bfc67c9dbb6
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.8.2a.a68
@@ -0,0 +1,13 @@
+# { dg-options "-fstropping=upper" }  #
+# Using case clauses.  #
+BEGIN PROC is divisible = (INT m) BOOL:
+      BEGIN BOOL divisible := FALSE;
+            FOR i TO 4 WHILE NOT divisible
+            DO INT k = (i|3, 5, 7, 11);
+               divisible := m MOD k = 0
+            OD;
+            divisible
+      END;
+      ASSERT (is divisible (50));
+      ASSERT (is divisible (253))
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-3.9.1b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.9.1b.a68
new file mode 100644
index 00000000000..01ef062fb5f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-3.9.1b.a68
@@ -0,0 +1,16 @@
+# { dg-options "-fstropping=upper" }  #
+# Using jumps.  #
+BEGIN INT a, INT b = 0, c = 2, d = 10, BOOL e = TRUE;
+      CO The following program using jumps is equivalent to:
+         FOR a FROM b BY c TO d WHILE e DO SKIP OD
+      CO
+      BEGIN INT j := b, INT k = c, m = d;
+      next: IF (k > 0 AND j <= m) OR (k < 0 AND j >= m) OR k = 0
+            THEN INT i = j;
+                 IF e
+                 THEN SKIP; j +:= k; GOTO next
+                 FI
+            FI;
+            ASSERT (j = 12)
+      END
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.2a.a68
new file mode 100644
index 00000000000..98e43c62334
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.2a.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Monadic lwb and upb.  #
+BEGIN INT n := 4; [n]INT a;
+      ASSERT (UPB a = 4);
+      n := 6;
+      ASSERT (UPB a = 4)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.3a.a68
new file mode 100644
index 00000000000..b2592404700
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.3a.a68
@@ -0,0 +1,9 @@
+# { dg-options "-fstropping=upper" }  #
+# Dyadic lwb an upb.  #
+BEGIN [0:10,-4:100]REAL xx;
+      ASSERT (1 LWB xx = 0);
+      ASSERT (1 UPB xx = 10);
+      ASSERT (1 UPB xx = UPB xx);
+      ASSERT (2 LWB xx = -4);
+      ASSERT (2 UPB xx = 100)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6a.a68
new file mode 100644
index 00000000000..e17a9ccc17b
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6a.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN [4]REAL x2 := (6, 7, 8, 9);
+      ASSERT (x2[2] > 6.9);
+      ASSERT (x2[2] < 7.1);
+      x2 := (1, 1, 1, 1);
+      ASSERT(x2[2] > 0.9);
+      ASSERT(x2[2] < 1.1)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6b.a68
new file mode 100644
index 00000000000..09302dac5f2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6b.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Multi-dimensional row displays.  #
+BEGIN [2,3]INT aa := ((1,2,3),(4,5,6));
+      [2,3,4]REAL bb := (((1,2,3,4), (5,6,7,8), (9,10,11,12)),
+                         ((13,14,15,16),(17,18,19,20),(21,22,2,24)));
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6c.a68
new file mode 100644
index 00000000000..241e134bf72
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.1.6c.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Further row displays.  #
+BEGIN [4]INT a, b;
+      [4]INT c := a, d := (1,2,3,0);
+      [2,4]INT ab := (a,b), cd := ((0,0,0,0), b);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6a.a68
new file mode 100644
index 00000000000..ed1fa42771a
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6a.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN STRUCT (INT day, month, year) indep day = (4, 7, 1776);
+      ASSERT (day OF indep day = 4);
+      ASSERT (month OF indep day = 7);
+      ASSERT (year OF indep day = 1776);
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6b.a68
new file mode 100644
index 00000000000..2f1ad2021d4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6b.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN []STRUCT(CHAR letter, INT integer) roman
+        = (("I",1),("V",5),("X",10),("L",50),("C",100));
+      # XXX letter OF roman should be ("I","V","X","L","C")  #
+      # XXX integer OF roman whould be (1,5,10,50,100)  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6d.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6d.a68
new file mode 100644
index 00000000000..8718efd7cd5
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.2.6d.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+# Multiple values and structures.
+
+  Having strings of different lenghts would not be valid in a variable
+  declaration, but is acceptable in an identity declaration.
+#
+BEGIN []STRUCT ([]CHAR name, INT age) family =
+         (("JOHN", 3), ("ROBERT", 1), ("CATHERINE", 4));
+      SKIP
+END
+
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1a.a68
new file mode 100644
index 00000000000..0fae194fb22
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1a.a68
@@ -0,0 +1,7 @@
+# { dg-options "-fstropping=upper" }  #
+# Simple mode declarations.  #
+BEGIN MODE INTEGER = INT;
+      MODE Z = INT, R = REAL, B = BOOL, V = VOID;
+      MODE ARRAYA = [100]INT, ARRAYB = [10,2:9]REAL;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1b.a68
new file mode 100644
index 00000000000..d98d7ec117e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.1b.a68
@@ -0,0 +1,15 @@
+# { dg-options "-fstropping=upper" }  #
+# Dynamic arrays revisited.  #
+BEGIN INT p := 2, q := 10;
+      MODE M = [p:q]INT;
+      M a;
+      ASSERT (LWB a = 2 AND UPB a = 10);
+      q := 4;
+      M b;
+      ASSERT (LWB a = 2 AND UPB a = 10);
+      ASSERT (LWB b = 2 AND UPB b = 4);
+      M c = (1,2,3,4); # M is interpreted as formal declarer.
+                         Bounds are ignored.
+                       #
+      ASSERT (LWB c = 1 AND UPB c = 4)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.2a.a68
new file mode 100644
index 00000000000..039a661a62f
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-4.3.2a.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Rows of integers.  #
+BEGIN [][]INT g = ((1,2,3),(4,5),(6,7,8,9));
+      ASSERT (UPB g[1] = 3 AND UPB g[2] = 2 AND UPB g[3] = 4)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.2a.a68
new file mode 100644
index 00000000000..9d77795ad8d
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.2a.a68
@@ -0,0 +1,15 @@
+# { dg-options "-fstropping=upper" }  #
+# Procedure declarations I.  #
+BEGIN INT x = 10, y = 20, i = 2;
+      PROC xxx = (INT arg) INT: 10;
+      PROC yyy = (INT arg) INT: 20;
+      PROC zzz = (INT arg) INT: 30;
+      PROC(INT)INT f = IF x > y THEN xxx ELSE zzz FI,
+                   g = CASE i IN xxx, yyy, zzz ESAC;
+      PROC(INT)INT h := IF x < y THEN xxx ELSE yyy FI;
+      ASSERT (f (100) = 30);
+      ASSERT (g (200) = 20);
+      ASSERT (h (300) = 10);
+      h := yyy;
+      ASSERT (h (300) = 20)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3a.a68
new file mode 100644
index 00000000000..45efc9c8834
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3a.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+# Using the factorial function in a program #
+BEGIN PROC f = (INT n) INT:
+      BEGIN INT product := 1;
+            FOR i TO n DO product *:= i OD;
+            product
+      END;
+      ASSERT (f(0) = 1);
+      ASSERT (f(1) = 1);
+      ASSERT (f(2) = 2);
+      ASSERT (f(3) = 6)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3c.a68
new file mode 100644
index 00000000000..fcd93c85c44
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.3c.a68
@@ -0,0 +1,29 @@
+# { dg-options "-fstropping=upper" }  #
+# Procedure declarations III  #
+BEGIN # From the ALGOL68 Revised Report.  #
+      PROC my char in string = (CHAR c, REF INT i, []CHAR s) BOOL:
+      BEGIN BOOL found := FALSE;
+            FOR k FROM LWB s TO UPB s WHILE NOT found
+            DO (c = s[k] | i := k; found := TRUE) OD;
+            found
+      END;
+      ASSERT ((INT idx := 0;
+               my char in string ("o", idx, "foo")
+               ANDTH idx = 2));
+      ASSERT (my char in string ("x", LOC INT, "foo") = FALSE);
+      # Swapping function.  #
+      PROC swap = (REF INT a, b) VOID:
+         (INT r = a; a := b; b := r);
+      ASSERT ((INT x := 1, y := 2;
+               swap (x, y);
+               x = 2 AND y = 1));
+      # Euclid's algorithm.  #
+      PROC hcf = (INT m, n) INT:
+      BEGIN INT a := m, b := n;
+            IF a < b THEN swap (a, b) FI;
+            WHILE b /= 0
+            DO INT c = b; b := a MOD b; a := c OD;
+            a
+      END;
+      ASSERT (hcf (10, 20) = 10)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.5a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.5a.a68
new file mode 100644
index 00000000000..4f61bf02a23
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-5.1.5a.a68
@@ -0,0 +1,19 @@
+# { dg-options "-fstropping=upper" }  #
+# Recursive procedures.  #
+BEGIN PROC f = (INT m, n) INT:
+         IF n = 0
+         THEN m
+         ELIF m < n
+         THEN f (n, m)
+         ELSE m * f (m % n, n - 1) + n * f (m - 1, n)
+         FI;
+      f (10, 20);
+      PROC a = (INT m, n) INT:
+         IF m = 0
+         THEN  + 1
+         ELIF n = 0
+         THEN a (m - 1, 1)
+         ELSE a (m - 1, a (m, n - 1))
+         FI;
+      a (10, 20)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2a.a68
new file mode 100644
index 00000000000..b2bed32b302
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2a.a68
@@ -0,0 +1,5 @@
+# { dg-options "-fstropping=upper" }  #
+# Using AND and OR  #
+BEGIN ASSERT ((2r111 AND 2r101) = 2r101);
+      ASSERT ((16rff AND 2r111) = 16r7)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2b.a68
new file mode 100644
index 00000000000..b9a4730b9d0
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2b.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Comparing objects of mode BITS  #
+BEGIN ASSERT (2r1010 <= 2r1110);
+      ASSERT (4r331 >= 8r74);
+      ASSERT (NOT (2r100 >= 2r011))
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2c.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2c.a68
new file mode 100644
index 00000000000..79bfc97d9b4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-6.2.2c.a68
@@ -0,0 +1,6 @@
+# { dg-options "-fstropping=upper" }  #
+# Using BIN  #
+BEGIN ASSERT (BIN 7 = 2r111);
+      INT i = 22;
+      ASSERT ((BITS b = BIN i; ABS (b SHL 3) + ABS (b SHL 1)) = 220)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1a.a68
new file mode 100644
index 00000000000..efd948be807
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1a.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Declarations of flexible names.  #
+BEGIN FLEX[1:0]INT n;
+      ASSERT (LWB n = 1 AND UPB n = 0 AND ELEMS n = 0);
+      FLEX[4,6]INT p;
+      ASSERT (1 LWB p = 1 AND 1 UPB p = 4 AND 1 ELEMS p = 4
+              AND 2 LWB p = 1 AND 2 UPB p = 6 AND 2 ELEMS p = 6)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1b.a68
new file mode 100644
index 00000000000..3360c5eabc2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.1b.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+# Null row displays an string denotations.  #
+BEGIN FLEX[4]INT a, FLEX[4,6]INT b, FLEX[10]CHAR c;
+      a := ();
+      ASSERT (LWB a = 1 AND UPB a = 0);
+      b := ((),());
+      ASSERT (1 LWB b = 1 AND 1 UPB b = 2
+              AND 2 LWB b = 1 AND 2 UPB b = 0);
+      c := ();
+      c := ""
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.3a.a68
new file mode 100644
index 00000000000..b1bfdf737ca
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.1.3a.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Transient references and declarations.  #
+BEGIN FLEX[4,6]INT p;
+      []INT q1 = p[3,]; # Transient name is dereferenced giving []INT  #
+      REF FLEX[,]INT q5 = p; # p and q5 are different ways of accessing
+                               the same name.  #
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.2a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.2a.a68
new file mode 100644
index 00000000000..688bcac00ec
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.2a.a68
@@ -0,0 +1,11 @@
+# { dg-options "-fstropping=upper" }  #
+# Virtual declarers.  #
+BEGIN REF[]INT s;
+      STRUCT ([10]INT a, [4]REF[]INT b) c;
+      UNION (REF FLEX[]INT, PROC(INT)INT) f;
+      FLEX[4][3]INT a;
+      REF FLEX[][]INT aa = LOC FLEX[4][3]INT;
+      [4]FLEX[3]INT b;
+      REF[]FLEX[]INT bb = LOC[4]FLEX[3]INT;
+      SKIP
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6a.a68
new file mode 100644
index 00000000000..1fbf6a3772e
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6a.a68
@@ -0,0 +1,23 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN INT n := 3, m := 3;
+      REF INT w := n, z := n, REF INT y = n;
+      # Delivers TRUE since y and n deliver the same variable of mode REF
+        INT.  No coercions take place.
+      #
+      ASSERT (y :=: n);
+      # Delivers TRUE.  here w is dereferenced to yield n.  The right
+        hand side is taken to be strong since dereferencing cannot
+        occur in a soft position.
+      #
+      ASSERT (n :=: w);
+      # Similarly delivers TRUE.  Strong position is lhs.  #
+      ASSERT (w :=: n);
+      # Delivers TRUE.  No coercions take place.  #
+      ASSERT (y ISNT m);
+      # Delivers true.  w gets coerced to REF INT due to the strong
+        context introduced by the cast.  No further coercions take place.
+      #
+      ASSERT (REF INT (w) :=: z);
+      # Delives true.  No coercions take place.  #
+      ASSERT (w :/=: z)
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6b.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6b.a68
new file mode 100644
index 00000000000..479339d7485
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.3.6b.a68
@@ -0,0 +1,12 @@
+# { dg-options "-fstropping=upper" }  #
+BEGIN
+   [3]INT a := (1,2,3);
+
+   CO Comparing transient or flex names using an identity relation is
+      undefined.  Therefore, a[2:3] :=: a[2:3] is undefined.
+   CO
+
+   # But the following are defined.  #
+   ASSERT (a[1] :=: a[1]);
+   ASSERT (a[1] :/=: a[2])
+END
diff --git a/gcc/testsuite/algol68/execute/mcgt/mcgt-7.5.3a.a68 b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.5.3a.a68
new file mode 100644
index 00000000000..dfb8cd40460
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/mcgt/mcgt-7.5.3a.a68
@@ -0,0 +1,8 @@
+# { dg-options "-fstropping=upper" }  #
+# Declarations involving global generators.  #
+BEGIN REF REAL xx;
+      BEGIN REF REAL x = HEAP REAL := 4;
+            xx := x
+      END;
+      ASSERT (xx = 4)
+END
-- 
2.30.2


^ permalink raw reply	[flat|nested] 50+ messages in thread

* Re: [PATCH V4 00/47] Algol 68 GCC Front-End
  2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
                   ` (46 preceding siblings ...)
  2025-10-18 21:51 ` [PATCH V4 47/47] a68: testsuite: mcgt tests Jose E. Marchesi
@ 2025-10-19 18:37 ` Sam James
  2025-10-20  7:43   ` Richard Biener
  47 siblings, 1 reply; 50+ messages in thread
From: Sam James @ 2025-10-19 18:37 UTC (permalink / raw)
  To: Jose E. Marchesi; +Cc: gcc-patches, Richard Biener, Jakub Jelinek

"Jose E. Marchesi" <jose.marchesi@oracle.com> writes:

> [...]
>
> QUESTION: The remainding patches are specific to the Algol 68 support
> and do not touch common code/infrastructure.  Should I purse explicit
> reviews for these?

AFAIK no.

For cobol, I don't think we did that, and I don't think it
really makes sense to require it.

I know for cobol, richi, jakub & others did go over it to help with
"integration"-style issues because they explicitly asked for help on
identifying such problems, but that was less about approval per-se
and more about getting the code up to scratch.

richi or jakub can correct me if I'm wrong.

> [...]
> The compiler driver is called `ga68'.
> The compiler proper is called `a681'.
> The run-time library is called `libga68'.
>

I tried wiring this up in our packaging last night and am pleased to
report it built and installed correctly on the first attempt!

> [...]

sam

^ permalink raw reply	[flat|nested] 50+ messages in thread

* Re: [PATCH V4 00/47] Algol 68 GCC Front-End
  2025-10-19 18:37 ` [PATCH V4 00/47] Algol 68 GCC Front-End Sam James
@ 2025-10-20  7:43   ` Richard Biener
  0 siblings, 0 replies; 50+ messages in thread
From: Richard Biener @ 2025-10-20  7:43 UTC (permalink / raw)
  To: Sam James; +Cc: Jose E. Marchesi, gcc-patches, Richard Biener, Jakub Jelinek

On Sun, Oct 19, 2025 at 8:38 PM Sam James <sam@gentoo.org> wrote:
>
> "Jose E. Marchesi" <jose.marchesi@oracle.com> writes:
>
> > [...]
> >
> > QUESTION: The remainding patches are specific to the Algol 68 support
> > and do not touch common code/infrastructure.  Should I purse explicit
> > reviews for these?
>
> AFAIK no.

When the SC accepts Algol68 they should nominate you as a maintainer
for it as well, so no, you can self-approve.

> For cobol, I don't think we did that, and I don't think it
> really makes sense to require it.
>
> I know for cobol, richi, jakub & others did go over it to help with
> "integration"-style issues because they explicitly asked for help on
> identifying such problems, but that was less about approval per-se
> and more about getting the code up to scratch.
>
> richi or jakub can correct me if I'm wrong.

Correct.  I mostly looked at Cobols use of GENERIC and middle-end
interfaces, GTY and other stuff.  Jose is in a much better position here
given I trust him to be familiar enough with all this.  Or maybe a worse
position since I didn't plan to look at those parts (not before the end of
stage1 for sure) ;)

> > [...]
> > The compiler driver is called `ga68'.
> > The compiler proper is called `a681'.
> > The run-time library is called `libga68'.
> >
>
> I tried wiring this up in our packaging last night and am pleased to
> report it built and installed correctly on the first attempt!

I'll start with packaging only after it hits trunk, because I'm too lazy
even starting with GCC 16 packaging at this point (there's
"something" already, but not for Algol, obviously).

Richard.

> > [...]
>
> sam

^ permalink raw reply	[flat|nested] 50+ messages in thread

end of thread, other threads:[~2025-10-20  7:43 UTC | newest]

Thread overview: 50+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2025-10-18 21:51 [PATCH V4 00/47] Algol 68 GCC Front-End Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 01/47] a68: top-level misc files Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 02/47] a68: build system Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 03/47] a68: build system (regenerated files) Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 04/47] a68: documentation Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 05/47] a68: command-line options Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 06/47] a68: DWARF language codes Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 07/47] a68: darwin specific support Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 08/47] a68: powerpc " Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 09/47] a68: gcc/algol68 misc files Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 10/47] a68: ga68 compiler driver Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 11/47] a68: a681 compiler proper Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 12/47] a68: unicode support routines Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 13/47] a68: front-end diagnostics Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 14/47] a68: parser: entry point Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 15/47] a68: parser: AST nodes attributes/types Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 16/47] a68: parser: scanner Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 17/47] a68: parser: keyword tables management Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 18/47] a68: parser: top-down parser Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 19/47] a68: parser: parenthesis checker Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 20/47] a68: parser: bottom-up parser Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 21/47] a68: parser: syntax check for declarers Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 22/47] a68: parser: standard prelude definitions Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 23/47] a68: parser: parsing of modes Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 24/47] a68: parser: symbol table management Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 25/47] a68: parser: static scope checker Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 26/47] a68: parser: debug facilities Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 27/47] a68: parser: extraction of tags from phrases Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 28/47] a68: parser: dynamic stack usage in serial clauses Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 29/47] a68: low: lowering entry point and misc handlers Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 30/47] a68: low: plain values Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 31/47] a68: low: stowed values Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 32/47] a68: low: standard prelude Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 33/47] a68: low: clauses and declarations Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 34/47] a68: low: runtime Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 35/47] a68: low: builtins Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 36/47] a68: low: ranges Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 37/47] a68: low: units and coercions Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 38/47] a68: low: modes Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 39/47] a68: libga68: sources, spec and misc files Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 40/47] a68: libga68: build system Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 41/47] a68: libga68: build system (generated files) Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 42/47] a68: testsuite: infrastructure Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 43/47] a68: testsuite: execution tests 1/2 Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 44/47] a68: testsuite: execution tests 2/2 Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 45/47] a68: testsuite: compilation tests Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 46/47] a68: testsuite: revised MC Algol 68 test set Jose E. Marchesi
2025-10-18 21:51 ` [PATCH V4 47/47] a68: testsuite: mcgt tests Jose E. Marchesi
2025-10-19 18:37 ` [PATCH V4 00/47] Algol 68 GCC Front-End Sam James
2025-10-20  7:43   ` Richard Biener

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).