https://gcc.gnu.org/g:466a286c3369c7227b0bbbd2efe6c41671c58e48
commit r16-5753-g466a286c3369c7227b0bbbd2efe6c41671c58e48 Author: Jose E. Marchesi <[email protected]> Date: Sat Oct 11 19:51:55 2025 +0200 a68: low: plain values Signed-off-by: Jose E. Marchesi <[email protected]> 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. Diff: --- 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 | 399 ++++++++++++++++++++++++++ 9 files changed, 2135 insertions(+) diff --git a/gcc/algol68/a68-low-bits.cc b/gcc/algol68/a68-low-bits.cc new file mode 100644 index 000000000000..465969f9ade1 --- /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 000000000000..000e919407d9 --- /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 000000000000..244493475558 --- /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 000000000000..aed1c3c3dab6 --- /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 000000000000..d119de9a56bc --- /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 000000000000..cc43d52aa6bf --- /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 000000000000..ab0064a4855b --- /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 000000000000..ba9987b57ed8 --- /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 000000000000..f5822037e33b --- /dev/null +++ b/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; +}
