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