@@ -0,0 +1,623 @@
+/* m2except.cc implements the construction of exception trees.
+
+Copyright (C) 2012-2022 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius@glam.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 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.
+
+GNU Modula-2 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 GNU Modula-2; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#include "gcc-consolidation.h"
+
+#include "../m2-tree.h"
+
+#define GM2
+#define GM2_BUG_REPORT \
+ "Please report this crash to the GNU Modula-2 mailing list " \
+ "<gm2@nongnu.org>\n"
+
+/* External functions. */
+
+#define m2except_c
+#include "m2assert.h"
+#include "m2block.h"
+#include "m2decl.h"
+#include "m2expr.h"
+#include "m2statement.h"
+#include "m2tree.h"
+#include "m2treelib.h"
+#include "m2type.h"
+
+/* Local prototypes. */
+
+#include "m2except.h"
+
+static tree build_exc_ptr (location_t location);
+static tree do_begin_catch (location_t location);
+static tree do_end_catch (location_t location);
+static tree begin_handler (location_t location);
+static void finish_handler (location_t location, tree handler);
+static tree finish_handler_parms (location_t location, tree handler);
+static void finish_handler_sequence (tree try_block);
+static tree begin_try_block (location_t location);
+static tree finish_expr_stmt (location_t location, tree expr);
+static tree maybe_cleanup_point_expr_void (tree expr);
+static tree build_target_expr_with_type (location_t location, tree init,
+ tree type);
+static tree get_target_expr (location_t location, tree init);
+static tree build_eh_type_type (location_t location, tree type);
+static tree get_tinfo_decl_m2 (location_t location);
+static tree eh_type_info (location_t location, tree type);
+static tree build_address (tree t);
+
+void _M2_gm2except_init (void);
+void _M2_gm2except_finally (void);
+
+/* Exception handling library functions. */
+
+static GTY (()) tree fn_begin_catch_tree = NULL_TREE;
+static GTY (()) tree fn_end_catch_tree = NULL_TREE;
+static GTY (()) tree fn_throw_tree = NULL_TREE;
+static GTY (()) tree fn_rethrow_tree = NULL_TREE;
+static GTY (()) tree cleanup_type = NULL_TREE;
+static GTY (()) tree fn_allocate_exception_tree = NULL_TREE;
+static GTY (()) tree fn_free_exception_tree = NULL_TREE;
+static GTY (()) tree gm2_eh_int_type = NULL_TREE;
+
+/* Modula-2 linker fodder. */
+
+void
+_M2_gm2except_init (void)
+{
+}
+void
+_M2_gm2except_finally (void)
+{
+}
+
+/* InitExceptions - initialize this module, it declares the external
+ functions and assigns them to the appropriate global tree
+ variables. */
+
+void
+m2except_InitExceptions (location_t location)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+ m2block_pushGlobalScope ();
+ flag_exceptions = 1;
+ init_eh ();
+
+ m2decl_BuildStartFunctionDeclaration (FALSE);
+ fn_rethrow_tree = m2decl_BuildEndFunctionDeclaration (
+ location, location, "__cxa_rethrow", void_type_node, TRUE, FALSE, TRUE);
+ TREE_NOTHROW (fn_rethrow_tree) = 0;
+
+ m2decl_BuildStartFunctionDeclaration (FALSE);
+ m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
+ fn_begin_catch_tree = m2decl_BuildEndFunctionDeclaration (
+ location, location, "__cxa_begin_catch", ptr_type_node, TRUE, FALSE,
+ TRUE);
+ m2decl_BuildStartFunctionDeclaration (FALSE);
+ fn_end_catch_tree = m2decl_BuildEndFunctionDeclaration (
+ location, location, "__cxa_end_catch", void_type_node, TRUE, FALSE,
+ TRUE);
+ /* This can throw if the destructor for the exception throws. */
+ TREE_NOTHROW (fn_end_catch_tree) = 0;
+
+ /* The CLEANUP_TYPE is the internal type of a destructor. */
+ t = void_list_node;
+ t = tree_cons (NULL_TREE, ptr_type_node, t);
+ t = build_function_type (void_type_node, t);
+ cleanup_type = build_pointer_type (t);
+
+ /* Declare void __cxa_throw (void*, void*, void (*)(void*)). */
+ m2decl_BuildStartFunctionDeclaration (FALSE);
+ m2decl_BuildParameterDeclaration (location, NULL, cleanup_type, FALSE);
+ m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
+ m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
+ fn_throw_tree = m2decl_BuildEndFunctionDeclaration (
+ location, location, "__cxa_throw", void_type_node, TRUE, FALSE, TRUE);
+
+ /* Declare void __cxa_rethrow (void). */
+ m2decl_BuildStartFunctionDeclaration (FALSE);
+ fn_rethrow_tree = m2decl_BuildEndFunctionDeclaration (
+ location, location, "__cxa_rethrow", void_type_node, TRUE, FALSE, TRUE);
+
+ /* Declare void *__cxa_allocate_exception (size_t). */
+ m2decl_BuildStartFunctionDeclaration (FALSE);
+ m2decl_BuildParameterDeclaration (location, NULL, size_type_node, FALSE);
+ fn_allocate_exception_tree = m2decl_BuildEndFunctionDeclaration (
+ location, location, "__cxa_allocate_exception", ptr_type_node, TRUE,
+ FALSE, TRUE);
+
+ /* Declare void *__cxa_free_exception (void *). */
+ m2decl_BuildStartFunctionDeclaration (FALSE);
+ m2decl_BuildParameterDeclaration (location, NULL, ptr_type_node, FALSE);
+ fn_free_exception_tree = m2decl_BuildEndFunctionDeclaration (
+ location, location, "__cxa_free_exception", ptr_type_node, TRUE, FALSE,
+ TRUE);
+
+ /* Define integer type exception type which will match C++ int type
+ in the C++ runtime library. */
+ gm2_eh_int_type = build_eh_type_type (location, integer_type_node);
+ m2block_popGlobalScope ();
+
+ MARK_TS_TYPED (TRY_BLOCK);
+ MARK_TS_TYPED (THROW_EXPR);
+ MARK_TS_TYPED (HANDLER);
+ MARK_TS_TYPED (EXPR_STMT);
+}
+
+/* do_call0 - return a tree containing: call builtin_function (). */
+
+static tree
+do_call0 (location_t location, tree builtin_function)
+{
+ tree function = build_address (builtin_function);
+ tree fntype = TREE_TYPE (TREE_TYPE (function));
+ tree result_type = TREE_TYPE (fntype);
+
+ m2assert_AssertLocation (location);
+ return build_call_array_loc (location, result_type, function, 0, NULL);
+}
+
+/* do_call1 - return a tree containing: call builtin_function
+ (param1). */
+
+static tree
+do_call1 (location_t location, tree builtin_function, tree param1)
+{
+ tree *argarray = XALLOCAVEC (tree, 1);
+ tree function = build_address (builtin_function);
+ tree fntype = TREE_TYPE (TREE_TYPE (function));
+ tree result_type = TREE_TYPE (fntype);
+
+ m2assert_AssertLocation (location);
+ argarray[0] = param1;
+ return build_call_array_loc (location, result_type, function, 1, argarray);
+}
+
+/* do_call3 - return a tree containing: call builtin_function
+ (param1, param2, param3). */
+
+static tree
+do_call3 (location_t location, tree builtin_function, tree param1, tree param2,
+ tree param3)
+{
+ tree *argarray = XALLOCAVEC (tree, 3);
+ tree function = build_address (builtin_function);
+ tree fntype = TREE_TYPE (TREE_TYPE (function));
+ tree result_type = TREE_TYPE (fntype);
+
+ m2assert_AssertLocation (location);
+ argarray[0] = param1;
+ argarray[1] = param2;
+ argarray[2] = param3;
+ return build_call_array_loc (location, result_type, function, 3, argarray);
+}
+
+/* build_exc_ptr - creates the GCC internal type, pointer to
+ exception control block. */
+
+static tree
+build_exc_ptr (location_t location)
+{
+ m2assert_AssertLocation (location);
+ return do_call1 (location, builtin_decl_explicit (BUILT_IN_EH_POINTER),
+ integer_zero_node);
+}
+
+static tree
+get_tinfo_decl_m2 (location_t location)
+{
+ tree t = build_decl (location, VAR_DECL, get_identifier ("_ZTIi"),
+ ptr_type_node);
+
+ m2assert_AssertLocation (location);
+ TREE_STATIC (t) = 1;
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
+ DECL_ARTIFICIAL (t) = 1;
+ DECL_IGNORED_P (t) = 1;
+ m2block_pushDecl (t);
+ make_decl_rtl (t);
+ return t;
+}
+
+/* Return the type info for TYPE as used by EH machinery. */
+
+static tree
+eh_type_info (location_t location, tree type)
+{
+ m2assert_AssertLocation (location);
+ if (type == NULL_TREE || type == error_mark_node)
+ return type;
+
+ return get_tinfo_decl_m2 (location);
+}
+
+/* Return an ADDR_EXPR giving the address of T. This function
+ attempts no optimizations or simplifications; it is a low-level
+ primitive. */
+
+static tree
+build_address (tree t)
+{
+ tree addr = build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (t)), t);
+
+ return addr;
+}
+
+/* Build the address of a typeinfo decl for use in the runtime
+ matching field of the exception model. */
+
+static tree
+build_eh_type_type (location_t location, tree type)
+{
+ tree exp = eh_type_info (location, type);
+
+ m2assert_AssertLocation (location);
+ if (!exp)
+ return NULL;
+
+ TREE_USED (exp) = 1;
+
+ return convert (ptr_type_node, build_address (exp));
+}
+
+/* Build a TARGET_EXPR, initializing the DECL with the VALUE. */
+
+static tree
+build_target_expr (tree decl, tree value)
+{
+ tree t = build4 (TARGET_EXPR, TREE_TYPE (decl), decl, value, NULL_TREE,
+ NULL_TREE);
+
+ /* We always set TREE_SIDE_EFFECTS so that expand_expr does not
+ ignore the TARGET_EXPR. If there really turn out to be no
+ side-effects, then the optimizer should be able to get rid of
+ whatever code is generated anyhow. */
+ TREE_SIDE_EFFECTS (t) = 1;
+
+ return t;
+}
+
+/* Return an undeclared local temporary of type TYPE for use in
+ building a TARGET_EXPR. */
+
+static tree
+build_local_temp (location_t location, tree type)
+{
+ tree slot = build_decl (location, VAR_DECL, NULL_TREE, type);
+
+ m2assert_AssertLocation (location);
+ DECL_ARTIFICIAL (slot) = 1;
+ DECL_IGNORED_P (slot) = 1;
+ DECL_CONTEXT (slot) = current_function_decl;
+ layout_decl (slot, 0);
+ return slot;
+}
+
+/* Build a TARGET_EXPR using INIT to initialize a new temporary of
+ the indicated TYPE. */
+
+static tree
+build_target_expr_with_type (location_t location, tree init, tree type)
+{
+ tree slot;
+
+ m2assert_AssertLocation (location);
+ gcc_assert (!VOID_TYPE_P (type));
+
+ if (TREE_CODE (init) == TARGET_EXPR)
+ return init;
+
+ slot = build_local_temp (location, type);
+ return build_target_expr (slot, init);
+}
+
+/* Like build_target_expr_with_type, but use the type of INIT. */
+
+static tree
+get_target_expr (location_t location, tree init)
+{
+ m2assert_AssertLocation (location);
+ return build_target_expr_with_type (location, init, TREE_TYPE (init));
+}
+
+/* do_allocate_exception - returns a tree which calls
+ allocate_exception (sizeof (type)); */
+
+static tree
+do_allocate_exception (location_t location, tree type)
+{
+ return do_call1 (location, fn_allocate_exception_tree, size_in_bytes (type));
+}
+
+/* Call __cxa_free_exception from a cleanup. This is never invoked
+ directly, but see the comment for stabilize_throw_expr. */
+
+static tree
+do_free_exception (location_t location, tree ptr)
+{
+ return do_call1 (location, fn_free_exception_tree, ptr);
+}
+
+/* do_throw - returns tree for a call to throw (ptr, gm2_eh_int_type,
+ 0). */
+
+static tree
+do_throw (location_t location, tree ptr)
+{
+ return do_call3 (location, fn_throw_tree, ptr,
+ unshare_expr (gm2_eh_int_type),
+ build_int_cst (cleanup_type, 0));
+}
+
+/* do_rethrow - returns a tree containing the call to rethrow (). */
+
+static tree
+do_rethrow (location_t location)
+{
+ return do_call0 (location, fn_rethrow_tree);
+}
+
+/* gm2_build_throw - build a GCC throw expression tree which looks
+ identical to the C++ front end. */
+
+static tree
+gm2_build_throw (location_t location, tree exp)
+{
+ m2assert_AssertLocation (location);
+
+ if (exp == NULL_TREE)
+ /* Rethrow the current exception. */
+ exp = build1 (THROW_EXPR, void_type_node, do_rethrow (location));
+ else
+ {
+ tree object, ptr;
+ tree allocate_expr;
+ tree tmp;
+
+ exp = m2expr_FoldAndStrip (
+ convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (exp)));
+ exp = m2expr_GetIntegerOne (location);
+
+ /* Allocate the space for the exception. */
+ allocate_expr = do_allocate_exception (location, TREE_TYPE (exp));
+ allocate_expr = get_target_expr (location, allocate_expr);
+ ptr = TARGET_EXPR_SLOT (allocate_expr);
+ TARGET_EXPR_CLEANUP (allocate_expr) = do_free_exception (location, ptr);
+ CLEANUP_EH_ONLY (allocate_expr) = 1;
+
+ object = build1 (NOP_EXPR, build_pointer_type (TREE_TYPE (exp)), ptr);
+ object = m2expr_BuildIndirect (location, object, TREE_TYPE (exp));
+
+ /* And initialize the exception object. */
+ exp = build2 (INIT_EXPR, TREE_TYPE (object), object, exp);
+
+ /* Prepend the allocation. */
+ exp = build2 (COMPOUND_EXPR, TREE_TYPE (exp), allocate_expr, exp);
+
+ /* Force all the cleanups to be evaluated here so that we don't have
+ to do them during unwinding. */
+ exp = build1 (CLEANUP_POINT_EXPR, void_type_node, exp);
+
+ tmp = do_throw (location, ptr);
+
+ /* Tack on the initialization stuff. */
+ exp = build2 (COMPOUND_EXPR, TREE_TYPE (tmp), exp, tmp);
+ exp = build1 (THROW_EXPR, void_type_node, exp);
+ }
+
+ SET_EXPR_LOCATION (exp, location);
+ return exp;
+}
+
+/* gccgm2_BuildThrow - builds a throw expression and return the tree. */
+
+tree
+m2except_BuildThrow (location_t location, tree expr)
+{
+ return gm2_build_throw (location, expr);
+}
+
+/* Build up a call to __cxa_begin_catch, to tell the runtime that the
+ exception has been handled. */
+
+static tree
+do_begin_catch (location_t location)
+{
+ return do_call1 (location, fn_begin_catch_tree, build_exc_ptr (location));
+}
+
+/* Build up a call to __cxa_end_catch, to destroy the exception
+ object for the current catch block if no others are currently using
+ it. */
+
+static tree
+do_end_catch (location_t location)
+{
+ tree cleanup = do_call0 (location, fn_end_catch_tree);
+
+ m2assert_AssertLocation (location);
+ TREE_NOTHROW (cleanup) = 1;
+ return cleanup;
+}
+
+/* BuildTryBegin - returns a tree representing the 'try' block. */
+
+tree
+m2except_BuildTryBegin (location_t location)
+{
+ m2assert_AssertLocation (location);
+ return begin_try_block (location);
+}
+
+/* BuildTryEnd - builds the end of the Try block and prepares for the
+ catch handlers. */
+
+void
+m2except_BuildTryEnd (tree try_block)
+{
+ TRY_STMTS (try_block) = m2block_pop_statement_list ();
+ TRY_HANDLERS (try_block) = m2block_begin_statement_list ();
+
+ /* Now ensure that all successive add_stmts adds to this statement
+ sequence. */
+ m2block_push_statement_list (TRY_HANDLERS (try_block));
+}
+
+/* BuildCatchBegin - creates a handler tree for the C++ statement
+ 'catch (...) {'. It returns the handler tree. */
+
+tree
+m2except_BuildCatchBegin (location_t location)
+{
+ tree handler = begin_handler (location);
+
+ m2assert_AssertLocation (location);
+ return finish_handler_parms (location, handler);
+}
+
+/* BuildCatchEnd - completes a try catch block. It returns the,
+ try_block, tree. It creates the C++ statement
+ '}' which matches the catch above. */
+
+tree
+m2except_BuildCatchEnd (location_t location, tree handler, tree try_block)
+{
+ m2assert_AssertLocation (location);
+ finish_handler (location, handler);
+ finish_handler_sequence (try_block);
+ return try_block;
+}
+
+/* Begin a handler. Returns a HANDLER if appropriate. */
+
+static tree
+begin_handler (location_t location)
+{
+ tree r;
+
+ m2assert_AssertLocation (location);
+ r = build_stmt (location, HANDLER, NULL_TREE, NULL_TREE);
+ add_stmt (location, r);
+
+ HANDLER_BODY (r) = m2block_begin_statement_list ();
+
+ /* Now ensure that all successive add_stmts adds to this
+ statement sequence. */
+ m2block_push_statement_list (HANDLER_BODY (r));
+ return r;
+}
+
+/* Finish a handler, which may be given by HANDLER. The BLOCKs are
+ the return value from the matching call to finish_handler_parms. */
+
+static void
+finish_handler (location_t location, tree handler)
+{
+ /* We might need to rethrow the exception if we reach the end.
+ use this code: finish_expr_stmt (build_throw (NULL_TREE)); */
+ tree body = m2block_pop_statement_list ();
+
+ m2assert_AssertLocation (location);
+ HANDLER_BODY (handler) = body;
+ HANDLER_BODY (handler) = build2 (TRY_FINALLY_EXPR, void_type_node, body,
+ do_end_catch (location));
+}
+
+/* Finish the handler-parameters for a handler, which may be given by
+ HANDLER. */
+
+static tree
+finish_handler_parms (location_t location, tree handler)
+{
+ m2assert_AssertLocation (location);
+ /* Equivalent to C++ catch (...). */
+ finish_expr_stmt (location, do_begin_catch (location));
+
+ HANDLER_TYPE (handler) = NULL_TREE;
+ return handler;
+}
+
+/* Finish a handler-sequence for a try-block, which may be given by
+ TRY_BLOCK. */
+
+static void
+finish_handler_sequence (tree try_block)
+{
+ TRY_HANDLERS (try_block) = m2block_pop_statement_list ();
+}
+
+/* Begin a try-block. Returns a newly-created TRY_BLOCK if
+ appropriate. */
+
+static tree
+begin_try_block (location_t location)
+{
+ tree r = build_stmt (location, TRY_BLOCK, NULL_TREE, NULL_TREE);
+
+ m2assert_AssertLocation (location);
+ TRY_STMTS (r) = m2block_begin_statement_list ();
+
+ /* Now ensure that all successive add_stmts adds to this statement
+ sequence. */
+ m2block_push_statement_list (TRY_STMTS (r));
+ return r;
+}
+
+/* Finish an expression-statement, whose EXPRESSION is as indicated. */
+
+static tree
+finish_expr_stmt (location_t location, tree expr)
+{
+ tree r = NULL_TREE;
+
+ m2assert_AssertLocation (location);
+ if (expr != NULL_TREE)
+ {
+ expr = build1 (CONVERT_EXPR, void_type_node, expr);
+
+ /* Simplification of inner statement expressions, compound exprs, etc
+ can result in us already having an EXPR_STMT. */
+ if (TREE_CODE (expr) != CLEANUP_POINT_EXPR)
+ {
+ if (TREE_CODE (expr) != EXPR_STMT)
+ expr = build_stmt (location, EXPR_STMT, expr);
+ expr = maybe_cleanup_point_expr_void (expr);
+ }
+ r = add_stmt (location, expr);
+ }
+
+ return r;
+}
+
+/* Like maybe_cleanup_point_expr except have the type of the new
+ expression be void so we don't need to create a temporary variable to
+ hold the inner expression. The reason why we do this is because the
+ original type might be an aggregate and we cannot create a temporary
+ variable for that type. */
+
+static tree
+maybe_cleanup_point_expr_void (tree expr)
+{
+ return fold_build_cleanup_point_expr (void_type_node, expr);
+}
+
+#include "gt-m2-m2except.h"
@@ -0,0 +1,4286 @@
+/* m2expr.cc provides an interface to GCC expression trees.
+
+Copyright (C) 2012-2022 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <gaius@glam.ac.uk>.
+
+This file is part of GNU Modula-2.
+
+GNU Modula-2 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.
+
+GNU Modula-2 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 GNU Modula-2; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#include "gcc-consolidation.h"
+
+#include "../gm2-lang.h"
+#include "../m2-tree.h"
+#include "m2convert.h"
+
+/* Prototypes. */
+
+#define m2expr_c
+#include "m2assert.h"
+#include "m2builtins.h"
+#include "m2convert.h"
+#include "m2decl.h"
+#include "m2expr.h"
+#include "m2options.h"
+#include "m2range.h"
+#include "m2statement.h"
+#include "m2tree.h"
+#include "m2treelib.h"
+#include "m2type.h"
+
+static void m2expr_checkRealOverflow (location_t location, enum tree_code code,
+ tree result);
+static tree checkWholeNegateOverflow (location_t location, tree i, tree lowest,
+ tree min, tree max);
+// static tree m2expr_Build4LogicalAnd (location_t location, tree a, tree b,
+// tree c, tree d);
+static tree m2expr_Build4LogicalOr (location_t location, tree a, tree b,
+ tree c, tree d);
+static tree m2expr_Build4TruthOrIf (location_t location, tree a, tree b,
+ tree c, tree d);
+static tree m2expr_Build4TruthAndIf (location_t location, tree a, tree b,
+ tree c, tree d);
+
+static int label_count = 0;
+static GTY (()) tree set_full_complement;
+
+/* CompareTrees returns -1 if e1 < e2, 0 if e1 == e2, and 1 if e1 > e2. */
+
+int
+m2expr_CompareTrees (tree e1, tree e2)
+{
+ return tree_int_cst_compare (m2expr_FoldAndStrip (e1),
+ m2expr_FoldAndStrip (e2));
+}
+
+/* FoldAndStrip return expression, t, after it has been folded (if
+ possible). */
+
+tree
+m2expr_FoldAndStrip (tree t)
+{
+ if (t != NULL)
+ {
+ t = fold (t);
+ if (TREE_CODE (t) == CONST_DECL)
+ return m2expr_FoldAndStrip (DECL_INITIAL (t));
+ }
+
+ return t;
+}
+
+/* StringLength returns an unsigned int which is the length of, string. */
+
+unsigned int
+m2expr_StringLength (tree string)
+{
+ return TREE_STRING_LENGTH (string);
+}
+
+/* CheckAddressToCardinal if op is a pointer convert it to the ADDRESS type. */
+
+static tree
+CheckAddressToCardinal (location_t location, tree op)
+{
+ if (m2type_IsAddress (TREE_TYPE (op)))
+ return m2convert_BuildConvert (location, m2type_GetCardinalAddressType (),
+ op, FALSE);
+ return op;
+}
+
+/* BuildTruthAndIf return TRUE if a && b. Retain order left to right. */
+
+static tree
+m2expr_BuildTruthAndIf (location_t location, tree a, tree b)
+{
+ return m2expr_build_binary_op (location, TRUTH_ANDIF_EXPR, a, b, FALSE);
+}
+
+/* BuildTruthOrIf return TRUE if a || b. Retain order left to right. */
+
+static tree
+m2expr_BuildTruthOrIf (location_t location, tree a, tree b)
+{
+ return m2expr_build_binary_op (location, TRUTH_ORIF_EXPR, a, b, FALSE);
+}
+
+/* BuildTruthNotIf inverts the boolean value of expr and returns the result. */
+
+static tree
+m2expr_BuildTruthNot (location_t location, tree expr)
+{
+ return m2expr_build_unary_op (location, TRUTH_NOT_EXPR, expr, FALSE);
+}
+
+/* BuildPostInc builds a post increment tree, the second operand is
+ always one. */
+
+static tree
+m2expr_BuildPostInc (location_t location, tree op)
+{
+ return m2expr_BuildAdd (location, op, build_int_cst (TREE_TYPE (op), 1), FALSE);
+}
+
+/* BuildPostDec builds a post decrement tree, the second operand is
+ always one. */
+
+static tree
+m2expr_BuildPostDec (location_t location, tree op)
+{
+ return m2expr_BuildSub (location, op, build_int_cst (TREE_TYPE (op), 1), FALSE);
+}
+
+/* BuildAddCheck builds an addition tree. */
+
+tree
+m2expr_BuildAddCheck (location_t location, tree op1, tree op2, tree lowest,
+ tree min, tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op_check (location, PLUS_EXPR, op1, op2, FALSE,
+ lowest, min, max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildAdd builds an addition tree. */
+
+tree
+m2expr_BuildAdd (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op (location, PLUS_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildSubCheck builds a subtraction tree. */
+
+tree
+m2expr_BuildSubCheck (location_t location, tree op1, tree op2, tree lowest,
+ tree min, tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op_check (location, MINUS_EXPR, op1, op2, FALSE,
+ lowest, min, max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildSub builds a subtraction tree. */
+
+tree
+m2expr_BuildSub (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op (location, MINUS_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildDivTrunc builds a trunc division tree. */
+
+tree
+m2expr_BuildDivTrunc (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op (location, TRUNC_DIV_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildDivTruncCheck builds a trunc division tree. */
+
+tree
+m2expr_BuildDivTruncCheck (location_t location, tree op1, tree op2, tree lowest,
+ tree min, tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op_check (location, TRUNC_DIV_EXPR, op1, op2, FALSE,
+ lowest, min, max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildModTruncCheck builds a trunc modulus tree. */
+
+tree
+m2expr_BuildModTruncCheck (location_t location, tree op1, tree op2, tree lowest,
+ tree min, tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op_check (location, TRUNC_MOD_EXPR, op1, op2, FALSE,
+ lowest, min, max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildModTrunc builds a trunc modulus tree. */
+
+tree
+m2expr_BuildModTrunc (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op (location, TRUNC_MOD_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildModCeilCheck builds a ceil modulus tree. */
+
+tree
+m2expr_BuildModCeilCheck (location_t location, tree op1, tree op2, tree lowest,
+ tree min, tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op_check (location, CEIL_MOD_EXPR, op1, op2, FALSE,
+ lowest, min, max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildModFloorCheck builds a trunc modulus tree. */
+
+tree
+m2expr_BuildModFloorCheck (location_t location, tree op1, tree op2, tree lowest,
+ tree min, tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op_check (location, FLOOR_MOD_EXPR, op1, op2, FALSE,
+ lowest, min, max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildDivCeil builds a ceil division tree. */
+
+tree
+m2expr_BuildDivCeil (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op (location, CEIL_DIV_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildDivCeilCheck builds a check ceil division tree. */
+
+tree
+m2expr_BuildDivCeilCheck (location_t location, tree op1, tree op2, tree lowest,
+ tree min, tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op_check (location, CEIL_DIV_EXPR, op1, op2, FALSE,
+ lowest, min, max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildModCeil builds a ceil modulus tree. */
+
+tree
+m2expr_BuildModCeil (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op (location, CEIL_MOD_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildDivFloor builds a floor division tree. */
+
+tree
+m2expr_BuildDivFloor (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op (location, FLOOR_DIV_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildDivFloorCheck builds a check floor division tree. */
+
+tree
+m2expr_BuildDivFloorCheck (location_t location, tree op1, tree op2, tree lowest,
+ tree min, tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op_check (location, FLOOR_DIV_EXPR, op1, op2, FALSE,
+ lowest, min, max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildRDiv builds a division tree (this should only be used for
+ REAL and COMPLEX types and NEVER for integer based types). */
+
+tree
+m2expr_BuildRDiv (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ t = m2expr_build_binary_op (location, RDIV_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildModFloor builds a modulus tree. */
+
+tree
+m2expr_BuildModFloor (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op (location, FLOOR_MOD_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildLSL builds and returns tree (op1 << op2). */
+
+tree
+m2expr_BuildLSL (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ t = m2expr_build_binary_op (location, LSHIFT_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildLSR builds and returns tree (op1 >> op2). */
+
+tree
+m2expr_BuildLSR (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ t = m2expr_build_binary_op (location, RSHIFT_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* createUniqueLabel returns a unique label which has been alloc'ed. */
+
+static char *
+createUniqueLabel (void)
+{
+ int size, i;
+ char *label;
+
+ label_count++;
+ i = label_count;
+ size = strlen (".LSHIFT") + 2;
+ while (i > 0)
+ {
+ i /= 10;
+ size++;
+ }
+ label = (char *)ggc_alloc_atomic (size);
+ sprintf (label, ".LSHIFT%d", label_count);
+ return label;
+}
+
+/* BuildLogicalShift builds the ISO Modula-2 SHIFT operator for a
+ fundamental data type. */
+
+void
+m2expr_BuildLogicalShift (location_t location, tree op1, tree op2, tree op3,
+ tree nBits ATTRIBUTE_UNUSED, int needconvert)
+{
+ tree res;
+
+ m2assert_AssertLocation (location);
+ op2 = m2expr_FoldAndStrip (op2);
+ op3 = m2expr_FoldAndStrip (op3);
+ if (TREE_CODE (op3) == INTEGER_CST)
+ {
+ op2 = m2convert_ToWord (location, op2);
+ if (tree_int_cst_sgn (op3) < 0)
+ res = m2expr_BuildLSR (
+ location, op2,
+ m2convert_ToWord (location,
+ m2expr_BuildNegate (location, op3, needconvert)),
+ needconvert);
+ else
+ res = m2expr_BuildLSL (location, op2, m2convert_ToWord (location, op3),
+ needconvert);
+ res = m2convert_BuildConvert (
+ location, m2tree_skip_type_decl (TREE_TYPE (op1)), res, FALSE);
+ m2statement_BuildAssignmentTree (location, op1, res);
+ }
+ else
+ {
+ char *labelElseName = createUniqueLabel ();
+ char *labelEndName = createUniqueLabel ();
+ tree is_less = m2expr_BuildLessThan (location,
+ m2convert_ToInteger (location, op3),
+ m2expr_GetIntegerZero (location));
+
+ m2statement_DoJump (location, is_less, NULL, labelElseName);
+ op2 = m2convert_ToWord (location, op2);
+ op3 = m2convert_ToWord (location, op3);
+ res = m2expr_BuildLSL (location, op2, op3, needconvert);
+ res = m2convert_BuildConvert (
+ location, m2tree_skip_type_decl (TREE_TYPE (op1)), res, FALSE);
+ m2statement_BuildAssignmentTree (location, op1, res);
+ m2statement_BuildGoto (location, labelEndName);
+ m2statement_DeclareLabel (location, labelElseName);
+ res = m2expr_BuildLSR (location, op2,
+ m2expr_BuildNegate (location, op3, needconvert),
+ needconvert);
+ res = m2convert_BuildConvert (
+ location, m2tree_skip_type_decl (TREE_TYPE (op1)), res, FALSE);
+ m2statement_BuildAssignmentTree (location, op1, res);
+ m2statement_DeclareLabel (location, labelEndName);
+ }
+}
+
+/* BuildLRL builds and returns tree (op1 rotate left by op2 bits). */
+
+tree
+m2expr_BuildLRL (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ t = m2expr_build_binary_op (location, LROTATE_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildLRR builds and returns tree (op1 rotate right by op2 bits). */
+
+tree
+m2expr_BuildLRR (location_t location, tree op1, tree op2, int needconvert)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ t = m2expr_build_binary_op (location, RROTATE_EXPR, op1, op2, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* m2expr_BuildMask returns a tree for the mask of a set of nBits.
+ It assumes nBits is <= TSIZE (WORD). */
+
+tree
+m2expr_BuildMask (location_t location, tree nBits, int needconvert)
+{
+ tree mask = m2expr_BuildLSL (location, m2expr_GetIntegerOne (location),
+ nBits, needconvert);
+ m2assert_AssertLocation (location);
+ return m2expr_BuildSub (location, mask, m2expr_GetIntegerOne (location),
+ needconvert);
+}
+
+/* m2expr_BuildLRotate returns a tree in which op1 has been left
+ rotated by nBits. It assumes nBits is <= TSIZE (WORD). */
+
+tree
+m2expr_BuildLRotate (location_t location, tree op1, tree nBits,
+ int needconvert)
+{
+ tree t;
+
+ op1 = m2expr_FoldAndStrip (op1);
+ nBits = m2expr_FoldAndStrip (nBits);
+ t = m2expr_build_binary_op (location, LROTATE_EXPR, op1, nBits, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* m2expr_BuildRRotate returns a tree in which op1 has been left
+ rotated by nBits. It assumes nBits is <= TSIZE (WORD). */
+
+tree
+m2expr_BuildRRotate (location_t location, tree op1, tree nBits,
+ int needconvert)
+{
+ tree t;
+
+ op1 = m2expr_FoldAndStrip (op1);
+ nBits = m2expr_FoldAndStrip (nBits);
+ t = m2expr_build_binary_op (location, RROTATE_EXPR, op1, nBits, needconvert);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildLRLn builds and returns tree (op1 rotate left by op2 bits) it
+ rotates a set of size, nBits. */
+
+tree
+m2expr_BuildLRLn (location_t location, tree op1, tree op2, tree nBits,
+ int needconvert)
+{
+ tree op2min;
+
+ m2assert_AssertLocation (location);
+
+ /* Ensure we wrap the rotate. */
+
+ op2min = m2expr_BuildModTrunc (
+ location, m2convert_ToCardinal (location, op2),
+ m2convert_ToCardinal (location, nBits), needconvert);
+
+ /* Optimize if we are we going to rotate a TSIZE(BITSET) set. */
+
+ if (m2expr_CompareTrees (
+ m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset ()), nBits)
+ == 0)
+ return m2expr_BuildLRotate (location, op1, op2min, needconvert);
+ else
+ {
+ tree mask = m2expr_BuildMask (location, nBits, needconvert);
+ tree left, right;
+
+ /* Make absolutely sure there are no high order bits lying around. */
+
+ op1 = m2expr_BuildLogicalAnd (location, op1, mask, needconvert);
+ left = m2expr_BuildLSL (location, op1, op2min, needconvert);
+ left = m2expr_BuildLogicalAnd (location, left, mask, needconvert);
+ right = m2expr_BuildLSR (
+ location, op1,
+ m2expr_BuildSub (location, m2convert_ToCardinal (location, nBits),
+ op2min, needconvert),
+ needconvert);
+ return m2expr_BuildLogicalOr (location, left, right, needconvert);
+ }
+}
+
+/* BuildLRRn builds and returns tree (op1 rotate right by op2 bits).
+ It rotates a set of size, nBits. */
+
+tree
+m2expr_BuildLRRn (location_t location, tree op1, tree op2, tree nBits,
+ int needconvert)
+{
+ tree op2min;
+
+ m2assert_AssertLocation (location);
+
+ /* Ensure we wrap the rotate. */
+
+ op2min = m2expr_BuildModTrunc (
+ location, m2convert_ToCardinal (location, op2),
+ m2convert_ToCardinal (location, nBits), needconvert);
+ /* Optimize if we are we going to rotate a TSIZE(BITSET) set. */
+
+ if (m2expr_CompareTrees (
+ m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset ()), nBits)
+ == 0)
+ return m2expr_BuildRRotate (location, op1, op2min, needconvert);
+ else
+ {
+ tree mask = m2expr_BuildMask (location, nBits, needconvert);
+ tree left, right;
+
+ /* Make absolutely sure there are no high order bits lying around. */
+
+ op1 = m2expr_BuildLogicalAnd (location, op1, mask, needconvert);
+ right = m2expr_BuildLSR (location, op1, op2min, needconvert);
+ left = m2expr_BuildLSL (
+ location, op1,
+ m2expr_BuildSub (location, m2convert_ToCardinal (location, nBits),
+ op2min, needconvert),
+ needconvert);
+ left = m2expr_BuildLogicalAnd (location, left, mask, needconvert);
+ return m2expr_BuildLogicalOr (location, left, right, needconvert);
+ }
+}
+
+/* BuildLogicalRotate build the ISO Modula-2 ROTATE operator for a
+ fundamental data type. */
+
+void
+m2expr_BuildLogicalRotate (location_t location, tree op1, tree op2, tree op3,
+ tree nBits, int needconvert)
+{
+ tree res;
+
+ m2assert_AssertLocation (location);
+ op2 = m2expr_FoldAndStrip (op2);
+ op3 = m2expr_FoldAndStrip (op3);
+ if (TREE_CODE (op3) == INTEGER_CST)
+ {
+ if (tree_int_cst_sgn (op3) < 0)
+ res = m2expr_BuildLRRn (
+ location, op2, m2expr_BuildNegate (location, op3, needconvert),
+ nBits, needconvert);
+ else
+ res = m2expr_BuildLRLn (location, op2, op3, nBits, needconvert);
+ m2statement_BuildAssignmentTree (location, op1, res);
+ }
+ else
+ {
+ char *labelElseName = createUniqueLabel ();
+ char *labelEndName = createUniqueLabel ();
+ tree is_less = m2expr_BuildLessThan (location,
+ m2convert_ToInteger (location, op3),
+ m2expr_GetIntegerZero (location));
+
+ m2statement_DoJump (location, is_less, NULL, labelElseName);
+ res = m2expr_BuildLRLn (location, op2, op3, nBits, needconvert);
+ m2statement_BuildAssignmentTree (location, op1, res);
+ m2statement_BuildGoto (location, labelEndName);
+ m2statement_DeclareLabel (location, labelElseName);
+ res = m2expr_BuildLRRn (location, op2,
+ m2expr_BuildNegate (location, op3, needconvert),
+ nBits, needconvert);
+ m2statement_BuildAssignmentTree (location, op1, res);
+ m2statement_DeclareLabel (location, labelEndName);
+ }
+}
+
+/* buildUnboundedArrayOf construct an unbounded struct and returns
+ the gcc tree. The two fields of the structure are initialized to
+ contentsPtr and high. */
+
+static tree
+buildUnboundedArrayOf (tree unbounded, tree contentsPtr, tree high)
+{
+ tree fields = TYPE_FIELDS (unbounded);
+ tree field_list = NULL_TREE;
+ tree constructor;
+
+ field_list = tree_cons (fields, contentsPtr, field_list);
+ fields = TREE_CHAIN (fields);
+
+ field_list = tree_cons (fields, high, field_list);
+
+ constructor = build_constructor_from_list (unbounded, nreverse (field_list));
+ TREE_CONSTANT (constructor) = 0;
+ TREE_STATIC (constructor) = 0;
+
+ return constructor;
+}
+
+/* BuildBinarySetDo if the size of the set is <= TSIZE(WORD) then op1
+ := binop(op2, op3) else call m2rtsprocedure(op1, op2, op3). */
+
+void
+m2expr_BuildBinarySetDo (location_t location, tree settype, tree op1, tree op2,
+ tree op3, void (*binop) (location_t, tree, tree, tree,
+ tree, int),
+ int is_op1lvalue, int is_op2lvalue, int is_op3lvalue,
+ tree nBits, tree unbounded, tree varproc,
+ tree leftproc, tree rightproc)
+{
+ tree size = m2expr_GetSizeOf (location, settype);
+ int is_const = FALSE;
+ int is_left = FALSE;
+
+ m2assert_AssertLocation (location);
+
+ ASSERT_BOOL (is_op1lvalue);
+ ASSERT_BOOL (is_op2lvalue);
+ ASSERT_BOOL (is_op3lvalue);
+
+ if (m2expr_CompareTrees (
+ size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
+ <= 0)
+ /* Small set size <= TSIZE(WORD). */
+ (*binop) (location,
+ m2treelib_get_rvalue (location, op1, settype, is_op1lvalue),
+ m2treelib_get_rvalue (location, op2, settype, is_op2lvalue),
+ m2treelib_get_rvalue (location, op3, settype, is_op3lvalue),
+ nBits, FALSE);
+ else
+ {
+ tree result;
+ tree high = m2expr_BuildSub (
+ location,
+ m2convert_ToCardinal (
+ location,
+ m2expr_BuildDivTrunc (
+ location, size,
+ m2expr_GetSizeOf (location, m2type_GetBitsetType ()),
+ FALSE)),
+ m2expr_GetCardinalOne (location), FALSE);
+
+ /* If op3 is constant then make op3 positive and remember which
+ direction we are shifting. */
+
+ op3 = m2tree_skip_const_decl (op3);
+ if (TREE_CODE (op3) == INTEGER_CST)
+ {
+ is_const = TRUE;
+ if (tree_int_cst_sgn (op3) < 0)
+ op3 = m2expr_BuildNegate (location, op3, FALSE);
+ else
+ is_left = TRUE;
+ op3 = m2convert_BuildConvert (location, m2type_GetM2CardinalType (),
+ op3, FALSE);
+ }
+
+ /* These parameters must match the prototypes of the procedures:
+ ShiftLeft, ShiftRight, ShiftVal, RotateLeft, RotateRight, RotateVal
+ inside gm2-iso/SYSTEM.mod. */
+
+ /* Remember we must build the parameters in reverse. */
+
+ /* Parameter 4 amount. */
+ m2statement_BuildParam (
+ location,
+ m2convert_BuildConvert (
+ location, m2type_GetM2IntegerType (),
+ m2treelib_get_rvalue (location, op3,
+ m2tree_skip_type_decl (TREE_TYPE (op3)),
+ is_op3lvalue),
+ FALSE));
+
+ /* Parameter 3 nBits. */
+ m2statement_BuildParam (
+ location,
+ m2convert_BuildConvert (location, m2type_GetM2CardinalType (),
+ m2expr_FoldAndStrip (nBits), FALSE));
+
+ /* Parameter 2 destination set. */
+ m2statement_BuildParam (
+ location,
+ buildUnboundedArrayOf (
+ unbounded,
+ m2treelib_get_set_address (location, op1, is_op1lvalue), high));
+
+ /* Parameter 1 source set. */
+ m2statement_BuildParam (
+ location,
+ buildUnboundedArrayOf (
+ unbounded,
+ m2treelib_get_set_address (location, op2, is_op2lvalue), high));
+
+ /* Now call the appropriate procedure inside SYSTEM.mod. */
+ if (is_const)
+ if (is_left)
+ result = m2statement_BuildProcedureCallTree (location, leftproc,
+ NULL_TREE);
+ else
+ result = m2statement_BuildProcedureCallTree (location, rightproc,
+ NULL_TREE);
+ else
+ result = m2statement_BuildProcedureCallTree (location, varproc,
+ NULL_TREE);
+ add_stmt (location, result);
+ }
+}
+
+/* Print a warning if a constant expression had overflow in folding.
+ Invoke this function on every expression that the language requires
+ to be a constant expression. */
+
+void
+m2expr_ConstantExpressionWarning (tree value)
+{
+ if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST
+ || TREE_CODE (value) == FIXED_CST || TREE_CODE (value) == VECTOR_CST
+ || TREE_CODE (value) == COMPLEX_CST)
+ && TREE_OVERFLOW (value))
+ pedwarn (input_location, OPT_Woverflow, "overflow in constant expression");
+}
+
+/* TreeOverflow return TRUE if the contant expression, t, has caused
+ an overflow. No error message or warning is emitted and no
+ modification is made to, t. */
+
+int
+m2expr_TreeOverflow (tree t)
+{
+ if ((TREE_CODE (t) == INTEGER_CST
+ || (TREE_CODE (t) == COMPLEX_CST
+ && TREE_CODE (TREE_REALPART (t)) == INTEGER_CST))
+ && TREE_OVERFLOW (t))
+ return TRUE;
+ else if ((TREE_CODE (t) == REAL_CST
+ || (TREE_CODE (t) == COMPLEX_CST
+ && TREE_CODE (TREE_REALPART (t)) == REAL_CST))
+ && TREE_OVERFLOW (t))
+ return TRUE;
+ else
+ return FALSE;
+}
+
+/* RemoveOverflow if tree, t, is a constant expression it removes any
+ overflow flag and returns, t. */
+
+tree
+m2expr_RemoveOverflow (tree t)
+{
+ if (TREE_CODE (t) == INTEGER_CST
+ || (TREE_CODE (t) == COMPLEX_CST
+ && TREE_CODE (TREE_REALPART (t)) == INTEGER_CST))
+ TREE_OVERFLOW (t) = 0;
+ else if (TREE_CODE (t) == REAL_CST
+ || (TREE_CODE (t) == COMPLEX_CST
+ && TREE_CODE (TREE_REALPART (t)) == REAL_CST))
+ TREE_OVERFLOW (t) = 0;
+ return t;
+}
+
+/* BuildCoerce return a tree containing the expression, expr, after
+ it has been coersed to, type. */
+
+tree
+m2expr_BuildCoerce (location_t location, tree des, tree type, tree expr)
+{
+ tree copy = copy_node (expr);
+ TREE_TYPE (copy) = type;
+
+ m2assert_AssertLocation (location);
+
+ return m2treelib_build_modify_expr (location, des, NOP_EXPR, copy);
+}
+
+/* BuildTrunc return an integer expression from a REAL or LONGREAL op1. */
+
+tree
+m2expr_BuildTrunc (tree op1)
+{
+ return convert_to_integer (m2type_GetIntegerType (),
+ m2expr_FoldAndStrip (op1));
+}
+
+/* checkUnaryWholeOverflow decide if we can check this unary expression. */
+
+tree
+m2expr_checkUnaryWholeOverflow (location_t location, enum tree_code code,
+ tree arg, tree lowest, tree min, tree max)
+{
+ if (M2Options_GetWholeValueCheck () && (min != NULL))
+ {
+ lowest = m2tree_skip_type_decl (lowest);
+ arg = fold_convert_loc (location, lowest, arg);
+
+ switch (code)
+ {
+ case NEGATE_EXPR:
+ return checkWholeNegateOverflow (location, arg, lowest, min, max);
+ default:
+ return NULL;
+ }
+ }
+ return NULL;
+}
+
+/* build_unary_op return a unary tree node. */
+
+tree
+m2expr_build_unary_op_check (location_t location, enum tree_code code,
+ tree arg, tree lowest, tree min, tree max)
+{
+ tree argtype = TREE_TYPE (arg);
+ tree result;
+ tree check = NULL;
+
+ m2assert_AssertLocation (location);
+
+ arg = m2expr_FoldAndStrip (arg);
+
+ if ((TREE_CODE (argtype) != REAL_TYPE) && (min != NULL))
+ check = m2expr_checkUnaryWholeOverflow (location, code, arg, lowest, min, max);
+
+ result = build1 (code, argtype, arg);
+ protected_set_expr_location (result, location);
+
+ if (check != NULL)
+ result = build2 (COMPOUND_EXPR, argtype, check, result);
+
+ if (TREE_CODE (argtype) == REAL_TYPE)
+ m2expr_checkRealOverflow (location, code, result);
+
+ return m2expr_FoldAndStrip (result);
+}
+
+/* build_unary_op return a unary tree node. */
+
+tree
+m2expr_build_unary_op (location_t location, enum tree_code code, tree arg,
+ int flag ATTRIBUTE_UNUSED)
+{
+ tree argtype = TREE_TYPE (arg);
+ tree result;
+
+ m2assert_AssertLocation (location);
+
+ arg = m2expr_FoldAndStrip (arg);
+ result = build1 (code, argtype, arg);
+ protected_set_expr_location (result, location);
+
+ return m2expr_FoldAndStrip (result);
+}
+
+/* build_binary_op is a heavily pruned version of the one found in
+ c-typeck.cc. The Modula-2 expression rules are much more restricted
+ than C. */
+
+tree
+build_binary_op (location_t location, enum tree_code code, tree op1, tree op2,
+ int convert ATTRIBUTE_UNUSED)
+{
+ tree type1 = TREE_TYPE (op1);
+ tree result;
+
+ m2assert_AssertLocation (location);
+
+ /* Strip NON_LVALUE_EXPRs, etc., since we aren't using as an lvalue. */
+ STRIP_TYPE_NOPS (op1);
+ STRIP_TYPE_NOPS (op2);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ result = build2 (code, type1, op1, op2);
+ protected_set_expr_location (result, location);
+
+ return m2expr_FoldAndStrip (result);
+}
+
+/* BuildLessThanZero - returns a tree containing (< value 0). It
+ checks the min and max value to ensure that the test can be safely
+ achieved and will short circuit the result otherwise. */
+
+tree
+m2expr_BuildLessThanZero (location_t location, tree value, tree type, tree min,
+ tree max)
+{
+ if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) >= 0)
+ /* min is greater than or equal to zero therefore value will always
+ be >= 0. */
+ return m2expr_GetIntegerZero (location);
+ else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) == -1)
+ /* max is less than zero therefore value will always be < 0. */
+ return m2expr_GetIntegerOne (location);
+ /* We now know 0 lies in the range min..max so we can safely cast
+ zero to type. */
+ return m2expr_BuildLessThan (
+ location, value,
+ fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
+}
+
+/* BuildGreaterThanZero - returns a tree containing (> value 0). It
+ checks the min and max value to ensure that the test can be safely
+ achieved and will short circuit the result otherwise. */
+
+tree
+m2expr_BuildGreaterThanZero (location_t location, tree value, tree type,
+ tree min, tree max)
+{
+ if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) == 1)
+ /* min is greater than zero therefore value will always be > 0. */
+ return m2expr_GetIntegerOne (location);
+ else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) <= 0)
+ /* max is less than or equal to zero therefore value will always be
+ <= 0. */
+ return m2expr_GetIntegerZero (location);
+ /* We now know 0 lies in the range min..max so we can safely cast
+ zero to type. */
+ return m2expr_BuildGreaterThan (
+ location, value,
+ fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
+}
+
+/* BuildEqualToZero - returns a tree containing (= value 0). It
+ checks the min and max value to ensure that the test can be safely
+ achieved and will short circuit the result otherwise. */
+
+tree
+m2expr_BuildEqualToZero (location_t location, tree value, tree type, tree min,
+ tree max)
+{
+ if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) == 1)
+ /* min is greater than zero therefore value will always be > 0. */
+ return m2expr_GetIntegerZero (location);
+ else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
+ /* max is less than or equal to zero therefore value will always be <
+ 0. */
+ return m2expr_GetIntegerZero (location);
+ /* We now know 0 lies in the range min..max so we can safely cast
+ zero to type. */
+ return m2expr_BuildEqualTo (
+ location, value,
+ fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
+}
+
+/* BuildNotEqualToZero - returns a tree containing (# value 0). It
+ checks the min and max value to ensure that the test can be safely
+ achieved and will short circuit the result otherwise. */
+
+tree
+m2expr_BuildNotEqualToZero (location_t location, tree value, tree type,
+ tree min, tree max)
+{
+ if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) == 1)
+ /* min is greater than zero therefore value will always be true. */
+ return m2expr_GetIntegerOne (location);
+ else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
+ /* max is less than or equal to zero therefore value will always be
+ true. */
+ return m2expr_GetIntegerOne (location);
+ /* We now know 0 lies in the range min..max so we can safely cast
+ zero to type. */
+ return m2expr_BuildNotEqualTo (
+ location, value,
+ fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
+}
+
+
+/* BuildGreaterThanOrEqualZero - returns a tree containing (>= value 0). It
+ checks the min and max value to ensure that the test can be safely
+ achieved and will short circuit the result otherwise. */
+
+tree
+m2expr_BuildGreaterThanOrEqualZero (location_t location, tree value, tree type,
+ tree min, tree max)
+{
+ if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) >= 0)
+ /* min is greater than or equal to zero therefore value will always be >= 0. */
+ return m2expr_GetIntegerOne (location);
+ else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
+ /* max is less than zero therefore value will always be < 0. */
+ return m2expr_GetIntegerZero (location);
+ /* We now know 0 lies in the range min..max so we can safely cast
+ zero to type. */
+ return m2expr_BuildGreaterThan (
+ location, value,
+ fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
+}
+
+
+/* BuildLessThanOrEqualZero - returns a tree containing (<= value 0). It
+ checks the min and max value to ensure that the test can be safely
+ achieved and will short circuit the result otherwise. */
+
+tree
+m2expr_BuildLessThanOrEqualZero (location_t location, tree value, tree type,
+ tree min, tree max)
+{
+ if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) > 0)
+ /* min is greater than zero therefore value will always be > 0. */
+ return m2expr_GetIntegerZero (location);
+ else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) <= 0)
+ /* max is less than or equal to zero therefore value will always be <= 0. */
+ return m2expr_GetIntegerOne (location);
+ /* We now know 0 lies in the range min..max so we can safely cast
+ zero to type. */
+ return m2expr_BuildLessThanOrEqual (
+ location, value,
+ fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
+}
+
+
+/* get_current_function_name, return the name of the current function if
+ it currently exists. NULL is returned if we are not inside a function. */
+
+static const char *
+get_current_function_name (void)
+{
+ if (current_function_decl != NULL
+ && (DECL_NAME (current_function_decl) != NULL)
+ && (IDENTIFIER_POINTER (DECL_NAME (current_function_decl)) != NULL))
+ return IDENTIFIER_POINTER (DECL_NAME (current_function_decl));
+ return NULL;
+}
+
+/* checkWholeNegateOverflow - check to see whether -arg will overflow
+ an integer.
+
+PROCEDURE sneg (i: INTEGER) ;
+BEGIN
+ IF i = MIN(INTEGER)
+ THEN
+ 'integer overflow'
+ END
+END sneg ;
+
+general purpose subrange type, i, is currently legal, min is
+ MIN(type) and max is MAX(type).
+
+PROCEDURE sneg (i: type) ;
+BEGIN
+ max := MAX (type) ;
+ min := MIN (type) ;
+ (* cannot overflow if i is 0 *)
+ IF (i#0) AND
+ (* will overflow if entire range is positive. *)
+ ((min >= 0) OR
+ (* will overflow if entire range is negative. *)
+ (max <= 0) OR
+ (* c7 and c8 and c9 and c10 -> c17 more units positive. *)
+ ((min < 0) AND (max > 0) AND ((min + max) > 0) AND (i > -min)) OR
+ (* c11 and c12 and c13 and c14 -> c18 more units negative. *)
+ ((min < 0) AND (max > 0) AND ((min + max) < 0) AND (i < -max)))
+ THEN
+ 'type overflow'
+ END
+END sneg ; */
+
+static tree
+checkWholeNegateOverflow (location_t location,
+ tree i, tree type, tree min,
+ tree max)
+{
+ tree a1
+ = m2expr_BuildNotEqualToZero (location, i, type, min, max); /* i # 0. */
+ tree c1 = m2expr_BuildGreaterThanZero (location, min, type, min,
+ max); /* min > 0. */
+ tree c2 = m2expr_BuildEqualToZero (location, min, type, min,
+ max); /* min == 0. */
+ tree c4 = m2expr_BuildLessThanZero (location, max, type, min,
+ max); /* max < 0. */
+ tree c5 = m2expr_BuildEqualToZero (location, max, type, min,
+ max); /* max == 0. */
+ tree c7 = m2expr_BuildLessThanZero (location, min, type, min,
+ max); /* min < 0. */
+ tree c8 = m2expr_BuildGreaterThanZero (location, max, type, min,
+ max); /* max > 0. */
+ tree c9 = m2expr_BuildGreaterThanZero (
+ location, m2expr_BuildAdd (location, min, max, FALSE), type, min,
+ max); /* min + max > 0. */
+ tree c10 = m2expr_BuildGreaterThan (
+ location, i, m2expr_BuildNegate (location, min, FALSE)); /* i > -min. */
+ tree c11 = m2expr_BuildLessThanZero (
+ location, m2expr_BuildAdd (location, min, max, FALSE), type, min,
+ max); /* min + max < 0. */
+ tree c12 = m2expr_BuildLessThan (
+ location, i, m2expr_BuildNegate (location, max, FALSE)); /* i < -max. */
+
+ tree b1 = m2expr_BuildTruthOrIf (location, c1, c2);
+ tree b2 = m2expr_BuildTruthOrIf (location, c8, c5);
+ tree o1 = m2expr_BuildTruthAndIf (location, b1, b2);
+
+ tree b3 = m2expr_BuildTruthOrIf (location, c7, c2);
+ tree b4 = m2expr_BuildTruthOrIf (location, c4, c5);
+ tree o2 = m2expr_BuildTruthAndIf (location, b3, b4);
+
+ tree o3 = m2expr_Build4TruthAndIf (location, c7, c8, c9, c10);
+ tree o4 = m2expr_Build4TruthAndIf (location, c7, c8, c11, c12);
+
+ tree a2 = m2expr_Build4TruthOrIf (location, o1, o2, o3, o4);
+ tree condition
+ = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, a1, a2));
+
+ tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value unary minus will cause range overflow");
+ return t;
+}
+
+/* checkWholeAddOverflow - check to see whether op1 + op2 will
+ overflow an integer.
+
+PROCEDURE sadd (i, j: INTEGER) ;
+BEGIN
+ IF ((j>0) AND (i > MAX(INTEGER)-j)) OR ((j<0) AND (i < MIN(INTEGER)-j))
+ THEN
+ 'signed addition overflow'
+ END
+END sadd. */
+
+static tree
+checkWholeAddOverflow (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree j_gt_zero = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
+ tree i_gt_max_sub_j = m2expr_BuildGreaterThan (
+ location, i, m2expr_BuildSub (location, max, j, FALSE));
+ tree j_lt_zero = m2expr_BuildLessThanZero (location, j, lowest, min, max);
+ tree i_lt_min_sub_j = m2expr_BuildLessThan (location, i,
+ m2expr_BuildSub (location, min, j, FALSE));
+ tree lhs_or = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, j_gt_zero, i_gt_max_sub_j));
+ tree rhs_or = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, j_lt_zero, i_lt_min_sub_j));
+ tree condition
+ = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, lhs_or, rhs_or));
+ tree result = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value addition will cause a range overflow");
+ return result;
+}
+
+/* checkWholeSubOverflow - check to see whether op1 - op2 will
+ overflow an integer.
+
+PROCEDURE ssub (i, j: INTEGER) ;
+BEGIN
+ IF ((j>0) AND (i < MIN(INTEGER)+j)) OR ((j<0) AND (i > MAX(INTEGER)+j))
+ THEN
+ 'signed subtraction overflow'
+ END
+END ssub. */
+
+static tree
+checkWholeSubOverflow (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree c1 = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
+ tree c2 = m2expr_BuildLessThan (location, i,
+ m2expr_BuildAdd (location, min, j, FALSE));
+ tree c3 = m2expr_BuildLessThanZero (location, j, lowest, min, max);
+ tree c4 = m2expr_BuildGreaterThan (location, i,
+ m2expr_BuildAdd (location, max, j, FALSE));
+ tree c5 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, c1, c2));
+ tree c6 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, c3, c4));
+ tree condition
+ = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, c5, c6));
+ tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value subtraction will cause a range overflow");
+ return t;
+}
+
+/* Build4TruthAndIf - return TRUE if a && b && c && d. Retain order left to
+ * right. */
+
+static tree
+m2expr_Build4TruthAndIf (location_t location, tree a, tree b, tree c, tree d)
+{
+ tree t1 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, a, b));
+ tree t2 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, t1, c));
+ return m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, t2, d));
+}
+
+/* Build3TruthAndIf - return TRUE if a && b && c. Retain order left to right.
+ */
+
+static tree
+m2expr_Build3TruthAndIf (location_t location, tree op1, tree op2, tree op3)
+{
+ tree t = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, op1, op2));
+ return m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, t, op3));
+}
+
+/* Build3TruthOrIf - return TRUE if a || b || c. Retain order left to right.
+ */
+
+static tree
+m2expr_Build3TruthOrIf (location_t location, tree op1, tree op2, tree op3)
+{
+ tree t = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, op1, op2));
+ return m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, t, op3));
+}
+
+/* Build4TruthOrIf - return TRUE if op1 || op2 || op3 || op4. Retain order
+ left to right. */
+
+static tree
+m2expr_Build4TruthOrIf (location_t location, tree op1, tree op2, tree op3,
+ tree op4)
+{
+ tree t1 = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, op1, op2));
+ tree t2 = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, t1, op3));
+ return m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, t2, op4));
+}
+
+/* Build4LogicalOr - return TRUE if op1 || op2 || op3 || op4. */
+
+static tree
+m2expr_Build4LogicalOr (location_t location, tree op1, tree op2, tree op3,
+ tree op4)
+{
+ tree t1 = m2expr_FoldAndStrip (
+ m2expr_BuildLogicalOr (location, op1, op2, FALSE));
+ tree t2
+ = m2expr_FoldAndStrip (m2expr_BuildLogicalOr (location, t1, op3, FALSE));
+ return m2expr_FoldAndStrip (
+ m2expr_BuildLogicalOr (location, t2, op4, FALSE));
+}
+
+/* checkWholeMultOverflow - check to see whether i * j will overflow
+ an integer.
+
+PROCEDURE smult (lhs, rhs: INTEGER) ;
+BEGIN
+ IF ((lhs > 0) AND (rhs > 0) AND (lhs > max DIV rhs)) OR
+ ((lhs > 0) AND (rhs < 0) AND (rhs < min DIV lhs)) OR
+ ((lhs < 0) AND (rhs > 0) AND (lhs < min DIV rhs)) OR
+ ((lhs < 0) AND (rhs < 0) AND (lhs < max DIV rhs))
+ THEN
+ error ('signed multiplication overflow')
+ END
+END smult ;
+
+ if ((c1 && c3 && c4)
+ || (c1 && c5 && c6)
+ || (c2 && c3 && c7)
+ || (c2 && c5 && c8))
+ error ('signed subtraction overflow'). */
+
+static tree
+testWholeMultOverflow (location_t location, tree lhs, tree rhs,
+ tree lowest, tree min, tree max)
+{
+ tree c1 = m2expr_BuildGreaterThanZero (location, lhs, lowest, min, max);
+ tree c2 = m2expr_BuildLessThanZero (location, lhs, lowest, min, max);
+
+ tree c3 = m2expr_BuildGreaterThanZero (location, rhs, lowest, min, max);
+ tree c4 = m2expr_BuildGreaterThan (
+ location, lhs, m2expr_BuildDivTrunc (location, max, rhs, FALSE));
+
+ tree c5 = m2expr_BuildLessThanZero (location, rhs, lowest, min, max);
+ tree c6 = m2expr_BuildLessThan (
+ location, rhs, m2expr_BuildDivTrunc (location, min, lhs, FALSE));
+ tree c7 = m2expr_BuildLessThan (
+ location, lhs, m2expr_BuildDivTrunc (location, min, rhs, FALSE));
+ tree c8 = m2expr_BuildLessThan (
+ location, lhs, m2expr_BuildDivTrunc (location, max, rhs, FALSE));
+
+ tree c9 = m2expr_Build3TruthAndIf (location, c1, c3, c4);
+ tree c10 = m2expr_Build3TruthAndIf (location, c1, c5, c6);
+ tree c11 = m2expr_Build3TruthAndIf (location, c2, c3, c7);
+ tree c12 = m2expr_Build3TruthAndIf (location, c2, c5, c8);
+
+ tree condition = m2expr_Build4LogicalOr (location, c9, c10, c11, c12);
+ return condition;
+}
+
+
+static tree
+checkWholeMultOverflow (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree condition = testWholeMultOverflow (location, i, j, lowest, min, max);
+ tree result = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value multiplication will cause a range overflow");
+ return result;
+}
+
+
+static tree
+divMinUnderflow (location_t location, tree value, tree lowest, tree min, tree max)
+{
+ tree min2 = m2expr_BuildMult (location, min, min, FALSE);
+ tree rhs = m2expr_BuildGreaterThanOrEqual (location, value, min2);
+ tree lhs = testWholeMultOverflow (location, min, min, lowest, min, max);
+ return m2expr_BuildTruthAndIf (location, lhs, rhs);
+}
+
+/*
+ divexpr - returns true if a DIV_TRUNC b will overflow.
+ */
+
+/* checkWholeDivOverflow - check to see whether i DIV_TRUNC j will overflow
+ an integer. The Modula-2 implementation of the GCC trees follows:
+
+PROCEDURE divtruncexpr (a, b: INTEGER) : BOOLEAN ;
+BEGIN
+ (* Firstly catch division by 0. *)
+ RETURN ((b = 0) OR
+ (* Case 2 range is always negative. *)
+ (* In which case a division will be illegal as result will be positive. *)
+ (max < 0) OR
+ (* Case 1 both min / max are positive, check for underflow. *)
+ ((min >= 0) AND (max >= 0) AND (multMinOverflow (b) OR (a < b * min))) OR
+ (* Case 1 both min / max are positive, check for overflow. *)
+ ((min >= 0) AND (max >= 0) AND (divMinUnderflow (a) OR (b > a DIV min))) OR
+ (* Case 3 mixed range, need to check underflow. *)
+ ((min < 0) AND (max >= 0) AND (a < 0) AND (b < 0) AND (b >= a DIV min)) OR
+ ((min < 0) AND (max >= 0) AND (a < 0) AND (b > 0) AND (b <= a DIV max)) OR
+ ((min < 0) AND (max >= 0) AND (a >= 0) AND (b < 0) AND (a DIV b < min)))
+END divtruncexpr ;
+
+s1 -> a DIV min
+s2 -> a DIV max
+s3 -> a DIV b
+
+b4 -> (min >= 0) AND (max >= 0)
+b5 -> (min < 0) AND (max >= 0)
+a_lt_b_mult_min -> (a < b * min)
+b_mult_min_overflow -> testWholeMultOverflow (location, b, min, lowest, min, max)
+b6 -> (b_mult_min_overflow OR a_lt_b_mult_min)
+b_gt_s1 -> (b > s1)
+a_div_min_overflow -> divMinUnderflow (location, a, min, lowest, min, max)
+b7 -> (a_div_min_overflow OR b_gt_s1)
+b8 -> (a < 0)
+b9 -> (b < 0)
+b10 -> (b > 0)
+b11 -> (b >= s1)
+b12 -> (b <= s2)
+b13 -> (s3 < min)
+b14 -> a >= 0
+
+c1 -> (b = 0)
+c2 -> (max < 0)
+c3 -> (b4 AND b6)
+c4 -> (b4 AND b7)
+c5 -> (b5 AND b8 AND b9 AND b11)
+c6 -> (b5 AND b8 AND b10 AND b12)
+c7 -> (b5 AND b14 AND b9 AND b13)
+
+ if (c1 || c2 || c3 || c4 || c5 || c6 || c7)
+ error ('signed div trunc overflow'). */
+
+static tree
+checkWholeDivTruncOverflow (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree b4a = m2expr_BuildGreaterThanOrEqualZero (location, min, lowest, min, max);
+ tree b4b = m2expr_BuildGreaterThanOrEqualZero (location, max, lowest, min, max);
+ tree b4 = m2expr_BuildTruthAndIf (location, b4a, b4b);
+ tree b5a = m2expr_BuildLessThanZero (location, min, lowest, min, max);
+ tree b5 = m2expr_BuildTruthAndIf (location, b5a, b4b);
+ tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
+ tree c2 = m2expr_BuildLessThanZero (location, max, lowest, min, max);
+ tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, m2expr_BuildMult (location, j, min, FALSE));
+ tree j_mult_min_overflow = testWholeMultOverflow (location, j, min, lowest, min, max);
+ tree b6 = m2expr_BuildTruthOrIf (location, j_mult_min_overflow, i_lt_j_mult_min);
+ tree c3 = m2expr_BuildTruthAndIf (location, b4, b6);
+ tree s1 = m2expr_BuildDivTrunc (location, i, min, FALSE);
+ tree s2 = m2expr_BuildDivTrunc (location, i, max, FALSE);
+ tree s3 = m2expr_BuildDivTrunc (location, i, j, FALSE);
+
+ tree j_gt_s1 = m2expr_BuildGreaterThan (location, j, s1);
+ tree i_div_min_overflow = divMinUnderflow (location, i, lowest, min, max);
+ tree b7 = m2expr_BuildTruthOrIf (location, i_div_min_overflow, j_gt_s1);
+ tree c4 = m2expr_BuildTruthAndIf (location, b4, b7);
+ tree b8 = m2expr_BuildLessThanZero (location, i, lowest, min, max);
+ tree b9 = m2expr_BuildLessThanZero (location, j, lowest, min, max);
+ tree b10 = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
+ tree b11 = m2expr_BuildGreaterThanOrEqual (location, j, s1);
+ tree b12 = m2expr_BuildLessThanOrEqual (location, j, s2);
+ tree b13 = m2expr_BuildLessThan (location, s3, min);
+ tree b14 = m2expr_BuildGreaterThanOrEqualZero (location, i, lowest, min, max);
+ tree c5 = m2expr_Build4TruthAndIf (location, b5, b8, b9, b11);
+ tree c6 = m2expr_Build4TruthAndIf (location, b5, b8, b10, b12);
+ tree c7 = m2expr_Build4TruthAndIf (location, b5, b14, b9, b13);
+ tree c8 = m2expr_Build4TruthOrIf (location, c1, c2, c3, c4);
+ tree condition = m2expr_Build4TruthOrIf (location, c5, c6, c7, c8);
+ tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value truncated division will cause a range overflow");
+ return t;
+}
+
+#if 0
+(*
+ divexpr - returns true if a DIV_CEIL b will overflow.
+ *)
+
+(* checkWholeDivCeilOverflow - check to see whether i DIV_CEIL j will overflow
+ an integer. *)
+
+PROCEDURE divceilexpr (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ RETURN ((j = 0) OR (* division by zero. *)
+ (maxT < 0) OR (* both inputs are < 0 and max is < 0,
+ therefore error. *)
+ ((i # 0) AND (* first operand is legally zero,
+ result is also legally zero. *)
+ divCeilOverflowCases (i, j)))
+END divceilexpr ;
+
+
+(*
+ divCeilOverflowCases - precondition: i, j are in range values.
+ postcondition: TRUE is returned if i divceil will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divCeilOverflowCases (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ RETURN (((i > 0) AND (j > 0) AND divCeilOverflowPosPos (i, j)) OR
+ ((i < 0) AND (j < 0) AND divCeilOverflowNegNeg (i, j)) OR
+ ((i > 0) AND (j < 0) AND divCeilOverflowPosNeg (i, j)) OR
+ ((i < 0) AND (j > 0) AND divCeilOverflowNegPos (i, j)))
+END divCeilOverflowCases ;
+
+
+(*
+ divCeilOverflowPosPos - precondition: i, j are legal and are both >= 0.
+ postcondition: TRUE is returned if i divceil will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divCeilOverflowPosPos (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ RETURN (((i MOD j = 0) AND (i < j * minT)) OR
+ (((i MOD j # 0) AND (i < j * minT + 1))))
+END divCeilOverflowPosPos ;
+
+
+(*
+ divCeilOverflowNegNeg - precondition: i, j are in range values and both < 0.
+ postcondition: TRUE is returned if i divceil will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divCeilOverflowNegNeg (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ RETURN ((maxT <= 0) OR (* signs will cause overflow. *)
+ (* check for underflow. *)
+ ((ABS (i) MOD ABS (j) = 0) AND (i >= j * minT)) OR
+ ((ABS (i) MOD ABS (j) # 0) AND (i >= j * minT - 1)) OR
+ (* check for overflow. *)
+ (((ABS (i) MOD maxT) = 0) AND (ABS (i) DIV maxT > ABS (j))) OR
+ (((ABS (i) MOD maxT) # 0) AND (ABS (i) DIV maxT > ABS (j) + 1)))
+END divCeilOverflowNegNeg ;
+
+
+(*
+ divCeilOverflowNegPos - precondition: i, j are in range values. i < 0, j >= 0.
+ postcondition: TRUE is returned if i divceil will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divCeilOverflowNegPos (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ (* easier than might be initially expected. We know minT < 0 and maxT > 0.
+ We know the result will be negative and therefore we only need to test
+ against minT. *)
+ RETURN (((ABS (i) MOD j = 0) AND (i < j * minT)) OR
+ ((ABS (i) MOD j # 0) AND (i < j * minT - 1)))
+END divCeilOverflowNegPos ;
+
+
+(*
+ divCeilOverflowPosNeg - precondition: i, j are in range values. i >= 0, j < 0.
+ postcondition: TRUE is returned if i divceil will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divCeilOverflowPosNeg (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ (* easier than might be initially expected. We know minT < 0 and maxT > 0.
+ We know the result will be negative and therefore we only need to test
+ against minT. *)
+ RETURN (((i MOD ABS (j) = 0) AND (i > j * minT)) OR
+ ((i MOD ABS (j) # 0) AND (i > j * minT - 1)))
+END divCeilOverflowPosNeg ;
+#endif
+
+/* divCeilOverflowPosPos, precondition: lhs, rhs are legal and are both >= 0.
+ Postcondition: TRUE is returned if lhs divceil rhs will result
+ in an overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN (((lhs MOD rhs = 0) AND (min >= 0) AND (lhs < rhs * min)) OR (* check for underflow, no remainder. *)
+ lhs_lt_rhs_mult_min
+ (((lhs MOD rhs # 0) AND (lhs < rhs * min + 1)))) (* check for underflow with remainder. *)
+ ((lhs > min) AND (lhs - 1 > rhs * min))
+ lhs_gt_rhs_mult_min
+
+ a -> (lhs MOD rhs = 0) AND (lhs < rhs * min)
+ b -> (lhs MOD rhs # 0) AND (lhs < rhs * min + 1)
+ RETURN a OR b. */
+
+static tree
+divCeilOverflowPosPos (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree i_mod_j = m2expr_BuildModTrunc (location, i, j, FALSE);
+ tree i_mod_j_eq_zero = m2expr_BuildEqualToZero (location, i_mod_j, lowest, min, max);
+ tree i_mod_j_ne_zero = m2expr_BuildNotEqualToZero (location, i_mod_j, lowest, min, max);
+ tree j_min = m2expr_BuildMult (location, j, min, FALSE);
+ tree j_min_1 = m2expr_BuildAdd (location, j_min, m2expr_GetIntegerOne (location), FALSE);
+ tree i_lt_j_min = m2expr_BuildLessThan (location, i, j_min);
+ tree i_lt_j_min_1 = m2expr_BuildLessThan (location, i, j_min_1);
+ tree a = m2expr_BuildTruthAndIf (location, i_mod_j_eq_zero, i_lt_j_min);
+ tree b = m2expr_BuildTruthAndIf (location, i_mod_j_ne_zero, i_lt_j_min_1);
+ return m2expr_BuildTruthOrIf (location, a, b);
+}
+
+
+/* divCeilOverflowPosNeg precondition: i, j are in range values and i >=0, j < 0.
+ Postcondition: TRUE is returned if i divceil j will result in an
+ overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN (((i MOD ABS (j) = 0) AND (i > j * min)) OR
+ ((i MOD ABS (j) # 0) AND (i > j * min - 1)))
+
+ abs_j -> (ABS (j))
+ i_mod_abs_j -> (i MOD abs_j)
+ i_mod_abs_j_eq_0 -> (i_mod_abs_j = 0)
+ i_mod_abs_j_ne_0 -> (i_mod_abs_j # 0)
+ j_mult_min -> (j * min)
+ j_mult_min_1 -> (j_mult_min - 1)
+ i_gt_j_mult_min -> (i > j_mult_min)
+ i_gt_j_mult_min_1 -> (i > j_mult_min_1)
+ a -> (i_mod_abs_j_eq_0 AND i_gt_j_mult_min)
+ b -> (i_mod_abs_j_ne_0 AND i_gt_j_mult_min_1)
+ c -> (a OR b). */
+
+static tree
+divCeilOverflowPosNeg (location_t location, tree i, tree j, tree lowest, tree min, tree max)
+{
+ tree abs_j = m2expr_BuildAbs (location, j);
+ tree i_mod_abs_j = m2expr_BuildModFloor (location, i, abs_j, FALSE);
+ tree i_mod_abs_j_eq_0 = m2expr_BuildEqualToZero (location, i_mod_abs_j, lowest, min, max);
+ tree i_mod_abs_j_ne_0 = m2expr_BuildNotEqualToZero (location, i_mod_abs_j, lowest, min, max);
+ tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
+ tree j_mult_min_1 = m2expr_BuildPostDec (location, j_mult_min);
+ tree i_gt_j_mult_min = m2expr_BuildGreaterThan (location, i, j_mult_min);
+ tree i_gt_j_mult_min_1 = m2expr_BuildGreaterThan (location, i, j_mult_min_1);
+ tree a = m2expr_BuildTruthAndIf (location, i_mod_abs_j_eq_0, i_gt_j_mult_min);
+ tree b = m2expr_BuildTruthAndIf (location, i_mod_abs_j_ne_0, i_gt_j_mult_min_1);
+ tree c = m2expr_BuildTruthOrIf (location, a, b);
+ return c;
+}
+
+
+/* divCeilOverflowNegPos precondition: i, j are in range values and i < 0, j >= 0.
+ Postcondition: TRUE is returned if i divceil j will result in an
+ overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN (((ABS (i) MOD j = 0) AND (i < j * min)) OR
+ ((ABS (i) MOD j # 0) AND (i < j * min - 1)))
+
+ abs_i -> (ABS (i))
+ abs_i_mod_j -> (abs_i MOD j)
+ abs_i_mod_j_eq_0 -> (abs_i_mod_j = 0)
+ abs_i_mod_j_ne_0 -> (abs_i_mod_j # 0)
+ j_mult_min -> (j * min)
+ j_mult_min_1 -> (j_mult_min - 1)
+ i_lt_j_mult_min -> (i < j_mult_min)
+ i_lt_j_mult_min_1 -> (i < j_mult_min_1)
+ a = (abs_i_mod_j_eq_0 AND i_lt_j_mult_min)
+ b = (abs_i_mod_j_ne_0 AND i_lt_j_mult_min_1)
+ c -> (a OR b). */
+
+static tree
+divCeilOverflowNegPos (location_t location, tree i, tree j, tree lowest, tree min, tree max)
+{
+ tree abs_i = m2expr_BuildAbs (location, i);
+ tree abs_i_mod_j = m2expr_BuildModFloor (location, abs_i, j, FALSE);
+ tree abs_i_mod_j_eq_0 = m2expr_BuildEqualToZero (location, abs_i_mod_j, lowest, min, max);
+ tree abs_i_mod_j_ne_0 = m2expr_BuildNotEqualToZero (location, abs_i_mod_j, lowest, min, max);
+ tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
+ tree j_mult_min_1 = m2expr_BuildPostDec (location, j_mult_min);
+ tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, j_mult_min);
+ tree i_lt_j_mult_min_1 = m2expr_BuildLessThan (location, i, j_mult_min_1);
+ tree a = m2expr_BuildTruthAndIf (location, abs_i_mod_j_eq_0, i_lt_j_mult_min);
+ tree b = m2expr_BuildTruthAndIf (location, abs_i_mod_j_ne_0, i_lt_j_mult_min_1);
+ tree c = m2expr_BuildTruthOrIf (location, a, b);
+ return c;
+}
+
+
+/* divCeilOverflowNegNeg precondition: i, j are in range values and both < 0.
+ Postcondition: TRUE is returned if i divceil j will result in an
+ overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN ((max <= 0) OR (* signs will cause overflow. *)
+ (* check for underflow. *)
+ ((ABS (i) MOD ABS (j) = 0) AND (i >= j * min)) OR
+ ((ABS (i) MOD ABS (j) # 0) AND (i >= j * min - 1)) OR
+ (* check for overflow. *)
+ (((ABS (i) MOD max) = 0) AND (ABS (i) DIV max > ABS (j))) OR
+ (((ABS (i) MOD max) # 0) AND (ABS (i) DIV max > ABS (j) + 1)))
+
+ max_lte_0 -> (max <= 0)
+ abs_i -> (ABS (i))
+ abs_j -> (ABS (j))
+ abs_i_mod_abs_j -> (abs_i MOD abs_j)
+ abs_i_mod_abs_j_eq_0 -> (abs_i_mod_abs_j = 0)
+ abs_i_mod_abs_j_ne_0 -> (abs_i_mod_abs_j # 0)
+ j_mult_min -> (j * min)
+ j_mult_min_1 -> (j_mult_min - 1)
+ i_ge_j_mult_min -> (i >= j_mult_min)
+ i_ge_j_mult_min_1 -> (i >= j_mult_min_1)
+ abs_i_mod_max -> (abs_i mod max)
+ abs_i_div_max -> (abs_i DIVfloor max)
+ abs_j_1 -> (abs_j + 1)
+ abs_i_mod_max_eq_0 -> (abs_i_mod_max = 0)
+ abs_i_mod_max_ne_0 -> (abs_i_mod_max # 0)
+ abs_i_div_max_gt_abs_j -> (abs_i_div_max > abs_j)
+ abs_i_div_max_gt_abs_j_1 -> (abs_i_div_max > abs_j_1)
+
+ a -> (abs_i_mod_abs_j_eq_0 AND i_ge_j_mult_min)
+ b -> (abs_i_mod_abs_j_ne_0 AND i_ge_j_mult_min_1)
+ c -> (abs_i_mod_max_eq_0 AND abs_i_div_max_gt_abs_j)
+ d -> (abs_i_mod_max_ne_0 AND abs_i_div_max_gt_abs_j_1)
+ e -> (a OR b OR c OR d)
+ return max_lte_0 OR e. */
+
+static tree
+divCeilOverflowNegNeg (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree max_lte_0 = m2expr_BuildLessThanOrEqualZero (location, max, lowest, min, max);
+ tree abs_i = m2expr_BuildAbs (location, i);
+ tree abs_j = m2expr_BuildAbs (location, j);
+ tree abs_i_mod_abs_j = m2expr_BuildModFloor (location, abs_i, abs_j, FALSE);
+ tree abs_i_mod_abs_j_eq_0 = m2expr_BuildEqualToZero (location, abs_i_mod_abs_j,
+ lowest, min, max);
+ tree abs_i_mod_abs_j_ne_0 = m2expr_BuildNotEqualToZero (location, abs_i_mod_abs_j,
+ lowest, min, max);
+ tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
+ tree j_mult_min_1 = m2expr_BuildPostDec (location, j_mult_min);
+ tree i_ge_j_mult_min = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min);
+ tree i_ge_j_mult_min_1 = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min_1);
+ tree abs_i_mod_max = m2expr_BuildModFloor (location, abs_i, max, FALSE);
+ tree abs_i_div_max = m2expr_BuildDivFloor (location, abs_i, max, FALSE);
+ tree abs_j_1 = m2expr_BuildPostInc (location, abs_j);
+ tree abs_i_mod_max_eq_0 = m2expr_BuildEqualToZero (location, abs_i_mod_max, lowest, min, max);
+ tree abs_i_mod_max_ne_0 = m2expr_BuildNotEqualToZero (location, abs_i_mod_max, lowest, min, max);
+ tree abs_i_div_max_gt_abs_j = m2expr_BuildGreaterThan (location, abs_i_div_max, abs_j);
+ tree abs_i_div_max_gt_abs_j_1 = m2expr_BuildGreaterThan (location, abs_i_div_max, abs_j_1);
+
+ tree a = m2expr_BuildTruthAndIf (location, abs_i_mod_abs_j_eq_0, i_ge_j_mult_min);
+ tree b = m2expr_BuildTruthAndIf (location, abs_i_mod_abs_j_ne_0, i_ge_j_mult_min_1);
+ tree c = m2expr_BuildTruthAndIf (location, abs_i_mod_max_eq_0, abs_i_div_max_gt_abs_j);
+ tree d = m2expr_BuildTruthAndIf (location, abs_i_mod_max_ne_0, abs_i_div_max_gt_abs_j_1);
+ tree e = m2expr_Build4TruthOrIf (location, a, b, c, d);
+ return m2expr_BuildTruthOrIf (location, max_lte_0, e);
+}
+
+
+/* divCeilOverflowCases, precondition: i, j are in range values.
+ Postcondition: TRUE is returned if i divceil will result in an
+ overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN (((i > 0) AND (j > 0) AND divCeilOverflowPosPos (i, j)) OR
+ ((i < 0) AND (j < 0) AND divCeilOverflowNegNeg (i, j)) OR
+ ((i > 0) AND (j < 0) AND divCeilOverflowPosNeg (i, j)) OR
+ ((i < 0) AND (j > 0) AND divCeilOverflowNegPos (i, j)))
+
+ a -> ((i > 0) AND (j > 0) AND divCeilOverflowPosPos (i, j))
+ b -> ((i < 0) AND (j < 0) AND divCeilOverflowNegNeg (i, j))
+ c -> ((i > 0) AND (j < 0) AND divCeilOverflowPosNeg (i, j))
+ d -> ((i < 0) AND (j > 0) AND divCeilOverflowNegPos (i, j))
+
+ RETURN a AND b AND c AND d. */
+
+static tree
+divCeilOverflowCases (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree i_gt_zero = m2expr_BuildGreaterThanZero (location, i, lowest, min, max);
+ tree j_gt_zero = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
+ tree i_lt_zero = m2expr_BuildLessThanZero (location, i, lowest, min, max);
+ tree j_lt_zero = m2expr_BuildLessThanZero (location, j, lowest, min, max);
+ tree a = m2expr_Build3TruthAndIf (location, i_gt_zero, j_gt_zero,
+ divCeilOverflowPosPos (location, i, j, lowest, min, max));
+ tree b = m2expr_Build3TruthAndIf (location, i_lt_zero, j_lt_zero,
+ divCeilOverflowNegNeg (location, i, j, lowest, min, max));
+ tree c = m2expr_Build3TruthAndIf (location, i_gt_zero, j_lt_zero,
+ divCeilOverflowPosNeg (location, i, j, lowest, min, max));
+ tree d = m2expr_Build3TruthAndIf (location, i_lt_zero, j_gt_zero,
+ divCeilOverflowNegPos (location, i, j, lowest, min, max));
+ return m2expr_Build4TruthOrIf (location, a, b, c, d);
+}
+
+
+/* checkWholeDivCeilOverflow check to see whether i DIV_CEIL j will overflow
+ an integer. A handbuilt expression of trees implementing:
+
+ RETURN ((j = 0) OR (* division by zero. *)
+ (maxT < 0) OR (* both inputs are < 0 and max is < 0,
+ therefore error. *)
+ ((i # 0) AND (* first operand is legally zero,
+ result is also legally zero. *)
+ divCeilOverflowCases (i, j)))
+
+ using the following subexpressions:
+
+ j_eq_zero -> (j == 0)
+ max_lt_zero -> (max < 0)
+ i_ne_zero -> (i # 0). */
+
+static tree
+checkWholeDivCeilOverflow (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree j_eq_zero = m2expr_BuildEqualToZero (location, j, lowest, min, max);
+ tree max_lt_zero = m2expr_BuildLessThanZero (location, max, lowest, min, max);
+ tree i_ne_zero = m2expr_BuildNotEqualToZero (location, i, lowest, min, max);
+ tree j_lt_zero;
+ tree rhs = m2expr_BuildTruthAndIf (location,
+ i_ne_zero,
+ divCeilOverflowCases (location,
+ i, j, lowest, min, max));
+
+ if (M2Options_GetISO ())
+ j_lt_zero = m2expr_FoldAndStrip (m2expr_BuildLessThanZero (location, j, lowest, min, max));
+ else
+ j_lt_zero = m2expr_GetIntegerZero (location);
+ j_eq_zero = m2expr_FoldAndStrip (j_eq_zero);
+ max_lt_zero = m2expr_FoldAndStrip (max_lt_zero);
+ i_ne_zero = m2expr_FoldAndStrip (i_ne_zero);
+ rhs = m2expr_FoldAndStrip (rhs);
+
+ tree condition = m2expr_Build4TruthOrIf (location, j_eq_zero, max_lt_zero, rhs, j_lt_zero);
+ tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value ceil division will cause a range overflow");
+ return t;
+}
+
+
+/* checkWholeModTruncOverflow, the GCC tree.def defines TRUNC_MOD_EXPR to return
+ the remainder which has the same sign as the dividend. In ISO Modula-2 the
+ divisor must never be negative (or zero). The pseudo code for implementing these
+ checks is given below:
+
+ IF j = 0
+ THEN
+ RETURN TRUE (* division by zero. *)
+ ELSIF j < 0
+ THEN
+ RETURN TRUE (* modulus and division by negative (rhs) not allowed in ISO Modula-2. *)
+ ELSIF i = 0
+ THEN
+ RETURN FALSE (* must be legal as result is same as operand. *)
+ ELSIF i > 0
+ THEN
+ (* test for: i MOD j < minT *)
+ IF j > i
+ THEN
+ RETURN FALSE
+ END ;
+ RETURN i - ((i DIV j) * j) < minT
+ ELSIF i < 0
+ THEN
+ (* the result will always be positive and less than i, given that j is less than zero
+ we know that minT must be < 0 as well and therefore the result of i MOD j will
+ never underflow. *)
+ RETURN FALSE
+ END ;
+ RETURN FALSE
+
+ which can be converted into a large expression:
+
+ RETURN (j = 0) OR ((j < 0) AND ISO) OR
+ ((i # 0) AND (j <= i) AND (i - ((i DIVtrunc j) * j) < minT)
+
+ and into GCC trees:
+
+ c1 -> (j = 0)
+ c2 -> (j < 0) (* only called from ISO or PIM4 or -fpositive-mod-floor *)
+ c3 -> (i # 0)
+ c4 -> (j <= i)
+ c6 -> (i DIVtrunc j)
+ c7 -> (i - (c6 * j))
+ c5 -> c7 < minT
+
+ t -> (c1 OR c2 OR
+ (c3 AND c4 AND c5)). */
+
+static tree
+checkWholeModTruncOverflow (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
+ tree c2 = m2expr_BuildLessThanZero (location, j, lowest, min, max);
+ tree c3 = m2expr_BuildNotEqualToZero (location, i, lowest, min, max);
+ tree c4 = m2expr_BuildLessThanOrEqual (location, j, i);
+ tree c6 = m2expr_BuildDivTrunc (location, i, j, FALSE);
+ tree c7 = m2expr_BuildSub (location, i, m2expr_BuildMult (location, c6, j, FALSE), FALSE);
+ tree c5 = m2expr_BuildLessThan (location, c7, min);
+ tree c8 = m2expr_Build3TruthAndIf (location, c3, c4, c5);
+ tree condition = m2expr_Build3TruthOrIf (location, c1, c2, c8);
+ tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value trunc modulus will cause a range overflow");
+ return t;
+}
+
+
+/* checkWholeModCeilOverflow, the GCC tree.def defines CEIL_MOD_EXPR to return
+ the remainder which has the same opposite of the divisor. In gm2 this is
+ only called when the divisor is negative. The pseudo code for implementing
+ these checks is given below:
+
+ IF j = 0
+ THEN
+ RETURN TRUE (* division by zero. *)
+ END ;
+ t := i - j * divceil (i, j) ;
+ printf ("t = %d, i = %d, j = %d, %d / %d = %d\n",
+ t, i, j, i, j, divceil (i, j));
+ RETURN NOT ((t >= minT) AND (t <= maxT))
+
+ which can be converted into the expression:
+
+ t := i - j * divceil (i, j) ;
+ RETURN (j = 0) OR (NOT ((t >= minT) AND (t <= maxT)))
+
+ and into GCC trees:
+
+ c1 -> (j = 0)
+ c2 -> (i - j)
+ c3 -> (i DIVceil j)
+ t -> (c2 * c3)
+ c4 -> (t >= minT)
+ c5 -> (t <= maxT)
+ c6 -> (c4 AND c5)
+ c7 -> (NOT c6)
+ c8 -> (c1 OR c7)
+ return c8. */
+
+static tree
+checkWholeModCeilOverflow (location_t location,
+ tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
+ tree c2 = m2expr_BuildSub (location, i, j, FALSE);
+ tree c3 = m2expr_BuildDivCeil (location, i, j, FALSE);
+ tree t = m2expr_BuildMult (location, c2, c3, FALSE);
+ tree c4 = m2expr_BuildGreaterThanOrEqual (location, t, min);
+ tree c5 = m2expr_BuildLessThanOrEqual (location, t, max);
+ tree c6 = m2expr_BuildTruthAndIf (location, c4, c5);
+ tree c7 = m2expr_BuildTruthNot (location, c6);
+ tree condition = m2expr_BuildTruthOrIf (location, c1, c7);
+ tree s = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value ceil modulus will cause a range overflow");
+ return s;
+}
+
+
+/* checkWholeModFloorOverflow, the GCC tree.def defines FLOOR_MOD_EXPR to return
+ the remainder which has the same sign as the divisor. In gm2 this is
+ only called when the divisor is positive. The pseudo code for implementing
+ these checks is given below:
+
+ IF j = 0
+ THEN
+ RETURN TRUE (* division by zero. *)
+ END ;
+ t := i - j * divfloor (i, j) ;
+ printf ("t = %d, i = %d, j = %d, %d / %d = %d\n",
+ t, i, j, i, j, divfloor (i, j));
+ RETURN NOT ((t >= minT) AND (t <= maxT))
+
+ which can be converted into the expression:
+
+ t := i - j * divfloor (i, j) ;
+ RETURN (j = 0) OR (NOT ((t >= minT) AND (t <= maxT)))
+
+ and into GCC trees:
+
+ c1 -> (j = 0)
+ c2 -> (i - j)
+ c3 -> (i DIVfloor j)
+ t -> (c2 * c3)
+ c4 -> (t >= minT)
+ c5 -> (t <= maxT)
+ c6 -> (c4 AND c5)
+ c7 -> (NOT c6)
+ c8 -> (c1 OR c7)
+ return c8. */
+
+static tree
+checkWholeModFloorOverflow (location_t location,
+ tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
+ tree c2 = m2expr_BuildSub (location, i, j, FALSE);
+ tree c3 = m2expr_BuildDivFloor (location, i, j, FALSE);
+ tree t = m2expr_BuildMult (location, c2, c3, FALSE);
+ tree c4 = m2expr_BuildGreaterThanOrEqual (location, t, min);
+ tree c5 = m2expr_BuildLessThanOrEqual (location, t, max);
+ tree c6 = m2expr_BuildTruthAndIf (location, c4, c5);
+ tree c7 = m2expr_BuildTruthNot (location, c6);
+ tree condition = m2expr_BuildTruthOrIf (location, c1, c7);
+ tree s = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value floor modulus will cause a range overflow");
+ return s;
+}
+
+
+#if 0
+/* The following is a Modula-2 implementation of the C tree node code
+ this code has been hand translated into GCC trees. */
+
+(*
+ divFloorOverflow2 - returns TRUE if an overflow will occur
+ if i divfloor j is performed.
+*)
+
+PROCEDURE divFloorOverflow (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ RETURN ((j = 0) OR (* division by zero. *)
+ (maxT < 0) OR (* both inputs are < 0 and max is < 0,
+ therefore error. *)
+ (* --fixme-- remember here to also check
+ if ISO M2 dialect and j < 0
+ which will also generate an error. *)
+ ((i # 0) AND (* first operand is legally zero,
+ result is also legally zero. *)
+ divFloorOverflowCases (i, j)))
+END divFloorOverflow ;
+
+
+(*
+ divFloorOverflowCases - precondition: i, j are in range values.
+ postcondition: TRUE is returned if i divfloor will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divFloorOverflowCases (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ RETURN (((i > 0) AND (j > 0) AND divFloorOverflowPosPos (i, j)) OR
+ ((i < 0) AND (j < 0) AND divFloorOverflowNegNeg (i, j)) OR
+ ((i > 0) AND (j < 0) AND divFloorOverflowPosNeg (i, j)) OR
+ ((i < 0) AND (j > 0) AND divFloorOverflowNegPos (i, j)))
+END divFloorOverflowCases ;
+
+
+(*
+ divFloorOverflowPosPos - precondition: lhs, rhs are legal and are both >= 0.
+ postcondition: TRUE is returned if lhs divfloor rhs will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divFloorOverflowPosPos (lhs, rhs: INTEGER) : BOOLEAN ;
+BEGIN
+ RETURN multMinOverflow (rhs) OR (lhs < rhs * min)
+END divFloorOverflowPosPos ;
+
+
+(*
+ divFloorOverflowNegNeg - precondition: i, j are in range values and both < 0.
+ postcondition: TRUE is returned if i divfloor will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divFloorOverflowNegNeg (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ RETURN ((maxT <= 0) OR (* signs will cause overflow. *)
+ (* check for underflow. *)
+ (i >= j * minT) OR
+ (* check for overflow. *)
+ (ABS (i) DIV maxT > ABS (j)))
+END divFloorOverflowNegNeg ;
+
+
+(*
+ divFloorOverflowNegPos - precondition: i, j are in range values. i < 0, j >= 0.
+ postcondition: TRUE is returned if i divfloor will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divFloorOverflowNegPos (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ (* easier than might be initially expected. We know minT < 0 and maxT > 0.
+ We know the result will be negative and therefore we only need to test
+ against minT. *)
+ RETURN i < j * minT
+END divFloorOverflowNegPos ;
+
+
+(*
+ divFloorOverflowPosNeg - precondition: i, j are in range values. i >= 0, j < 0.
+ postcondition: TRUE is returned if i divfloor will
+ result in an overflow/underflow.
+*)
+
+PROCEDURE divFloorOverflowPosNeg (i, j: INTEGER) : BOOLEAN ;
+BEGIN
+ (* easier than might be initially expected. We know minT < 0 and maxT > 0.
+ We know the result will be negative and therefore we only need to test
+ against minT. *)
+ RETURN i >= j * minT - j (* is safer than i > j * minT -1 *)
+END divFloorOverflowPosNeg ;
+#endif
+
+
+/* divFloorOverflowPosPos, precondition: i, j are legal and are both >= 0.
+ Postcondition: TRUE is returned if i divfloor will result in an overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN i < j * min
+
+ j_mult_min -> (j * min)
+ RETURN i < j_mult_min. */
+
+static tree
+divFloorOverflowPosPos (location_t location, tree i, tree j, tree min)
+{
+ tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
+ tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, j_mult_min);
+ return i_lt_j_mult_min;
+}
+
+
+/* divFloorOverflowNegNeg precondition: i, j are in range values and both < 0.
+ Postcondition: TRUE is returned if i divfloor j will result in an
+ overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN ((maxT <= 0) OR (* signs will cause overflow. *)
+ (* check for underflow. *)
+ (i >= j * min) OR
+ (* check for overflow. *)
+ (ABS (i) DIV max > ABS (j)))
+
+ max_lte_0 -> (max <= 0)
+ abs_i -> (ABS (i))
+ abs_j -> (ABS (j))
+ j_mult_min -> (j * min)
+ i_ge_j_mult_min -> (i >= j_mult_min)
+ abs_i_div_max -> (abs_i divfloor max)
+ abs_i_div_max_gt_abs_j -> (abs_i_div_max > abs_j)
+
+ return max_lte_0 OR
+ i_ge_j_mult_min OR
+ abs_i_div_max_gt_abs_j. */
+
+static tree
+divFloorOverflowNegNeg (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree max_lte_0 = m2expr_BuildLessThanOrEqualZero (location, max, lowest, min, max);
+ tree abs_i = m2expr_BuildAbs (location, i);
+ tree abs_j = m2expr_BuildAbs (location, j);
+ tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
+ tree i_ge_j_mult_min = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min);
+ tree abs_i_div_max = m2expr_BuildDivFloor (location, abs_i, max, FALSE);
+ tree abs_i_div_max_gt_abs_j = m2expr_BuildGreaterThan (location, abs_i_div_max, abs_j);
+
+ return m2expr_Build3TruthOrIf (location, max_lte_0, i_ge_j_mult_min, abs_i_div_max_gt_abs_j);
+}
+
+
+/* divFloorOverflowPosNeg precondition: i, j are in range values and i >=0, j < 0.
+ Postcondition: TRUE is returned if i divfloor j will result in an
+ overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN i >= j * min - j (* is safer than i > j * min -1 *)
+
+ j_mult_min -> (j * min)
+ j_mult_min_sub_j -> (j_mult_min - j)
+ i_ge_j_mult_min_sub_j -> (i >= j_mult_min_sub_j)
+
+ return i_ge_j_mult_min_sub_j. */
+
+static tree
+divFloorOverflowPosNeg (location_t location, tree i, tree j, tree min)
+{
+ tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
+ tree j_mult_min_sub_j = m2expr_BuildSub (location, j_mult_min, j, FALSE);
+ tree i_ge_j_mult_min_sub_j = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min_sub_j);
+ return i_ge_j_mult_min_sub_j;
+}
+
+
+/* divFloorOverflowNegPos precondition: i, j are in range values and i < 0, j > 0.
+ Postcondition: TRUE is returned if i divfloor j will result in an
+ overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN i < j * min
+
+ j_mult_min -> (j * min)
+ RETURN i < j_mult_min. */
+
+static tree
+divFloorOverflowNegPos (location_t location, tree i, tree j, tree min)
+{
+ tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
+ tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, j_mult_min);
+ return i_lt_j_mult_min;
+}
+
+
+/* divFloorOverflowCases, precondition: i, j are in range values.
+ Postcondition: TRUE is returned if i divfloor will result in an
+ overflow/underflow.
+
+ A handbuilt expression of trees implementing:
+
+ RETURN (((i > 0) AND (j > 0) AND divFloorOverflowPosPos (i, j)) OR
+ ((i < 0) AND (j < 0) AND divFloorOverflowNegNeg (i, j)) OR
+ ((i > 0) AND (j < 0) AND divFloorOverflowPosNeg (i, j)) OR
+ ((i < 0) AND (j > 0) AND divFloorOverflowNegPos (i, j)))
+
+ a -> ((i > 0) AND (j > 0) AND divFloorOverflowPosPos (i, j))
+ b -> ((i < 0) AND (j < 0) AND divFloorOverflowNegNeg (i, j))
+ c -> ((i > 0) AND (j < 0) AND divFloorOverflowPosNeg (i, j))
+ d -> ((i < 0) AND (j > 0) AND divFloorOverflowNegPos (i, j))
+
+ RETURN a AND b AND c AND d. */
+
+static tree
+divFloorOverflowCases (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree i_gt_zero = m2expr_BuildGreaterThanZero (location, i, lowest, min, max);
+ tree j_gt_zero = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
+ tree i_lt_zero = m2expr_BuildLessThanZero (location, i, lowest, min, max);
+ tree j_lt_zero = m2expr_BuildLessThanZero (location, j, lowest, min, max);
+ tree a = m2expr_Build3TruthAndIf (location, i_gt_zero, j_gt_zero,
+ divFloorOverflowPosPos (location, i, j, min));
+ tree b = m2expr_Build3TruthAndIf (location, i_lt_zero, j_lt_zero,
+ divFloorOverflowNegNeg (location, i, j, lowest, min, max));
+ tree c = m2expr_Build3TruthAndIf (location, i_gt_zero, j_lt_zero,
+ divFloorOverflowPosNeg (location, i, j, min));
+ tree d = m2expr_Build3TruthAndIf (location, i_lt_zero, j_gt_zero,
+ divFloorOverflowNegPos (location, i, j, min));
+ return m2expr_Build4TruthOrIf (location, a, b, c, d);
+}
+
+
+/* checkWholeDivFloorOverflow check to see whether i DIV_FLOOR j will overflow
+ an integer. A handbuilt expression of trees implementing:
+
+ RETURN ((j = 0) OR (* division by zero. *)
+ (maxT < 0) OR (* both inputs are < 0 and max is < 0,
+ therefore error. *)
+ (* we also check
+ if ISO M2 dialect and j < 0
+ which will also generate an error. *)
+ ((i # 0) AND (* first operand is legally zero,
+ result is also legally zero. *)
+ divFloorOverflowCases (i, j)))
+
+ using the following subexpressions:
+
+ j_eq_zero -> (j == 0)
+ max_lt_zero -> (max < 0)
+ i_ne_zero -> (i # 0). */
+
+static tree
+checkWholeDivFloorOverflow (location_t location, tree i, tree j, tree lowest,
+ tree min, tree max)
+{
+ tree j_eq_zero = m2expr_BuildEqualToZero (location, j, lowest, min, max);
+ tree max_lt_zero = m2expr_BuildLessThanZero (location, max, lowest, min, max);
+ tree i_ne_zero = m2expr_BuildNotEqualToZero (location, i, lowest, min, max);
+ tree j_lt_zero;
+ tree rhs = m2expr_BuildTruthAndIf (location,
+ i_ne_zero,
+ divFloorOverflowCases (location,
+ i, j, lowest, min, max));
+
+ if (M2Options_GetISO ())
+ /* ISO Modula-2 raises an exception if the right hand operand is < 0. */
+ j_lt_zero = m2expr_FoldAndStrip (m2expr_BuildLessThanZero (location, j, lowest, min, max));
+ else
+ j_lt_zero = m2expr_GetIntegerZero (location);
+ j_eq_zero = m2expr_FoldAndStrip (j_eq_zero);
+ max_lt_zero = m2expr_FoldAndStrip (max_lt_zero);
+ i_ne_zero = m2expr_FoldAndStrip (i_ne_zero);
+ rhs = m2expr_FoldAndStrip (rhs);
+
+ tree condition = m2expr_Build4TruthOrIf (location, j_eq_zero, max_lt_zero, rhs, j_lt_zero);
+ tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
+ get_current_function_name (),
+ "whole value floor division will cause a range overflow");
+ return t;
+}
+
+/* checkWholeOverflow check to see if the binary operators will overflow
+ ordinal types. */
+
+static tree
+m2expr_checkWholeOverflow (location_t location, enum tree_code code, tree op1,
+ tree op2, tree lowest, tree min, tree max)
+{
+ if (M2Options_GetWholeValueCheck () && (min != NULL))
+ {
+ lowest = m2tree_skip_type_decl (lowest);
+ op1 = fold_convert_loc (location, lowest, op1);
+ op2 = fold_convert_loc (location, lowest, op2);
+
+ switch (code)
+ {
+ case PLUS_EXPR:
+ return checkWholeAddOverflow (location, op1, op2, lowest, min, max);
+ case MINUS_EXPR:
+ return checkWholeSubOverflow (location, op1, op2, lowest, min, max);
+ case MULT_EXPR:
+ return checkWholeMultOverflow (location, op1, op2, lowest, min, max);
+ case TRUNC_DIV_EXPR:
+ return checkWholeDivTruncOverflow (location, op1, op2, lowest, min, max);
+ case CEIL_DIV_EXPR:
+ return checkWholeDivCeilOverflow (location, op1, op2, lowest, min, max);
+ case FLOOR_DIV_EXPR:
+ return checkWholeDivFloorOverflow (location, op1, op2, lowest, min, max);
+ case TRUNC_MOD_EXPR:
+ return checkWholeModTruncOverflow (location, op1, op2, lowest, min, max);
+ case CEIL_MOD_EXPR:
+ return checkWholeModCeilOverflow (location, op1, op2, lowest, min, max);
+ case FLOOR_MOD_EXPR:
+ return checkWholeModFloorOverflow (location, op1, op2, lowest, min, max);
+ default:
+ return NULL;
+ }
+ }
+ return NULL;
+}
+
+/* checkRealOverflow if we have enabled real value checking then
+ generate an overflow check appropriate to the tree code being used. */
+
+static void
+m2expr_checkRealOverflow (location_t location, enum tree_code code,
+ tree result)
+{
+ if (M2Options_GetFloatValueCheck ())
+ {
+ tree condition = m2expr_BuildEqualTo (
+ location, m2builtins_BuiltInIsfinite (location, result),
+ m2expr_GetIntegerZero (location));
+ switch (code)
+ {
+ case PLUS_EXPR:
+ m2type_AddStatement (location,
+ M2Range_BuildIfCallRealHandlerLoc (
+ location, condition,
+ get_current_function_name (),
+ "floating point + has caused an overflow"));
+ break;
+ case MINUS_EXPR:
+ m2type_AddStatement (location,
+ M2Range_BuildIfCallRealHandlerLoc (
+ location, condition,
+ get_current_function_name (),
+ "floating point - has caused an overflow"));
+ break;
+ case RDIV_EXPR:
+ case FLOOR_DIV_EXPR:
+ case CEIL_DIV_EXPR:
+ case TRUNC_DIV_EXPR:
+ m2type_AddStatement (location,
+ M2Range_BuildIfCallRealHandlerLoc (
+ location, condition,
+ get_current_function_name (),
+ "floating point / has caused an overflow"));
+ break;
+ case MULT_EXPR:
+ m2type_AddStatement (location,
+ M2Range_BuildIfCallRealHandlerLoc (
+ location, condition,
+ get_current_function_name (),
+ "floating point * has caused an overflow"));
+ break;
+ case NEGATE_EXPR:
+ m2type_AddStatement (
+ location, M2Range_BuildIfCallRealHandlerLoc (
+ location, condition,
+ get_current_function_name (),
+ "floating point unary - has caused an overflow"));
+ default:
+ break;
+ }
+ }
+}
+
+/* build_binary_op, a wrapper for the lower level build_binary_op
+ above. */
+
+tree
+m2expr_build_binary_op_check (location_t location, enum tree_code code,
+ tree op1, tree op2, int needconvert, tree lowest,
+ tree min, tree max)
+{
+ tree type1, type2, result;
+ tree check = NULL;
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ type1 = m2tree_skip_type_decl (TREE_TYPE (op1));
+ type2 = m2tree_skip_type_decl (TREE_TYPE (op2));
+
+ m2assert_AssertLocation (location);
+
+ if (code == PLUS_EXPR)
+ {
+ if (POINTER_TYPE_P (type1))
+ {
+ op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
+ return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op1),
+ op1, op2);
+ }
+ else if (POINTER_TYPE_P (type2))
+ {
+ op1 = fold_convert_loc (location, sizetype, unshare_expr (op1));
+ return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op2),
+ op2, op1);
+ }
+ }
+ if (code == MINUS_EXPR)
+ {
+ if (POINTER_TYPE_P (type1))
+ {
+ op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
+ op2 = fold_build1_loc (location, NEGATE_EXPR, sizetype, op2);
+ return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op1),
+ op1, op2);
+ }
+ else if (POINTER_TYPE_P (type2))
+ {
+ op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
+ op2 = fold_build1_loc (location, NEGATE_EXPR, sizetype, op2);
+ op1 = fold_convert_loc (location, sizetype, unshare_expr (op1));
+ return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op2),
+ op2, op1);
+ }
+ }
+
+ if ((code != LSHIFT_EXPR) && (code != RSHIFT_EXPR) && (code != LROTATE_EXPR)
+ && (code == RROTATE_EXPR))
+ if (type1 != type2)
+ error_at (location, "not expecting different types to binary operator");
+
+ if ((TREE_CODE (type1) != REAL_TYPE) && (min != NULL))
+ check = m2expr_checkWholeOverflow (location, code, op1, op2, lowest, min, max);
+
+ result = build_binary_op (location, code, op1, op2, needconvert);
+ if (check != NULL)
+ result = build2 (COMPOUND_EXPR, TREE_TYPE (result), check, result);
+
+ if (TREE_CODE (type1) == REAL_TYPE)
+ m2expr_checkRealOverflow (location, code, result);
+ return result;
+}
+
+/* build_binary_op, a wrapper for the lower level build_binary_op
+ above. */
+
+tree
+m2expr_build_binary_op (location_t location, enum tree_code code, tree op1,
+ tree op2, int convert)
+{
+ return m2expr_build_binary_op_check (location, code, op1, op2, convert, NULL,
+ NULL, NULL);
+}
+
+/* BuildAddAddress return an expression op1+op2 where op1 is a
+ pointer type and op2 is not a pointer type. */
+
+tree
+m2expr_BuildAddAddress (location_t location, tree op1, tree op2)
+{
+ tree type1, type2;
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ type1 = m2tree_skip_type_decl (TREE_TYPE (op1));
+ type2 = m2tree_skip_type_decl (TREE_TYPE (op2));
+
+ m2assert_AssertLocation (location);
+ ASSERT_CONDITION (POINTER_TYPE_P (type1));
+ ASSERT_CONDITION (!POINTER_TYPE_P (type2));
+
+ op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
+ return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op1),
+ m2expr_FoldAndStrip (op1),
+ m2expr_FoldAndStrip (op2));
+}
+
+/* BuildNegateCheck builds a negate tree. */
+
+tree
+m2expr_BuildNegateCheck (location_t location, tree arg, tree lowest, tree min,
+ tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ arg = m2expr_FoldAndStrip (arg);
+ arg = CheckAddressToCardinal (location, arg);
+
+ t = m2expr_build_unary_op_check (location, NEGATE_EXPR, arg, lowest, min,
+ max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* BuildNegate build a negate expression and returns the tree. */
+
+tree
+m2expr_BuildNegate (location_t location, tree op1, int needconvert)
+{
+ m2assert_AssertLocation (location);
+ op1 = m2expr_FoldAndStrip (op1);
+ op1 = CheckAddressToCardinal (location, op1);
+
+ return m2expr_build_unary_op (location, NEGATE_EXPR, op1, needconvert);
+}
+
+/* BuildSetNegate build a set negate expression and returns the tree. */
+
+tree
+m2expr_BuildSetNegate (location_t location, tree op1, int needconvert)
+{
+ m2assert_AssertLocation (location);
+
+ return m2expr_build_binary_op (
+ location, BIT_XOR_EXPR,
+ m2convert_BuildConvert (location, m2type_GetWordType (),
+ m2expr_FoldAndStrip (op1), FALSE),
+ set_full_complement, needconvert);
+}
+
+/* BuildMult build a multiplication tree. */
+
+tree
+m2expr_BuildMult (location_t location, tree op1, tree op2, int needconvert)
+{
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ m2assert_AssertLocation (location);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ return m2expr_build_binary_op (location, MULT_EXPR, op1, op2, needconvert);
+}
+
+/* BuildMultCheck builds a multiplication tree. */
+
+tree
+m2expr_BuildMultCheck (location_t location, tree op1, tree op2, tree lowest,
+ tree min, tree max)
+{
+ tree t;
+
+ m2assert_AssertLocation (location);
+
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+
+ op1 = CheckAddressToCardinal (location, op1);
+ op2 = CheckAddressToCardinal (location, op2);
+
+ t = m2expr_build_binary_op_check (location, MULT_EXPR, op1, op2, FALSE,
+ lowest, min, max);
+ return m2expr_FoldAndStrip (t);
+}
+
+/* testLimits return the number of bits required to represent:
+ min..max if it matches the, type. Otherwise NULL_TREE is returned. */
+
+static tree
+testLimits (location_t location, tree type, tree min, tree max)
+{
+ m2assert_AssertLocation (location);
+
+ if ((m2expr_CompareTrees (TYPE_MAX_VALUE (type), max) == 0)
+ && (m2expr_CompareTrees (TYPE_MIN_VALUE (type), min) == 0))
+ return m2expr_BuildMult (location, m2expr_GetSizeOf (location, type),
+ m2decl_BuildIntegerConstant (BITS_PER_UNIT),
+ FALSE);
+ return NULL_TREE;
+}
+
+/* noBitsRequired return the number of bits required to contain, values. */
+
+static tree
+noBitsRequired (tree values)
+{
+ int bits = tree_floor_log2 (values);
+
+ if (integer_pow2p (values))
+ return m2decl_BuildIntegerConstant (bits + 1);
+ else
+ return m2decl_BuildIntegerConstant (bits + 1);
+}
+
+/* getMax return the result of max(a, b). */
+
+static tree
+getMax (tree a, tree b)
+{
+ if (m2expr_CompareTrees (a, b) > 0)
+ return a;
+ else
+ return b;
+}
+
+/* calcNbits return the smallest number of bits required to
+ represent: min..max. */
+
+static tree
+calcNbits (location_t location, tree min, tree max)
+{
+ int negative = FALSE;
+ tree t = testLimits (location, m2type_GetIntegerType (), min, max);
+
+ m2assert_AssertLocation (location);
+
+ if (t == NULL)
+ t = testLimits (location, m2type_GetCardinalType (), min, max);
+
+ if (t == NULL)
+ {
+ if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) < 0)
+ {
+ min = m2expr_BuildAdd (location, min,
+ m2expr_GetIntegerOne (location), FALSE);
+ min = fold (m2expr_BuildNegate (location, min, FALSE));
+ negative = TRUE;
+ }
+ if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
+ {
+ max = fold (m2expr_BuildNegate (location, max, FALSE));
+ negative = TRUE;
+ }
+ t = noBitsRequired (getMax (min, max));
+ if (negative)
+ t = m2expr_BuildAdd (location, t, m2expr_GetIntegerOne (location),
+ FALSE);
+ }
+ return t;
+}
+
+/* BuildTBitSize return the minimum number of bits to represent, type. */
+
+tree
+m2expr_BuildTBitSize (location_t location, tree type)
+{
+ enum tree_code code = TREE_CODE (type);
+ tree min;
+ tree max;
+ m2assert_AssertLocation (location);
+
+ switch (code)
+ {
+
+ case TYPE_DECL:
+ return m2expr_BuildTBitSize (location, TREE_TYPE (type));
+ case INTEGER_TYPE:
+ case ENUMERAL_TYPE:
+ max = m2convert_BuildConvert (location, m2type_GetIntegerType (),
+ TYPE_MAX_VALUE (type), FALSE);
+ min = m2convert_BuildConvert (location, m2type_GetIntegerType (),
+ TYPE_MIN_VALUE (type), FALSE);
+ return calcNbits (location, min, max);
+ case BOOLEAN_TYPE:
+ return m2expr_GetIntegerOne (location);
+ default:
+ return m2expr_BuildMult (location, m2expr_GetSizeOf (location, type),
+ m2decl_BuildIntegerConstant (BITS_PER_UNIT),
+ FALSE);
+ }
+}
+
+/* BuildSize build a SIZE function expression and returns the tree. */
+
+tree
+m2expr_BuildSize (location_t location, tree op1,
+ int needconvert ATTRIBUTE_UNUSED)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_GetSizeOf (location, op1);
+}
+
+/* BuildAddr return an expression which calculates the address of op1
+ and returns the tree. If use_generic is TRUE then create a generic
+ pointer type. */
+
+tree
+m2expr_BuildAddr (location_t location, tree op1, int use_generic)
+{
+ tree type = m2tree_skip_type_decl (TREE_TYPE (op1));
+ tree ptrType = build_pointer_type (type);
+ tree result;
+
+ m2assert_AssertLocation (location);
+
+ if (!gm2_mark_addressable (op1))
+ error_at (location, "cannot take the address of this expression");
+
+ if (use_generic)
+ result = build1 (ADDR_EXPR, m2type_GetPointerType (), op1);
+ else
+ result = build1 (ADDR_EXPR, ptrType, op1);
+ protected_set_expr_location (result, location);
+ return result;
+}
+
+/* BuildOffset1 build and return an expression containing the number
+ of bytes the field is offset from the start of the record structure.
+ This function is the same as the above, except that it derives the
+ record from the field and then calls BuildOffset. */
+
+tree
+m2expr_BuildOffset1 (location_t location, tree field,
+ int needconvert ATTRIBUTE_UNUSED)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_BuildOffset (location, DECL_CONTEXT (field), field,
+ needconvert);
+}
+
+/* determinePenultimateField return the field associated with the
+ DECL_CONTEXT (field) within a record or varient. The record, is a
+ record/varient but it maybe an outer nested record to the field that
+ we are searching. Ie:
+
+ record = RECORD x: CARDINAL ; y: RECORD field: CARDINAL ; END END ;
+
+ determinePenultimateField (record, field) returns, y. We are
+ assurred that the chain of records leading to field will be unique as
+ they are built on the fly to implement varient records. */
+
+static tree
+determinePenultimateField (tree record, tree field)
+{
+ tree fieldlist = TYPE_FIELDS (record);
+ tree x, r;
+
+ for (x = fieldlist; x; x = TREE_CHAIN (x))
+ {
+ if (DECL_CONTEXT (field) == TREE_TYPE (x))
+ return x;
+ switch (TREE_CODE (TREE_TYPE (x)))
+ {
+ case RECORD_TYPE:
+ case UNION_TYPE:
+ r = determinePenultimateField (TREE_TYPE (x), field);
+ if (r != NULL)
+ return r;
+ break;
+ default:
+ break;
+ }
+ }
+ return NULL_TREE;
+}
+
+/* BuildOffset builds an expression containing the number of bytes
+the field is offset from the start of the record structure. The
+expression is returned. */
+
+tree
+m2expr_BuildOffset (location_t location, tree record, tree field,
+ int needconvert ATTRIBUTE_UNUSED)
+{
+ m2assert_AssertLocation (location);
+
+ if (DECL_CONTEXT (field) == record)
+ return m2convert_BuildConvert (
+ location, m2type_GetIntegerType (),
+ m2expr_BuildAdd (
+ location, DECL_FIELD_OFFSET (field),
+ m2expr_BuildDivTrunc (location, DECL_FIELD_BIT_OFFSET (field),
+ m2decl_BuildIntegerConstant (BITS_PER_UNIT),
+ FALSE),
+ FALSE),
+ FALSE);
+ else
+ {
+ tree r1 = DECL_CONTEXT (field);
+ tree r2 = determinePenultimateField (record, field);
+ return m2convert_BuildConvert (
+ location, m2type_GetIntegerType (),
+ m2expr_BuildAdd (
+ location, m2expr_BuildOffset (location, r1, field, needconvert),
+ m2expr_BuildOffset (location, record, r2, needconvert), FALSE),
+ FALSE);
+ }
+}
+
+/* BuildLogicalOrAddress build a logical or expressions and return the tree. */
+
+tree
+m2expr_BuildLogicalOrAddress (location_t location, tree op1, tree op2,
+ int needconvert)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (location, BIT_IOR_EXPR, op1, op2,
+ needconvert);
+}
+
+/* BuildLogicalOr build a logical or expressions and return the tree. */
+
+tree
+m2expr_BuildLogicalOr (location_t location, tree op1, tree op2,
+ int needconvert)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (
+ location, BIT_IOR_EXPR,
+ m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
+ m2convert_BuildConvert (location, m2type_GetWordType (), op2, FALSE),
+ needconvert);
+}
+
+/* BuildLogicalAnd build a logical and expression and return the tree. */
+
+tree
+m2expr_BuildLogicalAnd (location_t location, tree op1, tree op2,
+ int needconvert)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (
+ location, BIT_AND_EXPR,
+ m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
+ m2convert_BuildConvert (location, m2type_GetWordType (), op2, FALSE),
+ needconvert);
+}
+
+/* BuildSymmetricalDifference build a logical xor expression and return the
+ * tree. */
+
+tree
+m2expr_BuildSymmetricDifference (location_t location, tree op1, tree op2,
+ int needconvert)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (
+ location, BIT_XOR_EXPR,
+ m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
+ m2convert_BuildConvert (location, m2type_GetWordType (), op2, FALSE),
+ needconvert);
+}
+
+/* BuildLogicalDifference build a logical difference expression and
+return the tree. (op1 and (not op2)). */
+
+tree
+m2expr_BuildLogicalDifference (location_t location, tree op1, tree op2,
+ int needconvert)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (
+ location, BIT_AND_EXPR,
+ m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
+ m2expr_BuildSetNegate (location, op2, needconvert), needconvert);
+}
+
+/* base_type returns the base type of an ordinal subrange, or the
+type itself if it is not a subrange. */
+
+static tree
+base_type (tree type)
+{
+ if (type == error_mark_node)
+ return error_mark_node;
+
+ /* Check for ordinal subranges. */
+ if (m2tree_IsOrdinal (type) && TREE_TYPE (type))
+ type = TREE_TYPE (type);
+ return TYPE_MAIN_VARIANT (type);
+}
+
+/* boolean_enum_to_unsigned convert a BOOLEAN_TYPE, t, or
+ ENUMERAL_TYPE to an unsigned type. */
+
+static tree
+boolean_enum_to_unsigned (location_t location, tree t)
+{
+ tree type = TREE_TYPE (t);
+
+ if (TREE_CODE (base_type (type)) == BOOLEAN_TYPE)
+ return m2convert_BuildConvert (location, unsigned_type_node, t, FALSE);
+ else if (TREE_CODE (base_type (type)) == ENUMERAL_TYPE)
+ return m2convert_BuildConvert (location, unsigned_type_node, t, FALSE);
+ else
+ return t;
+}
+
+/* check_for_comparison check to see if, op, is of type, badType. If
+ so then it returns op after it has been cast to, goodType. op will
+ be an array so we take the address and cast the contents. */
+
+static tree
+check_for_comparison (location_t location, tree op, tree badType,
+ tree goodType)
+{
+ m2assert_AssertLocation (location);
+ if (m2tree_skip_type_decl (TREE_TYPE (op)) == badType)
+ /* Cannot compare array contents in m2expr_build_binary_op. */
+ return m2expr_BuildIndirect (
+ location, m2expr_BuildAddr (location, op, FALSE), goodType);
+ return op;
+}
+
+/* convert_for_comparison return a tree which can be used as an
+ argument during a comparison. */
+
+static tree
+convert_for_comparison (location_t location, tree op)
+{
+ m2assert_AssertLocation (location);
+ op = boolean_enum_to_unsigned (location, op);
+
+ op = check_for_comparison (location, op, m2type_GetISOWordType (),
+ m2type_GetWordType ());
+ op = check_for_comparison (location, op, m2type_GetM2Word16 (),
+ m2type_GetM2Cardinal16 ());
+ op = check_for_comparison (location, op, m2type_GetM2Word32 (),
+ m2type_GetM2Cardinal32 ());
+ op = check_for_comparison (location, op, m2type_GetM2Word64 (),
+ m2type_GetM2Cardinal64 ());
+
+ return op;
+}
+
+/* BuildLessThan return a tree which computes <. */
+
+tree
+m2expr_BuildLessThan (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (
+ location, LT_EXPR, boolean_enum_to_unsigned (location, op1),
+ boolean_enum_to_unsigned (location, op2), TRUE);
+}
+
+/* BuildGreaterThan return a tree which computes >. */
+
+tree
+m2expr_BuildGreaterThan (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (
+ location, GT_EXPR, boolean_enum_to_unsigned (location, op1),
+ boolean_enum_to_unsigned (location, op2), TRUE);
+}
+
+/* BuildLessThanOrEqual return a tree which computes <. */
+
+tree
+m2expr_BuildLessThanOrEqual (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (
+ location, LE_EXPR, boolean_enum_to_unsigned (location, op1),
+ boolean_enum_to_unsigned (location, op2), TRUE);
+}
+
+/* BuildGreaterThanOrEqual return a tree which computes >=. */
+
+tree
+m2expr_BuildGreaterThanOrEqual (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (
+ location, GE_EXPR, boolean_enum_to_unsigned (location, op1),
+ boolean_enum_to_unsigned (location, op2), TRUE);
+}
+
+/* BuildEqualTo return a tree which computes =. */
+
+tree
+m2expr_BuildEqualTo (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (location, EQ_EXPR,
+ convert_for_comparison (location, op1),
+ convert_for_comparison (location, op2), TRUE);
+}
+
+/* BuildEqualNotTo return a tree which computes #. */
+
+tree
+m2expr_BuildNotEqualTo (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_build_binary_op (location, NE_EXPR,
+ convert_for_comparison (location, op1),
+ convert_for_comparison (location, op2), TRUE);
+}
+
+/* BuildIsSuperset return a tree which computes: op1 & op2 == op2. */
+
+tree
+m2expr_BuildIsSuperset (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_BuildEqualTo (
+ location, op2, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
+}
+
+/* BuildIsNotSuperset return a tree which computes: op1 & op2 != op2. */
+
+tree
+m2expr_BuildIsNotSuperset (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_BuildNotEqualTo (
+ location, op2, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
+}
+
+/* BuildIsSubset return a tree which computes: op1 & op2 == op1. */
+
+tree
+m2expr_BuildIsSubset (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_BuildEqualTo (
+ location, op1, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
+}
+
+/* BuildIsNotSubset return a tree which computes: op1 & op2 != op1. */
+
+tree
+m2expr_BuildIsNotSubset (location_t location, tree op1, tree op2)
+{
+ m2assert_AssertLocation (location);
+ return m2expr_BuildNotEqualTo (
+ location, op1, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
+}
+
+/* BuildIfConstInVar generates: if constel in varset then goto label. */
+
+void
+m2expr_BuildIfConstInVar (location_t location, tree type, tree varset,
+ tree constel, int is_lvalue, int fieldno,
+ char *label)
+{
+ tree size = m2expr_GetSizeOf (location, type);
+ m2assert_AssertLocation (location);
+
+ ASSERT_BOOL (is_lvalue);
+ if (m2expr_CompareTrees (
+ size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
+ <= 0)
+ /* Small set size <= TSIZE(WORD). */
+ m2treelib_do_jump_if_bit (
+ location, NE_EXPR,
+ m2treelib_get_rvalue (location, varset, type, is_lvalue), constel,
+ label);
+ else
+ {
+ tree fieldlist = TYPE_FIELDS (type);
+ tree field;
+
+ for (field = fieldlist; (field != NULL) && (fieldno > 0);
+ field = TREE_CHAIN (field))
+ fieldno--;
+
+ m2treelib_do_jump_if_bit (
+ location, NE_EXPR,
+ m2treelib_get_set_field_rhs (location, varset, field), constel,
+ label);
+ }
+}
+
+/* BuildIfConstInVar generates: if not (constel in varset) then goto label. */
+
+void
+m2expr_BuildIfNotConstInVar (location_t location, tree type, tree varset,
+ tree constel, int is_lvalue, int fieldno,
+ char *label)
+{
+ tree size = m2expr_GetSizeOf (location, type);
+
+ m2assert_AssertLocation (location);
+
+ ASSERT_BOOL (is_lvalue);
+ if (m2expr_CompareTrees (
+ size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
+ <= 0)
+ /* Small set size <= TSIZE(WORD). */
+ m2treelib_do_jump_if_bit (
+ location, EQ_EXPR,
+ m2treelib_get_rvalue (location, varset, type, is_lvalue), constel,
+ label);
+ else
+ {
+ tree fieldlist = TYPE_FIELDS (type);
+ tree field;
+
+ for (field = fieldlist; (field != NULL) && (fieldno > 0);
+ field = TREE_CHAIN (field))
+ fieldno--;
+
+ m2treelib_do_jump_if_bit (
+ location, EQ_EXPR,
+ m2treelib_get_set_field_rhs (location, varset, field), constel,
+ label);
+ }
+}
+
+/* BuildIfVarInVar generates: if varel in varset then goto label. */
+
+void
+m2expr_BuildIfVarInVar (location_t location, tree type, tree varset,
+ tree varel, int is_lvalue, tree low,
+ tree high ATTRIBUTE_UNUSED, char *label)
+{
+ tree size = m2expr_GetSizeOf (location, type);
+ /* Calculate the index from the first bit, ie bit 0 represents low value. */
+ tree index = m2expr_BuildSub (
+ location, m2convert_BuildConvert (location, m2type_GetIntegerType (),
+ varel, FALSE),
+ m2convert_BuildConvert (location, m2type_GetIntegerType (), low, FALSE),
+ FALSE);
+
+ m2assert_AssertLocation (location);
+
+ if (m2expr_CompareTrees (
+ size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
+ <= 0)
+ /* Small set size <= TSIZE(WORD). */
+ m2treelib_do_jump_if_bit (
+ location, NE_EXPR,
+ m2treelib_get_rvalue (location, varset, type, is_lvalue), index,
+ label);
+ else
+ {
+ tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
+ /* Which word do we need to fetch? */
+ tree word_index = m2expr_FoldAndStrip (m2expr_BuildDivTrunc (
+ location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
+ FALSE));
+ /* Calculate the bit in this word. */
+ tree offset_into_word = m2expr_FoldAndStrip (m2expr_BuildModTrunc (
+ location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
+ FALSE));
+ tree p2 = m2expr_FoldAndStrip (m2expr_BuildMult (
+ location, word_index,
+ m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT), FALSE));
+
+ /* Calculate the address of the word we are interested in. */
+ p1 = m2expr_BuildAddAddress (location,
+ m2convert_convertToPtr (location, p1), p2);
+
+ /* Fetch the word, extract the bit and test for != 0. */
+ m2treelib_do_jump_if_bit (
+ location, NE_EXPR,
+ m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
+ offset_into_word, label);
+ }
+}
+
+/* BuildIfNotVarInVar generates: if not (varel in varset) then goto label. */
+
+void
+m2expr_BuildIfNotVarInVar (location_t location, tree type, tree varset,
+ tree varel, int is_lvalue, tree low,
+ tree high ATTRIBUTE_UNUSED, char *label)
+{
+ tree size = m2expr_GetSizeOf (location, type);
+ /* Calculate the index from the first bit, ie bit 0 represents low value. */
+ tree index = m2expr_BuildSub (
+ location, m2convert_BuildConvert (location, m2type_GetIntegerType (),
+ m2expr_FoldAndStrip (varel), FALSE),
+ m2convert_BuildConvert (location, m2type_GetIntegerType (),
+ m2expr_FoldAndStrip (low), FALSE),
+ FALSE);
+
+ index = m2expr_FoldAndStrip (index);
+ m2assert_AssertLocation (location);
+
+ if (m2expr_CompareTrees (
+ size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
+ <= 0)
+ /* Small set size <= TSIZE(WORD). */
+ m2treelib_do_jump_if_bit (
+ location, EQ_EXPR,
+ m2treelib_get_rvalue (location, varset, type, is_lvalue), index,
+ label);
+ else
+ {
+ tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
+ /* Calculate the index from the first bit. */
+
+ /* Which word do we need to fetch? */
+ tree word_index = m2expr_FoldAndStrip (m2expr_BuildDivTrunc (
+ location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
+ FALSE));
+ /* Calculate the bit in this word. */
+ tree offset_into_word = m2expr_FoldAndStrip (m2expr_BuildModTrunc (
+ location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
+ FALSE));
+ tree p2 = m2expr_FoldAndStrip (m2expr_BuildMult (
+ location, word_index,
+ m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT), FALSE));
+
+ /* Calculate the address of the word we are interested in. */
+ p1 = m2expr_BuildAddAddress (location, p1, p2);
+
+ /* Fetch the word, extract the bit and test for == 0. */
+ m2treelib_do_jump_if_bit (
+ location, EQ_EXPR,
+ m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
+ offset_into_word, label);
+ }
+}
+
+/* BuildForeachWordInSetDoIfExpr foreach word in set, type, compute
+ the expression, expr, and if true goto label. */
+
+void
+m2expr_BuildForeachWordInSetDoIfExpr (location_t location, tree type, tree op1,
+ tree op2, int is_op1lvalue,
+ int is_op2lvalue, int is_op1const,
+ int is_op2const,
+ tree (*expr) (location_t, tree, tree),
+ char *label)
+{
+ tree p1 = m2treelib_get_set_address_if_var (location, op1, is_op1lvalue,
+ is_op1const);
+ tree p2 = m2treelib_get_set_address_if_var (location, op2, is_op2lvalue,
+ is_op2const);
+ unsigned int fieldNo = 0;
+ tree field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
+ tree field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
+
+ m2assert_AssertLocation (location);
+ ASSERT_CONDITION (TREE_CODE (TREE_TYPE (op1)) == RECORD_TYPE);
+ ASSERT_CONDITION (TREE_CODE (TREE_TYPE (op2)) == RECORD_TYPE);
+
+ while (field1 != NULL && field2 != NULL)
+ {
+ m2statement_DoJump (
+ location,
+ (*expr) (location,
+ m2treelib_get_set_value (location, p1, field1, is_op1const,
+ is_op1lvalue, op1, fieldNo),
+ m2treelib_get_set_value (location, p2, field2, is_op2const,
+ is_op2lvalue, op2, fieldNo)),
+ NULL, label);
+ fieldNo++;
+ field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
+ field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
+ }
+}
+
+/* BuildIfInRangeGoto returns a tree containing if var is in the
+ range low..high then goto label. */
+
+void
+m2expr_BuildIfInRangeGoto (location_t location, tree var, tree low, tree high,
+ char *label)
+{
+ m2assert_AssertLocation (location);
+
+ if (m2expr_CompareTrees (low, high) == 0)
+ m2statement_DoJump (location, m2expr_BuildEqualTo (location, var, low),
+ NULL, label);
+ else
+ m2statement_DoJump (
+ location,
+ m2expr_build_binary_op (
+ location, TRUTH_ANDIF_EXPR,
+ m2expr_BuildGreaterThanOrEqual (location, var, low),
+ m2expr_BuildLessThanOrEqual (location, var, high), FALSE),
+ NULL, label);
+}
+
+/* BuildIfNotInRangeGoto returns a tree containing if var is not in
+ the range low..high then goto label. */
+
+void
+m2expr_BuildIfNotInRangeGoto (location_t location, tree var, tree low,
+ tree high, char *label)
+{
+ m2assert_AssertLocation (location);
+
+ if (m2expr_CompareTrees (low, high) == 0)
+ m2statement_DoJump (location, m2expr_BuildNotEqualTo (location, var, low),
+ NULL, label);
+ else
+ m2statement_DoJump (
+ location, m2expr_build_binary_op (
+ location, TRUTH_ORIF_EXPR,
+ m2expr_BuildLessThan (location, var, low),
+ m2expr_BuildGreaterThan (location, var, high), FALSE),
+ NULL, label);
+}
+
+/* BuildArray - returns a tree which accesses array[index] given,
+ lowIndice. */
+
+tree
+m2expr_BuildArray (location_t location, tree type, tree array, tree index,
+ tree low_indice)
+{
+ tree array_type = m2tree_skip_type_decl (TREE_TYPE (array));
+ tree index_type = TYPE_DOMAIN (array_type);
+ type = m2tree_skip_type_decl (type);
+// ASSERT_CONDITION (low_indice == TYPE_MIN_VALUE (index_type));
+
+ low_indice
+ = m2convert_BuildConvert (location, index_type, low_indice, FALSE);
+ return build4_loc (location, ARRAY_REF, type, array, index, low_indice,
+ NULL_TREE);
+}
+
+/* BuildComponentRef - build a component reference tree which
+ accesses record.field. If field does not belong to record it
+ calls BuildComponentRef on the penultimate field. */
+
+tree
+m2expr_BuildComponentRef (location_t location, tree record, tree field)
+{
+ tree recordType = m2tree_skip_reference_type (
+ m2tree_skip_type_decl (TREE_TYPE (record)));
+
+ if (DECL_CONTEXT (field) == recordType)
+ return build3 (COMPONENT_REF, TREE_TYPE (field), record, field, NULL_TREE);
+ else
+ {
+ tree f = determinePenultimateField (recordType, field);
+ return m2expr_BuildComponentRef (
+ location, m2expr_BuildComponentRef (location, record, f), field);
+ }
+}
+
+/* BuildIndirect - build: (*target) given that the object to be
+ copied is of, type. */
+
+tree
+m2expr_BuildIndirect (location_t location ATTRIBUTE_UNUSED, tree target,
+ tree type)
+{
+ /* Note that the second argument to build1 is:
+
+ TYPE_QUALS is a list of modifiers such as const or volatile to apply
+ to the pointer type, represented as identifiers.
+
+ it also determines the type of arithmetic and size of the object to
+ be indirectly moved. */
+
+ tree t1 = m2tree_skip_type_decl (type);
+ tree t2 = build_pointer_type (t1);
+
+ m2assert_AssertLocation (location);
+
+ return build1 (INDIRECT_REF, t1,
+ m2convert_BuildConvert (location, t2, target, FALSE));
+}
+
+/* IsTrue - returns TRUE if, t, is known to be TRUE. */
+
+int
+m2expr_IsTrue (tree t)
+{
+ return (m2expr_FoldAndStrip (t) == m2type_GetBooleanTrue ());
+}
+
+/* IsFalse - returns FALSE if, t, is known to be FALSE. */
+
+int
+m2expr_IsFalse (tree t)
+{
+ return (m2expr_FoldAndStrip (t) == m2type_GetBooleanFalse ());
+}
+
+/* AreConstantsEqual - maps onto tree.cc (tree_int_cst_equal). It
+ returns TRUE if the value of e1 is the same as e2. */
+
+int
+m2expr_AreConstantsEqual (tree e1, tree e2)
+{
+ return tree_int_cst_equal (e1, e2) != 0;
+}
+
+/* AreRealOrComplexConstantsEqual - returns TRUE if constants, e1 and
+ e2 are equal according to IEEE rules. This does not perform bit
+ equivalence for example IEEE states that -0 == 0 and NaN != NaN. */
+
+int
+m2expr_AreRealOrComplexConstantsEqual (tree e1, tree e2)
+{
+ if (TREE_CODE (e1) == COMPLEX_CST)
+ return (m2expr_AreRealOrComplexConstantsEqual (TREE_REALPART (e1),
+ TREE_REALPART (e2))
+ && m2expr_AreRealOrComplexConstantsEqual (TREE_IMAGPART (e1),
+ TREE_IMAGPART (e2)));
+ else
+ return real_compare (EQ_EXPR, &TREE_REAL_CST (e1), &TREE_REAL_CST (e2));
+}
+
+/* DetermineSign, returns -1 if e<0 0 if e==0 1 if e>0
+ an unsigned constant will never return -1. */
+
+int
+m2expr_DetermineSign (tree e)
+{
+ return tree_int_cst_sgn (e);
+}
+
+/* Similar to build_int_2 () but allows you to specify the type of
+ the integer constant that you are creating. */
+
+static tree
+build_int_2_type (HOST_WIDE_INT low, HOST_WIDE_INT hi, tree type)
+{
+ tree value;
+ HOST_WIDE_INT ival[3];
+
+ ival[0] = low;
+ ival[1] = hi;
+ ival[2] = 0;
+
+ widest_int wval = widest_int::from_array (ival, 3);
+ value = wide_int_to_tree (type, wval);
+
+ return value;
+}
+
+/* BuildCap - builds the Modula-2 function CAP(t) and returns the
+ result in a gcc Tree. */
+
+tree
+m2expr_BuildCap (location_t location, tree t)
+{
+ tree tt;
+ tree out_of_range, less_than, greater_than, translated;
+
+ m2assert_AssertLocation (location);
+
+ t = fold (t);
+ if (t == error_mark_node)
+ return error_mark_node;
+
+ tt = TREE_TYPE (t);
+
+ t = fold (convert (m2type_GetM2CharType (), t));
+
+ if (TREE_CODE (tt) == INTEGER_TYPE)
+ {
+ less_than = fold (m2expr_build_binary_op (
+ location, LT_EXPR, t,
+ build_int_2_type ('a', 0, m2type_GetM2CharType ()), 0));
+ greater_than = fold (m2expr_build_binary_op (
+ location, GT_EXPR, t,
+ build_int_2_type ('z', 0, m2type_GetM2CharType ()), 0));
+ out_of_range = fold (m2expr_build_binary_op (
+ location, TRUTH_ORIF_EXPR, less_than, greater_than, 0));
+
+ translated = fold (convert (
+ m2type_GetM2CharType (),
+ m2expr_build_binary_op (
+ location, MINUS_EXPR, t,
+ build_int_2_type ('a' - 'A', 0, m2type_GetM2CharType ()), 0)));
+
+ return fold_build3 (COND_EXPR, m2type_GetM2CharType (), out_of_range, t,
+ translated);
+ }
+
+ error_at (location,
+ "argument to CAP is not a constant or variable of type CHAR");
+ return error_mark_node;
+}
+
+/* BuildDivM2 if iso or pim4 then build and return ((op2 < 0) : (op1
+ divceil op2) ? (op1 divfloor op2)) otherwise use divtrunc. */
+
+tree
+m2expr_BuildDivM2 (location_t location, tree op1, tree op2,
+ unsigned int needsconvert)
+{
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+ ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
+ if (M2Options_GetPIM4 () || M2Options_GetISO ()
+ || M2Options_GetPositiveModFloor ())
+ return fold_build3 (
+ COND_EXPR, TREE_TYPE (op1),
+ m2expr_BuildLessThan (
+ location, op2,
+ m2convert_BuildConvert (location, TREE_TYPE (op2),
+ m2expr_GetIntegerZero (location), FALSE)),
+ m2expr_BuildDivCeil (location, op1, op2, needsconvert),
+ m2expr_BuildDivFloor (location, op1, op2, needsconvert));
+ else
+ return m2expr_BuildDivTrunc (location, op1, op2, needsconvert);
+}
+
+/* BuildDivM2Check - build and
+ return ((op2 < 0) : (op1 divtrunc op2) ? (op1 divfloor op2))
+ when -fiso, -fpim4 or -fpositive-mod-floor-div is present else
+ return op1 div trunc op2. Use the checking div equivalents. */
+
+tree
+m2expr_BuildDivM2Check (location_t location, tree op1, tree op2,
+ tree lowest, tree min, tree max)
+{
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+ ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
+ if (M2Options_GetISO ()
+ || M2Options_GetPIM4 () || M2Options_GetPositiveModFloor ())
+ return fold_build3 (
+ COND_EXPR, TREE_TYPE (op1),
+ m2expr_BuildLessThan (
+ location, op2,
+ m2convert_BuildConvert (location, TREE_TYPE (op2),
+ m2expr_GetIntegerZero (location), FALSE)),
+ m2expr_BuildDivCeilCheck (location, op1, op2, lowest, min, max),
+ m2expr_BuildDivFloorCheck (location, op1, op2, lowest, min, max));
+ else
+ return m2expr_BuildDivTruncCheck (location, op1, op2, lowest, min, max);
+}
+
+static
+tree
+m2expr_BuildISOModM2Check (location_t location,
+ tree op1, tree op2, tree lowest, tree min, tree max)
+{
+ tree cond = m2expr_BuildLessThan (location, op2,
+ m2convert_BuildConvert (location, TREE_TYPE (op2),
+ m2expr_GetIntegerZero (location), FALSE));
+
+ /* Return the result of the modulus. */
+ return fold_build3 (COND_EXPR, TREE_TYPE (op1), cond,
+ /* op2 < 0. */
+ m2expr_BuildModCeilCheck (location, op1, op2, lowest, min, max),
+ /* op2 >= 0. */
+ m2expr_BuildModFloorCheck (location, op1, op2, lowest, min, max));
+}
+
+
+/* BuildModM2Check if iso or pim4 then build and return ((op2 < 0) : (op1
+ modceil op2) ? (op1 modfloor op2)) otherwise use modtrunc.
+ Use the checking mod equivalents. */
+
+tree
+m2expr_BuildModM2Check (location_t location, tree op1, tree op2,
+ tree lowest, tree min, tree max)
+{
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+ ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
+ if (M2Options_GetPIM4 () || M2Options_GetISO ()
+ || M2Options_GetPositiveModFloor ())
+ return m2expr_BuildISOModM2Check (location, op1, op2, lowest, min, max);
+ else
+ return m2expr_BuildModTruncCheck (location, op1, op2, lowest, min, max);
+}
+
+/* BuildModM2 if iso or pim4 then build and return ((op2 < 0) : (op1
+ modceil op2) ? (op1 modfloor op2)) otherwise use modtrunc. */
+
+tree
+m2expr_BuildModM2 (location_t location, tree op1, tree op2,
+ unsigned int needsconvert)
+{
+ op1 = m2expr_FoldAndStrip (op1);
+ op2 = m2expr_FoldAndStrip (op2);
+ ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
+ if (M2Options_GetPIM4 () || M2Options_GetISO ()
+ || M2Options_GetPositiveModFloor ())
+ return fold_build3 (
+ COND_EXPR, TREE_TYPE (op1),
+ m2expr_BuildLessThan (
+ location, op2,
+ m2convert_BuildConvert (location, TREE_TYPE (op2),
+ m2expr_GetIntegerZero (location), FALSE)),
+ m2expr_BuildModCeil (location, op1, op2, needsconvert),
+ m2expr_BuildModFloor (location, op1, op2, needsconvert));
+ else
+ return m2expr_BuildModTrunc (location, op1, op2, needsconvert);
+}
+
+/* BuildAbs build the Modula-2 function ABS(t) and return the result
+ in a gcc Tree. */
+
+tree
+m2expr_BuildAbs (location_t location, tree t)
+{
+ m2assert_AssertLocation (location);
+
+ return m2expr_build_unary_op (location, ABS_EXPR, t, 0);
+}
+
+/* BuildRe build an expression for the function RE. */
+
+tree
+m2expr_BuildRe (tree op1)
+{
+ op1 = m2expr_FoldAndStrip (op1);
+ if (TREE_CODE (op1) == COMPLEX_CST)
+ return fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
+ else
+ return build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
+}
+
+/* BuildIm build an expression for the function IM. */
+
+tree
+m2expr_BuildIm (tree op1)
+{
+ op1 = m2expr_FoldAndStrip (op1);
+ if (TREE_CODE (op1) == COMPLEX_CST)
+ return fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
+ else
+ return build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
+}
+
+/* BuildCmplx build an expression for the function CMPLX. */
+
+tree
+m2expr_BuildCmplx (location_t location, tree type, tree real, tree imag)
+{
+ tree scalor;
+ real = m2expr_FoldAndStrip (real);
+ imag = m2expr_FoldAndStrip (imag);
+ type = m2tree_skip_type_decl (type);
+ scalor = TREE_TYPE (type);
+
+ if (scalor != TREE_TYPE (real))
+ real = m2convert_BuildConvert (location, scalor, real, FALSE);
+ if (scalor != TREE_TYPE (imag))
+ imag = m2convert_BuildConvert (location, scalor, imag, FALSE);
+
+ if ((TREE_CODE (real) == REAL_CST) && (TREE_CODE (imag) == REAL_CST))
+ return build_complex (type, real, imag);
+ else
+ return build2 (COMPLEX_EXPR, type, real, imag);
+}
+
+/* BuildBinaryForeachWordDo implements the large set operators. Each
+ word of the set can be calculated by binop. This function runs along
+ each word of the large set invoking the binop. */
+
+void
+m2expr_BuildBinaryForeachWordDo (location_t location, tree type, tree op1,
+ tree op2, tree op3,
+ tree (*binop) (location_t, tree, tree, int),
+ int is_op1lvalue, int is_op2lvalue,
+ int is_op3lvalue, int is_op1const,
+ int is_op2const, int is_op3const)
+{
+ tree size = m2expr_GetSizeOf (location, type);
+
+ m2assert_AssertLocation (location);
+
+ ASSERT_BOOL (is_op1lvalue);
+ ASSERT_BOOL (is_op2lvalue);
+ ASSERT_BOOL (is_op3lvalue);
+ ASSERT_BOOL (is_op1const);
+ ASSERT_BOOL (is_op2const);
+ ASSERT_BOOL (is_op3const);
+ if (m2expr_CompareTrees (
+ size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
+ <= 0)
+ /* Small set size <= TSIZE(WORD). */
+ m2statement_BuildAssignmentTree (
+ location, m2treelib_get_rvalue (location, op1, type, is_op1lvalue),
+ (*binop) (
+ location, m2treelib_get_rvalue (location, op2, type, is_op2lvalue),
+ m2treelib_get_rvalue (location, op3, type, is_op3lvalue), FALSE));
+ else
+ {
+ /* Large set size > TSIZE(WORD). */
+
+ tree p2 = m2treelib_get_set_address_if_var (location, op2, is_op2lvalue,
+ is_op2const);
+ tree p3 = m2treelib_get_set_address_if_var (location, op3, is_op3lvalue,
+ is_op3const);
+ unsigned int fieldNo = 0;
+ tree field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
+ tree field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
+ tree field3 = m2treelib_get_field_no (type, op3, is_op3const, fieldNo);
+
+ if (is_op1const)
+ error_at (
+ location,
+ "internal error: not expecting operand1 to be a constant set");
+
+ while (field1 != NULL && field2 != NULL && field3 != NULL)
+ {
+ m2statement_BuildAssignmentTree (
+ location, m2treelib_get_set_field_des (location, op1, field1),
+ (*binop) (
+ location,
+ m2treelib_get_set_value (location, p2, field2, is_op2const,
+ is_op2lvalue, op2, fieldNo),
+ m2treelib_get_set_value (location, p3, field3, is_op3const,
+ is_op3lvalue, op3, fieldNo),
+ FALSE));
+ fieldNo++;
+ field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
+ field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
+ field3 = m2treelib_get_field_no (type, op3, is_op3const, fieldNo);
+ }
+ }
+}
+
+/* Append DIGIT to NUM, a number of PRECISION bits being read in base
+ BASE. */
+
+static int
+append_digit (unsigned HOST_WIDE_INT *low, HOST_WIDE_INT *high,
+ unsigned int digit, unsigned int base)
+{
+ unsigned int shift;
+ int overflow;
+ HOST_WIDE_INT add_high, res_high, test_high;
+ unsigned HOST_WIDE_INT add_low, res_low, test_low;
+
+ switch (base)
+ {
+
+ case 2:
+ shift = 1;
+ break;
+ case 8:
+ shift = 3;
+ break;
+ case 10:
+ shift = 3;
+ break;
+ case 16:
+ shift = 4;
+ break;
+
+ default:
+ shift = 3;
+ error ("internal error: not expecting this base value for a constant");
+ }
+
+ /* Multiply by 2, 8 or 16. Catching this overflow here means we
+ don't need to worry about add_high overflowing. */
+ if (((*high) >> (INT_TYPE_SIZE - shift)) == 0)
+ overflow = FALSE;
+ else
+ overflow = TRUE;
+
+ res_high = *high << shift;
+ res_low = *low << shift;
+ res_high |= (*low) >> (INT_TYPE_SIZE - shift);
+
+ if (base == 10)
+ {
+ add_low = (*low) << 1;
+ add_high = ((*high) << 1) + ((*low) >> (INT_TYPE_SIZE - 1));
+ }
+ else
+ add_high = add_low = 0;
+
+ test_low = add_low + digit;
+ if (test_low < add_low)
+ add_high++;
+ add_low += digit;
+
+ test_low = res_low + add_low;
+ if (test_low < res_low)
+ add_high++;
+ test_high = res_high + add_high;
+ if (test_high < res_high)
+ overflow = TRUE;
+
+ *low = res_low + add_low;
+ *high = res_high + add_high;
+
+ return overflow;
+}
+
+/* interpret_integer convert an integer constant into two integer
+ constants. Heavily borrowed from gcc/cppexp.cc. */
+
+int
+m2expr_interpret_integer (const char *str, unsigned int base,
+ unsigned HOST_WIDE_INT *low, HOST_WIDE_INT *high)
+{
+ unsigned const char *p, *end;
+ int overflow = FALSE;
+ int len;
+
+ *low = 0;
+ *high = 0;
+ p = (unsigned const char *)str;
+ len = strlen (str);
+ end = p + len;
+
+ /* Common case of a single digit. */
+ if (len == 1)
+ *low = p[0] - '0';
+ else
+ {
+ unsigned int c = 0;
+
+ /* We can add a digit to numbers strictly less than this without
+ needing the precision and slowness of double integers. */
+
+ unsigned HOST_WIDE_INT max = ~(unsigned HOST_WIDE_INT)0;
+ max = (max - base + 1) / base + 1;
+
+ for (; p < end; p++)
+ {
+ c = *p;
+
+ if (ISDIGIT (c) || (base == 16 && ISXDIGIT (c)))
+ c = hex_value (c);
+ else
+ return overflow;
+
+ /* Strict inequality for when max is set to zero. */
+ if (*low < max)
+ *low = (*low) * base + c;
+ else
+ {
+ overflow = append_digit (low, high, c, base);
+ max = 0; /* From now on we always use append_digit. */
+ }
+ }
+ }
+ return overflow;
+}
+
+/* Append DIGIT to NUM, a number of PRECISION bits being read in base
+ BASE. */
+
+static int
+append_m2_digit (unsigned int *low, int *high, unsigned int digit,
+ unsigned int base, int *needsUnsigned)
+{
+ unsigned int shift;
+ int overflow;
+ int add_high, res_high, test_high;
+ unsigned int add_low, res_low, test_low;
+ unsigned int add_uhigh, res_uhigh, test_uhigh;
+
+ switch (base)
+ {
+
+ case 2:
+ shift = 1;
+ break;
+ case 8:
+ shift = 3;
+ break;
+ case 10:
+ shift = 3;
+ break;
+ case 16:
+ shift = 4;
+ break;
+
+ default:
+ shift = 3;
+ error ("internal error: not expecting this base value for a constant");
+ }
+
+ /* Multiply by 2, 8 or 16. Catching this overflow here means we
+ don't need to worry about add_high overflowing. */
+ if (((*high) >> (INT_TYPE_SIZE - shift)) == 0)
+ overflow = FALSE;
+ else
+ overflow = TRUE;
+
+ res_high = *high << shift;
+ res_low = *low << shift;
+ res_high |= (*low) >> (INT_TYPE_SIZE - shift);
+
+ if (base == 10)
+ {
+ add_low = (*low) << 1;
+ add_high = ((*high) << 1) + ((*low) >> (INT_TYPE_SIZE - 1));
+ }
+ else
+ add_high = add_low = 0;
+
+ test_low = add_low + digit;
+ if (test_low < add_low)
+ add_high++;
+ add_low += digit;
+
+ test_low = res_low + add_low;
+ if (test_low < res_low)
+ add_high++;
+ test_high = res_high + add_high;
+ if (test_high < res_high)
+ {
+ res_uhigh = res_high;
+ add_uhigh = add_high;
+ test_uhigh = res_uhigh + add_uhigh;
+ if (test_uhigh < res_uhigh)
+ overflow = TRUE;
+ else
+ *needsUnsigned = TRUE;
+ }
+
+ *low = res_low + add_low;
+ *high = res_high + add_high;
+
+ return overflow;
+}
+
+/* interpret_m2_integer convert an integer constant into two integer
+ constants. Heavily borrowed from gcc/cppexp.cc. Note that this is a
+ copy of the above code except that it uses `int' rather than
+ HOST_WIDE_INT to allow gm2 to determine what Modula-2 base type to
+ use for this constant and it also sets needsLong and needsUnsigned
+ if an overflow can be avoided by using these techniques. */
+
+int
+m2expr_interpret_m2_integer (const char *str, unsigned int base,
+ unsigned int *low, int *high,
+ int *needsLong, int *needsUnsigned)
+{
+ const unsigned char *p, *end;
+ int len;
+ *needsLong = FALSE;
+ *needsUnsigned = FALSE;
+
+ *low = 0;
+ *high = 0;
+ p = (unsigned const char *)str;
+ len = strlen (str);
+ end = p + len;
+
+ /* Common case of a single digit. */
+ if (len == 1)
+ *low = p[0] - '0';
+ else
+ {
+ unsigned int c = 0;
+
+ /* We can add a digit to numbers strictly less than this without
+ needing the precision and slowness of double integers. */
+
+ unsigned int max = ~(unsigned int)0;
+ max = (max - base + 1) / base + 1;
+
+ for (; p < end; p++)
+ {
+ c = *p;
+
+ if (ISDIGIT (c) || (base == 16 && ISXDIGIT (c)))
+ c = hex_value (c);
+ else
+ return FALSE; /* End of string and no overflow found. */
+
+ /* Strict inequality for when max is set to zero. */
+ if (*low < max)
+ *low = (*low) * base + c;
+ else
+ {
+ *needsLong = TRUE;
+ if (append_m2_digit (low, high, c, base,
+ needsUnsigned))
+ return TRUE; /* We have overflowed so bail out. */
+ max = 0; /* From now on we always use append_digit. */
+ }
+ }
+ }
+ return FALSE;
+}
+
+/* GetSizeOfInBits return the number of bits used to contain, type. */
+
+tree
+m2expr_GetSizeOfInBits (tree type)
+{
+ enum tree_code code = TREE_CODE (type);
+
+ if (code == FUNCTION_TYPE)
+ return m2expr_GetSizeOfInBits (ptr_type_node);
+
+ if (code == VOID_TYPE)
+ {
+ error ("%qs applied to a void type", "sizeof");
+ return size_one_node;
+ }
+
+ if (code == VAR_DECL)
+ return m2expr_GetSizeOfInBits (TREE_TYPE (type));
+
+ if (code == PARM_DECL)
+ return m2expr_GetSizeOfInBits (TREE_TYPE (type));
+
+ if (code == TYPE_DECL)
+ return m2expr_GetSizeOfInBits (TREE_TYPE (type));
+
+ if (code == COMPONENT_REF)
+ return m2expr_GetSizeOfInBits (TREE_TYPE (type));
+
+ if (code == ERROR_MARK)
+ return size_one_node;
+
+ if (!COMPLETE_TYPE_P (type))
+ {
+ error ("%qs applied to an incomplete type", "sizeof");
+ return size_zero_node;
+ }
+
+ return m2decl_BuildIntegerConstant (TYPE_PRECISION (type));
+}
+
+/* GetSizeOf taken from c-typeck.cc (c_sizeof). */
+
+tree
+m2expr_GetSizeOf (location_t location, tree type)
+{
+ enum tree_code code = TREE_CODE (type);
+ m2assert_AssertLocation (location);
+
+ if (code == FUNCTION_TYPE)
+ return m2expr_GetSizeOf (location, m2type_GetPointerType ());
+
+ if (code == VOID_TYPE)
+ return size_one_node;
+
+ if (code == VAR_DECL)
+ return m2expr_GetSizeOf (location, TREE_TYPE (type));
+
+ if (code == PARM_DECL)
+ return m2expr_GetSizeOf (location, TREE_TYPE (type));
+
+ if (code == TYPE_DECL)
+ return m2expr_GetSizeOf (location, TREE_TYPE (type));
+
+ if (code == ERROR_MARK)
+ return size_one_node;
+
+ if (code == CONSTRUCTOR)
+ return m2expr_GetSizeOf (location, TREE_TYPE (type));
+
+ if (code == FIELD_DECL)
+ return m2expr_GetSizeOf (location, TREE_TYPE (type));
+
+ if (code == COMPONENT_REF)
+ return m2expr_GetSizeOf (location, TREE_TYPE (type));
+
+ if (!COMPLETE_TYPE_P (type))
+ {
+ error_at (location, "%qs applied to an incomplete type", "sizeof");
+ return size_zero_node;
+ }
+
+ /* Convert in case a char is more than one unit. */
+ return size_binop_loc (
+ location, CEIL_DIV_EXPR, TYPE_SIZE_UNIT (type),
+ size_int (TYPE_PRECISION (char_type_node) / BITS_PER_UNIT));
+}
+
+tree
+m2expr_GetIntegerZero (location_t location ATTRIBUTE_UNUSED)
+{
+ return integer_zero_node;
+}
+
+tree
+m2expr_GetIntegerOne (location_t location ATTRIBUTE_UNUSED)
+{
+ return integer_one_node;
+}
+
+tree
+m2expr_GetCardinalOne (location_t location)
+{
+ return m2convert_ToCardinal (location, integer_one_node);
+}
+
+tree
+m2expr_GetCardinalZero (location_t location)
+{
+ return m2convert_ToCardinal (location, integer_zero_node);
+}
+
+tree
+m2expr_GetWordZero (location_t location)
+{
+ return m2convert_ToWord (location, integer_zero_node);
+}
+
+tree
+m2expr_GetWordOne (location_t location)
+{
+ return m2convert_ToWord (location, integer_one_node);
+}
+
+tree
+m2expr_GetPointerZero (location_t location)
+{
+ return m2convert_convertToPtr (location, integer_zero_node);
+}
+
+tree
+m2expr_GetPointerOne (location_t location)
+{
+ return m2convert_convertToPtr (location, integer_one_node);
+}
+
+/* build_set_full_complement return a word size value with all bits
+set to one. */
+
+static tree
+build_set_full_complement (location_t location)
+{
+ tree value = integer_zero_node;
+ int i;
+
+ m2assert_AssertLocation (location);
+
+ for (i = 0; i < SET_WORD_SIZE; i++)
+ {
+ value = m2expr_BuildLogicalOr (
+ location, value,
+ m2expr_BuildLSL (
+ location, m2expr_GetWordOne (location),
+ m2convert_BuildConvert (location, m2type_GetWordType (),
+ m2decl_BuildIntegerConstant (i), FALSE),
+ FALSE),
+ FALSE);
+ }
+ return value;
+}
+
+/* init initialise this module. */
+
+void
+m2expr_init (location_t location)
+{
+ m2assert_AssertLocation (location);
+
+ set_full_complement = build_set_full_complement (location);
+}
+
+#include "gt-m2-m2expr.h"