a68: low: plain values

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

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

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

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

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

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

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

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

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

gcc/algol68/a68-low-strings.cc

@@ -0,0 +1,399 @@
+/* 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.
+   NODE is used as the location for diagnostics in case the string breaks
+   contain some invalid data.  */
+
+char *
+a68_string_process_breaks (NODE_T *node, 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++;
+
+		    const char *begin = 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);
+		    if (n < 0)
+		      {
+			char *start = CHAR_IN_LINE (INFO (node)) + (begin - str);
+			a68_scan_error (LINE (INFO (node)), start,
+					"invalid Unicode codepoint in string literal");
+		      }
+
+		    offset += n;
+		  }
+		break;
+	      }
+	    default: gcc_unreachable ();
+	    }
+	}
+      else
+	{
+	  res[offset] = *p;
+	  offset += 1;
+	  p += 1;
+	}
+    }
+  res[offset] = '\0';
+
+  return res;
+}