From patchwork Tue Dec 6 14:47:28 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Gaius Mulley X-Patchwork-Id: 61588 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 75B98383FD74 for ; Tue, 6 Dec 2022 14:54:50 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 75B98383FD74 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1670338490; bh=HnFcNuk/zFCgn0iT/4lp93Wg/1aR4JzDqFivRUiJ7aU=; h=Subject:To:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=a/9W1tXjlOAuUpL9m22+nWSnlC08386KWXWrX0Gys5pIGpRy6FAfqJtStLa8sXivP diaLUTbsYwBBhsDp+xzBBvVBtGBaEmsQJA9kNXx0+bw0bIs6hh3pi4tCWpnINNm9bK LiH3yu5jrJFUnl4yQZeYHj+RzmKD6pvnHFKDwDIw= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x32b.google.com (mail-wm1-x32b.google.com [IPv6:2a00:1450:4864:20::32b]) by sourceware.org (Postfix) with ESMTPS id E417C3875B65 for ; Tue, 6 Dec 2022 14:48:11 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org E417C3875B65 Received: by mail-wm1-x32b.google.com with SMTP id l26so5119314wms.4 for ; Tue, 06 Dec 2022 06:48:11 -0800 (PST) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=date:message-id:to:subject:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=HnFcNuk/zFCgn0iT/4lp93Wg/1aR4JzDqFivRUiJ7aU=; b=rfFSyGZd6vEby3SaauKX7o5IF9Msx0alYgCbmSeACR/XMW2P+nsgpL2SDu4fYWK7jl 1AsfcL0btk8vKzuCX6qhw7t1J/+deDS4G1LBHwk10JfISvANZ4bz0Sv8eaIy8UHbxqzs yUOrG/1ndFD3nSuIrtQqw6oAnt5MKF/kxHXhif/iUZnQTXhjdjfFBKjDSwGJcplov1Lv lSUH5wTXIY/yr1rEZwV/Cf4Ww7pxS1hVxWXY+rWHJWCpldlpCRVCyDkWKjNTwxfhd+hY qzrMnMagVRKmaAxPwmydEbsm7FP7xvwXzxKMgHY8f83AuO45n7Sgpc7cYuqMtoNV9l6M 6N7A== X-Gm-Message-State: ANoB5pnerzINMUK+1jjDgafaMBKdS19dgn/vywyUwOI+H2seYrDW4lx+ fHyGez11u9JEGdD05NHedl2OACLjNXE= X-Google-Smtp-Source: AA0mqf64B63pSAht99oKGQ0QZI7Ssw0tSEAn/msbovQHXe22jWTgyhZ+w8o3BNc8y7rotC9LEKSKTA== X-Received: by 2002:a7b:c3c9:0:b0:3cf:5442:bbe with SMTP id t9-20020a7bc3c9000000b003cf54420bbemr68109519wmj.2.1670338088825; Tue, 06 Dec 2022 06:48:08 -0800 (PST) Received: from lancelot ([195.147.220.46]) by smtp.gmail.com with ESMTPSA id i10-20020a1c540a000000b003cfc02ab8basm24252208wmb.33.2022.12.06.06.47.31 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Dec 2022 06:48:07 -0800 (PST) X-Google-Original-From: Gaius Mulley Received: from gaius by lancelot with local (Exim 4.94.2) (envelope-from ) id 1p2ZEG-004Qgz-29 for gcc-patches@gcc.gnu.org; Tue, 06 Dec 2022 14:47:28 +0000 Subject: [PATCH v3 14/19] modula2 front end: gimple interface remainder To: X-Mailer: mail (GNU Mailutils 3.10) Message-Id: Date: Tue, 06 Dec 2022 14:47:28 +0000 X-Spam-Status: No, score=-1.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, KAM_SHORT, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: Gaius Mulley via Gcc-patches From: Gaius Mulley Reply-To: Gaius Mulley Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patchset contains the gimple interface. ------8<----------8<----------8<----------8<----------8<----------8<---- diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/init.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/init.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,196 @@ +/* init.cc initializes the modules of the GNU Modula-2 front end. + +Copyright (C) 2012-2022 Free Software Foundation, Inc. +Contributed by Gaius Mulley . + +This file is part of GNU Modula-2. + +GNU Modula-2 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GNU Modula-2 is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Modula-2; see the file COPYING3. If not see +. */ + +#include "init.h" +#include "config.h" +#include "system.h" + +#if defined(__GNUG__) +#define EXTERN extern "C" +#else /* !__GNUG__ */ +#define EXTERN extern +#endif /* !__GNUG__ */ + +EXTERN void _M2_M2Bitset_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Debug_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Defaults_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Environment_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_RTExceptions_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2EXCEPTION_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2RTS_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Dependent_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SysExceptions_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_DynamicStrings_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Assertion_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_FormatStrings_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_FIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SFIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SArgs_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Lists_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_UnixArgs_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Args_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_wrapc_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_TimeString_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_IO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_StdIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_CmdArgs_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Preprocess_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Error_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Search_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Indexing_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_NameKey_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_NumberIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_FpuIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SysStorage_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Storage_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_StrIO_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Debug_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Batch_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_StrLib_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2ALU_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Options_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Comp_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2LexBuf_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SymbolTable_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Base_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Quads_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SymbolKey_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_FifoQueue_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Reserved_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Const_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_P1SymBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_P2SymBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_P3SymBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2System_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2BasicBlock_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Pass_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Code_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2AsmUtil_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2FileName_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Students_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_StrCase_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_SymbolConversion_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2GCCDeclare_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2GenGCC_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Range_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Swig_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2MetaError_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2CaseList_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_PCSymBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_PCBuild_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_Sets_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_dtoa_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_ldtoa_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2Check_init (int argc, char *argv[], char *envp[]); +EXTERN void _M2_M2SSA_init (int argc, char *argv[], char *envp[]); +EXTERN void exit (int); +EXTERN void M2Comp_compile (const char *filename); +EXTERN void RTExceptions_DefaultErrorCatch (void); + + +/* FrontEndInit initialize the modules. This is a global + initialization and it is called once. */ + +void +init_FrontEndInit (void) +{ + _M2_Debug_init (0, NULL, NULL); + _M2_RTExceptions_init (0, NULL, NULL); + _M2_M2Defaults_init (0, NULL, NULL); + _M2_Environment_init (0, NULL, NULL); + _M2_M2EXCEPTION_init (0, NULL, NULL); + _M2_M2Dependent_init (0, NULL, NULL); + _M2_M2RTS_init (0, NULL, NULL); + _M2_SysExceptions_init (0, NULL, NULL); + _M2_DynamicStrings_init (0, NULL, NULL); + _M2_Assertion_init (0, NULL, NULL); + _M2_FormatStrings_init (0, NULL, NULL); + _M2_FIO_init (0, NULL, NULL); + _M2_SFIO_init (0, NULL, NULL); + _M2_SArgs_init (0, NULL, NULL); + _M2_Lists_init (0, NULL, NULL); + _M2_UnixArgs_init (0, NULL, NULL); + _M2_Args_init (0, NULL, NULL); + _M2_wrapc_init (0, NULL, NULL); + _M2_TimeString_init (0, NULL, NULL); + _M2_IO_init (0, NULL, NULL); + _M2_StdIO_init (0, NULL, NULL); + _M2_CmdArgs_init (0, NULL, NULL); + _M2_FpuIO_init (0, NULL, NULL); + _M2_SysStorage_init (0, NULL, NULL); + _M2_Storage_init (0, NULL, NULL); + _M2_StrIO_init (0, NULL, NULL); + _M2_StrLib_init (0, NULL, NULL); + _M2_dtoa_init (0, NULL, NULL); + _M2_ldtoa_init (0, NULL, NULL); + _M2_M2Search_init (0, NULL, NULL); + _M2_M2Options_init (0, NULL, NULL); +} + +/* PerCompilationInit initialize the modules before compiling, + filename. This is called every time we compile a new file. */ + +void +init_PerCompilationInit (const char *filename) +{ + _M2_M2Bitset_init (0, NULL, NULL); + _M2_M2Preprocess_init (0, NULL, NULL); + _M2_M2Error_init (0, NULL, NULL); + _M2_Indexing_init (0, NULL, NULL); + _M2_NameKey_init (0, NULL, NULL); + _M2_NumberIO_init (0, NULL, NULL); + _M2_M2Debug_init (0, NULL, NULL); + _M2_M2Batch_init (0, NULL, NULL); + _M2_M2ALU_init (0, NULL, NULL); + _M2_M2Comp_init (0, NULL, NULL); + _M2_M2LexBuf_init (0, NULL, NULL); + _M2_SymbolTable_init (0, NULL, NULL); + _M2_M2Base_init (0, NULL, NULL); + _M2_M2Quads_init (0, NULL, NULL); + _M2_SymbolKey_init (0, NULL, NULL); + _M2_FifoQueue_init (0, NULL, NULL); + _M2_M2Reserved_init (0, NULL, NULL); + _M2_M2Const_init (0, NULL, NULL); + _M2_P1SymBuild_init (0, NULL, NULL); + _M2_P2SymBuild_init (0, NULL, NULL); + _M2_P3SymBuild_init (0, NULL, NULL); + _M2_M2System_init (0, NULL, NULL); + _M2_M2BasicBlock_init (0, NULL, NULL); + _M2_M2Pass_init (0, NULL, NULL); + _M2_M2Code_init (0, NULL, NULL); + _M2_M2AsmUtil_init (0, NULL, NULL); + _M2_M2FileName_init (0, NULL, NULL); + _M2_M2Students_init (0, NULL, NULL); + _M2_StrCase_init (0, NULL, NULL); + _M2_SymbolConversion_init (0, NULL, NULL); + _M2_M2GCCDeclare_init (0, NULL, NULL); + _M2_M2GenGCC_init (0, NULL, NULL); + _M2_M2Range_init (0, NULL, NULL); + _M2_M2Swig_init (0, NULL, NULL); + _M2_M2MetaError_init (0, NULL, NULL); + _M2_M2CaseList_init (0, NULL, NULL); + _M2_PCSymBuild_init (0, NULL, NULL); + _M2_PCBuild_init (0, NULL, NULL); + _M2_Sets_init (0, NULL, NULL); + _M2_M2SSA_init (0, NULL, NULL); + _M2_M2Check_init (0, NULL, NULL); + M2Comp_compile (filename); +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2statement.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2statement.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,955 @@ +/* m2statement.cc provides an interface to GCC statement trees. + +Copyright (C) 2012-2022 Free Software Foundation, Inc. +Contributed by Gaius Mulley . + +This file is part of GNU Modula-2. + +GNU Modula-2 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GNU Modula-2 is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Modula-2; see the file COPYING3. If not see +. */ + +#include "gcc-consolidation.h" + +#include "../gm2-lang.h" +#include "../m2-tree.h" + +/* Prototypes. */ + +#define m2statement_c +#include "m2assert.h" +#include "m2block.h" +#include "m2decl.h" +#include "m2expr.h" +#include "m2statement.h" +#include "m2tree.h" +#include "m2treelib.h" +#include "m2type.h" +#include "m2convert.h" + +static GTY (()) tree param_list = NULL_TREE; /* Ready for the next time we + call/define a function. */ +static GTY (()) tree last_function = NULL_TREE; + + +/* BuildStartFunctionCode - generate function entry code. */ + +void +m2statement_BuildStartFunctionCode (location_t location, tree fndecl, + int isexported, int isinline) +{ + tree param_decl; + + ASSERT_BOOL (isexported); + ASSERT_BOOL (isinline); + /* Announce we are compiling this function. */ + announce_function (fndecl); + + /* Set up to compile the function and enter it. */ + + DECL_INITIAL (fndecl) = NULL_TREE; + + current_function_decl = fndecl; + m2block_pushFunctionScope (fndecl); + m2statement_SetBeginLocation (location); + + ASSERT_BOOL ((cfun != NULL)); + /* Initialize the RTL code for the function. */ + allocate_struct_function (fndecl, false); + /* Begin the statement tree for this function. */ + DECL_SAVED_TREE (fndecl) = NULL_TREE; + + /* Set the context of these parameters to this function. */ + for (param_decl = DECL_ARGUMENTS (fndecl); param_decl; + param_decl = TREE_CHAIN (param_decl)) + DECL_CONTEXT (param_decl) = fndecl; + + /* This function exists in static storage. (This does not mean + `static' in the C sense!) */ + TREE_STATIC (fndecl) = 1; + TREE_PUBLIC (fndecl) = isexported; + /* We could do better here by detecting ADR + or type PROC used on this function. --fixme-- */ + TREE_ADDRESSABLE (fndecl) = 1; + DECL_DECLARED_INLINE_P (fndecl) = 0; /* isinline; */ +} + +static void +gm2_gimplify_function_node (tree fndecl) +{ + /* Convert all nested functions to GIMPLE now. We do things in this + order so that items like VLA sizes are expanded properly in the + context of the correct function. */ + struct cgraph_node *cgn; + + dump_function (TDI_original, fndecl); + gimplify_function_tree (fndecl); + + cgn = cgraph_node::get_create (fndecl); + for (cgn = first_nested_function (cgn); + cgn != NULL; cgn = next_nested_function (cgn)) + gm2_gimplify_function_node (cgn->decl); +} + +/* BuildEndFunctionCode - generates the function epilogue. */ + +void +m2statement_BuildEndFunctionCode (location_t location, tree fndecl, int nested) +{ + tree block = DECL_INITIAL (fndecl); + + BLOCK_SUPERCONTEXT (block) = fndecl; + + /* Must mark the RESULT_DECL as being in this function. */ + DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; + + /* And attach it to the function. */ + DECL_INITIAL (fndecl) = block; + + m2block_finishFunctionCode (fndecl); + m2statement_SetEndLocation (location); + + gm2_genericize (fndecl); + if (nested) + (void)cgraph_node::get_create (fndecl); + else + cgraph_node::finalize_function (fndecl, false); + + m2block_popFunctionScope (); + + /* We're leaving the context of this function, so zap cfun. It's + still in DECL_STRUCT_FUNCTION, and we'll restore it in + tree_rest_of_compilation. */ + set_cfun (NULL); + current_function_decl = NULL; +} + +/* BuildPushFunctionContext - pushes the current function context. + Maps onto push_function_context in ../function.cc. */ + +void +m2statement_BuildPushFunctionContext (void) +{ + push_function_context (); +} + +/* BuildPopFunctionContext - pops the current function context. Maps + onto pop_function_context in ../function.cc. */ + +void +m2statement_BuildPopFunctionContext (void) +{ + pop_function_context (); +} + +void +m2statement_SetBeginLocation (location_t location) +{ + if (cfun != NULL) + cfun->function_start_locus = location; +} + +void +m2statement_SetEndLocation (location_t location) +{ + if (cfun != NULL) + cfun->function_end_locus = location; +} + +/* BuildAssignmentTree builds the assignment of, des, and, expr. + It returns, des. */ + +tree +m2statement_BuildAssignmentTree (location_t location, tree des, tree expr) +{ + tree result; + + m2assert_AssertLocation (location); + STRIP_TYPE_NOPS (expr); + + if (TREE_CODE (expr) == FUNCTION_DECL) + result = build2 (MODIFY_EXPR, TREE_TYPE (des), des, + m2expr_BuildAddr (location, expr, FALSE)); + else + { + gcc_assert (TREE_CODE (TREE_TYPE (des)) != TYPE_DECL); + if (TREE_TYPE (expr) == TREE_TYPE (des)) + result = build2 (MODIFY_EXPR, TREE_TYPE (des), des, expr); + else + result = build2 ( + MODIFY_EXPR, TREE_TYPE (des), des, + m2convert_BuildConvert (location, TREE_TYPE (des), expr, FALSE)); + } + + TREE_SIDE_EFFECTS (result) = 1; + add_stmt (location, result); + return des; +} + +/* BuildAssignmentStatement builds the assignment of, des, and, expr. */ + +void +m2statement_BuildAssignmentStatement (location_t location, tree des, tree expr) +{ + m2statement_BuildAssignmentTree (location, des, expr); +} + +/* BuildGoto builds a goto operation. */ + +void +m2statement_BuildGoto (location_t location, char *name) +{ + tree label = m2block_getLabel (location, name); + + m2assert_AssertLocation (location); + TREE_USED (label) = 1; + add_stmt (location, build1 (GOTO_EXPR, void_type_node, label)); +} + +/* DeclareLabel - create a label, name. */ + +void +m2statement_DeclareLabel (location_t location, char *name) +{ + tree label = m2block_getLabel (location, name); + + m2assert_AssertLocation (location); + add_stmt (location, build1 (LABEL_EXPR, void_type_node, label)); +} + +/* BuildParam - build a list of parameters, ready for a subsequent + procedure call. */ + +void +m2statement_BuildParam (location_t location, tree param) +{ + m2assert_AssertLocation (location); + + if (TREE_CODE (param) == FUNCTION_DECL) + param = m2expr_BuildAddr (location, param, FALSE); + + param_list = chainon (build_tree_list (NULL_TREE, param), param_list); +} + +/* nCount - return the number of chained tree nodes in list, t. */ + +static int +nCount (tree t) +{ + int i = 0; + + while (t != NULL) + { + i++; + t = TREE_CHAIN (t); + } + return i; +} + +/* BuildProcedureCallTree - creates a procedure call from a procedure + and parameter list and the return type, rettype. */ + +tree +m2statement_BuildProcedureCallTree (location_t location, tree procedure, + tree rettype) +{ + tree functype = TREE_TYPE (procedure); + tree funcptr = build1 (ADDR_EXPR, build_pointer_type (functype), procedure); + tree call; + int n = nCount (param_list); + tree *argarray = XALLOCAVEC (tree, n); + tree t = param_list; + int i; + + m2assert_AssertLocation (location); + ASSERT_CONDITION ( + last_function + == NULL_TREE); /* Previous function value has not been collected. */ + TREE_USED (procedure) = TRUE; + + for (i = 0; i < n; i++) + { + argarray[i] = TREE_VALUE (t); + t = TREE_CHAIN (t); + } + + if (rettype == NULL_TREE) + { + rettype = void_type_node; + call = build_call_array_loc (location, rettype, funcptr, n, argarray); + TREE_USED (call) = TRUE; + TREE_SIDE_EFFECTS (call) = TRUE; + +#if defined(DEBUG_PROCEDURE_CALLS) + fprintf (stderr, "built the modula-2 call, here is the tree\n"); + fflush (stderr); + debug_tree (call); +#endif + + param_list + = NULL_TREE; /* Ready for the next time we call a procedure. */ + last_function = NULL_TREE; + return call; + } + else + { + last_function = build_call_array_loc ( + location, m2tree_skip_type_decl (rettype), funcptr, n, argarray); + TREE_USED (last_function) = TRUE; + TREE_SIDE_EFFECTS (last_function) = TRUE; + param_list + = NULL_TREE; /* Ready for the next time we call a procedure. */ + return last_function; + } +} + +/* BuildIndirectProcedureCallTree - creates a procedure call from a + procedure and parameter list and the return type, rettype. */ + +tree +m2statement_BuildIndirectProcedureCallTree (location_t location, + tree procedure, tree rettype) +{ + tree call; + int n = nCount (param_list); + tree *argarray = XALLOCAVEC (tree, n); + tree t = param_list; + int i; + + m2assert_AssertLocation (location); + TREE_USED (procedure) = TRUE; + TREE_SIDE_EFFECTS (procedure) = TRUE; + + for (i = 0; i < n; i++) + { + argarray[i] = TREE_VALUE (t); + t = TREE_CHAIN (t); + } + + if (rettype == NULL_TREE) + { + rettype = void_type_node; + call = build_call_array_loc (location, rettype, procedure, n, argarray); + TREE_USED (call) = TRUE; + TREE_SIDE_EFFECTS (call) = TRUE; + +#if defined(DEBUG_PROCEDURE_CALLS) + fprintf (stderr, "built the modula-2 call, here is the tree\n"); + fflush (stderr); + debug_tree (call); +#endif + + last_function = NULL_TREE; + param_list + = NULL_TREE; /* Ready for the next time we call a procedure. */ + return call; + } + else + { + last_function = build_call_array_loc ( + location, m2tree_skip_type_decl (rettype), procedure, n, argarray); + TREE_USED (last_function) = TRUE; + TREE_SIDE_EFFECTS (last_function) = TRUE; + param_list + = NULL_TREE; /* Ready for the next time we call a procedure. */ + return last_function; + } +} + +/* BuildFunctValue - generates code for value := + last_function(foobar); */ + +tree +m2statement_BuildFunctValue (location_t location, tree value) +{ + tree assign + = m2treelib_build_modify_expr (location, value, NOP_EXPR, last_function); + + m2assert_AssertLocation (location); + ASSERT_CONDITION ( + last_function + != NULL_TREE); /* No value available, possible used before. */ + + TREE_SIDE_EFFECTS (assign) = TRUE; + TREE_USED (assign) = TRUE; + last_function = NULL_TREE; + return assign; +} + +/* BuildCall2 - builds a tree representing: function (arg1, arg2). */ + +tree +m2statement_BuildCall2 (location_t location, tree function, tree rettype, + tree arg1, tree arg2) +{ + m2assert_AssertLocation (location); + ASSERT_CONDITION (param_list == NULL_TREE); + + param_list = chainon (build_tree_list (NULL_TREE, arg2), param_list); + param_list = chainon (build_tree_list (NULL_TREE, arg1), param_list); + return m2statement_BuildProcedureCallTree (location, function, rettype); +} + +/* BuildCall3 - builds a tree representing: function (arg1, arg2, + arg3). */ + +tree +m2statement_BuildCall3 (location_t location, tree function, tree rettype, + tree arg1, tree arg2, tree arg3) +{ + m2assert_AssertLocation (location); + ASSERT_CONDITION (param_list == NULL_TREE); + + param_list = chainon (build_tree_list (NULL_TREE, arg3), param_list); + param_list = chainon (build_tree_list (NULL_TREE, arg2), param_list); + param_list = chainon (build_tree_list (NULL_TREE, arg1), param_list); + return m2statement_BuildProcedureCallTree (location, function, rettype); +} + +/* BuildFunctionCallTree - creates a procedure function call from + a procedure and parameter list and the return type, rettype. + No tree is returned as the tree is held in the last_function global + variable. It is expected the BuildFunctValue is to be called after + a call to BuildFunctionCallTree. */ + +void +m2statement_BuildFunctionCallTree (location_t location, tree procedure, + tree rettype) +{ + m2statement_BuildProcedureCallTree (location, procedure, rettype); +} + +/* SetLastFunction - assigns last_function to, t. */ + +void +m2statement_SetLastFunction (tree t) +{ + last_function = t; +} + +/* SetParamList - assigns param_list to, t. */ + +void +m2statement_SetParamList (tree t) +{ + param_list = t; +} + +/* GetLastFunction - returns, last_function. */ + +tree +m2statement_GetLastFunction (void) +{ + return last_function; +} + +/* GetParamList - returns, param_list. */ + +tree +m2statement_GetParamList (void) +{ + return param_list; +} + +/* GetCurrentFunction - returns the current_function. */ + +tree +m2statement_GetCurrentFunction (void) +{ + return current_function_decl; +} + +/* GetParamTree - return parameter, i. */ + +tree +m2statement_GetParamTree (tree call, unsigned int i) +{ + return CALL_EXPR_ARG (call, i); +} + +/* BuildTryFinally - returns a TRY_FINALL_EXPR with the call and + cleanups attached. */ + +tree +m2statement_BuildTryFinally (location_t location, tree call, tree cleanups) +{ + return build_stmt (location, TRY_FINALLY_EXPR, call, cleanups); +} + +/* BuildCleanUp - return a CLEANUP_POINT_EXPR which will clobber, + param. */ + +tree +m2statement_BuildCleanUp (tree param) +{ + tree clobber = build_constructor (TREE_TYPE (param), NULL); + TREE_THIS_VOLATILE (clobber) = 1; + return build2 (MODIFY_EXPR, TREE_TYPE (param), param, clobber); +} + +/* BuildAsm - generates an inline assembler instruction. */ + +void +m2statement_BuildAsm (location_t location, tree instr, int isVolatile, + int isSimple, tree inputs, tree outputs, tree trash, + tree labels) +{ + tree string = resolve_asm_operand_names (instr, outputs, inputs, labels); + tree args = build_stmt (location, ASM_EXPR, string, outputs, inputs, trash, + labels); + + m2assert_AssertLocation (location); + + /* ASM statements without outputs, including simple ones, are treated + as volatile. */ + ASM_INPUT_P (args) = isSimple; + ASM_VOLATILE_P (args) = isVolatile; + + add_stmt (location, args); +} + +/* BuildUnaryForeachWordDo - provides the large set operators. Each + word (or less) of the set can be calculated by unop. This + procedure runs along each word of the large set invoking the unop. */ + +void +m2statement_BuildUnaryForeachWordDo (location_t location, tree type, tree op1, + tree op2, + tree (*unop) (location_t, tree, int), + int is_op1lvalue, int is_op2lvalue, + int is_op1const, int is_op2const) +{ + tree size = m2expr_GetSizeOf (location, type); + + m2assert_AssertLocation (location); + ASSERT_BOOL (is_op1lvalue); + ASSERT_BOOL (is_op2lvalue); + ASSERT_BOOL (is_op1const); + ASSERT_BOOL (is_op2const); + if (m2expr_CompareTrees ( + size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT)) + <= 0) + /* Small set size <= TSIZE(WORD). */ + m2statement_BuildAssignmentTree ( + location, m2treelib_get_rvalue (location, op1, type, is_op1lvalue), + (*unop) (location, + m2treelib_get_rvalue (location, op2, type, is_op2lvalue), + FALSE)); + else + { + /* Large set size > TSIZE(WORD). */ + unsigned int fieldNo = 0; + tree field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo); + tree field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo); + + if (is_op1const) + error ("internal error: not expecting operand1 to be a constant set"); + + while (field1 != NULL && field2 != NULL) + { + m2statement_BuildAssignmentTree ( + location, m2treelib_get_set_field_des (location, op1, field1), + (*unop) (location, + m2treelib_get_set_field_rhs (location, op2, field2), + FALSE)); + fieldNo++; + field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo); + field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo); + } + } +} + +/* BuildExcludeVarConst - builds the EXCL(op1, 1< 0); + field = TREE_CHAIN (field)) + fieldno--; + + m2statement_BuildAssignmentTree ( + location, m2treelib_get_set_field_des (location, op1, field), + m2expr_BuildLogicalAnd ( + location, m2treelib_get_set_field_rhs (location, op1, field), + m2expr_BuildSetNegate ( + location, + m2expr_BuildLSL (location, m2expr_GetWordOne (location), op2, + FALSE), + FALSE), + FALSE)); + } +} + +/* BuildExcludeVarVar - builds the EXCL(varset, 1< 0); + field = TREE_CHAIN (field)) + fieldno--; + + m2statement_BuildAssignmentTree ( + location, + /* Would like to use: m2expr_BuildComponentRef (location, p, field) + but strangely we have to take the address of the field and + dereference it to satify the gimplifier. See + testsuite/gm2/pim/pass/timeio?.mod for testcases. */ + m2treelib_get_set_field_des (location, op1, field), + m2expr_BuildLogicalOr ( + location, m2treelib_get_set_field_rhs (location, op1, field), + m2expr_BuildLSL (location, m2expr_GetWordOne (location), + m2convert_ToWord (location, op2), FALSE), + FALSE)); + } +} + +/* BuildIncludeVarVar - builds the INCL(varset, 1<. + +This file is part of GNU Modula-2. + +GNU Modula-2 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GNU Modula-2 is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Modula-2; see the file COPYING3. If not see +. */ + +#include "gcc-consolidation.h" + +#include "../gm2-lang.h" +#include "../m2-tree.h" + +#define m2treelib_c +#include "m2assert.h" +#include "m2block.h" +#include "m2convert.h" +#include "m2decl.h" +#include "m2expr.h" +#include "m2statement.h" +#include "m2tree.h" +#include "m2treelib.h" +#include "m2treelib.h" +#include "m2type.h" + +/* do_jump_if_bit - tests bit in word against integer zero using + operator, code. If the result is true then jump to label. */ + +void +m2treelib_do_jump_if_bit (location_t location, enum tree_code code, tree word, + tree bit, char *label) +{ + word = m2convert_ToWord (location, word); + bit = m2convert_ToWord (location, bit); + m2statement_DoJump ( + location, + m2expr_build_binary_op ( + location, code, + m2expr_build_binary_op ( + location, BIT_AND_EXPR, word, + m2expr_BuildLSL (location, m2expr_GetWordOne (location), bit, + FALSE), + FALSE), + m2expr_GetWordZero (location), FALSE), + NULL, label); +} + +/* build_modify_expr - taken from c-typeck.cc and heavily pruned. + + Build an assignment expression of lvalue LHS from value RHS. If + LHS_ORIGTYPE is not NULL, it is the original type of LHS, which + may differ from TREE_TYPE (LHS) for an enum bitfield. MODIFYCODE + is the code for a binary operator that we use to combine the old + value of LHS with RHS to get the new value. Or else MODIFYCODE is + NOP_EXPR meaning do a simple assignment. If RHS_ORIGTYPE is not + NULL_TREE, it is the original type of RHS, which may differ from + TREE_TYPE (RHS) for an enum value. + + LOCATION is the location of the MODIFYCODE operator. RHS_LOC is the + location of the RHS. */ + +static tree +build_modify_expr (location_t location, tree lhs, enum tree_code modifycode, + tree rhs) +{ + tree result; + tree newrhs; + tree rhs_semantic_type = NULL_TREE; + tree lhstype = TREE_TYPE (lhs); + tree olhstype = lhstype; + + ASSERT_CONDITION (modifycode == NOP_EXPR); + + if (TREE_CODE (rhs) == EXCESS_PRECISION_EXPR) + { + rhs_semantic_type = TREE_TYPE (rhs); + rhs = TREE_OPERAND (rhs, 0); + } + + newrhs = rhs; + + /* If storing into a structure or union member, it has probably been + given type `int'. Compute the type that would go with the actual + amount of storage the member occupies. */ + + if (TREE_CODE (lhs) == COMPONENT_REF + && (TREE_CODE (lhstype) == INTEGER_TYPE + || TREE_CODE (lhstype) == BOOLEAN_TYPE + || TREE_CODE (lhstype) == REAL_TYPE + || TREE_CODE (lhstype) == ENUMERAL_TYPE)) + lhstype = TREE_TYPE (get_unwidened (lhs, 0)); + + /* If storing in a field that is in actuality a short or narrower + than one, we must store in the field in its actual type. */ + + if (lhstype != TREE_TYPE (lhs)) + { + lhs = copy_node (lhs); + TREE_TYPE (lhs) = lhstype; + } + + newrhs = fold (newrhs); + + if (rhs_semantic_type) + newrhs = build1 (EXCESS_PRECISION_EXPR, rhs_semantic_type, newrhs); + + /* Scan operands. */ + + result = build2 (MODIFY_EXPR, lhstype, lhs, newrhs); + TREE_SIDE_EFFECTS (result) = 1; + protected_set_expr_location (result, location); + + /* If we got the LHS in a different type for storing in, convert the + result back to the nominal type of LHS so that the value we return + always has the same type as the LHS argument. */ + + ASSERT_CONDITION (olhstype == TREE_TYPE (result)); + /* In Modula-2 I'm assuming this will be true this maybe wrong, but + at least I'll know about it soon. If true then we do not need to + implement convert_for_assignment - which is a huge win. */ + + return result; +} + +/* m2treelib_build_modify_expr - wrapper function for + build_modify_expr. */ + +tree +m2treelib_build_modify_expr (location_t location, tree des, + enum tree_code modifycode, tree copy) +{ + return build_modify_expr (location, des, modifycode, copy); +} + +/* nCount - return the number of trees chained on, t. */ + +static int +nCount (tree t) +{ + int i = 0; + + while (t != NULL) + { + i++; + t = TREE_CHAIN (t); + } + return i; +} + +/* DoCall - build a call tree arranging the parameter list as a + vector. */ + +tree +m2treelib_DoCall (location_t location, tree rettype, tree funcptr, + tree param_list) +{ + int n = nCount (param_list); + tree *argarray = XALLOCAVEC (tree, n); + tree l = param_list; + int i; + + for (i = 0; i < n; i++) + { + argarray[i] = TREE_VALUE (l); + l = TREE_CHAIN (l); + } + return build_call_array_loc (location, rettype, funcptr, n, argarray); +} + +/* DoCall0 - build a call tree with no parameters. */ + +tree +m2treelib_DoCall0 (location_t location, tree rettype, tree funcptr) +{ + tree *argarray = XALLOCAVEC (tree, 1); + + argarray[0] = NULL_TREE; + + return build_call_array_loc (location, rettype, funcptr, 0, argarray); +} + +/* DoCall1 - build a call tree with 1 parameter. */ + +tree +m2treelib_DoCall1 (location_t location, tree rettype, tree funcptr, tree arg0) +{ + tree *argarray = XALLOCAVEC (tree, 1); + + argarray[0] = arg0; + + return build_call_array_loc (location, rettype, funcptr, 1, argarray); +} + +/* DoCall2 - build a call tree with 2 parameters. */ + +tree +m2treelib_DoCall2 (location_t location, tree rettype, tree funcptr, tree arg0, + tree arg1) +{ + tree *argarray = XALLOCAVEC (tree, 2); + + argarray[0] = arg0; + argarray[1] = arg1; + + return build_call_array_loc (location, rettype, funcptr, 2, argarray); +} + +/* DoCall3 - build a call tree with 3 parameters. */ + +tree +m2treelib_DoCall3 (location_t location, tree rettype, tree funcptr, tree arg0, + tree arg1, tree arg2) +{ + tree *argarray = XALLOCAVEC (tree, 3); + + argarray[0] = arg0; + argarray[1] = arg1; + argarray[2] = arg2; + + return build_call_array_loc (location, rettype, funcptr, 3, argarray); +} + +/* get_rvalue - returns the rvalue of t. The, type, is the object + type to be copied upon indirection. */ + +tree +m2treelib_get_rvalue (location_t location, tree t, tree type, int is_lvalue) +{ + if (is_lvalue) + return m2expr_BuildIndirect (location, t, type); + else + return t; +} + +/* get_field_no - returns the field no for, op. The, op, is either a + constructor or a variable of type record. If, op, is a + constructor (a set constant in GNU Modula-2) then this function is + essentially a no-op and it returns op. Else we iterate over the + field list and return the appropriate field number. */ + +tree +m2treelib_get_field_no (tree type, tree op, int is_const, unsigned int fieldNo) +{ + ASSERT_BOOL (is_const); + if (is_const) + return op; + else + { + tree list = TYPE_FIELDS (type); + while (fieldNo > 0 && list != NULL_TREE) + { + list = TREE_CHAIN (list); + fieldNo--; + } + return list; + } +} + +/* get_set_value - returns the value indicated by, field, in the set. + Either p->field or the constant(op.fieldNo) is returned. */ + +tree +m2treelib_get_set_value (location_t location, tree p, tree field, int is_const, + int is_lvalue, tree op, unsigned int fieldNo) +{ + tree value; + constructor_elt *ce; + + ASSERT_BOOL (is_const); + ASSERT_BOOL (is_lvalue); + if (is_const) + { + ASSERT_CONDITION (is_lvalue == FALSE); + gcc_assert (!vec_safe_is_empty (CONSTRUCTOR_ELTS (op))); + unsigned int size = vec_safe_length (CONSTRUCTOR_ELTS (op)); + if (size < fieldNo) + internal_error ("field number exceeds definition of set"); + if (vec_safe_iterate (CONSTRUCTOR_ELTS (op), fieldNo, &ce)) + value = ce->value; + else + internal_error ( + "field number out of range trying to access set element"); + } + else if (is_lvalue) + { + if (TREE_CODE (TREE_TYPE (p)) == POINTER_TYPE) + value = m2expr_BuildComponentRef ( + location, m2expr_BuildIndirect (location, p, TREE_TYPE (p)), + field); + else + { + ASSERT_CONDITION (TREE_CODE (TREE_TYPE (p)) == REFERENCE_TYPE); + value = m2expr_BuildComponentRef (location, p, field); + } + } + else + { + tree type = TREE_TYPE (op); + enum tree_code code = TREE_CODE (type); + + ASSERT_CONDITION (code == RECORD_TYPE + || (code == POINTER_TYPE + && (TREE_CODE (TREE_TYPE (type)) == RECORD_TYPE))); + value = m2expr_BuildComponentRef (location, op, field); + } + value = m2convert_ToBitset (location, value); + return value; +} + +/* get_set_address - returns the address of op1. */ + +tree +m2treelib_get_set_address (location_t location, tree op1, int is_lvalue) +{ + if (is_lvalue) + return op1; + else + return m2expr_BuildAddr (location, op1, FALSE); +} + +/* get_set_field_lhs - returns the address of p->field. */ + +tree +m2treelib_get_set_field_lhs (location_t location, tree p, tree field) +{ + return m2expr_BuildAddr ( + location, m2convert_ToBitset ( + location, m2expr_BuildComponentRef (location, p, field)), + FALSE); +} + +/* get_set_field_rhs - returns the value of p->field. */ + +tree +m2treelib_get_set_field_rhs (location_t location, tree p, tree field) +{ + return m2convert_ToBitset (location, + m2expr_BuildComponentRef (location, p, field)); +} + +/* get_set_field_des - returns the p->field ready to be a (rhs) + designator. */ + +tree +m2treelib_get_set_field_des (location_t location, tree p, tree field) +{ + return m2expr_BuildIndirect ( + location, + m2expr_BuildAddr (location, + m2expr_BuildComponentRef (location, p, field), FALSE), + m2type_GetBitsetType ()); +} + +/* get_set_address_if_var - returns the address of, op, providing it + is not a constant. NULL is returned if, op, is a constant. */ + +tree +m2treelib_get_set_address_if_var (location_t location, tree op, int is_lvalue, + int is_const) +{ + if (is_const) + return NULL; + else + return m2treelib_get_set_address (location, op, is_lvalue); +} + +/* add_stmt - t is a statement. Add it to the statement-tree. */ + +tree +add_stmt (location_t location, tree t) +{ + return m2block_add_stmt (location, t); +} + +/* taken from gcc/c-semantics.cc. */ + +/* Build a generic statement based on the given type of node and + arguments. Similar to `build_nt', except that we set EXPR_LOCATION + to LOC. */ + +tree +build_stmt (location_t loc, enum tree_code code, ...) +{ + tree ret; + int length, i; + va_list p; + bool side_effects; + + m2assert_AssertLocation (loc); + /* This function cannot be used to construct variably-sized nodes. */ + gcc_assert (TREE_CODE_CLASS (code) != tcc_vl_exp); + + va_start (p, code); + + ret = make_node (code); + TREE_TYPE (ret) = void_type_node; + length = TREE_CODE_LENGTH (code); + SET_EXPR_LOCATION (ret, loc); + + /* TREE_SIDE_EFFECTS will already be set for statements with implicit + side effects. Here we make sure it is set for other expressions by + checking whether the parameters have side effects. */ + + side_effects = false; + for (i = 0; i < length; i++) + { + tree t = va_arg (p, tree); + if (t && !TYPE_P (t)) + side_effects |= TREE_SIDE_EFFECTS (t); + TREE_OPERAND (ret, i) = t; + } + + TREE_SIDE_EFFECTS (ret) |= side_effects; + + va_end (p); + return ret; +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/README --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/README 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,5 @@ +This directory contains the interface code between the Modula-2 front +end and GCC. In effect this is the Modula-2 compiler GCC Tree API. +It is an internal API only. Many of these filenames match their GCC C +family counterparts. So for example m2decl.def and m2decl.cc are the +Modula-2 front end version of c-decl.cc. diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2top.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2top.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,65 @@ +/* m2top.cc provides top level scoping functions. + +Copyright (C) 2012-2022 Free Software Foundation, Inc. +Contributed by Gaius Mulley . + +This file is part of GNU Modula-2. + +GNU Modula-2 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GNU Modula-2 is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Modula-2; see the file COPYING3. If not see +. */ + +#include "gcc-consolidation.h" + +#include "../gm2-lang.h" +#include "../m2-tree.h" + +#include "m2assert.h" +#include "m2block.h" +#include "m2decl.h" +#include "m2expr.h" +#include "m2tree.h" +#include "m2type.h" +#define m2top_c +#include "m2top.h" + +/* StartGlobalContext - initializes a dummy function for the global + scope. */ + +void +m2top_StartGlobalContext (void) +{ +} + +/* EndGlobalContext - ends the dummy function for the global scope. */ + +void +m2top_EndGlobalContext (void) +{ +} + +/* FinishBackend - flushes all outstanding functions held in the GCC + backend out to the assembly file. */ + +void +m2top_FinishBackend (void) +{ +} + +/* SetFlagUnitAtATime - sets GCC flag_unit_at_a_time to b. */ + +void +m2top_SetFlagUnitAtATime (int b) +{ + flag_unit_at_a_time = b; +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2tree.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2tree.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,132 @@ +/* m2tree.cc provides a simple interface to GCC tree queries and skips. + +Copyright (C) 2012-2022 Free Software Foundation, Inc. +Contributed by Gaius Mulley . + +This file is part of GNU Modula-2. + +GNU Modula-2 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GNU Modula-2 is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Modula-2; see the file COPYING3. If not see +. */ + +#include "gcc-consolidation.h" + +#include "../m2-tree.h" + +#define m2tree_c +#include "m2tree.h" + +int +m2tree_is_var (tree var) +{ + return TREE_CODE (var) == VAR_DECL; +} + +int +m2tree_is_array (tree array) +{ + return TREE_CODE (array) == ARRAY_TYPE; +} + +int +m2tree_is_type (tree type) +{ + switch (TREE_CODE (type)) + { + + case TYPE_DECL: + case ARRAY_TYPE: + case RECORD_TYPE: + case SET_TYPE: + case ENUMERAL_TYPE: + case POINTER_TYPE: + case INTEGER_TYPE: + case REAL_TYPE: + case UNION_TYPE: + case BOOLEAN_TYPE: + case COMPLEX_TYPE: + return TRUE; + default: + return FALSE; + } +} + +tree +m2tree_skip_type_decl (tree type) +{ + if (type == error_mark_node) + return error_mark_node; + + if (type == NULL_TREE) + return NULL_TREE; + + if (TREE_CODE (type) == TYPE_DECL) + return m2tree_skip_type_decl (TREE_TYPE (type)); + return type; +} + +tree +m2tree_skip_const_decl (tree exp) +{ + if (exp == error_mark_node) + return error_mark_node; + + if (exp == NULL_TREE) + return NULL_TREE; + + if (TREE_CODE (exp) == CONST_DECL) + return DECL_INITIAL (exp); + return exp; +} + +/* m2tree_skip_reference_type - skips all POINTER_TYPE and + REFERENCE_TYPEs. Otherwise return exp. */ + +tree +m2tree_skip_reference_type (tree exp) +{ + if (TREE_CODE (exp) == REFERENCE_TYPE) + return m2tree_skip_reference_type (TREE_TYPE (exp)); + if (TREE_CODE (exp) == POINTER_TYPE) + return m2tree_skip_reference_type (TREE_TYPE (exp)); + return exp; +} + +/* m2tree_IsOrdinal - return TRUE if code is an INTEGER, BOOLEAN or + ENUMERAL type. */ + +int +m2tree_IsOrdinal (tree type) +{ + enum tree_code code = TREE_CODE (type); + + return (code == INTEGER_TYPE || (code) == BOOLEAN_TYPE + || (code) == ENUMERAL_TYPE); +} + +/* is_a_constant - returns TRUE if tree, t, is a constant. */ + +int +m2tree_IsAConstant (tree t) +{ + return (TREE_CODE (t) == INTEGER_CST) || (TREE_CODE (t) == REAL_CST) + || (TREE_CODE (t) == REAL_CST) || (TREE_CODE (t) == COMPLEX_CST) + || (TREE_CODE (t) == STRING_CST); +} + + +void +m2tree_debug_tree (tree t) +{ + debug_tree (t); +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2type.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2type.cc 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,3092 @@ +/* m2type.cc provides an interface to GCC type trees. + +Copyright (C) 2012-2022 Free Software Foundation, Inc. +Contributed by Gaius Mulley . + +This file is part of GNU Modula-2. + +GNU Modula-2 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GNU Modula-2 is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Modula-2; see the file COPYING3. If not see +. */ + +#include "gcc-consolidation.h" + +#include "../gm2-lang.h" +#include "../m2-tree.h" + +#define m2type_c +#include "m2assert.h" +#include "m2block.h" +#include "m2builtins.h" +#include "m2convert.h" +#include "m2decl.h" +#include "m2except.h" +#include "m2expr.h" +#include "m2linemap.h" +#include "m2tree.h" +#include "m2treelib.h" +#include "m2type.h" + +#undef USE_BOOLEAN +static int broken_set_debugging_info = TRUE; + + +struct GTY (()) struct_constructor +{ + /* Constructor_type, the type that we are constructing. */ + tree GTY ((skip (""))) constructor_type; + /* Constructor_fields, the list of fields belonging to + constructor_type. Used by SET and RECORD constructors. */ + tree GTY ((skip (""))) constructor_fields; + /* Constructor_element_list, the list of constants used by SET and + RECORD constructors. */ + tree GTY ((skip (""))) constructor_element_list; + /* Constructor_elements, used by an ARRAY initializer all elements + are held in reverse order. */ + vec *constructor_elements; + /* Level, the next level down in the constructor stack. */ + struct struct_constructor *level; +}; + +static GTY (()) struct struct_constructor *top_constructor = NULL; + +typedef struct GTY (()) array_desc +{ + int type; + tree index; + tree array; + struct array_desc *next; +} array_desc; + +static GTY (()) array_desc *list_of_arrays = NULL; +/* Used in BuildStartFunctionType. */ +static GTY (()) tree param_type_list; + +static GTY (()) tree proc_type_node; +static GTY (()) tree bitset_type_node; +static GTY (()) tree bitnum_type_node; +static GTY (()) tree m2_char_type_node; +static GTY (()) tree m2_integer_type_node; +static GTY (()) tree m2_cardinal_type_node; +static GTY (()) tree m2_short_real_type_node; +static GTY (()) tree m2_real_type_node; +static GTY (()) tree m2_long_real_type_node; +static GTY (()) tree m2_long_int_type_node; +static GTY (()) tree m2_long_card_type_node; +static GTY (()) tree m2_short_int_type_node; +static GTY (()) tree m2_short_card_type_node; +static GTY (()) tree m2_z_type_node; +static GTY (()) tree m2_iso_loc_type_node; +static GTY (()) tree m2_iso_byte_type_node; +static GTY (()) tree m2_iso_word_type_node; +static GTY (()) tree m2_integer8_type_node; +static GTY (()) tree m2_integer16_type_node; +static GTY (()) tree m2_integer32_type_node; +static GTY (()) tree m2_integer64_type_node; +static GTY (()) tree m2_cardinal8_type_node; +static GTY (()) tree m2_cardinal16_type_node; +static GTY (()) tree m2_cardinal32_type_node; +static GTY (()) tree m2_cardinal64_type_node; +static GTY (()) tree m2_word16_type_node; +static GTY (()) tree m2_word32_type_node; +static GTY (()) tree m2_word64_type_node; +static GTY (()) tree m2_bitset8_type_node; +static GTY (()) tree m2_bitset16_type_node; +static GTY (()) tree m2_bitset32_type_node; +static GTY (()) tree m2_real32_type_node; +static GTY (()) tree m2_real64_type_node; +static GTY (()) tree m2_real96_type_node; +static GTY (()) tree m2_real128_type_node; +static GTY (()) tree m2_complex_type_node; +static GTY (()) tree m2_long_complex_type_node; +static GTY (()) tree m2_short_complex_type_node; +static GTY (()) tree m2_c_type_node; +static GTY (()) tree m2_complex32_type_node; +static GTY (()) tree m2_complex64_type_node; +static GTY (()) tree m2_complex96_type_node; +static GTY (()) tree m2_complex128_type_node; +static GTY (()) tree m2_packed_boolean_type_node; +static GTY (()) tree m2_cardinal_address_type_node; + +/* gm2_canonicalize_array - returns a unique array node based on + index_type and type. */ + +static tree +gm2_canonicalize_array (tree index_type, int type) +{ + array_desc *l = list_of_arrays; + + while (l != NULL) + { + if (l->type == type && l->index == index_type) + return l->array; + else + l = l->next; + } + l = ggc_alloc (); + l->next = list_of_arrays; + l->type = type; + l->index = index_type; + l->array = make_node (ARRAY_TYPE); + TREE_TYPE (l->array) = NULL_TREE; + TYPE_DOMAIN (l->array) = index_type; + list_of_arrays = l; + return l->array; +} + +/* BuildStartArrayType - creates an array with an indextype and + elttype. The front end symbol type is also passed to allow the + gccgm2 to return the canonical edition of the array type even if + the GCC elttype is NULL_TREE. */ + +tree +m2type_BuildStartArrayType (tree index_type, tree elt_type, int type) +{ + tree t; + + elt_type = m2tree_skip_type_decl (elt_type); + ASSERT_CONDITION (index_type != NULL_TREE); + if (elt_type == NULL_TREE) + { + /* Cannot use GCC canonicalization routines yet, so we use our front + end version based on the front end type. */ + return gm2_canonicalize_array (index_type, type); + } + t = gm2_canonicalize_array (index_type, type); + if (TREE_TYPE (t) == NULL_TREE) + TREE_TYPE (t) = elt_type; + else + ASSERT_CONDITION (TREE_TYPE (t) == elt_type); + + return t; +} + +/* PutArrayType assignes TREE_TYPE (array) to the skipped type. */ + +void +m2type_PutArrayType (tree array, tree type) +{ + TREE_TYPE (array) = m2tree_skip_type_decl (type); +} + +/* gccgm2_GetArrayNoOfElements returns the number of elements in + arraytype. */ + +tree +m2type_GetArrayNoOfElements (location_t location, tree arraytype) +{ + tree index_type = TYPE_DOMAIN (m2tree_skip_type_decl (arraytype)); + tree min = TYPE_MIN_VALUE (index_type); + tree max = TYPE_MAX_VALUE (index_type); + + m2assert_AssertLocation (location); + return m2expr_FoldAndStrip (m2expr_BuildSub (location, max, min, FALSE)); +} + +/* gm2_finish_build_array_type complete building the partially + created array type, arrayType. The arrayType is now known to be + declared as: ARRAY index_type OF elt_type. There will only ever + be one gcc tree type for this array definition. The third + parameter type is a front end type and this is necessary so that + the canonicalization creates unique array types for each type. */ + +static tree +gm2_finish_build_array_type (tree arrayType, tree elt_type, tree index_type, + int type) +{ + tree old = arrayType; + + elt_type = m2tree_skip_type_decl (elt_type); + ASSERT_CONDITION (index_type != NULL_TREE); + if (TREE_CODE (elt_type) == FUNCTION_TYPE) + { + error ("arrays of functions are not meaningful"); + elt_type = integer_type_node; + } + + TREE_TYPE (arrayType) = elt_type; + TYPE_DOMAIN (arrayType) = index_type; + + arrayType = gm2_canonicalize_array (index_type, type); + if (arrayType != old) + internal_error ("array declaration canonicalization has failed"); + + if (!COMPLETE_TYPE_P (arrayType)) + layout_type (arrayType); + return arrayType; +} + +/* BuildEndArrayType returns a type which is an array indexed by + IndexType and which has ElementType elements. */ + +tree +m2type_BuildEndArrayType (tree arraytype, tree elementtype, tree indextype, + int type) +{ + elementtype = m2tree_skip_type_decl (elementtype); + ASSERT (indextype == TYPE_DOMAIN (arraytype), indextype); + + if (TREE_CODE (elementtype) == FUNCTION_TYPE) + return gm2_finish_build_array_type (arraytype, ptr_type_node, indextype, + type); + else + return gm2_finish_build_array_type ( + arraytype, m2tree_skip_type_decl (elementtype), indextype, type); +} + +/* gm2_build_array_type returns a type which is an array indexed by + IndexType and which has ElementType elements. */ + +static tree +gm2_build_array_type (tree elementtype, tree indextype, int fetype) +{ + tree arrayType = m2type_BuildStartArrayType (indextype, elementtype, fetype); + return m2type_BuildEndArrayType (arrayType, elementtype, indextype, fetype); +} + +/* ValueInTypeRange returns TRUE if the constant, value, lies within + the range of type. */ + +int +m2type_ValueInTypeRange (tree type, tree value) +{ + tree low_type = m2tree_skip_type_decl (type); + tree min_value = TYPE_MIN_VALUE (low_type); + tree max_value = TYPE_MAX_VALUE (low_type); + + value = m2expr_FoldAndStrip (value); + return ((tree_int_cst_compare (min_value, value) <= 0) + && (tree_int_cst_compare (value, max_value) <= 0)); +} + +/* ValueOutOfTypeRange returns TRUE if the constant, value, exceeds + the range of type. */ + +int +m2type_ValueOutOfTypeRange (tree type, tree value) +{ + return (!m2type_ValueInTypeRange (type, value)); +} + +/* ExceedsTypeRange return TRUE if low or high exceed the range of + type. */ + +int +m2type_ExceedsTypeRange (tree type, tree low, tree high) +{ + return (m2type_ValueOutOfTypeRange (type, low) + || m2type_ValueOutOfTypeRange (type, high)); +} + +/* WithinTypeRange return TRUE if low and high are within the range + of type. */ + +int +m2type_WithinTypeRange (tree type, tree low, tree high) +{ + return (m2type_ValueInTypeRange (type, low) + && m2type_ValueInTypeRange (type, high)); +} + +/* BuildArrayIndexType creates an integer index which accesses an + array. low and high are the min, max elements of the array. GCC + insists we access an array with an integer indice. */ + +tree +m2type_BuildArrayIndexType (tree low, tree high) +{ + tree sizelow = convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (low)); + tree sizehigh + = convert (m2type_GetIntegerType (), m2expr_FoldAndStrip (high)); + + if (m2expr_TreeOverflow (sizelow)) + error ("low bound for the array is outside the ztype limits"); + if (m2expr_TreeOverflow (sizehigh)) + error ("high bound for the array is outside the ztype limits"); + + return build_range_type (m2type_GetIntegerType (), + m2expr_FoldAndStrip (sizelow), + m2expr_FoldAndStrip (sizehigh)); +} + +/* build_m2_type_node_by_array builds a ISO Modula-2 word type from + ARRAY [low..high] OF arrayType. This matches the front end data + type fetype which is only used during canonicalization. */ + +static tree +build_m2_type_node_by_array (tree arrayType, tree low, tree high, int fetype) +{ + return gm2_build_array_type (arrayType, + m2type_BuildArrayIndexType (low, high), fetype); +} + +/* build_m2_word16_type_node build an ISO 16 bit word as an ARRAY + [0..1] OF loc. */ + +static tree +build_m2_word16_type_node (location_t location, int loc) +{ + return build_m2_type_node_by_array (m2type_GetISOLocType (), + m2expr_GetIntegerZero (location), + m2expr_GetIntegerOne (location), loc); +} + +/* build_m2_word32_type_node build an ISO 32 bit word as an ARRAY + [0..3] OF loc. */ + +static tree +build_m2_word32_type_node (location_t location, int loc) +{ + return build_m2_type_node_by_array (m2type_GetISOLocType (), + m2expr_GetIntegerZero (location), + m2decl_BuildIntegerConstant (3), loc); +} + +/* build_m2_word64_type_node build an ISO 32 bit word as an ARRAY + [0..7] OF loc. */ + +static tree +build_m2_word64_type_node (location_t location, int loc) +{ + return build_m2_type_node_by_array (m2type_GetISOLocType (), + m2expr_GetIntegerZero (location), + m2decl_BuildIntegerConstant (7), loc); +} + +/* GetM2Complex32 return the fixed size complex type. */ + +tree +m2type_GetM2Complex32 (void) +{ + return m2_complex32_type_node; +} + +/* GetM2Complex64 return the fixed size complex type. */ + +tree +m2type_GetM2Complex64 (void) +{ + return m2_complex64_type_node; +} + +/* GetM2Complex96 return the fixed size complex type. */ + +tree +m2type_GetM2Complex96 (void) +{ + return m2_complex96_type_node; +} + +/* GetM2Complex128 return the fixed size complex type. */ + +tree +m2type_GetM2Complex128 (void) +{ + return m2_complex128_type_node; +} + +/* GetM2CType a test function. */ + +tree +m2type_GetM2CType (void) +{ + return m2_c_type_node; +} + +/* GetM2ShortComplexType return the short complex type. */ + +tree +m2type_GetM2ShortComplexType (void) +{ + return m2_short_complex_type_node; +} + +/* GetM2LongComplexType return the long complex type. */ + +tree +m2type_GetM2LongComplexType (void) +{ + return m2_long_complex_type_node; +} + +/* GetM2ComplexType return the complex type. */ + +tree +m2type_GetM2ComplexType (void) +{ + return m2_complex_type_node; +} + +/* GetM2Real128 return the real 128 bit type. */ + +tree +m2type_GetM2Real128 (void) +{ + return m2_real128_type_node; +} + +/* GetM2Real96 return the real 96 bit type. */ + +tree +m2type_GetM2Real96 (void) +{ + return m2_real96_type_node; +} + +/* GetM2Real64 return the real 64 bit type. */ + +tree +m2type_GetM2Real64 (void) +{ + return m2_real64_type_node; +} + +/* GetM2Real32 return the real 32 bit type. */ + +tree +m2type_GetM2Real32 (void) +{ + return m2_real32_type_node; +} + +/* GetM2Bitset32 return the bitset 32 bit type. */ + +tree +m2type_GetM2Bitset32 (void) +{ + return m2_bitset32_type_node; +} + +/* GetM2Bitset16 return the bitset 16 bit type. */ + +tree +m2type_GetM2Bitset16 (void) +{ + return m2_bitset16_type_node; +} + +/* GetM2Bitset8 return the bitset 8 bit type. */ + +tree +m2type_GetM2Bitset8 (void) +{ + return m2_bitset8_type_node; +} + +/* GetM2Word64 return the word 64 bit type. */ + +tree +m2type_GetM2Word64 (void) +{ + return m2_word64_type_node; +} + +/* GetM2Word32 return the word 32 bit type. */ + +tree +m2type_GetM2Word32 (void) +{ + return m2_word32_type_node; +} + +/* GetM2Word16 return the word 16 bit type. */ + +tree +m2type_GetM2Word16 (void) +{ + return m2_word16_type_node; +} + +/* GetM2Cardinal64 return the cardinal 64 bit type. */ + +tree +m2type_GetM2Cardinal64 (void) +{ + return m2_cardinal64_type_node; +} + +/* GetM2Cardinal32 return the cardinal 32 bit type. */ + +tree +m2type_GetM2Cardinal32 (void) +{ + return m2_cardinal32_type_node; +} + +/* GetM2Cardinal16 return the cardinal 16 bit type. */ + +tree +m2type_GetM2Cardinal16 (void) +{ + return m2_cardinal16_type_node; +} + +/* GetM2Cardinal8 return the cardinal 8 bit type. */ + +tree +m2type_GetM2Cardinal8 (void) +{ + return m2_cardinal8_type_node; +} + +/* GetM2Integer64 return the integer 64 bit type. */ + +tree +m2type_GetM2Integer64 (void) +{ + return m2_integer64_type_node; +} + +/* GetM2Integer32 return the integer 32 bit type. */ + +tree +m2type_GetM2Integer32 (void) +{ + return m2_integer32_type_node; +} + +/* GetM2Integer16 return the integer 16 bit type. */ + +tree +m2type_GetM2Integer16 (void) +{ + return m2_integer16_type_node; +} + +/* GetM2Integer8 return the integer 8 bit type. */ + +tree +m2type_GetM2Integer8 (void) +{ + return m2_integer8_type_node; +} + +/* GetM2RType return the ISO R data type, the longest real + datatype. */ + +tree +m2type_GetM2RType (void) +{ + return long_double_type_node; +} + +/* GetM2ZType return the ISO Z data type, the longest int datatype. */ + +tree +m2type_GetM2ZType (void) +{ + return m2_z_type_node; +} + +/* GetShortCardType return the C short unsigned data type. */ + +tree +m2type_GetShortCardType (void) +{ + return short_unsigned_type_node; +} + +/* GetM2ShortCardType return the m2 short cardinal data type. */ + +tree +m2type_GetM2ShortCardType (void) +{ + return m2_short_card_type_node; +} + +/* GetShortIntType return the C short int data type. */ + +tree +m2type_GetShortIntType (void) +{ + return short_integer_type_node; +} + +/* GetM2ShortIntType return the m2 short integer data type. */ + +tree +m2type_GetM2ShortIntType (void) +{ + return m2_short_int_type_node; +} + +/* GetM2LongCardType return the m2 long cardinal data type. */ + +tree +m2type_GetM2LongCardType (void) +{ + return m2_long_card_type_node; +} + +/* GetM2LongIntType return the m2 long integer data type. */ + +tree +m2type_GetM2LongIntType (void) +{ + return m2_long_int_type_node; +} + +/* GetM2LongRealType return the m2 long real data type. */ + +tree +m2type_GetM2LongRealType (void) +{ + return m2_long_real_type_node; +} + +/* GetM2RealType return the m2 real data type. */ + +tree +m2type_GetM2RealType (void) +{ + return m2_real_type_node; +} + +/* GetM2ShortRealType return the m2 short real data type. */ + +tree +m2type_GetM2ShortRealType (void) +{ + return m2_short_real_type_node; +} + +/* GetM2CardinalType return the m2 cardinal data type. */ + +tree +m2type_GetM2CardinalType (void) +{ + return m2_cardinal_type_node; +} + +/* GetM2IntegerType return the m2 integer data type. */ + +tree +m2type_GetM2IntegerType (void) +{ + return m2_integer_type_node; +} + +/* GetM2CharType return the m2 char data type. */ + +tree +m2type_GetM2CharType (void) +{ + return m2_char_type_node; +} + +/* GetProcType return the m2 proc data type. */ + +tree +m2type_GetProcType (void) +{ + return proc_type_node; +} + +/* GetISOWordType return the m2 iso word data type. */ + +tree +m2type_GetISOWordType (void) +{ + return m2_iso_word_type_node; +} + +/* GetISOByteType return the m2 iso byte data type. */ + +tree +m2type_GetISOByteType (void) +{ + return m2_iso_byte_type_node; +} + +/* GetISOLocType return the m2 loc word data type. */ + +tree +m2type_GetISOLocType (void) +{ + return m2_iso_loc_type_node; +} + +/* GetWordType return the C unsigned data type. */ + +tree +m2type_GetWordType (void) +{ + return unsigned_type_node; +} + +/* GetLongIntType return the C long int data type. */ + +tree +m2type_GetLongIntType (void) +{ + return long_integer_type_node; +} + +/* GetShortRealType return the C float data type. */ + +tree +m2type_GetShortRealType (void) +{ + return float_type_node; +} + +/* GetLongRealType return the C long double data type. */ + +tree +m2type_GetLongRealType (void) +{ + return long_double_type_node; +} + +/* GetRealType returns the C double_type_node. */ + +tree +m2type_GetRealType (void) +{ + return double_type_node; +} + +/* GetBitnumType return the ISO bitnum type. */ + +tree +m2type_GetBitnumType (void) +{ + return bitnum_type_node; +} + +/* GetBitsetType return the bitset type. */ + +tree +m2type_GetBitsetType (void) +{ + return bitset_type_node; +} + +/* GetCardinalType return the cardinal type. */ + +tree +m2type_GetCardinalType (void) +{ + return unsigned_type_node; +} + +/* GetPointerType return the GCC ptr type node. Equivalent to + (void *). */ + +tree +m2type_GetPointerType (void) +{ + return ptr_type_node; +} + +/* GetVoidType return the C void type. */ + +tree +m2type_GetVoidType (void) +{ + return void_type_node; +} + +/* GetByteType return the byte type node. */ + +tree +m2type_GetByteType (void) +{ + return unsigned_char_type_node; +} + +/* GetCharType return the char type node. */ + +tree +m2type_GetCharType (void) +{ + return char_type_node; +} + +/* GetIntegerType return the integer type node. */ + +tree +m2type_GetIntegerType (void) +{ + return integer_type_node; +} + +/* GetCSizeTType return a type representing, size_t on this system. */ + +tree +m2type_GetCSizeTType (void) +{ + return sizetype; +} + +/* GetCSSizeTType return a type representing, size_t on this + system. */ + +tree +m2type_GetCSSizeTType (void) +{ + return ssizetype; +} + +/* GetPackedBooleanType return the packed boolean data type node. */ + +tree +m2type_GetPackedBooleanType (void) +{ + return m2_packed_boolean_type_node; +} + +/* GetBooleanTrue return modula-2 TRUE. */ + +tree +m2type_GetBooleanTrue (void) +{ +#if defined(USE_BOOLEAN) + return boolean_true_node; +#else /* !USE_BOOLEAN */ + return m2expr_GetIntegerOne (m2linemap_BuiltinsLocation ()); +#endif /* !USE_BOOLEAN */ +} + +/* GetBooleanFalse return modula-2 FALSE. */ + +tree +m2type_GetBooleanFalse (void) +{ +#if defined(USE_BOOLEAN) + return boolean_false_node; +#else /* !USE_BOOLEAN */ + return m2expr_GetIntegerZero (m2linemap_BuiltinsLocation ()); +#endif /* !USE_BOOLEAN */ +} + +/* GetBooleanType return the modula-2 BOOLEAN type. */ + +tree +m2type_GetBooleanType (void) +{ +#if defined(USE_BOOLEAN) + return boolean_type_node; +#else /* !USE_BOOLEAN */ + return integer_type_node; +#endif /* !USE_BOOLEAN */ +} + +/* GetCardinalAddressType returns the internal data type for + computing binary arithmetic upon the ADDRESS datatype. */ + +tree +m2type_GetCardinalAddressType (void) +{ + return m2_cardinal_address_type_node; +} + +/* noBitsRequired returns the number of bits required to contain, + values. How many bits are required to represent all numbers + between: 0..values-1 */ + +static tree +noBitsRequired (tree values) +{ + int bits = tree_floor_log2 (values); + + if (integer_pow2p (values)) + /* remember we start counting from zero. */ + return m2decl_BuildIntegerConstant (bits); + else + return m2decl_BuildIntegerConstant (bits + 1); +} + +#if 0 +/* build_set_type creates a set type from the, domain, [low..high]. + The values low..high all have type, range_type. */ + +static tree +build_set_type (tree domain, tree range_type, int allow_void, int ispacked) +{ + tree type; + + if (!m2tree_IsOrdinal (domain) + && !(allow_void && TREE_CODE (domain) == VOID_TYPE)) + { + error ("set base type must be an ordinal type"); + return NULL; + } + + if (TYPE_SIZE (range_type) == 0) + layout_type (range_type); + + if (TYPE_SIZE (domain) == 0) + layout_type (domain); + + type = make_node (SET_TYPE); + TREE_TYPE (type) = range_type; + TYPE_DOMAIN (type) = domain; + TYPE_PACKED (type) = ispacked; + + return type; +} + + +/* convert_type_to_range does the conversion and copies the range + type */ + +static tree +convert_type_to_range (tree type) +{ + tree min, max; + tree itype; + + if (!m2tree_IsOrdinal (type)) + { + error ("ordinal type expected"); + return error_mark_node; + } + + min = TYPE_MIN_VALUE (type); + max = TYPE_MAX_VALUE (type); + + if (TREE_TYPE (min) != TREE_TYPE (max)) + { + error ("range limits are not of the same type"); + return error_mark_node; + } + + itype = build_range_type (TREE_TYPE (min), min, max); + + if (TREE_TYPE (type) == NULL_TREE) + { + layout_type (type); + TREE_TYPE (itype) = type; + } + else + { + layout_type (TREE_TYPE (type)); + TREE_TYPE (itype) = TREE_TYPE (type); + } + + layout_type (itype); + return itype; +} +#endif + +/* build_bitset_type builds the type BITSET which is exported from + SYSTEM. It also builds BITNUM (the subrange from which BITSET is + created). */ + +static tree +build_bitset_type (location_t location) +{ + m2assert_AssertLocation (location); + bitnum_type_node = build_range_type ( + m2tree_skip_type_decl (m2type_GetCardinalType ()), + m2decl_BuildIntegerConstant (0), + m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset () - 1)); + layout_type (bitnum_type_node); + +#if 1 + if (broken_set_debugging_info) + return unsigned_type_node; +#endif + + ASSERT ((COMPLETE_TYPE_P (bitnum_type_node)), bitnum_type_node); + + return m2type_BuildSetTypeFromSubrange ( + location, NULL, bitnum_type_node, m2decl_BuildIntegerConstant (0), + m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset () - 1), FALSE); +} + +/* BuildSetTypeFromSubrange constructs a set type from a + subrangeType. --fixme-- revisit once gdb/gcc supports dwarf-5 set type. */ + +tree +m2type_BuildSetTypeFromSubrange (location_t location, + char *name __attribute__ ((unused)), + tree subrangeType __attribute__ ((unused)), + tree lowval, tree highval, int ispacked) +{ + m2assert_AssertLocation (location); + lowval = m2expr_FoldAndStrip (lowval); + highval = m2expr_FoldAndStrip (highval); + +#if 0 + if (broken_set_debugging_info) + return unsigned_type_node; + else +#endif + if (ispacked) + { + tree noelements = m2expr_BuildAdd ( + location, m2expr_BuildSub (location, highval, lowval, FALSE), + integer_one_node, FALSE); + highval = m2expr_FoldAndStrip (m2expr_BuildSub ( + location, m2expr_BuildLSL (location, m2expr_GetWordOne (location), + noelements, FALSE), + m2expr_GetIntegerOne (location), FALSE)); + lowval = m2expr_GetIntegerZero (location); + return m2type_BuildSmallestTypeRange (location, lowval, highval); + } + else + return unsigned_type_node; +} + +/* build_m2_size_set_type build and return a set type with + precision bits. */ + +static tree +build_m2_size_set_type (location_t location, int precision) +{ + tree bitnum_type_node + = build_range_type (m2tree_skip_type_decl (m2type_GetCardinalType ()), + m2decl_BuildIntegerConstant (0), + m2decl_BuildIntegerConstant (precision - 1)); + layout_type (bitnum_type_node); + m2assert_AssertLocation (location); + + if (broken_set_debugging_info) + return unsigned_type_node; + + ASSERT ((COMPLETE_TYPE_P (bitnum_type_node)), bitnum_type_node); + + return m2type_BuildSetTypeFromSubrange ( + location, NULL, bitnum_type_node, m2decl_BuildIntegerConstant (0), + m2decl_BuildIntegerConstant (precision - 1), FALSE); +} + +/* build_m2_specific_size_type build a specific data type matching + number of bits precision whether it is_signed. It creates a + set type if base == SET_TYPE or returns the already created real, + if REAL_TYPE is specified. */ + +static tree +build_m2_specific_size_type (location_t location, enum tree_code base, + int precision, int is_signed) +{ + tree c; + + m2assert_AssertLocation (location); + + c = make_node (base); + TYPE_PRECISION (c) = precision; + + if (base == REAL_TYPE) + { + if (!float_mode_for_size (TYPE_PRECISION (c)).exists ()) + return NULL; + layout_type (c); + } + else if (base == SET_TYPE) + return build_m2_size_set_type (location, precision); + else + { + TYPE_SIZE (c) = 0; + + if (is_signed) + { + fixup_signed_type (c); + TYPE_UNSIGNED (c) = FALSE; + } + else + { + fixup_unsigned_type (c); + TYPE_UNSIGNED (c) = TRUE; + } + } + + return c; +} + +/* BuildSmallestTypeRange returns the smallest INTEGER_TYPE which + is sufficient to contain values: low..high. */ + +tree +m2type_BuildSmallestTypeRange (location_t location, tree low, tree high) +{ + tree bits; + + m2assert_AssertLocation (location); + low = fold (low); + high = fold (high); + bits = fold (noBitsRequired ( + m2expr_BuildAdd (location, m2expr_BuildSub (location, high, low, FALSE), + m2expr_GetIntegerOne (location), FALSE))); + return build_m2_specific_size_type (location, INTEGER_TYPE, + TREE_INT_CST_LOW (bits), + tree_int_cst_sgn (low) < 0); +} + +/* GetTreeType returns TREE_TYPE (t). */ + +tree +m2type_GetTreeType (tree t) +{ + return TREE_TYPE (t); +} + +/* finish_build_pointer_type finish building a POINTER_TYPE node. + necessary to solve self references in procedure types. */ + +/* Code taken from tree.cc:build_pointer_type_for_mode. */ + +static tree +finish_build_pointer_type (tree t, tree to_type, enum machine_mode mode, + bool can_alias_all) +{ + TREE_TYPE (t) = to_type; + SET_TYPE_MODE (t, mode); + TYPE_REF_CAN_ALIAS_ALL (t) = can_alias_all; + TYPE_NEXT_PTR_TO (t) = TYPE_POINTER_TO (to_type); + TYPE_POINTER_TO (to_type) = t; + + /* Lay out the type. */ + /* layout_type (t); */ + layout_type (t); + + return t; +} + +/* BuildParameterDeclaration creates and returns one parameter + from, name, and, type. It appends this parameter to the internal + param_type_list. */ + +tree +m2type_BuildProcTypeParameterDeclaration (location_t location, tree type, + int isreference) +{ + m2assert_AssertLocation (location); + ASSERT_BOOL (isreference); + type = m2tree_skip_type_decl (type); + if (isreference) + type = build_reference_type (type); + + param_type_list = tree_cons (NULL_TREE, type, param_type_list); + return type; +} + +/* BuildEndFunctionType build a function type which would return a, + value. The arguments have been created by + BuildParameterDeclaration. */ + +tree +m2type_BuildEndFunctionType (tree func, tree return_type, int uses_varargs) +{ + tree last; + + if (return_type == NULL_TREE) + return_type = void_type_node; + else + return_type = m2tree_skip_type_decl (return_type); + + if (uses_varargs) + { + if (param_type_list != NULL_TREE) + { + param_type_list = nreverse (param_type_list); + last = param_type_list; + param_type_list = nreverse (param_type_list); + gcc_assert (last != void_list_node); + } + } + else if (param_type_list == NULL_TREE) + param_type_list = void_list_node; + else + { + param_type_list = nreverse (param_type_list); + last = param_type_list; + param_type_list = nreverse (param_type_list); + TREE_CHAIN (last) = void_list_node; + } + param_type_list = build_function_type (return_type, param_type_list); + + func = finish_build_pointer_type (func, param_type_list, ptr_mode, false); + TYPE_SIZE (func) = 0; + layout_type (func); + return func; +} + +/* BuildStartFunctionType creates a pointer type, necessary to + create a function type. */ + +tree +m2type_BuildStartFunctionType (location_t location ATTRIBUTE_UNUSED, + char *name ATTRIBUTE_UNUSED) +{ + tree n = make_node (POINTER_TYPE); + + m2assert_AssertLocation (location); + return n; +} + +/* InitFunctionTypeParameters resets the current function type + parameter list. */ + +void +m2type_InitFunctionTypeParameters (void) +{ + param_type_list = NULL_TREE; +} + +/* gm2_finish_decl finishes VAR, TYPE and FUNCTION declarations. */ + +static void +gm2_finish_decl (location_t location, tree decl) +{ + tree type = TREE_TYPE (decl); + int was_incomplete = (DECL_SIZE (decl) == 0); + + m2assert_AssertLocation (location); + if (TREE_CODE (decl) == VAR_DECL) + { + if (DECL_SIZE (decl) == 0 && TREE_TYPE (decl) != error_mark_node + && COMPLETE_TYPE_P (TREE_TYPE (decl))) + layout_decl (decl, 0); + + if (DECL_SIZE (decl) == 0 + /* Don't give an error if we already gave one earlier. */ + && TREE_TYPE (decl) != error_mark_node) + { + error_at (location, "storage size of %q+D isn%'t known", decl); + TREE_TYPE (decl) = error_mark_node; + } + + if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl)) + && DECL_SIZE (decl) != 0) + { + if (TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST) + m2expr_ConstantExpressionWarning (DECL_SIZE (decl)); + else + error_at (location, "storage size of %q+D isn%'t constant", decl); + } + + if (TREE_USED (type)) + TREE_USED (decl) = 1; + } + + /* Output the assembler code and/or RTL code for variables and + functions, unless the type is an undefined structure or union. If + not, it will get done when the type is completed. */ + + if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL) + { + if (DECL_FILE_SCOPE_P (decl)) + { + if (DECL_INITIAL (decl) == NULL_TREE + || DECL_INITIAL (decl) == error_mark_node) + + /* Don't output anything when a tentative file-scope definition is + seen. But at end of compilation, do output code for them. */ + DECL_DEFER_OUTPUT (decl) = 1; + rest_of_decl_compilation (decl, true, 0); + } + + if (!DECL_FILE_SCOPE_P (decl)) + { + + /* Recompute the RTL of a local array now if it used to be an + incomplete type. */ + if (was_incomplete && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl)) + { + /* If we used it already as memory, it must stay in memory. */ + TREE_ADDRESSABLE (decl) = TREE_USED (decl); + /* If it's still incomplete now, no init will save it. */ + if (DECL_SIZE (decl) == 0) + DECL_INITIAL (decl) = 0; + } + } + } + + if (TREE_CODE (decl) == TYPE_DECL) + { + if (!DECL_FILE_SCOPE_P (decl) + && variably_modified_type_p (TREE_TYPE (decl), NULL_TREE)) + m2block_pushDecl (build_stmt (location, DECL_EXPR, decl)); + + rest_of_decl_compilation (decl, DECL_FILE_SCOPE_P (decl), 0); + } +} + +/* BuildVariableArrayAndDeclare creates a variable length array. + high is the maximum legal elements (which is a runtime variable). + This creates and array index, array type and local variable. */ + +tree +m2type_BuildVariableArrayAndDeclare (location_t location, tree elementtype, + tree high, char *name, tree scope) +{ + tree indextype = build_index_type (variable_size (high)); + tree arraytype = build_array_type (elementtype, indextype); + tree id = get_identifier (name); + tree decl; + + m2assert_AssertLocation (location); + decl = build_decl (location, VAR_DECL, id, arraytype); + + DECL_EXTERNAL (decl) = FALSE; + TREE_PUBLIC (decl) = TRUE; + DECL_CONTEXT (decl) = scope; + TREE_USED (arraytype) = TRUE; + TREE_USED (decl) = TRUE; + + m2block_pushDecl (decl); + + gm2_finish_decl (location, indextype); + gm2_finish_decl (location, arraytype); + add_stmt (location, build_stmt (location, DECL_EXPR, decl)); + + return decl; +} + +static tree +build_m2_iso_word_node (location_t location, int loc) +{ + tree c; + + m2assert_AssertLocation (location); + /* Define `WORD' as specified in ISO m2 + + WORD = ARRAY [0..SizeOfWord / SizeOfLoc] OF LOC ; */ + + if (m2decl_GetBitsPerInt () == BITS_PER_UNIT) + c = m2type_GetISOLocType (); + else + c = gm2_build_array_type ( + m2type_GetISOLocType (), + m2type_BuildArrayIndexType ( + m2expr_GetIntegerZero (location), + (m2expr_BuildSub (location, + m2decl_BuildIntegerConstant ( + m2decl_GetBitsPerInt () / BITS_PER_UNIT), + m2expr_GetIntegerOne (location), FALSE))), + loc); + return c; +} + +static tree +build_m2_iso_byte_node (location_t location, int loc) +{ + tree c; + + /* Define `BYTE' as specified in ISO m2 + + BYTE = ARRAY [0..SizeOfByte / SizeOfLoc] OF LOC ; */ + + if (BITS_PER_UNIT == 8) + c = m2type_GetISOLocType (); + else + c = gm2_build_array_type ( + m2type_GetISOLocType (), + m2type_BuildArrayIndexType ( + m2expr_GetIntegerZero (location), + m2decl_BuildIntegerConstant (BITS_PER_UNIT / 8)), + loc); + return c; +} + +/* m2type_InitSystemTypes initialise loc and word derivatives. */ + +void +m2type_InitSystemTypes (location_t location, int loc) +{ + m2assert_AssertLocation (location); + + m2_iso_word_type_node = build_m2_iso_word_node (location, loc); + m2_iso_byte_type_node = build_m2_iso_byte_node (location, loc); + + m2_word16_type_node = build_m2_word16_type_node (location, loc); + m2_word32_type_node = build_m2_word32_type_node (location, loc); + m2_word64_type_node = build_m2_word64_type_node (location, loc); +} + +static tree +build_m2_integer_node (void) +{ + return m2type_GetIntegerType (); +} + +static tree +build_m2_cardinal_node (void) +{ + return m2type_GetCardinalType (); +} + +static tree +build_m2_char_node (void) +{ + tree c; + + /* Define `CHAR', to be an unsigned char. */ + + c = make_unsigned_type (CHAR_TYPE_SIZE); + layout_type (c); + return c; +} + +static tree +build_m2_short_real_node (void) +{ + tree c; + + /* Define `REAL'. */ + + c = make_node (REAL_TYPE); + TYPE_PRECISION (c) = FLOAT_TYPE_SIZE; + layout_type (c); + + return c; +} + +static tree +build_m2_real_node (void) +{ + tree c; + + /* Define `REAL'. */ + + c = make_node (REAL_TYPE); + TYPE_PRECISION (c) = DOUBLE_TYPE_SIZE; + layout_type (c); + + return c; +} + +static tree +build_m2_long_real_node (void) +{ + tree c; + + /* Define `LONGREAL'. */ + + c = make_node (REAL_TYPE); + TYPE_PRECISION (c) = LONG_DOUBLE_TYPE_SIZE; + layout_type (c); + + return c; +} + +static tree +build_m2_long_int_node (void) +{ + tree c; + + /* Define `LONGINT'. */ + + c = make_signed_type (LONG_LONG_TYPE_SIZE); + layout_type (c); + + return c; +} + +static tree +build_m2_long_card_node (void) +{ + tree c; + + /* Define `LONGCARD'. */ + + c = make_unsigned_type (LONG_LONG_TYPE_SIZE); + layout_type (c); + + return c; +} + +static tree +build_m2_short_int_node (void) +{ + tree c; + + /* Define `SHORTINT'. */ + + c = make_signed_type (SHORT_TYPE_SIZE); + layout_type (c); + + return c; +} + +static tree +build_m2_short_card_node (void) +{ + tree c; + + /* Define `SHORTCARD'. */ + + c = make_unsigned_type (SHORT_TYPE_SIZE); + layout_type (c); + + return c; +} + +static tree +build_m2_iso_loc_node (void) +{ + tree c; + + /* Define `LOC' as specified in ISO m2. */ + + c = make_node (INTEGER_TYPE); + TYPE_PRECISION (c) = BITS_PER_UNIT; + TYPE_SIZE (c) = 0; + + fixup_unsigned_type (c); + TYPE_UNSIGNED (c) = 1; + + return c; +} + +static tree +build_m2_integer8_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 8, TRUE); +} + +static tree +build_m2_integer16_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 16, TRUE); +} + +static tree +build_m2_integer32_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 32, TRUE); +} + +static tree +build_m2_integer64_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 64, TRUE); +} + +static tree +build_m2_cardinal8_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 8, FALSE); +} + +static tree +build_m2_cardinal16_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 16, FALSE); +} + +static tree +build_m2_cardinal32_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 32, FALSE); +} + +static tree +build_m2_cardinal64_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, INTEGER_TYPE, 64, FALSE); +} + +static tree +build_m2_bitset8_type_node (location_t location) +{ + m2assert_AssertLocation (location); + if (broken_set_debugging_info) + return build_m2_specific_size_type (location, INTEGER_TYPE, 8, FALSE); + else + return build_m2_specific_size_type (location, SET_TYPE, 8, FALSE); +} + +static tree +build_m2_bitset16_type_node (location_t location) +{ + m2assert_AssertLocation (location); + if (broken_set_debugging_info) + return build_m2_specific_size_type (location, INTEGER_TYPE, 16, FALSE); + else + return build_m2_specific_size_type (location, SET_TYPE, 16, FALSE); +} + +static tree +build_m2_bitset32_type_node (location_t location) +{ + m2assert_AssertLocation (location); + if (broken_set_debugging_info) + return build_m2_specific_size_type (location, INTEGER_TYPE, 32, FALSE); + else + return build_m2_specific_size_type (location, SET_TYPE, 32, FALSE); +} + +static tree +build_m2_real32_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, REAL_TYPE, 32, TRUE); +} + +static tree +build_m2_real64_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, REAL_TYPE, 64, TRUE); +} + +static tree +build_m2_real96_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, REAL_TYPE, 96, TRUE); +} + +static tree +build_m2_real128_type_node (location_t location) +{ + m2assert_AssertLocation (location); + return build_m2_specific_size_type (location, REAL_TYPE, 128, TRUE); +} + +static tree +build_m2_complex_type_from (tree scalar_type) +{ + tree new_type; + + if (scalar_type == NULL) + return NULL; + if (scalar_type == float_type_node) + return complex_float_type_node; + if (scalar_type == double_type_node) + return complex_double_type_node; + if (scalar_type == long_double_type_node) + return complex_long_double_type_node; + + new_type = make_node (COMPLEX_TYPE); + TREE_TYPE (new_type) = scalar_type; + layout_type (new_type); + return new_type; +} + +static tree +build_m2_complex_type_node (void) +{ + return build_m2_complex_type_from (m2_real_type_node); +} + +static tree +build_m2_long_complex_type_node (void) +{ + return build_m2_complex_type_from (m2_long_real_type_node); +} + +static tree +build_m2_short_complex_type_node (void) +{ + return build_m2_complex_type_from (m2_short_real_type_node); +} + +static tree +build_m2_complex32_type_node (void) +{ + return build_m2_complex_type_from (m2_real32_type_node); +} + +static tree +build_m2_complex64_type_node (void) +{ + return build_m2_complex_type_from (m2_real64_type_node); +} + +static tree +build_m2_complex96_type_node (void) +{ + return build_m2_complex_type_from (m2_real96_type_node); +} + +static tree +build_m2_complex128_type_node (void) +{ + return build_m2_complex_type_from (m2_real128_type_node); +} + +static tree +build_m2_cardinal_address_type_node (location_t location) +{ + tree size = size_in_bytes (ptr_type_node); + int bits = TREE_INT_CST_LOW (size) * BITS_PER_UNIT; + + return build_m2_specific_size_type (location, INTEGER_TYPE, bits, FALSE); +} + +/* InitBaseTypes create the Modula-2 base types. */ + +void +m2type_InitBaseTypes (location_t location) +{ + m2assert_AssertLocation (location); + m2block_init (); + + ptr_type_node = build_pointer_type (void_type_node); + + proc_type_node + = build_pointer_type (build_function_type (void_type_node, NULL_TREE)); + + bitset_type_node = build_bitset_type (location); + m2_char_type_node = build_m2_char_node (); + m2_integer_type_node = build_m2_integer_node (); + m2_cardinal_type_node = build_m2_cardinal_node (); + m2_short_real_type_node = build_m2_short_real_node (); + m2_real_type_node = build_m2_real_node (); + m2_long_real_type_node = build_m2_long_real_node (); + m2_long_int_type_node = build_m2_long_int_node (); + m2_long_card_type_node = build_m2_long_card_node (); + m2_short_int_type_node = build_m2_short_int_node (); + m2_short_card_type_node = build_m2_short_card_node (); + m2_z_type_node = build_m2_long_int_node (); + m2_integer8_type_node = build_m2_integer8_type_node (location); + m2_integer16_type_node = build_m2_integer16_type_node (location); + m2_integer32_type_node = build_m2_integer32_type_node (location); + m2_integer64_type_node = build_m2_integer64_type_node (location); + m2_cardinal8_type_node = build_m2_cardinal8_type_node (location); + m2_cardinal16_type_node = build_m2_cardinal16_type_node (location); + m2_cardinal32_type_node = build_m2_cardinal32_type_node (location); + m2_cardinal64_type_node = build_m2_cardinal64_type_node (location); + m2_bitset8_type_node = build_m2_bitset8_type_node (location); + m2_bitset16_type_node = build_m2_bitset16_type_node (location); + m2_bitset32_type_node = build_m2_bitset32_type_node (location); + m2_real32_type_node = build_m2_real32_type_node (location); + m2_real64_type_node = build_m2_real64_type_node (location); + m2_real96_type_node = build_m2_real96_type_node (location); + m2_real128_type_node = build_m2_real128_type_node (location); + m2_complex_type_node = build_m2_complex_type_node (); + m2_long_complex_type_node = build_m2_long_complex_type_node (); + m2_short_complex_type_node = build_m2_short_complex_type_node (); + m2_c_type_node = build_m2_long_complex_type_node (); + m2_complex32_type_node = build_m2_complex32_type_node (); + m2_complex64_type_node = build_m2_complex64_type_node (); + m2_complex96_type_node = build_m2_complex96_type_node (); + m2_complex128_type_node = build_m2_complex128_type_node (); + m2_iso_loc_type_node = build_m2_iso_loc_node (); + + m2_cardinal_address_type_node + = build_m2_cardinal_address_type_node (location); + + m2_packed_boolean_type_node = build_nonstandard_integer_type (1, TRUE); + + m2builtins_init (location); + m2except_InitExceptions (location); + m2expr_init (location); +} + +/* BuildStartType given a, type, with a, name, return a GCC + declaration of this type. TYPE name = foo ; + + the type, foo, maybe a partially created type (which has + yet to be 'gm2_finish_decl'ed). */ + +tree +m2type_BuildStartType (location_t location, char *name, tree type) +{ + tree id = get_identifier (name); + tree decl, tem; + + m2assert_AssertLocation (location); + ASSERT (m2tree_is_type (type), type); + type = m2tree_skip_type_decl (type); + decl = build_decl (location, TYPE_DECL, id, type); + + tem = m2block_pushDecl (decl); + ASSERT (tem == decl, decl); + ASSERT (m2tree_is_type (decl), decl); + + return tem; +} + +/* BuildEndType finish declaring, type, and return, type. */ + +tree +m2type_BuildEndType (location_t location, tree type) +{ + m2assert_AssertLocation (location); + layout_type (TREE_TYPE (type)); + gm2_finish_decl (location, type); + return type; +} + +/* DeclareKnownType given a, type, with a, name, return a GCC + declaration of this type. TYPE name = foo ; */ + +tree +m2type_DeclareKnownType (location_t location, char *name, tree type) +{ + m2assert_AssertLocation (location); + return m2type_BuildEndType (location, + m2type_BuildStartType (location, name, type)); +} + +/* GetDefaultType given a, type, with a, name, return a GCC + declaration of this type. Checks to see whether the type name has + already been declared as a default type and if so it returns this + declaration. Otherwise it declares the type. In Modula-2 this is + equivalent to: + + TYPE name = type ; + + We need this function during gm2 initialization as it allows + gm2 to access default types before creating Modula-2 types. */ + +tree +m2type_GetDefaultType (location_t location, char *name, tree type) +{ + tree id = maybe_get_identifier (name); + + m2assert_AssertLocation (location); + if (id == NULL) + { + tree prev = type; + tree t; + + while (prev != NULL) + { + if (TYPE_NAME (prev) == NULL) + TYPE_NAME (prev) = get_identifier (name); + prev = TREE_TYPE (prev); + } + t = m2type_DeclareKnownType (location, name, type); + return t; + } + else + return id; +} + +tree +do_min_real (tree type) +{ + REAL_VALUE_TYPE r; + char buf[128]; + enum machine_mode mode = TYPE_MODE (type); + + get_max_float (REAL_MODE_FORMAT (mode), buf, sizeof (buf), false); + real_from_string (&r, buf); + return build1 (NEGATE_EXPR, type, build_real (type, r)); +} + +/* GetMinFrom given a, type, return a constant representing the + minimum legal value. */ + +tree +m2type_GetMinFrom (location_t location, tree type) +{ + m2assert_AssertLocation (location); + + if (type == m2_real_type_node || type == m2type_GetRealType ()) + return do_min_real (type); + if (type == m2_long_real_type_node || type == m2type_GetLongRealType ()) + return do_min_real (type); + if (type == m2_short_real_type_node || type == m2type_GetShortRealType ()) + return do_min_real (type); + if (type == ptr_type_node) + return m2expr_GetPointerZero (location); + + return TYPE_MIN_VALUE (m2tree_skip_type_decl (type)); +} + +tree +do_max_real (tree type) +{ + REAL_VALUE_TYPE r; + char buf[128]; + enum machine_mode mode = TYPE_MODE (type); + + get_max_float (REAL_MODE_FORMAT (mode), buf, sizeof (buf), false); + real_from_string (&r, buf); + return build_real (type, r); +} + +/* GetMaxFrom given a, type, return a constant representing the + maximum legal value. */ + +tree +m2type_GetMaxFrom (location_t location, tree type) +{ + m2assert_AssertLocation (location); + + if (type == m2_real_type_node || type == m2type_GetRealType ()) + return do_max_real (type); + if (type == m2_long_real_type_node || type == m2type_GetLongRealType ()) + return do_max_real (type); + if (type == m2_short_real_type_node || type == m2type_GetShortRealType ()) + return do_max_real (type); + if (type == ptr_type_node) + return fold (m2expr_BuildSub (location, m2expr_GetPointerZero (location), + m2expr_GetPointerOne (location), FALSE)); + + return TYPE_MAX_VALUE (m2tree_skip_type_decl (type)); +} + +/* BuildTypeDeclaration adds the, type, to the current statement + list. */ + +void +m2type_BuildTypeDeclaration (location_t location, tree type) +{ + enum tree_code code = TREE_CODE (type); + + m2assert_AssertLocation (location); + if (code == TYPE_DECL || code == RECORD_TYPE || code == POINTER_TYPE) + { + m2block_pushDecl (build_decl (location, TYPE_DECL, NULL, type)); + } + else if (code == VAR_DECL) + { + m2type_BuildTypeDeclaration (location, TREE_TYPE (type)); + m2block_pushDecl ( + build_stmt (location, DECL_EXPR, + type)); /* Is this safe? --fixme--. */ + } +} + +/* Begin compiling the definition of an enumeration type. NAME is + its name (or null if anonymous). Returns the type object, as yet + incomplete. Also records info about it so that build_enumerator may + be used to declare the individual values as they are read. */ + +static tree +gm2_start_enum (location_t location, tree name, int ispacked) +{ + tree enumtype = make_node (ENUMERAL_TYPE); + + m2assert_AssertLocation (location); + if (TYPE_VALUES (enumtype) != 0) + { + /* This enum is a named one that has been declared already. */ + error_at (location, "redeclaration of enum %qs", + IDENTIFIER_POINTER (name)); + + /* Completely replace its old definition. The old enumerators remain + defined, however. */ + TYPE_VALUES (enumtype) = 0; + } + + TYPE_PACKED (enumtype) = ispacked; + TREE_TYPE (enumtype) = m2type_GetIntegerType (); + + /* This is required as rest_of_type_compilation will use this field + when called from gm2_finish_enum. + + Create a fake NULL-named TYPE_DECL node whose TREE_TYPE will be the + tagged type we just added to the current scope. This fake NULL-named + TYPE_DECL node helps dwarfout.cc to know when it needs to output a + representation of a tagged type, and it also gives us a convenient + place to record the "scope start" address for the tagged type. */ + + TYPE_STUB_DECL (enumtype) = m2block_pushDecl ( + build_decl (location, TYPE_DECL, NULL_TREE, enumtype)); + + return enumtype; +} + +/* After processing and defining all the values of an enumeration + type, install their decls in the enumeration type and finish it off. + ENUMTYPE is the type object, VALUES a list of decl-value pairs, and + ATTRIBUTES are the specified attributes. Returns ENUMTYPE. */ + +static tree +gm2_finish_enum (location_t location, tree enumtype, tree values) +{ + tree pair, tem; + tree minnode = 0, maxnode = 0; + int precision; + signop sign; + + /* Calculate the maximum value of any enumerator in this type. */ + + if (values == error_mark_node) + minnode = maxnode = integer_zero_node; + else + { + minnode = maxnode = TREE_VALUE (values); + for (pair = TREE_CHAIN (values); pair; pair = TREE_CHAIN (pair)) + { + tree value = TREE_VALUE (pair); + if (tree_int_cst_lt (maxnode, value)) + maxnode = value; + if (tree_int_cst_lt (value, minnode)) + minnode = value; + } + } + + /* Construct the final type of this enumeration. It is the same as + one of the integral types the narrowest one that fits, except that + normally we only go as narrow as int and signed iff any of the + values are negative. */ + sign = (tree_int_cst_sgn (minnode) >= 0) ? UNSIGNED : SIGNED; + precision = MAX (tree_int_cst_min_precision (minnode, sign), + tree_int_cst_min_precision (maxnode, sign)); + + if (precision > TYPE_PRECISION (integer_type_node)) + { + warning (0, "enumeration values exceed range of integer"); + tem = long_long_integer_type_node; + } + else if (TYPE_PACKED (enumtype)) + tem = m2type_BuildSmallestTypeRange (location, minnode, maxnode); + else + tem = sign == UNSIGNED ? unsigned_type_node : integer_type_node; + + TYPE_MIN_VALUE (enumtype) = TYPE_MIN_VALUE (tem); + TYPE_MAX_VALUE (enumtype) = TYPE_MAX_VALUE (tem); + TYPE_UNSIGNED (enumtype) = TYPE_UNSIGNED (tem); + TYPE_SIZE (enumtype) = 0; + + /* If the precision of the type was specific with an attribute and it + was too small, give an error. Otherwise, use it. */ + if (TYPE_PRECISION (enumtype)) + { + if (precision > TYPE_PRECISION (enumtype)) + error ("specified mode too small for enumerated values"); + } + else + TYPE_PRECISION (enumtype) = TYPE_PRECISION (tem); + + layout_type (enumtype); + + if (values != error_mark_node) + { + + /* Change the type of the enumerators to be the enum type. We need + to do this irrespective of the size of the enum, for proper type + checking. Replace the DECL_INITIALs of the enumerators, and the + value slots of the list, with copies that have the enum type; they + cannot be modified in place because they may be shared (e.g. + integer_zero_node) Finally, change the purpose slots to point to the + names of the decls. */ + for (pair = values; pair; pair = TREE_CHAIN (pair)) + { + tree enu = TREE_PURPOSE (pair); + tree ini = DECL_INITIAL (enu); + + TREE_TYPE (enu) = enumtype; + + if (TREE_TYPE (ini) != integer_type_node) + ini = convert (enumtype, ini); + + DECL_INITIAL (enu) = ini; + TREE_PURPOSE (pair) = DECL_NAME (enu); + TREE_VALUE (pair) = ini; + } + + TYPE_VALUES (enumtype) = values; + } + + /* Fix up all variant types of this enum type. */ + for (tem = TYPE_MAIN_VARIANT (enumtype); tem; tem = TYPE_NEXT_VARIANT (tem)) + { + if (tem == enumtype) + continue; + TYPE_VALUES (tem) = TYPE_VALUES (enumtype); + TYPE_MIN_VALUE (tem) = TYPE_MIN_VALUE (enumtype); + TYPE_MAX_VALUE (tem) = TYPE_MAX_VALUE (enumtype); + TYPE_SIZE (tem) = TYPE_SIZE (enumtype); + TYPE_SIZE_UNIT (tem) = TYPE_SIZE_UNIT (enumtype); + SET_TYPE_MODE (tem, TYPE_MODE (enumtype)); + TYPE_PRECISION (tem) = TYPE_PRECISION (enumtype); + SET_TYPE_ALIGN (tem, TYPE_ALIGN (enumtype)); + TYPE_USER_ALIGN (tem) = TYPE_USER_ALIGN (enumtype); + TYPE_UNSIGNED (tem) = TYPE_UNSIGNED (enumtype); + TYPE_LANG_SPECIFIC (tem) = TYPE_LANG_SPECIFIC (enumtype); + } + + /* Finish debugging output for this type. */ + rest_of_type_compilation (enumtype, m2block_toplevel ()); + return enumtype; +} + +/* BuildStartEnumeration create an enumerated type in gcc. */ + +tree +m2type_BuildStartEnumeration (location_t location, char *name, int ispacked) +{ + tree id; + + m2assert_AssertLocation (location); + if ((name == NULL) || (strcmp (name, "") == 0)) + id = NULL_TREE; + else + id = get_identifier (name); + + return gm2_start_enum (location, id, ispacked); +} + +/* BuildEndEnumeration finish building the enumeration, it uses the + enum list, enumvalues, and returns a enumeration type tree. */ + +tree +m2type_BuildEndEnumeration (location_t location, tree enumtype, + tree enumvalues) +{ + tree finished ATTRIBUTE_UNUSED + = gm2_finish_enum (location, enumtype, enumvalues); + return enumtype; +} + +/* Build and install a CONST_DECL for one value of the current + enumeration type (one that was begun with start_enum). Return a + tree-list containing the CONST_DECL and its value. Assignment of + sequential values by default is handled here. */ + +static tree +gm2_build_enumerator (location_t location, tree name, tree value) +{ + tree decl, type; + + m2assert_AssertLocation (location); + /* Remove no-op casts from the value. */ + if (value) + STRIP_TYPE_NOPS (value); + + /* Now create a declaration for the enum value name. */ + + type = TREE_TYPE (value); + + decl = build_decl (location, CONST_DECL, name, type); + DECL_INITIAL (decl) = convert (type, value); + m2block_pushDecl (decl); + + return tree_cons (decl, value, NULL_TREE); +} + +/* BuildEnumerator build an enumerator and add it to the, + enumvalues, list. It returns a copy of the value. */ + +tree +m2type_BuildEnumerator (location_t location, char *name, tree value, + tree *enumvalues) +{ + tree id = get_identifier (name); + tree copy_of_value = copy_node (value); + tree gccenum = gm2_build_enumerator (location, id, copy_of_value); + + m2assert_AssertLocation (location); + /* Choose copy_of_value for enum value. */ + *enumvalues = chainon (gccenum, *enumvalues); + return copy_of_value; +} + +/* BuildPointerType returns a type which is a pointer to, totype. */ + +tree +m2type_BuildPointerType (tree totype) +{ + return build_pointer_type (m2tree_skip_type_decl (totype)); +} + +/* BuildConstPointerType returns a type which is a const pointer + to, totype. */ + +tree +m2type_BuildConstPointerType (tree totype) +{ + tree t = build_pointer_type (m2tree_skip_type_decl (totype)); + TYPE_READONLY (t) = TRUE; + return t; +} + +/* BuildSetType creates a SET OF [lowval..highval]. */ + +tree +m2type_BuildSetType (location_t location, char *name, tree type, tree lowval, + tree highval, int ispacked) +{ + tree range = build_range_type (m2tree_skip_type_decl (type), + m2expr_FoldAndStrip (lowval), + m2expr_FoldAndStrip (highval)); + + TYPE_PACKED (range) = ispacked; + m2assert_AssertLocation (location); + return m2type_BuildSetTypeFromSubrange (location, name, range, + m2expr_FoldAndStrip (lowval), + m2expr_FoldAndStrip (highval), + ispacked); +} + +/* push_constructor returns a new compound constructor frame. */ + +static struct struct_constructor * +push_constructor (void) +{ + struct struct_constructor *p = ggc_alloc (); + + p->level = top_constructor; + top_constructor = p; + return p; +} + +/* pop_constructor throws away the top constructor frame on the + stack. */ + +static void +pop_constructor (struct struct_constructor *p) +{ + ASSERT_CONDITION (p + == top_constructor); /* p should be the top_constructor. */ + top_constructor = top_constructor->level; +} + +/* BuildStartSetConstructor starts to create a set constant. + Remember that type is really a record type. */ + +void * +m2type_BuildStartSetConstructor (tree type) +{ + struct struct_constructor *p = push_constructor (); + + type = m2tree_skip_type_decl (type); + layout_type (type); + p->constructor_type = type; + p->constructor_fields = TYPE_FIELDS (type); + p->constructor_element_list = NULL_TREE; + vec_alloc (p->constructor_elements, 1); + return (void *)p; +} + +/* BuildSetConstructorElement adds, value, to the + constructor_element_list. */ + +void +m2type_BuildSetConstructorElement (void *p, tree value) +{ + struct struct_constructor *c = (struct struct_constructor *)p; + + if (value == NULL_TREE) + { + internal_error ("set type cannot be initialized with a %qs", + "NULL_TREE"); + return; + } + + if (c->constructor_fields == NULL) + { + internal_error ("set type does not take another integer value"); + return; + } + + c->constructor_element_list + = tree_cons (c->constructor_fields, value, c->constructor_element_list); + c->constructor_fields = TREE_CHAIN (c->constructor_fields); +} + +/* BuildEndSetConstructor finishes building a set constant. */ + +tree +m2type_BuildEndSetConstructor (void *p) +{ + tree constructor; + tree link; + struct struct_constructor *c = (struct struct_constructor *)p; + + for (link = c->constructor_element_list; link; link = TREE_CHAIN (link)) + { + tree field = TREE_PURPOSE (link); + DECL_SIZE (field) = bitsize_int (SET_WORD_SIZE); + DECL_BIT_FIELD (field) = 1; + } + + constructor = build_constructor_from_list ( + c->constructor_type, nreverse (c->constructor_element_list)); + TREE_CONSTANT (constructor) = 1; + TREE_STATIC (constructor) = 1; + + pop_constructor (c); + + return constructor; +} + +/* BuildStartRecordConstructor initializes a record compound + constructor frame. */ + +void * +m2type_BuildStartRecordConstructor (tree type) +{ + struct struct_constructor *p = push_constructor (); + + type = m2tree_skip_type_decl (type); + layout_type (type); + p->constructor_type = type; + p->constructor_fields = TYPE_FIELDS (type); + p->constructor_element_list = NULL_TREE; + vec_alloc (p->constructor_elements, 1); + return (void *)p; +} + +/* BuildEndRecordConstructor returns a tree containing the record + compound literal. */ + +tree +m2type_BuildEndRecordConstructor (void *p) +{ + struct struct_constructor *c = (struct struct_constructor *)p; + tree constructor = build_constructor_from_list ( + c->constructor_type, nreverse (c->constructor_element_list)); + TREE_CONSTANT (constructor) = 1; + TREE_STATIC (constructor) = 1; + + pop_constructor (c); + + return constructor; +} + +/* BuildRecordConstructorElement adds, value, to the + constructor_element_list. */ + +void +m2type_BuildRecordConstructorElement (void *p, tree value) +{ + m2type_BuildSetConstructorElement (p, value); +} + +/* BuildStartArrayConstructor initializes an array compound + constructor frame. */ + +void * +m2type_BuildStartArrayConstructor (tree type) +{ + struct struct_constructor *p = push_constructor (); + + type = m2tree_skip_type_decl (type); + layout_type (type); + p->constructor_type = type; + p->constructor_fields = TREE_TYPE (type); + p->constructor_element_list = NULL_TREE; + vec_alloc (p->constructor_elements, 1); + return (void *)p; +} + +/* BuildEndArrayConstructor returns a tree containing the array + compound literal. */ + +tree +m2type_BuildEndArrayConstructor (void *p) +{ + struct struct_constructor *c = (struct struct_constructor *)p; + tree constructor; + + constructor + = build_constructor (c->constructor_type, c->constructor_elements); + TREE_CONSTANT (constructor) = TRUE; + TREE_STATIC (constructor) = TRUE; + + pop_constructor (c); + + return constructor; +} + +/* BuildArrayConstructorElement adds, value, to the + constructor_element_list. */ + +void +m2type_BuildArrayConstructorElement (void *p, tree value, tree indice) +{ + struct struct_constructor *c = (struct struct_constructor *)p; + constructor_elt celt; + + if (value == NULL_TREE) + { + internal_error ("array cannot be initialized with a %qs", "NULL_TREE"); + return; + } + + if (c->constructor_fields == NULL_TREE) + { + internal_error ("array type must be initialized"); + return; + } + + if (c->constructor_fields != TREE_TYPE (value)) + { + internal_error ( + "array element value must be the same type as its declaration"); + return; + } + + celt.index = indice; + celt.value = value; + vec_safe_push (c->constructor_elements, celt); +} + +/* BuildArrayStringConstructor creates an array constructor for, + arrayType, consisting of the character elements defined by, str, + of, length, characters. */ + +tree +m2type_BuildArrayStringConstructor (location_t location, tree arrayType, + tree str, tree length) +{ + tree n; + tree val; + int i = 0; + const char *p = TREE_STRING_POINTER (str); + tree type = m2tree_skip_type_decl (TREE_TYPE (arrayType)); + struct struct_constructor *c + = (struct struct_constructor *)m2type_BuildStartArrayConstructor ( + arrayType); + char nul[1]; + int len = strlen (p); + + nul[0] = (char)0; + + m2assert_AssertLocation (location); + n = m2expr_GetIntegerZero (location); + while (m2expr_CompareTrees (n, length) < 0) + { + if (i < len) + val = m2convert_BuildConvert ( + location, type, m2type_BuildCharConstant (location, &p[i]), FALSE); + else + val = m2type_BuildCharConstant (location, &nul[0]); + m2type_BuildArrayConstructorElement (c, val, n); + i += 1; + n = m2expr_BuildAdd (location, n, m2expr_GetIntegerOne (location), + FALSE); + } + return m2type_BuildEndArrayConstructor (c); +} + +/* BuildSubrangeType creates a subrange of, type, with, lowval, + highval. */ + +tree +m2type_BuildSubrangeType (location_t location, char *name, tree type, + tree lowval, tree highval) +{ + tree range_type; + + m2assert_AssertLocation (location); + type = m2tree_skip_type_decl (type); + + lowval = m2expr_FoldAndStrip (lowval); + highval = m2expr_FoldAndStrip (highval); + + if (m2expr_TreeOverflow (lowval)) + error ("low bound for the subrange has overflowed"); + if (m2expr_TreeOverflow (highval)) + error ("high bound for the subrange has overflowed"); + + /* First build a type with the base range. */ + range_type = build_range_type (type, TYPE_MIN_VALUE (type), + TYPE_MAX_VALUE (type)); + + TYPE_UNSIGNED (range_type) = TYPE_UNSIGNED (type); +#if 0 + /* Then set the actual range. */ + SET_TYPE_RM_MIN_VALUE (range_type, lowval); + SET_TYPE_RM_MAX_VALUE (range_type, highval); +#endif + + if ((name != NULL) && (strcmp (name, "") != 0)) + { + /* Declared as TYPE foo = [x..y]; */ + range_type = m2type_DeclareKnownType (location, name, range_type); + layout_type (m2tree_skip_type_decl (range_type)); + } + + return range_type; +} + +/* BuildCharConstantChar creates a character constant given a character, ch. */ + +tree +m2type_BuildCharConstantChar (location_t location, char ch) +{ + tree id = build_int_cst (char_type_node, (int) ch); + id = m2convert_BuildConvert (location, m2type_GetM2CharType (), id, FALSE); + return m2block_RememberConstant (id); +} + +/* BuildCharConstant creates a character constant given a, string. */ + +tree +m2type_BuildCharConstant (location_t location, const char *string) +{ + return m2type_BuildCharConstantChar (location, string[0]); +} + +/* RealToTree convert a real number into a Tree. */ + +tree +m2type_RealToTree (char *name) +{ + return build_real ( + m2type_GetLongRealType (), + REAL_VALUE_ATOF (name, TYPE_MODE (m2type_GetLongRealType ()))); +} + +/* gm2_start_struct start to create a struct. */ + +static tree +gm2_start_struct (location_t location, enum tree_code code, char *name) +{ + tree s = make_node (code); + tree id; + + m2assert_AssertLocation (location); + if ((name == NULL) || (strcmp (name, "") == 0)) + id = NULL_TREE; + else + id = get_identifier (name); + + TYPE_PACKED (s) = FALSE; /* This maybe set TRUE later if necessary. */ + + m2block_pushDecl (build_decl (location, TYPE_DECL, id, s)); + return s; +} + +/* BuildStartRecord return a RECORD tree. */ + +tree +m2type_BuildStartRecord (location_t location, char *name) +{ + m2assert_AssertLocation (location); + return gm2_start_struct (location, RECORD_TYPE, name); +} + +/* BuildStartUnion return a union tree. */ + +tree +m2type_BuildStartUnion (location_t location, char *name) +{ + m2assert_AssertLocation (location); + return gm2_start_struct (location, UNION_TYPE, name); +} + +/* m2type_BuildStartVarient builds a varient record. It creates a + record field which has a, name, and whose type is a union. */ + +tree +m2type_BuildStartVarient (location_t location, char *name) +{ + tree varient = m2type_BuildStartUnion (location, name); + tree field = m2type_BuildStartFieldRecord (location, name, varient); + m2assert_AssertLocation (location); + return field; +} + +/* m2type_BuildEndVarient finish the varientField by calling + decl_finish and also finish the type of varientField (which is a + union). */ + +tree +m2type_BuildEndVarient (location_t location, tree varientField, + tree varientList, int isPacked) +{ + tree varient = TREE_TYPE (varientField); + m2assert_AssertLocation (location); + varient = m2type_BuildEndRecord (location, varient, varientList, isPacked); + gm2_finish_decl (location, varientField); + return varientField; +} + +/* m2type_BuildStartFieldVarient builds a field varient record. It + creates a record field which has a, name, and whose type is a + record. */ + +tree +m2type_BuildStartFieldVarient (location_t location, char *name) +{ + tree record = m2type_BuildStartRecord (location, name); + tree field = m2type_BuildStartFieldRecord (location, name, record); + m2assert_AssertLocation (location); + return field; +} + +/* BuildEndRecord a heavily pruned finish_struct from c-decl.cc. It + sets the context for each field to, t, propagates isPacked + throughout the fields in the structure. */ + +tree +m2type_BuildEndRecord (location_t location, tree record, tree fieldlist, + int isPacked) +{ + tree x, d; + + m2assert_AssertLocation (location); + + /* If this type was previously laid out as a forward reference, make + sure we lay it out again. */ + + TYPE_SIZE (record) = 0; + + /* Install struct as DECL_CONTEXT of each field decl. Also process + specified field sizes, found in the DECL_INITIAL, storing 0 there + after the type has been changed to precision equal to its width, + rather than the precision of the specified standard type. (Correct + layout requires the original type to have been preserved until now). */ + + for (x = fieldlist; x; x = TREE_CHAIN (x)) + { + DECL_CONTEXT (x) = record; + + if (TYPE_PACKED (record) && TYPE_ALIGN (TREE_TYPE (x)) > BITS_PER_UNIT) + DECL_PACKED (x) = 1; + + if (isPacked) + { + DECL_PACKED (x) = 1; + DECL_BIT_FIELD (x) = 1; + } + } + + /* Now we have the nearly final fieldlist. Record it, then lay out + the structure or union (including the fields). */ + + TYPE_FIELDS (record) = fieldlist; + layout_type (record); + + /* Now we have the truly final field list. Store it in this type and + in the variants. */ + + for (x = TYPE_MAIN_VARIANT (record); x; x = TYPE_NEXT_VARIANT (x)) + { + TYPE_FIELDS (x) = TYPE_FIELDS (record); + TYPE_LANG_SPECIFIC (x) = TYPE_LANG_SPECIFIC (record); + SET_TYPE_ALIGN (x, TYPE_ALIGN (record)); + TYPE_USER_ALIGN (x) = TYPE_USER_ALIGN (record); + } + + d = build_decl (location, TYPE_DECL, NULL, record); + TYPE_STUB_DECL (record) = d; + + /* Finish debugging output for this type. This must be done after we have + called build_decl. */ + rest_of_type_compilation (record, m2block_toplevel ()); + + return record; +} + +/* m2type_BuildEndFieldVarient finish the varientField by calling + decl_finish and also finish the type of varientField (which is a + record). */ + +tree +m2type_BuildEndFieldVarient (location_t location, tree varientField, + tree varientList, int isPacked) +{ + tree record = TREE_TYPE (varientField); + + m2assert_AssertLocation (location); + record = m2type_BuildEndRecord (location, record, varientList, isPacked); + gm2_finish_decl (location, varientField); + return varientField; +} + +/* m2type_BuildStartFieldRecord starts building a field record. It + returns the field which must be completed by calling + gm2_finish_decl. */ + +tree +m2type_BuildStartFieldRecord (location_t location, char *name, tree type) +{ + tree field, declarator; + + m2assert_AssertLocation (location); + if ((name == NULL) || (strcmp (name, "") == 0)) + declarator = NULL_TREE; + else + declarator = get_identifier (name); + + field = build_decl (location, FIELD_DECL, declarator, + m2tree_skip_type_decl (type)); + return field; +} + +/* Build a record field with name (name maybe NULL), returning the + new field declaration, FIELD_DECL. + + This is done during the parsing of the struct declaration. The + FIELD_DECL nodes are chained together and the lot of them are + ultimately passed to `build_struct' to make the RECORD_TYPE node. */ + +tree +m2type_BuildFieldRecord (location_t location, char *name, tree type) +{ + tree field = m2type_BuildStartFieldRecord (location, name, type); + + m2assert_AssertLocation (location); + gm2_finish_decl (location, field); + return field; +} + +/* ChainOn interface so that Modula-2 can also create chains of + declarations. */ + +tree +m2type_ChainOn (tree t1, tree t2) +{ + return chainon (t1, t2); +} + +/* ChainOnParamValue adds a list node {{name, str}, value} into the + tree list. */ + +tree +m2type_ChainOnParamValue (tree list, tree name, tree str, tree value) +{ + return chainon (list, build_tree_list (build_tree_list (name, str), value)); +} + +/* AddStringToTreeList adds, string, to list. */ + +tree +m2type_AddStringToTreeList (tree list, tree string) +{ + return tree_cons (NULL_TREE, string, list); +} + +/* SetAlignment sets the alignment of a, node, to, align. It + duplicates the, node, and sets the alignment to prevent alignment + effecting behaviour elsewhere. */ + +tree +m2type_SetAlignment (tree node, tree align) +{ + tree type = NULL_TREE; + tree decl = NULL_TREE; + int is_type = FALSE; + int i; + + if (DECL_P (node)) + { + decl = node; + is_type = (TREE_CODE (node) == TYPE_DECL); + type = TREE_TYPE (decl); + } + else if (TYPE_P (node)) + { + is_type = 1; + type = node; + } + + if (TREE_CODE (align) != INTEGER_CST) + error ("requested alignment is not a constant"); + else if ((i = tree_log2 (align)) == -1) + error ("requested alignment is not a power of 2"); + else if (i > HOST_BITS_PER_INT - 2) + error ("requested alignment is too large"); + else if (is_type) + { + + /* If we have a TYPE_DECL, then copy the type, so that we don't + accidentally modify a builtin type. See pushdecl. */ + if (decl && TREE_TYPE (decl) != error_mark_node + && DECL_ORIGINAL_TYPE (decl) == NULL_TREE) + { + tree tt = TREE_TYPE (decl); + type = build_variant_type_copy (type); + DECL_ORIGINAL_TYPE (decl) = tt; + TYPE_NAME (type) = decl; + TREE_USED (type) = TREE_USED (decl); + TREE_TYPE (decl) = type; + } + + SET_TYPE_ALIGN (type, (1 << i) * BITS_PER_UNIT); + TYPE_USER_ALIGN (type) = 1; + + if (decl) + { + SET_DECL_ALIGN (decl, (1 << i) * BITS_PER_UNIT); + DECL_USER_ALIGN (decl) = 1; + } + } + else if (TREE_CODE (decl) != VAR_DECL && TREE_CODE (decl) != FIELD_DECL) + error ("alignment may not be specified for %qD", decl); + else + { + SET_DECL_ALIGN (decl, (1 << i) * BITS_PER_UNIT); + DECL_USER_ALIGN (decl) = 1; + } + return node; +} + +/* SetDeclPacked sets the packed bit in decl TREE, node. It + returns the node. */ + +tree +m2type_SetDeclPacked (tree node) +{ + DECL_PACKED (node) = 1; + return node; +} + +/* SetTypePacked sets the packed bit in type TREE, node. It + returns the node. */ + +tree +m2type_SetTypePacked (tree node) +{ + TYPE_PACKED (node) = 1; + return node; +} + +/* SetRecordFieldOffset returns field after the byteOffset and + bitOffset has been applied to it. */ + +tree +m2type_SetRecordFieldOffset (tree field, tree byteOffset, tree bitOffset, + tree fieldtype, tree nbits) +{ + DECL_FIELD_OFFSET (field) = byteOffset; + DECL_FIELD_BIT_OFFSET (field) = bitOffset; + TREE_TYPE (field) = m2tree_skip_type_decl (fieldtype); + DECL_SIZE (field) = bitsize_int (TREE_INT_CST_LOW (nbits)); + return field; +} + +/* BuildPackedFieldRecord builds a packed field record of, name, + and, fieldtype. */ + +tree +m2type_BuildPackedFieldRecord (location_t location, char *name, tree fieldtype) +{ + m2assert_AssertLocation (location); + return m2type_BuildFieldRecord (location, name, fieldtype); +} + +/* BuildNumberOfArrayElements returns the number of elements in an + arrayType. */ + +tree +m2type_BuildNumberOfArrayElements (location_t location, tree arrayType) +{ + tree index = TYPE_DOMAIN (arrayType); + tree high = TYPE_MAX_VALUE (index); + tree low = TYPE_MIN_VALUE (index); + tree elements = m2expr_BuildAdd ( + location, m2expr_BuildSub (location, high, low, FALSE), + m2expr_GetIntegerOne (location), FALSE); + m2assert_AssertLocation (location); + return elements; +} + +/* AddStatement maps onto add_stmt. */ + +void +m2type_AddStatement (location_t location, tree t) +{ + if (t != NULL_TREE) + add_stmt (location, t); +} + +/* MarkFunctionReferenced marks a function as referenced. */ + +void +m2type_MarkFunctionReferenced (tree f) +{ + if (f != NULL_TREE) + if (TREE_CODE (f) == FUNCTION_DECL) + mark_decl_referenced (f); +} + +/* GarbageCollect force gcc to garbage collect. */ + +void +m2type_GarbageCollect (void) +{ + ggc_collect (); +} + +/* gm2_type_for_size return an integer type with BITS bits of + precision, that is unsigned if UNSIGNEDP is nonzero, otherwise + signed. */ + +tree +m2type_gm2_type_for_size (unsigned int bits, int unsignedp) +{ + if (bits == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + + if (bits == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + + if (bits == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + + if (bits == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + + if (bits == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); + + if (bits <= TYPE_PRECISION (intQI_type_node)) + return unsignedp ? unsigned_intQI_type_node : intQI_type_node; + + if (bits <= TYPE_PRECISION (intHI_type_node)) + return unsignedp ? unsigned_intHI_type_node : intHI_type_node; + + if (bits <= TYPE_PRECISION (intSI_type_node)) + return unsignedp ? unsigned_intSI_type_node : intSI_type_node; + + if (bits <= TYPE_PRECISION (intDI_type_node)) + return unsignedp ? unsigned_intDI_type_node : intDI_type_node; + + return 0; +} + +/* gm2_unsigned_type return an unsigned type the same as TYPE in + other respects. */ + +tree +m2type_gm2_unsigned_type (tree type) +{ + tree type1 = TYPE_MAIN_VARIANT (type); + if (type1 == signed_char_type_node || type1 == char_type_node) + return unsigned_char_type_node; + if (type1 == integer_type_node) + return unsigned_type_node; + if (type1 == short_integer_type_node) + return short_unsigned_type_node; + if (type1 == long_integer_type_node) + return long_unsigned_type_node; + if (type1 == long_long_integer_type_node) + return long_long_unsigned_type_node; + +#if HOST_BITS_PER_WIDE_INT >= 64 + if (type1 == intTI_type_node) + return unsigned_intTI_type_node; +#endif + if (type1 == intDI_type_node) + return unsigned_intDI_type_node; + if (type1 == intSI_type_node) + return unsigned_intSI_type_node; + if (type1 == intHI_type_node) + return unsigned_intHI_type_node; + if (type1 == intQI_type_node) + return unsigned_intQI_type_node; + + return m2type_gm2_signed_or_unsigned_type (TRUE, type); +} + +/* gm2_signed_type return a signed type the same as TYPE in other + respects. */ + +tree +m2type_gm2_signed_type (tree type) +{ + tree type1 = TYPE_MAIN_VARIANT (type); + if (type1 == unsigned_char_type_node || type1 == char_type_node) + return signed_char_type_node; + if (type1 == unsigned_type_node) + return integer_type_node; + if (type1 == short_unsigned_type_node) + return short_integer_type_node; + if (type1 == long_unsigned_type_node) + return long_integer_type_node; + if (type1 == long_long_unsigned_type_node) + return long_long_integer_type_node; + +#if HOST_BITS_PER_WIDE_INT >= 64 + if (type1 == unsigned_intTI_type_node) + return intTI_type_node; +#endif + if (type1 == unsigned_intDI_type_node) + return intDI_type_node; + if (type1 == unsigned_intSI_type_node) + return intSI_type_node; + if (type1 == unsigned_intHI_type_node) + return intHI_type_node; + if (type1 == unsigned_intQI_type_node) + return intQI_type_node; + + return m2type_gm2_signed_or_unsigned_type (FALSE, type); +} + +/* check_type if the precision of baseType and type are the same + then return true and set the signed or unsigned type in result + else return false. */ + +static int +check_type (tree baseType, tree type, int unsignedp, tree baseu, tree bases, + tree *result) +{ + if (TYPE_PRECISION (baseType) == TYPE_PRECISION (type)) + { + if (unsignedp) + *result = baseu; + else + *result = bases; + return TRUE; + } + return FALSE; +} + +/* gm2_signed_or_unsigned_type return a type the same as TYPE + except unsigned or signed according to UNSIGNEDP. */ + +tree +m2type_gm2_signed_or_unsigned_type (int unsignedp, tree type) +{ + tree result; + + if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp) + return type; + + /* For INTEGER_TYPEs we must check the precision as well, so as to + yield correct results for bit-field types. */ + + if (check_type (signed_char_type_node, type, unsignedp, + unsigned_char_type_node, signed_char_type_node, &result)) + return result; + if (check_type (integer_type_node, type, unsignedp, unsigned_type_node, + integer_type_node, &result)) + return result; + if (check_type (short_integer_type_node, type, unsignedp, + short_unsigned_type_node, short_integer_type_node, &result)) + return result; + if (check_type (long_integer_type_node, type, unsignedp, + long_unsigned_type_node, long_integer_type_node, &result)) + return result; + if (check_type (long_long_integer_type_node, type, unsignedp, + long_long_unsigned_type_node, long_long_integer_type_node, + &result)) + return result; + +#if HOST_BITS_PER_WIDE_INT >= 64 + if (check_type (intTI_type_node, type, unsignedp, unsigned_intTI_type_node, + intTI_type_node, &result)) + return result; +#endif + if (check_type (intDI_type_node, type, unsignedp, unsigned_intDI_type_node, + intDI_type_node, &result)) + return result; + if (check_type (intSI_type_node, type, unsignedp, unsigned_intSI_type_node, + intSI_type_node, &result)) + return result; + if (check_type (intHI_type_node, type, unsignedp, unsigned_intHI_type_node, + intHI_type_node, &result)) + return result; + if (check_type (intQI_type_node, type, unsignedp, unsigned_intQI_type_node, + intQI_type_node, &result)) + return result; +#undef TYPE_OK + + return type; +} + +/* IsAddress returns TRUE if the type is an ADDRESS. */ + +int +m2type_IsAddress (tree type) +{ + return type == ptr_type_node; +} + +#include "gt-m2-m2type.h"