From patchwork Mon Oct 10 15:31:22 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Gaius Mulley X-Patchwork-Id: 1883 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a5d:4ac7:0:0:0:0:0 with SMTP id y7csp1644795wrs; Mon, 10 Oct 2022 08:41:28 -0700 (PDT) X-Google-Smtp-Source: AMsMyM41mm3v7XFpjiUB4sjriwUM+/fq/gkD4qZe5/Vx2rdkPB8uGCqogokcnz0YUqHrsX1rHUR9 X-Received: by 2002:aa7:c509:0:b0:458:cb1f:b9e1 with SMTP id o9-20020aa7c509000000b00458cb1fb9e1mr18122005edq.369.1665416487828; Mon, 10 Oct 2022 08:41:27 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1665416487; cv=none; d=google.com; s=arc-20160816; b=mgXLVMxvvO1JlTBnqwH2AJRcrxdyZ1aMDjCHwravy9xouiJGrp0YKM3ilIN4dd7lRR NhSHCJ82uHg7n0RGZA/8OSzMjlAUAc6xHruCvHrodYgMh18TSD7AfxJNqrVdHTUNx8bx Uo/mZfzmPdymB2RwG51mFTmTkWJ+A+hszvyEcZOx5StOR/yPBNxxkIFGdA59umCoJlLP BBPT9JqmO8f++PFhBL34EKHwLpgJOww7QzcH9yGLQhtl63lOCEHXJvc9L/cMH1f74YDE ZjOAtPoEawfjUU4ATGVi+68NdTy7AGuOBewIqWWUdH0rU67CBKCcPpwLGAI5O9zEzj5a LUog== 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=ZXtlBEw907q3AG3ZAsjC4b3bCKBPSNuZfEAZkdcDYvc=; b=Q6vF1DRJI8Bk3oj2XInO1wPge5wlkFpc9cP+9NuJHtjipoG5V1vO7TeLosvJfbBann 2Tm8J2LAFOr/r3MuTecTI3nNd0dKPFWtI2hkqis3oQ0UOBX+gQ20LLMfWb3aYpfD//zv SAFspbKKnLy2X5oyxJidaq/U3/Nzclgyy4yeCGrwHk6okRM2Q2fyMmlhnaleYgcW2a85 qvAb4WUhBRPmmW2Eqns+yvsfyOSLmR95cTVwIdQsUenOcKwGYq2VUaQco8EyLHZAKLG7 t0xg1KJR2Z2Aph+h3gL3XZvXeNmkWrGDDnszhOhq70n00D6ikHrrKebCxV4pz35dRk1k VaVQ== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=igezvIW9; 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 (server2.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id oz20-20020a1709077d9400b0078d473448afsi10180542ejc.233.2022.10.10.08.41.27 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 10 Oct 2022 08:41:27 -0700 (PDT) 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=igezvIW9; 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 C18643955C8B for ; Mon, 10 Oct 2022 15:37:41 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org C18643955C8B DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1665416261; bh=ZXtlBEw907q3AG3ZAsjC4b3bCKBPSNuZfEAZkdcDYvc=; h=Subject:To:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=igezvIW9SSxJH1sHHryEpe4LYQzUHJepRxzSHe21mit7i8suohGYEB5zhFf1FK8wn wQWdrNxBRSt2nVxTK2jaDWQpyNFG/qAuzz2OsUWlfxb7qTBTjaVehh9pgDv/aJ3tzk 11zJcU0aZwJ7tf4XUTSFKl7lbWRcHoLS0HZeEev4= 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 77DD73952499 for ; Mon, 10 Oct 2022 15:31:29 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 77DD73952499 Received: by mail-wr1-x42d.google.com with SMTP id w18so17582493wro.7 for ; Mon, 10 Oct 2022 08:31:29 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=date:message-id:to:subject:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=ZXtlBEw907q3AG3ZAsjC4b3bCKBPSNuZfEAZkdcDYvc=; b=uin4Hgg2fcMDOLrIrvHMyLuAGm7otd8TUwxUGYFVpVuZ3XAlzH6PVuqjijgp8yV3Vp MDQwgVWbfgp5OYXrOOzkk4C5Qyt6aFMz4Ndkmxj77B2Qh94qEn5KpEaNwmxGwSuU5VEw ynR7ypz7P3aY2t0t7fh6helse/SdUUJKjAloY+Dj6Xr1Z6/5i23mb5c7octP1fOmuTPi 1Kod7DMA+otWDTcQ1YrO2IyVCWRBr6/QC0RmVH8DY2nm1x80AsKPopz4h6NCSxdBX5pa PC/a2nh0HQQRGPCZ8SeZ/l9khEbMwW9YDu7Atf5VvMJIkTE7WMFUpPrD2/sVubdX6nns xhKQ== X-Gm-Message-State: ACrzQf2Fgr19woNM2mv1V5Atp3CGp/1CPUGL2kecU2UTgaDp1hH5J4KY CdTjShK+atBVOmbNCW8kQ4cuIdhEZvk= X-Received: by 2002:a5d:64eb:0:b0:22e:48df:f1bb with SMTP id g11-20020a5d64eb000000b0022e48dff1bbmr11723858wri.262.1665415886336; Mon, 10 Oct 2022 08:31:26 -0700 (PDT) Received: from lancelot ([195.147.220.46]) by smtp.gmail.com with ESMTPSA id g20-20020a05600c4ed400b003b4ac05a8a4sm23387529wmq.27.2022.10.10.08.31.24 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 10 Oct 2022 08:31:26 -0700 (PDT) X-Google-Original-From: Gaius Mulley Received: from gaius by lancelot with local (Exim 4.94.2) (envelope-from ) id 1ohukU-00Bm2V-Q5 for gcc-patches@gcc.gnu.org; Mon, 10 Oct 2022 16:31:22 +0100 Subject: [PATCH] 11/19 modula2 front end: gimple interface *[a-d]*.cc To: X-Mailer: mail (GNU Mailutils 3.10) Message-Id: Date: Mon, 10 Oct 2022 16:31:22 +0100 X-Spam-Status: No, score=-1.4 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?1746315758855185146?= X-GMAIL-MSGID: =?utf-8?q?1746315758855185146?= 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-10-07 20:21:18.650096940 +0100 @@ -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-10-07 20:21:18.650096940 +0100 @@ -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-10-07 20:21:18.650096940 +0100 @@ -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-10-07 20:21:18.650096940 +0100 @@ -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-10-07 20:21:18.650096940 +0100 @@ -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-10-07 20:21:18.650096940 +0100 @@ -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-10-07 20:21:18.650096940 +0100 @@ -0,0 +1,438 @@ +/* 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. */ + +/* DeclareM2linkGlobals creates the following code in the application + module globals: + + int StaticInitialization = ScaffoldStatic; + const char *ForcedModuleInitOrder = RuntimeOverride; */ + +void +m2decl_DeclareM2linkGlobals (location_t location, + int ScaffoldStatic, const char *RuntimeOverride) +{ + m2block_pushGlobalScope (); + /* Generate: int StaticInitialization = ScaffoldStatic; */ + tree static_init = m2decl_DeclareKnownVariable (location, "StaticInitialization", + integer_type_node, + TRUE, FALSE, FALSE, TRUE, NULL_TREE); + DECL_INITIAL (static_init) = m2decl_BuildIntegerConstant (ScaffoldStatic); + /* Generate: const char *ForcedModuleInitOrder = RuntimeOverride; */ + tree ptr_to_char = build_pointer_type (char_type_node); + TYPE_READONLY (ptr_to_char) = TRUE; + tree forced_order = m2decl_DeclareKnownVariable (location, "ForcedModuleInitOrder", + ptr_to_char, + TRUE, FALSE, FALSE, TRUE, NULL_TREE); + if (RuntimeOverride == NULL || (strlen (RuntimeOverride) == 0)) + DECL_INITIAL (forced_order) = m2convert_BuildConvert (location, ptr_to_char, + m2decl_BuildIntegerConstant (0), + FALSE); + else + DECL_INITIAL (forced_order) = build_string_literal (strlen (RuntimeOverride), RuntimeOverride); + m2block_popGlobalScope (); +} + + +/* 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 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; + + 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 +} + +/* 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"