From patchwork Mon Oct 10 15:31:23 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Gaius Mulley X-Patchwork-Id: 1887 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a5d:4ac7:0:0:0:0:0 with SMTP id y7csp1646519wrs; Mon, 10 Oct 2022 08:45:46 -0700 (PDT) X-Google-Smtp-Source: AMsMyM57SH8yg3vPTBZkl9B7S1g1MInIBlVkFNhXScMr4cZRxyIrw0DovC/2KrxyrDa+WI3+X9yl X-Received: by 2002:a17:907:7f92:b0:78d:2b4b:e7f1 with SMTP id qk18-20020a1709077f9200b0078d2b4be7f1mr15111770ejc.136.1665416746426; Mon, 10 Oct 2022 08:45:46 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1665416746; cv=none; d=google.com; s=arc-20160816; b=PvVynYl0pv9Cb0dbnhEgDvYmUFMqZPlD5S+ZTG6jsqBXozxQfndS2vT2t6BWO4ANFZ OKoN04htEgrcPiQE93KfIRbt9J+NgbGIiWiBU3P60LbQwxfCBMy611rOv4SbtVh1lVRF +pygOSJKM/Ui4jqR6eVOxzk2n9gAYHG6J2YcUVysFdI8yntS0esNn2KlesfnyNr8vG9N KzOFnmJFuDmm4RnuGl7srJw92yR1QpRbiT2EhfGGgwrT31/VIsNGz4e8IErkqU+CY9jo F5u7i6Jpvc5PBLt0hk49qcONUGQEtlLxYWIch35tUgY0AAGYpvijgIImouCEh6Lca6ze wJQA== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence:date:message-id:to :subject:dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=vwtvZW5cuUIKNauBjInRnq2PKSjXrIYa/qxNNbRe4pU=; b=qjE0AJ1od4lfOw1+ZBMHdGCUvS+H2bHXWqkyIvvLuzEH7b0XECYKDQ9L7AaoRA3nCh U5baRrEoj98YDttl0J0QWtFidDnaYJjllqP89Qsm22uPOw3YB7NbWLAS81bq7njBC2oM YewNnb+6bdlXOuL6GZsdEPNyuLJjBJugafAWgmb57gy/CbfzHxKlFK5cF4gQ2+ZET8am YI0L2Ca4dZmZUQYllQOGsmB/v+LN5zZ+wo+VPnlL7C/0g0g4bSn13TrAft0bBD8Jg7l4 6IwPDWblZL/RC6GlSG6+1TBjkMVJyFFdC8L5CZEwvJTP0lcC4F6szH93gG9eW/nD+7tx 4q7A== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=EjX3yMVz; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from sourceware.org (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id op3-20020a170906bce300b0073155abc1b8si9945554ejb.154.2022.10.10.08.45.45 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 10 Oct 2022 08:45:46 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=EjX3yMVz; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 9677C3955629 for ; Mon, 10 Oct 2022 15:43:30 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9677C3955629 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1665416610; bh=vwtvZW5cuUIKNauBjInRnq2PKSjXrIYa/qxNNbRe4pU=; h=Subject:To:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=EjX3yMVzjEmlOTBl9a8vDudIFVcg5qRNsGsmFxqf2I9+uUjSPoQ78RnHlCDdJliKX Rflg99rBG7nOtO8Bjj7rKbTwxqOCmDPmV1nYrqnyhIKwuPXp7QpfFYQLNJk5dpcr8U IRottfcOh8PSbINk5FcWmB9Kc0GRrrXg5sMn3lcE= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x436.google.com (mail-wr1-x436.google.com [IPv6:2a00:1450:4864:20::436]) by sourceware.org (Postfix) with ESMTPS id A201B3959CAA for ; Mon, 10 Oct 2022 15:34:00 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org A201B3959CAA Received: by mail-wr1-x436.google.com with SMTP id j16so17586489wrh.5 for ; Mon, 10 Oct 2022 08:34:00 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=date:message-id:to:subject:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=vwtvZW5cuUIKNauBjInRnq2PKSjXrIYa/qxNNbRe4pU=; b=2cP07pQ5fuvv4mslrymdges6Wofg5kahHnKjXOGOV7TJ43vnOPCt3bddTuVtyUp0Rr 7YDcuB2PkxKGll9OxPt3jC05piNuurlE7AmjlusPeXWAb+hmPMFti0vdrqbgHDTwxXNT NCJANfo6mXPdWVeSrEkEk4tw5e7TimHM8IAo5Fw0D2UI/5pjlh5vOTGhGbkmRE4AufOv Ha50DqdQbEnZnZzWWp0MedMvA5qECQ2dup1x0XRvhSx/EJwtPg7iM9d6V3ecr+RM9Pxj 6DUDFBse5CchLzHcR4dj/hTbVPjQsGLzXt2Mo0EYyhQhMLDqx53n0FruNLFqRIjwNTaj qBEA== X-Gm-Message-State: ACrzQf0pQdsQu3qvVijJfXZTwKC9s2d7xrfy34D62NSOdZEaLvhtcav0 nzcrUJf8KH8pWB53KilU2jPQAPNeghc= X-Received: by 2002:a5d:5850:0:b0:22b:1ada:a0d1 with SMTP id i16-20020a5d5850000000b0022b1adaa0d1mr11686846wrf.313.1665416037542; Mon, 10 Oct 2022 08:33:57 -0700 (PDT) Received: from lancelot ([195.147.220.46]) by smtp.gmail.com with ESMTPSA id j26-20020adfd21a000000b0022cc0a2cbecsm9057624wrh.15.2022.10.10.08.31.26 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 10 Oct 2022 08:33:57 -0700 (PDT) X-Google-Original-From: Gaius Mulley Received: from gaius by lancelot with local (Exim 4.94.2) (envelope-from ) id 1ohukV-00Bm34-D9 for gcc-patches@gcc.gnu.org; Mon, 10 Oct 2022 16:31:23 +0100 Subject: [PATCH] 12/19 modula2 front end: gimple interface *[e-f]*.cc To: X-Mailer: mail (GNU Mailutils 3.10) Message-Id: Date: Mon, 10 Oct 2022 16:31:23 +0100 X-Spam-Status: No, score=-1.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, KAM_SHORT, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Gaius Mulley via Gcc-patches From: Gaius Mulley Reply-To: Gaius Mulley Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1746316030201033499?= X-GMAIL-MSGID: =?utf-8?q?1746316030201033499?= This patchset contains the gimple interface. ------8<----------8<----------8<----------8<----------8<----------8<---- diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2except.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2except.cc 2022-10-07 20:21:18.650096940 +0100 @@ -0,0 +1,623 @@ +/* m2except.cc implements the construction of exception trees. + +Copyright (C) 2012-2022 Free Software Foundation, Inc. +Contributed by Gaius Mulley . + +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 +. */ + +#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 " \ + "\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" diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2expr.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2expr.cc 2022-10-07 20:21:18.650096940 +0100 @@ -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 . + +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 +. */ + +#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"