[COMMITTED] algol68: emit run-time error when REPR fails
Jose E. Marchesi
jemarch@gnu.org
Thu Apr 3 21:42:18 GMT 2025
According to the Report:
OP REPR = (INT a) CHAR:
C that character 'x', if it exists, for
which ABS x = a C
We implement CHAR values to be Unicode code points, which are defined
in the ranges [U+0000,U+D7FF] and [U+E000,U+10FFFF].
This patch implements a run-time error in case REPR is passed an
integral value which is not a valid Unicode code point.
---
gcc/algol68/a68-low-chars.cc | 48 +++++++++++++++++++++++++++++----
gcc/algol68/a68-low-prelude.cc | 4 +--
gcc/algol68/a68-low-runtime.def | 1 +
gcc/algol68/a68.h | 2 +-
libga68/ga68-error.c | 13 +++++++++
libga68/ga68.h | 2 ++
6 files changed, 62 insertions(+), 8 deletions(-)
diff --git a/gcc/algol68/a68-low-chars.cc b/gcc/algol68/a68-low-chars.cc
index 0fce0ba3883..0e35f241a1d 100644
--- a/gcc/algol68/a68-low-chars.cc
+++ b/gcc/algol68/a68-low-chars.cc
@@ -43,14 +43,52 @@
#include "a68.h"
/* Given an integral value, if it denotes a char code build the corresponding
- CHAR. Otherwise raise an error. */
+ CHAR. Otherwise raise a run-time error. */
tree
-a68_char_repr (tree val)
+a68_char_repr (NODE_T *p, tree val)
{
- /* XXX check that the given value is within the CHAR range, i.e. the 21 bits
- of UCS-4 or a single byte. If not raise run-time error. */
- return fold_convert (a68_int_type, 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
diff --git a/gcc/algol68/a68-low-prelude.cc b/gcc/algol68/a68-low-prelude.cc
index 9ec2213fc82..7eaa1a7d58a 100644
--- a/gcc/algol68/a68-low-prelude.cc
+++ b/gcc/algol68/a68-low-prelude.cc
@@ -840,8 +840,8 @@ a68_lower_string_plusto3 (NODE_T *p, LOW_CTX_T ctx)
tree
a68_lower_repr2 (NODE_T *p, LOW_CTX_T ctx)
{
- tree op = a68_lower_tree (NEXT (SUB (p)), ctx);
- return fold_convert (CTYPE (MOID (p)), op);
+ NODE_T *op = NEXT (SUB (p));
+ return a68_char_repr (op, a68_lower_tree (op, ctx));
}
tree
diff --git a/gcc/algol68/a68-low-runtime.def b/gcc/algol68/a68-low-runtime.def
index dd34f11642c..386425085ca 100644
--- a/gcc/algol68/a68-low-runtime.def
+++ b/gcc/algol68/a68-low-runtime.def
@@ -44,6 +44,7 @@ DEF_A68_RUNTIME (SET_EXIT_STATUS, "_libga68_set_exit_status", RT(VOID), P1(INT),
DEF_A68_RUNTIME (MALLOC, "_libga68_malloc", RT(VOIDPTR), P1(SIZE), ECF_NOTHROW | ECF_LEAF)
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)
diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
index 9b06a3ddb8f..17764ef284f 100644
--- a/gcc/algol68/a68.h
+++ b/gcc/algol68/a68.h
@@ -590,7 +590,7 @@ char *a68_string_process_breaks (const char *str);
/* a68-low-chars.cc */
-tree a68_char_repr (tree val);
+tree a68_char_repr (NODE_T *p, tree val);
tree a68_char_abs (tree val);
/* a68-low-multiples.cc */
diff --git a/libga68/ga68-error.c b/libga68/ga68-error.c
index 0ca41f9a250..a0621099269 100644
--- a/libga68/ga68-error.c
+++ b/libga68/ga68-error.c
@@ -66,6 +66,19 @@ _libga68_derefnil (const char *filename, unsigned int lineno)
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
diff --git a/libga68/ga68.h b/libga68/ga68.h
index 962c21ec113..2e4ad88729f 100644
--- a/libga68/ga68.h
+++ b/libga68/ga68.h
@@ -36,6 +36,8 @@
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);
--
2.30.2
More information about the Algol68
mailing list