From patchwork Tue Dec 6 19:27:39 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Gaius Mulley X-Patchwork-Id: 61606 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 5A6363871F9C for ; Tue, 6 Dec 2022 19:28:31 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 5A6363871F9C DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1670354911; bh=fDrHOKEhw7gLroQQhkwUR7lZ5L1xeRKGHWWliy9Robw=; h=Subject:To:Date:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:From; b=tMFES+mqqGkraWDX8NEFmRXjzOLxoJXq+a/4WvM2fZDZybBiJBb4oq33wQ3tAWqmI yNuCJLVip2Z0AjnweSnRSDttV6jiGcuKACPo63L3w3maNbUkIp5KZa08yKHYmJerYw /U9PkgI5Ouj6I9oZKn8NKyMECSkKSK2ozpFiOrZk= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x42d.google.com (mail-wr1-x42d.google.com [IPv6:2a00:1450:4864:20::42d]) by sourceware.org (Postfix) with ESMTPS id C70743871FA5 for ; Tue, 6 Dec 2022 19:27:44 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org C70743871FA5 Received: by mail-wr1-x42d.google.com with SMTP id o5so24980005wrm.1 for ; Tue, 06 Dec 2022 11:27:44 -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=fDrHOKEhw7gLroQQhkwUR7lZ5L1xeRKGHWWliy9Robw=; b=5tKeq87bBkOvYLButgI/OftWxRx+UCWfsyGfdQj4Z+L1u3qhwYiU73Rf404sjQbE/x N3gtBhLJ1CxwW3J1QCnr4GmHalGCLxsphFQwtmRqzr5GPEoRp89cC4lHRUl9Y28aOfLO qQgNhRIb0buq0r/gKhs9oGcLqquX2ZnnG3fMQFppVwuYJkQUUB8p41iyvmEmFq/55Uw3 yW28Bkg9T4Nq9FKTTpvkdUyvgF4dK9S0Xh08x09WFQCu2YXXqjRE9rYLWnD3czKJLvdO u7P8wnWWsrrEL/FGUldOBpSONcWh/mar+9VOa4etkDEEFYZRkb+n5f5d2EyG9PD0Df2z ufdA== X-Gm-Message-State: ANoB5pnzF7qkrGIlJERgAXTbMsoFFoSny4//DzBqUB5/PCZI11McblIC uxrsj8WCRzLtZdnsfgPn0eibSjqS50s= X-Google-Smtp-Source: AA0mqf7jgZlciVz2vjCMXdIWoIwiy7ZIutrC+dj0XBBSASmRHN4SrBOaxSXwKWdRFOW453T8D4HKig== X-Received: by 2002:adf:dd84:0:b0:242:8a3:6685 with SMTP id x4-20020adfdd84000000b0024208a36685mr33225040wrl.321.1670354862106; Tue, 06 Dec 2022 11:27:42 -0800 (PST) Received: from lancelot ([195.147.220.46]) by smtp.gmail.com with ESMTPSA id e14-20020adff34e000000b0024228b0b932sm21558774wrp.27.2022.12.06.11.27.40 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Dec 2022 11:27:41 -0800 (PST) X-Google-Original-From: Gaius Mulley Received: from gaius by lancelot with local (Exim 4.94.2) (envelope-from ) id 1p2dbP-006uqW-MN for gcc-patches@gcc.gnu.org; Tue, 06 Dec 2022 19:27:39 +0000 Subject: [PATCH v4 15/19] modula2 front end: cc1gm2 additional non modula2 source files To: X-Mailer: mail (GNU Mailutils 3.10) Message-Id: Date: Tue, 06 Dec 2022 19:27:39 +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" Version 4 contains two missed feedback suggestions (namespace in m2pp.cc) and use build_nonstandard_integer_type in gm2-lang.cc:gm2_type_for_size. This patch set contains the .h, .cc and .flex files found in gcc/m2. The files are tightly coupled with the gimple interface (see 04-gimple-interface) and built using the rules found in (01-03-make). ------8<----------8<----------8<----------8<----------8<----------8<---- diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-lang.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-lang.cc 2022-12-06 18:18:32.612239623 +0000 @@ -0,0 +1,889 @@ +/* gm2-lang.cc language-dependent hooks for GNU Modula-2. + +Copyright (C) 2002-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 COPYING. If not, write to the +Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ + +#include "gm2-gcc/gcc-consolidation.h" + +#include "langhooks-def.h" /* FIXME: for lhd_set_decl_assembler_name. */ +#include "tree-pass.h" /* FIXME: only for PROP_gimple_any. */ +#include "toplev.h" +#include "debug.h" + +#include "opts.h" + +#define GM2_LANG_C +#include "gm2-lang.h" +#include "m2block.h" +#include "dynamicstrings.h" +#include "m2options.h" +#include "m2convert.h" +#include "m2linemap.h" +#include "init.h" +#include "m2-tree.h" +#include "convert.h" +#include "rtegraph.h" + +static void write_globals (void); + +static int insideCppArgs = FALSE; + +#define EXPR_STMT_EXPR(NODE) TREE_OPERAND (EXPR_STMT_CHECK (NODE), 0) + +/* start of new stuff. */ + +/* Language-dependent contents of a type. */ + +struct GTY (()) lang_type +{ + char dummy; +}; + +/* Language-dependent contents of a decl. */ + +struct GTY (()) lang_decl +{ + char dummy; +}; + +/* Language-dependent contents of an identifier. This must include a + tree_identifier. */ + +struct GTY (()) lang_identifier +{ + struct tree_identifier common; +}; + +/* The resulting tree type. */ + +union GTY ((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"), + chain_next ("CODE_CONTAINS_STRUCT (TREE_CODE (&%h.generic), " + "TS_COMMON) ? ((union lang_tree_node *) TREE_CHAIN " + "(&%h.generic)) : NULL"))) lang_tree_node +{ + union tree_node GTY ((tag ("0"), + desc ("tree_node_structure (&%h)"))) generic; + struct lang_identifier GTY ((tag ("1"))) identifier; +}; + +struct GTY (()) language_function +{ + + /* While we are parsing the function, this contains information about + the statement-tree that we are building. */ + /* struct stmt_tree_s stmt_tree; */ + tree stmt_tree; +}; + +/* Language hooks. */ + +bool +gm2_langhook_init (void) +{ + build_common_tree_nodes (false); + build_common_builtin_nodes (); + + /* The default precision for floating point numbers. This is used + for floating point constants with abstract type. This may eventually + be controllable by a command line option. */ + mpfr_set_default_prec (256); + + /* GNU Modula-2 uses exceptions. */ + using_eh_for_cleanups (); + return true; +} + +/* The option mask. */ + +static unsigned int +gm2_langhook_option_lang_mask (void) +{ + return CL_ModulaX2; +} + +/* Initialize the options structure. */ + +static void +gm2_langhook_init_options_struct (struct gcc_options *opts) +{ + /* Default to avoiding range issues for complex multiply and divide. */ + opts->x_flag_complex_method = 2; + + /* The builtin math functions should not set errno. */ + opts->x_flag_errno_math = 0; + opts->frontend_set_flag_errno_math = true; + + /* Exceptions are used. */ + opts->x_flag_exceptions = 1; + init_FrontEndInit (); +} + +/* Infrastructure for a VEC of bool values. */ + +/* This array determines whether the filename is associated with the + C preprocessor. */ + +static vec filename_cpp; + +void +gm2_langhook_init_options (unsigned int decoded_options_count, + struct cl_decoded_option *decoded_options) +{ + unsigned int i; + bool in_cpp_args = false; + + for (i = 1; i < decoded_options_count; i++) + { + switch (decoded_options[i].opt_index) + { + case OPT_fcpp_begin: + in_cpp_args = true; + break; + case OPT_fcpp_end: + in_cpp_args = false; + break; + case OPT_SPECIAL_input_file: + case OPT_SPECIAL_program_name: + filename_cpp.safe_push (in_cpp_args); + } + } + filename_cpp.safe_push (false); +} + +static bool +is_cpp_filename (unsigned int i) +{ + gcc_assert (i < filename_cpp.length ()); + return filename_cpp[i]; +} + +/* Handle gm2 specific options. Return 0 if we didn't do anything. */ + +bool +gm2_langhook_handle_option ( + size_t scode, const char *arg, HOST_WIDE_INT value, int kind ATTRIBUTE_UNUSED, + location_t loc ATTRIBUTE_UNUSED, + const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED) +{ + enum opt_code code = (enum opt_code)scode; + + /* ignore file names. */ + if (code == N_OPTS) + return 1; + + switch (code) + { + case OPT_B: + M2Options_SetB (arg); + return 1; + case OPT_c: + M2Options_Setc (value); + return 1; + case OPT_I: + if (insideCppArgs) + { + const struct cl_option *option = &cl_options[scode]; + const char *opt = (const char *)option->opt_text; + M2Options_CppArg (opt, arg, TRUE); + } + else + M2Options_SetSearchPath (arg); + return 1; + case OPT_fiso: + M2Options_SetISO (value); + return 1; + case OPT_fpim: + M2Options_SetPIM (value); + return 1; + case OPT_fpim2: + M2Options_SetPIM2 (value); + return 1; + case OPT_fpim3: + M2Options_SetPIM3 (value); + return 1; + case OPT_fpim4: + M2Options_SetPIM4 (value); + return 1; + case OPT_fpositive_mod_floor_div: + M2Options_SetPositiveModFloor (value); + return 1; + case OPT_flibs_: + /* handled in the gm2 driver. */ + return 1; + case OPT_fgen_module_list_: + M2Options_SetGenModuleList (value, arg); + return 1; + case OPT_fnil: + M2Options_SetNilCheck (value); + return 1; + case OPT_fwholediv: + M2Options_SetWholeDiv (value); + return 1; + case OPT_findex: + M2Options_SetIndex (value); + return 1; + case OPT_frange: + M2Options_SetRange (value); + return 1; + case OPT_ffloatvalue: + M2Options_SetFloatValueCheck (value); + return 1; + case OPT_fwholevalue: + M2Options_SetWholeValueCheck (value); + return 1; + case OPT_freturn: + M2Options_SetReturnCheck (value); + return 1; + case OPT_fcase: + M2Options_SetCaseCheck (value); + return 1; + case OPT_fd: + M2Options_SetCompilerDebugging (value); + return 1; + case OPT_fdebug_trace_quad: + M2Options_SetDebugTraceQuad (value); + return 1; + case OPT_fdebug_trace_api: + M2Options_SetDebugTraceAPI (value); + return 1; + case OPT_fdebug_function_line_numbers: + M2Options_SetDebugFunctionLineNumbers (value); + return 1; + case OPT_fauto_init: + M2Options_SetAutoInit (value); + return 1; + case OPT_fsoft_check_all: + M2Options_SetCheckAll (value); + return 1; + case OPT_fexceptions: + M2Options_SetExceptions (value); + return 1; + case OPT_Wstyle: + M2Options_SetStyle (value); + return 1; + case OPT_Wpedantic: + M2Options_SetPedantic (value); + return 1; + case OPT_Wpedantic_param_names: + M2Options_SetPedanticParamNames (value); + return 1; + case OPT_Wpedantic_cast: + M2Options_SetPedanticCast (value); + return 1; + case OPT_fextended_opaque: + M2Options_SetExtendedOpaque (value); + return 1; + case OPT_Wverbose_unbounded: + M2Options_SetVerboseUnbounded (value); + return 1; + case OPT_Wunused_variable: + M2Options_SetUnusedVariableChecking (value); + return 1; + case OPT_Wunused_parameter: + M2Options_SetUnusedParameterChecking (value); + return 1; + case OPT_fm2_strict_type: + M2Options_SetStrictTypeChecking (value); + return 1; + case OPT_Wall: + M2Options_SetWall (value); + return 1; + case OPT_fxcode: + M2Options_SetXCode (value); + return 1; + case OPT_fm2_lower_case: + M2Options_SetLowerCaseKeywords (value); + return 1; + case OPT_fuse_list_: + M2Options_SetUselist (value, arg); + return 1; + case OPT_fruntime_modules_: + M2Options_SetRuntimeModuleOverride (arg); + return 1; + case OPT_fpthread: + /* handled in the driver. */ + return 1; + case OPT_fm2_plugin: + /* handled in the driver. */ + return 1; + case OPT_fscaffold_dynamic: + M2Options_SetScaffoldDynamic (value); + return 1; + case OPT_fscaffold_static: + M2Options_SetScaffoldStatic (value); + return 1; + case OPT_fscaffold_main: + M2Options_SetScaffoldMain (value); + return 1; + case OPT_fcpp: + M2Options_SetCpp (value); + return 1; + case OPT_fcpp_begin: + insideCppArgs = TRUE; + return 1; + case OPT_fcpp_end: + insideCppArgs = FALSE; + return 1; + case OPT_fq: + M2Options_SetQuadDebugging (value); + return 1; + case OPT_fsources: + M2Options_SetSources (value); + return 1; + case OPT_funbounded_by_reference: + M2Options_SetUnboundedByReference (value); + return 1; + case OPT_fdef_: + M2Options_setdefextension (arg); + return 1; + case OPT_fmod_: + M2Options_setmodextension (arg); + return 1; + case OPT_fdump_system_exports: + M2Options_SetDumpSystemExports (value); + return 1; + case OPT_fswig: + M2Options_SetSwig (value); + return 1; + case OPT_fshared: + M2Options_SetShared (value); + return 1; + case OPT_fm2_statistics: + M2Options_SetStatistics (value); + return 1; + case OPT_fm2_g: + M2Options_SetM2g (value); + return 1; + case OPT_O: + M2Options_SetOptimizing (value); + return 1; + case OPT_quiet: + M2Options_SetQuiet (value); + return 1; + case OPT_fm2_whole_program: + M2Options_SetWholeProgram (value); + return 1; + case OPT_flocation_: + if (strcmp (arg, "builtins") == 0) + { + M2Options_SetForcedLocation (BUILTINS_LOCATION); + return 1; + } + else if (strcmp (arg, "unknown") == 0) + { + M2Options_SetForcedLocation (UNKNOWN_LOCATION); + return 1; + } + else if ((arg != NULL) && (ISDIGIT (arg[0]))) + { + M2Options_SetForcedLocation (atoi (arg)); + return 1; + } + else + return 0; + case OPT_save_temps: + M2Options_SetSaveTemps (value); + return 1; + case OPT_save_temps_: + M2Options_SetSaveTempsDir (arg); + return 1; + default: + if (insideCppArgs) + { + const struct cl_option *option = &cl_options[scode]; + const char *opt = (const char *)option->opt_text; + + M2Options_CppArg (opt, arg, TRUE); + return 1; + } + return 0; + } + return 0; +} + +/* Run after parsing options. */ + +static bool +gm2_langhook_post_options (const char **pfilename) +{ + const char *filename = *pfilename; + flag_excess_precision = EXCESS_PRECISION_FAST; + M2Options_SetCC1Quiet (quiet_flag); + M2Options_FinaliseOptions (); + main_input_filename = filename; + + /* Returning false means that the backend should be used. */ + return false; +} + +/* Call the compiler for every source filename on the command line. */ + +static void +gm2_parse_input_files (const char **filenames, unsigned int filename_count) +{ + unsigned int i; + gcc_assert (filename_count > 0); + + for (i = 0; i < filename_count; i++) + if (!is_cpp_filename (i)) + { + main_input_filename = filenames[i]; + init_PerCompilationInit (filenames[i]); + } +} + +static void +gm2_langhook_parse_file (void) +{ + gm2_parse_input_files (in_fnames, num_in_fnames); + write_globals (); +} + +static tree +gm2_langhook_type_for_size (unsigned int bits, int unsignedp) +{ + return gm2_type_for_size (bits, unsignedp); +} + +static tree +gm2_langhook_type_for_mode (machine_mode mode, int unsignedp) +{ + tree type; + + for (int i = 0; i < NUM_INT_N_ENTS; i ++) + if (int_n_enabled_p[i] + && mode == int_n_data[i].m) + return (unsignedp ? int_n_trees[i].unsigned_type + : int_n_trees[i].signed_type); + + if (VECTOR_MODE_P (mode)) + { + tree inner; + + inner = gm2_langhook_type_for_mode (GET_MODE_INNER (mode), unsignedp); + if (inner != NULL_TREE) + return build_vector_type_for_mode (inner, mode); + return NULL_TREE; + } + + scalar_int_mode imode; + if (is_int_mode (mode, &imode)) + return gm2_langhook_type_for_size (GET_MODE_BITSIZE (imode), unsignedp); + + if (mode == TYPE_MODE (float_type_node)) + return float_type_node; + + if (mode == TYPE_MODE (double_type_node)) + return double_type_node; + + if (mode == TYPE_MODE (long_double_type_node)) + return long_double_type_node; + + if (COMPLEX_MODE_P (mode)) + { + if (mode == TYPE_MODE (complex_float_type_node)) + return complex_float_type_node; + if (mode == TYPE_MODE (complex_double_type_node)) + return complex_double_type_node; + if (mode == TYPE_MODE (complex_long_double_type_node)) + return complex_long_double_type_node; + } + +#if HOST_BITS_PER_WIDE_INT >= 64 + /* The middle-end and some backends rely on TImode being supported + for 64-bit HWI. */ + if (mode == TImode) + { + type = build_nonstandard_integer_type (GET_MODE_BITSIZE (TImode), + unsignedp); + if (type && TYPE_MODE (type) == TImode) + return type; + } +#endif + return NULL_TREE; +} + +/* Record a builtin function. We just ignore builtin functions. */ + +static tree +gm2_langhook_builtin_function (tree decl) +{ + return decl; +} + +/* Return true if we are in the global binding level. */ + +static bool +gm2_langhook_global_bindings_p (void) +{ + return current_function_decl == NULL_TREE; +} + +/* Unused langhook. */ + +static tree +gm2_langhook_pushdecl (tree decl ATTRIBUTE_UNUSED) +{ + gcc_unreachable (); +} + +/* This hook is used to get the current list of declarations as trees. + We don't support that; instead we use write_globals. This can't + simply crash because it is called by -gstabs. */ + +static tree +gm2_langhook_getdecls (void) +{ + return NULL; +} + +/* m2_write_global_declarations writes out globals creating an array + of the declarations and calling wrapup_global_declarations. */ + +static void +m2_write_global_declarations (tree globals) +{ + auto_vec global_decls; + tree decl = globals; + int n = 0; + + while (decl != NULL) + { + global_decls.safe_push (decl); + decl = TREE_CHAIN (decl); + n++; + } + wrapup_global_declarations (global_decls.address (), n); +} + +/* Write out globals. */ + +static void +write_globals (void) +{ + tree t; + unsigned i; + + m2block_finishGlobals (); + + /* Process all file scopes in this compilation, and the + external_scope, through wrapup_global_declarations and + check_global_declarations. */ + FOR_EACH_VEC_ELT (*all_translation_units, i, t) + m2_write_global_declarations (BLOCK_VARS (DECL_INITIAL (t))); +} + + +/* Gimplify an EXPR_STMT node. */ + +static void +gimplify_expr_stmt (tree *stmt_p) +{ + gcc_assert (EXPR_STMT_EXPR (*stmt_p) != NULL_TREE); + *stmt_p = EXPR_STMT_EXPR (*stmt_p); +} + +/* Genericize a TRY_BLOCK. */ + +static void +genericize_try_block (tree *stmt_p) +{ + tree body = TRY_STMTS (*stmt_p); + tree cleanup = TRY_HANDLERS (*stmt_p); + + *stmt_p = build2 (TRY_CATCH_EXPR, void_type_node, body, cleanup); +} + +/* Genericize a HANDLER by converting to a CATCH_EXPR. */ + +static void +genericize_catch_block (tree *stmt_p) +{ + tree type = HANDLER_TYPE (*stmt_p); + tree body = HANDLER_BODY (*stmt_p); + + /* FIXME should the caught type go in TREE_TYPE? */ + *stmt_p = build2 (CATCH_EXPR, void_type_node, type, body); +} + +/* Convert the tree representation of FNDECL from m2 frontend trees + to GENERIC. */ + +extern void pf (tree); + +void +gm2_genericize (tree fndecl) +{ + tree t; + struct cgraph_node *cgn; + +#if 0 + pf (fndecl); +#endif + /* Fix up the types of parms passed by invisible reference. */ + for (t = DECL_ARGUMENTS (fndecl); t; t = DECL_CHAIN (t)) + if (TREE_ADDRESSABLE (TREE_TYPE (t))) + { + + /* If a function's arguments are copied to create a thunk, then + DECL_BY_REFERENCE will be set -- but the type of the argument will be + a pointer type, so we will never get here. */ + gcc_assert (!DECL_BY_REFERENCE (t)); + gcc_assert (DECL_ARG_TYPE (t) != TREE_TYPE (t)); + TREE_TYPE (t) = DECL_ARG_TYPE (t); + DECL_BY_REFERENCE (t) = 1; + TREE_ADDRESSABLE (t) = 0; + relayout_decl (t); + } + + /* Dump all nested functions now. */ + cgn = cgraph_node::get_create (fndecl); + for (cgn = first_nested_function (cgn); + cgn != NULL; cgn = next_nested_function (cgn)) + gm2_genericize (cgn->decl); +} + +/* gm2 gimplify expression, currently just change THROW in the same + way as C++ */ + +static int +gm2_langhook_gimplify_expr (tree *expr_p, gimple_seq *pre_p ATTRIBUTE_UNUSED, + gimple_seq *post_p ATTRIBUTE_UNUSED) +{ + enum tree_code code = TREE_CODE (*expr_p); + + switch (code) + { + case THROW_EXPR: + + /* FIXME communicate throw type to back end, probably by moving + THROW_EXPR into ../tree.def. */ + *expr_p = TREE_OPERAND (*expr_p, 0); + return GS_OK; + + case EXPR_STMT: + gimplify_expr_stmt (expr_p); + return GS_OK; + + case TRY_BLOCK: + genericize_try_block (expr_p); + return GS_OK; + + case HANDLER: + genericize_catch_block (expr_p); + return GS_OK; + + default: + return GS_UNHANDLED; + } +} + +static GTY(()) tree gm2_eh_personality_decl; + +static tree +gm2_langhook_eh_personality (void) +{ + if (!gm2_eh_personality_decl) + gm2_eh_personality_decl = build_personality_function ("gxx"); + + return gm2_eh_personality_decl; +} + +/* Functions called directly by the generic backend. */ + +tree +convert_loc (location_t location, tree type, tree expr) +{ + if (type == error_mark_node || expr == error_mark_node + || TREE_TYPE (expr) == error_mark_node) + return error_mark_node; + + if (type == TREE_TYPE (expr)) + return expr; + + gcc_assert (TYPE_MAIN_VARIANT (type) != NULL); + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr))) + return fold_convert (type, expr); + + expr = m2convert_GenericToType (location, type, expr); + switch (TREE_CODE (type)) + { + case VOID_TYPE: + case BOOLEAN_TYPE: + return fold_convert (type, expr); + case INTEGER_TYPE: + return fold (convert_to_integer (type, expr)); + case POINTER_TYPE: + return fold (convert_to_pointer (type, expr)); + case REAL_TYPE: + return fold (convert_to_real (type, expr)); + case COMPLEX_TYPE: + return fold (convert_to_complex (type, expr)); + case ENUMERAL_TYPE: + return fold (convert_to_integer (type, expr)); + default: + error_at (location, "cannot convert expression, only base types can be converted"); + break; + } + return error_mark_node; +} + +/* Functions called directly by the generic backend. */ + +tree +convert (tree type, tree expr) +{ + return convert_loc (m2linemap_UnknownLocation (), type, expr); +} + +/* Mark EXP saying that we need to be able to take the address of it; + it should not be allocated in a register. Returns true if + successful. */ + +bool +gm2_mark_addressable (tree exp) +{ + tree x = exp; + + while (TRUE) + switch (TREE_CODE (x)) + { + case COMPONENT_REF: + if (DECL_PACKED (TREE_OPERAND (x, 1))) + return false; + x = TREE_OPERAND (x, 0); + break; + + case ADDR_EXPR: + case ARRAY_REF: + case REALPART_EXPR: + case IMAGPART_EXPR: + x = TREE_OPERAND (x, 0); + break; + + case COMPOUND_LITERAL_EXPR: + case CONSTRUCTOR: + case STRING_CST: + case VAR_DECL: + case CONST_DECL: + case PARM_DECL: + case RESULT_DECL: + case FUNCTION_DECL: + TREE_ADDRESSABLE (x) = 1; + return true; + default: + return true; + } + /* Never reach here. */ + gcc_unreachable (); +} + +/* Return an integer type with BITS bits of precision, that is + unsigned if UNSIGNEDP is nonzero, otherwise signed. */ + +tree +gm2_type_for_size (unsigned int bits, int unsignedp) +{ + tree type; + + if (unsignedp) + { + if (bits == INT_TYPE_SIZE) + type = unsigned_type_node; + else if (bits == CHAR_TYPE_SIZE) + type = unsigned_char_type_node; + else if (bits == SHORT_TYPE_SIZE) + type = short_unsigned_type_node; + else if (bits == LONG_TYPE_SIZE) + type = long_unsigned_type_node; + else if (bits == LONG_LONG_TYPE_SIZE) + type = long_long_unsigned_type_node; + else + type = build_nonstandard_integer_type (bits, + unsignedp); + } + else + { + if (bits == INT_TYPE_SIZE) + type = integer_type_node; + else if (bits == CHAR_TYPE_SIZE) + type = signed_char_type_node; + else if (bits == SHORT_TYPE_SIZE) + type = short_integer_type_node; + else if (bits == LONG_TYPE_SIZE) + type = long_integer_type_node; + else if (bits == LONG_LONG_TYPE_SIZE) + type = long_long_integer_type_node; + else + type = build_nonstandard_integer_type (bits, + unsignedp); + } + return type; +} + +/* Allow the analyzer to understand Storage ALLOCATE/DEALLOCATE. */ + +bool +gm2_langhook_new_dispose_storage_substitution (void) +{ + return true; +} + +#undef LANG_HOOKS_NAME +#undef LANG_HOOKS_INIT +#undef LANG_HOOKS_INIT_OPTIONS +#undef LANG_HOOKS_OPTION_LANG_MASK +#undef LANG_HOOKS_INIT_OPTIONS_STRUCT +#undef LANG_HOOKS_HANDLE_OPTION +#undef LANG_HOOKS_POST_OPTIONS +#undef LANG_HOOKS_PARSE_FILE +#undef LANG_HOOKS_TYPE_FOR_MODE +#undef LANG_HOOKS_TYPE_FOR_SIZE +#undef LANG_HOOKS_BUILTIN_FUNCTION +#undef LANG_HOOKS_GLOBAL_BINDINGS_P +#undef LANG_HOOKS_PUSHDECL +#undef LANG_HOOKS_GETDECLS +#undef LANG_HOOKS_GIMPLIFY_EXPR +#undef LANG_HOOKS_EH_PERSONALITY +#undef LANG_HOOKS_NEW_DISPOSE_STORAGE_SUBSTITUTION + +#define LANG_HOOKS_NAME "GNU Modula-2" +#define LANG_HOOKS_INIT gm2_langhook_init +#define LANG_HOOKS_INIT_OPTIONS gm2_langhook_init_options +#define LANG_HOOKS_OPTION_LANG_MASK gm2_langhook_option_lang_mask +#define LANG_HOOKS_INIT_OPTIONS_STRUCT gm2_langhook_init_options_struct +#define LANG_HOOKS_HANDLE_OPTION gm2_langhook_handle_option +#define LANG_HOOKS_POST_OPTIONS gm2_langhook_post_options +#define LANG_HOOKS_PARSE_FILE gm2_langhook_parse_file +#define LANG_HOOKS_TYPE_FOR_MODE gm2_langhook_type_for_mode +#define LANG_HOOKS_TYPE_FOR_SIZE gm2_langhook_type_for_size +#define LANG_HOOKS_BUILTIN_FUNCTION gm2_langhook_builtin_function +#define LANG_HOOKS_GLOBAL_BINDINGS_P gm2_langhook_global_bindings_p +#define LANG_HOOKS_PUSHDECL gm2_langhook_pushdecl +#define LANG_HOOKS_GETDECLS gm2_langhook_getdecls +#define LANG_HOOKS_GIMPLIFY_EXPR gm2_langhook_gimplify_expr +#define LANG_HOOKS_EH_PERSONALITY gm2_langhook_eh_personality +#define LANG_HOOKS_NEW_DISPOSE_STORAGE_SUBSTITUTION \ + gm2_langhook_new_dispose_storage_substitution + +struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; + +#include "gt-m2-gm2-lang.h" +#include "gtype-m2.h" diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-lang.h --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2-lang.h 2022-12-06 02:56:51.344774733 +0000 @@ -0,0 +1,56 @@ +/* Language-dependent hooks for GNU Modula-2. + Copyright (C) 2003-2022 Free Software Foundation, Inc. + Contributed by Gaius Mulley + +This file is part of GNU CC. + +GNU CC 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 CC 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 CC; see the file COPYING. If not, write to +the Free Software Foundation, 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. */ + +#if !defined(GM2_LANG_H) +# define GM2_LANG_H + +#if defined(GM2_LANG_C) +# define EXTERN +#else +# define EXTERN extern +#endif +#include "config.h" +#include "system.h" +#include "ansidecl.h" +#include "coretypes.h" +#include "opts.h" +#include "tree.h" +#include "gimple.h" + + +EXTERN enum gimplify_status gm2_gimplify_expr (tree *, tree *, tree *); +EXTERN bool gm2_mark_addressable (tree); +EXTERN tree gm2_type_for_size (unsigned int bits, int unsignedp); +EXTERN tree gm2_type_for_mode (enum machine_mode mode, int unsignedp); +EXTERN bool gm2_langhook_init (void); +EXTERN bool gm2_langhook_handle_option (size_t scode, const char *arg, + int value, + int kind ATTRIBUTE_UNUSED, + location_t loc ATTRIBUTE_UNUSED, + const struct cl_option_handlers *handlers ATTRIBUTE_UNUSED); +EXTERN void gm2_langhook_init_options (unsigned int decoded_options_count, + struct cl_decoded_option *decoded_options); +EXTERN void gm2_genericize (tree fndecl); +EXTERN tree convert_loc (location_t location, tree type, tree expr); + + +#undef EXTERN +#endif diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2version.h --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/gm2version.h 2022-12-06 02:56:51.360774949 +0000 @@ -0,0 +1,22 @@ +/* gm2version provides access to the gm2 front end version number. + +Copyright (C) 2008-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 +. */ + +extern void gm2_version (int need_to_exit); diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/m2.flex --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/m2.flex 2022-12-06 02:56:51.360774949 +0000 @@ -0,0 +1,760 @@ +%{ +/* m2.flex implements lexical analysis for Modula-2. + +Copyright (C) 2004-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 "gm2-gcc/gcc-consolidation.h" + +#include "GM2Reserved.h" +#include "GM2LexBuf.h" +#include "input.h" +#include "m2options.h" + + +#if defined(GM2USEGGC) +# include "ggc.h" +#endif + +#include "timevar.h" + +#define START_FILE(F,L) m2linemap_StartFile(F,L) +#define END_FILE() m2linemap_EndFile() +#define START_LINE(N,S) m2linemap_StartLine(N,S) +#define GET_LOCATION(COLUMN_START,COLUMN_END) \ + m2linemap_GetLocationRange(COLUMN_START,COLUMN_END) +#define TIMEVAR_PUSH_LEX timevar_push (TV_LEX) +#define TIMEVAR_POP_LEX timevar_pop (TV_LEX) + +#ifdef __cplusplus +#define EXTERN extern "C" +#endif + + /* m2.flex provides a lexical analyser for GNU Modula-2. */ + + struct lineInfo { + char *linebuf; /* line contents */ + int linelen; /* length */ + int tokenpos; /* start position of token within line */ + int toklen; /* a copy of yylen (length of token) */ + int nextpos; /* position after token */ + int lineno; /* line number of this line */ + int column; /* first column number of token on this line */ + int inuse; /* do we need to keep this line info? */ + location_t location; /* the corresponding gcc location_t */ + struct lineInfo *next; + }; + + struct functionInfo { + char *name; /* function name */ + int module; /* is it really a module? */ + struct functionInfo *next; /* list of nested functions */ + }; + + static int lineno =1; /* a running count of the file line number */ + static char *filename =NULL; + static int commentLevel=0; + static struct lineInfo *currentLine=NULL; + static struct functionInfo *currentFunction=NULL; + static int seenFunctionStart=FALSE; + static int seenEnd=FALSE; + static int seenModuleStart=FALSE; + static int isDefinitionModule=FALSE; + static int totalLines=0; + +static void pushLine (void); +static void popLine (void); +static void finishedLine (void); +static void resetpos (void); +static void consumeLine (void); +static void updatepos (void); +static void skippos (void); +static void poperrorskip (const char *); +static void endOfComment (void); +static void handleDate (void); +static void handleLine (void); +static void handleFile (void); +static void handleFunction (void); +static void handleColumn (void); +static void pushFunction (char *function, int module); +static void popFunction (void); +static void checkFunction (void); +EXTERN void m2flex_M2Error (const char *); +EXTERN location_t m2flex_GetLocation (void); +EXTERN int m2flex_GetColumnNo (void); +EXTERN int m2flex_OpenSource (char *s); +EXTERN int m2flex_GetLineNo (void); +EXTERN void m2flex_CloseSource (void); +EXTERN char *m2flex_GetToken (void); +EXTERN void _M2_m2flex_init (void); +EXTERN int m2flex_GetTotalLines (void); +extern void yylex (void); + +#if !defined(TRUE) +# define TRUE (1==1) +#endif +#if !defined(FALSE) +# define FALSE (1==0) +#endif + +#define YY_DECL void yylex (void) +%} + +%option nounput +%x COMMENT COMMENT1 LINE0 LINE1 LINE2 + +%% + +"(*" { updatepos(); + commentLevel=1; pushLine(); skippos(); + BEGIN COMMENT; } +"*)" { endOfComment(); } +"(*" { commentLevel++; pushLine(); updatepos(); skippos(); } +"<*" { if (commentLevel == 1) { + updatepos(); + pushLine(); + skippos(); + BEGIN COMMENT1; + } else + updatepos(); skippos(); + } +\n.* { consumeLine(); } +. { updatepos(); skippos(); } +. { updatepos(); skippos(); } +"*>" { updatepos(); skippos(); finishedLine(); BEGIN COMMENT; } +\n.* { consumeLine(); } +"*)" { poperrorskip("unterminated source code directive, missing *>"); + endOfComment(); } +<> { poperrorskip("unterminated source code directive, missing *>"); BEGIN COMMENT; } +<> { poperrorskip("unterminated comment found at the end of the file, missing *)"); BEGIN INITIAL; } + +^\#.* { consumeLine(); /* printf("found: %s\n", currentLine->linebuf); */ BEGIN LINE0; } +\n\#.* { consumeLine(); /* printf("found: %s\n", currentLine->linebuf); */ BEGIN LINE0; } +\#[ \t]* { updatepos(); } +[0-9]+[ \t]*\" { updatepos(); lineno=atoi(yytext)-1; BEGIN LINE1; } +\n { m2flex_M2Error("missing initial quote after #line directive"); resetpos(); BEGIN INITIAL; } +[^\n] +[^\"\n]+ { m2flex_M2Error("missing final quote after #line directive"); resetpos(); BEGIN INITIAL; } +.*\" { updatepos(); + filename = (char *)xrealloc(filename, yyleng+1); + strcpy(filename, yytext); + filename[yyleng-1] = (char)0; /* remove trailing quote */ + START_FILE (filename, lineno); + BEGIN LINE2; + } +[ \t]* { updatepos(); } +\n { M2LexBuf_SetFile(filename); updatepos(); BEGIN INITIAL; } +2[ \t]*\n { M2LexBuf_SetFile(filename); updatepos(); BEGIN INITIAL; } +1[ \t]*\n { M2LexBuf_SetFile(filename); updatepos(); BEGIN INITIAL; } +1[ \t]*.*\n { M2LexBuf_SetFile(filename); updatepos(); BEGIN INITIAL; } +2[ \t]*.*\n { M2LexBuf_SetFile(filename); updatepos(); BEGIN INITIAL; } +3[ \t]*.*\n { M2LexBuf_SetFile(filename); updatepos(); BEGIN INITIAL; } + +\n[^\#].* { consumeLine(); /* printf("found: %s\n", currentLine->linebuf); */ } +\n { consumeLine(); /* printf("found: %s\n", currentLine->linebuf); */ } + +\"[^\"\n]*\" { updatepos(); M2LexBuf_AddTokCharStar(M2Reserved_stringtok, yytext); return; } +\"[^\"\n]*$ { updatepos(); + m2flex_M2Error("missing terminating quote, \""); + resetpos(); return; + } + +'[^'\n]*' { updatepos(); M2LexBuf_AddTokCharStar(M2Reserved_stringtok, yytext); return; } +'[^'\n]*$ { updatepos(); + m2flex_M2Error("missing terminating quote, '"); + resetpos(); return; + } + +<> { updatepos(); M2LexBuf_AddTok(M2Reserved_eoftok); return; } +\+ { updatepos(); M2LexBuf_AddTok(M2Reserved_plustok); return; } +- { updatepos(); M2LexBuf_AddTok(M2Reserved_minustok); return; } +"*" { updatepos(); M2LexBuf_AddTok(M2Reserved_timestok); return; } +\/ { updatepos(); M2LexBuf_AddTok(M2Reserved_dividetok); return; } +:= { updatepos(); M2LexBuf_AddTok(M2Reserved_becomestok); return; } +\& { updatepos(); M2LexBuf_AddTok(M2Reserved_ambersandtok); return; } +\. { updatepos(); M2LexBuf_AddTok(M2Reserved_periodtok); return; } +\, { updatepos(); M2LexBuf_AddTok(M2Reserved_commatok); return; } +\; { updatepos(); M2LexBuf_AddTok(M2Reserved_semicolontok); return; } +\( { updatepos(); M2LexBuf_AddTok(M2Reserved_lparatok); return; } +\) { updatepos(); M2LexBuf_AddTok(M2Reserved_rparatok); return; } +\[ { updatepos(); M2LexBuf_AddTok(M2Reserved_lsbratok); return; } +\] { updatepos(); M2LexBuf_AddTok(M2Reserved_rsbratok); return; } +\(\! { updatepos(); M2LexBuf_AddTok(M2Reserved_lsbratok); return; } +\!\) { updatepos(); M2LexBuf_AddTok(M2Reserved_rsbratok); return; } +\^ { updatepos(); M2LexBuf_AddTok(M2Reserved_uparrowtok); return; } +\@ { updatepos(); M2LexBuf_AddTok(M2Reserved_uparrowtok); return; } +\{ { updatepos(); M2LexBuf_AddTok(M2Reserved_lcbratok); return; } +\} { updatepos(); M2LexBuf_AddTok(M2Reserved_rcbratok); return; } +\(\: { updatepos(); M2LexBuf_AddTok(M2Reserved_lcbratok); return; } +\:\) { updatepos(); M2LexBuf_AddTok(M2Reserved_rcbratok); return; } +\' { updatepos(); M2LexBuf_AddTok(M2Reserved_singlequotetok); return; } +\= { updatepos(); M2LexBuf_AddTok(M2Reserved_equaltok); return; } +\# { updatepos(); M2LexBuf_AddTok(M2Reserved_hashtok); return; } +\< { updatepos(); M2LexBuf_AddTok(M2Reserved_lesstok); return; } +\> { updatepos(); M2LexBuf_AddTok(M2Reserved_greatertok); return; } +\<\> { updatepos(); M2LexBuf_AddTok(M2Reserved_lessgreatertok); return; } +\<\= { updatepos(); M2LexBuf_AddTok(M2Reserved_lessequaltok); return; } +\>\= { updatepos(); M2LexBuf_AddTok(M2Reserved_greaterequaltok); return; } +"<*" { updatepos(); M2LexBuf_AddTok(M2Reserved_ldirectivetok); return; } +"*>" { updatepos(); M2LexBuf_AddTok(M2Reserved_rdirectivetok); return; } +\.\. { updatepos(); M2LexBuf_AddTok(M2Reserved_periodperiodtok); return; } +\.\.\. { updatepos(); M2LexBuf_AddTok(M2Reserved_periodperiodperiodtok); return; } +\: { updatepos(); M2LexBuf_AddTok(M2Reserved_colontok); return; } +\" { updatepos(); M2LexBuf_AddTok(M2Reserved_doublequotestok); return; } +\| { updatepos(); M2LexBuf_AddTok(M2Reserved_bartok); return; } +\! { updatepos(); M2LexBuf_AddTok(M2Reserved_bartok); return; } +\~ { updatepos(); M2LexBuf_AddTok(M2Reserved_nottok); return; } +AND { updatepos(); M2LexBuf_AddTok(M2Reserved_andtok); return; } +ARRAY { updatepos(); M2LexBuf_AddTok(M2Reserved_arraytok); return; } +BEGIN { updatepos(); M2LexBuf_AddTok(M2Reserved_begintok); return; } +BY { updatepos(); M2LexBuf_AddTok(M2Reserved_bytok); return; } +CASE { updatepos(); M2LexBuf_AddTok(M2Reserved_casetok); return; } +CONST { updatepos(); M2LexBuf_AddTok(M2Reserved_consttok); return; } +DEFINITION { updatepos(); isDefinitionModule = TRUE; + M2LexBuf_AddTok(M2Reserved_definitiontok); return; } +DIV { updatepos(); M2LexBuf_AddTok(M2Reserved_divtok); return; } +DO { updatepos(); M2LexBuf_AddTok(M2Reserved_dotok); return; } +ELSE { updatepos(); M2LexBuf_AddTok(M2Reserved_elsetok); return; } +ELSIF { updatepos(); M2LexBuf_AddTok(M2Reserved_elsiftok); return; } +END { updatepos(); seenEnd=TRUE; + M2LexBuf_AddTok(M2Reserved_endtok); return; } +EXCEPT { updatepos(); M2LexBuf_AddTok(M2Reserved_excepttok); return; } +EXIT { updatepos(); M2LexBuf_AddTok(M2Reserved_exittok); return; } +EXPORT { updatepos(); M2LexBuf_AddTok(M2Reserved_exporttok); return; } +FINALLY { updatepos(); M2LexBuf_AddTok(M2Reserved_finallytok); return; } +FOR { updatepos(); M2LexBuf_AddTok(M2Reserved_fortok); return; } +FROM { updatepos(); M2LexBuf_AddTok(M2Reserved_fromtok); return; } +IF { updatepos(); M2LexBuf_AddTok(M2Reserved_iftok); return; } +IMPLEMENTATION { updatepos(); M2LexBuf_AddTok(M2Reserved_implementationtok); return; } +IMPORT { updatepos(); M2LexBuf_AddTok(M2Reserved_importtok); return; } +IN { updatepos(); M2LexBuf_AddTok(M2Reserved_intok); return; } +LOOP { updatepos(); M2LexBuf_AddTok(M2Reserved_looptok); return; } +MOD { updatepos(); M2LexBuf_AddTok(M2Reserved_modtok); return; } +MODULE { updatepos(); seenModuleStart=TRUE; + M2LexBuf_AddTok(M2Reserved_moduletok); return; } +NOT { updatepos(); M2LexBuf_AddTok(M2Reserved_nottok); return; } +OF { updatepos(); M2LexBuf_AddTok(M2Reserved_oftok); return; } +OR { updatepos(); M2LexBuf_AddTok(M2Reserved_ortok); return; } +PACKEDSET { updatepos(); M2LexBuf_AddTok(M2Reserved_packedsettok); return; } +POINTER { updatepos(); M2LexBuf_AddTok(M2Reserved_pointertok); return; } +PROCEDURE { updatepos(); seenFunctionStart=TRUE; + M2LexBuf_AddTok(M2Reserved_proceduretok); return; } +QUALIFIED { updatepos(); M2LexBuf_AddTok(M2Reserved_qualifiedtok); return; } +UNQUALIFIED { updatepos(); M2LexBuf_AddTok(M2Reserved_unqualifiedtok); return; } +RECORD { updatepos(); M2LexBuf_AddTok(M2Reserved_recordtok); return; } +REM { updatepos(); M2LexBuf_AddTok(M2Reserved_remtok); return; } +REPEAT { updatepos(); M2LexBuf_AddTok(M2Reserved_repeattok); return; } +RETRY { updatepos(); M2LexBuf_AddTok(M2Reserved_retrytok); return; } +RETURN { updatepos(); M2LexBuf_AddTok(M2Reserved_returntok); return; } +SET { updatepos(); M2LexBuf_AddTok(M2Reserved_settok); return; } +THEN { updatepos(); M2LexBuf_AddTok(M2Reserved_thentok); return; } +TO { updatepos(); M2LexBuf_AddTok(M2Reserved_totok); return; } +TYPE { updatepos(); M2LexBuf_AddTok(M2Reserved_typetok); return; } +UNTIL { updatepos(); M2LexBuf_AddTok(M2Reserved_untiltok); return; } +VAR { updatepos(); M2LexBuf_AddTok(M2Reserved_vartok); return; } +WHILE { updatepos(); M2LexBuf_AddTok(M2Reserved_whiletok); return; } +WITH { updatepos(); M2LexBuf_AddTok(M2Reserved_withtok); return; } +ASM { updatepos(); M2LexBuf_AddTok(M2Reserved_asmtok); return; } +VOLATILE { updatepos(); M2LexBuf_AddTok(M2Reserved_volatiletok); return; } +\_\_DATE\_\_ { updatepos(); handleDate(); return; } +\_\_LINE\_\_ { updatepos(); handleLine(); return; } +\_\_FILE\_\_ { updatepos(); handleFile(); return; } +\_\_FUNCTION\_\_ { updatepos(); handleFunction(); return; } +\_\_COLUMN\_\_ { updatepos(); handleColumn(); return; } +\_\_ATTRIBUTE\_\_ { updatepos(); M2LexBuf_AddTok(M2Reserved_attributetok); return; } +\_\_BUILTIN\_\_ { updatepos(); M2LexBuf_AddTok(M2Reserved_builtintok); return; } +\_\_INLINE\_\_ { updatepos(); M2LexBuf_AddTok(M2Reserved_inlinetok); return; } + + +(([0-9]*\.[0-9]+)(E[+-]?[0-9]+)?) { updatepos(); M2LexBuf_AddTokCharStar(M2Reserved_realtok, yytext); return; } +[0-9]*\.E[+-]?[0-9]+ { updatepos(); M2LexBuf_AddTokCharStar(M2Reserved_realtok, yytext); return; } +[a-zA-Z_][a-zA-Z0-9_]* { checkFunction(); updatepos(); M2LexBuf_AddTokCharStar(M2Reserved_identtok, yytext); return; } +[0-9]+ { updatepos(); M2LexBuf_AddTokCharStar(M2Reserved_integertok, yytext); return; } +[0-9]+B { updatepos(); M2LexBuf_AddTokCharStar(M2Reserved_integertok, yytext); return; } +[0-9]+C { updatepos(); M2LexBuf_AddTokCharStar(M2Reserved_integertok, yytext); return; } +[0-9A-F]+H { updatepos(); M2LexBuf_AddTokCharStar(M2Reserved_integertok, yytext); return; } +[\t\r ]+ { currentLine->tokenpos += yyleng; /* Ignore space. */; } +. { updatepos(); m2flex_M2Error("unrecognised symbol"); skippos(); } + +%% + +/* have removed the -? from the beginning of the real/integer constant literal rules */ + +/* + * hand built routines + */ + +/* + * handleFile - handles the __FILE__ construct by wraping it in double quotes and putting + * it into the token buffer as a string. + */ + +static void handleFile (void) +{ + char *s = (char *)alloca(strlen(filename)+2+1); + + strcpy(s, "\""); + strcat(s, filename); + strcat(s, "\""); + M2LexBuf_AddTokCharStar(M2Reserved_stringtok, s); +} + +/* + * handleLine - handles the __LINE__ construct by passing an integer to + * the token buffer. + */ + +static void handleLine (void) +{ + M2LexBuf_AddTokInteger(M2Reserved_integertok, lineno); +} + +/* + * handleColumn - handles the __COLUMN__ construct by passing an integer to + * the token buffer. + */ + +static void handleColumn (void) +{ + M2LexBuf_AddTokInteger(M2Reserved_integertok, m2flex_GetColumnNo()); +} + +/* + * handleDate - handles the __DATE__ construct by passing the date + * as a string to the token buffer. + */ + +static void handleDate (void) +{ + time_t clock = time ((time_t *)0); + char *sdate = ctime (&clock); + char *s = (char *) alloca (strlen (sdate) + 2 + 1); + char *p = index (sdate, '\n'); + + if (p != NULL) { + *p = (char) 0; + } + strcpy(s, "\""); + strcat(s, sdate); + strcat(s, "\""); + M2LexBuf_AddTokCharStar (M2Reserved_stringtok, s); +} + +/* + * handleFunction - handles the __FUNCTION__ construct by wrapping + * it in double quotes and putting it into the token + * buffer as a string. + */ + +static void handleFunction (void) +{ + if (currentFunction == NULL) + M2LexBuf_AddTokCharStar(M2Reserved_stringtok, const_cast("\"\"")); + else if (currentFunction->module) { + char *s = (char *) alloca(strlen(yytext) + + strlen("\"module initialization\"") + 1); + strcpy(s, "\"module "); + strcat(s, currentFunction->name); + strcat(s, " initialization\""); + M2LexBuf_AddTokCharStar(M2Reserved_stringtok, s); + } else { + char *function = currentFunction->name; + char *s = (char *)alloca(strlen(function)+2+1); + strcpy(s, "\""); + strcat(s, function); + strcat(s, "\""); + M2LexBuf_AddTokCharStar(M2Reserved_stringtok, s); + } +} + +/* + * pushFunction - pushes the function name onto the stack. + */ + +static void pushFunction (char *function, int module) +{ + if (currentFunction == NULL) { + currentFunction = (struct functionInfo *)xmalloc (sizeof (struct functionInfo)); + currentFunction->name = xstrdup(function); + currentFunction->next = NULL; + currentFunction->module = module; + } else { + struct functionInfo *f = (struct functionInfo *)xmalloc (sizeof (struct functionInfo)); + f->name = xstrdup(function); + f->next = currentFunction; + f->module = module; + currentFunction = f; + } +} + +/* + * popFunction - pops the current function. + */ + +static void popFunction (void) +{ + if (currentFunction != NULL && currentFunction->next != NULL) { + struct functionInfo *f = currentFunction; + + currentFunction = currentFunction->next; + if (f->name != NULL) + free(f->name); + free(f); + } +} + +/* + * endOfComment - handles the end of comment + */ + +static void endOfComment (void) +{ + commentLevel--; + updatepos(); + skippos(); + if (commentLevel==0) { + BEGIN INITIAL; + finishedLine(); + } else + popLine(); +} + +/* + * m2flex_M2Error - displays the error message, s, after the code line and pointer + * to the erroneous token. + */ + +EXTERN void m2flex_M2Error (const char *s) +{ + if (currentLine->linebuf != NULL) { + int i=1; + + printf("%s:%d:%s\n", filename, currentLine->lineno, currentLine->linebuf); + printf("%s:%d:%*s", filename, currentLine->lineno, 1+currentLine->tokenpos, "^"); + while (itoklen) { + putchar('^'); + i++; + } + putchar('\n'); + } + printf("%s:%d:%s\n", filename, currentLine->lineno, s); +} + +static void poperrorskip (const char *s) +{ + int nextpos =currentLine->nextpos; + int tokenpos=currentLine->tokenpos; + + popLine(); + m2flex_M2Error(s); + if (currentLine != NULL) { + currentLine->nextpos = nextpos; + currentLine->tokenpos = tokenpos; + } +} + +/* + * consumeLine - reads a line into a buffer, it then pushes back the whole + * line except the initial \n. + */ + +static void consumeLine (void) +{ + if (currentLine->linelenlinebuf = (char *)xrealloc (currentLine->linebuf, yyleng); + currentLine->linelen = yyleng; + } + strcpy(currentLine->linebuf, yytext+1); /* copy all except the initial \n */ + lineno++; + totalLines++; + currentLine->lineno = lineno; + currentLine->tokenpos=0; + currentLine->nextpos=0; + currentLine->column=0; + START_LINE (lineno, yyleng); + yyless(1); /* push back all but the \n */ +} + +static void assert_location (location_t location ATTRIBUTE_UNUSED) +{ +#if 0 + if ((location != BUILTINS_LOCATION) && (location != UNKNOWN_LOCATION) && (! M2Options_GetCpp ())) { + expanded_location xl = expand_location (location); + if (xl.line != currentLine->lineno) { + m2flex_M2Error ("mismatched gcc location and front end token number"); + } + } +#endif +} + +/* + * updatepos - updates the current token position. + * Should be used when a rule matches a token. + */ + +static void updatepos (void) +{ + seenFunctionStart = FALSE; + seenEnd = FALSE; + seenModuleStart = FALSE; + currentLine->nextpos = currentLine->tokenpos+yyleng; + currentLine->toklen = yyleng; + /* if (currentLine->column == 0) */ + currentLine->column = currentLine->tokenpos+1; + currentLine->location = + M2Options_OverrideLocation (GET_LOCATION (currentLine->column, + currentLine->column+currentLine->toklen-1)); + assert_location (GET_LOCATION (currentLine->column, + currentLine->column+currentLine->toklen-1)); +} + +/* + * checkFunction - checks to see whether we have seen the start + * or end of a function. + */ + +static void checkFunction (void) +{ + if (! isDefinitionModule) { + if (seenModuleStart) + pushFunction(yytext, 1); + if (seenFunctionStart) + pushFunction(yytext, 0); + if (seenEnd && currentFunction != NULL && + (strcmp(currentFunction->name, yytext) == 0)) + popFunction(); + } + seenFunctionStart = FALSE; + seenEnd = FALSE; + seenModuleStart = FALSE; +} + +/* + * skippos - skips over this token. This function should be called + * if we are not returning and thus not calling getToken. + */ + +static void skippos (void) +{ + currentLine->tokenpos = currentLine->nextpos; +} + +/* + * initLine - initializes a currentLine + */ + +static void initLine (void) +{ + currentLine = (struct lineInfo *)xmalloc (sizeof(struct lineInfo)); + + if (currentLine == NULL) + perror("xmalloc"); + currentLine->linebuf = NULL; + currentLine->linelen = 0; + currentLine->tokenpos = 0; + currentLine->toklen = 0; + currentLine->nextpos = 0; + currentLine->lineno = lineno; + currentLine->column = 0; + currentLine->inuse = TRUE; + currentLine->next = NULL; +} + +/* + * pushLine - pushes a new line structure. + */ + +static void pushLine (void) +{ + if (currentLine == NULL) + initLine(); + else if (currentLine->inuse) { + struct lineInfo *l = (struct lineInfo *)xmalloc (sizeof(struct lineInfo)); + + if (currentLine->linebuf == NULL) { + l->linebuf = NULL; + l->linelen = 0; + } else { + l->linebuf = (char *)xstrdup (currentLine->linebuf); + l->linelen = strlen (l->linebuf)+1; + } + l->tokenpos = currentLine->tokenpos; + l->toklen = currentLine->toklen; + l->nextpos = currentLine->nextpos; + l->lineno = currentLine->lineno; + l->column = currentLine->column; + l->next = currentLine; + currentLine = l; + } + currentLine->inuse = TRUE; +} + +/* + * popLine - pops a line structure. + */ + +static void popLine (void) +{ + if (currentLine != NULL) { + struct lineInfo *l = currentLine; + + if (currentLine->linebuf != NULL) + free(currentLine->linebuf); + currentLine = l->next; + free(l); + } +} + +/* + * resetpos - resets the position of the next token to the start of the line. + */ + +static void resetpos (void) +{ + if (currentLine != NULL) + currentLine->nextpos = 0; +} + +/* + * finishedLine - indicates that the current line does not need to be preserved when a pushLine + * occurs. + */ + +static void finishedLine (void) +{ + currentLine->inuse = FALSE; +} + +/* + * m2flex_GetToken - returns a new token. + */ + +EXTERN char *m2flex_GetToken (void) +{ + TIMEVAR_PUSH_LEX; + if (currentLine == NULL) + initLine(); + currentLine->tokenpos = currentLine->nextpos; + yylex(); + TIMEVAR_POP_LEX; + return yytext; +} + +/* + * CloseSource - provided for semantic sugar + */ + +EXTERN void m2flex_CloseSource (void) +{ + END_FILE (); +} + +/* + * OpenSource - returns TRUE if file s can be opened and + * all tokens are taken from this file. + */ + +EXTERN int m2flex_OpenSource (char *s) +{ + FILE *f = fopen(s, "r"); + + if (f == NULL) + return( FALSE ); + else { + isDefinitionModule = FALSE; + while (currentFunction != NULL) + { + struct functionInfo *f = currentFunction; + currentFunction = f->next; + if (f->name != NULL) + free(f->name); + free(f); + } + yy_delete_buffer (YY_CURRENT_BUFFER); + yy_switch_to_buffer (yy_create_buffer(f, YY_BUF_SIZE)); + filename = xstrdup (s); + lineno = 1; + if (currentLine == NULL) + pushLine (); + else + currentLine->lineno = lineno; + START_FILE (filename, lineno); + BEGIN INITIAL; resetpos (); + return TRUE; + } +} + +/* + * m2flex_GetLineNo - returns the current line number. + */ + +EXTERN int m2flex_GetLineNo (void) +{ + if (currentLine != NULL) + return currentLine->lineno; + else + return 0; +} + +/* + * m2flex_GetColumnNo - returns the column where the current + * token starts. + */ + +EXTERN int m2flex_GetColumnNo (void) +{ + if (currentLine != NULL) + return currentLine->column; + else + return 0; +} + +/* + * m2flex_GetLocation - returns the gcc location_t of the current token. + */ + +EXTERN location_t m2flex_GetLocation (void) +{ + if (currentLine != NULL) + return currentLine->location; + else + return 0; +} + +/* + * GetTotalLines - returns the total number of lines parsed. + */ + +EXTERN int m2flex_GetTotalLines (void) +{ + return totalLines; +} + +/* + * yywrap is called when end of file is seen. We push an eof token + * and tell the lexical analysis to stop. + */ + +int yywrap (void) +{ + updatepos(); M2LexBuf_AddTok(M2Reserved_eoftok); return 1; +} + +EXTERN void _M2_m2flex_init (void) {} +EXTERN void _M2_m2flex_finish (void) {} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/m2pp.cc --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/m2pp.cc 2022-12-06 19:12:13.046656408 +0000 @@ -0,0 +1,2647 @@ +/* m2pp.c pretty print trees, output in Modula-2 where possible. + +Copyright (C) 2007-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 +. */ + +#if defined(GM2) +#include "gm2-gcc/gcc-consolidation.h" + +#include "m2-tree.h" +#include "gm2-lang.h" + +#include "gm2-gcc/m2tree.h" +#include "gm2-gcc/m2expr.h" +#include "gm2-gcc/m2type.h" +#include "gm2-gcc/m2decl.h" +#else +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "cp/cp-tree.h" +#include "stringpool.h" +#include "gm2-gcc/gcc-consolidation.h" +#include "../cp/cp-tree.h" +#endif + +#define M2PP_C +#include "m2/m2pp.h" + +namespace modula2 { + +#undef DEBUGGING + +typedef struct pretty_t +{ + int needs_space; + int needs_indent; + int curpos; + int indent; + int issued_begin; + int in_vars; + int in_types; + tree block; + int bits; +} pretty; + +typedef struct m2stack_t +{ + tree value; + struct m2stack_t *next; +} stack; + +/* Prototypes. */ + +static pretty *initPretty (int bits); +static pretty *dupPretty (pretty *s); +static int getindent (pretty *s); +static void setindent (pretty *s, int n); +static int getcurpos (pretty *s); +static void m2pp_identifier (pretty *s, tree t); +static void m2pp_needspace (pretty *s); +static void m2pp_function (pretty *s, tree t); +static void m2pp_function_header (pretty *s, tree t); +static void m2pp_function_vars (pretty *s, tree t); +static void m2pp_statement_sequence (pretty *s, tree t); +static void m2pp_print (pretty *s, const char *p); +static void m2pp_print_char (pretty *s, char ch); +static void m2pp_parameter (pretty *s, tree t); +static void m2pp_type (pretty *s, tree t); +static void m2pp_ident_pointer (pretty *s, tree t); +static void m2pp_set_type (pretty *s, tree t); +static void m2pp_enum (pretty *s, tree t); +static void m2pp_array (pretty *s, tree t); +static void m2pp_subrange (pretty *s, tree t); +static void m2pp_gimpified (pretty *s, tree t); +static void m2pp_pointer_type (pretty *s, tree t); +static void m2pp_record_type (pretty *s, tree t); +static void m2pp_union_type (pretty *s, tree t); +static void m2pp_simple_type (pretty *s, tree t); +static void m2pp_expression (pretty *s, tree t); +static void m2pp_relop (pretty *s, tree t, const char *p); +static void m2pp_simple_expression (pretty *s, tree t); +static void m2pp_statement_sequence (pretty *s, tree t); +static void m2pp_unknown (pretty *s, const char *s1, const char *s2); +static void m2pp_statement (pretty *s, tree t); +static void m2pp_assignment (pretty *s, tree t); +static void m2pp_designator (pretty *s, tree t); +static void m2pp_conditional (pretty *s, tree t); +static void m2pp_label_expr (pretty *s, tree t); +static void m2pp_label_decl (pretty *s, tree t); +static void m2pp_goto (pretty *s, tree t); +static void m2pp_list (pretty *s, tree t); +static void m2pp_offset (pretty *s, tree t); +static void m2pp_indirect_ref (pretty *s, tree t); +static void m2pp_integer_cst (pretty *s, tree t); +static void m2pp_real_cst (pretty *s, tree t); +static void m2pp_string_cst (pretty *s, tree t); +static void m2pp_integer (pretty *s, tree t); +static void m2pp_addr_expr (pretty *s, tree t); +static void m2pp_nop (pretty *s, tree t); +static void m2pp_convert (pretty *s, tree t); +static void m2pp_var_decl (pretty *s, tree t); +static void m2pp_binary (pretty *s, tree t, const char *p); +static void m2pp_unary (pretty *s, tree t, const char *p); +static void m2pp_call_expr (pretty *s, tree t); +static void m2pp_procedure_call (pretty *s, tree t); +static void m2pp_ssa (pretty *s, tree t); +static void m2pp_block (pretty *s, tree t); +static void m2pp_block_list (pretty *s, tree t); +static void m2pp_var_list (pretty *s, tree t); +static void m2pp_bind_expr (pretty *s, tree t); +static void m2pp_return_expr (pretty *s, tree t); +static void m2pp_result_decl (pretty *s, tree t); +static void m2pp_try_block (pretty *s, tree t); +static void m2pp_cleanup_point_expr (pretty *s, tree t); +static void m2pp_handler (pretty *s, tree t); +static void m2pp_component_ref (pretty *s, tree t); +static void m2pp_array_ref (pretty *s, tree t); +static void m2pp_begin (pretty *s); +static void m2pp_var (pretty *s); +static void m2pp_types (pretty *s); +static void m2pp_decl_expr (pretty *s, tree t); +static void m2pp_var_type_decl (pretty *s, tree t); +static void m2pp_non_lvalue_expr (pretty *s, tree t); +static void m2pp_procedure_type (pretty *s, tree t); +static void m2pp_param_type (pretty *s, tree t); +static void m2pp_type_lowlevel (pretty *s, tree t); +static void m2pp_try_catch_expr (pretty *s, tree t); +static void m2pp_throw (pretty *s, tree t); +static void m2pp_catch_expr (pretty *s, tree t); +static void m2pp_try_finally_expr (pretty *s, tree t); +static void m2pp_complex (pretty *s, tree t); +static void killPretty (pretty *s); +static void m2pp_compound_expression (pretty *s, tree t); +static void m2pp_target_expression (pretty *s, tree t); +static void m2pp_constructor (pretty *s, tree t); +static void m2pp_translation (pretty *s, tree t); +static void m2pp_module_block (pretty *s, tree t); +static void push (tree t); +static void pop (void); +static int begin_printed (tree t); +static void m2pp_decl_list (pretty *s, tree t); +static void m2pp_loc (pretty *s, tree t); + +void pet (tree t); +void m2pp_integer (pretty *s, tree t); + +extern void stop (void); + +static stack *stackPtr = NULL; + +/* do_pf helper function for pf. */ + +void +do_pf (tree t, int bits) +{ + pretty *state = initPretty (bits); + + if (TREE_CODE (t) == TRANSLATION_UNIT_DECL) + m2pp_translation (state, t); + else if (TREE_CODE (t) == BLOCK) + m2pp_module_block (state, t); + else if (TREE_CODE (t) == FUNCTION_DECL) + m2pp_function (state, t); + else + m2pp_statement_sequence (state, t); + killPretty (state); +} + +/* pf print function. Expected to be printed interactively from + the debugger: print pf(func), or to be called from code. */ + +void +pf (tree t) +{ + do_pf (t, FALSE); +} + +/* pe print expression. Expected to be printed interactively from + the debugger: print pe(expr), or to be called from code. */ + +void +pe (tree t) +{ + pretty *state = initPretty (FALSE); + + m2pp_expression (state, t); + m2pp_needspace (state); + m2pp_print (state, ";\n"); + killPretty (state); +} + +/* pet print expression and its type. Expected to be printed + interactively from the debugger: print pet(expr), or to be called + from code. */ + +void +pet (tree t) +{ + pretty *state = initPretty (FALSE); + + m2pp_expression (state, t); + m2pp_needspace (state); + m2pp_print (state, ":"); + m2pp_type (state, TREE_TYPE (t)); + m2pp_print (state, ";\n"); + killPretty (state); +} + +/* pt print type. Expected to be printed interactively from the + debugger: print pt(expr), or to be called from code. */ + +void +pt (tree t) +{ + pretty *state = initPretty (FALSE); + m2pp_type (state, t); + m2pp_needspace (state); + m2pp_print (state, ";\n"); + killPretty (state); +} + +/* ptl print type low level. Expected to be printed interactively + from the debugger: print ptl(type), or to be called from code. */ + +void +ptl (tree t) +{ + pretty *state = initPretty (FALSE); + m2pp_type_lowlevel (state, t); + m2pp_needspace (state); + m2pp_print (state, ";\n"); + killPretty (state); +} + +/* ptcl print TREE_CHAINed list. */ + +void +ptcl (tree t) +{ + pretty *state = initPretty (FALSE); + + m2pp_decl_list (state, t); + m2pp_print (state, "\n"); + killPretty (state); +} + +/* loc if tree has a location then display it within a comment. */ + +static void +m2pp_loc (pretty *s, tree t) +{ + if (CAN_HAVE_LOCATION_P (t)) + { + if (EXPR_HAS_LOCATION (t)) + { + if (EXPR_LOCATION (t) == UNKNOWN_LOCATION) + m2pp_print (s, "(* missing location1 *)\n"); + else + { + expanded_location l = expand_location (EXPR_LOCATION (t)); + + m2pp_print (s, "(* "); + m2pp_print (s, l.file); + m2pp_print (s, ":"); + printf ("%d", l.line); + m2pp_print (s, " *)"); + m2pp_print (s, "\n"); + } + } + else + { + m2pp_print (s, "(* missing location2 *)\n"); + } + } +} + +/* m2pp_decl_list prints a TREE_CHAINed list for a decl node. */ + +static void +m2pp_decl_list (pretty *s, tree t) +{ + tree u = t; + + m2pp_print (s, "("); + m2pp_needspace (s); + while (t != NULL_TREE) + { + m2pp_identifier (s, t); + t = TREE_CHAIN (t); + if (t == u || t == NULL_TREE) + break; + m2pp_print (s, ","); + m2pp_needspace (s); + } + m2pp_needspace (s); + m2pp_print (s, ")"); +} + +static void +m2pp_decl_bool (pretty *s, tree t) +{ + if (TREE_STATIC (t)) + m2pp_print (s, "static, "); + if (DECL_EXTERNAL (t)) + m2pp_print (s, "external, "); + if (DECL_SEEN_IN_BIND_EXPR_P (t)) + m2pp_print (s, "in bind expr, "); +} + +void +pv (tree t) +{ + if (t) + { + enum tree_code code = TREE_CODE (t); + + if (code == PARM_DECL) + { + pretty *state = initPretty (FALSE); + m2pp_identifier (state, t); + m2pp_needspace (state); + m2pp_print (state, "\n"); + else + { + m2pp_print (state, ", abstract origin = "); + m2pp_identifier (state, DECL_ABSTRACT_ORIGIN (t)); + m2pp_print (state, ">\n"); + modula2::pv (DECL_ABSTRACT_ORIGIN (t)); + } + killPretty (state); + } + if (code == VAR_DECL) + { + pretty *state = initPretty (FALSE); + m2pp_identifier (state, t); + m2pp_needspace (state); + m2pp_print (state, "(* *)\n"); + else + { + m2pp_print (state, ", abstract origin = "); + m2pp_identifier (state, DECL_ABSTRACT_ORIGIN (t)); + m2pp_print (state, "> *)\n"); + modula2::pv (DECL_ABSTRACT_ORIGIN (t)); + } + killPretty (state); + } + } +} + +#if defined(GM2_MAINTAINER) + +/* remember an internal debugging hook. */ +static tree rememberF = NULL; + +static void +remember (tree t) +{ + rememberF = t; + printf ("type: watch *((tree *) %p) != %p\n", (void *)&DECL_SAVED_TREE (t), + (void *)DECL_SAVED_TREE (t)); +} +#endif + +/* push pushes tree t onto stack. */ + +static void +push (tree t) +{ + stack *s = (stack *)xmalloc (sizeof (stack)); + + s->value = t; + s->next = stackPtr; + stackPtr = s; +} + +/* pop pops a tree, from the stack. */ + +static void +pop (void) +{ + stack *s = stackPtr; + + stackPtr = stackPtr->next; + free (s); +} + +/* being_printed returns TRUE if t is held on the stack. */ + +static int +begin_printed (tree t) +{ + stack *s = stackPtr; + + while (s != NULL) + { + if (s->value == t) + return TRUE; + else + s = s->next; + } + return FALSE; +} + +/* dupPretty duplicate and return a copy of state s. */ + +static pretty * +dupPretty (pretty *s) +{ + pretty *p = initPretty (s->bits); + *p = *s; + return p; +} + +/* initPretty initialise the state of the pretty printer. */ + +static pretty * +initPretty (int bits) +{ + pretty *state = (pretty *)xmalloc (sizeof (pretty)); + state->needs_space = FALSE; + state->needs_indent = FALSE; + state->curpos = 0; + state->indent = 0; + state->issued_begin = FALSE; + state->in_vars = FALSE; + state->in_types = FALSE; + state->block = NULL_TREE; + state->bits = bits; + return state; +} + +/* killPretty cleans up the state. */ + +static void +killPretty (pretty *s) +{ + free (s); + fflush (stdout); +} + +/* getindent returns the current indent value. */ + +static int +getindent (pretty *s) +{ + return s->indent; +} + +/* setindent sets the current indent to, n. */ + +static void +setindent (pretty *s, int n) +{ + s->indent = n; +} + +/* getcurpos returns the current cursor position. */ + +static int +getcurpos (pretty *s) +{ + if (s->needs_space) + return s->curpos + 1; + else + return s->curpos; +} + +/* m2pp_type_lowlevel prints out the low level details of a + fundamental type. */ + +static void +m2pp_type_lowlevel (pretty *s, tree t) +{ + if (TREE_CODE (t) == INTEGER_TYPE) + { + m2pp_print (s, "min"); + m2pp_needspace (s); + m2pp_integer_cst (s, TYPE_MIN_VALUE (t)); + m2pp_print (s, ", max"); + m2pp_needspace (s); + m2pp_integer_cst (s, TYPE_MAX_VALUE (t)); + m2pp_print (s, ", type size unit"); + m2pp_needspace (s); + m2pp_integer_cst (s, TYPE_SIZE_UNIT (t)); + m2pp_print (s, ", type size"); + m2pp_needspace (s); + m2pp_integer_cst (s, TYPE_SIZE (t)); + + printf (", precision %d, mode %d, align %d, user align %d", + TYPE_PRECISION (t), TYPE_MODE (t), TYPE_ALIGN (t), + TYPE_USER_ALIGN (t)); + + m2pp_needspace (s); + if (TYPE_UNSIGNED (t)) + m2pp_print (s, "unsigned\n"); + else + m2pp_print (s, "signed\n"); + } +} + +/* m2pp_var emit a VAR if necessary. */ + +static void +m2pp_var (pretty *s) +{ + if (!s->in_vars) + { + s->in_vars = TRUE; + m2pp_print (s, "VAR\n"); + setindent (s, getindent (s) + 3); + } +} + +/* m2pp_types emit a TYPE if necessary. */ + +static void +m2pp_types (pretty *s) +{ + if (!s->in_types) + { + s->in_types = TRUE; + m2pp_print (s, "TYPE\n"); + setindent (s, getindent (s) + 3); + } +} + +/* hextree displays the critical fields for function, block and + bind_expr trees in raw hex. */ + +static void +hextree (tree t) +{ + if (t == NULL_TREE) + return; + + if (TREE_CODE (t) == BLOCK) + { + printf ("(* BLOCK %p *)\n", (void *)t); + printf ("BLOCK_VARS (t) = %p\n", (void *)BLOCK_VARS (t)); + printf ("BLOCK_SUPERCONTEXT (t) = %p\n", + (void *)BLOCK_SUPERCONTEXT (t)); + } + if (TREE_CODE (t) == BIND_EXPR) + { + printf ("(* BIND_EXPR %p *)\n", (void *)t); + printf ("BIND_EXPR_VARS (t) = %p\n", (void *)BIND_EXPR_VARS (t)); + printf ("BIND_EXPR_BLOCK (t) = %p\n", (void *)BIND_EXPR_BLOCK (t)); + printf ("BIND_EXPR_BODY (t) = %p\n", (void *)BIND_EXPR_BODY (t)); + } + if (TREE_CODE (t) == FUNCTION_DECL) + { + printf ("(* FUNCTION_DECL %p *)\n", (void *)t); + printf ("DECL_INITIAL (t) = %p\n", (void *)DECL_INITIAL (t)); + printf ("DECL_SAVED_TREE (t) = %p\n", (void *)DECL_SAVED_TREE (t)); + hextree (DECL_INITIAL (t)); + hextree (DECL_SAVED_TREE (t)); + } + if (TREE_CODE (t) == VAR_DECL) + { + pretty *state = initPretty (FALSE); + + printf ("(* VAR_DECL %p <", (void *)t); + if (DECL_SEEN_IN_BIND_EXPR_P (t)) + printf ("b"); + if (DECL_EXTERNAL (t)) + printf ("e"); + if (TREE_STATIC (t)) + printf ("s"); + printf ("> context = %p*)\n", (void *)decl_function_context (t)); + m2pp_type (state, TREE_TYPE (t)); + m2pp_needspace (state); + m2pp_print (state, ";\n"); + killPretty (state); + } + if (TREE_CODE (t) == PARM_DECL) + { + pretty *state = initPretty (FALSE); + + printf ("(* PARM_DECL %p <", (void *)t); + printf ("> context = %p*)\n", (void *)decl_function_context (t)); + m2pp_type (state, TREE_TYPE (t)); + m2pp_needspace (state); + m2pp_print (state, ";\n"); + killPretty (state); + } +} + +/* translation produce a pseudo implementation module from the tree t. */ + +static void +m2pp_translation (pretty *s, tree t) +{ + tree block = DECL_INITIAL (t); + + m2pp_print (s, "IMPLEMENTATION MODULE "); + m2pp_identifier (s, t); + m2pp_print (s, "\n\n"); + + if (block != NULL) + { + m2pp_module_block (s, block); + m2pp_print (s, "\n"); + } + + m2pp_print (s, "\n"); + m2pp_print (s, "END "); + m2pp_identifier (s, t); + m2pp_print (s, ".\n"); +} + +static void +m2pp_module_block (pretty *s, tree t) +{ + t = BLOCK_VARS (t); + + if (t != NULL_TREE) + for (; t != NULL_TREE; t = TREE_CHAIN (t)) + { + switch (TREE_CODE (t)) + { + case FUNCTION_DECL: + if (!DECL_EXTERNAL (t)) + { + pretty *p = dupPretty (s); + printf ("\n"); + p->in_vars = FALSE; + p->in_types = FALSE; + m2pp_function (p, t); + killPretty (p); + printf ("\n"); + s->in_vars = FALSE; + s->in_types = FALSE; + } + break; + + case TYPE_DECL: + { + int o = getindent (s); + int p; + + m2pp_print (s, "\n"); + m2pp_types (s); + setindent (s, o + 3); + m2pp_identifier (s, t); + m2pp_print (s, " = "); + p = getcurpos (s); + setindent (s, p); + m2pp_type (s, TREE_TYPE (t)); + setindent (s, o); + m2pp_needspace (s); + m2pp_print (s, ";\n"); + s->in_vars = FALSE; + } + break; + + case VAR_DECL: + m2pp_var (s); + m2pp_identifier (s, t); + m2pp_needspace (s); + m2pp_print (s, ":"); + m2pp_needspace (s); + m2pp_type (s, TREE_TYPE (t)); + m2pp_needspace (s); + m2pp_print (s, ";\n"); + s->in_types = FALSE; + break; + + case DECL_EXPR: + printf ("is this node legal here? \n"); + m2pp_decl_expr (s, t); + break; + + default: + m2pp_unknown (s, __FUNCTION__, get_tree_code_name (TREE_CODE (t))); + } + } +} + +/* m2pp_begin emit a BEGIN if necessary. */ + +static void +m2pp_begin (pretty *s) +{ + if (!s->issued_begin) + { + if (s->in_vars || s->in_types) + { + setindent (s, getindent (s) - 3); + m2pp_print (s, "BEGIN\n"); + setindent (s, getindent (s) + 3); + } + else + { + m2pp_print (s, "BEGIN\n"); + setindent (s, getindent (s) + 3); + } + s->issued_begin = TRUE; + s->in_vars = FALSE; + s->in_types = FALSE; + } +} + +/* m2pp_function walk over the function. */ + +static void +m2pp_function (pretty *s, tree t) +{ + m2pp_function_header (s, t); + m2pp_function_vars (s, t); + m2pp_statement_sequence (s, DECL_SAVED_TREE (t)); + if (TREE_CODE (t) == FUNCTION_DECL) + { + m2pp_begin (s); + setindent (s, getindent (s) - 3); + m2pp_print (s, "END"); + m2pp_needspace (s); + m2pp_identifier (s, t); + m2pp_needspace (s); + m2pp_print (s, ";\n"); + } +} + +/* m2pp_bind_expr displays the bind expr tree node. */ + +static void +m2pp_bind_expr (pretty *s, tree t) +{ + if (TREE_CODE (t) == BIND_EXPR) + { + if (BIND_EXPR_VARS (t)) + { + m2pp_print (s, "(* variables in bind_expr *)\n"); + m2pp_var (s); + m2pp_var_list (s, BIND_EXPR_VARS (t)); + } + if (BIND_EXPR_BLOCK (t)) + { + m2pp_print (s, "(* bind_expr_block *)\n"); + m2pp_statement_sequence (s, BIND_EXPR_BLOCK (t)); + m2pp_needspace (s); + m2pp_print (s, "; \n"); + } + m2pp_statement_sequence (s, BIND_EXPR_BODY (t)); + } +} + +/* m2pp_block_list iterates over the list of blocks. */ + +static void +m2pp_block_list (pretty *s, tree t) +{ + for (; t; t = BLOCK_CHAIN (t)) + m2pp_block (s, t); +} + +/* m2pp_block prints the VARiables and the TYPEs inside a block. */ + +static void +m2pp_block (pretty *s, tree t) +{ + if ((BLOCK_VARS (t) != NULL_TREE) && (s->block != BLOCK_VARS (t))) + { + s->block = BLOCK_VARS (t); + m2pp_print (s, "(* block variables *)\n"); + m2pp_var (s); + m2pp_var_list (s, BLOCK_VARS (t)); + } +} + +/* m2pp_var_type_decl displays the variable and type declaration. */ + +static void +m2pp_var_type_decl (pretty *s, tree t) +{ + m2pp_identifier (s, t); + m2pp_needspace (s); + m2pp_print (s, ":"); + m2pp_needspace (s); + m2pp_type (s, TREE_TYPE (t)); + m2pp_needspace (s); + m2pp_print (s, ";\n"); +} + +/* m2pp_var_list print a variable list. */ + +static void +m2pp_var_list (pretty *s, tree t) +{ + if (t != NULL_TREE) + for (; t; t = TREE_CHAIN (t)) + { + if (TREE_CODE (t) == FUNCTION_DECL) + { + pretty *p = dupPretty (s); + printf ("\n"); + p->in_vars = FALSE; + p->in_types = FALSE; + m2pp_function (p, t); + killPretty (p); + printf ("\n"); + } + else if (TREE_CODE (t) == TYPE_DECL) + m2pp_identifier (s, t); + else if (TREE_CODE (t) == DECL_EXPR) + { + printf ("is this node legal here? \n"); + // is it legal to have a DECL_EXPR here ? + m2pp_var_type_decl (s, DECL_EXPR_DECL (t)); + } + else + m2pp_var_type_decl (s, t); + } +} + +#if 0 +/* m2pp_type_list print a variable list. */ + +static void +m2pp_type_list (pretty *s, tree t) +{ + if (t != NULL_TREE) + for (; t; t = TREE_CHAIN (t)) + { + m2pp_identifier (s, t); + m2pp_needspace (s); + m2pp_print (s, "="); + m2pp_needspace (s); + m2pp_type (s, TREE_TYPE (t)); + m2pp_needspace (s); + m2pp_print (s, ";\n"); + } +} +#endif + +/* m2pp_needspace sets appropriate flag to TRUE. */ + +static void +m2pp_needspace (pretty *s) +{ + s->needs_space = TRUE; +} + +/* m2pp_identifer prints an identifier. */ + +static void +m2pp_identifier (pretty *s, tree t) +{ + if (t) + { + if (TREE_CODE (t) == COMPONENT_REF) + m2pp_component_ref (s, t); + else if (DECL_NAME (t) && IDENTIFIER_POINTER (DECL_NAME (t))) + m2pp_ident_pointer (s, DECL_NAME (t)); + else + { + char name[100]; + + if (TREE_CODE (t) == CONST_DECL) + snprintf (name, 100, "C_%u", DECL_UID (t)); + else + snprintf (name, 100, "D_%u", DECL_UID (t)); + m2pp_print (s, name); + } + } +} + +/* m2pp_ident_pointer displays an ident pointer. */ + +static void +m2pp_ident_pointer (pretty *s, tree t) +{ + if (t) + m2pp_print (s, IDENTIFIER_POINTER (t)); +} + +/* m2pp_parameter prints out a param decl tree. */ + +static void +m2pp_parameter (pretty *s, tree t) +{ + if (TREE_CODE (t) == PARM_DECL) + { + if (TREE_TYPE (t) && (TREE_CODE (TREE_TYPE (t)) == REFERENCE_TYPE)) + { + m2pp_print (s, "VAR"); + m2pp_needspace (s); + m2pp_identifier (s, t); + m2pp_print (s, ":"); + m2pp_needspace (s); + m2pp_simple_type (s, TREE_TYPE (TREE_TYPE (t))); + } + else + { + m2pp_identifier (s, t); + m2pp_print (s, ":"); + m2pp_needspace (s); + m2pp_simple_type (s, TREE_TYPE (t)); + } + } +} + +/* m2pp_param_type prints out the type of parameter. */ + +static void +m2pp_param_type (pretty *s, tree t) +{ + if (t && (TREE_CODE (t) == REFERENCE_TYPE)) + { + m2pp_print (s, "VAR"); + m2pp_needspace (s); + m2pp_simple_type (s, TREE_TYPE (t)); + } + else + m2pp_simple_type (s, t); +} + +/* m2pp_procedure_type displays a procedure type. */ + +static void +m2pp_procedure_type (pretty *s, tree t) +{ + push (t); + if (TREE_CODE (t) == FUNCTION_TYPE) + { + tree i = TYPE_ARG_TYPES (t); + tree returnType = TREE_TYPE (TREE_TYPE (t)); + + m2pp_needspace (s); + m2pp_print (s, "PROCEDURE"); + m2pp_needspace (s); + if (i != NULL_TREE) + { + int o = getindent (s); + int p; + int first = TRUE; + + m2pp_print (s, "("); + p = getcurpos (s); + setindent (s, p); + while (i != NULL_TREE) + { + if (TREE_CHAIN (i) == NULL_TREE) + { + if (TREE_VALUE (i) == void_type_node) + /* Ignore void_type_node at the end. */ + ; + else + { + m2pp_param_type (s, TREE_VALUE (i)); + m2pp_print (s, ", ..."); + } + break; + } + else + { + if (!first) + { + m2pp_print (s, ","); + m2pp_needspace (s); + } + m2pp_param_type (s, TREE_VALUE (i)); + } + i = TREE_CHAIN (i); + first = FALSE; + } + m2pp_print (s, ")"); + setindent (s, o); + } + else if (returnType != NULL_TREE) + { + m2pp_needspace (s); + m2pp_print (s, "()"); + } + if (returnType != NULL_TREE) + { + m2pp_needspace (s); + m2pp_print (s, ": "); + m2pp_simple_type (s, returnType); + } + } + pop (); +} + +/* m2pp_comment_header displays a simple header with some critical + tree info. */ + +static void +m2pp_comment_header (pretty *s, tree t) +{ + int o = getindent (s); + + m2pp_print (s, "(*\n"); + setindent (s, o + 3); + m2pp_identifier (s, t); + m2pp_needspace (s); + m2pp_print (s, "-"); + m2pp_needspace (s); + if (TREE_PUBLIC (t)) + { + m2pp_needspace (s); + m2pp_print (s, "public,"); + } + if (TREE_STATIC (t)) + { + m2pp_needspace (s); + m2pp_print (s, "static,"); + } + if (DECL_EXTERNAL (t)) + { + m2pp_needspace (s); + m2pp_print (s, "extern"); + } + m2pp_print (s, "\n"); + setindent (s, o); + m2pp_print (s, "*)\n\n"); +} + +/* m2pp_function_header displays the function header. */ + +static void +m2pp_function_header (pretty *s, tree t) +{ + push (t); + if (TREE_CODE (t) == FUNCTION_DECL) + { + tree i = DECL_ARGUMENTS (t); + tree returnType = TREE_TYPE (TREE_TYPE (t)); + + m2pp_comment_header (s, t); + m2pp_print (s, "PROCEDURE "); + m2pp_identifier (s, t); + m2pp_needspace (s); + if (i != NULL_TREE) + { + int o = getindent (s); + int p; + + m2pp_print (s, "("); + p = getcurpos (s); + setindent (s, p); + while (i != NULL_TREE) + { + m2pp_parameter (s, i); + i = TREE_CHAIN (i); + if (i != NULL_TREE) + m2pp_print (s, ";\n"); + } + m2pp_print (s, ")"); + m2pp_needspace (s); + setindent (s, o); + } + else if (returnType != void_type_node) + { + m2pp_print (s, "()"); + m2pp_needspace (s); + } + if (returnType != void_type_node) + { + m2pp_print (s, ": "); + m2pp_simple_type (s, returnType); + m2pp_needspace (s); + } + m2pp_print (s, "; "); + m2pp_loc (s, t); + m2pp_print (s, "\n"); + } + pop (); +} + +/* m2pp_add_var adds a variable into a list as defined by, data. */ + +static tree +m2pp_add_var (tree *tp, int *walk_subtrees, void *data) +{ + tree t = *tp; + pretty *s = (pretty *)data; + enum tree_code code = TREE_CODE (t); + + if (code == VAR_DECL) + { + m2pp_var (s); + m2pp_identifier (s, t); + m2pp_needspace (s); + m2pp_print (s, ":"); + m2pp_needspace (s); + m2pp_type (s, TREE_TYPE (t)); + m2pp_needspace (s); + m2pp_print (s, ";\n"); + } + if (code == SSA_NAME) + { + m2pp_var (s); + m2pp_ssa (s, t); + m2pp_identifier (s, SSA_NAME_VAR (t)); + m2pp_needspace (s); + m2pp_print (s, ":"); + m2pp_needspace (s); + m2pp_type (s, TREE_TYPE (t)); + m2pp_needspace (s); + m2pp_print (s, ";\n"); + } + + *walk_subtrees = 1; + return NULL_TREE; +} + +/* m2pp_function_vars displays variables as defined by the function + tree. */ + +static void +m2pp_function_vars (pretty *s, tree t) +{ + walk_tree_without_duplicates (&t, m2pp_add_var, s); + + if (TREE_CODE (t) == FUNCTION_DECL && DECL_INITIAL (t)) + { + m2pp_print (s, "(* variables in function_decl (decl_initial) *)\n"); + m2pp_var (s); + m2pp_statement_sequence (s, DECL_INITIAL (t)); + } +} + +/* m2pp_print print out a string p interpreting '\n' and + adjusting the fields within state s. */ + +static void +m2pp_print (pretty *s, const char *p) +{ + if (p) + { + int l = strlen (p); + int i = 0; + + if (s->needs_space) + { + printf (" "); + s->needs_space = FALSE; + s->curpos++; + } + + while (i < l) + { + if (p[i] == '\n') + { + s->needs_indent = TRUE; + s->curpos = 0; + printf ("\n"); + } + else + { + if (s->needs_indent) + { + if (s->indent > 0) + printf ("%*c", s->indent, ' '); + s->needs_indent = FALSE; + s->curpos += s->indent; + } + s->curpos++; + putchar (p[i]); + } + i++; + } + } +} + +/* m2pp_print_char prints out a character ch obeying needs_space + and needs_indent. */ + +static void +m2pp_print_char (pretty *s, char ch) +{ + if (s->needs_space) + { + printf (" "); + s->needs_space = FALSE; + s->curpos++; + } + if (s->needs_indent) + { + if (s->indent > 0) + printf ("%*c", s->indent, ' '); + s->needs_indent = FALSE; + s->curpos += s->indent; + } + if (ch == '\n') + { + s->curpos++; + putchar ('\\'); + putchar ('n'); + } + else + putchar (ch); + s->curpos++; +} + +/* m2pp_integer display the appropriate integer type. */ + +#if defined(GM2) +void +m2pp_integer (pretty *s, tree t) +{ + if (t == m2type_GetM2ZType ()) + m2pp_print (s, "M2ZTYPE"); + else if (t == m2type_GetM2LongIntType ()) + m2pp_print (s, "LONGINT"); + else if (t == m2type_GetM2IntegerType ()) + m2pp_print (s, "INTEGER"); + else if (t == m2type_GetM2ShortIntType ()) + m2pp_print (s, "SHORTINT"); + else if (t == m2type_GetLongIntType ()) + m2pp_print (s, "long int"); + else if (t == m2type_GetIntegerType ()) + m2pp_print (s, "int"); + else if (t == m2type_GetShortIntType ()) + m2pp_print (s, "short"); + else if (t == m2type_GetM2LongCardType ()) + m2pp_print (s, "LONGCARD"); + else if (t == m2type_GetM2CardinalType ()) + m2pp_print (s, "CARDINAL"); + else if (t == m2type_GetM2ShortCardType ()) + m2pp_print (s, "SHORTCARD"); + else if (t == m2type_GetCardinalType ()) + m2pp_print (s, "CARDINAL"); + else if (t == m2type_GetPointerType ()) + m2pp_print (s, "ADDRESS"); + else if (t == m2type_GetByteType ()) + m2pp_print (s, "BYTE"); + else if (t == m2type_GetCharType ()) + m2pp_print (s, "CHAR"); + else if (t == m2type_GetBitsetType ()) + m2pp_print (s, "BITSET"); + else if (t == m2type_GetBitnumType ()) + m2pp_print (s, "BITNUM"); + else + { + if (TYPE_UNSIGNED (t)) + m2pp_print (s, "CARDINAL"); + else + m2pp_print (s, "INTEGER"); + m2pp_integer_cst (s, TYPE_SIZE (t)); + } +} +#else +void +m2pp_integer (pretty *s, tree t ATTRIBUTE_UNUSED) +{ + m2pp_print (s, "INTEGER"); +} +#endif + +/* m2pp_complex display the actual complex type. */ + +#if defined(GM2) +static void +m2pp_complex (pretty *s, tree t) +{ + if (t == m2type_GetM2ComplexType ()) + m2pp_print (s, "COMPLEX"); + else if (t == m2type_GetM2LongComplexType ()) + m2pp_print (s, "LONGCOMPLEX"); + else if (t == m2type_GetM2ShortComplexType ()) + m2pp_print (s, "SHORTCOMPLEX"); + else if (t == m2type_GetM2CType ()) + m2pp_print (s, "C'omplex' type"); + else if (t == m2type_GetM2Complex32 ()) + m2pp_print (s, "COMPLEX32"); + else if (t == m2type_GetM2Complex64 ()) + m2pp_print (s, "COMPLEX64"); + else if (t == m2type_GetM2Complex96 ()) + m2pp_print (s, "COMPLEX96"); + else if (t == m2type_GetM2Complex128 ()) + m2pp_print (s, "COMPLEX128"); + else + m2pp_print (s, "unknown COMPLEX type"); +} + +#else + +static void +m2pp_complex (pretty *s, tree t ATTRIBUTE_UNUSED) +{ + m2pp_print (s, "a COMPLEX type"); +} +#endif + +/* m2pp_type prints a full type. */ + +void +m2pp_type (pretty *s, tree t) +{ + if (begin_printed (t)) + { + m2pp_print (s, "<...>"); + return; + } + if ((TREE_CODE (t) != FIELD_DECL) && (TREE_CODE (t) != TYPE_DECL)) + m2pp_gimpified (s, t); + switch (TREE_CODE (t)) + { + case INTEGER_TYPE: + m2pp_integer (s, t); + break; + case REAL_TYPE: + m2pp_print (s, "REAL"); + break; + case ENUMERAL_TYPE: + m2pp_enum (s, t); + break; + case UNION_TYPE: + m2pp_union_type (s, t); + break; + case RECORD_TYPE: + m2pp_record_type (s, t); + break; + case ARRAY_TYPE: + m2pp_array (s, t); + break; +#if 0 + case FUNCTION_TYPE: + m2pp_function_type (s, t); + break; +#endif + case TYPE_DECL: + m2pp_identifier (s, t); + break; + case POINTER_TYPE: + m2pp_pointer_type (s, t); + break; +#if defined(GM2) + case SET_TYPE: + m2pp_set_type (s, t); + break; +#endif + case VOID_TYPE: + m2pp_print (s, "ADDRESS"); + break; + case COMPLEX_TYPE: + m2pp_complex (s, t); + break; + default: + m2pp_unknown (s, __FUNCTION__, get_tree_code_name (TREE_CODE (t))); + } +} + +/* m2pp_set_type prints out the set type. */ + +static void +m2pp_set_type (pretty *s, tree t) +{ + push (t); + m2pp_print (s, "SET OF"); + m2pp_needspace (s); + m2pp_type (s, TREE_TYPE (t)); + pop (); +} + +/* m2pp_enum print out the enumeration type. */ + +static void +m2pp_enum (pretty *s, tree t) +{ + tree chain_p = TYPE_VALUES (t); + + push (t); + m2pp_print (s, "("); + while (chain_p) + { + m2pp_ident_pointer (s, TREE_PURPOSE (chain_p)); + chain_p = TREE_CHAIN (chain_p); + if (chain_p) + m2pp_print (s, ", "); + } + m2pp_print (s, ")"); + pop (); +} + +/* m2pp_array prints out the array type. */ + +static void +m2pp_array (pretty *s, tree t) +{ + push (t); + m2pp_print (s, "ARRAY"); + m2pp_needspace (s); + m2pp_subrange (s, TYPE_DOMAIN (t)); + m2pp_needspace (s); + m2pp_print (s, "OF"); + m2pp_needspace (s); + m2pp_type (s, TREE_TYPE (t)); + pop (); +} + +/* m2pp_subrange prints out the subrange, but probably the lower + bound will always be zero. */ + +static void +m2pp_subrange (pretty *s, tree t) +{ + tree min = TYPE_MIN_VALUE (t); + tree max = TYPE_MAX_VALUE (t); + + m2pp_print (s, "["); + m2pp_expression (s, min); + m2pp_print (s, ".."); + m2pp_expression (s, max); + m2pp_print (s, "]"); +} + +/* m2pp_gimplified print out a gimplified comment. */ + +static void +m2pp_gimpified (pretty *s, tree t) +{ + if (!TYPE_SIZES_GIMPLIFIED (t)) + { + m2pp_print (s, "(* *)"); + m2pp_needspace (s); + } +} + +/* m2pp_printer_type display the pointer type. */ + +static void +m2pp_pointer_type (pretty *s, tree t) +{ + push (t); + if (TREE_CODE (t) == POINTER_TYPE) + { + if (TREE_CODE (TREE_TYPE (t)) == FUNCTION_TYPE) + m2pp_procedure_type (s, TREE_TYPE (t)); + else if (t == ptr_type_node) + m2pp_print (s, "ADDRESS"); + else + { + m2pp_print (s, "POINTER TO"); + m2pp_needspace (s); + m2pp_type (s, TREE_TYPE (t)); + } + } + pop (); +} + +/* m2pp_record_alignment prints out whether this record is aligned + (packed). */ + +static void +m2pp_record_alignment (pretty *s, tree t) +{ + if (TYPE_PACKED (t)) + m2pp_print (s, "<* bytealignment (0) *>\n"); +} + +static unsigned int +m2pp_getaligned (tree t) +{ + if (DECL_P (t)) + { + if (DECL_USER_ALIGN (t)) + return DECL_ALIGN (t); + } + else if (TYPE_P (t)) + { + if (TYPE_USER_ALIGN (t)) + return TYPE_ALIGN (t); + } + return 0; +} + +static void +m2pp_recordfield_alignment (pretty *s, tree t) +{ + unsigned int aligned = m2pp_getaligned (t); + + if (aligned != 0) + { + int o = getindent (s); + int p = getcurpos (s); + m2pp_needspace (s); + m2pp_print (s, "<* bytealignment ("); + setindent (s, p + 18); + + printf ("%d", aligned / BITS_PER_UNIT); + + m2pp_print (s, ")"); + m2pp_needspace (s); + setindent (s, p); + m2pp_print (s, "*>"); + setindent (s, o); + } +} + +static void +m2pp_recordfield_bitfield (pretty *s, tree t) +{ + if ((TREE_CODE (t) == FIELD_DECL) && DECL_PACKED (t)) + { + m2pp_print (s, " (* packed"); + if (DECL_NONADDRESSABLE_P (t)) + m2pp_print (s, ", non-addressible"); + if (DECL_BIT_FIELD (t)) + m2pp_print (s, ", bit-field"); + m2pp_print (s, ", offset: "); + m2pp_expression (s, DECL_FIELD_OFFSET (t)); + m2pp_print (s, ", bit offset:"); + m2pp_expression (s, DECL_FIELD_BIT_OFFSET (t)); + m2pp_print (s, " *) "); + } +} + +/* m2pp_record_type displays the record type. */ + +static void +m2pp_record_type (pretty *s, tree t) +{ + push (t); + if (TREE_CODE (t) == RECORD_TYPE) + { + tree i; + int o = getindent (s); + int p = getcurpos (s); + + m2pp_print (s, "RECORD\n"); + setindent (s, p + 3); + m2pp_record_alignment (s, t); + for (i = TYPE_FIELDS (t); i != NULL_TREE; i = TREE_CHAIN (i)) + { + m2pp_identifier (s, i); + m2pp_print (s, " : "); + m2pp_type (s, TREE_TYPE (i)); + m2pp_recordfield_bitfield (s, i); + m2pp_recordfield_alignment (s, i); + m2pp_print (s, ";\n"); + } + setindent (s, p); + m2pp_print (s, "END"); + setindent (s, o); + } + pop (); +} + +/* m2pp_record_type displays the record type. */ + +static void +m2pp_union_type (pretty *s, tree t) +{ + push (t); + if (TREE_CODE (t) == UNION_TYPE) + { + tree i; + int o = getindent (s); + int p = getcurpos (s); + + m2pp_print (s, "CASE .. OF\n"); + setindent (s, p + 3); + m2pp_record_alignment (s, t); + for (i = TYPE_FIELDS (t); i != NULL_TREE; i = TREE_CHAIN (i)) + { + m2pp_identifier (s, i); + m2pp_print (s, " : "); + m2pp_type (s, TREE_TYPE (i)); + m2pp_recordfield_bitfield (s, i); + m2pp_print (s, ";\n"); + } + setindent (s, p); + m2pp_print (s, "END"); + setindent (s, o); + } + pop (); +} + +/* m2pp_simple_type. */ + +static void +m2pp_simple_type (pretty *s, tree t) +{ + if (begin_printed (t)) + { + m2pp_print (s, "<...>"); + return; + } + + m2pp_gimpified (s, t); + switch (TREE_CODE (t)) + { + case INTEGER_TYPE: + m2pp_integer (s, t); + break; + case REAL_TYPE: + m2pp_print (s, "REAL"); + break; + case BOOLEAN_TYPE: + m2pp_print (s, "BOOLEAN"); + break; + case VOID_TYPE: + m2pp_print (s, "ADDRESS"); + break; + case TYPE_DECL: + m2pp_identifier (s, t); + break; + case POINTER_TYPE: + m2pp_pointer_type (s, t); + break; + case RECORD_TYPE: + m2pp_record_type (s, t); + break; + case UNION_TYPE: + m2pp_union_type (s, t); + break; + case ENUMERAL_TYPE: + m2pp_enum (s, t); + break; + case COMPLEX_TYPE: + m2pp_complex (s, t); + break; + default: + m2pp_unknown (s, __FUNCTION__, get_tree_code_name (TREE_CODE (t))); + } +} + +/* m2pp_expression display an expression. */ + +static void +m2pp_expression (pretty *s, tree t) +{ + enum tree_code code = TREE_CODE (t); + + switch (code) + { + case EQ_EXPR: + m2pp_relop (s, t, "="); + break; + case NE_EXPR: + m2pp_relop (s, t, "#"); + break; + case LE_EXPR: + m2pp_relop (s, t, "<="); + break; + case GE_EXPR: + m2pp_relop (s, t, ">="); + break; + case LT_EXPR: + m2pp_relop (s, t, "<"); + break; + case GT_EXPR: + m2pp_relop (s, t, ">"); + break; + default: + m2pp_simple_expression (s, t); + } +} + +/* m2pp_relop displays the lhs relop rhs. */ + +static void +m2pp_relop (pretty *s, tree t, const char *p) +{ + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_needspace (s); + m2pp_print (s, p); + m2pp_needspace (s); + m2pp_expression (s, TREE_OPERAND (t, 1)); +} + +/* m2pp_compound_expression handle compound expression tree. */ + +static void +m2pp_compound_expression (pretty *s, tree t) +{ + m2pp_print (s, "compound expression {"); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, " (* result ignored *), "); + m2pp_expression (s, TREE_OPERAND (t, 1)); + m2pp_print (s, "}"); + m2pp_needspace (s); +} + +/* m2pp_target_expression handle target expression tree. */ + +static void +m2pp_target_expression (pretty *s, tree t) +{ + m2pp_print (s, "{"); + m2pp_needspace (s); + if (TREE_OPERAND (t, 0) != NULL_TREE) + { + m2pp_print (s, "(* target *) "); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, ","); + m2pp_needspace (s); + } + if (TREE_OPERAND (t, 1) != NULL_TREE) + { + m2pp_print (s, "(* initializer *) "); + m2pp_expression (s, TREE_OPERAND (t, 1)); + m2pp_print (s, ","); + m2pp_needspace (s); + } + if (TREE_OPERAND (t, 2) != NULL_TREE) + { + m2pp_print (s, "(* cleanup *) "); + m2pp_expression (s, TREE_OPERAND (t, 2)); + m2pp_print (s, ","); + m2pp_needspace (s); + } + if (TREE_OPERAND (t, 3) != NULL_TREE) + { + m2pp_print (s, "(* saved initializer *) "); + m2pp_expression (s, TREE_OPERAND (t, 3)); + m2pp_print (s, ","); + m2pp_needspace (s); + } + m2pp_print (s, "}"); + m2pp_needspace (s); +} + +/* m2pp_constructor print out a constructor. */ + +static void +m2pp_constructor (pretty *s, tree t) +{ + tree purpose, value; + unsigned HOST_WIDE_INT ix; + + m2pp_print (s, "{ "); + FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (t), ix, purpose, value) + { + m2pp_print (s, "(index: "); + m2pp_simple_expression (s, purpose); + m2pp_print (s, ") "); + m2pp_simple_expression (s, value); + m2pp_print (s, ", "); + } + m2pp_print (s, "}"); + m2pp_print (s, "(* type: "); + setindent (s, getindent (s) + 8); + m2pp_type (s, TREE_TYPE (t)); + setindent (s, getindent (s) - 8); + m2pp_print (s, " *)\n"); +} + +/* m2pp_complex_expr handle GCC complex_expr tree. */ + +static void +m2pp_complex_expr (pretty *s, tree t) +{ + if (TREE_CODE (t) == COMPLEX_CST) + { + m2pp_print (s, "CMPLX("); + m2pp_needspace (s); + m2pp_expression (s, TREE_REALPART (t)); + m2pp_print (s, ","); + m2pp_needspace (s); + m2pp_expression (s, TREE_IMAGPART (t)); + m2pp_print (s, ")"); + } + else + { + m2pp_print (s, "CMPLX("); + m2pp_needspace (s); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, ","); + m2pp_needspace (s); + m2pp_expression (s, TREE_OPERAND (t, 1)); + m2pp_print (s, ")"); + } +} + +/* m2pp_imagpart_expr handle imagpart_expr tree. */ + +static void +m2pp_imagpart_expr (pretty *s, tree t) +{ + m2pp_print (s, "IM("); + m2pp_needspace (s); + if (TREE_CODE (t) == IMAGPART_EXPR) + m2pp_expression (s, TREE_OPERAND (t, 0)); + else if (TREE_CODE (t) == COMPLEX_CST) + m2pp_expression (s, TREE_IMAGPART (t)); + m2pp_needspace (s); + m2pp_print (s, ")"); +} + +/* m2pp_realpart_expr handle imagpart_expr tree. */ + +static void +m2pp_realpart_expr (pretty *s, tree t) +{ + m2pp_print (s, "RE("); + m2pp_needspace (s); + if (TREE_CODE (t) == REALPART_EXPR) + m2pp_expression (s, TREE_OPERAND (t, 0)); + else if (TREE_CODE (t) == COMPLEX_CST) + m2pp_expression (s, TREE_REALPART (t)); + m2pp_needspace (s); + m2pp_print (s, ")"); +} + +/* m2pp_bit_ior_expr generate a C style bit or. */ + +static void +m2pp_bit_ior_expr (pretty *s, tree t) +{ + m2pp_binary (s, t, "|"); +} + +/* m2pp_truth_expr. */ + +static void +m2pp_truth_expr (pretty *s, tree t, const char *op) +{ + m2pp_print (s, "("); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, ")"); + m2pp_needspace (s); + m2pp_print (s, op); + m2pp_needspace (s); + m2pp_print (s, "("); + m2pp_expression (s, TREE_OPERAND (t, 1)); + m2pp_print (s, ")"); +} + +/* m2pp_simple_expression handle GCC expression tree. */ + +static void +m2pp_simple_expression (pretty *s, tree t) +{ + enum tree_code code = TREE_CODE (t); + + switch (code) + { + case ERROR_MARK: + m2pp_print (s, "(* !!! ERROR NODE !!! *)"); + break; + case CONSTRUCTOR: + m2pp_constructor (s, t); + break; + case IDENTIFIER_NODE: + m2pp_ident_pointer (s, t); + break; + case PARM_DECL: + m2pp_identifier (s, t); + break; + case FIELD_DECL: + m2pp_identifier (s, t); + break; + case TREE_LIST: + m2pp_list (s, t); + break; + case BLOCK: + m2pp_print (s, "(* BLOCK NODE *)"); + break; + case OFFSET_TYPE: + m2pp_offset (s, t); + break; + case INTEGER_CST: + m2pp_integer_cst (s, t); + break; + case REAL_CST: + m2pp_real_cst (s, t); + break; + case STRING_CST: + m2pp_string_cst (s, t); + break; + case INDIRECT_REF: + m2pp_indirect_ref (s, t); + break; + case ADDR_EXPR: + m2pp_addr_expr (s, t); + break; + case NOP_EXPR: + m2pp_nop (s, t); + break; + case CONVERT_EXPR: + m2pp_convert (s, t); + break; + case VAR_DECL: + m2pp_var_decl (s, t); + break; + case RESULT_DECL: + m2pp_result_decl (s, t); + break; + case PLUS_EXPR: + m2pp_binary (s, t, "+"); + break; + case MINUS_EXPR: + m2pp_binary (s, t, "-"); + break; + case MULT_EXPR: + m2pp_binary (s, t, "*"); + break; + case FLOOR_DIV_EXPR: + case CEIL_DIV_EXPR: + case TRUNC_DIV_EXPR: + case ROUND_DIV_EXPR: + m2pp_binary (s, t, "DIV"); + break; + case FLOOR_MOD_EXPR: + case CEIL_MOD_EXPR: + case TRUNC_MOD_EXPR: + case ROUND_MOD_EXPR: + m2pp_binary (s, t, "MOD"); + break; + case NEGATE_EXPR: + m2pp_unary (s, t, "-"); + break; + case CALL_EXPR: + m2pp_call_expr (s, t); + break; + case SSA_NAME: + m2pp_ssa (s, t); + break; + case COMPONENT_REF: + m2pp_component_ref (s, t); + break; + case RETURN_EXPR: + m2pp_return_expr (s, t); + break; + case ARRAY_REF: + m2pp_array_ref (s, t); + break; + case NON_LVALUE_EXPR: + m2pp_non_lvalue_expr (s, t); + break; + case EXPR_STMT: + m2pp_expression (s, EXPR_STMT_EXPR (t)); + break; +#if 0 + case EXC_PTR_EXPR: + m2pp_print (s, "GCC_EXCEPTION_OBJECT"); + break; +#endif + case INIT_EXPR: + case MODIFY_EXPR: + m2pp_assignment (s, t); + break; + case COMPOUND_EXPR: + m2pp_compound_expression (s, t); + break; + case TARGET_EXPR: + m2pp_target_expression (s, t); + break; + case THROW_EXPR: + m2pp_throw (s, t); + break; + case FUNCTION_DECL: + m2pp_identifier (s, t); + break; + case COMPLEX_EXPR: + m2pp_complex_expr (s, t); + break; + case REALPART_EXPR: + m2pp_realpart_expr (s, t); + break; + case IMAGPART_EXPR: + m2pp_imagpart_expr (s, t); + break; + case CONST_DECL: + m2pp_identifier (s, t); + break; + case POINTER_PLUS_EXPR: + m2pp_binary (s, t, "+"); + break; + case CLEANUP_POINT_EXPR: + m2pp_cleanup_point_expr (s, t); + break; + case BIT_IOR_EXPR: + m2pp_bit_ior_expr (s, t); + break; + case TRUTH_ANDIF_EXPR: + m2pp_truth_expr (s, t, "AND"); + break; + case TRUTH_ORIF_EXPR: + m2pp_truth_expr (s, t, "OR"); + break; + default: + m2pp_unknown (s, __FUNCTION__, get_tree_code_name (code)); + } +} + +/* non_lvalue_expr indicates that operand 0 is not an lvalue. */ + +static void +m2pp_non_lvalue_expr (pretty *s, tree t) +{ + m2pp_needspace (s); + m2pp_print (s, "assert_non_lvalue("); + m2pp_needspace (s); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_needspace (s); + m2pp_print (s, ")"); +} + +/* m2pp_array_ref prints out the array reference. */ + +static void +m2pp_array_ref (pretty *s, tree t) +{ + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, "["); + m2pp_expression (s, TREE_OPERAND (t, 1)); + m2pp_print (s, "]"); +} + +/* m2pp_ssa prints out the ssa variable name. */ + +static void +m2pp_ssa (pretty *s, tree t) +{ + m2pp_identifier (s, SSA_NAME_VAR (t)); +} + +/* m2pp_binary print the binary operator, p, and lhs, rhs. */ + +static void +m2pp_binary (pretty *s, tree t, const char *p) +{ + tree left = TREE_OPERAND (t, 0); + tree right = TREE_OPERAND (t, 1); + + m2pp_expression (s, left); + m2pp_needspace (s); + m2pp_print (s, p); + m2pp_needspace (s); + m2pp_expression (s, right); +} + +/* m2pp_unary print the unary operator, p, and expression. */ + +static void +m2pp_unary (pretty *s, tree t, const char *p) +{ + tree expr = TREE_OPERAND (t, 0); + + m2pp_needspace (s); + m2pp_print (s, p); + m2pp_expression (s, expr); +} + +/* m2pp_integer_cst displays the integer constant. */ + +static void +m2pp_integer_cst (pretty *s, tree t) +{ + char val[100]; + + snprintf (val, 100, "%lud", TREE_INT_CST_LOW (t)); + m2pp_print (s, val); +} + +/* m2pp_real_cst displays the real constant. */ + +static void +m2pp_real_cst (pretty *s, tree t ATTRIBUTE_UNUSED) +{ + m2pp_print (s, ""); +} + +/* m2pp_string_cst displays the real constant. */ + +static void +m2pp_string_cst (pretty *s, tree t) +{ + const char *p = TREE_STRING_POINTER (t); + int i = 0; + + m2pp_print (s, "\""); + while (p[i] != '\0') + { + m2pp_print_char (s, p[i]); + i++; + } + m2pp_print (s, "\""); +} + +/* m2pp_statement_sequence iterates over a statement list + displaying each statement in turn. */ + +static void +m2pp_statement_sequence (pretty *s, tree t) +{ + if (t != NULL_TREE) + { + if (TREE_CODE (t) == STATEMENT_LIST) + { + tree_stmt_iterator i; + m2pp_print (s, "(* statement list *)\n"); + + for (i = tsi_start (t); !tsi_end_p (i); tsi_next (&i)) + m2pp_statement (s, *tsi_stmt_ptr (i)); + } + else + m2pp_statement (s, t); + } +} + +/* m2pp_unknown displays an error message. */ + +static void +m2pp_unknown (pretty *s, const char *s1, const char *s2) +{ + m2pp_begin (s); + m2pp_print (s, s1); + m2pp_needspace (s); + m2pp_print (s, s2); + m2pp_needspace (s); +} + +/* m2pp_throw displays a throw statement. */ + +static void +m2pp_throw (pretty *s, tree t) +{ + tree expr = TREE_OPERAND (t, 0); + + m2pp_begin (s); + if (expr == NULL_TREE) + m2pp_print (s, "THROW ;\n"); + else + { + m2pp_print (s, "THROW ("); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, ")\n"); + } +} + +/* m2pp_catch_expr attempts to reconstruct a catch expr. */ + +static void +m2pp_catch_expr (pretty *s, tree t) +{ + tree types = CATCH_TYPES (t); + tree body = CATCH_BODY (t); + + m2pp_print (s, "(* CATCH expression "); + if (types != NULL_TREE) + { + m2pp_print (s, "("); + m2pp_expression (s, types); + m2pp_print (s, ")"); + } + m2pp_print (s, "*)\n"); + m2pp_print (s, "(* catch body *)\n"); + m2pp_statement_sequence (s, body); + m2pp_print (s, "(* end catch body *)\n"); +} + +/* m2pp_try_finally_expr attemts to reconstruct a try finally expr. */ + +static void +m2pp_try_finally_expr (pretty *s, tree t) +{ + m2pp_begin (s); + m2pp_print (s, "(* try_finally_expr *)\n"); + setindent (s, getindent (s) + 3); + m2pp_statement_sequence (s, TREE_OPERAND (t, 0)); + setindent (s, getindent (s) - 3); + m2pp_print (s, + "(* finally (cleanup which is executed after the above) *)\n"); + setindent (s, getindent (s) + 3); + m2pp_statement_sequence (s, TREE_OPERAND (t, 1)); + setindent (s, getindent (s) - 3); + m2pp_print (s, "(* end try_finally_expr *)\n"); +} + +#if !defined(GM2) +/* m2pp_if_stmt pretty print a C++ if_stmt. */ + +static void +m2pp_if_stmt (pretty *s, tree t) +{ + m2pp_print (s, "(* only C++ uses if_stmt nodes *)\n"); + m2pp_print (s, "IF "); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, "\n"); + m2pp_print (s, "THEN\n"); + setindent (s, getindent (s) + 3); + m2pp_statement_sequence (s, TREE_OPERAND (t, 1)); + setindent (s, getindent (s) - 3); + m2pp_print (s, "ELSE\n"); + setindent (s, getindent (s) + 3); + m2pp_statement_sequence (s, TREE_OPERAND (t, 2)); + setindent (s, getindent (s) - 3); + m2pp_print (s, "END\n"); +} +#endif + +/* m2pp_statement attempts to reconstruct a statement. */ + +static void +m2pp_statement (pretty *s, tree t) +{ + enum tree_code code = TREE_CODE (t); + + m2pp_loc (s, t); + switch (code) + { + case COND_EXPR: + m2pp_conditional (s, t); + break; + case LABEL_EXPR: + m2pp_label_expr (s, t); + break; + case LABEL_DECL: + m2pp_label_decl (s, t); + break; + case GOTO_EXPR: + m2pp_goto (s, t); + break; + case INIT_EXPR: + case MODIFY_EXPR: + m2pp_assignment (s, t); + break; + case CALL_EXPR: + m2pp_procedure_call (s, t); + break; + case BLOCK: + m2pp_block_list (s, t); + break; + case BIND_EXPR: + m2pp_bind_expr (s, t); + break; + case RETURN_EXPR: + m2pp_return_expr (s, t); + break; + case DECL_EXPR: + m2pp_decl_expr (s, t); + break; + case TRY_BLOCK: + m2pp_try_block (s, t); + break; + case HANDLER: + m2pp_handler (s, t); + break; + case CLEANUP_POINT_EXPR: + m2pp_cleanup_point_expr (s, t); + break; + case THROW_EXPR: + m2pp_throw (s, t); + break; + case TRY_CATCH_EXPR: + m2pp_try_catch_expr (s, t); + break; + case TRY_FINALLY_EXPR: + m2pp_try_finally_expr (s, t); + break; + case CATCH_EXPR: + m2pp_catch_expr (s, t); + break; +#if defined(CPP) + case IF_STMT: + m2pp_if_stmt (s, t); + break; +#endif + case ERROR_MARK: + m2pp_print (s, "\n"); + break; + default: + m2pp_unknown (s, __FUNCTION__, get_tree_code_name (TREE_CODE (t))); + } +} + +/* m2pp_try_catch_expr is used after gimplification. */ + +static void +m2pp_try_catch_expr (pretty *s, tree t) +{ + m2pp_print (s, "(* try_catch_expr begins *)\n"); + m2pp_statement_sequence (s, TREE_OPERAND (t, 0)); + setindent (s, 0); + m2pp_print (s, "EXCEPT\n"); + setindent (s, 3); + m2pp_statement_sequence (s, TREE_OPERAND (t, 1)); + m2pp_print (s, "(* try_catch_expr ends *)\n"); +} + +/* m2pp_cleanup_point_expr emits a comment indicating a GCC + cleanup_point_expr is present. */ + +static void +m2pp_cleanup_point_expr (pretty *s, tree t) +{ + m2pp_begin (s); + m2pp_print (s, "(* cleanup point begins *)\n"); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, "(* cleanup point ends *)\n"); +} + +/* m2pp_decl_expr displays a local declaration. */ + +static void +m2pp_decl_expr (pretty *s, tree t) +{ + m2pp_var (s); + m2pp_print (s, "(* variable in decl_expr *)\n"); + m2pp_var_type_decl (s, DECL_EXPR_DECL (t)); +} + +/* m2pp_procedure_call print a call to a procedure. */ + +static void +m2pp_procedure_call (pretty *s, tree t) +{ + m2pp_begin (s); + m2pp_call_expr (s, t); + m2pp_needspace (s); + m2pp_print (s, ";\n"); +} + +/* args displays each argument in an iter list by calling expression. */ + +static void +m2pp_args (pretty *s, tree e) +{ + call_expr_arg_iterator iter; + tree arg; + + m2pp_print (s, "("); + m2pp_needspace (s); + FOR_EACH_CALL_EXPR_ARG (arg, iter, e) + { + m2pp_expression (s, arg); + if (more_call_expr_args_p (&iter)) + { + m2pp_print (s, ","); + m2pp_needspace (s); + } + } + m2pp_print (s, ")"); +} + +/* m2pp_call_expr print a call to a procedure or function. */ + +static void +m2pp_call_expr (pretty *s, tree t) +{ + tree call = CALL_EXPR_FN (t); + tree args = TREE_OPERAND (t, 1); + tree type = TREE_TYPE (t); + int has_return_type = TRUE; + tree proc; + + if (type && (TREE_CODE (type) == VOID_TYPE)) + has_return_type = FALSE; + + if (TREE_CODE (call) == ADDR_EXPR || TREE_CODE (call) == NON_LVALUE_EXPR) + proc = TREE_OPERAND (call, 0); + else + proc = call; + + m2pp_expression (s, proc); + if (args || has_return_type) + m2pp_args (s, t); +} + +/* m2pp_return_expr displays the return statement. */ + +static void +m2pp_return_expr (pretty *s, tree t) +{ + tree e = TREE_OPERAND (t, 0); + + m2pp_begin (s); + if (e == NULL_TREE) + { + m2pp_print (s, "RETURN"); + } + else if (TREE_CODE (e) == MODIFY_EXPR || (TREE_CODE (e) == INIT_EXPR)) + { + m2pp_assignment (s, e); + m2pp_print (s, "RETURN"); + m2pp_needspace (s); + m2pp_expression (s, TREE_OPERAND (e, 0)); + } + else + { + m2pp_print (s, "RETURN"); + m2pp_needspace (s); + m2pp_expression (s, e); + } + m2pp_needspace (s); + m2pp_print (s, ";\n"); +} + +/* m2pp_try_block displays the try block. */ + +static void +m2pp_try_block (pretty *s, tree t) +{ + tree stmts = TRY_STMTS (t); + tree handlers = TRY_HANDLERS (t); + + m2pp_begin (s); + m2pp_print (s, "(* TRY *)\n"); + m2pp_statement_sequence (s, stmts); + setindent (s, 0); + m2pp_print (s, "EXCEPT\n"); + setindent (s, 3); + m2pp_statement_sequence (s, handlers); + m2pp_print (s, "(* END TRY *)\n"); +} + +/* m2pp_try_block displays the handler block. */ + +static void +m2pp_handler (pretty *s, tree t) +{ + tree parms = HANDLER_PARMS (t); + tree body = HANDLER_BODY (t); + tree type = HANDLER_TYPE (t); + + m2pp_print (s, "(* handler *)\n"); + if (parms != NULL_TREE) + { + m2pp_print (s, "(* handler parameter has a type (should be NULL_TREE) " + "in Modula-2 *)\n"); + m2pp_print (s, "CATCH ("); + m2pp_expression (s, parms); + m2pp_print (s, ")\n"); + } + if (type != NULL_TREE) + m2pp_print (s, "(* handler type (should be NULL_TREE) in Modula-2 *)\n"); + m2pp_statement_sequence (s, body); +} + +/* m2pp_assignment prints out the assignment statement. */ + +static void +m2pp_assignment (pretty *s, tree t) +{ + int o; + + m2pp_begin (s); + m2pp_designator (s, TREE_OPERAND (t, 0)); + m2pp_needspace (s); + m2pp_print (s, ":="); + m2pp_needspace (s); + o = getindent (s); + setindent (s, getcurpos (s) + 1); + m2pp_expression (s, TREE_OPERAND (t, 1)); + m2pp_needspace (s); + m2pp_print (s, ";\n"); + setindent (s, o); +} + +/* m2pp_designator displays the lhs of an assignment. */ + +static void +m2pp_designator (pretty *s, tree t) +{ + m2pp_expression (s, t); +} + +/* m2pp_indirect_ref displays the indirect operator. */ + +static void +m2pp_indirect_ref (pretty *s, tree t) +{ + m2pp_print (s, "("); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, ")^"); +} + +/* m2pp_conditional builds an IF THEN ELSE END. With more work + this should be moved into statement sequence which could look for + repeat and while loops. */ + +static void +m2pp_conditional (pretty *s, tree t) +{ + int o; + + m2pp_begin (s); + m2pp_print (s, "IF"); + m2pp_needspace (s); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, "\nTHEN\n"); + o = getindent (s); + setindent (s, o + 3); + m2pp_statement_sequence (s, TREE_OPERAND (t, 1)); + setindent (s, o); + if (TREE_OPERAND (t, 2) != NULL_TREE) + { + m2pp_print (s, "ELSE\n"); + setindent (s, o + 3); + m2pp_statement_sequence (s, TREE_OPERAND (t, 2)); + setindent (s, o); + } + m2pp_print (s, "END ;\n"); +} + +/* m2pp_label_decl displays a label. Again should be moved into + statement sequence to determine proper loop constructs. */ + +static void +m2pp_label_decl (pretty *s, tree t) +{ + m2pp_begin (s); + m2pp_print (s, "(* label "); + m2pp_identifier (s, t); + m2pp_print (s, ": *)\n"); +} + +/* m2pp_label_expr skips the LABEL_EXPR to find the LABEL_DECL. */ + +static void +m2pp_label_expr (pretty *s, tree t) +{ + m2pp_begin (s); + m2pp_statement (s, TREE_OPERAND (t, 0)); +} + +/* m2pp_goto displays a goto statement. Again should be moved into + statement sequence to determine proper loop constructs. */ + +static void +m2pp_goto (pretty *s, tree t) +{ + m2pp_begin (s); + m2pp_print (s, "(* goto "); + m2pp_identifier (s, TREE_OPERAND (t, 0)); + m2pp_print (s, " *)\n"); +} + +/* m2pp_list prints a TREE_CHAINed list. */ + +static void +m2pp_list (pretty *s, tree t) +{ + tree u = t; + + m2pp_print (s, "("); + m2pp_needspace (s); + while (t != NULL_TREE) + { + m2pp_expression (s, TREE_VALUE (t)); + t = TREE_CHAIN (t); + if (t == u || t == NULL_TREE) + break; + m2pp_print (s, ","); + m2pp_needspace (s); + } + m2pp_needspace (s); + m2pp_print (s, ")"); +} + +/* m2pp_offset displays the offset operator. */ + +static void +m2pp_offset (pretty *s, tree t) +{ + tree type = TREE_TYPE (t); + tree base = TYPE_OFFSET_BASETYPE (t); + + m2pp_print (s, "OFFSET ("); + m2pp_type (s, base); + m2pp_print (s, "."); + m2pp_type (s, type); + m2pp_print (s, ")"); +} + +/* m2pp_addr_expr create an ADR expression. */ + +static void +m2pp_addr_expr (pretty *s, tree t) +{ + m2pp_needspace (s); + m2pp_print (s, "ADR ("); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, ")"); +} + +/* m2pp_nop generate a CAST expression. */ + +static void +m2pp_nop (pretty *s, tree t) +{ + m2pp_needspace (s); + m2pp_print (s, "CAST ("); + m2pp_simple_type (s, TREE_TYPE (t)); + m2pp_print (s, ", "); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, ")"); +} + +/* m2pp_convert generate a CONVERT expression. */ + +static void +m2pp_convert (pretty *s, tree t) +{ + m2pp_needspace (s); + m2pp_print (s, "CONVERT ("); + m2pp_simple_type (s, TREE_TYPE (t)); + m2pp_print (s, ", "); + m2pp_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, ")"); +} + +/* m2pp_var_decl generate a variable. */ + +static void +m2pp_var_decl (pretty *s, tree t) +{ + m2pp_identifier (s, t); +} + +/* m2pp_result_decl generate a result declaration (variable). */ + +static void +m2pp_result_decl (pretty *s, tree t) +{ + m2pp_identifier (s, t); +} + +/* m2pp_component_ref generate a record field access. */ + +static void +m2pp_component_ref (pretty *s, tree t) +{ + m2pp_simple_expression (s, TREE_OPERAND (t, 0)); + m2pp_print (s, "."); + m2pp_simple_expression (s, TREE_OPERAND (t, 1)); +} + +} diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/m2pp.h --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/m2pp.h 2022-12-06 19:11:43.238260073 +0000 @@ -0,0 +1,43 @@ +/* m2pp.h pretty print trees, output in Modula-2 where possible. + +Copyright (C) 2007-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 +. */ + +#if !defined(M2PP_H) +# define M2PP_H + +# if defined(M2PP_C) +# define EXTERN +# else +# define EXTERN extern +# endif + +namespace modula2 { +/* These functions allow a maintainer to dump the trees in Modula-2. */ + +EXTERN void pf (tree t); +EXTERN void pe (tree t); +EXTERN void pt (tree t); +EXTERN void ptl (tree t); +EXTERN void pv (tree t); +EXTERN void ptcl (tree t); +} + +# undef EXTERN +#endif diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/m2-tree.def --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/m2-tree.def 2022-12-06 02:56:51.360774949 +0000 @@ -0,0 +1,24 @@ +/* gm2-tree.def a component of a C header file used to define a SET type. + +Copyright (C) 2006-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 COPYING. If not, write to the +Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ + +/* A SET_TYPE type. */ +DEFTREECODE (SET_TYPE, "set_type", tcc_type, 0) diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/m2-tree.h --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/m2-tree.h 2022-12-06 02:56:51.360774949 +0000 @@ -0,0 +1,48 @@ +/* m2-tree.h create language specific tree nodes for Modula-2. + +Copyright (C) 2001-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 +. */ + +#ifndef GCC_GM2_TREE_H +#define GCC_GM2_TREE_H + +#include "ggc.h" +#include "function.h" +#include "hashtab.h" +#include "vec.h" + +/* These macros provide convenient access to the various statement nodes. */ + +#define TRY_STMTS(NODE) TREE_OPERAND (TRY_BLOCK_CHECK (NODE), 0) +#define TRY_HANDLERS(NODE) TREE_OPERAND (TRY_BLOCK_CHECK (NODE), 1) + +/* Nonzero if this try block is a function try block. */ +#define FN_TRY_BLOCK_P(NODE) TREE_LANG_FLAG_3 (TRY_BLOCK_CHECK (NODE)) +#define HANDLER_PARMS(NODE) TREE_OPERAND (HANDLER_CHECK (NODE), 0) +#define HANDLER_BODY(NODE) TREE_OPERAND (HANDLER_CHECK (NODE), 1) +#define HANDLER_TYPE(NODE) TREE_TYPE (HANDLER_CHECK (NODE)) + +/* STMT_EXPR accessor. */ +#define STMT_EXPR_STMT(NODE) TREE_OPERAND (STMT_EXPR_CHECK (NODE), 0) + +/* EXPR_STMT accessor. This gives the expression associated with an + expression statement. */ +#define EXPR_STMT_EXPR(NODE) TREE_OPERAND (EXPR_STMT_CHECK (NODE), 0) + +#endif diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/version.c --- /dev/null 2022-08-24 16:22:16.888000070 +0100 +++ gcc-git-devel-modula2/gcc/m2/version.c 2022-12-06 02:56:51.380775219 +0000 @@ -0,0 +1 @@ +#define version_string "1.9.5"