From patchwork Tue Dec 6 14:47:27 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Gaius Mulley X-Patchwork-Id: 30355 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:adf:f944:0:0:0:0:0 with SMTP id q4csp2867692wrr; Tue, 6 Dec 2022 06:58:45 -0800 (PST) X-Google-Smtp-Source: AA0mqf5dbqAz0BpuVH/rZdMRvbmlu+7Y2TALbmJUsPbt6e+v5c578M76YC4rhT1hFkIO78oTJenj X-Received: by 2002:a17:906:b103:b0:7c0:9a2e:2840 with SMTP id u3-20020a170906b10300b007c09a2e2840mr24829132ejy.404.1670338725459; Tue, 06 Dec 2022 06:58:45 -0800 (PST) ARC-Seal: i=1; a=rsa-sha256; t=1670338725; cv=none; d=google.com; s=arc-20160816; b=AY+tSUDKWg8CYWudrna5fyIvU7FU8/51yuEpjBDYy46vcl5IrdY/IoyzVegW/oirV0 b6bgrmvAUcQGCcNtytf4zY4t7QyHlsAKllriDXsLnOR7ekKk+ylkBFfBc4Qb+uEdaXTB /NtDSCh7CJ7fonMa74ceBPOW4059l+Ex/NFNFs/9R6BBrI1w0zXPFB7YNmyIiXhSiWev 27ajwfA8yjKrtSAirHdlUyqnSMX1/cg1771IKuIh0d86b5ZSmC4+UMXmRXR3qSekVKEn amnDbtKmE/UMnJaTUgu25HCCqjrTP0XYVwGJLlBqFn7jF3lhsxO1qLXWcP/uhxRrGD4l 14GQ== 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=OKB1HCFcLuJ9RRBmR+2bVy1kGVqVs6Hue9GoxOGuZi8=; b=GW1cC4ujz4NMK+VewxRKoCez/A92kQxY5YrOFjvOFosUCKcxC2rkfy+1uiNH5AcrNL HNb5WrwwWxI5G7gw9B8gJQYu5+FzpwYGcl9Rfil3qRQDFvwi0YT4DUzBSH3OCdgURoJs ZYkIF28PVJSNZCdxp+PJ9JRQ2KTo9ysaQDUgG1PJk0jz46qZKSiuQD4YCWWaRXs9dpj6 5WvHP5fsXpk3r3qSuzZfkx9cnuP7oVVLyc2UxLW9LrFgyCsCc8H57XrJM2KbbP3vTMm+ +YvxUKQJmKrUPQ6dMtz8/F2zlyPrHVtu0VplmCSItmrykTAXvQ3cIjgD/8Lod04KIVJ2 6Gzw== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=Pg1FYVj6; 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 ca12-20020aa7cd6c000000b0046aa75bee2dsi1878554edb.367.2022.12.06.06.58.44 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Dec 2022 06:58:45 -0800 (PST) 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=Pg1FYVj6; 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 C85A638367A1 for ; Tue, 6 Dec 2022 14:53:29 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org C85A638367A1 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1670338409; bh=OKB1HCFcLuJ9RRBmR+2bVy1kGVqVs6Hue9GoxOGuZi8=; h=Subject:To:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=Pg1FYVj6nWCKCLDn7MAKs8s7PHkP7GnfzTpv+iOjJ28tR8wVLiu3IoKnz2X/5Zmjl KTaBo38RicB8CarowCFzdfETP/We2hj3INVD1Lj/m46EU5M2DGniEl6Y1Aw6VBKEVC iLDp3QK3YMqzAtvLoUyiS3+BBZ38I+1CRJm6kNSA= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42d.google.com (mail-wr1-x42d.google.com [IPv6:2a00:1450:4864:20::42d]) by sourceware.org (Postfix) with ESMTPS id B5A3A3875B55 for ; Tue, 6 Dec 2022 14:47:54 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org B5A3A3875B55 Received: by mail-wr1-x42d.google.com with SMTP id h10so14249261wrx.3 for ; Tue, 06 Dec 2022 06:47:54 -0800 (PST) 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=OKB1HCFcLuJ9RRBmR+2bVy1kGVqVs6Hue9GoxOGuZi8=; b=qnsjxIoUfwyEdVf6TJlqsDOabLXnUgrLwChZZRR9ChjSgk6TVRrdr0klg0PtYUQLmD 9zOF4wxQV0SaZSYQL6Df1w1jGhtxeA2gzrqE8mphLTNbbGE4EOeKqpaJQliTBnURVQK4 VAC8ExmdyfO3yox271/BUQao5WmHnYroj+YvpLYBpB4KS1cldVp6ZKSpyy7lg6giM3Hv 1yOu/9HX7CI3M43cQtI3IKlWgCqbnmqUB/hFlEW0VTm0AIG/g/hGQ/xNEoILYCqf1P9N h/Nr4iIdL66OOECOEmGY6KiW/Llo8drYXrKTKaYvntPCEqWs/7M/pAa/YQUQEJsX9Rce CLzA== X-Gm-Message-State: ANoB5pnYJxoNh109nwjv55BPO7se2Jpdw1DaS7Omy7KlmL6Lxt3d2eZ7 kFgWCrqAwcIkR4OAxCGTkT+GsNb1Pd8= X-Received: by 2002:adf:f944:0:b0:236:8f54:f1f4 with SMTP id q4-20020adff944000000b002368f54f1f4mr53722187wrr.654.1670338072234; Tue, 06 Dec 2022 06:47:52 -0800 (PST) Received: from lancelot ([195.147.220.46]) by smtp.gmail.com with ESMTPSA id m18-20020adfe952000000b002421888a011sm17000598wrn.69.2022.12.06.06.47.29 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Dec 2022 06:47:51 -0800 (PST) X-Google-Original-From: Gaius Mulley Received: from gaius by lancelot with local (Exim 4.94.2) (envelope-from ) id 1p2ZEF-004QgF-C1 for gcc-patches@gcc.gnu.org; Tue, 06 Dec 2022 14:47:27 +0000 Subject: [PATCH v3 11/19] modula2 front end: gimple interface *[a-d]*.cc To: X-Mailer: mail (GNU Mailutils 3.10) Message-Id: Date: Tue, 06 Dec 2022 14:47:27 +0000 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?1751477099618470862?= X-GMAIL-MSGID: =?utf-8?q?1751477099618470862?= This patchset contains the gimple interface. ------8<----------8<----------8<----------8<----------8<----------8<---- diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2assert.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2assert.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,41 @@ +/* m2assert.cc provides a simple assertion for location. + +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" + +#define m2assert_c +#include "m2assert.h" +#include "m2options.h" + +void +m2assert_AssertLocation (location_t location) +{ + /* Internally the compiler will use unknown location and + builtins_location so we ignore these values. */ + if (location == BUILTINS_LOCATION || location == UNKNOWN_LOCATION) + return; + + if (M2Options_OverrideLocation (location) != location) + internal_error ("the location value is corrupt"); +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2block.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2block.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,770 @@ +/* m2block.cc provides an interface to maintaining block structures. + +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" + +#define m2block_c +#include "m2assert.h" +#include "m2block.h" +#include "m2decl.h" +#include "m2options.h" +#include "m2tree.h" +#include "m2treelib.h" + +/* For each binding contour we allocate a binding_level structure + which records the entities defined or declared in that contour. + Contours include: + + the global one one for each subprogram definition + + Binding contours are used to create GCC tree BLOCK nodes. */ + +struct GTY (()) binding_level +{ + /* The function associated with the scope. This is NULL_TREE for the + global scope. */ + tree fndecl; + + /* A chain of _DECL nodes for all variables, constants, functions, + and typedef types. These are in the reverse of the order supplied. */ + tree names; + + /* A boolean to indicate whether this is binding level is a global ie + outer module scope. In which case fndecl will be NULL_TREE. */ + int is_global; + + /* The context of the binding level, for a function binding level + this will be the same as fndecl, however for a global binding level + this is a translation_unit. */ + tree context; + + /* The binding level below this one. This field is only used when + the binding level has been pushed by pushFunctionScope. */ + struct binding_level *next; + + /* All binding levels are placed onto this list. */ + struct binding_level *list; + + /* A varray of trees, which represent the list of statement + sequences. */ + vec *m2_statements; + + /* A list of constants (only kept in the global binding level). + Constants need to be kept through the life of the compilation, as the + same constants can be used in any scope. */ + tree constants; + + /* A list of inner module initialization functions. */ + tree init_functions; + + /* A list of types created by M2GCCDeclare prior to code generation + and those which may not be specifically declared and saved via a + push_decl. */ + tree types; + + /* A list of all DECL_EXPR created within this binding level. This + will be prepended to the statement list once the binding level (scope + is finished). */ + tree decl; + + /* A list of labels which have been created in this scope. */ + tree labels; + + /* The number of times this level has been pushed. */ + int count; +}; + +/* The binding level currently in effect. */ + +static GTY (()) struct binding_level *current_binding_level; + +/* The outermost binding level, for names of file scope. This is + created when the compiler is started and exists through the entire + run. */ + +static GTY (()) struct binding_level *global_binding_level; + +/* The head of the binding level lists. */ +static GTY (()) struct binding_level *head_binding_level; + +/* The current statement tree. */ + +typedef struct stmt_tree_s *stmt_tree_t; + +#undef DEBUGGING + +static location_t pending_location; +static int pending_statement = FALSE; + +/* assert_global_names asserts that the global_binding_level->names + can be chained. */ + +static void +assert_global_names (void) +{ + tree p = global_binding_level->names; + + while (p) + p = TREE_CHAIN (p); +} + +/* lookupLabel return label tree in current scope, otherwise + NULL_TREE. */ + +static tree +lookupLabel (tree id) +{ + tree t; + + for (t = current_binding_level->labels; t != NULL_TREE; t = TREE_CHAIN (t)) + { + tree l = TREE_VALUE (t); + + if (id == DECL_NAME (l)) + return l; + } + return NULL_TREE; +} + +/* getLabel return the label name or create a label name in the + current scope. */ + +tree +m2block_getLabel (location_t location, char *name) +{ + tree id = get_identifier (name); + tree label = lookupLabel (id); + + if (label == NULL_TREE) + { + label = build_decl (location, LABEL_DECL, id, void_type_node); + current_binding_level->labels + = tree_cons (NULL_TREE, label, current_binding_level->labels); + } + if (DECL_CONTEXT (label) == NULL_TREE) + DECL_CONTEXT (label) = current_function_decl; + ASSERT ((DECL_CONTEXT (label) == current_function_decl), + current_function_decl); + + DECL_MODE (label) = VOIDmode; + return label; +} + +static void +init_binding_level (struct binding_level *l) +{ + l->fndecl = NULL; + l->names = NULL; + l->is_global = 0; + l->context = NULL; + l->next = NULL; + l->list = NULL; + vec_alloc (l->m2_statements, 1); + l->constants = NULL; + l->init_functions = NULL; + l->types = NULL; + l->decl = NULL; + l->labels = NULL; + l->count = 0; +} + +static struct binding_level * +newLevel (void) +{ + struct binding_level *newlevel = ggc_alloc (); + + init_binding_level (newlevel); + + /* Now we a push_statement_list. */ + vec_safe_push (newlevel->m2_statements, m2block_begin_statement_list ()); + return newlevel; +} + +tree * +m2block_cur_stmt_list_addr (void) +{ + ASSERT_CONDITION (current_binding_level != NULL); + int l = vec_safe_length (current_binding_level->m2_statements) - 1; + + return &(*current_binding_level->m2_statements)[l]; +} + +tree +m2block_cur_stmt_list (void) +{ + tree *t = m2block_cur_stmt_list_addr (); + + return *t; +} + +/* is_building_stmt_list returns TRUE if we are building a + statement list. TRUE is returned if we are in a binding level and + a statement list is under construction. */ + +int +m2block_is_building_stmt_list (void) +{ + ASSERT_CONDITION (current_binding_level != NULL); + return !vec_safe_is_empty (current_binding_level->m2_statements); +} + +/* push_statement_list pushes the statement list t onto the + current binding level. */ + +tree +m2block_push_statement_list (tree t) +{ + ASSERT_CONDITION (current_binding_level != NULL); + vec_safe_push (current_binding_level->m2_statements, t); + return t; +} + +/* pop_statement_list pops and returns a statement list from the + current binding level. */ + +tree +m2block_pop_statement_list (void) +{ + ASSERT_CONDITION (current_binding_level != NULL); + { + tree t = current_binding_level->m2_statements->pop (); + + return t; + } +} + +/* begin_statement_list starts a tree statement. It pushes the + statement list and returns the list node. */ + +tree +m2block_begin_statement_list (void) +{ + return alloc_stmt_list (); +} + +/* findLevel returns the binding level associated with fndecl one + is created if there is no existing one on head_binding_level. */ + +static struct binding_level * +findLevel (tree fndecl) +{ + struct binding_level *b; + + if (fndecl == NULL_TREE) + return global_binding_level; + + b = head_binding_level; + while ((b != NULL) && (b->fndecl != fndecl)) + b = b->list; + + if (b == NULL) + { + b = newLevel (); + b->fndecl = fndecl; + b->context = fndecl; + b->is_global = FALSE; + b->list = head_binding_level; + b->next = NULL; + } + return b; +} + +/* pushFunctionScope push a binding level. */ + +void +m2block_pushFunctionScope (tree fndecl) +{ + struct binding_level *n; + struct binding_level *b; + +#if defined(DEBUGGING) + if (fndecl != NULL) + printf ("pushFunctionScope\n"); +#endif + + /* Allow multiple consecutive pushes of the same scope. */ + + if (current_binding_level != NULL + && (current_binding_level->fndecl == fndecl)) + { + current_binding_level->count++; + return; + } + + /* Firstly check to see that fndecl is not already on the binding + stack. */ + + for (b = current_binding_level; b != NULL; b = b->next) + /* Only allowed one instance of the binding on the stack at a time. */ + ASSERT_CONDITION (b->fndecl != fndecl); + + n = findLevel (fndecl); + + /* Add this level to the front of the stack. */ + n->next = current_binding_level; + current_binding_level = n; +} + +/* popFunctionScope - pops a binding level, returning the function + associated with the binding level. */ + +tree +m2block_popFunctionScope (void) +{ + tree fndecl = current_binding_level->fndecl; + +#if defined(DEBUGGING) + if (fndecl != NULL) + printf ("popFunctionScope\n"); +#endif + + if (current_binding_level->count > 0) + { + /* Multiple pushes have occurred of the same function scope (and + ignored), pop them likewise. */ + current_binding_level->count--; + return fndecl; + } + ASSERT_CONDITION (current_binding_level->fndecl + != NULL_TREE); /* Expecting local scope. */ + + ASSERT_CONDITION (current_binding_level->constants + == NULL_TREE); /* Should not be used. */ + ASSERT_CONDITION (current_binding_level->names + == NULL_TREE); /* Should be cleared. */ + ASSERT_CONDITION (current_binding_level->decl + == NULL_TREE); /* Should be cleared. */ + + current_binding_level = current_binding_level->next; + return fndecl; +} + +/* pushGlobalScope push the global scope onto the binding level + stack. There can only ever be one instance of the global binding + level on the stack. */ + +void +m2block_pushGlobalScope (void) +{ +#if defined(DEBUGGING) + printf ("pushGlobalScope\n"); +#endif + m2block_pushFunctionScope (NULL_TREE); +} + +/* popGlobalScope pops the current binding level, it expects this + binding level to be the global binding level. */ + +void +m2block_popGlobalScope (void) +{ + ASSERT_CONDITION ( + current_binding_level->is_global); /* Expecting global scope. */ + ASSERT_CONDITION (current_binding_level == global_binding_level); + + if (current_binding_level->count > 0) + { + current_binding_level->count--; + return; + } + + current_binding_level = current_binding_level->next; +#if defined(DEBUGGING) + printf ("popGlobalScope\n"); +#endif + + assert_global_names (); +} + +/* finishFunctionDecl removes declarations from the current binding + level and places them inside fndecl. The current binding level is + then able to be destroyed by a call to popFunctionScope. + + The extra tree nodes associated with fndecl will be created such + as BIND_EXPR, BLOCK and the initial STATEMENT_LIST containing the + DECL_EXPR is also created. */ + +void +m2block_finishFunctionDecl (location_t location, tree fndecl) +{ + tree context = current_binding_level->context; + tree block = DECL_INITIAL (fndecl); + tree bind_expr = DECL_SAVED_TREE (fndecl); + tree i; + + if (block == NULL_TREE) + { + block = make_node (BLOCK); + DECL_INITIAL (fndecl) = block; + TREE_USED (block) = TRUE; + BLOCK_SUBBLOCKS (block) = NULL_TREE; + } + BLOCK_SUPERCONTEXT (block) = context; + + BLOCK_VARS (block) + = chainon (BLOCK_VARS (block), current_binding_level->names); + TREE_USED (fndecl) = TRUE; + + if (bind_expr == NULL_TREE) + { + bind_expr + = build3 (BIND_EXPR, void_type_node, current_binding_level->names, + current_binding_level->decl, block); + DECL_SAVED_TREE (fndecl) = bind_expr; + } + else + { + if (!chain_member (current_binding_level->names, + BIND_EXPR_VARS (bind_expr))) + { + BIND_EXPR_VARS (bind_expr) = chainon (BIND_EXPR_VARS (bind_expr), + current_binding_level->names); + + if (current_binding_level->names != NULL_TREE) + { + for (i = current_binding_level->names; i != NULL_TREE; + i = DECL_CHAIN (i)) + append_to_statement_list_force (i, + &BIND_EXPR_BODY (bind_expr)); + + } + } + } + SET_EXPR_LOCATION (bind_expr, location); + + current_binding_level->names = NULL_TREE; + current_binding_level->decl = NULL_TREE; +} + +/* finishFunctionCode adds cur_stmt_list to fndecl. The current + binding level is then able to be destroyed by a call to + popFunctionScope. The cur_stmt_list is appended to the + STATEMENT_LIST. */ + +void +m2block_finishFunctionCode (tree fndecl) +{ + tree bind_expr; + tree block; + tree statements = m2block_pop_statement_list (); + tree_stmt_iterator i; + + ASSERT_CONDITION (DECL_SAVED_TREE (fndecl) != NULL_TREE); + + bind_expr = DECL_SAVED_TREE (fndecl); + ASSERT_CONDITION (TREE_CODE (bind_expr) == BIND_EXPR); + + block = DECL_INITIAL (fndecl); + ASSERT_CONDITION (TREE_CODE (block) == BLOCK); + + if (current_binding_level->names != NULL_TREE) + { + BIND_EXPR_VARS (bind_expr) + = chainon (BIND_EXPR_VARS (bind_expr), current_binding_level->names); + current_binding_level->names = NULL_TREE; + } + if (current_binding_level->labels != NULL_TREE) + { + tree t; + + for (t = current_binding_level->labels; t != NULL_TREE; + t = TREE_CHAIN (t)) + { + tree l = TREE_VALUE (t); + + BIND_EXPR_VARS (bind_expr) = chainon (BIND_EXPR_VARS (bind_expr), l); + } + current_binding_level->labels = NULL_TREE; + } + + BLOCK_VARS (block) = BIND_EXPR_VARS (bind_expr); + + if (current_binding_level->decl != NULL_TREE) + for (i = tsi_start (current_binding_level->decl); !tsi_end_p (i); + tsi_next (&i)) + append_to_statement_list_force (*tsi_stmt_ptr (i), + &BIND_EXPR_BODY (bind_expr)); + + for (i = tsi_start (statements); !tsi_end_p (i); tsi_next (&i)) + append_to_statement_list_force (*tsi_stmt_ptr (i), + &BIND_EXPR_BODY (bind_expr)); + + current_binding_level->decl = NULL_TREE; +} + +void +m2block_finishGlobals (void) +{ + tree context = global_binding_level->context; + tree block = make_node (BLOCK); + tree p = global_binding_level->names; + + BLOCK_SUBBLOCKS (block) = NULL; + TREE_USED (block) = 1; + + BLOCK_VARS (block) = p; + + DECL_INITIAL (context) = block; + BLOCK_SUPERCONTEXT (block) = context; +} + +/* pushDecl pushes a declaration onto the current binding level. */ + +tree +m2block_pushDecl (tree decl) +{ + /* External objects aren't nested, other objects may be. */ + + if (decl != current_function_decl) + DECL_CONTEXT (decl) = current_binding_level->context; + + /* Put the declaration on the list. The list of declarations is in + reverse order. The list will be reversed later if necessary. This + needs to be this way for compatibility with the back-end. */ + + TREE_CHAIN (decl) = current_binding_level->names; + current_binding_level->names = decl; + + assert_global_names (); + + return decl; +} + +/* includeDecl pushes a declaration onto the current binding level + providing it is not already present. */ + +void +m2block_includeDecl (tree decl) +{ + tree p = current_binding_level->names; + + while (p != decl && p != NULL) + p = TREE_CHAIN (p); + if (p != decl) + m2block_pushDecl (decl); +} + +/* addDeclExpr adds the DECL_EXPR node t to the statement list + current_binding_level->decl. This allows us to order all + declarations at the beginning of the function. */ + +void +m2block_addDeclExpr (tree t) +{ + append_to_statement_list_force (t, ¤t_binding_level->decl); +} + +/* RememberType remember the type t in the ggc marked list. */ + +tree +m2block_RememberType (tree t) +{ + global_binding_level->types + = tree_cons (NULL_TREE, t, global_binding_level->types); + return t; +} + +/* global_constant returns t. It chains t onto the + global_binding_level list of constants, if it is not already + present. */ + +tree +m2block_global_constant (tree t) +{ + tree s; + + if (global_binding_level->constants != NULL_TREE) + for (s = global_binding_level->constants; s != NULL_TREE; + s = TREE_CHAIN (s)) + { + tree c = TREE_VALUE (s); + + if (c == t) + return t; + } + + global_binding_level->constants + = tree_cons (NULL_TREE, t, global_binding_level->constants); + return t; +} + +/* RememberConstant adds a tree t onto the list of constants to + be marked whenever the ggc re-marks all used storage. Constants + live throughout the whole compilation and they can be used by + many different functions if necessary. */ + +tree +m2block_RememberConstant (tree t) +{ + if ((t != NULL) && (m2tree_IsAConstant (t))) + return m2block_global_constant (t); + return t; +} + +/* DumpGlobalConstants displays all global constants and checks + none are poisoned. */ + +tree +m2block_DumpGlobalConstants (void) +{ + tree s; + + if (global_binding_level->constants != NULL_TREE) + for (s = global_binding_level->constants; TREE_CHAIN (s); + s = TREE_CHAIN (s)) + debug_tree (s); + return NULL_TREE; +} + +/* RememberInitModuleFunction records tree t in the global + binding level. So that it will not be garbage collected. In + theory the inner modules could be placed inside the + current_binding_level I suspect. */ + +tree +m2block_RememberInitModuleFunction (tree t) +{ + global_binding_level->init_functions + = tree_cons (NULL_TREE, t, global_binding_level->init_functions); + return t; +} + +/* toplevel return TRUE if we are in the global scope. */ + +int +m2block_toplevel (void) +{ + if (current_binding_level == NULL) + return TRUE; + if (current_binding_level->fndecl == NULL) + return TRUE; + return FALSE; +} + +/* GetErrorNode returns the gcc error_mark_node. */ + +tree +m2block_GetErrorNode (void) +{ + return error_mark_node; +} + +/* GetGlobals - returns a list of global variables, functions, + constants. */ + +tree +m2block_GetGlobals (void) +{ + assert_global_names (); + return global_binding_level->names; +} + +/* GetGlobalContext - returns the global context tree. */ + +tree +m2block_GetGlobalContext (void) +{ + return global_binding_level->context; +} + +/* do_add_stmt - t is a statement. Add it to the statement-tree. */ + +static tree +do_add_stmt (tree t) +{ + if (current_binding_level != NULL) + append_to_statement_list_force (t, m2block_cur_stmt_list_addr ()); + return t; +} + +/* flush_pending_note - flushes a pending_statement note if + necessary. */ + +static void +flush_pending_note (void) +{ + if (pending_statement && (M2Options_GetM2g ())) + { +#if 0 + /* --fixme-- we need a machine independant way to generate a nop. */ + tree instr = m2decl_BuildStringConstant ("nop", 3); + tree string + = resolve_asm_operand_names (instr, NULL_TREE, NULL_TREE, NULL_TREE); + tree note = build_stmt (pending_location, ASM_EXPR, string, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE); + + ASM_INPUT_P (note) = FALSE; + ASM_VOLATILE_P (note) = FALSE; +#else + tree note = build_empty_stmt (pending_location); +#endif + pending_statement = FALSE; + do_add_stmt (note); + } +} + +/* add_stmt t is a statement. Add it to the statement-tree. */ + +tree +m2block_add_stmt (location_t location, tree t) +{ + if ((CAN_HAVE_LOCATION_P (t)) && (!EXPR_HAS_LOCATION (t))) + SET_EXPR_LOCATION (t, location); + + if (pending_statement && (pending_location != location)) + flush_pending_note (); + + pending_statement = FALSE; + return do_add_stmt (t); +} + +/* addStmtNote remember this location represents the start of a + Modula-2 statement. It is flushed if another different location + is generated or another tree is given to add_stmt. */ + +void +m2block_addStmtNote (location_t location) +{ + if (pending_statement && (pending_location != location)) + flush_pending_note (); + + pending_statement = TRUE; + pending_location = location; +} + +void +m2block_removeStmtNote (void) +{ + pending_statement = FALSE; +} + +/* init - initialize the data structures in this module. */ + +void +m2block_init (void) +{ + global_binding_level = newLevel (); + global_binding_level->context = build_translation_unit_decl (NULL); + global_binding_level->is_global = TRUE; + current_binding_level = NULL; +} + +#include "gt-m2-m2block.h" diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2builtins.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2builtins.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,1330 @@ +/* m2builtins.cc provides an interface to the GCC builtins. + +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 "m2block.h" +#include "m2convert.h" +#include "m2decl.h" +#include "m2expr.h" +#include "m2statement.h" +#include "m2tree.h" +#include "m2treelib.h" +#include "m2type.h" + +#define GM2 +#define GM2_BUG_REPORT \ + "Please report this crash to the GNU Modula-2 mailing list " \ + "\n" + +#define ASSERT(X, Y) \ + { \ + if (!(X)) \ + { \ + debug_tree (Y); \ + internal_error ("%s:%d:assertion of condition `%s' failed", __FILE__, __LINE__, \ + #X); \ + } \ + } +#define ERROR(X) \ + { \ + internal_error ("%s:%d:%s", __FILE__, __LINE__, X); \ + } + +typedef enum { + BT_FN_NONE, + BT_FN_PTR_SIZE, + BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE, + BT_FN_FLOAT, + BT_FN_DOUBLE, + BT_FN_LONG_DOUBLE, + BT_FN_FLOAT_FLOAT, + BT_FN_DOUBLE_DOUBLE, + BT_FN_LONG_DOUBLE_LONG_DOUBLE, + BT_FN_STRING_CONST_STRING_INT, + BT_FN_INT_CONST_PTR_CONST_PTR_SIZE, + BT_FN_TRAD_PTR_PTR_INT_SIZE, + BT_FN_STRING_STRING_CONST_STRING, + BT_FN_STRING_STRING_CONST_STRING_SIZE, + BT_FN_INT_CONST_STRING_CONST_STRING, + BT_FN_INT_CONST_STRING_CONST_STRING_SIZE, + BT_FN_INT_CONST_STRING, + BT_FN_STRING_CONST_STRING_CONST_STRING, + BT_FN_SIZE_CONST_STRING_CONST_STRING, + BT_FN_PTR_UNSIGNED, + BT_FN_VOID_PTR_INT, + BT_FN_INT_PTR, + BT_FN_INT_FLOAT, + BT_FN_INT_DOUBLE, + BT_FN_INT_LONG_DOUBLE, + BT_FN_FLOAT_FCOMPLEX, + BT_FN_DOUBLE_DCOMPLEX, + BT_FN_LONG_DOUBLE_LDCOMPLEX, + + BT_FN_FCOMPLEX_FCOMPLEX, + BT_FN_DCOMPLEX_DCOMPLEX, + BT_FN_LDCOMPLEX_LDCOMPLEX, + + BT_FN_DCOMPLEX_DOUBLE_DCOMPLEX, + BT_FN_FCOMPLEX_FLOAT_FCOMPLEX, + BT_FN_LDCOMPLEX_LONG_DOUBLE_LDCOMPLEX, + + BT_FN_FLOAT_FLOAT_FLOATPTR, + BT_FN_DOUBLE_DOUBLE_DOUBLEPTR, + BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLEPTR, + + BT_FN_FLOAT_FLOAT_LONG_DOUBLE, + BT_FN_DOUBLE_DOUBLE_LONG_DOUBLE, + BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE, + + BT_FN_FLOAT_FLOAT_LONG, + BT_FN_DOUBLE_DOUBLE_LONG, + BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG, + + BT_FN_FLOAT_FLOAT_INT, + BT_FN_DOUBLE_DOUBLE_INT, + BT_FN_LONG_DOUBLE_LONG_DOUBLE_INT, + + BT_FN_FLOAT_FLOAT_FLOAT, + BT_FN_DOUBLE_DOUBLE_DOUBLE, +} builtin_prototype; + +struct builtin_function_entry +{ + const char *name; + builtin_prototype defn; + int function_code; + enum built_in_class fclass; + const char *library_name; + tree function_node; + tree return_node; +}; + +/* Entries are added by examining gcc/builtins.def and copying those + functions which can be applied to Modula-2. */ + +static struct builtin_function_entry list_of_builtins[] = { + { "__builtin_alloca", BT_FN_PTR_SIZE, BUILT_IN_ALLOCA, BUILT_IN_NORMAL, + "alloca", NULL, NULL }, + { "__builtin_memcpy", BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE, BUILT_IN_MEMCPY, + BUILT_IN_NORMAL, "memcpy", NULL, NULL }, + + { "__builtin_isfinite", BT_FN_INT_DOUBLE, BUILT_IN_ISFINITE, BUILT_IN_NORMAL, + "isfinite", NULL, NULL }, + + { "__builtin_sinf", BT_FN_FLOAT_FLOAT, BUILT_IN_SINF, BUILT_IN_NORMAL, + "sinf", NULL, NULL }, + { "__builtin_sin", BT_FN_DOUBLE_DOUBLE, BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", + NULL, NULL }, + { "__builtin_sinl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_SINL, + BUILT_IN_NORMAL, "sinl", NULL, NULL }, + { "__builtin_cosf", BT_FN_FLOAT_FLOAT, BUILT_IN_SINF, BUILT_IN_NORMAL, + "cosf", NULL, NULL }, + { "__builtin_cos", BT_FN_DOUBLE_DOUBLE, BUILT_IN_COS, BUILT_IN_NORMAL, "cos", + NULL, NULL }, + { "__builtin_cosl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_COSL, + BUILT_IN_NORMAL, "cosl", NULL, NULL }, + { "__builtin_sqrtf", BT_FN_FLOAT_FLOAT, BUILT_IN_SQRTF, BUILT_IN_NORMAL, + "sqrtf", NULL, NULL }, + { "__builtin_sqrt", BT_FN_DOUBLE_DOUBLE, BUILT_IN_SQRT, BUILT_IN_NORMAL, + "sqrt", NULL, NULL }, + { "__builtin_sqrtl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_SQRTL, + BUILT_IN_NORMAL, "sqrtl", NULL, NULL }, + { "__builtin_fabsf", BT_FN_FLOAT_FLOAT, BUILT_IN_FABSF, BUILT_IN_NORMAL, + "fabsf", NULL, NULL }, + { "__builtin_fabs", BT_FN_DOUBLE_DOUBLE, BUILT_IN_FABS, BUILT_IN_NORMAL, + "fabs", NULL, NULL }, + { "__builtin_fabsl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_FABSL, + BUILT_IN_NORMAL, "fabsl", NULL, NULL }, + { "__builtin_logf", BT_FN_FLOAT_FLOAT, BUILT_IN_LOGF, BUILT_IN_NORMAL, + "logf", NULL, NULL }, + { "__builtin_log", BT_FN_DOUBLE_DOUBLE, BUILT_IN_LOG, BUILT_IN_NORMAL, "log", + NULL, NULL }, + { "__builtin_logl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_LOGL, + BUILT_IN_NORMAL, "logl", NULL, NULL }, + { "__builtin_expf", BT_FN_FLOAT_FLOAT, BUILT_IN_EXPF, BUILT_IN_NORMAL, + "expf", NULL, NULL }, + { "__builtin_exp", BT_FN_DOUBLE_DOUBLE, BUILT_IN_EXP, BUILT_IN_NORMAL, "exp", + NULL, NULL }, + { "__builtin_expl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_EXPL, + BUILT_IN_NORMAL, "expl", NULL, NULL }, + { "__builtin_log10f", BT_FN_FLOAT_FLOAT, BUILT_IN_LOG10F, BUILT_IN_NORMAL, + "log10f", NULL, NULL }, + { "__builtin_log10", BT_FN_DOUBLE_DOUBLE, BUILT_IN_LOG10, BUILT_IN_NORMAL, + "log10", NULL, NULL }, + { "__builtin_log10l", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_LOG10L, + BUILT_IN_NORMAL, "log10l", NULL, NULL }, + { "__builtin_ilogbf", BT_FN_INT_FLOAT, BUILT_IN_ILOGBF, BUILT_IN_NORMAL, + "ilogbf", NULL, NULL }, + { "__builtin_ilogb", BT_FN_INT_DOUBLE, BUILT_IN_ILOGB, BUILT_IN_NORMAL, + "ilogb", NULL, NULL }, + { "__builtin_ilogbl", BT_FN_INT_LONG_DOUBLE, BUILT_IN_ILOGBL, + BUILT_IN_NORMAL, "ilogbl", NULL, NULL }, + + { "__builtin_atan2f", BT_FN_FLOAT_FLOAT_FLOAT, BUILT_IN_ATAN2F, + BUILT_IN_NORMAL, "atan2f", NULL, NULL }, + { "__builtin_atan2", BT_FN_DOUBLE_DOUBLE_DOUBLE, BUILT_IN_ATAN2, + BUILT_IN_NORMAL, "atan2", NULL, NULL }, + { "__builtin_atan2l", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE, + BUILT_IN_ATAN2L, BUILT_IN_NORMAL, "atan2l", NULL, NULL }, + + { "__builtin_signbit", BT_FN_INT_DOUBLE, BUILT_IN_SIGNBIT, BUILT_IN_NORMAL, + "signbit", NULL, NULL }, + { "__builtin_signbitf", BT_FN_INT_FLOAT, BUILT_IN_SIGNBITF, BUILT_IN_NORMAL, + "signbitf", NULL, NULL }, + { "__builtin_signbitl", BT_FN_INT_LONG_DOUBLE, BUILT_IN_SIGNBITL, + BUILT_IN_NORMAL, "signbitl", NULL, NULL }, + { "__builtin_significand", BT_FN_DOUBLE_DOUBLE, BUILT_IN_SIGNIFICAND, + BUILT_IN_NORMAL, "significand", NULL, NULL }, + { "__builtin_significandf", BT_FN_FLOAT_FLOAT, BUILT_IN_SIGNIFICANDF, + BUILT_IN_NORMAL, "significandf", NULL, NULL }, + { "__builtin_significandl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, + BUILT_IN_SIGNIFICANDL, BUILT_IN_NORMAL, "significandl", NULL, NULL }, + { "__builtin_modf", BT_FN_DOUBLE_DOUBLE_DOUBLEPTR, BUILT_IN_MODF, + BUILT_IN_NORMAL, "modf", NULL, NULL }, + { "__builtin_modff", BT_FN_FLOAT_FLOAT_FLOATPTR, BUILT_IN_MODFF, + BUILT_IN_NORMAL, "modff", NULL, NULL }, + { "__builtin_modfl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLEPTR, + BUILT_IN_MODFL, BUILT_IN_NORMAL, "modfl", NULL, NULL }, + { "__builtin_nextafter", BT_FN_DOUBLE_DOUBLE_DOUBLE, BUILT_IN_NEXTAFTER, + BUILT_IN_NORMAL, "nextafter", NULL, NULL }, + { "__builtin_nextafterf", BT_FN_FLOAT_FLOAT_FLOAT, BUILT_IN_NEXTAFTERF, + BUILT_IN_NORMAL, "nextafterf", NULL, NULL }, + { "__builtin_nextafterl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE, + BUILT_IN_NEXTAFTERL, BUILT_IN_NORMAL, "nextafterl", NULL, NULL }, + { "__builtin_nexttoward", BT_FN_DOUBLE_DOUBLE_LONG_DOUBLE, + BUILT_IN_NEXTTOWARD, BUILT_IN_NORMAL, "nexttoward", NULL, NULL }, + { "__builtin_nexttowardf", BT_FN_FLOAT_FLOAT_LONG_DOUBLE, + BUILT_IN_NEXTTOWARDF, BUILT_IN_NORMAL, "nexttowardf", NULL, NULL }, + { "__builtin_nexttowardl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE, + BUILT_IN_NEXTTOWARDL, BUILT_IN_NORMAL, "nexttowardl", NULL, NULL }, + { "__builtin_scalb", BT_FN_DOUBLE_DOUBLE_DOUBLE, BUILT_IN_SCALB, + BUILT_IN_NORMAL, "scalb", NULL, NULL }, + { "__builtin_scalbf", BT_FN_FLOAT_FLOAT_FLOAT, BUILT_IN_SCALBF, + BUILT_IN_NORMAL, "scalbf", NULL, NULL }, + { "__builtin_scalbl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE, + BUILT_IN_SCALBL, BUILT_IN_NORMAL, "scalbl", NULL, NULL }, + { "__builtin_scalbln", BT_FN_DOUBLE_DOUBLE_LONG, BUILT_IN_SCALBLN, + BUILT_IN_NORMAL, "scalbln", NULL, NULL }, + { "__builtin_scalblnf", BT_FN_FLOAT_FLOAT_LONG, BUILT_IN_SCALBLNF, + BUILT_IN_NORMAL, "scalblnf", NULL, NULL }, + { "__builtin_scalblnl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG, + BUILT_IN_SCALBLNL, BUILT_IN_NORMAL, "scalblnl", NULL, NULL }, + { "__builtin_scalbn", BT_FN_DOUBLE_DOUBLE_INT, BUILT_IN_SCALBN, + BUILT_IN_NORMAL, "scalbln", NULL, NULL }, + { "__builtin_scalbnf", BT_FN_FLOAT_FLOAT_INT, BUILT_IN_SCALBNF, + BUILT_IN_NORMAL, "scalblnf", NULL, NULL }, + { "__builtin_scalbnl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_INT, BUILT_IN_SCALBNL, + BUILT_IN_NORMAL, "scalblnl", NULL, NULL }, + + /* Complex intrinsic functions. */ + { "__builtin_cabs", BT_FN_DOUBLE_DCOMPLEX, BUILT_IN_CABS, BUILT_IN_NORMAL, + "cabs", NULL, NULL }, + { "__builtin_cabsf", BT_FN_FLOAT_FCOMPLEX, BUILT_IN_CABSF, BUILT_IN_NORMAL, + "cabsf", NULL, NULL }, + { "__builtin_cabsl", BT_FN_LONG_DOUBLE_LDCOMPLEX, BUILT_IN_CABSL, + BUILT_IN_NORMAL, "cabsl", NULL, NULL }, + + { "__builtin_carg", BT_FN_DOUBLE_DCOMPLEX, BUILT_IN_CABS, BUILT_IN_NORMAL, + "carg", NULL, NULL }, + { "__builtin_cargf", BT_FN_FLOAT_FCOMPLEX, BUILT_IN_CABSF, BUILT_IN_NORMAL, + "cargf", NULL, NULL }, + { "__builtin_cargl", BT_FN_LONG_DOUBLE_LDCOMPLEX, BUILT_IN_CABSL, + BUILT_IN_NORMAL, "cargl", NULL, NULL }, + + { "__builtin_conj", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CONJ, BUILT_IN_NORMAL, + "carg", NULL, NULL }, + { "__builtin_conjf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CONJF, + BUILT_IN_NORMAL, "conjf", NULL, NULL }, + { "__builtin_conjl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CONJL, + BUILT_IN_NORMAL, "conjl", NULL, NULL }, + + { "__builtin_cpow", BT_FN_DCOMPLEX_DOUBLE_DCOMPLEX, BUILT_IN_CPOW, + BUILT_IN_NORMAL, "cpow", NULL, NULL }, + { "__builtin_cpowf", BT_FN_FCOMPLEX_FLOAT_FCOMPLEX, BUILT_IN_CPOWF, + BUILT_IN_NORMAL, "cpowf", NULL, NULL }, + { "__builtin_cpowl", BT_FN_LDCOMPLEX_LONG_DOUBLE_LDCOMPLEX, BUILT_IN_CPOWL, + BUILT_IN_NORMAL, "cpowl", NULL, NULL }, + + { "__builtin_csqrt", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CSQRT, + BUILT_IN_NORMAL, "csqrt", NULL, NULL }, + { "__builtin_csqrtf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CSQRTF, + BUILT_IN_NORMAL, "csqrtf", NULL, NULL }, + { "__builtin_csqrtl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CSQRTL, + BUILT_IN_NORMAL, "csqrtl", NULL, NULL }, + + { "__builtin_cexp", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CEXP, BUILT_IN_NORMAL, + "cexp", NULL, NULL }, + { "__builtin_cexpf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CEXPF, + BUILT_IN_NORMAL, "cexpf", NULL, NULL }, + { "__builtin_cexpl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CEXPL, + BUILT_IN_NORMAL, "cexpl", NULL, NULL }, + + { "__builtin_cln", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CLOG, BUILT_IN_NORMAL, + "cln", NULL, NULL }, + { "__builtin_clnf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CLOGF, BUILT_IN_NORMAL, + "clnf", NULL, NULL }, + { "__builtin_clnl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CLOGL, + BUILT_IN_NORMAL, "clnl", NULL, NULL }, + + { "__builtin_csin", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CSIN, BUILT_IN_NORMAL, + "csin", NULL, NULL }, + { "__builtin_csinf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CSINF, + BUILT_IN_NORMAL, "csinf", NULL, NULL }, + { "__builtin_csinl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CSINL, + BUILT_IN_NORMAL, "csinl", NULL, NULL }, + + { "__builtin_ccos", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CCOS, BUILT_IN_NORMAL, + "ccos", NULL, NULL }, + { "__builtin_ccosf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CCOSF, + BUILT_IN_NORMAL, "ccosf", NULL, NULL }, + { "__builtin_ccosl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CCOSL, + BUILT_IN_NORMAL, "ccosl", NULL, NULL }, + + { "__builtin_ctan", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CTAN, BUILT_IN_NORMAL, + "ctan", NULL, NULL }, + { "__builtin_ctanf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CTANF, + BUILT_IN_NORMAL, "ctanf", NULL, NULL }, + { "__builtin_ctanl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CTANL, + BUILT_IN_NORMAL, "ctanl", NULL, NULL }, + + { "__builtin_casin", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CASIN, + BUILT_IN_NORMAL, "casin", NULL, NULL }, + { "__builtin_casinf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CASINF, + BUILT_IN_NORMAL, "casinf", NULL, NULL }, + { "__builtin_casinl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CASINL, + BUILT_IN_NORMAL, "casinl", NULL, NULL }, + + { "__builtin_cacos", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CACOS, + BUILT_IN_NORMAL, "cacos", NULL, NULL }, + { "__builtin_cacosf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CACOSF, + BUILT_IN_NORMAL, "cacosf", NULL, NULL }, + { "__builtin_cacosl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CACOSL, + BUILT_IN_NORMAL, "cacosl", NULL, NULL }, + + { "__builtin_catan", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CATAN, + BUILT_IN_NORMAL, "catan", NULL, NULL }, + { "__builtin_catanf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CATANF, + BUILT_IN_NORMAL, "catanf", NULL, NULL }, + { "__builtin_catanl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CATANL, + BUILT_IN_NORMAL, "catanl", NULL, NULL }, + + { "__builtin_huge_val", BT_FN_DOUBLE, BUILT_IN_HUGE_VAL, BUILT_IN_NORMAL, + "huge_val", NULL, NULL }, + { "__builtin_huge_valf", BT_FN_FLOAT, BUILT_IN_HUGE_VALF, BUILT_IN_NORMAL, + "huge_valf", NULL, NULL }, + { "__builtin_huge_vall", BT_FN_LONG_DOUBLE, BUILT_IN_HUGE_VALL, + BUILT_IN_NORMAL, "huge_vall", NULL, NULL }, + + { "__builtin_index", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_INDEX, + BUILT_IN_NORMAL, "index", NULL, NULL }, + { "__builtin_rindex", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_RINDEX, + BUILT_IN_NORMAL, "rindex", NULL, NULL }, + { "__builtin_memcmp", BT_FN_INT_CONST_PTR_CONST_PTR_SIZE, BUILT_IN_MEMCMP, + BUILT_IN_NORMAL, "memcmp", NULL, NULL }, + { "__builtin_memmove", BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE, BUILT_IN_MEMMOVE, + BUILT_IN_NORMAL, "memmove", NULL, NULL }, + { "__builtin_memset", BT_FN_TRAD_PTR_PTR_INT_SIZE, BUILT_IN_MEMSET, + BUILT_IN_NORMAL, "memset", NULL, NULL }, + { "__builtin_strcat", BT_FN_STRING_STRING_CONST_STRING, BUILT_IN_STRCAT, + BUILT_IN_NORMAL, "strcat", NULL, NULL }, + { "__builtin_strncat", BT_FN_STRING_STRING_CONST_STRING_SIZE, + BUILT_IN_STRNCAT, BUILT_IN_NORMAL, "strncat", NULL, NULL }, + { "__builtin_strcpy", BT_FN_STRING_STRING_CONST_STRING, BUILT_IN_STRCPY, + BUILT_IN_NORMAL, "strcpy", NULL, NULL }, + { "__builtin_strncpy", BT_FN_STRING_STRING_CONST_STRING_SIZE, + BUILT_IN_STRNCPY, BUILT_IN_NORMAL, "strncpy", NULL, NULL }, + { "__builtin_strcmp", BT_FN_INT_CONST_STRING_CONST_STRING, BUILT_IN_STRCMP, + BUILT_IN_NORMAL, "strcmp", NULL, NULL }, + { "__builtin_strncmp", BT_FN_INT_CONST_STRING_CONST_STRING_SIZE, + BUILT_IN_STRNCMP, BUILT_IN_NORMAL, "strncmp", NULL, NULL }, + { "__builtin_strlen", BT_FN_INT_CONST_STRING, BUILT_IN_STRLEN, + BUILT_IN_NORMAL, "strlen", NULL, NULL }, + { "__builtin_strstr", BT_FN_STRING_CONST_STRING_CONST_STRING, + BUILT_IN_STRSTR, BUILT_IN_NORMAL, "strstr", NULL, NULL }, + { "__builtin_strpbrk", BT_FN_STRING_CONST_STRING_CONST_STRING, + BUILT_IN_STRPBRK, BUILT_IN_NORMAL, "strpbrk", NULL, NULL }, + { "__builtin_strspn", BT_FN_SIZE_CONST_STRING_CONST_STRING, BUILT_IN_STRSPN, + BUILT_IN_NORMAL, "strspn", NULL, NULL }, + { "__builtin_strcspn", BT_FN_SIZE_CONST_STRING_CONST_STRING, + BUILT_IN_STRCSPN, BUILT_IN_NORMAL, "strcspn", NULL, NULL }, + { "__builtin_strchr", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_STRCHR, + BUILT_IN_NORMAL, "strchr", NULL, NULL }, + { "__builtin_strrchr", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_STRCHR, + BUILT_IN_NORMAL, "strrchr", NULL, NULL }, + //{ "__builtin_constant_p", BT_FN_INT_VAR, BUILT_IN_CONSTANT_P, + //BUILT_IN_NORMAL, "constant_p", NULL, NULL}, + { "__builtin_frame_address", BT_FN_PTR_UNSIGNED, BUILT_IN_FRAME_ADDRESS, + BUILT_IN_NORMAL, "frame_address", NULL, NULL }, + { "__builtin_return_address", BT_FN_PTR_UNSIGNED, BUILT_IN_RETURN_ADDRESS, + BUILT_IN_NORMAL, "return_address", NULL, NULL }, + //{ "__builtin_aggregate_incoming_address", BT_FN_PTR_VAR, + //BUILT_IN_AGGREGATE_INCOMING_ADDRESS, BUILT_IN_NORMAL, + //"aggregate_incoming_address", NULL, NULL}, + { "__builtin_longjmp", BT_FN_VOID_PTR_INT, BUILT_IN_LONGJMP, BUILT_IN_NORMAL, + "longjmp", NULL, NULL }, + { "__builtin_setjmp", BT_FN_INT_PTR, BUILT_IN_SETJMP, BUILT_IN_NORMAL, + "setjmp", NULL, NULL }, + { NULL, BT_FN_NONE, 0, NOT_BUILT_IN, "", NULL, NULL } +}; + +struct builtin_type_info +{ + const char *name; + unsigned int returnType; + tree (*functionHandler) (location_t, tree); +}; + +static GTY (()) tree sizetype_endlink; +static GTY (()) tree unsigned_endlink; +static GTY (()) tree endlink; +static GTY (()) tree math_endlink; +static GTY (()) tree int_endlink; +static GTY (()) tree ptr_endlink; +static GTY (()) tree const_ptr_endlink; +static GTY (()) tree double_ftype_void; +static GTY (()) tree float_ftype_void; +static GTY (()) tree ldouble_ftype_void; +static GTY (()) tree float_ftype_float; +static GTY (()) tree double_ftype_double; +static GTY (()) tree ldouble_ftype_ldouble; +static GTY (()) tree gm2_alloca_node; +static GTY (()) tree gm2_memcpy_node; +static GTY (()) tree gm2_isfinite_node; +static GTY (()) tree gm2_huge_valf_node; +static GTY (()) tree gm2_huge_val_node; +static GTY (()) tree gm2_huge_vall_node; +static GTY (()) tree long_doubleptr_type_node; +static GTY (()) tree doubleptr_type_node; +static GTY (()) tree floatptr_type_node; +static GTY (()) tree builtin_ftype_int_var; + +/* Prototypes for locally defined functions. */ +static tree DoBuiltinAlloca (location_t location, tree n); +static tree DoBuiltinMemCopy (location_t location, tree dest, tree src, + tree n); +static tree DoBuiltinIsfinite (location_t location, tree value); +static void create_function_prototype (location_t location, + struct builtin_function_entry *fe); +static tree doradix (location_t location, tree type); +static tree doplaces (location_t location, tree type); +static tree doexponentmin (location_t location, tree type); +static tree doexponentmax (location_t location, tree type); +static tree dolarge (location_t location, tree type); +static tree dosmall (location_t location, tree type); +static tree doiec559 (location_t location, tree type); +static tree dolia1 (location_t location, tree type); +static tree doiso (location_t location, tree type); +static tree doieee (location_t location, tree type); +static tree dorounds (location_t location, tree type); +static tree dogUnderflow (location_t location, tree type); +static tree doexception (location_t location, tree type); +static tree doextend (location_t location, tree type); +static tree donModes (location_t location, tree type); +/* Prototypes finish here. */ + +#define m2builtins_c +#include "m2builtins.h" + +static struct builtin_type_info m2_type_info[] = { + { "radix", 2, doradix }, + { "places", 2, doplaces }, + { "expoMin", 2, doexponentmin }, + { "expoMax", 2, doexponentmax }, + { "large", 3, dolarge }, + { "small", 3, dosmall }, + { "IEC559", 1, doiec559 }, + { "LIA1", 1, dolia1 }, + { "ISO", 1, doiso }, + { "IEEE", 1, doieee }, + { "rounds", 1, dorounds }, + { "gUnderflow", 1, dogUnderflow }, + { "exception", 1, doexception }, + { "extend", 1, doextend }, + { "nModes", 2, donModes }, + { NULL, 0, NULL }, +}; + +/* Return a definition for a builtin function named NAME and whose +data type is TYPE. TYPE should be a function type with argument +types. FUNCTION_CODE tells later passes how to compile calls to this +function. See tree.h for its possible values. + +If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, the +name to be called if we can't opencode the function. */ + +tree +builtin_function (location_t location, const char *name, tree type, + int function_code, enum built_in_class fclass, + const char *library_name, tree attrs) +{ + tree decl = add_builtin_function (name, type, function_code, fclass, + library_name, attrs); + DECL_SOURCE_LOCATION (decl) = location; + + m2block_pushDecl (decl); + return decl; +} + +/* GetBuiltinConst - returns the gcc tree of a builtin constant, + name. NIL is returned if the constant is unknown. */ + +tree +m2builtins_GetBuiltinConst (char *name) +{ + if (strcmp (name, "BITS_PER_UNIT") == 0) + return m2decl_BuildIntegerConstant (BITS_PER_UNIT); + if (strcmp (name, "BITS_PER_WORD") == 0) + return m2decl_BuildIntegerConstant (BITS_PER_WORD); + if (strcmp (name, "BITS_PER_CHAR") == 0) + return m2decl_BuildIntegerConstant (CHAR_TYPE_SIZE); + if (strcmp (name, "UNITS_PER_WORD") == 0) + return m2decl_BuildIntegerConstant (UNITS_PER_WORD); + + return NULL_TREE; +} + +/* GetBuiltinConstType - returns the type of a builtin constant, + name. 0 = unknown constant name 1 = integer 2 = real. */ + +unsigned int +m2builtins_GetBuiltinConstType (char *name) +{ + if (strcmp (name, "BITS_PER_UNIT") == 0) + return 1; + if (strcmp (name, "BITS_PER_WORD") == 0) + return 1; + if (strcmp (name, "BITS_PER_CHAR") == 0) + return 1; + if (strcmp (name, "UNITS_PER_WORD") == 0) + return 1; + + return 0; +} + +/* GetBuiltinTypeInfoType - returns value: 0 is ident is unknown. 1 + if ident is IEC559, LIA1, ISO, IEEE, rounds, underflow, exception, + extend. 2 if ident is radix, places, exponentmin, exponentmax, + noofmodes. 3 if ident is large, small. */ + +unsigned int +m2builtins_GetBuiltinTypeInfoType (const char *ident) +{ + int i = 0; + + while (m2_type_info[i].name != NULL) + if (strcmp (m2_type_info[i].name, ident) == 0) + return m2_type_info[i].returnType; + else + i++; + return 0; +} + +/* GetBuiltinTypeInfo - returns value: NULL_TREE if ident is unknown. + boolean Tree if ident is IEC559, LIA1, ISO, IEEE, rounds, + underflow, exception, extend. ZType Tree if ident is radix, + places, exponentmin, exponentmax, noofmodes. + RType Tree if ident is large, small. */ + +tree +m2builtins_GetBuiltinTypeInfo (location_t location, tree type, + const char *ident) +{ + int i = 0; + + type = m2tree_skip_type_decl (type); + while (m2_type_info[i].name != NULL) + if (strcmp (m2_type_info[i].name, ident) == 0) + return (*m2_type_info[i].functionHandler) (location, type); + else + i++; + return NULL_TREE; +} + +/* doradix - returns the radix of the floating point, type. */ + +static tree +doradix (location_t location ATTRIBUTE_UNUSED, tree type) +{ + if (TREE_CODE (type) == REAL_TYPE) + { + enum machine_mode mode = TYPE_MODE (type); + int radix = REAL_MODE_FORMAT (mode)->b; + return m2decl_BuildIntegerConstant (radix); + } + else + return NULL_TREE; +} + +/* doplaces - returns the whole number value of the number of radix + places used to store values of the corresponding real number type. */ + +static tree +doplaces (location_t location ATTRIBUTE_UNUSED, tree type) +{ + if (TREE_CODE (type) == REAL_TYPE) + { + /* Taken from c-family/c-cppbuiltin.cc. */ + /* The number of decimal digits, q, such that any floating-point + number with q decimal digits can be rounded into a + floating-point number with p radix b digits and back again + without change to the q decimal digits, p log10 b if b is a + power of 10 floor((p - 1) log10 b) otherwise. */ + enum machine_mode mode = TYPE_MODE (type); + const struct real_format *fmt = REAL_MODE_FORMAT (mode); + const double log10_2 = .30102999566398119521; + double log10_b = log10_2; + int digits = (fmt->p - 1) * log10_b; + return m2decl_BuildIntegerConstant (digits); + } + else + return NULL_TREE; +} + +/* doexponentmin - returns the whole number of the exponent minimum. */ + +static tree +doexponentmin (location_t location ATTRIBUTE_UNUSED, tree type) +{ + if (TREE_CODE (type) == REAL_TYPE) + { + enum machine_mode mode = TYPE_MODE (type); + int emin = REAL_MODE_FORMAT (mode)->emin; + return m2decl_BuildIntegerConstant (emin); + } + else + return NULL_TREE; +} + +/* doexponentmax - returns the whole number of the exponent maximum. */ + +static tree +doexponentmax (location_t location ATTRIBUTE_UNUSED, tree type) +{ + if (TREE_CODE (type) == REAL_TYPE) + { + enum machine_mode mode = TYPE_MODE (type); + int emax = REAL_MODE_FORMAT (mode)->emax; + return m2decl_BuildIntegerConstant (emax); + } + else + return NULL_TREE; +} + +static tree +computeLarge (tree type) +{ + enum machine_mode mode = TYPE_MODE (type); + const struct real_format *fmt = REAL_MODE_FORMAT (mode); + REAL_VALUE_TYPE real; + char buf[128]; + + /* Shamelessly taken from c-cppbuiltin.cc:builtin_define_float_constants. */ + + /* Since, for the supported formats, B is always a power of 2, we + construct the following numbers directly as a hexadecimal constants. */ + + get_max_float (fmt, buf, sizeof (buf), false); + real_from_string (&real, buf); + return build_real (type, real); +} + +/* dolarge - return the largest value of the corresponding real type. */ + +static tree +dolarge (location_t location ATTRIBUTE_UNUSED, tree type) +{ + if (TREE_CODE (type) == REAL_TYPE) + return computeLarge (type); + return NULL_TREE; +} + +static tree +computeSmall (tree type) +{ + enum machine_mode mode = TYPE_MODE (type); + const struct real_format *fmt = REAL_MODE_FORMAT (mode); + REAL_VALUE_TYPE real; + char buf[128]; + + /* The minimum normalized positive floating-point number, + b**(emin-1). */ + + sprintf (buf, "0x1p%d", fmt->emin - 1); + real_from_string (&real, buf); + return build_real (type, real); +} + +/* dosmall - return the smallest positive value of the corresponding + real type. */ + +static tree +dosmall (location_t location ATTRIBUTE_UNUSED, tree type) +{ + if (TREE_CODE (type) == REAL_TYPE) + return computeSmall (type); + return NULL_TREE; +} + +/* doiec559 - a boolean value that is true if and only if the + implementation of the corresponding real number type conforms to + IEC 559:1989 (also known as IEEE 754:1987) in all regards. */ + +static tree +doiec559 (location_t location, tree type) +{ + if (m2expr_IsTrue (m2expr_BuildEqualTo (location, + m2decl_BuildIntegerConstant (32), + m2expr_GetSizeOfInBits (type)))) + return m2type_GetBooleanTrue (); + if (m2expr_IsTrue (m2expr_BuildEqualTo (location, + m2decl_BuildIntegerConstant (64), + m2expr_GetSizeOfInBits (type)))) + return m2type_GetBooleanTrue (); + return m2type_GetBooleanFalse (); +} + +/* dolia1 - returns TRUE if using ieee (currently always TRUE). */ + +static tree +dolia1 (location_t location, tree type) +{ + return doieee (location, type); +} + +/* doiso - returns TRUE if using ieee (--fixme--). */ + +static tree +doiso (location_t location, tree type) +{ + return doieee (location, type); +} + +/* doieee - returns TRUE if ieee arithmetic is being used. */ + +static tree +doieee (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED) +{ + /* --fixme-- maybe we should look for the -mno-ieee flag and return this + result. */ + return m2type_GetBooleanTrue (); +} + +/* dorounds - returns TRUE if and only if each operation produces a + result that is one of the values of the corresponding real number + type nearest to the mathematical result. */ + +static tree +dorounds (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED) +{ + if (FLT_ROUNDS) + return m2type_GetBooleanTrue (); + else + return m2type_GetBooleanFalse (); +} + +/* dogUnderflow - returns TRUE if and only if there are values of the + corresponding real number type between 0.0 and small. */ + +static tree +dogUnderflow (location_t location ATTRIBUTE_UNUSED, tree type) +{ + if (TREE_CODE (type) == REAL_TYPE) + { + enum machine_mode mode = TYPE_MODE (type); + const struct real_format *fmt = REAL_MODE_FORMAT (mode); + if (fmt->has_denorm) + return m2type_GetBooleanTrue (); + else + return m2type_GetBooleanFalse (); + } + return NULL_TREE; +} + +/* doexception - */ + +static tree +doexception (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED) +{ + return m2type_GetBooleanTrue (); +} + +/* doextend - */ + +static tree +doextend (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED) +{ + return m2type_GetBooleanTrue (); +} + +/* donModes - */ + +static tree +donModes (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED) +{ + return m2decl_BuildIntegerConstant (1); +} + +/* BuiltInMemCopy - copy n bytes of memory efficiently from address + src to dest. */ + +tree +m2builtins_BuiltInMemCopy (location_t location, tree dest, tree src, tree n) +{ + return DoBuiltinMemCopy (location, dest, src, n); +} + +/* BuiltInAlloca - given an expression, n, allocate, n, bytes on the + stack for the life of the current function. */ + +tree +m2builtins_BuiltInAlloca (location_t location, tree n) +{ + return DoBuiltinAlloca (location, n); +} + +/* BuiltInIsfinite - return integer 1 if the real expression is + finite otherwise return integer 0. */ + +tree +m2builtins_BuiltInIsfinite (location_t location, tree expression) +{ + return DoBuiltinIsfinite (location, expression); +} + +/* BuiltinExists - returns TRUE if the builtin function, name, exists + for this target architecture. */ + +int +m2builtins_BuiltinExists (char *name) +{ + struct builtin_function_entry *fe; + + for (fe = &list_of_builtins[0]; fe->name != NULL; fe++) + if (strcmp (name, fe->name) == 0) + return TRUE; + + return FALSE; +} + +/* BuildBuiltinTree - returns a Tree containing the builtin function, + name. */ + +tree +m2builtins_BuildBuiltinTree (location_t location, char *name) +{ + struct builtin_function_entry *fe; + tree t; + + m2statement_SetLastFunction (NULL_TREE); + for (fe = &list_of_builtins[0]; fe->name != NULL; fe++) + if (strcmp (name, fe->name) == 0) + { + tree functype = TREE_TYPE (fe->function_node); + tree funcptr = build1 (ADDR_EXPR, build_pointer_type (functype), + fe->function_node); + + m2statement_SetLastFunction (m2treelib_DoCall ( + location, fe->return_node, funcptr, m2statement_GetParamList ())); + m2statement_SetParamList (NULL_TREE); + t = m2statement_GetLastFunction (); + if (fe->return_node == void_type_node) + m2statement_SetLastFunction (NULL_TREE); + return t; + } + + m2statement_SetParamList (NULL_TREE); + return m2statement_GetLastFunction (); +} + +static tree +DoBuiltinMemCopy (location_t location, tree dest, tree src, tree bytes) +{ + tree functype = TREE_TYPE (gm2_memcpy_node); + tree funcptr + = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_memcpy_node); + tree call + = m2treelib_DoCall3 (location, ptr_type_node, funcptr, dest, src, bytes); + return call; +} + +static tree +DoBuiltinAlloca (location_t location, tree bytes) +{ + tree functype = TREE_TYPE (gm2_alloca_node); + tree funcptr + = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_alloca_node); + tree call = m2treelib_DoCall1 (location, ptr_type_node, funcptr, bytes); + + return call; +} + +static tree +DoBuiltinIsfinite (location_t location, tree value) +{ + tree functype = TREE_TYPE (gm2_isfinite_node); + tree funcptr + = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_isfinite_node); + tree call = m2treelib_DoCall1 (location, ptr_type_node, funcptr, value); + + return call; +} + +tree +m2builtins_BuiltInHugeVal (location_t location) +{ + tree functype = TREE_TYPE (gm2_huge_val_node); + tree funcptr + = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_huge_val_node); + tree call = m2treelib_DoCall0 (location, ptr_type_node, funcptr); + return call; +} + +tree +m2builtins_BuiltInHugeValShort (location_t location) +{ + tree functype = TREE_TYPE (gm2_huge_valf_node); + tree funcptr + = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_huge_valf_node); + tree call = m2treelib_DoCall0 (location, ptr_type_node, funcptr); + return call; +} + +tree +m2builtins_BuiltInHugeValLong (location_t location) +{ + tree functype = TREE_TYPE (gm2_huge_vall_node); + tree funcptr + = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_huge_vall_node); + tree call = m2treelib_DoCall0 (location, ptr_type_node, funcptr); + return call; +} + +static void +create_function_prototype (location_t location, + struct builtin_function_entry *fe) +{ + tree ftype; + + switch (fe->defn) + { + + case BT_FN_PTR_SIZE: + ftype = build_function_type (ptr_type_node, sizetype_endlink); + fe->return_node = ptr_type_node; + break; + + case BT_FN_STRING_STRING_CONST_STRING_SIZE: + case BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE: + ftype = build_function_type ( + ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, + tree_cons (NULL_TREE, const_ptr_type_node, + sizetype_endlink))); + fe->return_node = ptr_type_node; + break; + case BT_FN_FLOAT: + ftype = float_ftype_void; + fe->return_node = float_type_node; + break; + case BT_FN_DOUBLE: + ftype = double_ftype_void; + fe->return_node = double_type_node; + break; + case BT_FN_LONG_DOUBLE: + ftype = ldouble_ftype_void; + fe->return_node = long_double_type_node; + break; + case BT_FN_FLOAT_FLOAT: + ftype = float_ftype_float; + fe->return_node = float_type_node; + break; + case BT_FN_DOUBLE_DOUBLE: + ftype = double_ftype_double; + fe->return_node = double_type_node; + break; + case BT_FN_LONG_DOUBLE_LONG_DOUBLE: + ftype = ldouble_ftype_ldouble; + fe->return_node = long_double_type_node; + break; + case BT_FN_STRING_CONST_STRING_INT: + ftype = build_function_type ( + ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, int_endlink)); + fe->return_node = ptr_type_node; + break; + case BT_FN_INT_CONST_PTR_CONST_PTR_SIZE: + ftype = build_function_type ( + integer_type_node, + tree_cons (NULL_TREE, const_ptr_type_node, + tree_cons (NULL_TREE, const_ptr_type_node, int_endlink))); + fe->return_node = integer_type_node; + break; + case BT_FN_TRAD_PTR_PTR_INT_SIZE: + ftype = build_function_type ( + ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, + tree_cons (NULL_TREE, integer_type_node, + sizetype_endlink))); + fe->return_node = ptr_type_node; + break; + case BT_FN_STRING_STRING_CONST_STRING: + ftype = build_function_type ( + ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, ptr_endlink)); + fe->return_node = ptr_type_node; + break; + case BT_FN_INT_CONST_STRING_CONST_STRING: + ftype = build_function_type ( + integer_type_node, + tree_cons (NULL_TREE, const_ptr_type_node, ptr_endlink)); + fe->return_node = integer_type_node; + break; + case BT_FN_INT_CONST_STRING_CONST_STRING_SIZE: + ftype = build_function_type ( + integer_type_node, + tree_cons ( + NULL_TREE, const_ptr_type_node, + tree_cons (NULL_TREE, const_ptr_type_node, sizetype_endlink))); + fe->return_node = integer_type_node; + break; + case BT_FN_INT_CONST_STRING: + ftype = build_function_type (integer_type_node, ptr_endlink); + fe->return_node = integer_type_node; + break; + case BT_FN_STRING_CONST_STRING_CONST_STRING: + ftype = build_function_type ( + ptr_type_node, + tree_cons (NULL_TREE, const_ptr_type_node, const_ptr_endlink)); + fe->return_node = ptr_type_node; + break; + case BT_FN_SIZE_CONST_STRING_CONST_STRING: + ftype = build_function_type ( + sizetype, + tree_cons (NULL_TREE, const_ptr_type_node, const_ptr_endlink)); + fe->return_node = sizetype; + break; + case BT_FN_PTR_UNSIGNED: + ftype = build_function_type (ptr_type_node, unsigned_endlink); + fe->return_node = ptr_type_node; + break; + case BT_FN_VOID_PTR_INT: + ftype = build_function_type ( + void_type_node, tree_cons (NULL_TREE, ptr_type_node, int_endlink)); + fe->return_node = void_type_node; + break; + case BT_FN_INT_PTR: + ftype = build_function_type (integer_type_node, ptr_endlink); + fe->return_node = integer_type_node; + break; + case BT_FN_INT_FLOAT: + ftype = build_function_type ( + integer_type_node, tree_cons (NULL_TREE, float_type_node, endlink)); + fe->return_node = integer_type_node; + break; + case BT_FN_INT_DOUBLE: + ftype = build_function_type ( + integer_type_node, tree_cons (NULL_TREE, double_type_node, endlink)); + fe->return_node = integer_type_node; + break; + case BT_FN_INT_LONG_DOUBLE: + ftype = build_function_type ( + integer_type_node, + tree_cons (NULL_TREE, long_double_type_node, endlink)); + fe->return_node = integer_type_node; + break; + case BT_FN_FLOAT_FCOMPLEX: + ftype = build_function_type ( + float_type_node, + tree_cons (NULL_TREE, complex_float_type_node, endlink)); + fe->return_node = float_type_node; + break; + case BT_FN_DOUBLE_DCOMPLEX: + ftype = build_function_type ( + double_type_node, + tree_cons (NULL_TREE, complex_double_type_node, endlink)); + fe->return_node = double_type_node; + break; + case BT_FN_LONG_DOUBLE_LDCOMPLEX: + ftype = build_function_type ( + long_double_type_node, + tree_cons (NULL_TREE, complex_long_double_type_node, endlink)); + fe->return_node = long_double_type_node; + break; + case BT_FN_FCOMPLEX_FCOMPLEX: + ftype = build_function_type ( + complex_float_type_node, + tree_cons (NULL_TREE, complex_float_type_node, endlink)); + fe->return_node = complex_float_type_node; + break; + case BT_FN_DCOMPLEX_DCOMPLEX: + ftype = build_function_type ( + complex_double_type_node, + tree_cons (NULL_TREE, complex_double_type_node, endlink)); + fe->return_node = complex_double_type_node; + break; + case BT_FN_LDCOMPLEX_LDCOMPLEX: + ftype = build_function_type ( + complex_long_double_type_node, + tree_cons (NULL_TREE, complex_long_double_type_node, endlink)); + fe->return_node = complex_long_double_type_node; + break; + case BT_FN_DCOMPLEX_DOUBLE_DCOMPLEX: + ftype = build_function_type ( + complex_double_type_node, + tree_cons (NULL_TREE, complex_double_type_node, + tree_cons (NULL_TREE, double_type_node, endlink))); + fe->return_node = complex_double_type_node; + break; + case BT_FN_FCOMPLEX_FLOAT_FCOMPLEX: + ftype = build_function_type ( + complex_float_type_node, + tree_cons (NULL_TREE, complex_float_type_node, + tree_cons (NULL_TREE, float_type_node, endlink))); + fe->return_node = complex_float_type_node; + break; + case BT_FN_LDCOMPLEX_LONG_DOUBLE_LDCOMPLEX: + ftype = build_function_type ( + complex_long_double_type_node, + tree_cons (NULL_TREE, complex_long_double_type_node, + tree_cons (NULL_TREE, long_double_type_node, endlink))); + fe->return_node = complex_long_double_type_node; + break; + case BT_FN_FLOAT_FLOAT_FLOATPTR: + ftype = build_function_type ( + float_type_node, + tree_cons (NULL_TREE, float_type_node, + tree_cons (NULL_TREE, floatptr_type_node, endlink))); + fe->return_node = float_type_node; + break; + case BT_FN_DOUBLE_DOUBLE_DOUBLEPTR: + ftype = build_function_type ( + double_type_node, + tree_cons (NULL_TREE, double_type_node, + tree_cons (NULL_TREE, doubleptr_type_node, endlink))); + fe->return_node = double_type_node; + break; + case BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLEPTR: + ftype = build_function_type ( + long_double_type_node, + tree_cons ( + NULL_TREE, long_double_type_node, + tree_cons (NULL_TREE, long_doubleptr_type_node, endlink))); + fe->return_node = long_double_type_node; + break; + case BT_FN_FLOAT_FLOAT_LONG_DOUBLE: + ftype = build_function_type ( + float_type_node, + tree_cons (NULL_TREE, float_type_node, + tree_cons (NULL_TREE, long_double_type_node, endlink))); + fe->return_node = float_type_node; + break; + case BT_FN_DOUBLE_DOUBLE_LONG_DOUBLE: + ftype = build_function_type ( + double_type_node, + tree_cons (NULL_TREE, double_type_node, + tree_cons (NULL_TREE, long_double_type_node, endlink))); + fe->return_node = double_type_node; + break; + case BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE: + ftype = build_function_type ( + long_double_type_node, + tree_cons (NULL_TREE, long_double_type_node, + tree_cons (NULL_TREE, long_double_type_node, endlink))); + fe->return_node = long_double_type_node; + break; + case BT_FN_FLOAT_FLOAT_LONG: + ftype = build_function_type ( + float_type_node, + tree_cons (NULL_TREE, float_type_node, + tree_cons (NULL_TREE, long_integer_type_node, endlink))); + fe->return_node = float_type_node; + break; + case BT_FN_DOUBLE_DOUBLE_LONG: + ftype = build_function_type ( + double_type_node, + tree_cons (NULL_TREE, double_type_node, + tree_cons (NULL_TREE, long_integer_type_node, endlink))); + fe->return_node = double_type_node; + break; + case BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG: + ftype = build_function_type ( + long_double_type_node, + tree_cons (NULL_TREE, long_double_type_node, + tree_cons (NULL_TREE, long_integer_type_node, endlink))); + fe->return_node = long_double_type_node; + break; + case BT_FN_FLOAT_FLOAT_INT: + ftype = build_function_type ( + float_type_node, + tree_cons (NULL_TREE, float_type_node, + tree_cons (NULL_TREE, integer_type_node, endlink))); + fe->return_node = float_type_node; + break; + case BT_FN_DOUBLE_DOUBLE_INT: + ftype = build_function_type ( + double_type_node, + tree_cons (NULL_TREE, double_type_node, + tree_cons (NULL_TREE, integer_type_node, endlink))); + fe->return_node = double_type_node; + break; + case BT_FN_LONG_DOUBLE_LONG_DOUBLE_INT: + ftype = build_function_type ( + long_double_type_node, + tree_cons (NULL_TREE, long_double_type_node, + tree_cons (NULL_TREE, integer_type_node, endlink))); + fe->return_node = long_double_type_node; + break; + case BT_FN_FLOAT_FLOAT_FLOAT: + ftype = build_function_type ( + float_type_node, + tree_cons (NULL_TREE, float_type_node, + tree_cons (NULL_TREE, float_type_node, endlink))); + fe->return_node = float_type_node; + break; + case BT_FN_DOUBLE_DOUBLE_DOUBLE: + ftype = build_function_type ( + double_type_node, + tree_cons (NULL_TREE, double_type_node, + tree_cons (NULL_TREE, double_type_node, endlink))); + fe->return_node = double_type_node; + break; + default: + ERROR ("enum has no case"); + } + fe->function_node + = builtin_function (location, fe->name, ftype, fe->function_code, + fe->fclass, fe->library_name, NULL); +} + +static tree +find_builtin_tree (const char *name) +{ + struct builtin_function_entry *fe; + + for (fe = &list_of_builtins[0]; fe->name != NULL; fe++) + if (strcmp (name, fe->name) == 0) + return fe->function_node; + + ERROR ("cannot find builtin function"); + return NULL_TREE; +} + + +static void +set_decl_built_in_class (tree decl, built_in_class c) +{ + FUNCTION_DECL_CHECK (decl)->function_decl.built_in_class = c; +} + + +static void +set_decl_function_code (tree decl, built_in_function f) +{ + tree_function_decl &fndecl = FUNCTION_DECL_CHECK (decl)->function_decl; + fndecl.function_code = f; +} + +/* Define a single builtin. */ +static void +define_builtin (enum built_in_function val, const char *name, tree type, + const char *libname, int flags) +{ + tree decl; + + decl = build_decl (BUILTINS_LOCATION, FUNCTION_DECL, get_identifier (name), + type); + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + SET_DECL_ASSEMBLER_NAME (decl, get_identifier (libname)); + m2block_pushDecl (decl); + set_decl_built_in_class (decl, BUILT_IN_NORMAL); + set_decl_function_code (decl, val); + set_call_expr_flags (decl, flags); + + set_builtin_decl (val, decl, true); +} + +void +m2builtins_init (location_t location) +{ + int i; + + m2block_pushGlobalScope (); + endlink = void_list_node; + sizetype_endlink = tree_cons (NULL_TREE, sizetype, endlink); + math_endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); + int_endlink = tree_cons (NULL_TREE, integer_type_node, NULL_TREE); + ptr_endlink = tree_cons (NULL_TREE, ptr_type_node, NULL_TREE); + const_ptr_endlink = tree_cons (NULL_TREE, const_ptr_type_node, NULL_TREE); + unsigned_endlink = tree_cons (NULL_TREE, unsigned_type_node, NULL_TREE); + + float_ftype_void = build_function_type (float_type_node, math_endlink); + double_ftype_void = build_function_type (double_type_node, math_endlink); + ldouble_ftype_void + = build_function_type (long_double_type_node, math_endlink); + + long_doubleptr_type_node = build_pointer_type (long_double_type_node); + doubleptr_type_node = build_pointer_type (double_type_node); + floatptr_type_node = build_pointer_type (float_type_node); + + float_ftype_float = build_function_type ( + float_type_node, tree_cons (NULL_TREE, float_type_node, math_endlink)); + + double_ftype_double = build_function_type ( + double_type_node, tree_cons (NULL_TREE, double_type_node, math_endlink)); + + ldouble_ftype_ldouble = build_function_type ( + long_double_type_node, + tree_cons (NULL_TREE, long_double_type_node, endlink)); + + builtin_ftype_int_var = build_function_type ( + integer_type_node, tree_cons (NULL_TREE, double_type_node, endlink)); + + for (i = 0; list_of_builtins[i].name != NULL; i++) + create_function_prototype (location, &list_of_builtins[i]); + + define_builtin (BUILT_IN_TRAP, "__builtin_trap", + build_function_type_list (void_type_node, NULL_TREE), + "__builtin_trap", ECF_NOTHROW | ECF_LEAF | ECF_NORETURN); + define_builtin (BUILT_IN_ISGREATER, "isgreater", builtin_ftype_int_var, + "__builtin_isgreater", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + define_builtin (BUILT_IN_ISGREATEREQUAL, "isgreaterequal", + builtin_ftype_int_var, "__builtin_isgreaterequal", + ECF_CONST | ECF_NOTHROW | ECF_LEAF); + define_builtin (BUILT_IN_ISLESS, "isless", builtin_ftype_int_var, + "__builtin_isless", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + define_builtin (BUILT_IN_ISLESSEQUAL, "islessequal", builtin_ftype_int_var, + "__builtin_islessequal", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + define_builtin (BUILT_IN_ISLESSGREATER, "islessgreater", + builtin_ftype_int_var, "__builtin_islessgreater", + ECF_CONST | ECF_NOTHROW | ECF_LEAF); + define_builtin (BUILT_IN_ISUNORDERED, "isunordered", builtin_ftype_int_var, + "__builtin_isunordered", ECF_CONST | ECF_NOTHROW | ECF_LEAF); + + gm2_alloca_node = find_builtin_tree ("__builtin_alloca"); + gm2_memcpy_node = find_builtin_tree ("__builtin_memcpy"); + gm2_huge_valf_node = find_builtin_tree ("__builtin_huge_valf"); + gm2_huge_val_node = find_builtin_tree ("__builtin_huge_val"); + gm2_huge_vall_node = find_builtin_tree ("__builtin_huge_vall"); + gm2_isfinite_node = find_builtin_tree ("__builtin_isfinite"); + m2block_popGlobalScope (); +} + +#include "gt-m2-m2builtins.h" + +/* END m2builtins. */ diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2color.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2color.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,66 @@ +/* m2color.cc interface to gcc colorization. + +Copyright (C) 2019-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 +. */ + +#define m2color_c +#include "m2color.h" + +#include "gcc-consolidation.h" +#include "diagnostic-color.h" + + +char * +m2color_colorize_start (bool show_color, char *name, unsigned int name_len) +{ + return const_cast (colorize_start (show_color, name, name_len)); +} + + +char * +m2color_colorize_stop (bool show_color) +{ + return const_cast (colorize_stop (show_color)); +} + + +char * +m2color_open_quote (void) +{ + return const_cast (open_quote); +} + + +char * +m2color_close_quote (void) +{ + return const_cast (close_quote); +} + + +void +_M2_m2color_init () +{ +} + + +void +_M2_m2color_finish () +{ +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2configure.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2configure.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,101 @@ +/* m2configure.cc provides an interface to some configuration values. + +Copyright (C) 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 "config.h" +#include "system.h" +#include "libiberty.h" + +#include "config.h" +#include "system.h" +#include "libiberty.h" + +#include "gcc-consolidation.h" + +#include "../gm2-lang.h" +#include "../m2-tree.h" +#include "m2convert.h" + +/* Prototypes. */ + +#define m2configure_c + +#include "m2assert.h" +#include "m2builtins.h" +#include "m2convert.h" +#include "m2decl.h" +#include "m2expr.h" +#include "m2options.h" +#include "m2configure.h" + +#include "m2/gm2version.h" +#include "m2/gm2config.h" + +#define CPPPROGRAM "cc1" + + +/* gen_gm2_libexec returns a string containing libexec / + DEFAULT_TARGET_MACHINE string / DEFAULT_TARGET_MACHINE. */ + +static char * +gen_gm2_libexec (const char *libexec) +{ + int l = strlen (libexec) + 1 + strlen (DEFAULT_TARGET_MACHINE) + 1 + + strlen (DEFAULT_TARGET_VERSION) + 1; + char *s = (char *)xmalloc (l); + char dir_sep[2]; + + dir_sep[0] = DIR_SEPARATOR; + dir_sep[1] = (char)0; + + strcpy (s, libexec); + strcat (s, dir_sep); + strcat (s, DEFAULT_TARGET_MACHINE); + strcat (s, dir_sep); + strcat (s, DEFAULT_TARGET_VERSION); + return s; +} + +/* FullPathCPP returns the fullpath and program name to cpp. */ + +char * +m2configure_FullPathCPP (void) +{ + if (M2Options_GetCpp ()) + { + char *path = (char *) M2Options_GetB (); + + if (path == NULL) + path = gen_gm2_libexec (STANDARD_LIBEXEC_PREFIX); + + if (strcmp (path, "") == 0) + return xstrdup (CPPPROGRAM); + + char *full = (char *)xmalloc (strlen (path) + 1 + strlen (CPPPROGRAM) + 1); + strcpy (full, path); + char *sep = (char *)alloca (2); + sep[0] = DIR_SEPARATOR; + sep[1] = (char)0; + strcat (full, sep); + strcat (full, CPPPROGRAM); + return full; + } + return NULL; +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2convert.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2convert.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,659 @@ +/* m2convert.cc provides GCC tree conversion for the Modula-2 language. + +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" + +#define m2convert_c +#include "m2assert.h" +#include "m2block.h" +#include "m2convert.h" +#include "m2decl.h" +#include "m2expr.h" +#include "m2expr.h" +#include "m2statement.h" +#include "m2tree.h" +#include "m2treelib.h" +#include "m2type.h" + +static tree const_to_ISO_type (location_t location, tree expr, tree iso_type); +static tree const_to_ISO_aggregate_type (location_t location, tree expr, + tree iso_type); + +/* These enumerators are possible types of unsafe conversions. + SAFE_CONVERSION The conversion is safe UNSAFE_OTHER Another type of + conversion with problems UNSAFE_SIGN Conversion between signed and + unsigned integers which are all warned about immediately, so this is + unused UNSAFE_REAL Conversions that reduce the precision of reals + including conversions from reals to integers. */ +enum conversion_safety +{ + SAFE_CONVERSION = 0, + UNSAFE_OTHER, + UNSAFE_SIGN, + UNSAFE_REAL +}; + +/* ConvertString - converts string, expr, into a string of type, + type. */ + +tree +m2convert_ConvertString (tree type, tree expr) +{ + const char *str = TREE_STRING_POINTER (expr); + int len = TREE_STRING_LENGTH (expr); + return m2decl_BuildStringConstantType (len, str, type); +} + + +/* (Taken from c-common.cc and trimmed for Modula-2) + + Checks if expression EXPR of real/integer type cannot be converted to + the real/integer type TYPE. Function returns non-zero when: + EXPR is a constant which cannot be exactly converted to TYPE. + EXPR is not a constant and size of EXPR's type > than size of + TYPE, for EXPR type and TYPE being both integers or both real. + EXPR is not a constant of real type and TYPE is an integer. + EXPR is not a constant of integer type which cannot be exactly + converted to real type. Function allows conversions between types + of different signedness and can return SAFE_CONVERSION (zero) in + that case. Function can produce signedness warnings if + PRODUCE_WARNS is true. */ + +enum conversion_safety +unsafe_conversion_p (location_t loc, tree type, tree expr, bool produce_warns) +{ + enum conversion_safety give_warning = SAFE_CONVERSION; /* Is 0 or false. */ + tree expr_type = TREE_TYPE (expr); + + if (TREE_CODE (expr) == REAL_CST || TREE_CODE (expr) == INTEGER_CST) + { + + /* Warn for real constant that is not an exact integer converted to + integer type. */ + if (TREE_CODE (expr_type) == REAL_TYPE + && TREE_CODE (type) == INTEGER_TYPE) + { + if (!real_isinteger (TREE_REAL_CST_PTR (expr), + TYPE_MODE (expr_type))) + give_warning = UNSAFE_REAL; + } + /* Warn for an integer constant that does not fit into integer type. */ + else if (TREE_CODE (expr_type) == INTEGER_TYPE + && TREE_CODE (type) == INTEGER_TYPE + && !int_fits_type_p (expr, type)) + { + if (TYPE_UNSIGNED (type) && !TYPE_UNSIGNED (expr_type) + && tree_int_cst_sgn (expr) < 0) + { + if (produce_warns) + warning_at (loc, OPT_Wsign_conversion, + "negative integer" + " implicitly converted to unsigned type"); + } + else if (!TYPE_UNSIGNED (type) && TYPE_UNSIGNED (expr_type)) + { + if (produce_warns) + warning_at (loc, OPT_Wsign_conversion, + "conversion of unsigned" + " constant value to negative integer"); + } + else + give_warning = UNSAFE_OTHER; + } + else if (TREE_CODE (type) == REAL_TYPE) + { + /* Warn for an integer constant that does not fit into real type. */ + if (TREE_CODE (expr_type) == INTEGER_TYPE) + { + REAL_VALUE_TYPE a = real_value_from_int_cst (0, expr); + if (!exact_real_truncate (TYPE_MODE (type), &a)) + give_warning = UNSAFE_REAL; + } + + /* Warn for a real constant that does not fit into a smaller real + type. */ + else if (TREE_CODE (expr_type) == REAL_TYPE + && TYPE_PRECISION (type) < TYPE_PRECISION (expr_type)) + { + REAL_VALUE_TYPE a = TREE_REAL_CST (expr); + if (!exact_real_truncate (TYPE_MODE (type), &a)) + give_warning = UNSAFE_REAL; + } + } + } + else + { + /* Warn for real types converted to integer types. */ + if (TREE_CODE (expr_type) == REAL_TYPE + && TREE_CODE (type) == INTEGER_TYPE) + give_warning = UNSAFE_REAL; + + } + + return give_warning; +} + +/* (Taken from c-common.cc and trimmed for Modula-2) + + Warns if the conversion of EXPR to TYPE may alter a value. This is + a helper function for warnings_for_convert_and_check. */ + +static void +conversion_warning (location_t loc, tree type, tree expr) +{ + tree expr_type = TREE_TYPE (expr); + enum conversion_safety conversion_kind; + + if (!warn_conversion && !warn_sign_conversion && !warn_float_conversion) + return; + + switch (TREE_CODE (expr)) + { + case EQ_EXPR: + case NE_EXPR: + case LE_EXPR: + case GE_EXPR: + case LT_EXPR: + case GT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + case TRUTH_NOT_EXPR: + + /* Conversion from boolean to a signed:1 bit-field (which only can + hold the values 0 and -1) doesn't lose information - but it does + change the value. */ + if (TYPE_PRECISION (type) == 1 && !TYPE_UNSIGNED (type)) + warning_at (loc, OPT_Wconversion, + "conversion to %qT from boolean expression", type); + return; + + case REAL_CST: + case INTEGER_CST: + conversion_kind = unsafe_conversion_p (loc, type, expr, true); + if (conversion_kind == UNSAFE_REAL) + warning_at (loc, OPT_Wfloat_conversion, + "conversion to %qT alters %qT constant value", type, + expr_type); + else if (conversion_kind) + warning_at (loc, OPT_Wconversion, + "conversion to %qT alters %qT constant value", type, + expr_type); + return; + + case COND_EXPR: + { + + /* In case of COND_EXPR, we do not care about the type of COND_EXPR, + only about the conversion of each operand. */ + tree op1 = TREE_OPERAND (expr, 1); + tree op2 = TREE_OPERAND (expr, 2); + + conversion_warning (loc, type, op1); + conversion_warning (loc, type, op2); + return; + } + + default: /* 'expr' is not a constant. */ + conversion_kind = unsafe_conversion_p (loc, type, expr, true); + if (conversion_kind == UNSAFE_REAL) + warning_at (loc, OPT_Wfloat_conversion, + "conversion to %qT from %qT may alter its value", type, + expr_type); + else if (conversion_kind) + warning_at (loc, OPT_Wconversion, + "conversion to %qT from %qT may alter its value", type, + expr_type); + } +} + +/* (Taken from c-common.cc and trimmed for Modula-2) + + Produce warnings after a conversion. RESULT is the result of + converting EXPR to TYPE. This is a helper function for + convert_and_check and cp_convert_and_check. */ + +void +warnings_for_convert_and_check (location_t loc, tree type, tree expr, + tree result) +{ + if (TREE_CODE (expr) == INTEGER_CST && (TREE_CODE (type) == INTEGER_TYPE + || TREE_CODE (type) == ENUMERAL_TYPE) + && !int_fits_type_p (expr, type)) + { + + /* Do not diagnose overflow in a constant expression merely because a + conversion overflowed. */ + if (TREE_OVERFLOW (result)) + TREE_OVERFLOW (result) = TREE_OVERFLOW (expr); + + if (TYPE_UNSIGNED (type)) + { + + /* This detects cases like converting -129 or 256 to unsigned + char. */ + if (!int_fits_type_p (expr, m2type_gm2_signed_type (type))) + warning_at (loc, OPT_Woverflow, + "large integer implicitly truncated to unsigned type"); + else + conversion_warning (loc, type, expr); + } + else if (!int_fits_type_p (expr, m2type_gm2_unsigned_type (type))) + warning_at (loc, OPT_Woverflow, + "overflow in implicit constant conversion"); + /* No warning for converting 0x80000000 to int. */ + else if (pedantic && (TREE_CODE (TREE_TYPE (expr)) != INTEGER_TYPE + || TYPE_PRECISION (TREE_TYPE (expr)) + != TYPE_PRECISION (type))) + warning_at (loc, OPT_Woverflow, + "overflow in implicit constant conversion"); + + else + conversion_warning (loc, type, expr); + } + else if ((TREE_CODE (result) == INTEGER_CST + || TREE_CODE (result) == FIXED_CST) + && TREE_OVERFLOW (result)) + warning_at (loc, OPT_Woverflow, + "overflow in implicit constant conversion"); + else + conversion_warning (loc, type, expr); +} + +/* (Taken from c-common.cc and trimmed for Modula-2) + + Convert EXPR to TYPE, warning about conversion problems with + constants. Invoke this function on every expression that is + converted implicitly, i.e. because of language rules and not + because of an explicit cast. */ + +static tree +convert_and_check (location_t loc, tree type, tree expr) +{ + tree result; + tree expr_for_warning; + + /* Convert from a value with possible excess precision rather than + via the semantic type, but do not warn about values not fitting + exactly in the semantic type. */ + if (TREE_CODE (expr) == EXCESS_PRECISION_EXPR) + { + tree orig_type = TREE_TYPE (expr); + expr = TREE_OPERAND (expr, 0); + expr_for_warning = convert (orig_type, expr); + if (orig_type == type) + return expr_for_warning; + } + else + expr_for_warning = expr; + + if (TREE_TYPE (expr) == type) + return expr; + + result = convert_loc (loc, type, expr); + + if (!TREE_OVERFLOW_P (expr) && result != error_mark_node) + warnings_for_convert_and_check (loc, type, expr_for_warning, result); + + return result; +} + + +static tree +doOrdinal (tree value) +{ + if (TREE_CODE (value) == STRING_CST && (m2expr_StringLength (value) <= 1)) + { + const char *p = TREE_STRING_POINTER (value); + int i = p[0]; + + return m2decl_BuildIntegerConstant (i); + } + return value; +} + +static int +same_size_types (location_t location, tree t1, tree t2) +{ + tree n1 = m2expr_GetSizeOf (location, t1); + tree n2 = m2expr_GetSizeOf (location, t2); + + return m2expr_CompareTrees (n1, n2) == 0; +} + +static int +converting_ISO_generic (location_t location, tree type, tree value, + tree generic_type, tree *result) +{ + tree value_type = m2tree_skip_type_decl (TREE_TYPE (value)); + + if (value_type == type) + /* We let the caller deal with this. */ + return FALSE; + + if ((TREE_CODE (value) == INTEGER_CST) && (type == generic_type)) + { + *result = const_to_ISO_type (location, value, generic_type); + return TRUE; + } + + if (same_size_types (location, type, value_type)) + { + if (value_type == generic_type) + { + tree pt = build_pointer_type (type); + tree a = build1 (ADDR_EXPR, pt, value); + tree t = build1 (INDIRECT_REF, type, a); + *result = build1 (NOP_EXPR, type, t); + return TRUE; + } + else if (type == generic_type) + { + tree pt = build_pointer_type (type); + tree a = build1 (ADDR_EXPR, pt, value); + tree t = build1 (INDIRECT_REF, type, a); + *result = build1 (NOP_EXPR, type, t); + return TRUE; + } + } + return FALSE; +} + +/* convert_char_to_array - convert a single char, value, into an + type. The type will be array [..] of char. The array type + returned will have nuls appended to pad the single char to the + correct array length. */ + +static tree +convert_char_to_array (location_t location, tree type, tree value) +{ + tree i = m2decl_BuildIntegerConstant (0); + struct struct_constructor *c + = (struct struct_constructor *)m2type_BuildStartArrayConstructor (type); + tree n = m2type_GetArrayNoOfElements (location, type); + char nul[1]; + + nul[0] = (char)0; + + /* Store the initial char. */ + m2type_BuildArrayConstructorElement (c, value, i); + i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1), FALSE); + + /* Now pad out the remaining elements with nul chars. */ + while (m2expr_CompareTrees (i, n) < 0) + { + m2type_BuildArrayConstructorElement ( + c, m2type_BuildCharConstant (location, &nul[0]), i); + i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1), + FALSE); + } + return m2type_BuildEndArrayConstructor (c); +} + +/* convert_string_to_array - convert a STRING_CST into an array type. + array [..] of char. The array constant returned will have nuls + appended to pad the contents to the correct length. */ + +static tree +convert_string_to_array (location_t location, tree type, tree value) +{ + tree n = m2type_GetArrayNoOfElements (location, type); + + return m2type_BuildArrayStringConstructor (location, type, value, n); +} + +/* BuildConvert - build and return tree VAL (type, value). + checkOverflow determines whether we should suppress overflow + checking. */ + +tree +m2convert_BuildConvert (location_t location, tree type, tree value, + int checkOverflow) +{ + type = m2tree_skip_type_decl (type); + tree t; + + value = fold (value); + STRIP_NOPS (value); + value = m2expr_FoldAndStrip (value); + + if (TREE_CODE (value) == STRING_CST && (m2expr_StringLength (value) <= 1) + && (m2tree_IsOrdinal (type))) + value = doOrdinal (value); + else if (TREE_CODE (value) == FUNCTION_DECL && TREE_TYPE (value) != type) + value = m2expr_BuildAddr (0, value, FALSE); + + if (converting_ISO_generic (location, type, value, m2type_GetByteType (), &t) + || converting_ISO_generic (location, type, value, + m2type_GetISOLocType (), &t) + || converting_ISO_generic (location, type, value, + m2type_GetISOByteType (), &t) + || converting_ISO_generic (location, type, value, + m2type_GetISOWordType (), &t) + || converting_ISO_generic (location, type, value, m2type_GetM2Word16 (), + &t) + || converting_ISO_generic (location, type, value, m2type_GetM2Word32 (), + &t) + || converting_ISO_generic (location, type, value, m2type_GetM2Word64 (), + &t)) + return t; + + if (TREE_CODE (type) == ARRAY_TYPE + && TREE_TYPE (type) == m2type_GetM2CharType ()) + { + if (TREE_TYPE (value) == m2type_GetM2CharType ()) + + /* Passing a const char to an array [..] of char. So we convert + const char into the correct length string. */ + return convert_char_to_array (location, type, value); + if (TREE_CODE (value) == STRING_CST) + /* Convert a string into an array constant, padding with zeros if + necessary. */ + return convert_string_to_array (location, type, value); + } + + if (checkOverflow) + return convert_and_check (location, type, value); + else + return convert (type, value); +} + +/* const_to_ISO_type - perform VAL (iso_type, expr). */ + +static tree +const_to_ISO_type (location_t location, tree expr, tree iso_type) +{ + tree n = m2expr_GetSizeOf (location, iso_type); + + if ((m2expr_CompareTrees (n, m2decl_BuildIntegerConstant (1)) == 0) + && (iso_type == m2type_GetByteType () + || iso_type == m2type_GetISOLocType () + || iso_type == m2type_GetISOByteType ())) + return build1 (NOP_EXPR, iso_type, expr); + return const_to_ISO_aggregate_type (location, expr, iso_type); +} + +/* const_to_ISO_aggregate_type - perform VAL (iso_type, expr). The + iso_type will be declared by the SYSTEM module as: TYPE iso_type = + ARRAY [0..n] OF LOC + + this function will store a constant into the iso_type in the correct + endian order. It converts the expr into a unsigned int or signed + int and then strips it a byte at a time. */ + +static tree +const_to_ISO_aggregate_type (location_t location, tree expr, tree iso_type) +{ + tree byte; + m2type_Constructor c; + tree i = m2decl_BuildIntegerConstant (0); + tree n = m2expr_GetSizeOf (location, iso_type); + tree max_uint = m2decl_BuildIntegerConstant (256); + + while (m2expr_CompareTrees (i, n) < 0) + { + max_uint = m2expr_BuildMult (location, max_uint, + m2decl_BuildIntegerConstant (256), FALSE); + i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1), + FALSE); + } + max_uint = m2expr_BuildDivFloor (location, max_uint, + m2decl_BuildIntegerConstant (2), FALSE); + + if (m2expr_CompareTrees (expr, m2decl_BuildIntegerConstant (0)) < 0) + expr = m2expr_BuildAdd (location, expr, max_uint, FALSE); + + i = m2decl_BuildIntegerConstant (0); + c = m2type_BuildStartArrayConstructor (iso_type); + while (m2expr_CompareTrees (i, n) < 0) + { + byte = m2expr_BuildModTrunc (location, expr, + m2decl_BuildIntegerConstant (256), FALSE); + if (BYTES_BIG_ENDIAN) + m2type_BuildArrayConstructorElement ( + c, m2convert_ToLoc (location, byte), + m2expr_BuildSub (location, m2expr_BuildSub (location, n, i, FALSE), + m2decl_BuildIntegerConstant (1), FALSE)); + else + m2type_BuildArrayConstructorElement ( + c, m2convert_ToLoc (location, byte), i); + + i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1), + FALSE); + expr = m2expr_BuildDivFloor (location, expr, + m2decl_BuildIntegerConstant (256), FALSE); + } + + return m2type_BuildEndArrayConstructor (c); +} + +/* ConvertConstantAndCheck - in Modula-2 sementics: RETURN( VAL(type, + expr) ). Only to be used for a constant expr, overflow checking + is performed. */ + +tree +m2convert_ConvertConstantAndCheck (location_t location, tree type, tree expr) +{ + tree etype; + expr = fold (expr); + STRIP_NOPS (expr); + expr = m2expr_FoldAndStrip (expr); + etype = TREE_TYPE (expr); + + m2assert_AssertLocation (location); + if (etype == type) + return expr; + + if (TREE_CODE (expr) == FUNCTION_DECL) + expr = m2expr_BuildAddr (location, expr, FALSE); + + type = m2tree_skip_type_decl (type); + if (type == m2type_GetByteType () || type == m2type_GetISOLocType () + || type == m2type_GetISOByteType () || type == m2type_GetISOWordType () + || type == m2type_GetM2Word16 () || type == m2type_GetM2Word32 () + || type == m2type_GetM2Word64 ()) + return const_to_ISO_type (location, expr, type); + + return convert_and_check (location, type, m2expr_FoldAndStrip (expr)); +} + +/* ToWord - converts an expression (Integer or Ordinal type) into a + WORD. */ + +tree +m2convert_ToWord (location_t location, tree expr) +{ + return m2convert_BuildConvert (location, m2type_GetWordType (), expr, FALSE); +} + +/* ToCardinal - convert an expression, expr, to a CARDINAL. */ + +tree +m2convert_ToCardinal (location_t location, tree expr) +{ + return m2convert_BuildConvert (location, m2type_GetCardinalType (), expr, + FALSE); +} + +/* convertToPtr - if the type of tree, t, is not a ptr_type_node then + convert it. */ + +tree +m2convert_convertToPtr (location_t location, tree type) +{ + if (TREE_CODE (TREE_TYPE (type)) == POINTER_TYPE) + return type; + else + return m2convert_BuildConvert (location, m2type_GetPointerType (), type, + FALSE); +} + +/* ToInteger - convert an expression, expr, to an INTEGER. */ + +tree +m2convert_ToInteger (location_t location, tree expr) +{ + return m2convert_BuildConvert (location, m2type_GetIntegerType (), expr, + FALSE); +} + +/* ToBitset - convert an expression, expr, to a BITSET type. */ + +tree +m2convert_ToBitset (location_t location, tree expr) +{ + return m2convert_BuildConvert (location, m2type_GetBitsetType (), expr, + FALSE); +} + +/* ToLoc - convert an expression, expr, to a LOC. */ + +tree +m2convert_ToLoc (location_t location, tree expr) +{ + return m2convert_BuildConvert (location, m2type_GetISOByteType (), expr, + FALSE); +} + +/* GenericToType - converts, expr, into, type, providing that expr is + a generic system type (byte, word etc). Otherwise expr is + returned unaltered. */ + +tree +m2convert_GenericToType (location_t location, tree type, tree expr) +{ + tree etype = TREE_TYPE (expr); + + type = m2tree_skip_type_decl (type); + if (type == etype) + return expr; + + if (type == m2type_GetISOWordType () || type == m2type_GetM2Word16 () + || type == m2type_GetM2Word32 () || type == m2type_GetM2Word64 ()) + return const_to_ISO_type (location, expr, type); + + return expr; +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2decl.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2decl.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,453 @@ +/* m2decl.cc provides an interface to GCC decl 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" + +#define m2decl_c +#include "m2assert.h" +#include "m2block.h" +#include "m2decl.h" +#include "m2expr.h" +#include "m2tree.h" +#include "m2treelib.h" +#include "m2type.h" +#include "m2convert.h" + +extern GTY (()) tree current_function_decl; + +/* Used in BuildStartFunctionType. */ +static GTY (()) tree param_type_list; +static GTY (()) tree param_list = NULL_TREE; /* Ready for the next time we + call/define a function. */ + +tree +m2decl_DeclareM2linkStaticInitialization (location_t location, + int ScaffoldStatic) +{ + m2block_pushGlobalScope (); + /* Generate: int M2LINK_StaticInitialization = ScaffoldStatic; */ + tree init = m2decl_BuildIntegerConstant (ScaffoldStatic); + tree static_init = m2decl_DeclareKnownVariable (location, "M2LINK_StaticInitialization", + integer_type_node, + TRUE, FALSE, FALSE, TRUE, NULL_TREE, init); + m2block_popGlobalScope (); + return static_init; +} + + +tree +m2decl_DeclareM2linkForcedModuleInitOrder (location_t location, + const char *RuntimeOverride) +{ + m2block_pushGlobalScope (); + /* Generate: const char *ForcedModuleInitOrder = RuntimeOverride; */ + tree ptr_to_char = build_pointer_type (char_type_node); + TYPE_READONLY (ptr_to_char) = TRUE; + tree init = m2decl_BuildPtrToTypeString (location, RuntimeOverride, ptr_to_char); + tree forced_order = m2decl_DeclareKnownVariable (location, "M2LINK_ForcedModuleInitOrder", + ptr_to_char, + TRUE, FALSE, FALSE, TRUE, NULL_TREE, init); + m2block_popGlobalScope (); + return forced_order; +} + + +/* DeclareKnownVariable declares a variable to GCC. */ + +tree +m2decl_DeclareKnownVariable (location_t location, const char *name, tree type, + int exported, int imported, int istemporary, + int isglobal, tree scope, tree initial) +{ + tree id; + tree decl; + + m2assert_AssertLocation (location); + ASSERT (m2tree_is_type (type), type); + ASSERT_BOOL (isglobal); + + id = get_identifier (name); + type = m2tree_skip_type_decl (type); + decl = build_decl (location, VAR_DECL, id, type); + + DECL_SOURCE_LOCATION (decl) = location; + + DECL_EXTERNAL (decl) = imported; + TREE_STATIC (decl) = isglobal; + TREE_PUBLIC (decl) = exported || imported; + + gcc_assert ((istemporary == 0) || (istemporary == 1)); + + /* The variable was not declared by GCC, but by the front end. */ + DECL_ARTIFICIAL (decl) = istemporary; + /* If istemporary then we don't want debug info for it. */ + DECL_IGNORED_P (decl) = istemporary; + /* If istemporary we don't want even the fancy names of those printed in + -fdump-final-insns= dumps. */ + DECL_NAMELESS (decl) = istemporary; + + /* Make the variable writable. */ + TREE_READONLY (decl) = 0; + + DECL_CONTEXT (decl) = scope; + + if (initial) + DECL_INITIAL (decl) = initial; + + m2block_pushDecl (decl); + + if (DECL_SIZE (decl) == 0) + error ("storage size of %qD has not been resolved", decl); + + if ((TREE_PUBLIC (decl) == 0) && DECL_EXTERNAL (decl)) + internal_error ("inconsistant because %qs", + "PUBLIC_DECL(decl) == 0 && DECL_EXTERNAL(decl) == 1"); + + m2block_addDeclExpr (build_stmt (location, DECL_EXPR, decl)); + + return decl; +} + +/* DeclareKnownConstant - given a constant, value, of, type, create a + constant in the GCC symbol table. Note that the name of the + constant is not used as _all_ constants are declared in the global + scope. The front end deals with scoping rules - here we declare + all constants with no names in the global scope. This allows + M2SubExp and constant folding routines the liberty of operating + with quadruples which all assume constants can always be + referenced. */ + +tree +m2decl_DeclareKnownConstant (location_t location, tree type, tree value) +{ + tree id = make_node (IDENTIFIER_NODE); /* Ignore the name of the constant. */ + tree decl; + + m2assert_AssertLocation (location); + m2expr_ConstantExpressionWarning (value); + type = m2tree_skip_type_decl (type); + layout_type (type); + + decl = build_decl (location, CONST_DECL, id, type); + + DECL_INITIAL (decl) = value; + TREE_TYPE (decl) = type; + + decl = m2block_global_constant (decl); + + return decl; +} + +/* BuildParameterDeclaration - creates and returns one parameter + from, name, and, type. It appends this parameter to the internal + param_type_list. */ + +tree +m2decl_BuildParameterDeclaration (location_t location, char *name, tree type, + int isreference) +{ + tree parm_decl; + + m2assert_AssertLocation (location); + ASSERT_BOOL (isreference); + type = m2tree_skip_type_decl (type); + layout_type (type); + if (isreference) + type = build_reference_type (type); + + if (name == NULL) + parm_decl = build_decl (location, PARM_DECL, NULL, type); + else + parm_decl = build_decl (location, PARM_DECL, get_identifier (name), type); + DECL_ARG_TYPE (parm_decl) = type; + if (isreference) + TREE_READONLY (parm_decl) = TRUE; + + param_list = chainon (parm_decl, param_list); + layout_type (type); + param_type_list = tree_cons (NULL_TREE, type, param_type_list); + return parm_decl; +} + +/* BuildStartFunctionDeclaration - initializes global variables ready + for building a function. */ + +void +m2decl_BuildStartFunctionDeclaration (int uses_varargs) +{ + if (uses_varargs) + param_type_list = NULL_TREE; + else + param_type_list = tree_cons (NULL_TREE, void_type_node, NULL_TREE); + param_list = NULL_TREE; /* Ready for when we define a function. */ +} + +/* BuildEndFunctionDeclaration - build a function which will return a + value of returntype. The arguments have been created by + BuildParameterDeclaration. */ + +tree +m2decl_BuildEndFunctionDeclaration (location_t location_begin, + location_t location_end, const char *name, + tree returntype, int isexternal, + int isnested, int ispublic) +{ + tree fntype; + tree fndecl; + + m2assert_AssertLocation (location_begin); + m2assert_AssertLocation (location_end); + ASSERT_BOOL (isexternal); + ASSERT_BOOL (isnested); + ASSERT_BOOL (ispublic); + returntype = m2tree_skip_type_decl (returntype); + /* The function type depends on the return type and type of args, + both of which we have created in BuildParameterDeclaration */ + if (returntype == NULL_TREE) + returntype = void_type_node; + else if (TREE_CODE (returntype) == FUNCTION_TYPE) + returntype = ptr_type_node; + + fntype = build_function_type (returntype, param_type_list); + fndecl = build_decl (location_begin, FUNCTION_DECL, get_identifier (name), + fntype); + + if (isexternal) + ASSERT_CONDITION (ispublic); + + DECL_EXTERNAL (fndecl) = isexternal; + TREE_PUBLIC (fndecl) = ispublic; + TREE_STATIC (fndecl) = (!isexternal); + DECL_ARGUMENTS (fndecl) = param_list; + DECL_RESULT (fndecl) + = build_decl (location_end, RESULT_DECL, NULL_TREE, returntype); + DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; + TREE_TYPE (fndecl) = fntype; + + DECL_SOURCE_LOCATION (fndecl) = location_begin; + + /* Prevent the optimizer from removing it if it is public. */ + if (TREE_PUBLIC (fndecl)) + gm2_mark_addressable (fndecl); + + m2block_pushDecl (fndecl); + + rest_of_decl_compilation (fndecl, 1, 0); + param_list + = NULL_TREE; /* Ready for the next time we call/define a function. */ + return fndecl; +} + +/* BuildModuleCtor creates the per module constructor used as part of + the dynamic linking scaffold. */ + +void +m2decl_BuildModuleCtor (tree module_ctor) +{ + decl_init_priority_insert (module_ctor, DEFAULT_INIT_PRIORITY); +} + +/* DeclareModuleCtor configures the function to be used as a ctor. */ + +tree +m2decl_DeclareModuleCtor (tree decl) +{ + /* Declare module_ctor (). */ + TREE_PUBLIC (decl) = 1; + DECL_ARTIFICIAL (decl) = 1; + DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; + DECL_VISIBILITY_SPECIFIED (decl) = 1; + DECL_STATIC_CONSTRUCTOR (decl) = 1; + return decl; +} + + +/* DetermineSizeOfConstant - given, str, and, base, fill in needsLong + and needsUnsigned appropriately. */ + +void +m2decl_DetermineSizeOfConstant (location_t location, + const char *str, unsigned int base, + int *needsLong, int *needsUnsigned) +{ + unsigned int ulow; + int high; + int overflow = m2expr_interpret_m2_integer (str, base, &ulow, &high, + needsLong, needsUnsigned); + if (overflow) + error_at (location, "constant %qs is too large", str); +} + +/* BuildConstLiteralNumber - returns a GCC TREE built from the + string, str. It assumes that, str, represents a legal number in + Modula-2. It always returns a positive value. */ + +tree +m2decl_BuildConstLiteralNumber (location_t location, const char *str, unsigned int base) +{ + tree value, type; + unsigned HOST_WIDE_INT low; + HOST_WIDE_INT high; + HOST_WIDE_INT ival[3]; + int overflow = m2expr_interpret_integer (str, base, &low, &high); + int needLong, needUnsigned; + + ival[0] = low; + ival[1] = high; + ival[2] = 0; + + widest_int wval = widest_int::from_array (ival, 3); + + m2decl_DetermineSizeOfConstant (location, str, base, &needLong, &needUnsigned); + + if (needUnsigned && needLong) + type = m2type_GetM2LongCardType (); + else + type = m2type_GetM2LongIntType (); + + value = wide_int_to_tree (type, wval); + + if (overflow || m2expr_TreeOverflow (value)) + error_at (location, "constant %qs is too large", str); + + return m2block_RememberConstant (value); +} + +/* BuildCStringConstant - creates a string constant given a, string, + and, length. */ + +tree +m2decl_BuildCStringConstant (const char *string, int length) +{ + tree elem, index, type; + + /* +1 ensures that we always nul terminate our strings. */ + elem = build_type_variant (char_type_node, 1, 0); + index = build_index_type (build_int_cst (integer_type_node, length + 1)); + type = build_array_type (elem, index); + return m2decl_BuildStringConstantType (length + 1, string, type); +} + +/* BuildStringConstant - creates a string constant given a, string, + and, length. */ + +tree +m2decl_BuildStringConstant (const char *string, int length) +{ + tree elem, index, type; + + elem = build_type_variant (char_type_node, 1, 0); + index = build_index_type (build_int_cst (integer_type_node, length)); + type = build_array_type (elem, index); + return m2decl_BuildStringConstantType (length, string, type); + // maybe_wrap_with_location +} + + +tree +m2decl_BuildPtrToTypeString (location_t location, const char *string, tree type) +{ + if ((string == NULL) || (strlen (string) == 0)) + return m2convert_BuildConvert (location, type, + m2decl_BuildIntegerConstant (0), + FALSE); + return build_string_literal (strlen (string), string); +} + + +/* BuildIntegerConstant - return a tree containing the integer value. */ + +tree +m2decl_BuildIntegerConstant (int value) +{ + switch (value) + { + + case 0: + return integer_zero_node; + case 1: + return integer_one_node; + + default: + return m2block_RememberConstant ( + build_int_cst (integer_type_node, value)); + } +} + +/* BuildStringConstantType - builds a string constant with a type. */ + +tree +m2decl_BuildStringConstantType (int length, const char *string, tree type) +{ + tree id = build_string (length, string); + + TREE_TYPE (id) = type; + TREE_CONSTANT (id) = TRUE; + TREE_READONLY (id) = TRUE; + TREE_STATIC (id) = TRUE; + + return m2block_RememberConstant (id); +} + +/* GetBitsPerWord - returns the number of bits in a WORD. */ + +int +m2decl_GetBitsPerWord (void) +{ + return BITS_PER_WORD; +} + +/* GetBitsPerInt - returns the number of bits in a INTEGER. */ + +int +m2decl_GetBitsPerInt (void) +{ + return INT_TYPE_SIZE; +} + +/* GetBitsPerBitset - returns the number of bits in a BITSET. */ + +int +m2decl_GetBitsPerBitset (void) +{ + return SET_WORD_SIZE; +} + +/* GetBitsPerUnit - returns the number of bits in a UNIT. */ + +int +m2decl_GetBitsPerUnit (void) +{ + return BITS_PER_UNIT; +} + +/* m2decl_GetDeclContext - returns the DECL_CONTEXT of tree, t. */ + +tree +m2decl_GetDeclContext (tree t) +{ + return DECL_CONTEXT (t); +} + +#include "gt-m2-m2decl.h" From patchwork Tue Dec 6 14:47:27 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Gaius Mulley X-Patchwork-Id: 30360 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:adf:f944:0:0:0:0:0 with SMTP id q4csp2868600wrr; Tue, 6 Dec 2022 07:00:31 -0800 (PST) X-Google-Smtp-Source: AA0mqf4osBrMfT8MvQ/CtUgS98X/NfNQXaNWUPjGm+lzgXpit0N0mJORkMiZVUsVdM3tNtFVA7j8 X-Received: by 2002:a17:906:1f56:b0:7ad:f6ef:e6c8 with SMTP id d22-20020a1709061f5600b007adf6efe6c8mr9665959ejk.541.1670338831653; Tue, 06 Dec 2022 07:00:31 -0800 (PST) ARC-Seal: i=1; a=rsa-sha256; t=1670338831; cv=none; d=google.com; s=arc-20160816; b=dcsiTGu6kIm2xje4baYWzLiFzx+Wj51wzvj4qEgIfR9pWpouyTBBs3OAG+rboWbcpU fzF07mBQAxaEj6m2A9x/zt0ZkYKU/+QR1mI4oN2tAnmgsveE6sgK0EB0Z6StMn9ciw3m dsOQxHeTxR0blRHTnOWjhB0WbkMKs4qK4pQAp0T3iVHIX3neZTnbCNC1Zl5CvMepI4IV vLqqMnIctYqtOVZ/vyCY3lHHp9aTihaciSCZl0ReCsDw/C3yHSfznDC1ppogcZf/iHB/ mwqBfji/ud0WXi7iP6Uw0WYQoLgMpffwPUx4jL7cUmbGKmKOyEejUZhCLfPGUFDPky9D EnJQ== 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=eXqKFLIdy3fUrATlUub1c3Ea8cYvCZ2Qeli5As/XOTI=; b=Jzev5s6/EBW9rSy8iQj1IipXoNLBO2uUu7OFcEeapsQ44HHU6KWv01kx9hknUPTiNH owAYK0UolWRF0nBEmSzYk0sgK+bwZxv4boOQvvsqa9vsY6O+1HEDVX2qmbeu7XEU9k7k TViIdVhYMZpoB2Hjfkdod3yRsdPLRqm0Krzwilb1sJZ8VmeVQOVUtknx6wUoL/t8o9si dFDx9ly8ddzfl3GerH3/b5pKC9xxM3ukUsJgT9LAsukRhifRnDaB+MnFIz5OorlPWZFE i0eJ1s8Z2UuXJFzyGCro9eowUSbAXq9G+U8wqzWzssxJBuPKoAAxevyiVW5OpfjrsW6L FuQg== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=UtEJMoqg; 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 gn17-20020a1709070d1100b007c111fc30absi1046953ejc.865.2022.12.06.07.00.31 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Dec 2022 07:00:31 -0800 (PST) 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=UtEJMoqg; 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 9F184384C927 for ; Tue, 6 Dec 2022 14:57:04 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9F184384C927 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1670338624; bh=eXqKFLIdy3fUrATlUub1c3Ea8cYvCZ2Qeli5As/XOTI=; h=Subject:To:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=UtEJMoqgvhRtOdV+HZR1ssDp8rEbnof6Y0hisj4z/79skzAwqygMqLlo35PBmhVxL Uw4SazuUUJKNr14BdrwkddaUXIqRRQcqTgmvZvQLHX2CvyYXk7LJFsFw9oy/LRa5XO D15s/Wh7HJ0K4HBn7qwwSC+1E5Oghc8GGIgMqamc= 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 8B832384699F for ; Tue, 6 Dec 2022 14:48:19 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 8B832384699F Received: by mail-wr1-x436.google.com with SMTP id o5so23814664wrm.1 for ; Tue, 06 Dec 2022 06:48:19 -0800 (PST) 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=eXqKFLIdy3fUrATlUub1c3Ea8cYvCZ2Qeli5As/XOTI=; b=7CtkSslHt7TO8mOwwqWR2uEvcdkxhUt9iqJnwrEZzF+ztsJA/qqmCMJDj68vM2Dchp tWeJ01M1O1+tgUf3iWt7hwfSWFL7Ertrpqnmik8pSPSxiv4Js9rObeyWD9eiY5Dn24WR kk14I+SlD+qHHCO/O6qPsIpPH0YlLzjeO2mj9YhU7hWbXhmyajKSldoH1iWX4NdDScOD hURc71mMCBLjW+qHVJx121CrPIuHcmDDDboFFPnTp673suhn4ycLjL9t7hjOKtGqYvLK fnIXCYmR8mZL7mbGeYpzFFjU/SL1vg8nDmRUIzNHziBTKKlu8ZcBcY3w19ASPXk7zs6t Ny+Q== X-Gm-Message-State: ANoB5pkjkOoErHF4vuWp5B/fENN8jKZ9OYLoaewEVlxrn+3Mihhen2wr A21szBVxayUUTxH2VCSqsT6Rv1eDKG4= X-Received: by 2002:a5d:6749:0:b0:242:6666:9111 with SMTP id l9-20020a5d6749000000b0024266669111mr5079222wrw.530.1670338097622; Tue, 06 Dec 2022 06:48:17 -0800 (PST) Received: from lancelot ([195.147.220.46]) by smtp.gmail.com with ESMTPSA id k15-20020a5d66cf000000b00228d52b935asm16587140wrw.71.2022.12.06.06.47.31 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Dec 2022 06:48:17 -0800 (PST) X-Google-Original-From: Gaius Mulley Received: from gaius by lancelot with local (Exim 4.94.2) (envelope-from ) id 1p2ZEF-004QgU-Kq for gcc-patches@gcc.gnu.org; Tue, 06 Dec 2022 14:47:27 +0000 Subject: [PATCH v3 12/19] modula2 front end: gimple interface *[e-f]*.cc To: X-Mailer: mail (GNU Mailutils 3.10) Message-Id: Date: Tue, 06 Dec 2022 14:47:27 +0000 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?1751477210510465159?= X-GMAIL-MSGID: =?utf-8?q?1751477210510465159?= 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-12-06 02:56:51.344774733 +0000 @@ -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-12-06 02:56:51.344774733 +0000 @@ -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" From patchwork Tue Dec 6 14:47:28 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Gaius Mulley X-Patchwork-Id: 30359 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:adf:f944:0:0:0:0:0 with SMTP id q4csp2868075wrr; Tue, 6 Dec 2022 06:59:39 -0800 (PST) X-Google-Smtp-Source: AA0mqf5kNJy1twZggPiHgHTK4YV6weINB+HKPMsJHjTMjx9rBZfOjw9xCgbh4NZZ2UFrUGsSjRQe X-Received: by 2002:a17:906:402:b0:7a6:fc0f:6fe6 with SMTP id d2-20020a170906040200b007a6fc0f6fe6mr70573028eja.694.1670338779061; Tue, 06 Dec 2022 06:59:39 -0800 (PST) ARC-Seal: i=1; a=rsa-sha256; t=1670338779; cv=none; d=google.com; s=arc-20160816; b=u1fk6Dy2L+uYD84rO73OM4tfXSwtqncKTGdCoefCi9C59W4MiwWBapCGZ3ex+fIlRg aTNS9Pz+YPXl+KZD6Q6Hb2T+S+FmWu0FL5q3B53sIUxBb5JxP5UHZ8TlvMC103/OFGjN 8+WMB400M/rFslO8NdO49p2MPRyzedn47XtGMhGxVPOAfjwcOhQ24qmklKFE04BqDXxv IUVPOATK6fVZdfVUii9sYF34kCEBMBmJDnRBCSFfcDLIPijCbzukcSl9YpEx0s/1x3Rt kV6IbzSYIaj/Qe9IzCotfa7WQ6xvYZ7cMc7ePQhM+6ZtwkbiuE8oGJhKkAMbXy4Vf6t9 TLeQ== 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=HnFcNuk/zFCgn0iT/4lp93Wg/1aR4JzDqFivRUiJ7aU=; b=K7IU35nagDGSPNKTB2XwTXK+N2/ietU6KSsc1w2ACem+gvY5Ojn28VLVqmtf9M0jAv OyFkBzSTOSxTagCxATq8BxSj1oMWsTyKBQdyEWdzYzuWaJKh1/O4JqLJBddfzXJe0nGh cM6iQDDJt9fclywt5TeZerEFAH3KSDQGaD+yzE6wb6iLyEx5RGuj3L26yYIgdkqKp2Xe X1q8wivZKC96SwLQSf3EDIm60EJEP/wcDLpbIGydvdNrptn/ZzgCrRVMI8RPVLmd+X5a 3F0fka2uAImXmE14VQ8oWvplPIAdY5MxWEvRHiLkL/pmnAsmEO7sZGWElrapqyt58uJ/ lJVQ== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=rqxBFHh0; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 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 (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id cs10-20020a170906dc8a00b007c10ac8f9afsi2057665ejc.807.2022.12.06.06.59.38 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Dec 2022 06:59:39 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=rqxBFHh0; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 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 260523833A07 for ; Tue, 6 Dec 2022 14:55:15 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 260523833A07 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1670338515; bh=HnFcNuk/zFCgn0iT/4lp93Wg/1aR4JzDqFivRUiJ7aU=; h=Subject:To:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=rqxBFHh0+07Bibzjd3J/OAiAIe3dVZFnbFbbjbVyp+Ndn/EtXX/nhstczDKmmvZue TFDmXoJ1sFh7tB7V3ymVk/QaPj8dlyPw9VYwWZMQzXTRNN/LQO2DqFT57rIq8+0Z1B PkoPMhGI9u+VpOpOOk4GF+ABJqR3oJnLd3zXbRi8= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32b.google.com (mail-wm1-x32b.google.com [IPv6:2a00:1450:4864:20::32b]) by sourceware.org (Postfix) with ESMTPS id E417C3875B65 for ; Tue, 6 Dec 2022 14:48:11 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org E417C3875B65 Received: by mail-wm1-x32b.google.com with SMTP id l26so5119314wms.4 for ; Tue, 06 Dec 2022 06:48:11 -0800 (PST) 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=HnFcNuk/zFCgn0iT/4lp93Wg/1aR4JzDqFivRUiJ7aU=; b=rfFSyGZd6vEby3SaauKX7o5IF9Msx0alYgCbmSeACR/XMW2P+nsgpL2SDu4fYWK7jl 1AsfcL0btk8vKzuCX6qhw7t1J/+deDS4G1LBHwk10JfISvANZ4bz0Sv8eaIy8UHbxqzs yUOrG/1ndFD3nSuIrtQqw6oAnt5MKF/kxHXhif/iUZnQTXhjdjfFBKjDSwGJcplov1Lv lSUH5wTXIY/yr1rEZwV/Cf4Ww7pxS1hVxWXY+rWHJWCpldlpCRVCyDkWKjNTwxfhd+hY qzrMnMagVRKmaAxPwmydEbsm7FP7xvwXzxKMgHY8f83AuO45n7Sgpc7cYuqMtoNV9l6M 6N7A== X-Gm-Message-State: ANoB5pnerzINMUK+1jjDgafaMBKdS19dgn/vywyUwOI+H2seYrDW4lx+ fHyGez11u9JEGdD05NHedl2OACLjNXE= X-Received: by 2002:a7b:c3c9:0:b0:3cf:5442:bbe with SMTP id t9-20020a7bc3c9000000b003cf54420bbemr68109519wmj.2.1670338088825; Tue, 06 Dec 2022 06:48:08 -0800 (PST) Received: from lancelot ([195.147.220.46]) by smtp.gmail.com with ESMTPSA id i10-20020a1c540a000000b003cfc02ab8basm24252208wmb.33.2022.12.06.06.47.31 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Dec 2022 06:48:07 -0800 (PST) X-Google-Original-From: Gaius Mulley Received: from gaius by lancelot with local (Exim 4.94.2) (envelope-from ) id 1p2ZEG-004Qgz-29 for gcc-patches@gcc.gnu.org; Tue, 06 Dec 2022 14:47:28 +0000 Subject: [PATCH v3 14/19] modula2 front end: gimple interface remainder To: X-Mailer: mail (GNU Mailutils 3.10) Message-Id: Date: Tue, 06 Dec 2022 14:47:28 +0000 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?1751477155264291032?= X-GMAIL-MSGID: =?utf-8?q?1751477155264291032?= This patchset contains the gimple interface. ------8<----------8<----------8<----------8<----------8<----------8<---- diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/init.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/init.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,196 @@ +/* init.cc initializes the modules of the GNU Modula-2 front end. + +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 "init.h" +#include "config.h" +#include "system.h" + +#if defined(__GNUG__) +#define EXTERN extern "C" +#else /* !__GNUG__ */ +#define EXTERN extern +#endif /* !__GNUG__ */ + +EXTERN void _M2_M2Bitset_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Debug_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Defaults_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Environment_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_RTExceptions_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2EXCEPTION_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2RTS_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Dependent_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SysExceptions_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_DynamicStrings_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Assertion_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_FormatStrings_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_FIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SFIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SArgs_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Lists_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_UnixArgs_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Args_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_wrapc_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_TimeString_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_IO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_StdIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_CmdArgs_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Preprocess_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Error_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Search_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Indexing_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_NameKey_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_NumberIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_FpuIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SysStorage_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Storage_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_StrIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Debug_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Batch_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_StrLib_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2ALU_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Options_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Comp_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2LexBuf_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SymbolTable_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Base_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Quads_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SymbolKey_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_FifoQueue_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Reserved_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Const_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_P1SymBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_P2SymBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_P3SymBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2System_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2BasicBlock_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Pass_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Code_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2AsmUtil_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2FileName_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Students_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_StrCase_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SymbolConversion_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2GCCDeclare_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2GenGCC_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Range_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Swig_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2MetaError_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2CaseList_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_PCSymBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_PCBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Sets_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_dtoa_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_ldtoa_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Check_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2SSA_init (int argc, char *argv[], char *envp[]); +EXTERN void exit (int); +EXTERN void M2Comp_compile (const char *filename); +EXTERN void RTExceptions_DefaultErrorCatch (void); + + +/* FrontEndInit initialize the modules. This is a global + initialization and it is called once. */ + +void +init_FrontEndInit (void) +{ + _M2_Debug_init (0, NULL, NULL); + _M2_RTExceptions_init (0, NULL, NULL); + _M2_M2Defaults_init (0, NULL, NULL); + _M2_Environment_init (0, NULL, NULL); + _M2_M2EXCEPTION_init (0, NULL, NULL); + _M2_M2Dependent_init (0, NULL, NULL); + _M2_M2RTS_init (0, NULL, NULL); + _M2_SysExceptions_init (0, NULL, NULL); + _M2_DynamicStrings_init (0, NULL, NULL); + _M2_Assertion_init (0, NULL, NULL); + _M2_FormatStrings_init (0, NULL, NULL); + _M2_FIO_init (0, NULL, NULL); + _M2_SFIO_init (0, NULL, NULL); + _M2_SArgs_init (0, NULL, NULL); + _M2_Lists_init (0, NULL, NULL); + _M2_UnixArgs_init (0, NULL, NULL); + _M2_Args_init (0, NULL, NULL); + _M2_wrapc_init (0, NULL, NULL); + _M2_TimeString_init (0, NULL, NULL); + _M2_IO_init (0, NULL, NULL); + _M2_StdIO_init (0, NULL, NULL); + _M2_CmdArgs_init (0, NULL, NULL); + _M2_FpuIO_init (0, NULL, NULL); + _M2_SysStorage_init (0, NULL, NULL); + _M2_Storage_init (0, NULL, NULL); + _M2_StrIO_init (0, NULL, NULL); + _M2_StrLib_init (0, NULL, NULL); + _M2_dtoa_init (0, NULL, NULL); + _M2_ldtoa_init (0, NULL, NULL); + _M2_M2Search_init (0, NULL, NULL); + _M2_M2Options_init (0, NULL, NULL); +} + +/* PerCompilationInit initialize the modules before compiling, + filename. This is called every time we compile a new file. */ + +void +init_PerCompilationInit (const char *filename) +{ + _M2_M2Bitset_init (0, NULL, NULL); + _M2_M2Preprocess_init (0, NULL, NULL); + _M2_M2Error_init (0, NULL, NULL); + _M2_Indexing_init (0, NULL, NULL); + _M2_NameKey_init (0, NULL, NULL); + _M2_NumberIO_init (0, NULL, NULL); + _M2_M2Debug_init (0, NULL, NULL); + _M2_M2Batch_init (0, NULL, NULL); + _M2_M2ALU_init (0, NULL, NULL); + _M2_M2Comp_init (0, NULL, NULL); + _M2_M2LexBuf_init (0, NULL, NULL); + _M2_SymbolTable_init (0, NULL, NULL); + _M2_M2Base_init (0, NULL, NULL); + _M2_M2Quads_init (0, NULL, NULL); + _M2_SymbolKey_init (0, NULL, NULL); + _M2_FifoQueue_init (0, NULL, NULL); + _M2_M2Reserved_init (0, NULL, NULL); + _M2_M2Const_init (0, NULL, NULL); + _M2_P1SymBuild_init (0, NULL, NULL); + _M2_P2SymBuild_init (0, NULL, NULL); + _M2_P3SymBuild_init (0, NULL, NULL); + _M2_M2System_init (0, NULL, NULL); + _M2_M2BasicBlock_init (0, NULL, NULL); + _M2_M2Pass_init (0, NULL, NULL); + _M2_M2Code_init (0, NULL, NULL); + _M2_M2AsmUtil_init (0, NULL, NULL); + _M2_M2FileName_init (0, NULL, NULL); + _M2_M2Students_init (0, NULL, NULL); + _M2_StrCase_init (0, NULL, NULL); + _M2_SymbolConversion_init (0, NULL, NULL); + _M2_M2GCCDeclare_init (0, NULL, NULL); + _M2_M2GenGCC_init (0, NULL, NULL); + _M2_M2Range_init (0, NULL, NULL); + _M2_M2Swig_init (0, NULL, NULL); + _M2_M2MetaError_init (0, NULL, NULL); + _M2_M2CaseList_init (0, NULL, NULL); + _M2_PCSymBuild_init (0, NULL, NULL); + _M2_PCBuild_init (0, NULL, NULL); + _M2_Sets_init (0, NULL, NULL); + _M2_M2SSA_init (0, NULL, NULL); + _M2_M2Check_init (0, NULL, NULL); + M2Comp_compile (filename); +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2statement.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2statement.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,955 @@ +/* m2statement.cc provides an interface to GCC statement 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" + +/* Prototypes. */ + +#define m2statement_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" +#include "m2convert.h" + +static GTY (()) tree param_list = NULL_TREE; /* Ready for the next time we + call/define a function. */ +static GTY (()) tree last_function = NULL_TREE; + + +/* BuildStartFunctionCode - generate function entry code. */ + +void +m2statement_BuildStartFunctionCode (location_t location, tree fndecl, + int isexported, int isinline) +{ + tree param_decl; + + ASSERT_BOOL (isexported); + ASSERT_BOOL (isinline); + /* Announce we are compiling this function. */ + announce_function (fndecl); + + /* Set up to compile the function and enter it. */ + + DECL_INITIAL (fndecl) = NULL_TREE; + + current_function_decl = fndecl; + m2block_pushFunctionScope (fndecl); + m2statement_SetBeginLocation (location); + + ASSERT_BOOL ((cfun != NULL)); + /* Initialize the RTL code for the function. */ + allocate_struct_function (fndecl, false); + /* Begin the statement tree for this function. */ + DECL_SAVED_TREE (fndecl) = NULL_TREE; + + /* Set the context of these parameters to this function. */ + for (param_decl = DECL_ARGUMENTS (fndecl); param_decl; + param_decl = TREE_CHAIN (param_decl)) + DECL_CONTEXT (param_decl) = fndecl; + + /* This function exists in static storage. (This does not mean + `static' in the C sense!) */ + TREE_STATIC (fndecl) = 1; + TREE_PUBLIC (fndecl) = isexported; + /* We could do better here by detecting ADR + or type PROC used on this function. --fixme-- */ + TREE_ADDRESSABLE (fndecl) = 1; + DECL_DECLARED_INLINE_P (fndecl) = 0; /* isinline; */ +} + +static void +gm2_gimplify_function_node (tree fndecl) +{ + /* Convert all nested functions to GIMPLE now. We do things in this + order so that items like VLA sizes are expanded properly in the + context of the correct function. */ + struct cgraph_node *cgn; + + dump_function (TDI_original, fndecl); + gimplify_function_tree (fndecl); + + cgn = cgraph_node::get_create (fndecl); + for (cgn = first_nested_function (cgn); + cgn != NULL; cgn = next_nested_function (cgn)) + gm2_gimplify_function_node (cgn->decl); +} + +/* BuildEndFunctionCode - generates the function epilogue. */ + +void +m2statement_BuildEndFunctionCode (location_t location, tree fndecl, int nested) +{ + tree block = DECL_INITIAL (fndecl); + + BLOCK_SUPERCONTEXT (block) = fndecl; + + /* Must mark the RESULT_DECL as being in this function. */ + DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; + + /* And attach it to the function. */ + DECL_INITIAL (fndecl) = block; + + m2block_finishFunctionCode (fndecl); + m2statement_SetEndLocation (location); + + gm2_genericize (fndecl); + if (nested) + (void)cgraph_node::get_create (fndecl); + else + cgraph_node::finalize_function (fndecl, false); + + m2block_popFunctionScope (); + + /* We're leaving the context of this function, so zap cfun. It's + still in DECL_STRUCT_FUNCTION, and we'll restore it in + tree_rest_of_compilation. */ + set_cfun (NULL); + current_function_decl = NULL; +} + +/* BuildPushFunctionContext - pushes the current function context. + Maps onto push_function_context in ../function.cc. */ + +void +m2statement_BuildPushFunctionContext (void) +{ + push_function_context (); +} + +/* BuildPopFunctionContext - pops the current function context. Maps + onto pop_function_context in ../function.cc. */ + +void +m2statement_BuildPopFunctionContext (void) +{ + pop_function_context (); +} + +void +m2statement_SetBeginLocation (location_t location) +{ + if (cfun != NULL) + cfun->function_start_locus = location; +} + +void +m2statement_SetEndLocation (location_t location) +{ + if (cfun != NULL) + cfun->function_end_locus = location; +} + +/* BuildAssignmentTree builds the assignment of, des, and, expr. + It returns, des. */ + +tree +m2statement_BuildAssignmentTree (location_t location, tree des, tree expr) +{ + tree result; + + m2assert_AssertLocation (location); + STRIP_TYPE_NOPS (expr); + + if (TREE_CODE (expr) == FUNCTION_DECL) + result = build2 (MODIFY_EXPR, TREE_TYPE (des), des, + m2expr_BuildAddr (location, expr, FALSE)); + else + { + gcc_assert (TREE_CODE (TREE_TYPE (des)) != TYPE_DECL); + if (TREE_TYPE (expr) == TREE_TYPE (des)) + result = build2 (MODIFY_EXPR, TREE_TYPE (des), des, expr); + else + result = build2 ( + MODIFY_EXPR, TREE_TYPE (des), des, + m2convert_BuildConvert (location, TREE_TYPE (des), expr, FALSE)); + } + + TREE_SIDE_EFFECTS (result) = 1; + add_stmt (location, result); + return des; +} + +/* BuildAssignmentStatement builds the assignment of, des, and, expr. */ + +void +m2statement_BuildAssignmentStatement (location_t location, tree des, tree expr) +{ + m2statement_BuildAssignmentTree (location, des, expr); +} + +/* BuildGoto builds a goto operation. */ + +void +m2statement_BuildGoto (location_t location, char *name) +{ + tree label = m2block_getLabel (location, name); + + m2assert_AssertLocation (location); + TREE_USED (label) = 1; + add_stmt (location, build1 (GOTO_EXPR, void_type_node, label)); +} + +/* DeclareLabel - create a label, name. */ + +void +m2statement_DeclareLabel (location_t location, char *name) +{ + tree label = m2block_getLabel (location, name); + + m2assert_AssertLocation (location); + add_stmt (location, build1 (LABEL_EXPR, void_type_node, label)); +} + +/* BuildParam - build a list of parameters, ready for a subsequent + procedure call. */ + +void +m2statement_BuildParam (location_t location, tree param) +{ + m2assert_AssertLocation (location); + + if (TREE_CODE (param) == FUNCTION_DECL) + param = m2expr_BuildAddr (location, param, FALSE); + + param_list = chainon (build_tree_list (NULL_TREE, param), param_list); +} + +/* nCount - return the number of chained tree nodes in list, t. */ + +static int +nCount (tree t) +{ + int i = 0; + + while (t != NULL) + { + i++; + t = TREE_CHAIN (t); + } + return i; +} + +/* BuildProcedureCallTree - creates a procedure call from a procedure + and parameter list and the return type, rettype. */ + +tree +m2statement_BuildProcedureCallTree (location_t location, tree procedure, + tree rettype) +{ + tree functype = TREE_TYPE (procedure); + tree funcptr = build1 (ADDR_EXPR, build_pointer_type (functype), procedure); + tree call; + int n = nCount (param_list); + tree *argarray = XALLOCAVEC (tree, n); + tree t = param_list; + int i; + + m2assert_AssertLocation (location); + ASSERT_CONDITION ( + last_function + == NULL_TREE); /* Previous function value has not been collected. */ + TREE_USED (procedure) = TRUE; + + for (i = 0; i < n; i++) + { + argarray[i] = TREE_VALUE (t); + t = TREE_CHAIN (t); + } + + if (rettype == NULL_TREE) + { + rettype = void_type_node; + call = build_call_array_loc (location, rettype, funcptr, n, argarray); + TREE_USED (call) = TRUE; + TREE_SIDE_EFFECTS (call) = TRUE; + +#if defined(DEBUG_PROCEDURE_CALLS) + fprintf (stderr, "built the modula-2 call, here is the tree\n"); + fflush (stderr); + debug_tree (call); +#endif + + param_list + = NULL_TREE; /* Ready for the next time we call a procedure. */ + last_function = NULL_TREE; + return call; + } + else + { + last_function = build_call_array_loc ( + location, m2tree_skip_type_decl (rettype), funcptr, n, argarray); + TREE_USED (last_function) = TRUE; + TREE_SIDE_EFFECTS (last_function) = TRUE; + param_list + = NULL_TREE; /* Ready for the next time we call a procedure. */ + return last_function; + } +} + +/* BuildIndirectProcedureCallTree - creates a procedure call from a + procedure and parameter list and the return type, rettype. */ + +tree +m2statement_BuildIndirectProcedureCallTree (location_t location, + tree procedure, tree rettype) +{ + tree call; + int n = nCount (param_list); + tree *argarray = XALLOCAVEC (tree, n); + tree t = param_list; + int i; + + m2assert_AssertLocation (location); + TREE_USED (procedure) = TRUE; + TREE_SIDE_EFFECTS (procedure) = TRUE; + + for (i = 0; i < n; i++) + { + argarray[i] = TREE_VALUE (t); + t = TREE_CHAIN (t); + } + + if (rettype == NULL_TREE) + { + rettype = void_type_node; + call = build_call_array_loc (location, rettype, procedure, n, argarray); + TREE_USED (call) = TRUE; + TREE_SIDE_EFFECTS (call) = TRUE; + +#if defined(DEBUG_PROCEDURE_CALLS) + fprintf (stderr, "built the modula-2 call, here is the tree\n"); + fflush (stderr); + debug_tree (call); +#endif + + last_function = NULL_TREE; + param_list + = NULL_TREE; /* Ready for the next time we call a procedure. */ + return call; + } + else + { + last_function = build_call_array_loc ( + location, m2tree_skip_type_decl (rettype), procedure, n, argarray); + TREE_USED (last_function) = TRUE; + TREE_SIDE_EFFECTS (last_function) = TRUE; + param_list + = NULL_TREE; /* Ready for the next time we call a procedure. */ + return last_function; + } +} + +/* BuildFunctValue - generates code for value := + last_function(foobar); */ + +tree +m2statement_BuildFunctValue (location_t location, tree value) +{ + tree assign + = m2treelib_build_modify_expr (location, value, NOP_EXPR, last_function); + + m2assert_AssertLocation (location); + ASSERT_CONDITION ( + last_function + != NULL_TREE); /* No value available, possible used before. */ + + TREE_SIDE_EFFECTS (assign) = TRUE; + TREE_USED (assign) = TRUE; + last_function = NULL_TREE; + return assign; +} + +/* BuildCall2 - builds a tree representing: function (arg1, arg2). */ + +tree +m2statement_BuildCall2 (location_t location, tree function, tree rettype, + tree arg1, tree arg2) +{ + m2assert_AssertLocation (location); + ASSERT_CONDITION (param_list == NULL_TREE); + + param_list = chainon (build_tree_list (NULL_TREE, arg2), param_list); + param_list = chainon (build_tree_list (NULL_TREE, arg1), param_list); + return m2statement_BuildProcedureCallTree (location, function, rettype); +} + +/* BuildCall3 - builds a tree representing: function (arg1, arg2, + arg3). */ + +tree +m2statement_BuildCall3 (location_t location, tree function, tree rettype, + tree arg1, tree arg2, tree arg3) +{ + m2assert_AssertLocation (location); + ASSERT_CONDITION (param_list == NULL_TREE); + + param_list = chainon (build_tree_list (NULL_TREE, arg3), param_list); + param_list = chainon (build_tree_list (NULL_TREE, arg2), param_list); + param_list = chainon (build_tree_list (NULL_TREE, arg1), param_list); + return m2statement_BuildProcedureCallTree (location, function, rettype); +} + +/* BuildFunctionCallTree - creates a procedure function call from + a procedure and parameter list and the return type, rettype. + No tree is returned as the tree is held in the last_function global + variable. It is expected the BuildFunctValue is to be called after + a call to BuildFunctionCallTree. */ + +void +m2statement_BuildFunctionCallTree (location_t location, tree procedure, + tree rettype) +{ + m2statement_BuildProcedureCallTree (location, procedure, rettype); +} + +/* SetLastFunction - assigns last_function to, t. */ + +void +m2statement_SetLastFunction (tree t) +{ + last_function = t; +} + +/* SetParamList - assigns param_list to, t. */ + +void +m2statement_SetParamList (tree t) +{ + param_list = t; +} + +/* GetLastFunction - returns, last_function. */ + +tree +m2statement_GetLastFunction (void) +{ + return last_function; +} + +/* GetParamList - returns, param_list. */ + +tree +m2statement_GetParamList (void) +{ + return param_list; +} + +/* GetCurrentFunction - returns the current_function. */ + +tree +m2statement_GetCurrentFunction (void) +{ + return current_function_decl; +} + +/* GetParamTree - return parameter, i. */ + +tree +m2statement_GetParamTree (tree call, unsigned int i) +{ + return CALL_EXPR_ARG (call, i); +} + +/* BuildTryFinally - returns a TRY_FINALL_EXPR with the call and + cleanups attached. */ + +tree +m2statement_BuildTryFinally (location_t location, tree call, tree cleanups) +{ + return build_stmt (location, TRY_FINALLY_EXPR, call, cleanups); +} + +/* BuildCleanUp - return a CLEANUP_POINT_EXPR which will clobber, + param. */ + +tree +m2statement_BuildCleanUp (tree param) +{ + tree clobber = build_constructor (TREE_TYPE (param), NULL); + TREE_THIS_VOLATILE (clobber) = 1; + return build2 (MODIFY_EXPR, TREE_TYPE (param), param, clobber); +} + +/* BuildAsm - generates an inline assembler instruction. */ + +void +m2statement_BuildAsm (location_t location, tree instr, int isVolatile, + int isSimple, tree inputs, tree outputs, tree trash, + tree labels) +{ + tree string = resolve_asm_operand_names (instr, outputs, inputs, labels); + tree args = build_stmt (location, ASM_EXPR, string, outputs, inputs, trash, + labels); + + m2assert_AssertLocation (location); + + /* ASM statements without outputs, including simple ones, are treated + as volatile. */ + ASM_INPUT_P (args) = isSimple; + ASM_VOLATILE_P (args) = isVolatile; + + add_stmt (location, args); +} + +/* BuildUnaryForeachWordDo - provides the large set operators. Each + word (or less) of the set can be calculated by unop. This + procedure runs along each word of the large set invoking the unop. */ + +void +m2statement_BuildUnaryForeachWordDo (location_t location, tree type, tree op1, + tree op2, + tree (*unop) (location_t, tree, int), + int is_op1lvalue, int is_op2lvalue, + int is_op1const, int is_op2const) +{ + tree size = m2expr_GetSizeOf (location, type); + + m2assert_AssertLocation (location); + ASSERT_BOOL (is_op1lvalue); + ASSERT_BOOL (is_op2lvalue); + ASSERT_BOOL (is_op1const); + ASSERT_BOOL (is_op2const); + 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), + (*unop) (location, + m2treelib_get_rvalue (location, op2, type, is_op2lvalue), + FALSE)); + else + { + /* Large set size > TSIZE(WORD). */ + 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); + + if (is_op1const) + error ("internal error: not expecting operand1 to be a constant set"); + + while (field1 != NULL && field2 != NULL) + { + m2statement_BuildAssignmentTree ( + location, m2treelib_get_set_field_des (location, op1, field1), + (*unop) (location, + m2treelib_get_set_field_rhs (location, op2, field2), + FALSE)); + fieldNo++; + field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo); + field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo); + } + } +} + +/* BuildExcludeVarConst - builds the EXCL(op1, 1< 0); + field = TREE_CHAIN (field)) + fieldno--; + + m2statement_BuildAssignmentTree ( + location, m2treelib_get_set_field_des (location, op1, field), + m2expr_BuildLogicalAnd ( + location, m2treelib_get_set_field_rhs (location, op1, field), + m2expr_BuildSetNegate ( + location, + m2expr_BuildLSL (location, m2expr_GetWordOne (location), op2, + FALSE), + FALSE), + FALSE)); + } +} + +/* BuildExcludeVarVar - builds the EXCL(varset, 1< 0); + field = TREE_CHAIN (field)) + fieldno--; + + m2statement_BuildAssignmentTree ( + location, + /* Would like to use: m2expr_BuildComponentRef (location, p, field) + but strangely we have to take the address of the field and + dereference it to satify the gimplifier. See + testsuite/gm2/pim/pass/timeio?.mod for testcases. */ + m2treelib_get_set_field_des (location, op1, field), + m2expr_BuildLogicalOr ( + location, m2treelib_get_set_field_rhs (location, op1, field), + m2expr_BuildLSL (location, m2expr_GetWordOne (location), + m2convert_ToWord (location, op2), FALSE), + FALSE)); + } +} + +/* BuildIncludeVarVar - builds the INCL(varset, 1<. + +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" + +#define m2treelib_c +#include "m2assert.h" +#include "m2block.h" +#include "m2convert.h" +#include "m2decl.h" +#include "m2expr.h" +#include "m2statement.h" +#include "m2tree.h" +#include "m2treelib.h" +#include "m2treelib.h" +#include "m2type.h" + +/* do_jump_if_bit - tests bit in word against integer zero using + operator, code. If the result is true then jump to label. */ + +void +m2treelib_do_jump_if_bit (location_t location, enum tree_code code, tree word, + tree bit, char *label) +{ + word = m2convert_ToWord (location, word); + bit = m2convert_ToWord (location, bit); + m2statement_DoJump ( + location, + m2expr_build_binary_op ( + location, code, + m2expr_build_binary_op ( + location, BIT_AND_EXPR, word, + m2expr_BuildLSL (location, m2expr_GetWordOne (location), bit, + FALSE), + FALSE), + m2expr_GetWordZero (location), FALSE), + NULL, label); +} + +/* build_modify_expr - taken from c-typeck.cc and heavily pruned. + + Build an assignment expression of lvalue LHS from value RHS. If + LHS_ORIGTYPE is not NULL, it is the original type of LHS, which + may differ from TREE_TYPE (LHS) for an enum bitfield. MODIFYCODE + is the code for a binary operator that we use to combine the old + value of LHS with RHS to get the new value. Or else MODIFYCODE is + NOP_EXPR meaning do a simple assignment. If RHS_ORIGTYPE is not + NULL_TREE, it is the original type of RHS, which may differ from + TREE_TYPE (RHS) for an enum value. + + LOCATION is the location of the MODIFYCODE operator. RHS_LOC is the + location of the RHS. */ + +static tree +build_modify_expr (location_t location, tree lhs, enum tree_code modifycode, + tree rhs) +{ + tree result; + tree newrhs; + tree rhs_semantic_type = NULL_TREE; + tree lhstype = TREE_TYPE (lhs); + tree olhstype = lhstype; + + ASSERT_CONDITION (modifycode == NOP_EXPR); + + if (TREE_CODE (rhs) == EXCESS_PRECISION_EXPR) + { + rhs_semantic_type = TREE_TYPE (rhs); + rhs = TREE_OPERAND (rhs, 0); + } + + newrhs = rhs; + + /* If storing into a structure or union member, it has probably been + given type `int'. Compute the type that would go with the actual + amount of storage the member occupies. */ + + if (TREE_CODE (lhs) == COMPONENT_REF + && (TREE_CODE (lhstype) == INTEGER_TYPE + || TREE_CODE (lhstype) == BOOLEAN_TYPE + || TREE_CODE (lhstype) == REAL_TYPE + || TREE_CODE (lhstype) == ENUMERAL_TYPE)) + lhstype = TREE_TYPE (get_unwidened (lhs, 0)); + + /* If storing in a field that is in actuality a short or narrower + than one, we must store in the field in its actual type. */ + + if (lhstype != TREE_TYPE (lhs)) + { + lhs = copy_node (lhs); + TREE_TYPE (lhs) = lhstype; + } + + newrhs = fold (newrhs); + + if (rhs_semantic_type) + newrhs = build1 (EXCESS_PRECISION_EXPR, rhs_semantic_type, newrhs); + + /* Scan operands. */ + + result = build2 (MODIFY_EXPR, lhstype, lhs, newrhs); + TREE_SIDE_EFFECTS (result) = 1; + protected_set_expr_location (result, location); + + /* If we got the LHS in a different type for storing in, convert the + result back to the nominal type of LHS so that the value we return + always has the same type as the LHS argument. */ + + ASSERT_CONDITION (olhstype == TREE_TYPE (result)); + /* In Modula-2 I'm assuming this will be true this maybe wrong, but + at least I'll know about it soon. If true then we do not need to + implement convert_for_assignment - which is a huge win. */ + + return result; +} + +/* m2treelib_build_modify_expr - wrapper function for + build_modify_expr. */ + +tree +m2treelib_build_modify_expr (location_t location, tree des, + enum tree_code modifycode, tree copy) +{ + return build_modify_expr (location, des, modifycode, copy); +} + +/* nCount - return the number of trees chained on, t. */ + +static int +nCount (tree t) +{ + int i = 0; + + while (t != NULL) + { + i++; + t = TREE_CHAIN (t); + } + return i; +} + +/* DoCall - build a call tree arranging the parameter list as a + vector. */ + +tree +m2treelib_DoCall (location_t location, tree rettype, tree funcptr, + tree param_list) +{ + int n = nCount (param_list); + tree *argarray = XALLOCAVEC (tree, n); + tree l = param_list; + int i; + + for (i = 0; i < n; i++) + { + argarray[i] = TREE_VALUE (l); + l = TREE_CHAIN (l); + } + return build_call_array_loc (location, rettype, funcptr, n, argarray); +} + +/* DoCall0 - build a call tree with no parameters. */ + +tree +m2treelib_DoCall0 (location_t location, tree rettype, tree funcptr) +{ + tree *argarray = XALLOCAVEC (tree, 1); + + argarray[0] = NULL_TREE; + + return build_call_array_loc (location, rettype, funcptr, 0, argarray); +} + +/* DoCall1 - build a call tree with 1 parameter. */ + +tree +m2treelib_DoCall1 (location_t location, tree rettype, tree funcptr, tree arg0) +{ + tree *argarray = XALLOCAVEC (tree, 1); + + argarray[0] = arg0; + + return build_call_array_loc (location, rettype, funcptr, 1, argarray); +} + +/* DoCall2 - build a call tree with 2 parameters. */ + +tree +m2treelib_DoCall2 (location_t location, tree rettype, tree funcptr, tree arg0, + tree arg1) +{ + tree *argarray = XALLOCAVEC (tree, 2); + + argarray[0] = arg0; + argarray[1] = arg1; + + return build_call_array_loc (location, rettype, funcptr, 2, argarray); +} + +/* DoCall3 - build a call tree with 3 parameters. */ + +tree +m2treelib_DoCall3 (location_t location, tree rettype, tree funcptr, tree arg0, + tree arg1, tree arg2) +{ + tree *argarray = XALLOCAVEC (tree, 3); + + argarray[0] = arg0; + argarray[1] = arg1; + argarray[2] = arg2; + + return build_call_array_loc (location, rettype, funcptr, 3, argarray); +} + +/* get_rvalue - returns the rvalue of t. The, type, is the object + type to be copied upon indirection. */ + +tree +m2treelib_get_rvalue (location_t location, tree t, tree type, int is_lvalue) +{ + if (is_lvalue) + return m2expr_BuildIndirect (location, t, type); + else + return t; +} + +/* get_field_no - returns the field no for, op. The, op, is either a + constructor or a variable of type record. If, op, is a + constructor (a set constant in GNU Modula-2) then this function is + essentially a no-op and it returns op. Else we iterate over the + field list and return the appropriate field number. */ + +tree +m2treelib_get_field_no (tree type, tree op, int is_const, unsigned int fieldNo) +{ + ASSERT_BOOL (is_const); + if (is_const) + return op; + else + { + tree list = TYPE_FIELDS (type); + while (fieldNo > 0 && list != NULL_TREE) + { + list = TREE_CHAIN (list); + fieldNo--; + } + return list; + } +} + +/* get_set_value - returns the value indicated by, field, in the set. + Either p->field or the constant(op.fieldNo) is returned. */ + +tree +m2treelib_get_set_value (location_t location, tree p, tree field, int is_const, + int is_lvalue, tree op, unsigned int fieldNo) +{ + tree value; + constructor_elt *ce; + + ASSERT_BOOL (is_const); + ASSERT_BOOL (is_lvalue); + if (is_const) + { + ASSERT_CONDITION (is_lvalue == FALSE); + gcc_assert (!vec_safe_is_empty (CONSTRUCTOR_ELTS (op))); + unsigned int size = vec_safe_length (CONSTRUCTOR_ELTS (op)); + if (size < fieldNo) + internal_error ("field number exceeds definition of set"); + if (vec_safe_iterate (CONSTRUCTOR_ELTS (op), fieldNo, &ce)) + value = ce->value; + else + internal_error ( + "field number out of range trying to access set element"); + } + else if (is_lvalue) + { + if (TREE_CODE (TREE_TYPE (p)) == POINTER_TYPE) + value = m2expr_BuildComponentRef ( + location, m2expr_BuildIndirect (location, p, TREE_TYPE (p)), + field); + else + { + ASSERT_CONDITION (TREE_CODE (TREE_TYPE (p)) == REFERENCE_TYPE); + value = m2expr_BuildComponentRef (location, p, field); + } + } + else + { + tree type = TREE_TYPE (op); + enum tree_code code = TREE_CODE (type); + + ASSERT_CONDITION (code == RECORD_TYPE + || (code == POINTER_TYPE + && (TREE_CODE (TREE_TYPE (type)) == RECORD_TYPE))); + value = m2expr_BuildComponentRef (location, op, field); + } + value = m2convert_ToBitset (location, value); + return value; +} + +/* get_set_address - returns the address of op1. */ + +tree +m2treelib_get_set_address (location_t location, tree op1, int is_lvalue) +{ + if (is_lvalue) + return op1; + else + return m2expr_BuildAddr (location, op1, FALSE); +} + +/* get_set_field_lhs - returns the address of p->field. */ + +tree +m2treelib_get_set_field_lhs (location_t location, tree p, tree field) +{ + return m2expr_BuildAddr ( + location, m2convert_ToBitset ( + location, m2expr_BuildComponentRef (location, p, field)), + FALSE); +} + +/* get_set_field_rhs - returns the value of p->field. */ + +tree +m2treelib_get_set_field_rhs (location_t location, tree p, tree field) +{ + return m2convert_ToBitset (location, + m2expr_BuildComponentRef (location, p, field)); +} + +/* get_set_field_des - returns the p->field ready to be a (rhs) + designator. */ + +tree +m2treelib_get_set_field_des (location_t location, tree p, tree field) +{ + return m2expr_BuildIndirect ( + location, + m2expr_BuildAddr (location, + m2expr_BuildComponentRef (location, p, field), FALSE), + m2type_GetBitsetType ()); +} + +/* get_set_address_if_var - returns the address of, op, providing it + is not a constant. NULL is returned if, op, is a constant. */ + +tree +m2treelib_get_set_address_if_var (location_t location, tree op, int is_lvalue, + int is_const) +{ + if (is_const) + return NULL; + else + return m2treelib_get_set_address (location, op, is_lvalue); +} + +/* add_stmt - t is a statement. Add it to the statement-tree. */ + +tree +add_stmt (location_t location, tree t) +{ + return m2block_add_stmt (location, t); +} + +/* taken from gcc/c-semantics.cc. */ + +/* Build a generic statement based on the given type of node and + arguments. Similar to `build_nt', except that we set EXPR_LOCATION + to LOC. */ + +tree +build_stmt (location_t loc, enum tree_code code, ...) +{ + tree ret; + int length, i; + va_list p; + bool side_effects; + + m2assert_AssertLocation (loc); + /* This function cannot be used to construct variably-sized nodes. */ + gcc_assert (TREE_CODE_CLASS (code) != tcc_vl_exp); + + va_start (p, code); + + ret = make_node (code); + TREE_TYPE (ret) = void_type_node; + length = TREE_CODE_LENGTH (code); + SET_EXPR_LOCATION (ret, loc); + + /* TREE_SIDE_EFFECTS will already be set for statements with implicit + side effects. Here we make sure it is set for other expressions by + checking whether the parameters have side effects. */ + + side_effects = false; + for (i = 0; i < length; i++) + { + tree t = va_arg (p, tree); + if (t && !TYPE_P (t)) + side_effects |= TREE_SIDE_EFFECTS (t); + TREE_OPERAND (ret, i) = t; + } + + TREE_SIDE_EFFECTS (ret) |= side_effects; + + va_end (p); + return ret; +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/README --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/README 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,5 @@ +This directory contains the interface code between the Modula-2 front +end and GCC. In effect this is the Modula-2 compiler GCC Tree API. +It is an internal API only. Many of these filenames match their GCC C +family counterparts. So for example m2decl.def and m2decl.cc are the +Modula-2 front end version of c-decl.cc. diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2top.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2top.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,65 @@ +/* m2top.cc provides top level scoping functions. + +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 "m2assert.h" +#include "m2block.h" +#include "m2decl.h" +#include "m2expr.h" +#include "m2tree.h" +#include "m2type.h" +#define m2top_c +#include "m2top.h" + +/* StartGlobalContext - initializes a dummy function for the global + scope. */ + +void +m2top_StartGlobalContext (void) +{ +} + +/* EndGlobalContext - ends the dummy function for the global scope. */ + +void +m2top_EndGlobalContext (void) +{ +} + +/* FinishBackend - flushes all outstanding functions held in the GCC + backend out to the assembly file. */ + +void +m2top_FinishBackend (void) +{ +} + +/* SetFlagUnitAtATime - sets GCC flag_unit_at_a_time to b. */ + +void +m2top_SetFlagUnitAtATime (int b) +{ + flag_unit_at_a_time = b; +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2tree.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2tree.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,132 @@ +/* m2tree.cc provides a simple interface to GCC tree queries and skips. + +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 m2tree_c +#include "m2tree.h" + +int +m2tree_is_var (tree var) +{ + return TREE_CODE (var) == VAR_DECL; +} + +int +m2tree_is_array (tree array) +{ + return TREE_CODE (array) == ARRAY_TYPE; +} + +int +m2tree_is_type (tree type) +{ + switch (TREE_CODE (type)) + { + + case TYPE_DECL: + case ARRAY_TYPE: + case RECORD_TYPE: + case SET_TYPE: + case ENUMERAL_TYPE: + case POINTER_TYPE: + case INTEGER_TYPE: + case REAL_TYPE: + case UNION_TYPE: + case BOOLEAN_TYPE: + case COMPLEX_TYPE: + return TRUE; + default: + return FALSE; + } +} + +tree +m2tree_skip_type_decl (tree type) +{ + if (type == error_mark_node) + return error_mark_node; + + if (type == NULL_TREE) + return NULL_TREE; + + if (TREE_CODE (type) == TYPE_DECL) + return m2tree_skip_type_decl (TREE_TYPE (type)); + return type; +} + +tree +m2tree_skip_const_decl (tree exp) +{ + if (exp == error_mark_node) + return error_mark_node; + + if (exp == NULL_TREE) + return NULL_TREE; + + if (TREE_CODE (exp) == CONST_DECL) + return DECL_INITIAL (exp); + return exp; +} + +/* m2tree_skip_reference_type - skips all POINTER_TYPE and + REFERENCE_TYPEs. Otherwise return exp. */ + +tree +m2tree_skip_reference_type (tree exp) +{ + if (TREE_CODE (exp) == REFERENCE_TYPE) + return m2tree_skip_reference_type (TREE_TYPE (exp)); + if (TREE_CODE (exp) == POINTER_TYPE) + return m2tree_skip_reference_type (TREE_TYPE (exp)); + return exp; +} + +/* m2tree_IsOrdinal - return TRUE if code is an INTEGER, BOOLEAN or + ENUMERAL type. */ + +int +m2tree_IsOrdinal (tree type) +{ + enum tree_code code = TREE_CODE (type); + + return (code == INTEGER_TYPE || (code) == BOOLEAN_TYPE + || (code) == ENUMERAL_TYPE); +} + +/* is_a_constant - returns TRUE if tree, t, is a constant. */ + +int +m2tree_IsAConstant (tree t) +{ + return (TREE_CODE (t) == INTEGER_CST) || (TREE_CODE (t) == REAL_CST) + || (TREE_CODE (t) == REAL_CST) || (TREE_CODE (t) == COMPLEX_CST) + || (TREE_CODE (t) == STRING_CST); +} + + +void +m2tree_debug_tree (tree t) +{ + debug_tree (t); +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2type.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2type.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,3092 @@ +/* m2type.cc provides an interface to GCC type 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" + +#define m2type_c +#include "m2assert.h" +#include "m2block.h" +#include "m2builtins.h" +#include "m2convert.h" +#include "m2decl.h" +#include "m2except.h" +#include "m2expr.h" +#include "m2linemap.h" +#include "m2tree.h" +#include "m2treelib.h" +#include "m2type.h" + +#undef USE_BOOLEAN +static int broken_set_debugging_info = TRUE; + + +struct GTY (()) struct_constructor +{ + /* Constructor_type, the type that we are constructing. */ + tree GTY ((skip (""))) constructor_type; + /* Constructor_fields, the list of fields belonging to + constructor_type. Used by SET and RECORD constructors. */ + tree GTY ((skip (""))) constructor_fields; + /* Constructor_element_list, the list of constants used by SET and + RECORD constructors. */ + tree GTY ((skip (""))) constructor_element_list; + /* Constructor_elements, used by an ARRAY initializer all elements + are held in reverse order. */ + vec *constructor_elements; + /* Level, the next level down in the constructor stack. */ + struct struct_constructor *level; +}; + +static GTY (()) struct struct_constructor *top_constructor = NULL; + +typedef struct GTY (()) array_desc +{ + int type; + tree index; + tree array; + struct array_desc *next; +} array_desc; + +static GTY (()) array_desc *list_of_arrays = NULL; +/* Used in BuildStartFunctionType. */ +static GTY (()) tree param_type_list; + +static GTY (()) tree proc_type_node; +static GTY (()) tree bitset_type_node; +static GTY (()) tree bitnum_type_node; +static GTY (()) tree m2_char_type_node; +static GTY (()) tree m2_integer_type_node; +static GTY (()) tree m2_cardinal_type_node; +static GTY (()) tree m2_short_real_type_node; +static GTY (()) tree m2_real_type_node; +static GTY (()) tree m2_long_real_type_node; +static GTY (()) tree m2_long_int_type_node; +static GTY (()) tree m2_long_card_type_node; +static GTY (()) tree m2_short_int_type_node; +static GTY (()) tree m2_short_card_type_node; +static GTY (()) tree m2_z_type_node; +static GTY (()) tree m2_iso_loc_type_node; +static GTY (()) tree m2_iso_byte_type_node; +static GTY (()) tree m2_iso_word_type_node; +static GTY (()) tree m2_integer8_type_node; +static GTY (()) tree m2_integer16_type_node; +static GTY (()) tree m2_integer32_type_node; +static GTY (()) tree m2_integer64_type_node; +static GTY (()) tree m2_cardinal8_type_node; +static GTY (()) tree m2_cardinal16_type_node; +static GTY (()) tree m2_cardinal32_type_node; +static GTY (()) tree m2_cardinal64_type_node; +static GTY (()) tree m2_word16_type_node; +static GTY (()) tree m2_word32_type_node; +static GTY (()) tree m2_word64_type_node; +static GTY (()) tree m2_bitset8_type_node; +static GTY (()) tree m2_bitset16_type_node; +static GTY (()) tree m2_bitset32_type_node; +static GTY (()) tree m2_real32_type_node; +static GTY (()) tree m2_real64_type_node; +static GTY (()) tree m2_real96_type_node; +static GTY (()) tree m2_real128_type_node; +static GTY (()) tree m2_complex_type_node; +static GTY (()) tree m2_long_complex_type_node; +static GTY (()) tree m2_short_complex_type_node; +static GTY (()) tree m2_c_type_node; +static GTY (()) tree m2_complex32_type_node; +static GTY (()) tree m2_complex64_type_node; +static GTY (()) tree m2_complex96_type_node; +static GTY (()) tree m2_complex128_type_node; +static GTY (()) tree m2_packed_boolean_type_node; +static GTY (()) tree m2_cardinal_address_type_node; + +/* gm2_canonicalize_array - returns a unique array node based on + index_type and type. */ + +static tree +gm2_canonicalize_array (tree index_type, int type) +{ + array_desc *l = list_of_arrays; + + while (l != NULL) + { + if (l->type == type && l->index == index_type) + return l->array; + else + l = l->next; + } + l = ggc_alloc (); + l->next = list_of_arrays; + l->type = type; + l->index = index_type; + l->array = make_node (ARRAY_TYPE); + TREE_TYPE (l->array) = NULL_TREE; + TYPE_DOMAIN (l->array) = index_type; + list_of_arrays = l; + return l->array; +} + +/* BuildStartArrayType - creates an array with an indextype and + elttype. The front end symbol type is also passed to allow the + gccgm2 to return the canonical edition of the array type even if + the GCC elttype is NULL_TREE. */ + +tree +m2type_BuildStartArrayType (tree index_type, tree elt_type, int type) +{ + tree t; + + elt_type = m2tree_skip_type_decl (elt_type); + ASSERT_CONDITION (index_type != NULL_TREE); + if (elt_type == NULL_TREE) + { + /* Cannot use GCC canonicalization routines yet, so we use our front + end version based on the front end type. */ + return gm2_canonicalize_array (index_type, type); + } + t = gm2_canonicalize_array (index_type, type); + if (TREE_TYPE (t) == NULL_TREE) + TREE_TYPE (t) = elt_type; + else + ASSERT_CONDITION (TREE_TYPE (t) == elt_type); + + return t; +} + +/* PutArrayType assignes TREE_TYPE (array) to the skipped type. */ + +void +m2type_PutArrayType (tree array, tree type) +{ + TREE_TYPE (array) = m2tree_skip_type_decl (type); +} + +/* gccgm2_GetArrayNoOfElements returns the number of elements in + arraytype. */ + +tree +m2type_GetArrayNoOfElements (location_t location, tree arraytype) +{ + tree index_type = TYPE_DOMAIN (m2tree_skip_type_decl (arraytype)); + tree min = TYPE_MIN_VALUE (index_type); + tree max = TYPE_MAX_VALUE (index_type); + + m2assert_AssertLocation (location); + return m2expr_FoldAndStrip (m2expr_BuildSub (location, max, min, FALSE)); +} + +/* gm2_finish_build_array_type complete building the partially + created array type, arrayType. The arrayType is now known to be + declared as: ARRAY index_type OF elt_type. There will only ever + be one gcc tree type for this array definition. The third + parameter type is a front end type and this is necessary so that + the canonicalization creates unique array types for each type. */ + +static tree +gm2_finish_build_array_type (tree arrayType, tree elt_type, tree index_type, + int type) +{ + tree old = arrayType; + + elt_type = m2tree_skip_type_decl (elt_type); + ASSERT_CONDITION (index_type != NULL_TREE); + if (TREE_CODE (elt_type) == FUNCTION_TYPE) + { + error ("arrays of functions are not meaningful"); + elt_type = integer_type_node; + } + + TREE_TYPE (arrayType) = elt_type; + TYPE_DOMAIN (arrayType) = index_type; + + arrayType = gm2_canonicalize_array (index_type, type); + if (arrayType != old) + internal_error ("array declaration canonicalization has failed"); + + if (!COMPLETE_TYPE_P (arrayType)) + layout_type (arrayType); + return arrayType; +} + +/* BuildEndArrayType returns a type which is an array indexed by + IndexType and which has ElementType elements. */ + +tree +m2type_BuildEndArrayType (tree arraytype, tree elementtype, tree indextype, + int type) +{ + elementtype = m2tree_skip_type_decl (elementtype); + ASSERT (indextype == TYPE_DOMAIN (arraytype), indextype); + + if (TREE_CODE (elementtype) == FUNCTION_TYPE) + return gm2_finish_build_array_type (arraytype, ptr_type_node, indextype, + type); + else + return gm2_finish_build_array_type ( + arraytype, m2tree_skip_type_decl (elementtype), indextype, type); +} + +/* gm2_build_array_type returns a type which is an array indexed by + IndexType and which has ElementType elements. */ + +static tree +gm2_build_array_type (tree elementtype, tree indextype, int fetype) +{ + tree arrayType = m2type_BuildStartArrayType (indextype, elementtype, fetype); + return m2type_BuildEndArrayType (arrayType, elementtype, indextype, fetype); +} + +/* ValueInTypeRange returns TRUE if the constant, value, lies within + the range of type. */ + +int +m2type_ValueInTypeRange (tree type, tree value) +{ + tree low_type = m2tree_skip_type_decl (type); + tree min_value = TYPE_MIN_VALUE (low_type); + tree max_value = TYPE_MAX_VALUE (low_type); + + value = m2expr_FoldAndStrip (value); + return ((tree_int_cst_compare (min_value, value) <= 0) + && (tree_int_cst_compare (value, max_value) <= 0)); +} + +/* ValueOutOfTypeRange returns TRUE if the constant, value, exceeds + the range of type. */ + +int +m2type_ValueOutOfTypeRange (tree type, tree value) +{ + return (!m2type_ValueInTypeRange (type, value)); +} + +/* ExceedsTypeRange return TRUE if low or high exceed the range of + type. */ + +int +m2type_ExceedsTypeRange (tree type, tree low, tree high) +{ + return (m2type_ValueOutOfTypeRange (type, low) + || m2type_ValueOutOfTypeRange (type, high)); +} + +/* WithinTypeRange return TRUE if low and high are within the range + of type. */ + +int +m2type_WithinTypeRange (tree type, tree low, tree high) +{ + return (m2type_ValueInTypeRange (type, low) + && m2type_ValueInTypeRange (type, high)); +} + +/* BuildArrayIndexType creates an integer index which accesses an + array. low and high are the min, max elements of the array. GCC + insists we access an array with an integer indice. */ + +tree +m2type_BuildArrayIndexType (tree low, tree high) +{ + tree sizelow = convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (low)); + tree sizehigh + = convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (high)); + + if (m2expr_TreeOverflow (sizelow)) + error ("low bound for the array is outside the ztype limits"); + if (m2expr_TreeOverflow (sizehigh)) + error ("high bound for the array is outside the ztype limits"); + + return build_range_type (m2type_GetIntegerType (), + m2expr_FoldAndStrip (sizelow), + m2expr_FoldAndStrip (sizehigh)); +} + +/* build_m2_type_node_by_array builds a ISO Modula-2 word type from + ARRAY [low..high] OF arrayType. This matches the front end data + type fetype which is only used during canonicalization. */ + +static tree +build_m2_type_node_by_array (tree arrayType, tree low, tree high, int fetype) +{ + return gm2_build_array_type (arrayType, + m2type_BuildArrayIndexType (low, high), fetype); +} + +/* build_m2_word16_type_node build an ISO 16 bit word as an ARRAY + [0..1] OF loc. */ + +static tree +build_m2_word16_type_node (location_t location, int loc) +{ + return build_m2_type_node_by_array (m2type_GetISOLocType (), + m2expr_GetIntegerZero (location), + m2expr_GetIntegerOne (location), loc); +} + +/* build_m2_word32_type_node build an ISO 32 bit word as an ARRAY + [0..3] OF loc. */ + +static tree +build_m2_word32_type_node (location_t location, int loc) +{ + return build_m2_type_node_by_array (m2type_GetISOLocType (), + m2expr_GetIntegerZero (location), + m2decl_BuildIntegerConstant (3), loc); +} + +/* build_m2_word64_type_node build an ISO 32 bit word as an ARRAY + [0..7] OF loc. */ + +static tree +build_m2_word64_type_node (location_t location, int loc) +{ + return build_m2_type_node_by_array (m2type_GetISOLocType (), + m2expr_GetIntegerZero (location), + m2decl_BuildIntegerConstant (7), loc); +} + +/* GetM2Complex32 return the fixed size complex type. */ + +tree +m2type_GetM2Complex32 (void) +{ + return m2_complex32_type_node; +} + +/* GetM2Complex64 return the fixed size complex type. */ + +tree +m2type_GetM2Complex64 (void) +{ + return m2_complex64_type_node; +} + +/* GetM2Complex96 return the fixed size complex type. */ + +tree +m2type_GetM2Complex96 (void) +{ + return m2_complex96_type_node; +} + +/* GetM2Complex128 return the fixed size complex type. */ + +tree +m2type_GetM2Complex128 (void) +{ + return m2_complex128_type_node; +} + +/* GetM2CType a test function. */ + +tree +m2type_GetM2CType (void) +{ + return m2_c_type_node; +} + +/* GetM2ShortComplexType return the short complex type. */ + +tree +m2type_GetM2ShortComplexType (void) +{ + return m2_short_complex_type_node; +} + +/* GetM2LongComplexType return the long complex type. */ + +tree +m2type_GetM2LongComplexType (void) +{ + return m2_long_complex_type_node; +} + +/* GetM2ComplexType return the complex type. */ + +tree +m2type_GetM2ComplexType (void) +{ + return m2_complex_type_node; +} + +/* GetM2Real128 return the real 128 bit type. */ + +tree +m2type_GetM2Real128 (void) +{ + return m2_real128_type_node; +} + +/* GetM2Real96 return the real 96 bit type. */ + +tree +m2type_GetM2Real96 (void) +{ + return m2_real96_type_node; +} + +/* GetM2Real64 return the real 64 bit type. */ + +tree +m2type_GetM2Real64 (void) +{ + return m2_real64_type_node; +} + +/* GetM2Real32 return the real 32 bit type. */ + +tree +m2type_GetM2Real32 (void) +{ + return m2_real32_type_node; +} + +/* GetM2Bitset32 return the bitset 32 bit type. */ + +tree +m2type_GetM2Bitset32 (void) +{ + return m2_bitset32_type_node; +} + +/* GetM2Bitset16 return the bitset 16 bit type. */ + +tree +m2type_GetM2Bitset16 (void) +{ + return m2_bitset16_type_node; +} + +/* GetM2Bitset8 return the bitset 8 bit type. */ + +tree +m2type_GetM2Bitset8 (void) +{ + return m2_bitset8_type_node; +} + +/* GetM2Word64 return the word 64 bit type. */ + +tree +m2type_GetM2Word64 (void) +{ + return m2_word64_type_node; +} + +/* GetM2Word32 return the word 32 bit type. */ + +tree +m2type_GetM2Word32 (void) +{ + return m2_word32_type_node; +} + +/* GetM2Word16 return the word 16 bit type. */ + +tree +m2type_GetM2Word16 (void) +{ + return m2_word16_type_node; +} + +/* GetM2Cardinal64 return the cardinal 64 bit type. */ + +tree +m2type_GetM2Cardinal64 (void) +{ + return m2_cardinal64_type_node; +} + +/* GetM2Cardinal32 return the cardinal 32 bit type. */ + +tree +m2type_GetM2Cardinal32 (void) +{ + return m2_cardinal32_type_node; +} + +/* GetM2Cardinal16 return the cardinal 16 bit type. */ + +tree +m2type_GetM2Cardinal16 (void) +{ + return m2_cardinal16_type_node; +} + +/* GetM2Cardinal8 return the cardinal 8 bit type. */ + +tree +m2type_GetM2Cardinal8 (void) +{ + return m2_cardinal8_type_node; +} + +/* GetM2Integer64 return the integer 64 bit type. */ + +tree +m2type_GetM2Integer64 (void) +{ + return m2_integer64_type_node; +} + +/* GetM2Integer32 return the integer 32 bit type. */ + +tree +m2type_GetM2Integer32 (void) +{ + return m2_integer32_type_node; +} + +/* GetM2Integer16 return the integer 16 bit type. */ + +tree +m2type_GetM2Integer16 (void) +{ + return m2_integer16_type_node; +} + +/* GetM2Integer8 return the integer 8 bit type. */ + +tree +m2type_GetM2Integer8 (void) +{ + return m2_integer8_type_node; +} + +/* GetM2RType return the ISO R data type, the longest real + datatype. */ + +tree +m2type_GetM2RType (void) +{ + return long_double_type_node; +} + +/* GetM2ZType return the ISO Z data type, the longest int datatype. */ + +tree +m2type_GetM2ZType (void) +{ + return m2_z_type_node; +} + +/* GetShortCardType return the C short unsigned data type. */ + +tree +m2type_GetShortCardType (void) +{ + return short_unsigned_type_node; +} + +/* GetM2ShortCardType return the m2 short cardinal data type. */ + +tree +m2type_GetM2ShortCardType (void) +{ + return m2_short_card_type_node; +} + +/* GetShortIntType return the C short int data type. */ + +tree +m2type_GetShortIntType (void) +{ + return short_integer_type_node; +} + +/* GetM2ShortIntType return the m2 short integer data type. */ + +tree +m2type_GetM2ShortIntType (void) +{ + return m2_short_int_type_node; +} + +/* GetM2LongCardType return the m2 long cardinal data type. */ + +tree +m2type_GetM2LongCardType (void) +{ + return m2_long_card_type_node; +} + +/* GetM2LongIntType return the m2 long integer data type. */ + +tree +m2type_GetM2LongIntType (void) +{ + return m2_long_int_type_node; +} + +/* GetM2LongRealType return the m2 long real data type. */ + +tree +m2type_GetM2LongRealType (void) +{ + return m2_long_real_type_node; +} + +/* GetM2RealType return the m2 real data type. */ + +tree +m2type_GetM2RealType (void) +{ + return m2_real_type_node; +} + +/* GetM2ShortRealType return the m2 short real data type. */ + +tree +m2type_GetM2ShortRealType (void) +{ + return m2_short_real_type_node; +} + +/* GetM2CardinalType return the m2 cardinal data type. */ + +tree +m2type_GetM2CardinalType (void) +{ + return m2_cardinal_type_node; +} + +/* GetM2IntegerType return the m2 integer data type. */ + +tree +m2type_GetM2IntegerType (void) +{ + return m2_integer_type_node; +} + +/* GetM2CharType return the m2 char data type. */ + +tree +m2type_GetM2CharType (void) +{ + return m2_char_type_node; +} + +/* GetProcType return the m2 proc data type. */ + +tree +m2type_GetProcType (void) +{ + return proc_type_node; +} + +/* GetISOWordType return the m2 iso word data type. */ + +tree +m2type_GetISOWordType (void) +{ + return m2_iso_word_type_node; +} + +/* GetISOByteType return the m2 iso byte data type. */ + +tree +m2type_GetISOByteType (void) +{ + return m2_iso_byte_type_node; +} + +/* GetISOLocType return the m2 loc word data type. */ + +tree +m2type_GetISOLocType (void) +{ + return m2_iso_loc_type_node; +} + +/* GetWordType return the C unsigned data type. */ + +tree +m2type_GetWordType (void) +{ + return unsigned_type_node; +} + +/* GetLongIntType return the C long int data type. */ + +tree +m2type_GetLongIntType (void) +{ + return long_integer_type_node; +} + +/* GetShortRealType return the C float data type. */ + +tree +m2type_GetShortRealType (void) +{ + return float_type_node; +} + +/* GetLongRealType return the C long double data type. */ + +tree +m2type_GetLongRealType (void) +{ + return long_double_type_node; +} + +/* GetRealType returns the C double_type_node. */ + +tree +m2type_GetRealType (void) +{ + return double_type_node; +} + +/* GetBitnumType return the ISO bitnum type. */ + +tree +m2type_GetBitnumType (void) +{ + return bitnum_type_node; +} + +/* GetBitsetType return the bitset type. */ + +tree +m2type_GetBitsetType (void) +{ + return bitset_type_node; +} + +/* GetCardinalType return the cardinal type. */ + +tree +m2type_GetCardinalType (void) +{ + return unsigned_type_node; +} + +/* GetPointerType return the GCC ptr type node. Equivalent to + (void *). */ + +tree +m2type_GetPointerType (void) +{ + return ptr_type_node; +} + +/* GetVoidType return the C void type. */ + +tree +m2type_GetVoidType (void) +{ + return void_type_node; +} + +/* GetByteType return the byte type node. */ + +tree +m2type_GetByteType (void) +{ + return unsigned_char_type_node; +} + +/* GetCharType return the char type node. */ + +tree +m2type_GetCharType (void) +{ + return char_type_node; +} + +/* GetIntegerType return the integer type node. */ + +tree +m2type_GetIntegerType (void) +{ + return integer_type_node; +} + +/* GetCSizeTType return a type representing, size_t on this system. */ + +tree +m2type_GetCSizeTType (void) +{ + return sizetype; +} + +/* GetCSSizeTType return a type representing, size_t on this + system. */ + +tree +m2type_GetCSSizeTType (void) +{ + return ssizetype; +} + +/* GetPackedBooleanType return the packed boolean data type node. */ + +tree +m2type_GetPackedBooleanType (void) +{ + return m2_packed_boolean_type_node; +} + +/* GetBooleanTrue return modula-2 TRUE. */ + +tree +m2type_GetBooleanTrue (void) +{ +#if defined(USE_BOOLEAN) + return boolean_true_node; +#else /* !USE_BOOLEAN */ + return m2expr_GetIntegerOne (m2linemap_BuiltinsLocation ()); +#endif /* !USE_BOOLEAN */ +} + +/* GetBooleanFalse return modula-2 FALSE. */ + +tree +m2type_GetBooleanFalse (void) +{ +#if defined(USE_BOOLEAN) + return boolean_false_node; +#else /* !USE_BOOLEAN */ + return m2expr_GetIntegerZero (m2linemap_BuiltinsLocation ()); +#endif /* !USE_BOOLEAN */ +} + +/* GetBooleanType return the modula-2 BOOLEAN type. */ + +tree +m2type_GetBooleanType (void) +{ +#if defined(USE_BOOLEAN) + return boolean_type_node; +#else /* !USE_BOOLEAN */ + return integer_type_node; +#endif /* !USE_BOOLEAN */ +} + +/* GetCardinalAddressType returns the internal data type for + computing binary arithmetic upon the ADDRESS datatype. */ + +tree +m2type_GetCardinalAddressType (void) +{ + return m2_cardinal_address_type_node; +} + +/* noBitsRequired returns the number of bits required to contain, + values. How many bits are required to represent all numbers + between: 0..values-1 */ + +static tree +noBitsRequired (tree values) +{ + int bits = tree_floor_log2 (values); + + if (integer_pow2p (values)) + /* remember we start counting from zero. */ + return m2decl_BuildIntegerConstant (bits); + else + return m2decl_BuildIntegerConstant (bits + 1); +} + +#if 0 +/* build_set_type creates a set type from the, domain, [low..high]. + The values low..high all have type, range_type. */ + +static tree +build_set_type (tree domain, tree range_type, int allow_void, int ispacked) +{ + tree type; + + if (!m2tree_IsOrdinal (domain) + && !(allow_void && TREE_CODE (domain) == VOID_TYPE)) + { + error ("set base type must be an ordinal type"); + return NULL; + } + + if (TYPE_SIZE (range_type) == 0) + layout_type (range_type); + + if (TYPE_SIZE (domain) == 0) + layout_type (domain); + + type = make_node (SET_TYPE); + TREE_TYPE (type) = range_type; + TYPE_DOMAIN (type) = domain; + TYPE_PACKED (type) = ispacked; + + return type; +} + + +/* convert_type_to_range does the conversion and copies the range + type */ + +static tree +convert_type_to_range (tree type) +{ + tree min, max; + tree itype; + + if (!m2tree_IsOrdinal (type)) + { + error ("ordinal type expected"); + return error_mark_node; + } + + min = TYPE_MIN_VALUE (type); + max = TYPE_MAX_VALUE (type); + + if (TREE_TYPE (min) != TREE_TYPE (max)) + { + error ("range limits are not of the same type"); + return error_mark_node; + } + + itype = build_range_type (TREE_TYPE (min), min, max); + + if (TREE_TYPE (type) == NULL_TREE) + { + layout_type (type); + TREE_TYPE (itype) = type; + } + else + { + layout_type (TREE_TYPE (type)); + TREE_TYPE (itype) = TREE_TYPE (type); + } + + layout_type (itype); + return itype; +} +#endif + +/* build_bitset_type builds the type BITSET which is exported from + SYSTEM. It also builds BITNUM (the subrange from which BITSET is + created). */ + +static tree +build_bitset_type (location_t location) +{ + m2assert_AssertLocation (location); + bitnum_type_node = build_range_type ( + m2tree_skip_type_decl (m2type_GetCardinalType ()), + m2decl_BuildIntegerConstant (0), + m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset () - 1)); + layout_type (bitnum_type_node); + +#if 1 + if (broken_set_debugging_info) + return unsigned_type_node; +#endif + + ASSERT ((COMPLETE_TYPE_P (bitnum_type_node)), bitnum_type_node); + + return m2type_BuildSetTypeFromSubrange ( + location, NULL, bitnum_type_node, m2decl_BuildIntegerConstant (0), + m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset () - 1), FALSE); +} + +/* BuildSetTypeFromSubrange constructs a set type from a + subrangeType. --fixme-- revisit once gdb/gcc supports dwarf-5 set type. */ + +tree +m2type_BuildSetTypeFromSubrange (location_t location, + char *name __attribute__ ((unused)), + tree subrangeType __attribute__ ((unused)), + tree lowval, tree highval, int ispacked) +{ + m2assert_AssertLocation (location); + lowval = m2expr_FoldAndStrip (lowval); + highval = m2expr_FoldAndStrip (highval); + +#if 0 + if (broken_set_debugging_info) + return unsigned_type_node; + else +#endif + if (ispacked) + { + tree noelements = m2expr_BuildAdd ( + location, m2expr_BuildSub (location, highval, lowval, FALSE), + integer_one_node, FALSE); + highval = m2expr_FoldAndStrip (m2expr_BuildSub ( + location, m2expr_BuildLSL (location, m2expr_GetWordOne (location), + noelements, FALSE), + m2expr_GetIntegerOne (location), FALSE)); + lowval = m2expr_GetIntegerZero (location); + return m2type_BuildSmallestTypeRange (location, lowval, highval); + } + else + return unsigned_type_node; +} + +/* build_m2_size_set_type build and return a set type with + precision bits. */ + +static tree +build_m2_size_set_type (location_t location, int precision) +{ + tree bitnum_type_node + = build_range_type (m2tree_skip_type_decl (m2type_GetCardinalType ()), + m2decl_BuildIntegerConstant (0), + m2decl_BuildIntegerConstant (precision - 1)); + layout_type (bitnum_type_node); + m2assert_AssertLocation (location); + + if (broken_set_debugging_info) + return unsigned_type_node; + + ASSERT ((COMPLETE_TYPE_P (bitnum_type_node)), bitnum_type_node); + + return m2type_BuildSetTypeFromSubrange ( + location, NULL, bitnum_type_node, m2decl_BuildIntegerConstant (0), + m2decl_BuildIntegerConstant (precision - 1), FALSE); +} + +/* build_m2_specific_size_type build a specific data type matching + number of bits precision whether it is_signed. It creates a + set type if base == SET_TYPE or returns the already created real, + if REAL_TYPE is specified. */ + +static tree +build_m2_specific_size_type (location_t location, enum tree_code base, + int precision, int is_signed) +{ + tree c; + + m2assert_AssertLocation (location); + + c = make_node (base); + TYPE_PRECISION (c) = precision; + + if (base == REAL_TYPE) + { + if (!float_mode_for_size (TYPE_PRECISION (c)).exists ()) + return NULL; + layout_type (c); + } + else if (base == SET_TYPE) + return build_m2_size_set_type (location, precision); + else + { + TYPE_SIZE (c) = 0; + + if (is_signed) + { + fixup_signed_type (c); + TYPE_UNSIGNED (c) = FALSE; + } + else + { + fixup_unsigned_type (c); + TYPE_UNSIGNED (c) = TRUE; + } + } + + return c; +} + +/* BuildSmallestTypeRange returns the smallest INTEGER_TYPE which + is sufficient to contain values: low..high. */ + +tree +m2type_BuildSmallestTypeRange (location_t location, tree low, tree high) +{ + tree bits; + + m2assert_AssertLocation (location); + low = fold (low); + high = fold (high); + bits = fold (noBitsRequired ( + m2expr_BuildAdd (location, m2expr_BuildSub (location, high, low, FALSE), + m2expr_GetIntegerOne (location), FALSE))); + return build_m2_specific_size_type (location, INTEGER_TYPE, + TREE_INT_CST_LOW (bits), + tree_int_cst_sgn (low) < 0); +} + +/* GetTreeType returns TREE_TYPE (t). */ + +tree +m2type_GetTreeType (tree t) +{ + return TREE_TYPE (t); +} + +/* finish_build_pointer_type finish building a POINTER_TYPE node. + necessary to solve self references in procedure types. */ + +/* Code taken from tree.cc:build_pointer_type_for_mode. */ + +static tree +finish_build_pointer_type (tree t, tree to_type, enum machine_mode mode, + bool can_alias_all) +{ + TREE_TYPE (t) = to_type; + SET_TYPE_MODE (t, mode); + TYPE_REF_CAN_ALIAS_ALL (t) = can_alias_all; + TYPE_NEXT_PTR_TO (t) = TYPE_POINTER_TO (to_type); + TYPE_POINTER_TO (to_type) = t; + + /* Lay out the type. */ + /* layout_type (t); */ + layout_type (t); + + return t; +} + +/* BuildParameterDeclaration creates and returns one parameter + from, name, and, type. It appends this parameter to the internal + param_type_list. */ + +tree +m2type_BuildProcTypeParameterDeclaration (location_t location, tree type, + int isreference) +{ + m2assert_AssertLocation (location); + ASSERT_BOOL (isreference); + type = m2tree_skip_type_decl (type); + if (isreference) + type = build_reference_type (type); + + param_type_list = tree_cons (NULL_TREE, type, param_type_list); + return type; +} + +/* BuildEndFunctionType build a function type which would return a, + value. The arguments have been created by + BuildParameterDeclaration. */ + +tree +m2type_BuildEndFunctionType (tree func, tree return_type, int uses_varargs) +{ + tree last; + + if (return_type == NULL_TREE) + return_type = void_type_node; + else + return_type = m2tree_skip_type_decl (return_type); + + if (uses_varargs) + { + if (param_type_list != NULL_TREE) + { + param_type_list = nreverse (param_type_list); + last = param_type_list; + param_type_list = nreverse (param_type_list); + gcc_assert (last != void_list_node); + } + } + else if (param_type_list == NULL_TREE) + param_type_list = void_list_node; + else + { + param_type_list = nreverse (param_type_list); + last = param_type_list; + param_type_list = nreverse (param_type_list); + TREE_CHAIN (last) = void_list_node; + } + param_type_list = build_function_type (return_type, param_type_list); + + func = finish_build_pointer_type (func, param_type_list, ptr_mode, false); + TYPE_SIZE (func) = 0; + layout_type (func); + return func; +} + +/* BuildStartFunctionType creates a pointer type, necessary to + create a function type. */ + +tree +m2type_BuildStartFunctionType (location_t location ATTRIBUTE_UNUSED, + char *name ATTRIBUTE_UNUSED) +{ + tree n = make_node (POINTER_TYPE); + + m2assert_AssertLocation (location); + return n; +} + +/* InitFunctionTypeParameters resets the current function type + parameter list. */ + +void +m2type_InitFunctionTypeParameters (void) +{ + param_type_list = NULL_TREE; +} + +/* gm2_finish_decl finishes VAR, TYPE and FUNCTION declarations. */ + +static void +gm2_finish_decl (location_t location, tree decl) +{ + tree type = TREE_TYPE (decl); + int was_incomplete = (DECL_SIZE (decl) == 0); + + m2assert_AssertLocation (location); + if (TREE_CODE (decl) == VAR_DECL) + { + if (DECL_SIZE (decl) == 0 && TREE_TYPE (decl) != error_mark_node + && COMPLETE_TYPE_P (TREE_TYPE (decl))) + layout_decl (decl, 0); + + if (DECL_SIZE (decl) == 0 + /* Don't give an error if we already gave one earlier. */ + && TREE_TYPE (decl) != error_mark_node) + { + error_at (location, "storage size of %q+D isn%'t known", decl); + TREE_TYPE (decl) = error_mark_node; + } + + if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl)) + && DECL_SIZE (decl) != 0) + { + if (TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST) + m2expr_ConstantExpressionWarning (DECL_SIZE (decl)); + else + error_at (location, "storage size of %q+D isn%'t constant", decl); + } + + if (TREE_USED (type)) + TREE_USED (decl) = 1; + } + + /* Output the assembler code and/or RTL code for variables and + functions, unless the type is an undefined structure or union. If + not, it will get done when the type is completed. */ + + if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL) + { + if (DECL_FILE_SCOPE_P (decl)) + { + if (DECL_INITIAL (decl) == NULL_TREE + || DECL_INITIAL (decl) == error_mark_node) + + /* Don't output anything when a tentative file-scope definition is + seen. But at end of compilation, do output code for them. */ + DECL_DEFER_OUTPUT (decl) = 1; + rest_of_decl_compilation (decl, true, 0); + } + + if (!DECL_FILE_SCOPE_P (decl)) + { + + /* Recompute the RTL of a local array now if it used to be an + incomplete type. */ + if (was_incomplete && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl)) + { + /* If we used it already as memory, it must stay in memory. */ + TREE_ADDRESSABLE (decl) = TREE_USED (decl); + /* If it's still incomplete now, no init will save it. */ + if (DECL_SIZE (decl) == 0) + DECL_INITIAL (decl) = 0; + } + } + } + + if (TREE_CODE (decl) == TYPE_DECL) + { + if (!DECL_FILE_SCOPE_P (decl) + && variably_modified_type_p (TREE_TYPE (decl), NULL_TREE)) + m2block_pushDecl (build_stmt (location, DECL_EXPR, decl)); + + rest_of_decl_compilation (decl, DECL_FILE_SCOPE_P (decl), 0); + } +} + +/* BuildVariableArrayAndDeclare creates a variable length array. + high is the maximum legal elements (which is a runtime variable). + This creates and array index, array type and local variable. */ + +tree +m2type_BuildVariableArrayAndDeclare (location_t location, tree elementtype, + tree high, char *name, tree scope) +{ + tree indextype = build_index_type (variable_size (high)); + tree arraytype = build_array_type (elementtype, indextype); + tree id = get_identifier (name); + tree decl; + + m2assert_AssertLocation (location); + decl = build_decl (location, VAR_DECL, id, arraytype); + + DECL_EXTERNAL (decl) = FALSE; + TREE_PUBLIC (decl) = TRUE; + DECL_CONTEXT (decl) = scope; + TREE_USED (arraytype) = TRUE; + TREE_USED (decl) = TRUE; + + m2block_pushDecl (decl); + + gm2_finish_decl (location, indextype); + gm2_finish_decl (location, arraytype); + add_stmt (location, build_stmt (location, DECL_EXPR, decl)); + + return decl; +} + +static tree +build_m2_iso_word_node (location_t location, int loc) +{ + tree c; + + m2assert_AssertLocation (location); + /* Define `WORD' as specified in ISO m2 + + WORD = ARRAY [0..SizeOfWord / SizeOfLoc] OF LOC ; */ + + if (m2decl_GetBitsPerInt () == BITS_PER_UNIT) + c = m2type_GetISOLocType (); + else + c = gm2_build_array_type ( + m2type_GetISOLocType (), + m2type_BuildArrayIndexType ( + m2expr_GetIntegerZero (location), + (m2expr_BuildSub (location, + m2decl_BuildIntegerConstant ( + m2decl_GetBitsPerInt () / BITS_PER_UNIT), + m2expr_GetIntegerOne (location), FALSE))), + loc); + return c; +} + +static tree +build_m2_iso_byte_node (location_t location, int loc) +{ + tree c; + + /* Define `BYTE' as specified in ISO m2 + + BYTE = ARRAY [0..SizeOfByte / SizeOfLoc] OF LOC ; */ + + if (BITS_PER_UNIT == 8) + c = m2type_GetISOLocType (); + else + c = gm2_build_array_type ( + m2type_GetISOLocType (), + m2type_BuildArrayIndexType ( + m2expr_GetIntegerZero (location), + m2decl_BuildIntegerConstant (BITS_PER_UNIT / 8)), + loc); + return c; +} + +/* m2type_InitSystemTypes initialise loc and word derivatives. */ + +void +m2type_InitSystemTypes (location_t location, int loc) +{ + m2assert_AssertLocation (location); + + m2_iso_word_type_node = build_m2_iso_word_node (location, loc); + m2_iso_byte_type_node = build_m2_iso_byte_node (location, loc); + + m2_word16_type_node = build_m2_word16_type_node (location, loc); + m2_word32_type_node = build_m2_word32_type_node (location, loc); + m2_word64_type_node = build_m2_word64_type_node (location, loc); +} + +static tree +build_m2_integer_node (void) +{ + return m2type_GetIntegerType (); +} + +static tree +build_m2_cardinal_node (void) +{ + return m2type_GetCardinalType (); +} + +static tree +build_m2_char_node (void) +{ + tree c; + + /* Define `CHAR', to be an unsigned char. */ + + c = make_unsigned_type (CHAR_TYPE_SIZE); + layout_type (c); + return c; +} + +static tree +build_m2_short_real_node (void) +{ + tree c; + + /* Define `REAL'. */ + + c = make_node (REAL_TYPE); + TYPE_PRECISION (c) = FLOAT_TYPE_SIZE; + layout_type (c); + + return c; +} + +static tree +build_m2_real_node (void) +{ + tree c; + + /* Define `REAL'. */ + + c = make_node (REAL_TYPE); + TYPE_PRECISION (c) = DOUBLE_TYPE_SIZE; + layout_type (c); + + return c; +} + +static tree +build_m2_long_real_node (void) +{ + tree c; + + /* Define `LONGREAL'. */ + + c = make_node (REAL_TYPE); + TYPE_PRECISION (c) = LONG_DOUBLE_TYPE_SIZE; + layout_type (c); + + return c; +} + +static tree +build_m2_long_int_node (void) +{ + tree c; + + /* Define `LONGINT'. */ + + c = make_signed_type (LONG_LONG_TYPE_SIZE); + layout_type (c); + + return c; +} + +static tree +build_m2_long_card_node (void) +{ + tree c; + + /* Define `LONGCARD'. */ + + c = make_unsigned_type (LONG_LONG_TYPE_SIZE); + layout_type (c); + + return c; +} + +static tree +build_m2_short_int_node (void) +{ + tree c; + + /* Define `SHORTINT'. */ + + c = make_signed_type (SHORT_TYPE_SIZE); + layout_type (c); + + return c; +} + +static tree +build_m2_short_card_node (void) +{ + tree c; + + /* Define `SHORTCARD'. */ + + c = make_unsigned_type (SHORT_TYPE_SIZE); + layout_type (c); + + return c; +} + +static tree +build_m2_iso_loc_node (void) +{ + tree c; + + /* Define `LOC' as specified in ISO m2. */ + + c = make_node (INTEGER_TYPE); + TYPE_PRECISION (c) = BITS_PER_UNIT; + TYPE_SIZE (c) = 0; + + fixup_unsigned_type (c); + TYPE_UNSIGNED (c) = 1; + + return c; +} + +static tree +build_m2_integer8_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 8, TRUE); +} + +static tree +build_m2_integer16_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 16, TRUE); +} + +static tree +build_m2_integer32_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 32, TRUE); +} + +static tree +build_m2_integer64_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 64, TRUE); +} + +static tree +build_m2_cardinal8_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 8, FALSE); +} + +static tree +build_m2_cardinal16_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 16, FALSE); +} + +static tree +build_m2_cardinal32_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 32, FALSE); +} + +static tree +build_m2_cardinal64_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 64, FALSE); +} + +static tree +build_m2_bitset8_type_node (location_t location) +{ + m2assert_AssertLocation (location); + if (broken_set_debugging_info) + return build_m2_specific_size_type (location, INTEGER_TYPE, 8, FALSE); + else + return build_m2_specific_size_type (location, SET_TYPE, 8, FALSE); +} + +static tree +build_m2_bitset16_type_node (location_t location) +{ + m2assert_AssertLocation (location); + if (broken_set_debugging_info) + return build_m2_specific_size_type (location, INTEGER_TYPE, 16, FALSE); + else + return build_m2_specific_size_type (location, SET_TYPE, 16, FALSE); +} + +static tree +build_m2_bitset32_type_node (location_t location) +{ + m2assert_AssertLocation (location); + if (broken_set_debugging_info) + return build_m2_specific_size_type (location, INTEGER_TYPE, 32, FALSE); + else + return build_m2_specific_size_type (location, SET_TYPE, 32, FALSE); +} + +static tree +build_m2_real32_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, REAL_TYPE, 32, TRUE); +} + +static tree +build_m2_real64_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, REAL_TYPE, 64, TRUE); +} + +static tree +build_m2_real96_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, REAL_TYPE, 96, TRUE); +} + +static tree +build_m2_real128_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, REAL_TYPE, 128, TRUE); +} + +static tree +build_m2_complex_type_from (tree scalar_type) +{ + tree new_type; + + if (scalar_type == NULL) + return NULL; + if (scalar_type == float_type_node) + return complex_float_type_node; + if (scalar_type == double_type_node) + return complex_double_type_node; + if (scalar_type == long_double_type_node) + return complex_long_double_type_node; + + new_type = make_node (COMPLEX_TYPE); + TREE_TYPE (new_type) = scalar_type; + layout_type (new_type); + return new_type; +} + +static tree +build_m2_complex_type_node (void) +{ + return build_m2_complex_type_from (m2_real_type_node); +} + +static tree +build_m2_long_complex_type_node (void) +{ + return build_m2_complex_type_from (m2_long_real_type_node); +} + +static tree +build_m2_short_complex_type_node (void) +{ + return build_m2_complex_type_from (m2_short_real_type_node); +} + +static tree +build_m2_complex32_type_node (void) +{ + return build_m2_complex_type_from (m2_real32_type_node); +} + +static tree +build_m2_complex64_type_node (void) +{ + return build_m2_complex_type_from (m2_real64_type_node); +} + +static tree +build_m2_complex96_type_node (void) +{ + return build_m2_complex_type_from (m2_real96_type_node); +} + +static tree +build_m2_complex128_type_node (void) +{ + return build_m2_complex_type_from (m2_real128_type_node); +} + +static tree +build_m2_cardinal_address_type_node (location_t location) +{ + tree size = size_in_bytes (ptr_type_node); + int bits = TREE_INT_CST_LOW (size) * BITS_PER_UNIT; + + return build_m2_specific_size_type (location, INTEGER_TYPE, bits, FALSE); +} + +/* InitBaseTypes create the Modula-2 base types. */ + +void +m2type_InitBaseTypes (location_t location) +{ + m2assert_AssertLocation (location); + m2block_init (); + + ptr_type_node = build_pointer_type (void_type_node); + + proc_type_node + = build_pointer_type (build_function_type (void_type_node, NULL_TREE)); + + bitset_type_node = build_bitset_type (location); + m2_char_type_node = build_m2_char_node (); + m2_integer_type_node = build_m2_integer_node (); + m2_cardinal_type_node = build_m2_cardinal_node (); + m2_short_real_type_node = build_m2_short_real_node (); + m2_real_type_node = build_m2_real_node (); + m2_long_real_type_node = build_m2_long_real_node (); + m2_long_int_type_node = build_m2_long_int_node (); + m2_long_card_type_node = build_m2_long_card_node (); + m2_short_int_type_node = build_m2_short_int_node (); + m2_short_card_type_node = build_m2_short_card_node (); + m2_z_type_node = build_m2_long_int_node (); + m2_integer8_type_node = build_m2_integer8_type_node (location); + m2_integer16_type_node = build_m2_integer16_type_node (location); + m2_integer32_type_node = build_m2_integer32_type_node (location); + m2_integer64_type_node = build_m2_integer64_type_node (location); + m2_cardinal8_type_node = build_m2_cardinal8_type_node (location); + m2_cardinal16_type_node = build_m2_cardinal16_type_node (location); + m2_cardinal32_type_node = build_m2_cardinal32_type_node (location); + m2_cardinal64_type_node = build_m2_cardinal64_type_node (location); + m2_bitset8_type_node = build_m2_bitset8_type_node (location); + m2_bitset16_type_node = build_m2_bitset16_type_node (location); + m2_bitset32_type_node = build_m2_bitset32_type_node (location); + m2_real32_type_node = build_m2_real32_type_node (location); + m2_real64_type_node = build_m2_real64_type_node (location); + m2_real96_type_node = build_m2_real96_type_node (location); + m2_real128_type_node = build_m2_real128_type_node (location); + m2_complex_type_node = build_m2_complex_type_node (); + m2_long_complex_type_node = build_m2_long_complex_type_node (); + m2_short_complex_type_node = build_m2_short_complex_type_node (); + m2_c_type_node = build_m2_long_complex_type_node (); + m2_complex32_type_node = build_m2_complex32_type_node (); + m2_complex64_type_node = build_m2_complex64_type_node (); + m2_complex96_type_node = build_m2_complex96_type_node (); + m2_complex128_type_node = build_m2_complex128_type_node (); + m2_iso_loc_type_node = build_m2_iso_loc_node (); + + m2_cardinal_address_type_node + = build_m2_cardinal_address_type_node (location); + + m2_packed_boolean_type_node = build_nonstandard_integer_type (1, TRUE); + + m2builtins_init (location); + m2except_InitExceptions (location); + m2expr_init (location); +} + +/* BuildStartType given a, type, with a, name, return a GCC + declaration of this type. TYPE name = foo ; + + the type, foo, maybe a partially created type (which has + yet to be 'gm2_finish_decl'ed). */ + +tree +m2type_BuildStartType (location_t location, char *name, tree type) +{ + tree id = get_identifier (name); + tree decl, tem; + + m2assert_AssertLocation (location); + ASSERT (m2tree_is_type (type), type); + type = m2tree_skip_type_decl (type); + decl = build_decl (location, TYPE_DECL, id, type); + + tem = m2block_pushDecl (decl); + ASSERT (tem == decl, decl); + ASSERT (m2tree_is_type (decl), decl); + + return tem; +} + +/* BuildEndType finish declaring, type, and return, type. */ + +tree +m2type_BuildEndType (location_t location, tree type) +{ + m2assert_AssertLocation (location); + layout_type (TREE_TYPE (type)); + gm2_finish_decl (location, type); + return type; +} + +/* DeclareKnownType given a, type, with a, name, return a GCC + declaration of this type. TYPE name = foo ; */ + +tree +m2type_DeclareKnownType (location_t location, char *name, tree type) +{ + m2assert_AssertLocation (location); + return m2type_BuildEndType (location, + m2type_BuildStartType (location, name, type)); +} + +/* GetDefaultType given a, type, with a, name, return a GCC + declaration of this type. Checks to see whether the type name has + already been declared as a default type and if so it returns this + declaration. Otherwise it declares the type. In Modula-2 this is + equivalent to: + + TYPE name = type ; + + We need this function during gm2 initialization as it allows + gm2 to access default types before creating Modula-2 types. */ + +tree +m2type_GetDefaultType (location_t location, char *name, tree type) +{ + tree id = maybe_get_identifier (name); + + m2assert_AssertLocation (location); + if (id == NULL) + { + tree prev = type; + tree t; + + while (prev != NULL) + { + if (TYPE_NAME (prev) == NULL) + TYPE_NAME (prev) = get_identifier (name); + prev = TREE_TYPE (prev); + } + t = m2type_DeclareKnownType (location, name, type); + return t; + } + else + return id; +} + +tree +do_min_real (tree type) +{ + REAL_VALUE_TYPE r; + char buf[128]; + enum machine_mode mode = TYPE_MODE (type); + + get_max_float (REAL_MODE_FORMAT (mode), buf, sizeof (buf), false); + real_from_string (&r, buf); + return build1 (NEGATE_EXPR, type, build_real (type, r)); +} + +/* GetMinFrom given a, type, return a constant representing the + minimum legal value. */ + +tree +m2type_GetMinFrom (location_t location, tree type) +{ + m2assert_AssertLocation (location); + + if (type == m2_real_type_node || type == m2type_GetRealType ()) + return do_min_real (type); + if (type == m2_long_real_type_node || type == m2type_GetLongRealType ()) + return do_min_real (type); + if (type == m2_short_real_type_node || type == m2type_GetShortRealType ()) + return do_min_real (type); + if (type == ptr_type_node) + return m2expr_GetPointerZero (location); + + return TYPE_MIN_VALUE (m2tree_skip_type_decl (type)); +} + +tree +do_max_real (tree type) +{ + REAL_VALUE_TYPE r; + char buf[128]; + enum machine_mode mode = TYPE_MODE (type); + + get_max_float (REAL_MODE_FORMAT (mode), buf, sizeof (buf), false); + real_from_string (&r, buf); + return build_real (type, r); +} + +/* GetMaxFrom given a, type, return a constant representing the + maximum legal value. */ + +tree +m2type_GetMaxFrom (location_t location, tree type) +{ + m2assert_AssertLocation (location); + + if (type == m2_real_type_node || type == m2type_GetRealType ()) + return do_max_real (type); + if (type == m2_long_real_type_node || type == m2type_GetLongRealType ()) + return do_max_real (type); + if (type == m2_short_real_type_node || type == m2type_GetShortRealType ()) + return do_max_real (type); + if (type == ptr_type_node) + return fold (m2expr_BuildSub (location, m2expr_GetPointerZero (location), + m2expr_GetPointerOne (location), FALSE)); + + return TYPE_MAX_VALUE (m2tree_skip_type_decl (type)); +} + +/* BuildTypeDeclaration adds the, type, to the current statement + list. */ + +void +m2type_BuildTypeDeclaration (location_t location, tree type) +{ + enum tree_code code = TREE_CODE (type); + + m2assert_AssertLocation (location); + if (code == TYPE_DECL || code == RECORD_TYPE || code == POINTER_TYPE) + { + m2block_pushDecl (build_decl (location, TYPE_DECL, NULL, type)); + } + else if (code == VAR_DECL) + { + m2type_BuildTypeDeclaration (location, TREE_TYPE (type)); + m2block_pushDecl ( + build_stmt (location, DECL_EXPR, + type)); /* Is this safe? --fixme--. */ + } +} + +/* Begin compiling the definition of an enumeration type. NAME is + its name (or null if anonymous). Returns the type object, as yet + incomplete. Also records info about it so that build_enumerator may + be used to declare the individual values as they are read. */ + +static tree +gm2_start_enum (location_t location, tree name, int ispacked) +{ + tree enumtype = make_node (ENUMERAL_TYPE); + + m2assert_AssertLocation (location); + if (TYPE_VALUES (enumtype) != 0) + { + /* This enum is a named one that has been declared already. */ + error_at (location, "redeclaration of enum %qs", + IDENTIFIER_POINTER (name)); + + /* Completely replace its old definition. The old enumerators remain + defined, however. */ + TYPE_VALUES (enumtype) = 0; + } + + TYPE_PACKED (enumtype) = ispacked; + TREE_TYPE (enumtype) = m2type_GetIntegerType (); + + /* This is required as rest_of_type_compilation will use this field + when called from gm2_finish_enum. + + Create a fake NULL-named TYPE_DECL node whose TREE_TYPE will be the + tagged type we just added to the current scope. This fake NULL-named + TYPE_DECL node helps dwarfout.cc to know when it needs to output a + representation of a tagged type, and it also gives us a convenient + place to record the "scope start" address for the tagged type. */ + + TYPE_STUB_DECL (enumtype) = m2block_pushDecl ( + build_decl (location, TYPE_DECL, NULL_TREE, enumtype)); + + return enumtype; +} + +/* After processing and defining all the values of an enumeration + type, install their decls in the enumeration type and finish it off. + ENUMTYPE is the type object, VALUES a list of decl-value pairs, and + ATTRIBUTES are the specified attributes. Returns ENUMTYPE. */ + +static tree +gm2_finish_enum (location_t location, tree enumtype, tree values) +{ + tree pair, tem; + tree minnode = 0, maxnode = 0; + int precision; + signop sign; + + /* Calculate the maximum value of any enumerator in this type. */ + + if (values == error_mark_node) + minnode = maxnode = integer_zero_node; + else + { + minnode = maxnode = TREE_VALUE (values); + for (pair = TREE_CHAIN (values); pair; pair = TREE_CHAIN (pair)) + { + tree value = TREE_VALUE (pair); + if (tree_int_cst_lt (maxnode, value)) + maxnode = value; + if (tree_int_cst_lt (value, minnode)) + minnode = value; + } + } + + /* Construct the final type of this enumeration. It is the same as + one of the integral types the narrowest one that fits, except that + normally we only go as narrow as int and signed iff any of the + values are negative. */ + sign = (tree_int_cst_sgn (minnode) >= 0) ? UNSIGNED : SIGNED; + precision = MAX (tree_int_cst_min_precision (minnode, sign), + tree_int_cst_min_precision (maxnode, sign)); + + if (precision > TYPE_PRECISION (integer_type_node)) + { + warning (0, "enumeration values exceed range of integer"); + tem = long_long_integer_type_node; + } + else if (TYPE_PACKED (enumtype)) + tem = m2type_BuildSmallestTypeRange (location, minnode, maxnode); + else + tem = sign == UNSIGNED ? unsigned_type_node : integer_type_node; + + TYPE_MIN_VALUE (enumtype) = TYPE_MIN_VALUE (tem); + TYPE_MAX_VALUE (enumtype) = TYPE_MAX_VALUE (tem); + TYPE_UNSIGNED (enumtype) = TYPE_UNSIGNED (tem); + TYPE_SIZE (enumtype) = 0; + + /* If the precision of the type was specific with an attribute and it + was too small, give an error. Otherwise, use it. */ + if (TYPE_PRECISION (enumtype)) + { + if (precision > TYPE_PRECISION (enumtype)) + error ("specified mode too small for enumerated values"); + } + else + TYPE_PRECISION (enumtype) = TYPE_PRECISION (tem); + + layout_type (enumtype); + + if (values != error_mark_node) + { + + /* Change the type of the enumerators to be the enum type. We need + to do this irrespective of the size of the enum, for proper type + checking. Replace the DECL_INITIALs of the enumerators, and the + value slots of the list, with copies that have the enum type; they + cannot be modified in place because they may be shared (e.g. + integer_zero_node) Finally, change the purpose slots to point to the + names of the decls. */ + for (pair = values; pair; pair = TREE_CHAIN (pair)) + { + tree enu = TREE_PURPOSE (pair); + tree ini = DECL_INITIAL (enu); + + TREE_TYPE (enu) = enumtype; + + if (TREE_TYPE (ini) != integer_type_node) + ini = convert (enumtype, ini); + + DECL_INITIAL (enu) = ini; + TREE_PURPOSE (pair) = DECL_NAME (enu); + TREE_VALUE (pair) = ini; + } + + TYPE_VALUES (enumtype) = values; + } + + /* Fix up all variant types of this enum type. */ + for (tem = TYPE_MAIN_VARIANT (enumtype); tem; tem = TYPE_NEXT_VARIANT (tem)) + { + if (tem == enumtype) + continue; + TYPE_VALUES (tem) = TYPE_VALUES (enumtype); + TYPE_MIN_VALUE (tem) = TYPE_MIN_VALUE (enumtype); + TYPE_MAX_VALUE (tem) = TYPE_MAX_VALUE (enumtype); + TYPE_SIZE (tem) = TYPE_SIZE (enumtype); + TYPE_SIZE_UNIT (tem) = TYPE_SIZE_UNIT (enumtype); + SET_TYPE_MODE (tem, TYPE_MODE (enumtype)); + TYPE_PRECISION (tem) = TYPE_PRECISION (enumtype); + SET_TYPE_ALIGN (tem, TYPE_ALIGN (enumtype)); + TYPE_USER_ALIGN (tem) = TYPE_USER_ALIGN (enumtype); + TYPE_UNSIGNED (tem) = TYPE_UNSIGNED (enumtype); + TYPE_LANG_SPECIFIC (tem) = TYPE_LANG_SPECIFIC (enumtype); + } + + /* Finish debugging output for this type. */ + rest_of_type_compilation (enumtype, m2block_toplevel ()); + return enumtype; +} + +/* BuildStartEnumeration create an enumerated type in gcc. */ + +tree +m2type_BuildStartEnumeration (location_t location, char *name, int ispacked) +{ + tree id; + + m2assert_AssertLocation (location); + if ((name == NULL) || (strcmp (name, "") == 0)) + id = NULL_TREE; + else + id = get_identifier (name); + + return gm2_start_enum (location, id, ispacked); +} + +/* BuildEndEnumeration finish building the enumeration, it uses the + enum list, enumvalues, and returns a enumeration type tree. */ + +tree +m2type_BuildEndEnumeration (location_t location, tree enumtype, + tree enumvalues) +{ + tree finished ATTRIBUTE_UNUSED + = gm2_finish_enum (location, enumtype, enumvalues); + return enumtype; +} + +/* Build and install a CONST_DECL for one value of the current + enumeration type (one that was begun with start_enum). Return a + tree-list containing the CONST_DECL and its value. Assignment of + sequential values by default is handled here. */ + +static tree +gm2_build_enumerator (location_t location, tree name, tree value) +{ + tree decl, type; + + m2assert_AssertLocation (location); + /* Remove no-op casts from the value. */ + if (value) + STRIP_TYPE_NOPS (value); + + /* Now create a declaration for the enum value name. */ + + type = TREE_TYPE (value); + + decl = build_decl (location, CONST_DECL, name, type); + DECL_INITIAL (decl) = convert (type, value); + m2block_pushDecl (decl); + + return tree_cons (decl, value, NULL_TREE); +} + +/* BuildEnumerator build an enumerator and add it to the, + enumvalues, list. It returns a copy of the value. */ + +tree +m2type_BuildEnumerator (location_t location, char *name, tree value, + tree *enumvalues) +{ + tree id = get_identifier (name); + tree copy_of_value = copy_node (value); + tree gccenum = gm2_build_enumerator (location, id, copy_of_value); + + m2assert_AssertLocation (location); + /* Choose copy_of_value for enum value. */ + *enumvalues = chainon (gccenum, *enumvalues); + return copy_of_value; +} + +/* BuildPointerType returns a type which is a pointer to, totype. */ + +tree +m2type_BuildPointerType (tree totype) +{ + return build_pointer_type (m2tree_skip_type_decl (totype)); +} + +/* BuildConstPointerType returns a type which is a const pointer + to, totype. */ + +tree +m2type_BuildConstPointerType (tree totype) +{ + tree t = build_pointer_type (m2tree_skip_type_decl (totype)); + TYPE_READONLY (t) = TRUE; + return t; +} + +/* BuildSetType creates a SET OF [lowval..highval]. */ + +tree +m2type_BuildSetType (location_t location, char *name, tree type, tree lowval, + tree highval, int ispacked) +{ + tree range = build_range_type (m2tree_skip_type_decl (type), + m2expr_FoldAndStrip (lowval), + m2expr_FoldAndStrip (highval)); + + TYPE_PACKED (range) = ispacked; + m2assert_AssertLocation (location); + return m2type_BuildSetTypeFromSubrange (location, name, range, + m2expr_FoldAndStrip (lowval), + m2expr_FoldAndStrip (highval), + ispacked); +} + +/* push_constructor returns a new compound constructor frame. */ + +static struct struct_constructor * +push_constructor (void) +{ + struct struct_constructor *p = ggc_alloc (); + + p->level = top_constructor; + top_constructor = p; + return p; +} + +/* pop_constructor throws away the top constructor frame on the + stack. */ + +static void +pop_constructor (struct struct_constructor *p) +{ + ASSERT_CONDITION (p + == top_constructor); /* p should be the top_constructor. */ + top_constructor = top_constructor->level; +} + +/* BuildStartSetConstructor starts to create a set constant. + Remember that type is really a record type. */ + +void * +m2type_BuildStartSetConstructor (tree type) +{ + struct struct_constructor *p = push_constructor (); + + type = m2tree_skip_type_decl (type); + layout_type (type); + p->constructor_type = type; + p->constructor_fields = TYPE_FIELDS (type); + p->constructor_element_list = NULL_TREE; + vec_alloc (p->constructor_elements, 1); + return (void *)p; +} + +/* BuildSetConstructorElement adds, value, to the + constructor_element_list. */ + +void +m2type_BuildSetConstructorElement (void *p, tree value) +{ + struct struct_constructor *c = (struct struct_constructor *)p; + + if (value == NULL_TREE) + { + internal_error ("set type cannot be initialized with a %qs", + "NULL_TREE"); + return; + } + + if (c->constructor_fields == NULL) + { + internal_error ("set type does not take another integer value"); + return; + } + + c->constructor_element_list + = tree_cons (c->constructor_fields, value, c->constructor_element_list); + c->constructor_fields = TREE_CHAIN (c->constructor_fields); +} + +/* BuildEndSetConstructor finishes building a set constant. */ + +tree +m2type_BuildEndSetConstructor (void *p) +{ + tree constructor; + tree link; + struct struct_constructor *c = (struct struct_constructor *)p; + + for (link = c->constructor_element_list; link; link = TREE_CHAIN (link)) + { + tree field = TREE_PURPOSE (link); + DECL_SIZE (field) = bitsize_int (SET_WORD_SIZE); + DECL_BIT_FIELD (field) = 1; + } + + constructor = build_constructor_from_list ( + c->constructor_type, nreverse (c->constructor_element_list)); + TREE_CONSTANT (constructor) = 1; + TREE_STATIC (constructor) = 1; + + pop_constructor (c); + + return constructor; +} + +/* BuildStartRecordConstructor initializes a record compound + constructor frame. */ + +void * +m2type_BuildStartRecordConstructor (tree type) +{ + struct struct_constructor *p = push_constructor (); + + type = m2tree_skip_type_decl (type); + layout_type (type); + p->constructor_type = type; + p->constructor_fields = TYPE_FIELDS (type); + p->constructor_element_list = NULL_TREE; + vec_alloc (p->constructor_elements, 1); + return (void *)p; +} + +/* BuildEndRecordConstructor returns a tree containing the record + compound literal. */ + +tree +m2type_BuildEndRecordConstructor (void *p) +{ + struct struct_constructor *c = (struct struct_constructor *)p; + tree constructor = build_constructor_from_list ( + c->constructor_type, nreverse (c->constructor_element_list)); + TREE_CONSTANT (constructor) = 1; + TREE_STATIC (constructor) = 1; + + pop_constructor (c); + + return constructor; +} + +/* BuildRecordConstructorElement adds, value, to the + constructor_element_list. */ + +void +m2type_BuildRecordConstructorElement (void *p, tree value) +{ + m2type_BuildSetConstructorElement (p, value); +} + +/* BuildStartArrayConstructor initializes an array compound + constructor frame. */ + +void * +m2type_BuildStartArrayConstructor (tree type) +{ + struct struct_constructor *p = push_constructor (); + + type = m2tree_skip_type_decl (type); + layout_type (type); + p->constructor_type = type; + p->constructor_fields = TREE_TYPE (type); + p->constructor_element_list = NULL_TREE; + vec_alloc (p->constructor_elements, 1); + return (void *)p; +} + +/* BuildEndArrayConstructor returns a tree containing the array + compound literal. */ + +tree +m2type_BuildEndArrayConstructor (void *p) +{ + struct struct_constructor *c = (struct struct_constructor *)p; + tree constructor; + + constructor + = build_constructor (c->constructor_type, c->constructor_elements); + TREE_CONSTANT (constructor) = TRUE; + TREE_STATIC (constructor) = TRUE; + + pop_constructor (c); + + return constructor; +} + +/* BuildArrayConstructorElement adds, value, to the + constructor_element_list. */ + +void +m2type_BuildArrayConstructorElement (void *p, tree value, tree indice) +{ + struct struct_constructor *c = (struct struct_constructor *)p; + constructor_elt celt; + + if (value == NULL_TREE) + { + internal_error ("array cannot be initialized with a %qs", "NULL_TREE"); + return; + } + + if (c->constructor_fields == NULL_TREE) + { + internal_error ("array type must be initialized"); + return; + } + + if (c->constructor_fields != TREE_TYPE (value)) + { + internal_error ( + "array element value must be the same type as its declaration"); + return; + } + + celt.index = indice; + celt.value = value; + vec_safe_push (c->constructor_elements, celt); +} + +/* BuildArrayStringConstructor creates an array constructor for, + arrayType, consisting of the character elements defined by, str, + of, length, characters. */ + +tree +m2type_BuildArrayStringConstructor (location_t location, tree arrayType, + tree str, tree length) +{ + tree n; + tree val; + int i = 0; + const char *p = TREE_STRING_POINTER (str); + tree type = m2tree_skip_type_decl (TREE_TYPE (arrayType)); + struct struct_constructor *c + = (struct struct_constructor *)m2type_BuildStartArrayConstructor ( + arrayType); + char nul[1]; + int len = strlen (p); + + nul[0] = (char)0; + + m2assert_AssertLocation (location); + n = m2expr_GetIntegerZero (location); + while (m2expr_CompareTrees (n, length) < 0) + { + if (i < len) + val = m2convert_BuildConvert ( + location, type, m2type_BuildCharConstant (location, &p[i]), FALSE); + else + val = m2type_BuildCharConstant (location, &nul[0]); + m2type_BuildArrayConstructorElement (c, val, n); + i += 1; + n = m2expr_BuildAdd (location, n, m2expr_GetIntegerOne (location), + FALSE); + } + return m2type_BuildEndArrayConstructor (c); +} + +/* BuildSubrangeType creates a subrange of, type, with, lowval, + highval. */ + +tree +m2type_BuildSubrangeType (location_t location, char *name, tree type, + tree lowval, tree highval) +{ + tree range_type; + + m2assert_AssertLocation (location); + type = m2tree_skip_type_decl (type); + + lowval = m2expr_FoldAndStrip (lowval); + highval = m2expr_FoldAndStrip (highval); + + if (m2expr_TreeOverflow (lowval)) + error ("low bound for the subrange has overflowed"); + if (m2expr_TreeOverflow (highval)) + error ("high bound for the subrange has overflowed"); + + /* First build a type with the base range. */ + range_type = build_range_type (type, TYPE_MIN_VALUE (type), + TYPE_MAX_VALUE (type)); + + TYPE_UNSIGNED (range_type) = TYPE_UNSIGNED (type); +#if 0 + /* Then set the actual range. */ + SET_TYPE_RM_MIN_VALUE (range_type, lowval); + SET_TYPE_RM_MAX_VALUE (range_type, highval); +#endif + + if ((name != NULL) && (strcmp (name, "") != 0)) + { + /* Declared as TYPE foo = [x..y]; */ + range_type = m2type_DeclareKnownType (location, name, range_type); + layout_type (m2tree_skip_type_decl (range_type)); + } + + return range_type; +} + +/* BuildCharConstantChar creates a character constant given a character, ch. */ + +tree +m2type_BuildCharConstantChar (location_t location, char ch) +{ + tree id = build_int_cst (char_type_node, (int) ch); + id = m2convert_BuildConvert (location, m2type_GetM2CharType (), id, FALSE); + return m2block_RememberConstant (id); +} + +/* BuildCharConstant creates a character constant given a, string. */ + +tree +m2type_BuildCharConstant (location_t location, const char *string) +{ + return m2type_BuildCharConstantChar (location, string[0]); +} + +/* RealToTree convert a real number into a Tree. */ + +tree +m2type_RealToTree (char *name) +{ + return build_real ( + m2type_GetLongRealType (), + REAL_VALUE_ATOF (name, TYPE_MODE (m2type_GetLongRealType ()))); +} + +/* gm2_start_struct start to create a struct. */ + +static tree +gm2_start_struct (location_t location, enum tree_code code, char *name) +{ + tree s = make_node (code); + tree id; + + m2assert_AssertLocation (location); + if ((name == NULL) || (strcmp (name, "") == 0)) + id = NULL_TREE; + else + id = get_identifier (name); + + TYPE_PACKED (s) = FALSE; /* This maybe set TRUE later if necessary. */ + + m2block_pushDecl (build_decl (location, TYPE_DECL, id, s)); + return s; +} + +/* BuildStartRecord return a RECORD tree. */ + +tree +m2type_BuildStartRecord (location_t location, char *name) +{ + m2assert_AssertLocation (location); + return gm2_start_struct (location, RECORD_TYPE, name); +} + +/* BuildStartUnion return a union tree. */ + +tree +m2type_BuildStartUnion (location_t location, char *name) +{ + m2assert_AssertLocation (location); + return gm2_start_struct (location, UNION_TYPE, name); +} + +/* m2type_BuildStartVarient builds a varient record. It creates a + record field which has a, name, and whose type is a union. */ + +tree +m2type_BuildStartVarient (location_t location, char *name) +{ + tree varient = m2type_BuildStartUnion (location, name); + tree field = m2type_BuildStartFieldRecord (location, name, varient); + m2assert_AssertLocation (location); + return field; +} + +/* m2type_BuildEndVarient finish the varientField by calling + decl_finish and also finish the type of varientField (which is a + union). */ + +tree +m2type_BuildEndVarient (location_t location, tree varientField, + tree varientList, int isPacked) +{ + tree varient = TREE_TYPE (varientField); + m2assert_AssertLocation (location); + varient = m2type_BuildEndRecord (location, varient, varientList, isPacked); + gm2_finish_decl (location, varientField); + return varientField; +} + +/* m2type_BuildStartFieldVarient builds a field varient record. It + creates a record field which has a, name, and whose type is a + record. */ + +tree +m2type_BuildStartFieldVarient (location_t location, char *name) +{ + tree record = m2type_BuildStartRecord (location, name); + tree field = m2type_BuildStartFieldRecord (location, name, record); + m2assert_AssertLocation (location); + return field; +} + +/* BuildEndRecord a heavily pruned finish_struct from c-decl.cc. It + sets the context for each field to, t, propagates isPacked + throughout the fields in the structure. */ + +tree +m2type_BuildEndRecord (location_t location, tree record, tree fieldlist, + int isPacked) +{ + tree x, d; + + m2assert_AssertLocation (location); + + /* If this type was previously laid out as a forward reference, make + sure we lay it out again. */ + + TYPE_SIZE (record) = 0; + + /* Install struct as DECL_CONTEXT of each field decl. Also process + specified field sizes, found in the DECL_INITIAL, storing 0 there + after the type has been changed to precision equal to its width, + rather than the precision of the specified standard type. (Correct + layout requires the original type to have been preserved until now). */ + + for (x = fieldlist; x; x = TREE_CHAIN (x)) + { + DECL_CONTEXT (x) = record; + + if (TYPE_PACKED (record) && TYPE_ALIGN (TREE_TYPE (x)) > BITS_PER_UNIT) + DECL_PACKED (x) = 1; + + if (isPacked) + { + DECL_PACKED (x) = 1; + DECL_BIT_FIELD (x) = 1; + } + } + + /* Now we have the nearly final fieldlist. Record it, then lay out + the structure or union (including the fields). */ + + TYPE_FIELDS (record) = fieldlist; + layout_type (record); + + /* Now we have the truly final field list. Store it in this type and + in the variants. */ + + for (x = TYPE_MAIN_VARIANT (record); x; x = TYPE_NEXT_VARIANT (x)) + { + TYPE_FIELDS (x) = TYPE_FIELDS (record); + TYPE_LANG_SPECIFIC (x) = TYPE_LANG_SPECIFIC (record); + SET_TYPE_ALIGN (x, TYPE_ALIGN (record)); + TYPE_USER_ALIGN (x) = TYPE_USER_ALIGN (record); + } + + d = build_decl (location, TYPE_DECL, NULL, record); + TYPE_STUB_DECL (record) = d; + + /* Finish debugging output for this type. This must be done after we have + called build_decl. */ + rest_of_type_compilation (record, m2block_toplevel ()); + + return record; +} + +/* m2type_BuildEndFieldVarient finish the varientField by calling + decl_finish and also finish the type of varientField (which is a + record). */ + +tree +m2type_BuildEndFieldVarient (location_t location, tree varientField, + tree varientList, int isPacked) +{ + tree record = TREE_TYPE (varientField); + + m2assert_AssertLocation (location); + record = m2type_BuildEndRecord (location, record, varientList, isPacked); + gm2_finish_decl (location, varientField); + return varientField; +} + +/* m2type_BuildStartFieldRecord starts building a field record. It + returns the field which must be completed by calling + gm2_finish_decl. */ + +tree +m2type_BuildStartFieldRecord (location_t location, char *name, tree type) +{ + tree field, declarator; + + m2assert_AssertLocation (location); + if ((name == NULL) || (strcmp (name, "") == 0)) + declarator = NULL_TREE; + else + declarator = get_identifier (name); + + field = build_decl (location, FIELD_DECL, declarator, + m2tree_skip_type_decl (type)); + return field; +} + +/* Build a record field with name (name maybe NULL), returning the + new field declaration, FIELD_DECL. + + This is done during the parsing of the struct declaration. The + FIELD_DECL nodes are chained together and the lot of them are + ultimately passed to `build_struct' to make the RECORD_TYPE node. */ + +tree +m2type_BuildFieldRecord (location_t location, char *name, tree type) +{ + tree field = m2type_BuildStartFieldRecord (location, name, type); + + m2assert_AssertLocation (location); + gm2_finish_decl (location, field); + return field; +} + +/* ChainOn interface so that Modula-2 can also create chains of + declarations. */ + +tree +m2type_ChainOn (tree t1, tree t2) +{ + return chainon (t1, t2); +} + +/* ChainOnParamValue adds a list node {{name, str}, value} into the + tree list. */ + +tree +m2type_ChainOnParamValue (tree list, tree name, tree str, tree value) +{ + return chainon (list, build_tree_list (build_tree_list (name, str), value)); +} + +/* AddStringToTreeList adds, string, to list. */ + +tree +m2type_AddStringToTreeList (tree list, tree string) +{ + return tree_cons (NULL_TREE, string, list); +} + +/* SetAlignment sets the alignment of a, node, to, align. It + duplicates the, node, and sets the alignment to prevent alignment + effecting behaviour elsewhere. */ + +tree +m2type_SetAlignment (tree node, tree align) +{ + tree type = NULL_TREE; + tree decl = NULL_TREE; + int is_type = FALSE; + int i; + + if (DECL_P (node)) + { + decl = node; + is_type = (TREE_CODE (node) == TYPE_DECL); + type = TREE_TYPE (decl); + } + else if (TYPE_P (node)) + { + is_type = 1; + type = node; + } + + if (TREE_CODE (align) != INTEGER_CST) + error ("requested alignment is not a constant"); + else if ((i = tree_log2 (align)) == -1) + error ("requested alignment is not a power of 2"); + else if (i > HOST_BITS_PER_INT - 2) + error ("requested alignment is too large"); + else if (is_type) + { + + /* If we have a TYPE_DECL, then copy the type, so that we don't + accidentally modify a builtin type. See pushdecl. */ + if (decl && TREE_TYPE (decl) != error_mark_node + && DECL_ORIGINAL_TYPE (decl) == NULL_TREE) + { + tree tt = TREE_TYPE (decl); + type = build_variant_type_copy (type); + DECL_ORIGINAL_TYPE (decl) = tt; + TYPE_NAME (type) = decl; + TREE_USED (type) = TREE_USED (decl); + TREE_TYPE (decl) = type; + } + + SET_TYPE_ALIGN (type, (1 << i) * BITS_PER_UNIT); + TYPE_USER_ALIGN (type) = 1; + + if (decl) + { + SET_DECL_ALIGN (decl, (1 << i) * BITS_PER_UNIT); + DECL_USER_ALIGN (decl) = 1; + } + } + else if (TREE_CODE (decl) != VAR_DECL && TREE_CODE (decl) != FIELD_DECL) + error ("alignment may not be specified for %qD", decl); + else + { + SET_DECL_ALIGN (decl, (1 << i) * BITS_PER_UNIT); + DECL_USER_ALIGN (decl) = 1; + } + return node; +} + +/* SetDeclPacked sets the packed bit in decl TREE, node. It + returns the node. */ + +tree +m2type_SetDeclPacked (tree node) +{ + DECL_PACKED (node) = 1; + return node; +} + +/* SetTypePacked sets the packed bit in type TREE, node. It + returns the node. */ + +tree +m2type_SetTypePacked (tree node) +{ + TYPE_PACKED (node) = 1; + return node; +} + +/* SetRecordFieldOffset returns field after the byteOffset and + bitOffset has been applied to it. */ + +tree +m2type_SetRecordFieldOffset (tree field, tree byteOffset, tree bitOffset, + tree fieldtype, tree nbits) +{ + DECL_FIELD_OFFSET (field) = byteOffset; + DECL_FIELD_BIT_OFFSET (field) = bitOffset; + TREE_TYPE (field) = m2tree_skip_type_decl (fieldtype); + DECL_SIZE (field) = bitsize_int (TREE_INT_CST_LOW (nbits)); + return field; +} + +/* BuildPackedFieldRecord builds a packed field record of, name, + and, fieldtype. */ + +tree +m2type_BuildPackedFieldRecord (location_t location, char *name, tree fieldtype) +{ + m2assert_AssertLocation (location); + return m2type_BuildFieldRecord (location, name, fieldtype); +} + +/* BuildNumberOfArrayElements returns the number of elements in an + arrayType. */ + +tree +m2type_BuildNumberOfArrayElements (location_t location, tree arrayType) +{ + tree index = TYPE_DOMAIN (arrayType); + tree high = TYPE_MAX_VALUE (index); + tree low = TYPE_MIN_VALUE (index); + tree elements = m2expr_BuildAdd ( + location, m2expr_BuildSub (location, high, low, FALSE), + m2expr_GetIntegerOne (location), FALSE); + m2assert_AssertLocation (location); + return elements; +} + +/* AddStatement maps onto add_stmt. */ + +void +m2type_AddStatement (location_t location, tree t) +{ + if (t != NULL_TREE) + add_stmt (location, t); +} + +/* MarkFunctionReferenced marks a function as referenced. */ + +void +m2type_MarkFunctionReferenced (tree f) +{ + if (f != NULL_TREE) + if (TREE_CODE (f) == FUNCTION_DECL) + mark_decl_referenced (f); +} + +/* GarbageCollect force gcc to garbage collect. */ + +void +m2type_GarbageCollect (void) +{ + ggc_collect (); +} + +/* gm2_type_for_size return an integer type with BITS bits of + precision, that is unsigned if UNSIGNEDP is nonzero, otherwise + signed. */ + +tree +m2type_gm2_type_for_size (unsigned int bits, int unsignedp) +{ + if (bits == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + + if (bits == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + + if (bits == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + + if (bits == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + + if (bits == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); + + if (bits <= TYPE_PRECISION (intQI_type_node)) + return unsignedp ? unsigned_intQI_type_node : intQI_type_node; + + if (bits <= TYPE_PRECISION (intHI_type_node)) + return unsignedp ? unsigned_intHI_type_node : intHI_type_node; + + if (bits <= TYPE_PRECISION (intSI_type_node)) + return unsignedp ? unsigned_intSI_type_node : intSI_type_node; + + if (bits <= TYPE_PRECISION (intDI_type_node)) + return unsignedp ? unsigned_intDI_type_node : intDI_type_node; + + return 0; +} + +/* gm2_unsigned_type return an unsigned type the same as TYPE in + other respects. */ + +tree +m2type_gm2_unsigned_type (tree type) +{ + tree type1 = TYPE_MAIN_VARIANT (type); + if (type1 == signed_char_type_node || type1 == char_type_node) + return unsigned_char_type_node; + if (type1 == integer_type_node) + return unsigned_type_node; + if (type1 == short_integer_type_node) + return short_unsigned_type_node; + if (type1 == long_integer_type_node) + return long_unsigned_type_node; + if (type1 == long_long_integer_type_node) + return long_long_unsigned_type_node; + +#if HOST_BITS_PER_WIDE_INT >= 64 + if (type1 == intTI_type_node) + return unsigned_intTI_type_node; +#endif + if (type1 == intDI_type_node) + return unsigned_intDI_type_node; + if (type1 == intSI_type_node) + return unsigned_intSI_type_node; + if (type1 == intHI_type_node) + return unsigned_intHI_type_node; + if (type1 == intQI_type_node) + return unsigned_intQI_type_node; + + return m2type_gm2_signed_or_unsigned_type (TRUE, type); +} + +/* gm2_signed_type return a signed type the same as TYPE in other + respects. */ + +tree +m2type_gm2_signed_type (tree type) +{ + tree type1 = TYPE_MAIN_VARIANT (type); + if (type1 == unsigned_char_type_node || type1 == char_type_node) + return signed_char_type_node; + if (type1 == unsigned_type_node) + return integer_type_node; + if (type1 == short_unsigned_type_node) + return short_integer_type_node; + if (type1 == long_unsigned_type_node) + return long_integer_type_node; + if (type1 == long_long_unsigned_type_node) + return long_long_integer_type_node; + +#if HOST_BITS_PER_WIDE_INT >= 64 + if (type1 == unsigned_intTI_type_node) + return intTI_type_node; +#endif + if (type1 == unsigned_intDI_type_node) + return intDI_type_node; + if (type1 == unsigned_intSI_type_node) + return intSI_type_node; + if (type1 == unsigned_intHI_type_node) + return intHI_type_node; + if (type1 == unsigned_intQI_type_node) + return intQI_type_node; + + return m2type_gm2_signed_or_unsigned_type (FALSE, type); +} + +/* check_type if the precision of baseType and type are the same + then return true and set the signed or unsigned type in result + else return false. */ + +static int +check_type (tree baseType, tree type, int unsignedp, tree baseu, tree bases, + tree *result) +{ + if (TYPE_PRECISION (baseType) == TYPE_PRECISION (type)) + { + if (unsignedp) + *result = baseu; + else + *result = bases; + return TRUE; + } + return FALSE; +} + +/* gm2_signed_or_unsigned_type return a type the same as TYPE + except unsigned or signed according to UNSIGNEDP. */ + +tree +m2type_gm2_signed_or_unsigned_type (int unsignedp, tree type) +{ + tree result; + + if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp) + return type; + + /* For INTEGER_TYPEs we must check the precision as well, so as to + yield correct results for bit-field types. */ + + if (check_type (signed_char_type_node, type, unsignedp, + unsigned_char_type_node, signed_char_type_node, &result)) + return result; + if (check_type (integer_type_node, type, unsignedp, unsigned_type_node, + integer_type_node, &result)) + return result; + if (check_type (short_integer_type_node, type, unsignedp, + short_unsigned_type_node, short_integer_type_node, &result)) + return result; + if (check_type (long_integer_type_node, type, unsignedp, + long_unsigned_type_node, long_integer_type_node, &result)) + return result; + if (check_type (long_long_integer_type_node, type, unsignedp, + long_long_unsigned_type_node, long_long_integer_type_node, + &result)) + return result; + +#if HOST_BITS_PER_WIDE_INT >= 64 + if (check_type (intTI_type_node, type, unsignedp, unsigned_intTI_type_node, + intTI_type_node, &result)) + return result; +#endif + if (check_type (intDI_type_node, type, unsignedp, unsigned_intDI_type_node, + intDI_type_node, &result)) + return result; + if (check_type (intSI_type_node, type, unsignedp, unsigned_intSI_type_node, + intSI_type_node, &result)) + return result; + if (check_type (intHI_type_node, type, unsignedp, unsigned_intHI_type_node, + intHI_type_node, &result)) + return result; + if (check_type (intQI_type_node, type, unsignedp, unsigned_intQI_type_node, + intQI_type_node, &result)) + return result; +#undef TYPE_OK + + return type; +} + +/* IsAddress returns TRUE if the type is an ADDRESS. */ + +int +m2type_IsAddress (tree type) +{ + return type == ptr_type_node; +} + +#include "gt-m2-m2type.h"