* [PATCH] 11/19 modula2 front end: gimple interface *[a-d]*.cc
@ 2022-10-10 15:31 Gaius Mulley
0 siblings, 0 replies; only message in thread
From: Gaius Mulley @ 2022-10-10 15:31 UTC (permalink / raw)
To: gcc-patches
This patchset contains the gimple interface.
------8<----------8<----------8<----------8<----------8<----------8<----
diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2assert.cc
--- /dev/null 2022-08-24 16:22:16.888000070 +0100
+++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2assert.cc 2022-10-07 20:21:18.650096940 +0100
@@ -0,0 +1,41 @@
+/* m2assert.cc provides a simple assertion for location.
+
+Copyright (C) 2012-2022 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <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 m2assert_c
+#include "m2assert.h"
+#include "m2options.h"
+
+void
+m2assert_AssertLocation (location_t location)
+{
+ /* Internally the compiler will use unknown location and
+ builtins_location so we ignore these values. */
+ if (location == BUILTINS_LOCATION || location == UNKNOWN_LOCATION)
+ return;
+
+ if (M2Options_OverrideLocation (location) != location)
+ internal_error ("the location value is corrupt");
+}
diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2block.cc
--- /dev/null 2022-08-24 16:22:16.888000070 +0100
+++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2block.cc 2022-10-07 20:21:18.650096940 +0100
@@ -0,0 +1,770 @@
+/* m2block.cc provides an interface to maintaining block structures.
+
+Copyright (C) 2012-2022 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <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"
+
+#define m2block_c
+#include "m2assert.h"
+#include "m2block.h"
+#include "m2decl.h"
+#include "m2options.h"
+#include "m2tree.h"
+#include "m2treelib.h"
+
+/* For each binding contour we allocate a binding_level structure
+ which records the entities defined or declared in that contour.
+ Contours include:
+
+ the global one one for each subprogram definition
+
+ Binding contours are used to create GCC tree BLOCK nodes. */
+
+struct GTY (()) binding_level
+{
+ /* The function associated with the scope. This is NULL_TREE for the
+ global scope. */
+ tree fndecl;
+
+ /* A chain of _DECL nodes for all variables, constants, functions,
+ and typedef types. These are in the reverse of the order supplied. */
+ tree names;
+
+ /* A boolean to indicate whether this is binding level is a global ie
+ outer module scope. In which case fndecl will be NULL_TREE. */
+ int is_global;
+
+ /* The context of the binding level, for a function binding level
+ this will be the same as fndecl, however for a global binding level
+ this is a translation_unit. */
+ tree context;
+
+ /* The binding level below this one. This field is only used when
+ the binding level has been pushed by pushFunctionScope. */
+ struct binding_level *next;
+
+ /* All binding levels are placed onto this list. */
+ struct binding_level *list;
+
+ /* A varray of trees, which represent the list of statement
+ sequences. */
+ vec<tree, va_gc> *m2_statements;
+
+ /* A list of constants (only kept in the global binding level).
+ Constants need to be kept through the life of the compilation, as the
+ same constants can be used in any scope. */
+ tree constants;
+
+ /* A list of inner module initialization functions. */
+ tree init_functions;
+
+ /* A list of types created by M2GCCDeclare prior to code generation
+ and those which may not be specifically declared and saved via a
+ push_decl. */
+ tree types;
+
+ /* A list of all DECL_EXPR created within this binding level. This
+ will be prepended to the statement list once the binding level (scope
+ is finished). */
+ tree decl;
+
+ /* A list of labels which have been created in this scope. */
+ tree labels;
+
+ /* The number of times this level has been pushed. */
+ int count;
+};
+
+/* The binding level currently in effect. */
+
+static GTY (()) struct binding_level *current_binding_level;
+
+/* The outermost binding level, for names of file scope. This is
+ created when the compiler is started and exists through the entire
+ run. */
+
+static GTY (()) struct binding_level *global_binding_level;
+
+/* The head of the binding level lists. */
+static GTY (()) struct binding_level *head_binding_level;
+
+/* The current statement tree. */
+
+typedef struct stmt_tree_s *stmt_tree_t;
+
+#undef DEBUGGING
+
+static location_t pending_location;
+static int pending_statement = FALSE;
+
+/* assert_global_names asserts that the global_binding_level->names
+ can be chained. */
+
+static void
+assert_global_names (void)
+{
+ tree p = global_binding_level->names;
+
+ while (p)
+ p = TREE_CHAIN (p);
+}
+
+/* lookupLabel return label tree in current scope, otherwise
+ NULL_TREE. */
+
+static tree
+lookupLabel (tree id)
+{
+ tree t;
+
+ for (t = current_binding_level->labels; t != NULL_TREE; t = TREE_CHAIN (t))
+ {
+ tree l = TREE_VALUE (t);
+
+ if (id == DECL_NAME (l))
+ return l;
+ }
+ return NULL_TREE;
+}
+
+/* getLabel return the label name or create a label name in the
+ current scope. */
+
+tree
+m2block_getLabel (location_t location, char *name)
+{
+ tree id = get_identifier (name);
+ tree label = lookupLabel (id);
+
+ if (label == NULL_TREE)
+ {
+ label = build_decl (location, LABEL_DECL, id, void_type_node);
+ current_binding_level->labels
+ = tree_cons (NULL_TREE, label, current_binding_level->labels);
+ }
+ if (DECL_CONTEXT (label) == NULL_TREE)
+ DECL_CONTEXT (label) = current_function_decl;
+ ASSERT ((DECL_CONTEXT (label) == current_function_decl),
+ current_function_decl);
+
+ DECL_MODE (label) = VOIDmode;
+ return label;
+}
+
+static void
+init_binding_level (struct binding_level *l)
+{
+ l->fndecl = NULL;
+ l->names = NULL;
+ l->is_global = 0;
+ l->context = NULL;
+ l->next = NULL;
+ l->list = NULL;
+ vec_alloc (l->m2_statements, 1);
+ l->constants = NULL;
+ l->init_functions = NULL;
+ l->types = NULL;
+ l->decl = NULL;
+ l->labels = NULL;
+ l->count = 0;
+}
+
+static struct binding_level *
+newLevel (void)
+{
+ struct binding_level *newlevel = ggc_alloc<binding_level> ();
+
+ init_binding_level (newlevel);
+
+ /* Now we a push_statement_list. */
+ vec_safe_push (newlevel->m2_statements, m2block_begin_statement_list ());
+ return newlevel;
+}
+
+tree *
+m2block_cur_stmt_list_addr (void)
+{
+ ASSERT_CONDITION (current_binding_level != NULL);
+ int l = vec_safe_length (current_binding_level->m2_statements) - 1;
+
+ return &(*current_binding_level->m2_statements)[l];
+}
+
+tree
+m2block_cur_stmt_list (void)
+{
+ tree *t = m2block_cur_stmt_list_addr ();
+
+ return *t;
+}
+
+/* is_building_stmt_list returns TRUE if we are building a
+ statement list. TRUE is returned if we are in a binding level and
+ a statement list is under construction. */
+
+int
+m2block_is_building_stmt_list (void)
+{
+ ASSERT_CONDITION (current_binding_level != NULL);
+ return !vec_safe_is_empty (current_binding_level->m2_statements);
+}
+
+/* push_statement_list pushes the statement list t onto the
+ current binding level. */
+
+tree
+m2block_push_statement_list (tree t)
+{
+ ASSERT_CONDITION (current_binding_level != NULL);
+ vec_safe_push (current_binding_level->m2_statements, t);
+ return t;
+}
+
+/* pop_statement_list pops and returns a statement list from the
+ current binding level. */
+
+tree
+m2block_pop_statement_list (void)
+{
+ ASSERT_CONDITION (current_binding_level != NULL);
+ {
+ tree t = current_binding_level->m2_statements->pop ();
+
+ return t;
+ }
+}
+
+/* begin_statement_list starts a tree statement. It pushes the
+ statement list and returns the list node. */
+
+tree
+m2block_begin_statement_list (void)
+{
+ return alloc_stmt_list ();
+}
+
+/* findLevel returns the binding level associated with fndecl one
+ is created if there is no existing one on head_binding_level. */
+
+static struct binding_level *
+findLevel (tree fndecl)
+{
+ struct binding_level *b;
+
+ if (fndecl == NULL_TREE)
+ return global_binding_level;
+
+ b = head_binding_level;
+ while ((b != NULL) && (b->fndecl != fndecl))
+ b = b->list;
+
+ if (b == NULL)
+ {
+ b = newLevel ();
+ b->fndecl = fndecl;
+ b->context = fndecl;
+ b->is_global = FALSE;
+ b->list = head_binding_level;
+ b->next = NULL;
+ }
+ return b;
+}
+
+/* pushFunctionScope push a binding level. */
+
+void
+m2block_pushFunctionScope (tree fndecl)
+{
+ struct binding_level *n;
+ struct binding_level *b;
+
+#if defined(DEBUGGING)
+ if (fndecl != NULL)
+ printf ("pushFunctionScope\n");
+#endif
+
+ /* Allow multiple consecutive pushes of the same scope. */
+
+ if (current_binding_level != NULL
+ && (current_binding_level->fndecl == fndecl))
+ {
+ current_binding_level->count++;
+ return;
+ }
+
+ /* Firstly check to see that fndecl is not already on the binding
+ stack. */
+
+ for (b = current_binding_level; b != NULL; b = b->next)
+ /* Only allowed one instance of the binding on the stack at a time. */
+ ASSERT_CONDITION (b->fndecl != fndecl);
+
+ n = findLevel (fndecl);
+
+ /* Add this level to the front of the stack. */
+ n->next = current_binding_level;
+ current_binding_level = n;
+}
+
+/* popFunctionScope - pops a binding level, returning the function
+ associated with the binding level. */
+
+tree
+m2block_popFunctionScope (void)
+{
+ tree fndecl = current_binding_level->fndecl;
+
+#if defined(DEBUGGING)
+ if (fndecl != NULL)
+ printf ("popFunctionScope\n");
+#endif
+
+ if (current_binding_level->count > 0)
+ {
+ /* Multiple pushes have occurred of the same function scope (and
+ ignored), pop them likewise. */
+ current_binding_level->count--;
+ return fndecl;
+ }
+ ASSERT_CONDITION (current_binding_level->fndecl
+ != NULL_TREE); /* Expecting local scope. */
+
+ ASSERT_CONDITION (current_binding_level->constants
+ == NULL_TREE); /* Should not be used. */
+ ASSERT_CONDITION (current_binding_level->names
+ == NULL_TREE); /* Should be cleared. */
+ ASSERT_CONDITION (current_binding_level->decl
+ == NULL_TREE); /* Should be cleared. */
+
+ current_binding_level = current_binding_level->next;
+ return fndecl;
+}
+
+/* pushGlobalScope push the global scope onto the binding level
+ stack. There can only ever be one instance of the global binding
+ level on the stack. */
+
+void
+m2block_pushGlobalScope (void)
+{
+#if defined(DEBUGGING)
+ printf ("pushGlobalScope\n");
+#endif
+ m2block_pushFunctionScope (NULL_TREE);
+}
+
+/* popGlobalScope pops the current binding level, it expects this
+ binding level to be the global binding level. */
+
+void
+m2block_popGlobalScope (void)
+{
+ ASSERT_CONDITION (
+ current_binding_level->is_global); /* Expecting global scope. */
+ ASSERT_CONDITION (current_binding_level == global_binding_level);
+
+ if (current_binding_level->count > 0)
+ {
+ current_binding_level->count--;
+ return;
+ }
+
+ current_binding_level = current_binding_level->next;
+#if defined(DEBUGGING)
+ printf ("popGlobalScope\n");
+#endif
+
+ assert_global_names ();
+}
+
+/* finishFunctionDecl removes declarations from the current binding
+ level and places them inside fndecl. The current binding level is
+ then able to be destroyed by a call to popFunctionScope.
+
+ The extra tree nodes associated with fndecl will be created such
+ as BIND_EXPR, BLOCK and the initial STATEMENT_LIST containing the
+ DECL_EXPR is also created. */
+
+void
+m2block_finishFunctionDecl (location_t location, tree fndecl)
+{
+ tree context = current_binding_level->context;
+ tree block = DECL_INITIAL (fndecl);
+ tree bind_expr = DECL_SAVED_TREE (fndecl);
+ tree i;
+
+ if (block == NULL_TREE)
+ {
+ block = make_node (BLOCK);
+ DECL_INITIAL (fndecl) = block;
+ TREE_USED (block) = TRUE;
+ BLOCK_SUBBLOCKS (block) = NULL_TREE;
+ }
+ BLOCK_SUPERCONTEXT (block) = context;
+
+ BLOCK_VARS (block)
+ = chainon (BLOCK_VARS (block), current_binding_level->names);
+ TREE_USED (fndecl) = TRUE;
+
+ if (bind_expr == NULL_TREE)
+ {
+ bind_expr
+ = build3 (BIND_EXPR, void_type_node, current_binding_level->names,
+ current_binding_level->decl, block);
+ DECL_SAVED_TREE (fndecl) = bind_expr;
+ }
+ else
+ {
+ if (!chain_member (current_binding_level->names,
+ BIND_EXPR_VARS (bind_expr)))
+ {
+ BIND_EXPR_VARS (bind_expr) = chainon (BIND_EXPR_VARS (bind_expr),
+ current_binding_level->names);
+
+ if (current_binding_level->names != NULL_TREE)
+ {
+ for (i = current_binding_level->names; i != NULL_TREE;
+ i = DECL_CHAIN (i))
+ append_to_statement_list_force (i,
+ &BIND_EXPR_BODY (bind_expr));
+
+ }
+ }
+ }
+ SET_EXPR_LOCATION (bind_expr, location);
+
+ current_binding_level->names = NULL_TREE;
+ current_binding_level->decl = NULL_TREE;
+}
+
+/* finishFunctionCode adds cur_stmt_list to fndecl. The current
+ binding level is then able to be destroyed by a call to
+ popFunctionScope. The cur_stmt_list is appended to the
+ STATEMENT_LIST. */
+
+void
+m2block_finishFunctionCode (tree fndecl)
+{
+ tree bind_expr;
+ tree block;
+ tree statements = m2block_pop_statement_list ();
+ tree_stmt_iterator i;
+
+ ASSERT_CONDITION (DECL_SAVED_TREE (fndecl) != NULL_TREE);
+
+ bind_expr = DECL_SAVED_TREE (fndecl);
+ ASSERT_CONDITION (TREE_CODE (bind_expr) == BIND_EXPR);
+
+ block = DECL_INITIAL (fndecl);
+ ASSERT_CONDITION (TREE_CODE (block) == BLOCK);
+
+ if (current_binding_level->names != NULL_TREE)
+ {
+ BIND_EXPR_VARS (bind_expr)
+ = chainon (BIND_EXPR_VARS (bind_expr), current_binding_level->names);
+ current_binding_level->names = NULL_TREE;
+ }
+ if (current_binding_level->labels != NULL_TREE)
+ {
+ tree t;
+
+ for (t = current_binding_level->labels; t != NULL_TREE;
+ t = TREE_CHAIN (t))
+ {
+ tree l = TREE_VALUE (t);
+
+ BIND_EXPR_VARS (bind_expr) = chainon (BIND_EXPR_VARS (bind_expr), l);
+ }
+ current_binding_level->labels = NULL_TREE;
+ }
+
+ BLOCK_VARS (block) = BIND_EXPR_VARS (bind_expr);
+
+ if (current_binding_level->decl != NULL_TREE)
+ for (i = tsi_start (current_binding_level->decl); !tsi_end_p (i);
+ tsi_next (&i))
+ append_to_statement_list_force (*tsi_stmt_ptr (i),
+ &BIND_EXPR_BODY (bind_expr));
+
+ for (i = tsi_start (statements); !tsi_end_p (i); tsi_next (&i))
+ append_to_statement_list_force (*tsi_stmt_ptr (i),
+ &BIND_EXPR_BODY (bind_expr));
+
+ current_binding_level->decl = NULL_TREE;
+}
+
+void
+m2block_finishGlobals (void)
+{
+ tree context = global_binding_level->context;
+ tree block = make_node (BLOCK);
+ tree p = global_binding_level->names;
+
+ BLOCK_SUBBLOCKS (block) = NULL;
+ TREE_USED (block) = 1;
+
+ BLOCK_VARS (block) = p;
+
+ DECL_INITIAL (context) = block;
+ BLOCK_SUPERCONTEXT (block) = context;
+}
+
+/* pushDecl pushes a declaration onto the current binding level. */
+
+tree
+m2block_pushDecl (tree decl)
+{
+ /* External objects aren't nested, other objects may be. */
+
+ if (decl != current_function_decl)
+ DECL_CONTEXT (decl) = current_binding_level->context;
+
+ /* Put the declaration on the list. The list of declarations is in
+ reverse order. The list will be reversed later if necessary. This
+ needs to be this way for compatibility with the back-end. */
+
+ TREE_CHAIN (decl) = current_binding_level->names;
+ current_binding_level->names = decl;
+
+ assert_global_names ();
+
+ return decl;
+}
+
+/* includeDecl pushes a declaration onto the current binding level
+ providing it is not already present. */
+
+void
+m2block_includeDecl (tree decl)
+{
+ tree p = current_binding_level->names;
+
+ while (p != decl && p != NULL)
+ p = TREE_CHAIN (p);
+ if (p != decl)
+ m2block_pushDecl (decl);
+}
+
+/* addDeclExpr adds the DECL_EXPR node t to the statement list
+ current_binding_level->decl. This allows us to order all
+ declarations at the beginning of the function. */
+
+void
+m2block_addDeclExpr (tree t)
+{
+ append_to_statement_list_force (t, ¤t_binding_level->decl);
+}
+
+/* RememberType remember the type t in the ggc marked list. */
+
+tree
+m2block_RememberType (tree t)
+{
+ global_binding_level->types
+ = tree_cons (NULL_TREE, t, global_binding_level->types);
+ return t;
+}
+
+/* global_constant returns t. It chains t onto the
+ global_binding_level list of constants, if it is not already
+ present. */
+
+tree
+m2block_global_constant (tree t)
+{
+ tree s;
+
+ if (global_binding_level->constants != NULL_TREE)
+ for (s = global_binding_level->constants; s != NULL_TREE;
+ s = TREE_CHAIN (s))
+ {
+ tree c = TREE_VALUE (s);
+
+ if (c == t)
+ return t;
+ }
+
+ global_binding_level->constants
+ = tree_cons (NULL_TREE, t, global_binding_level->constants);
+ return t;
+}
+
+/* RememberConstant adds a tree t onto the list of constants to
+ be marked whenever the ggc re-marks all used storage. Constants
+ live throughout the whole compilation and they can be used by
+ many different functions if necessary. */
+
+tree
+m2block_RememberConstant (tree t)
+{
+ if ((t != NULL) && (m2tree_IsAConstant (t)))
+ return m2block_global_constant (t);
+ return t;
+}
+
+/* DumpGlobalConstants displays all global constants and checks
+ none are poisoned. */
+
+tree
+m2block_DumpGlobalConstants (void)
+{
+ tree s;
+
+ if (global_binding_level->constants != NULL_TREE)
+ for (s = global_binding_level->constants; TREE_CHAIN (s);
+ s = TREE_CHAIN (s))
+ debug_tree (s);
+ return NULL_TREE;
+}
+
+/* RememberInitModuleFunction records tree t in the global
+ binding level. So that it will not be garbage collected. In
+ theory the inner modules could be placed inside the
+ current_binding_level I suspect. */
+
+tree
+m2block_RememberInitModuleFunction (tree t)
+{
+ global_binding_level->init_functions
+ = tree_cons (NULL_TREE, t, global_binding_level->init_functions);
+ return t;
+}
+
+/* toplevel return TRUE if we are in the global scope. */
+
+int
+m2block_toplevel (void)
+{
+ if (current_binding_level == NULL)
+ return TRUE;
+ if (current_binding_level->fndecl == NULL)
+ return TRUE;
+ return FALSE;
+}
+
+/* GetErrorNode returns the gcc error_mark_node. */
+
+tree
+m2block_GetErrorNode (void)
+{
+ return error_mark_node;
+}
+
+/* GetGlobals - returns a list of global variables, functions,
+ constants. */
+
+tree
+m2block_GetGlobals (void)
+{
+ assert_global_names ();
+ return global_binding_level->names;
+}
+
+/* GetGlobalContext - returns the global context tree. */
+
+tree
+m2block_GetGlobalContext (void)
+{
+ return global_binding_level->context;
+}
+
+/* do_add_stmt - t is a statement. Add it to the statement-tree. */
+
+static tree
+do_add_stmt (tree t)
+{
+ if (current_binding_level != NULL)
+ append_to_statement_list_force (t, m2block_cur_stmt_list_addr ());
+ return t;
+}
+
+/* flush_pending_note - flushes a pending_statement note if
+ necessary. */
+
+static void
+flush_pending_note (void)
+{
+ if (pending_statement && (M2Options_GetM2g ()))
+ {
+#if 0
+ /* --fixme-- we need a machine independant way to generate a nop. */
+ tree instr = m2decl_BuildStringConstant ("nop", 3);
+ tree string
+ = resolve_asm_operand_names (instr, NULL_TREE, NULL_TREE, NULL_TREE);
+ tree note = build_stmt (pending_location, ASM_EXPR, string, NULL_TREE,
+ NULL_TREE, NULL_TREE, NULL_TREE);
+
+ ASM_INPUT_P (note) = FALSE;
+ ASM_VOLATILE_P (note) = FALSE;
+#else
+ tree note = build_empty_stmt (pending_location);
+#endif
+ pending_statement = FALSE;
+ do_add_stmt (note);
+ }
+}
+
+/* add_stmt t is a statement. Add it to the statement-tree. */
+
+tree
+m2block_add_stmt (location_t location, tree t)
+{
+ if ((CAN_HAVE_LOCATION_P (t)) && (!EXPR_HAS_LOCATION (t)))
+ SET_EXPR_LOCATION (t, location);
+
+ if (pending_statement && (pending_location != location))
+ flush_pending_note ();
+
+ pending_statement = FALSE;
+ return do_add_stmt (t);
+}
+
+/* addStmtNote remember this location represents the start of a
+ Modula-2 statement. It is flushed if another different location
+ is generated or another tree is given to add_stmt. */
+
+void
+m2block_addStmtNote (location_t location)
+{
+ if (pending_statement && (pending_location != location))
+ flush_pending_note ();
+
+ pending_statement = TRUE;
+ pending_location = location;
+}
+
+void
+m2block_removeStmtNote (void)
+{
+ pending_statement = FALSE;
+}
+
+/* init - initialize the data structures in this module. */
+
+void
+m2block_init (void)
+{
+ global_binding_level = newLevel ();
+ global_binding_level->context = build_translation_unit_decl (NULL);
+ global_binding_level->is_global = TRUE;
+ current_binding_level = NULL;
+}
+
+#include "gt-m2-m2block.h"
diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2builtins.cc
--- /dev/null 2022-08-24 16:22:16.888000070 +0100
+++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2builtins.cc 2022-10-07 20:21:18.650096940 +0100
@@ -0,0 +1,1330 @@
+/* m2builtins.cc provides an interface to the GCC builtins.
+
+Copyright (C) 2012-2022 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <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 "m2block.h"
+#include "m2convert.h"
+#include "m2decl.h"
+#include "m2expr.h"
+#include "m2statement.h"
+#include "m2tree.h"
+#include "m2treelib.h"
+#include "m2type.h"
+
+#define GM2
+#define GM2_BUG_REPORT \
+ "Please report this crash to the GNU Modula-2 mailing list " \
+ "<gm2@nongnu.org>\n"
+
+#define ASSERT(X, Y) \
+ { \
+ if (!(X)) \
+ { \
+ debug_tree (Y); \
+ internal_error ("%s:%d:assertion of condition `%s' failed", __FILE__, __LINE__, \
+ #X); \
+ } \
+ }
+#define ERROR(X) \
+ { \
+ internal_error ("%s:%d:%s", __FILE__, __LINE__, X); \
+ }
+
+typedef enum {
+ BT_FN_NONE,
+ BT_FN_PTR_SIZE,
+ BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE,
+ BT_FN_FLOAT,
+ BT_FN_DOUBLE,
+ BT_FN_LONG_DOUBLE,
+ BT_FN_FLOAT_FLOAT,
+ BT_FN_DOUBLE_DOUBLE,
+ BT_FN_LONG_DOUBLE_LONG_DOUBLE,
+ BT_FN_STRING_CONST_STRING_INT,
+ BT_FN_INT_CONST_PTR_CONST_PTR_SIZE,
+ BT_FN_TRAD_PTR_PTR_INT_SIZE,
+ BT_FN_STRING_STRING_CONST_STRING,
+ BT_FN_STRING_STRING_CONST_STRING_SIZE,
+ BT_FN_INT_CONST_STRING_CONST_STRING,
+ BT_FN_INT_CONST_STRING_CONST_STRING_SIZE,
+ BT_FN_INT_CONST_STRING,
+ BT_FN_STRING_CONST_STRING_CONST_STRING,
+ BT_FN_SIZE_CONST_STRING_CONST_STRING,
+ BT_FN_PTR_UNSIGNED,
+ BT_FN_VOID_PTR_INT,
+ BT_FN_INT_PTR,
+ BT_FN_INT_FLOAT,
+ BT_FN_INT_DOUBLE,
+ BT_FN_INT_LONG_DOUBLE,
+ BT_FN_FLOAT_FCOMPLEX,
+ BT_FN_DOUBLE_DCOMPLEX,
+ BT_FN_LONG_DOUBLE_LDCOMPLEX,
+
+ BT_FN_FCOMPLEX_FCOMPLEX,
+ BT_FN_DCOMPLEX_DCOMPLEX,
+ BT_FN_LDCOMPLEX_LDCOMPLEX,
+
+ BT_FN_DCOMPLEX_DOUBLE_DCOMPLEX,
+ BT_FN_FCOMPLEX_FLOAT_FCOMPLEX,
+ BT_FN_LDCOMPLEX_LONG_DOUBLE_LDCOMPLEX,
+
+ BT_FN_FLOAT_FLOAT_FLOATPTR,
+ BT_FN_DOUBLE_DOUBLE_DOUBLEPTR,
+ BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLEPTR,
+
+ BT_FN_FLOAT_FLOAT_LONG_DOUBLE,
+ BT_FN_DOUBLE_DOUBLE_LONG_DOUBLE,
+ BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
+
+ BT_FN_FLOAT_FLOAT_LONG,
+ BT_FN_DOUBLE_DOUBLE_LONG,
+ BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG,
+
+ BT_FN_FLOAT_FLOAT_INT,
+ BT_FN_DOUBLE_DOUBLE_INT,
+ BT_FN_LONG_DOUBLE_LONG_DOUBLE_INT,
+
+ BT_FN_FLOAT_FLOAT_FLOAT,
+ BT_FN_DOUBLE_DOUBLE_DOUBLE,
+} builtin_prototype;
+
+struct builtin_function_entry
+{
+ const char *name;
+ builtin_prototype defn;
+ int function_code;
+ enum built_in_class fclass;
+ const char *library_name;
+ tree function_node;
+ tree return_node;
+};
+
+/* Entries are added by examining gcc/builtins.def and copying those
+ functions which can be applied to Modula-2. */
+
+static struct builtin_function_entry list_of_builtins[] = {
+ { "__builtin_alloca", BT_FN_PTR_SIZE, BUILT_IN_ALLOCA, BUILT_IN_NORMAL,
+ "alloca", NULL, NULL },
+ { "__builtin_memcpy", BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE, BUILT_IN_MEMCPY,
+ BUILT_IN_NORMAL, "memcpy", NULL, NULL },
+
+ { "__builtin_isfinite", BT_FN_INT_DOUBLE, BUILT_IN_ISFINITE, BUILT_IN_NORMAL,
+ "isfinite", NULL, NULL },
+
+ { "__builtin_sinf", BT_FN_FLOAT_FLOAT, BUILT_IN_SINF, BUILT_IN_NORMAL,
+ "sinf", NULL, NULL },
+ { "__builtin_sin", BT_FN_DOUBLE_DOUBLE, BUILT_IN_SIN, BUILT_IN_NORMAL, "sin",
+ NULL, NULL },
+ { "__builtin_sinl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_SINL,
+ BUILT_IN_NORMAL, "sinl", NULL, NULL },
+ { "__builtin_cosf", BT_FN_FLOAT_FLOAT, BUILT_IN_SINF, BUILT_IN_NORMAL,
+ "cosf", NULL, NULL },
+ { "__builtin_cos", BT_FN_DOUBLE_DOUBLE, BUILT_IN_COS, BUILT_IN_NORMAL, "cos",
+ NULL, NULL },
+ { "__builtin_cosl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_COSL,
+ BUILT_IN_NORMAL, "cosl", NULL, NULL },
+ { "__builtin_sqrtf", BT_FN_FLOAT_FLOAT, BUILT_IN_SQRTF, BUILT_IN_NORMAL,
+ "sqrtf", NULL, NULL },
+ { "__builtin_sqrt", BT_FN_DOUBLE_DOUBLE, BUILT_IN_SQRT, BUILT_IN_NORMAL,
+ "sqrt", NULL, NULL },
+ { "__builtin_sqrtl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_SQRTL,
+ BUILT_IN_NORMAL, "sqrtl", NULL, NULL },
+ { "__builtin_fabsf", BT_FN_FLOAT_FLOAT, BUILT_IN_FABSF, BUILT_IN_NORMAL,
+ "fabsf", NULL, NULL },
+ { "__builtin_fabs", BT_FN_DOUBLE_DOUBLE, BUILT_IN_FABS, BUILT_IN_NORMAL,
+ "fabs", NULL, NULL },
+ { "__builtin_fabsl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_FABSL,
+ BUILT_IN_NORMAL, "fabsl", NULL, NULL },
+ { "__builtin_logf", BT_FN_FLOAT_FLOAT, BUILT_IN_LOGF, BUILT_IN_NORMAL,
+ "logf", NULL, NULL },
+ { "__builtin_log", BT_FN_DOUBLE_DOUBLE, BUILT_IN_LOG, BUILT_IN_NORMAL, "log",
+ NULL, NULL },
+ { "__builtin_logl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_LOGL,
+ BUILT_IN_NORMAL, "logl", NULL, NULL },
+ { "__builtin_expf", BT_FN_FLOAT_FLOAT, BUILT_IN_EXPF, BUILT_IN_NORMAL,
+ "expf", NULL, NULL },
+ { "__builtin_exp", BT_FN_DOUBLE_DOUBLE, BUILT_IN_EXP, BUILT_IN_NORMAL, "exp",
+ NULL, NULL },
+ { "__builtin_expl", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_EXPL,
+ BUILT_IN_NORMAL, "expl", NULL, NULL },
+ { "__builtin_log10f", BT_FN_FLOAT_FLOAT, BUILT_IN_LOG10F, BUILT_IN_NORMAL,
+ "log10f", NULL, NULL },
+ { "__builtin_log10", BT_FN_DOUBLE_DOUBLE, BUILT_IN_LOG10, BUILT_IN_NORMAL,
+ "log10", NULL, NULL },
+ { "__builtin_log10l", BT_FN_LONG_DOUBLE_LONG_DOUBLE, BUILT_IN_LOG10L,
+ BUILT_IN_NORMAL, "log10l", NULL, NULL },
+ { "__builtin_ilogbf", BT_FN_INT_FLOAT, BUILT_IN_ILOGBF, BUILT_IN_NORMAL,
+ "ilogbf", NULL, NULL },
+ { "__builtin_ilogb", BT_FN_INT_DOUBLE, BUILT_IN_ILOGB, BUILT_IN_NORMAL,
+ "ilogb", NULL, NULL },
+ { "__builtin_ilogbl", BT_FN_INT_LONG_DOUBLE, BUILT_IN_ILOGBL,
+ BUILT_IN_NORMAL, "ilogbl", NULL, NULL },
+
+ { "__builtin_atan2f", BT_FN_FLOAT_FLOAT_FLOAT, BUILT_IN_ATAN2F,
+ BUILT_IN_NORMAL, "atan2f", NULL, NULL },
+ { "__builtin_atan2", BT_FN_DOUBLE_DOUBLE_DOUBLE, BUILT_IN_ATAN2,
+ BUILT_IN_NORMAL, "atan2", NULL, NULL },
+ { "__builtin_atan2l", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
+ BUILT_IN_ATAN2L, BUILT_IN_NORMAL, "atan2l", NULL, NULL },
+
+ { "__builtin_signbit", BT_FN_INT_DOUBLE, BUILT_IN_SIGNBIT, BUILT_IN_NORMAL,
+ "signbit", NULL, NULL },
+ { "__builtin_signbitf", BT_FN_INT_FLOAT, BUILT_IN_SIGNBITF, BUILT_IN_NORMAL,
+ "signbitf", NULL, NULL },
+ { "__builtin_signbitl", BT_FN_INT_LONG_DOUBLE, BUILT_IN_SIGNBITL,
+ BUILT_IN_NORMAL, "signbitl", NULL, NULL },
+ { "__builtin_significand", BT_FN_DOUBLE_DOUBLE, BUILT_IN_SIGNIFICAND,
+ BUILT_IN_NORMAL, "significand", NULL, NULL },
+ { "__builtin_significandf", BT_FN_FLOAT_FLOAT, BUILT_IN_SIGNIFICANDF,
+ BUILT_IN_NORMAL, "significandf", NULL, NULL },
+ { "__builtin_significandl", BT_FN_LONG_DOUBLE_LONG_DOUBLE,
+ BUILT_IN_SIGNIFICANDL, BUILT_IN_NORMAL, "significandl", NULL, NULL },
+ { "__builtin_modf", BT_FN_DOUBLE_DOUBLE_DOUBLEPTR, BUILT_IN_MODF,
+ BUILT_IN_NORMAL, "modf", NULL, NULL },
+ { "__builtin_modff", BT_FN_FLOAT_FLOAT_FLOATPTR, BUILT_IN_MODFF,
+ BUILT_IN_NORMAL, "modff", NULL, NULL },
+ { "__builtin_modfl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLEPTR,
+ BUILT_IN_MODFL, BUILT_IN_NORMAL, "modfl", NULL, NULL },
+ { "__builtin_nextafter", BT_FN_DOUBLE_DOUBLE_DOUBLE, BUILT_IN_NEXTAFTER,
+ BUILT_IN_NORMAL, "nextafter", NULL, NULL },
+ { "__builtin_nextafterf", BT_FN_FLOAT_FLOAT_FLOAT, BUILT_IN_NEXTAFTERF,
+ BUILT_IN_NORMAL, "nextafterf", NULL, NULL },
+ { "__builtin_nextafterl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
+ BUILT_IN_NEXTAFTERL, BUILT_IN_NORMAL, "nextafterl", NULL, NULL },
+ { "__builtin_nexttoward", BT_FN_DOUBLE_DOUBLE_LONG_DOUBLE,
+ BUILT_IN_NEXTTOWARD, BUILT_IN_NORMAL, "nexttoward", NULL, NULL },
+ { "__builtin_nexttowardf", BT_FN_FLOAT_FLOAT_LONG_DOUBLE,
+ BUILT_IN_NEXTTOWARDF, BUILT_IN_NORMAL, "nexttowardf", NULL, NULL },
+ { "__builtin_nexttowardl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
+ BUILT_IN_NEXTTOWARDL, BUILT_IN_NORMAL, "nexttowardl", NULL, NULL },
+ { "__builtin_scalb", BT_FN_DOUBLE_DOUBLE_DOUBLE, BUILT_IN_SCALB,
+ BUILT_IN_NORMAL, "scalb", NULL, NULL },
+ { "__builtin_scalbf", BT_FN_FLOAT_FLOAT_FLOAT, BUILT_IN_SCALBF,
+ BUILT_IN_NORMAL, "scalbf", NULL, NULL },
+ { "__builtin_scalbl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE,
+ BUILT_IN_SCALBL, BUILT_IN_NORMAL, "scalbl", NULL, NULL },
+ { "__builtin_scalbln", BT_FN_DOUBLE_DOUBLE_LONG, BUILT_IN_SCALBLN,
+ BUILT_IN_NORMAL, "scalbln", NULL, NULL },
+ { "__builtin_scalblnf", BT_FN_FLOAT_FLOAT_LONG, BUILT_IN_SCALBLNF,
+ BUILT_IN_NORMAL, "scalblnf", NULL, NULL },
+ { "__builtin_scalblnl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG,
+ BUILT_IN_SCALBLNL, BUILT_IN_NORMAL, "scalblnl", NULL, NULL },
+ { "__builtin_scalbn", BT_FN_DOUBLE_DOUBLE_INT, BUILT_IN_SCALBN,
+ BUILT_IN_NORMAL, "scalbln", NULL, NULL },
+ { "__builtin_scalbnf", BT_FN_FLOAT_FLOAT_INT, BUILT_IN_SCALBNF,
+ BUILT_IN_NORMAL, "scalblnf", NULL, NULL },
+ { "__builtin_scalbnl", BT_FN_LONG_DOUBLE_LONG_DOUBLE_INT, BUILT_IN_SCALBNL,
+ BUILT_IN_NORMAL, "scalblnl", NULL, NULL },
+
+ /* Complex intrinsic functions. */
+ { "__builtin_cabs", BT_FN_DOUBLE_DCOMPLEX, BUILT_IN_CABS, BUILT_IN_NORMAL,
+ "cabs", NULL, NULL },
+ { "__builtin_cabsf", BT_FN_FLOAT_FCOMPLEX, BUILT_IN_CABSF, BUILT_IN_NORMAL,
+ "cabsf", NULL, NULL },
+ { "__builtin_cabsl", BT_FN_LONG_DOUBLE_LDCOMPLEX, BUILT_IN_CABSL,
+ BUILT_IN_NORMAL, "cabsl", NULL, NULL },
+
+ { "__builtin_carg", BT_FN_DOUBLE_DCOMPLEX, BUILT_IN_CABS, BUILT_IN_NORMAL,
+ "carg", NULL, NULL },
+ { "__builtin_cargf", BT_FN_FLOAT_FCOMPLEX, BUILT_IN_CABSF, BUILT_IN_NORMAL,
+ "cargf", NULL, NULL },
+ { "__builtin_cargl", BT_FN_LONG_DOUBLE_LDCOMPLEX, BUILT_IN_CABSL,
+ BUILT_IN_NORMAL, "cargl", NULL, NULL },
+
+ { "__builtin_conj", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CONJ, BUILT_IN_NORMAL,
+ "carg", NULL, NULL },
+ { "__builtin_conjf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CONJF,
+ BUILT_IN_NORMAL, "conjf", NULL, NULL },
+ { "__builtin_conjl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CONJL,
+ BUILT_IN_NORMAL, "conjl", NULL, NULL },
+
+ { "__builtin_cpow", BT_FN_DCOMPLEX_DOUBLE_DCOMPLEX, BUILT_IN_CPOW,
+ BUILT_IN_NORMAL, "cpow", NULL, NULL },
+ { "__builtin_cpowf", BT_FN_FCOMPLEX_FLOAT_FCOMPLEX, BUILT_IN_CPOWF,
+ BUILT_IN_NORMAL, "cpowf", NULL, NULL },
+ { "__builtin_cpowl", BT_FN_LDCOMPLEX_LONG_DOUBLE_LDCOMPLEX, BUILT_IN_CPOWL,
+ BUILT_IN_NORMAL, "cpowl", NULL, NULL },
+
+ { "__builtin_csqrt", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CSQRT,
+ BUILT_IN_NORMAL, "csqrt", NULL, NULL },
+ { "__builtin_csqrtf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CSQRTF,
+ BUILT_IN_NORMAL, "csqrtf", NULL, NULL },
+ { "__builtin_csqrtl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CSQRTL,
+ BUILT_IN_NORMAL, "csqrtl", NULL, NULL },
+
+ { "__builtin_cexp", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CEXP, BUILT_IN_NORMAL,
+ "cexp", NULL, NULL },
+ { "__builtin_cexpf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CEXPF,
+ BUILT_IN_NORMAL, "cexpf", NULL, NULL },
+ { "__builtin_cexpl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CEXPL,
+ BUILT_IN_NORMAL, "cexpl", NULL, NULL },
+
+ { "__builtin_cln", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CLOG, BUILT_IN_NORMAL,
+ "cln", NULL, NULL },
+ { "__builtin_clnf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CLOGF, BUILT_IN_NORMAL,
+ "clnf", NULL, NULL },
+ { "__builtin_clnl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CLOGL,
+ BUILT_IN_NORMAL, "clnl", NULL, NULL },
+
+ { "__builtin_csin", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CSIN, BUILT_IN_NORMAL,
+ "csin", NULL, NULL },
+ { "__builtin_csinf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CSINF,
+ BUILT_IN_NORMAL, "csinf", NULL, NULL },
+ { "__builtin_csinl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CSINL,
+ BUILT_IN_NORMAL, "csinl", NULL, NULL },
+
+ { "__builtin_ccos", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CCOS, BUILT_IN_NORMAL,
+ "ccos", NULL, NULL },
+ { "__builtin_ccosf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CCOSF,
+ BUILT_IN_NORMAL, "ccosf", NULL, NULL },
+ { "__builtin_ccosl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CCOSL,
+ BUILT_IN_NORMAL, "ccosl", NULL, NULL },
+
+ { "__builtin_ctan", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CTAN, BUILT_IN_NORMAL,
+ "ctan", NULL, NULL },
+ { "__builtin_ctanf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CTANF,
+ BUILT_IN_NORMAL, "ctanf", NULL, NULL },
+ { "__builtin_ctanl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CTANL,
+ BUILT_IN_NORMAL, "ctanl", NULL, NULL },
+
+ { "__builtin_casin", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CASIN,
+ BUILT_IN_NORMAL, "casin", NULL, NULL },
+ { "__builtin_casinf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CASINF,
+ BUILT_IN_NORMAL, "casinf", NULL, NULL },
+ { "__builtin_casinl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CASINL,
+ BUILT_IN_NORMAL, "casinl", NULL, NULL },
+
+ { "__builtin_cacos", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CACOS,
+ BUILT_IN_NORMAL, "cacos", NULL, NULL },
+ { "__builtin_cacosf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CACOSF,
+ BUILT_IN_NORMAL, "cacosf", NULL, NULL },
+ { "__builtin_cacosl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CACOSL,
+ BUILT_IN_NORMAL, "cacosl", NULL, NULL },
+
+ { "__builtin_catan", BT_FN_DCOMPLEX_DCOMPLEX, BUILT_IN_CATAN,
+ BUILT_IN_NORMAL, "catan", NULL, NULL },
+ { "__builtin_catanf", BT_FN_FCOMPLEX_FCOMPLEX, BUILT_IN_CATANF,
+ BUILT_IN_NORMAL, "catanf", NULL, NULL },
+ { "__builtin_catanl", BT_FN_LDCOMPLEX_LDCOMPLEX, BUILT_IN_CATANL,
+ BUILT_IN_NORMAL, "catanl", NULL, NULL },
+
+ { "__builtin_huge_val", BT_FN_DOUBLE, BUILT_IN_HUGE_VAL, BUILT_IN_NORMAL,
+ "huge_val", NULL, NULL },
+ { "__builtin_huge_valf", BT_FN_FLOAT, BUILT_IN_HUGE_VALF, BUILT_IN_NORMAL,
+ "huge_valf", NULL, NULL },
+ { "__builtin_huge_vall", BT_FN_LONG_DOUBLE, BUILT_IN_HUGE_VALL,
+ BUILT_IN_NORMAL, "huge_vall", NULL, NULL },
+
+ { "__builtin_index", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_INDEX,
+ BUILT_IN_NORMAL, "index", NULL, NULL },
+ { "__builtin_rindex", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_RINDEX,
+ BUILT_IN_NORMAL, "rindex", NULL, NULL },
+ { "__builtin_memcmp", BT_FN_INT_CONST_PTR_CONST_PTR_SIZE, BUILT_IN_MEMCMP,
+ BUILT_IN_NORMAL, "memcmp", NULL, NULL },
+ { "__builtin_memmove", BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE, BUILT_IN_MEMMOVE,
+ BUILT_IN_NORMAL, "memmove", NULL, NULL },
+ { "__builtin_memset", BT_FN_TRAD_PTR_PTR_INT_SIZE, BUILT_IN_MEMSET,
+ BUILT_IN_NORMAL, "memset", NULL, NULL },
+ { "__builtin_strcat", BT_FN_STRING_STRING_CONST_STRING, BUILT_IN_STRCAT,
+ BUILT_IN_NORMAL, "strcat", NULL, NULL },
+ { "__builtin_strncat", BT_FN_STRING_STRING_CONST_STRING_SIZE,
+ BUILT_IN_STRNCAT, BUILT_IN_NORMAL, "strncat", NULL, NULL },
+ { "__builtin_strcpy", BT_FN_STRING_STRING_CONST_STRING, BUILT_IN_STRCPY,
+ BUILT_IN_NORMAL, "strcpy", NULL, NULL },
+ { "__builtin_strncpy", BT_FN_STRING_STRING_CONST_STRING_SIZE,
+ BUILT_IN_STRNCPY, BUILT_IN_NORMAL, "strncpy", NULL, NULL },
+ { "__builtin_strcmp", BT_FN_INT_CONST_STRING_CONST_STRING, BUILT_IN_STRCMP,
+ BUILT_IN_NORMAL, "strcmp", NULL, NULL },
+ { "__builtin_strncmp", BT_FN_INT_CONST_STRING_CONST_STRING_SIZE,
+ BUILT_IN_STRNCMP, BUILT_IN_NORMAL, "strncmp", NULL, NULL },
+ { "__builtin_strlen", BT_FN_INT_CONST_STRING, BUILT_IN_STRLEN,
+ BUILT_IN_NORMAL, "strlen", NULL, NULL },
+ { "__builtin_strstr", BT_FN_STRING_CONST_STRING_CONST_STRING,
+ BUILT_IN_STRSTR, BUILT_IN_NORMAL, "strstr", NULL, NULL },
+ { "__builtin_strpbrk", BT_FN_STRING_CONST_STRING_CONST_STRING,
+ BUILT_IN_STRPBRK, BUILT_IN_NORMAL, "strpbrk", NULL, NULL },
+ { "__builtin_strspn", BT_FN_SIZE_CONST_STRING_CONST_STRING, BUILT_IN_STRSPN,
+ BUILT_IN_NORMAL, "strspn", NULL, NULL },
+ { "__builtin_strcspn", BT_FN_SIZE_CONST_STRING_CONST_STRING,
+ BUILT_IN_STRCSPN, BUILT_IN_NORMAL, "strcspn", NULL, NULL },
+ { "__builtin_strchr", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_STRCHR,
+ BUILT_IN_NORMAL, "strchr", NULL, NULL },
+ { "__builtin_strrchr", BT_FN_STRING_CONST_STRING_INT, BUILT_IN_STRCHR,
+ BUILT_IN_NORMAL, "strrchr", NULL, NULL },
+ //{ "__builtin_constant_p", BT_FN_INT_VAR, BUILT_IN_CONSTANT_P,
+ //BUILT_IN_NORMAL, "constant_p", NULL, NULL},
+ { "__builtin_frame_address", BT_FN_PTR_UNSIGNED, BUILT_IN_FRAME_ADDRESS,
+ BUILT_IN_NORMAL, "frame_address", NULL, NULL },
+ { "__builtin_return_address", BT_FN_PTR_UNSIGNED, BUILT_IN_RETURN_ADDRESS,
+ BUILT_IN_NORMAL, "return_address", NULL, NULL },
+ //{ "__builtin_aggregate_incoming_address", BT_FN_PTR_VAR,
+ //BUILT_IN_AGGREGATE_INCOMING_ADDRESS, BUILT_IN_NORMAL,
+ //"aggregate_incoming_address", NULL, NULL},
+ { "__builtin_longjmp", BT_FN_VOID_PTR_INT, BUILT_IN_LONGJMP, BUILT_IN_NORMAL,
+ "longjmp", NULL, NULL },
+ { "__builtin_setjmp", BT_FN_INT_PTR, BUILT_IN_SETJMP, BUILT_IN_NORMAL,
+ "setjmp", NULL, NULL },
+ { NULL, BT_FN_NONE, 0, NOT_BUILT_IN, "", NULL, NULL }
+};
+
+struct builtin_type_info
+{
+ const char *name;
+ unsigned int returnType;
+ tree (*functionHandler) (location_t, tree);
+};
+
+static GTY (()) tree sizetype_endlink;
+static GTY (()) tree unsigned_endlink;
+static GTY (()) tree endlink;
+static GTY (()) tree math_endlink;
+static GTY (()) tree int_endlink;
+static GTY (()) tree ptr_endlink;
+static GTY (()) tree const_ptr_endlink;
+static GTY (()) tree double_ftype_void;
+static GTY (()) tree float_ftype_void;
+static GTY (()) tree ldouble_ftype_void;
+static GTY (()) tree float_ftype_float;
+static GTY (()) tree double_ftype_double;
+static GTY (()) tree ldouble_ftype_ldouble;
+static GTY (()) tree gm2_alloca_node;
+static GTY (()) tree gm2_memcpy_node;
+static GTY (()) tree gm2_isfinite_node;
+static GTY (()) tree gm2_huge_valf_node;
+static GTY (()) tree gm2_huge_val_node;
+static GTY (()) tree gm2_huge_vall_node;
+static GTY (()) tree long_doubleptr_type_node;
+static GTY (()) tree doubleptr_type_node;
+static GTY (()) tree floatptr_type_node;
+static GTY (()) tree builtin_ftype_int_var;
+
+/* Prototypes for locally defined functions. */
+static tree DoBuiltinAlloca (location_t location, tree n);
+static tree DoBuiltinMemCopy (location_t location, tree dest, tree src,
+ tree n);
+static tree DoBuiltinIsfinite (location_t location, tree value);
+static void create_function_prototype (location_t location,
+ struct builtin_function_entry *fe);
+static tree doradix (location_t location, tree type);
+static tree doplaces (location_t location, tree type);
+static tree doexponentmin (location_t location, tree type);
+static tree doexponentmax (location_t location, tree type);
+static tree dolarge (location_t location, tree type);
+static tree dosmall (location_t location, tree type);
+static tree doiec559 (location_t location, tree type);
+static tree dolia1 (location_t location, tree type);
+static tree doiso (location_t location, tree type);
+static tree doieee (location_t location, tree type);
+static tree dorounds (location_t location, tree type);
+static tree dogUnderflow (location_t location, tree type);
+static tree doexception (location_t location, tree type);
+static tree doextend (location_t location, tree type);
+static tree donModes (location_t location, tree type);
+/* Prototypes finish here. */
+
+#define m2builtins_c
+#include "m2builtins.h"
+
+static struct builtin_type_info m2_type_info[] = {
+ { "radix", 2, doradix },
+ { "places", 2, doplaces },
+ { "expoMin", 2, doexponentmin },
+ { "expoMax", 2, doexponentmax },
+ { "large", 3, dolarge },
+ { "small", 3, dosmall },
+ { "IEC559", 1, doiec559 },
+ { "LIA1", 1, dolia1 },
+ { "ISO", 1, doiso },
+ { "IEEE", 1, doieee },
+ { "rounds", 1, dorounds },
+ { "gUnderflow", 1, dogUnderflow },
+ { "exception", 1, doexception },
+ { "extend", 1, doextend },
+ { "nModes", 2, donModes },
+ { NULL, 0, NULL },
+};
+
+/* Return a definition for a builtin function named NAME and whose
+data type is TYPE. TYPE should be a function type with argument
+types. FUNCTION_CODE tells later passes how to compile calls to this
+function. See tree.h for its possible values.
+
+If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, the
+name to be called if we can't opencode the function. */
+
+tree
+builtin_function (location_t location, const char *name, tree type,
+ int function_code, enum built_in_class fclass,
+ const char *library_name, tree attrs)
+{
+ tree decl = add_builtin_function (name, type, function_code, fclass,
+ library_name, attrs);
+ DECL_SOURCE_LOCATION (decl) = location;
+
+ m2block_pushDecl (decl);
+ return decl;
+}
+
+/* GetBuiltinConst - returns the gcc tree of a builtin constant,
+ name. NIL is returned if the constant is unknown. */
+
+tree
+m2builtins_GetBuiltinConst (char *name)
+{
+ if (strcmp (name, "BITS_PER_UNIT") == 0)
+ return m2decl_BuildIntegerConstant (BITS_PER_UNIT);
+ if (strcmp (name, "BITS_PER_WORD") == 0)
+ return m2decl_BuildIntegerConstant (BITS_PER_WORD);
+ if (strcmp (name, "BITS_PER_CHAR") == 0)
+ return m2decl_BuildIntegerConstant (CHAR_TYPE_SIZE);
+ if (strcmp (name, "UNITS_PER_WORD") == 0)
+ return m2decl_BuildIntegerConstant (UNITS_PER_WORD);
+
+ return NULL_TREE;
+}
+
+/* GetBuiltinConstType - returns the type of a builtin constant,
+ name. 0 = unknown constant name 1 = integer 2 = real. */
+
+unsigned int
+m2builtins_GetBuiltinConstType (char *name)
+{
+ if (strcmp (name, "BITS_PER_UNIT") == 0)
+ return 1;
+ if (strcmp (name, "BITS_PER_WORD") == 0)
+ return 1;
+ if (strcmp (name, "BITS_PER_CHAR") == 0)
+ return 1;
+ if (strcmp (name, "UNITS_PER_WORD") == 0)
+ return 1;
+
+ return 0;
+}
+
+/* GetBuiltinTypeInfoType - returns value: 0 is ident is unknown. 1
+ if ident is IEC559, LIA1, ISO, IEEE, rounds, underflow, exception,
+ extend. 2 if ident is radix, places, exponentmin, exponentmax,
+ noofmodes. 3 if ident is large, small. */
+
+unsigned int
+m2builtins_GetBuiltinTypeInfoType (const char *ident)
+{
+ int i = 0;
+
+ while (m2_type_info[i].name != NULL)
+ if (strcmp (m2_type_info[i].name, ident) == 0)
+ return m2_type_info[i].returnType;
+ else
+ i++;
+ return 0;
+}
+
+/* GetBuiltinTypeInfo - returns value: NULL_TREE if ident is unknown.
+ boolean Tree if ident is IEC559, LIA1, ISO, IEEE, rounds,
+ underflow, exception, extend. ZType Tree if ident is radix,
+ places, exponentmin, exponentmax, noofmodes.
+ RType Tree if ident is large, small. */
+
+tree
+m2builtins_GetBuiltinTypeInfo (location_t location, tree type,
+ const char *ident)
+{
+ int i = 0;
+
+ type = m2tree_skip_type_decl (type);
+ while (m2_type_info[i].name != NULL)
+ if (strcmp (m2_type_info[i].name, ident) == 0)
+ return (*m2_type_info[i].functionHandler) (location, type);
+ else
+ i++;
+ return NULL_TREE;
+}
+
+/* doradix - returns the radix of the floating point, type. */
+
+static tree
+doradix (location_t location ATTRIBUTE_UNUSED, tree type)
+{
+ if (TREE_CODE (type) == REAL_TYPE)
+ {
+ enum machine_mode mode = TYPE_MODE (type);
+ int radix = REAL_MODE_FORMAT (mode)->b;
+ return m2decl_BuildIntegerConstant (radix);
+ }
+ else
+ return NULL_TREE;
+}
+
+/* doplaces - returns the whole number value of the number of radix
+ places used to store values of the corresponding real number type. */
+
+static tree
+doplaces (location_t location ATTRIBUTE_UNUSED, tree type)
+{
+ if (TREE_CODE (type) == REAL_TYPE)
+ {
+ /* Taken from c-family/c-cppbuiltin.cc. */
+ /* The number of decimal digits, q, such that any floating-point
+ number with q decimal digits can be rounded into a
+ floating-point number with p radix b digits and back again
+ without change to the q decimal digits, p log10 b if b is a
+ power of 10 floor((p - 1) log10 b) otherwise. */
+ enum machine_mode mode = TYPE_MODE (type);
+ const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+ const double log10_2 = .30102999566398119521;
+ double log10_b = log10_2;
+ int digits = (fmt->p - 1) * log10_b;
+ return m2decl_BuildIntegerConstant (digits);
+ }
+ else
+ return NULL_TREE;
+}
+
+/* doexponentmin - returns the whole number of the exponent minimum. */
+
+static tree
+doexponentmin (location_t location ATTRIBUTE_UNUSED, tree type)
+{
+ if (TREE_CODE (type) == REAL_TYPE)
+ {
+ enum machine_mode mode = TYPE_MODE (type);
+ int emin = REAL_MODE_FORMAT (mode)->emin;
+ return m2decl_BuildIntegerConstant (emin);
+ }
+ else
+ return NULL_TREE;
+}
+
+/* doexponentmax - returns the whole number of the exponent maximum. */
+
+static tree
+doexponentmax (location_t location ATTRIBUTE_UNUSED, tree type)
+{
+ if (TREE_CODE (type) == REAL_TYPE)
+ {
+ enum machine_mode mode = TYPE_MODE (type);
+ int emax = REAL_MODE_FORMAT (mode)->emax;
+ return m2decl_BuildIntegerConstant (emax);
+ }
+ else
+ return NULL_TREE;
+}
+
+static tree
+computeLarge (tree type)
+{
+ enum machine_mode mode = TYPE_MODE (type);
+ const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+ REAL_VALUE_TYPE real;
+ char buf[128];
+
+ /* Shamelessly taken from c-cppbuiltin.cc:builtin_define_float_constants. */
+
+ /* Since, for the supported formats, B is always a power of 2, we
+ construct the following numbers directly as a hexadecimal constants. */
+
+ get_max_float (fmt, buf, sizeof (buf), false);
+ real_from_string (&real, buf);
+ return build_real (type, real);
+}
+
+/* dolarge - return the largest value of the corresponding real type. */
+
+static tree
+dolarge (location_t location ATTRIBUTE_UNUSED, tree type)
+{
+ if (TREE_CODE (type) == REAL_TYPE)
+ return computeLarge (type);
+ return NULL_TREE;
+}
+
+static tree
+computeSmall (tree type)
+{
+ enum machine_mode mode = TYPE_MODE (type);
+ const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+ REAL_VALUE_TYPE real;
+ char buf[128];
+
+ /* The minimum normalized positive floating-point number,
+ b**(emin-1). */
+
+ sprintf (buf, "0x1p%d", fmt->emin - 1);
+ real_from_string (&real, buf);
+ return build_real (type, real);
+}
+
+/* dosmall - return the smallest positive value of the corresponding
+ real type. */
+
+static tree
+dosmall (location_t location ATTRIBUTE_UNUSED, tree type)
+{
+ if (TREE_CODE (type) == REAL_TYPE)
+ return computeSmall (type);
+ return NULL_TREE;
+}
+
+/* doiec559 - a boolean value that is true if and only if the
+ implementation of the corresponding real number type conforms to
+ IEC 559:1989 (also known as IEEE 754:1987) in all regards. */
+
+static tree
+doiec559 (location_t location, tree type)
+{
+ if (m2expr_IsTrue (m2expr_BuildEqualTo (location,
+ m2decl_BuildIntegerConstant (32),
+ m2expr_GetSizeOfInBits (type))))
+ return m2type_GetBooleanTrue ();
+ if (m2expr_IsTrue (m2expr_BuildEqualTo (location,
+ m2decl_BuildIntegerConstant (64),
+ m2expr_GetSizeOfInBits (type))))
+ return m2type_GetBooleanTrue ();
+ return m2type_GetBooleanFalse ();
+}
+
+/* dolia1 - returns TRUE if using ieee (currently always TRUE). */
+
+static tree
+dolia1 (location_t location, tree type)
+{
+ return doieee (location, type);
+}
+
+/* doiso - returns TRUE if using ieee (--fixme--). */
+
+static tree
+doiso (location_t location, tree type)
+{
+ return doieee (location, type);
+}
+
+/* doieee - returns TRUE if ieee arithmetic is being used. */
+
+static tree
+doieee (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
+{
+ /* --fixme-- maybe we should look for the -mno-ieee flag and return this
+ result. */
+ return m2type_GetBooleanTrue ();
+}
+
+/* dorounds - returns TRUE if and only if each operation produces a
+ result that is one of the values of the corresponding real number
+ type nearest to the mathematical result. */
+
+static tree
+dorounds (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
+{
+ if (FLT_ROUNDS)
+ return m2type_GetBooleanTrue ();
+ else
+ return m2type_GetBooleanFalse ();
+}
+
+/* dogUnderflow - returns TRUE if and only if there are values of the
+ corresponding real number type between 0.0 and small. */
+
+static tree
+dogUnderflow (location_t location ATTRIBUTE_UNUSED, tree type)
+{
+ if (TREE_CODE (type) == REAL_TYPE)
+ {
+ enum machine_mode mode = TYPE_MODE (type);
+ const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+ if (fmt->has_denorm)
+ return m2type_GetBooleanTrue ();
+ else
+ return m2type_GetBooleanFalse ();
+ }
+ return NULL_TREE;
+}
+
+/* doexception - */
+
+static tree
+doexception (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
+{
+ return m2type_GetBooleanTrue ();
+}
+
+/* doextend - */
+
+static tree
+doextend (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
+{
+ return m2type_GetBooleanTrue ();
+}
+
+/* donModes - */
+
+static tree
+donModes (location_t location ATTRIBUTE_UNUSED, tree type ATTRIBUTE_UNUSED)
+{
+ return m2decl_BuildIntegerConstant (1);
+}
+
+/* BuiltInMemCopy - copy n bytes of memory efficiently from address
+ src to dest. */
+
+tree
+m2builtins_BuiltInMemCopy (location_t location, tree dest, tree src, tree n)
+{
+ return DoBuiltinMemCopy (location, dest, src, n);
+}
+
+/* BuiltInAlloca - given an expression, n, allocate, n, bytes on the
+ stack for the life of the current function. */
+
+tree
+m2builtins_BuiltInAlloca (location_t location, tree n)
+{
+ return DoBuiltinAlloca (location, n);
+}
+
+/* BuiltInIsfinite - return integer 1 if the real expression is
+ finite otherwise return integer 0. */
+
+tree
+m2builtins_BuiltInIsfinite (location_t location, tree expression)
+{
+ return DoBuiltinIsfinite (location, expression);
+}
+
+/* BuiltinExists - returns TRUE if the builtin function, name, exists
+ for this target architecture. */
+
+int
+m2builtins_BuiltinExists (char *name)
+{
+ struct builtin_function_entry *fe;
+
+ for (fe = &list_of_builtins[0]; fe->name != NULL; fe++)
+ if (strcmp (name, fe->name) == 0)
+ return TRUE;
+
+ return FALSE;
+}
+
+/* BuildBuiltinTree - returns a Tree containing the builtin function,
+ name. */
+
+tree
+m2builtins_BuildBuiltinTree (location_t location, char *name)
+{
+ struct builtin_function_entry *fe;
+ tree t;
+
+ m2statement_SetLastFunction (NULL_TREE);
+ for (fe = &list_of_builtins[0]; fe->name != NULL; fe++)
+ if (strcmp (name, fe->name) == 0)
+ {
+ tree functype = TREE_TYPE (fe->function_node);
+ tree funcptr = build1 (ADDR_EXPR, build_pointer_type (functype),
+ fe->function_node);
+
+ m2statement_SetLastFunction (m2treelib_DoCall (
+ location, fe->return_node, funcptr, m2statement_GetParamList ()));
+ m2statement_SetParamList (NULL_TREE);
+ t = m2statement_GetLastFunction ();
+ if (fe->return_node == void_type_node)
+ m2statement_SetLastFunction (NULL_TREE);
+ return t;
+ }
+
+ m2statement_SetParamList (NULL_TREE);
+ return m2statement_GetLastFunction ();
+}
+
+static tree
+DoBuiltinMemCopy (location_t location, tree dest, tree src, tree bytes)
+{
+ tree functype = TREE_TYPE (gm2_memcpy_node);
+ tree funcptr
+ = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_memcpy_node);
+ tree call
+ = m2treelib_DoCall3 (location, ptr_type_node, funcptr, dest, src, bytes);
+ return call;
+}
+
+static tree
+DoBuiltinAlloca (location_t location, tree bytes)
+{
+ tree functype = TREE_TYPE (gm2_alloca_node);
+ tree funcptr
+ = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_alloca_node);
+ tree call = m2treelib_DoCall1 (location, ptr_type_node, funcptr, bytes);
+
+ return call;
+}
+
+static tree
+DoBuiltinIsfinite (location_t location, tree value)
+{
+ tree functype = TREE_TYPE (gm2_isfinite_node);
+ tree funcptr
+ = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_isfinite_node);
+ tree call = m2treelib_DoCall1 (location, ptr_type_node, funcptr, value);
+
+ return call;
+}
+
+tree
+m2builtins_BuiltInHugeVal (location_t location)
+{
+ tree functype = TREE_TYPE (gm2_huge_val_node);
+ tree funcptr
+ = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_huge_val_node);
+ tree call = m2treelib_DoCall0 (location, ptr_type_node, funcptr);
+ return call;
+}
+
+tree
+m2builtins_BuiltInHugeValShort (location_t location)
+{
+ tree functype = TREE_TYPE (gm2_huge_valf_node);
+ tree funcptr
+ = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_huge_valf_node);
+ tree call = m2treelib_DoCall0 (location, ptr_type_node, funcptr);
+ return call;
+}
+
+tree
+m2builtins_BuiltInHugeValLong (location_t location)
+{
+ tree functype = TREE_TYPE (gm2_huge_vall_node);
+ tree funcptr
+ = build1 (ADDR_EXPR, build_pointer_type (functype), gm2_huge_vall_node);
+ tree call = m2treelib_DoCall0 (location, ptr_type_node, funcptr);
+ return call;
+}
+
+static void
+create_function_prototype (location_t location,
+ struct builtin_function_entry *fe)
+{
+ tree ftype;
+
+ switch (fe->defn)
+ {
+
+ case BT_FN_PTR_SIZE:
+ ftype = build_function_type (ptr_type_node, sizetype_endlink);
+ fe->return_node = ptr_type_node;
+ break;
+
+ case BT_FN_STRING_STRING_CONST_STRING_SIZE:
+ case BT_FN_TRAD_PTR_PTR_CONST_PTR_SIZE:
+ ftype = build_function_type (
+ ptr_type_node, tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node,
+ sizetype_endlink)));
+ fe->return_node = ptr_type_node;
+ break;
+ case BT_FN_FLOAT:
+ ftype = float_ftype_void;
+ fe->return_node = float_type_node;
+ break;
+ case BT_FN_DOUBLE:
+ ftype = double_ftype_void;
+ fe->return_node = double_type_node;
+ break;
+ case BT_FN_LONG_DOUBLE:
+ ftype = ldouble_ftype_void;
+ fe->return_node = long_double_type_node;
+ break;
+ case BT_FN_FLOAT_FLOAT:
+ ftype = float_ftype_float;
+ fe->return_node = float_type_node;
+ break;
+ case BT_FN_DOUBLE_DOUBLE:
+ ftype = double_ftype_double;
+ fe->return_node = double_type_node;
+ break;
+ case BT_FN_LONG_DOUBLE_LONG_DOUBLE:
+ ftype = ldouble_ftype_ldouble;
+ fe->return_node = long_double_type_node;
+ break;
+ case BT_FN_STRING_CONST_STRING_INT:
+ ftype = build_function_type (
+ ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, int_endlink));
+ fe->return_node = ptr_type_node;
+ break;
+ case BT_FN_INT_CONST_PTR_CONST_PTR_SIZE:
+ ftype = build_function_type (
+ integer_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node, int_endlink)));
+ fe->return_node = integer_type_node;
+ break;
+ case BT_FN_TRAD_PTR_PTR_INT_SIZE:
+ ftype = build_function_type (
+ ptr_type_node, tree_cons (NULL_TREE, ptr_type_node,
+ tree_cons (NULL_TREE, integer_type_node,
+ sizetype_endlink)));
+ fe->return_node = ptr_type_node;
+ break;
+ case BT_FN_STRING_STRING_CONST_STRING:
+ ftype = build_function_type (
+ ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, ptr_endlink));
+ fe->return_node = ptr_type_node;
+ break;
+ case BT_FN_INT_CONST_STRING_CONST_STRING:
+ ftype = build_function_type (
+ integer_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node, ptr_endlink));
+ fe->return_node = integer_type_node;
+ break;
+ case BT_FN_INT_CONST_STRING_CONST_STRING_SIZE:
+ ftype = build_function_type (
+ integer_type_node,
+ tree_cons (
+ NULL_TREE, const_ptr_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node, sizetype_endlink)));
+ fe->return_node = integer_type_node;
+ break;
+ case BT_FN_INT_CONST_STRING:
+ ftype = build_function_type (integer_type_node, ptr_endlink);
+ fe->return_node = integer_type_node;
+ break;
+ case BT_FN_STRING_CONST_STRING_CONST_STRING:
+ ftype = build_function_type (
+ ptr_type_node,
+ tree_cons (NULL_TREE, const_ptr_type_node, const_ptr_endlink));
+ fe->return_node = ptr_type_node;
+ break;
+ case BT_FN_SIZE_CONST_STRING_CONST_STRING:
+ ftype = build_function_type (
+ sizetype,
+ tree_cons (NULL_TREE, const_ptr_type_node, const_ptr_endlink));
+ fe->return_node = sizetype;
+ break;
+ case BT_FN_PTR_UNSIGNED:
+ ftype = build_function_type (ptr_type_node, unsigned_endlink);
+ fe->return_node = ptr_type_node;
+ break;
+ case BT_FN_VOID_PTR_INT:
+ ftype = build_function_type (
+ void_type_node, tree_cons (NULL_TREE, ptr_type_node, int_endlink));
+ fe->return_node = void_type_node;
+ break;
+ case BT_FN_INT_PTR:
+ ftype = build_function_type (integer_type_node, ptr_endlink);
+ fe->return_node = integer_type_node;
+ break;
+ case BT_FN_INT_FLOAT:
+ ftype = build_function_type (
+ integer_type_node, tree_cons (NULL_TREE, float_type_node, endlink));
+ fe->return_node = integer_type_node;
+ break;
+ case BT_FN_INT_DOUBLE:
+ ftype = build_function_type (
+ integer_type_node, tree_cons (NULL_TREE, double_type_node, endlink));
+ fe->return_node = integer_type_node;
+ break;
+ case BT_FN_INT_LONG_DOUBLE:
+ ftype = build_function_type (
+ integer_type_node,
+ tree_cons (NULL_TREE, long_double_type_node, endlink));
+ fe->return_node = integer_type_node;
+ break;
+ case BT_FN_FLOAT_FCOMPLEX:
+ ftype = build_function_type (
+ float_type_node,
+ tree_cons (NULL_TREE, complex_float_type_node, endlink));
+ fe->return_node = float_type_node;
+ break;
+ case BT_FN_DOUBLE_DCOMPLEX:
+ ftype = build_function_type (
+ double_type_node,
+ tree_cons (NULL_TREE, complex_double_type_node, endlink));
+ fe->return_node = double_type_node;
+ break;
+ case BT_FN_LONG_DOUBLE_LDCOMPLEX:
+ ftype = build_function_type (
+ long_double_type_node,
+ tree_cons (NULL_TREE, complex_long_double_type_node, endlink));
+ fe->return_node = long_double_type_node;
+ break;
+ case BT_FN_FCOMPLEX_FCOMPLEX:
+ ftype = build_function_type (
+ complex_float_type_node,
+ tree_cons (NULL_TREE, complex_float_type_node, endlink));
+ fe->return_node = complex_float_type_node;
+ break;
+ case BT_FN_DCOMPLEX_DCOMPLEX:
+ ftype = build_function_type (
+ complex_double_type_node,
+ tree_cons (NULL_TREE, complex_double_type_node, endlink));
+ fe->return_node = complex_double_type_node;
+ break;
+ case BT_FN_LDCOMPLEX_LDCOMPLEX:
+ ftype = build_function_type (
+ complex_long_double_type_node,
+ tree_cons (NULL_TREE, complex_long_double_type_node, endlink));
+ fe->return_node = complex_long_double_type_node;
+ break;
+ case BT_FN_DCOMPLEX_DOUBLE_DCOMPLEX:
+ ftype = build_function_type (
+ complex_double_type_node,
+ tree_cons (NULL_TREE, complex_double_type_node,
+ tree_cons (NULL_TREE, double_type_node, endlink)));
+ fe->return_node = complex_double_type_node;
+ break;
+ case BT_FN_FCOMPLEX_FLOAT_FCOMPLEX:
+ ftype = build_function_type (
+ complex_float_type_node,
+ tree_cons (NULL_TREE, complex_float_type_node,
+ tree_cons (NULL_TREE, float_type_node, endlink)));
+ fe->return_node = complex_float_type_node;
+ break;
+ case BT_FN_LDCOMPLEX_LONG_DOUBLE_LDCOMPLEX:
+ ftype = build_function_type (
+ complex_long_double_type_node,
+ tree_cons (NULL_TREE, complex_long_double_type_node,
+ tree_cons (NULL_TREE, long_double_type_node, endlink)));
+ fe->return_node = complex_long_double_type_node;
+ break;
+ case BT_FN_FLOAT_FLOAT_FLOATPTR:
+ ftype = build_function_type (
+ float_type_node,
+ tree_cons (NULL_TREE, float_type_node,
+ tree_cons (NULL_TREE, floatptr_type_node, endlink)));
+ fe->return_node = float_type_node;
+ break;
+ case BT_FN_DOUBLE_DOUBLE_DOUBLEPTR:
+ ftype = build_function_type (
+ double_type_node,
+ tree_cons (NULL_TREE, double_type_node,
+ tree_cons (NULL_TREE, doubleptr_type_node, endlink)));
+ fe->return_node = double_type_node;
+ break;
+ case BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLEPTR:
+ ftype = build_function_type (
+ long_double_type_node,
+ tree_cons (
+ NULL_TREE, long_double_type_node,
+ tree_cons (NULL_TREE, long_doubleptr_type_node, endlink)));
+ fe->return_node = long_double_type_node;
+ break;
+ case BT_FN_FLOAT_FLOAT_LONG_DOUBLE:
+ ftype = build_function_type (
+ float_type_node,
+ tree_cons (NULL_TREE, float_type_node,
+ tree_cons (NULL_TREE, long_double_type_node, endlink)));
+ fe->return_node = float_type_node;
+ break;
+ case BT_FN_DOUBLE_DOUBLE_LONG_DOUBLE:
+ ftype = build_function_type (
+ double_type_node,
+ tree_cons (NULL_TREE, double_type_node,
+ tree_cons (NULL_TREE, long_double_type_node, endlink)));
+ fe->return_node = double_type_node;
+ break;
+ case BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG_DOUBLE:
+ ftype = build_function_type (
+ long_double_type_node,
+ tree_cons (NULL_TREE, long_double_type_node,
+ tree_cons (NULL_TREE, long_double_type_node, endlink)));
+ fe->return_node = long_double_type_node;
+ break;
+ case BT_FN_FLOAT_FLOAT_LONG:
+ ftype = build_function_type (
+ float_type_node,
+ tree_cons (NULL_TREE, float_type_node,
+ tree_cons (NULL_TREE, long_integer_type_node, endlink)));
+ fe->return_node = float_type_node;
+ break;
+ case BT_FN_DOUBLE_DOUBLE_LONG:
+ ftype = build_function_type (
+ double_type_node,
+ tree_cons (NULL_TREE, double_type_node,
+ tree_cons (NULL_TREE, long_integer_type_node, endlink)));
+ fe->return_node = double_type_node;
+ break;
+ case BT_FN_LONG_DOUBLE_LONG_DOUBLE_LONG:
+ ftype = build_function_type (
+ long_double_type_node,
+ tree_cons (NULL_TREE, long_double_type_node,
+ tree_cons (NULL_TREE, long_integer_type_node, endlink)));
+ fe->return_node = long_double_type_node;
+ break;
+ case BT_FN_FLOAT_FLOAT_INT:
+ ftype = build_function_type (
+ float_type_node,
+ tree_cons (NULL_TREE, float_type_node,
+ tree_cons (NULL_TREE, integer_type_node, endlink)));
+ fe->return_node = float_type_node;
+ break;
+ case BT_FN_DOUBLE_DOUBLE_INT:
+ ftype = build_function_type (
+ double_type_node,
+ tree_cons (NULL_TREE, double_type_node,
+ tree_cons (NULL_TREE, integer_type_node, endlink)));
+ fe->return_node = double_type_node;
+ break;
+ case BT_FN_LONG_DOUBLE_LONG_DOUBLE_INT:
+ ftype = build_function_type (
+ long_double_type_node,
+ tree_cons (NULL_TREE, long_double_type_node,
+ tree_cons (NULL_TREE, integer_type_node, endlink)));
+ fe->return_node = long_double_type_node;
+ break;
+ case BT_FN_FLOAT_FLOAT_FLOAT:
+ ftype = build_function_type (
+ float_type_node,
+ tree_cons (NULL_TREE, float_type_node,
+ tree_cons (NULL_TREE, float_type_node, endlink)));
+ fe->return_node = float_type_node;
+ break;
+ case BT_FN_DOUBLE_DOUBLE_DOUBLE:
+ ftype = build_function_type (
+ double_type_node,
+ tree_cons (NULL_TREE, double_type_node,
+ tree_cons (NULL_TREE, double_type_node, endlink)));
+ fe->return_node = double_type_node;
+ break;
+ default:
+ ERROR ("enum has no case");
+ }
+ fe->function_node
+ = builtin_function (location, fe->name, ftype, fe->function_code,
+ fe->fclass, fe->library_name, NULL);
+}
+
+static tree
+find_builtin_tree (const char *name)
+{
+ struct builtin_function_entry *fe;
+
+ for (fe = &list_of_builtins[0]; fe->name != NULL; fe++)
+ if (strcmp (name, fe->name) == 0)
+ return fe->function_node;
+
+ ERROR ("cannot find builtin function");
+ return NULL_TREE;
+}
+
+
+static void
+set_decl_built_in_class (tree decl, built_in_class c)
+{
+ FUNCTION_DECL_CHECK (decl)->function_decl.built_in_class = c;
+}
+
+
+static void
+set_decl_function_code (tree decl, built_in_function f)
+{
+ tree_function_decl &fndecl = FUNCTION_DECL_CHECK (decl)->function_decl;
+ fndecl.function_code = f;
+}
+
+/* Define a single builtin. */
+static void
+define_builtin (enum built_in_function val, const char *name, tree type,
+ const char *libname, int flags)
+{
+ tree decl;
+
+ decl = build_decl (BUILTINS_LOCATION, FUNCTION_DECL, get_identifier (name),
+ type);
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ SET_DECL_ASSEMBLER_NAME (decl, get_identifier (libname));
+ m2block_pushDecl (decl);
+ set_decl_built_in_class (decl, BUILT_IN_NORMAL);
+ set_decl_function_code (decl, val);
+ set_call_expr_flags (decl, flags);
+
+ set_builtin_decl (val, decl, true);
+}
+
+void
+m2builtins_init (location_t location)
+{
+ int i;
+
+ m2block_pushGlobalScope ();
+ endlink = void_list_node;
+ sizetype_endlink = tree_cons (NULL_TREE, sizetype, endlink);
+ math_endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
+ int_endlink = tree_cons (NULL_TREE, integer_type_node, NULL_TREE);
+ ptr_endlink = tree_cons (NULL_TREE, ptr_type_node, NULL_TREE);
+ const_ptr_endlink = tree_cons (NULL_TREE, const_ptr_type_node, NULL_TREE);
+ unsigned_endlink = tree_cons (NULL_TREE, unsigned_type_node, NULL_TREE);
+
+ float_ftype_void = build_function_type (float_type_node, math_endlink);
+ double_ftype_void = build_function_type (double_type_node, math_endlink);
+ ldouble_ftype_void
+ = build_function_type (long_double_type_node, math_endlink);
+
+ long_doubleptr_type_node = build_pointer_type (long_double_type_node);
+ doubleptr_type_node = build_pointer_type (double_type_node);
+ floatptr_type_node = build_pointer_type (float_type_node);
+
+ float_ftype_float = build_function_type (
+ float_type_node, tree_cons (NULL_TREE, float_type_node, math_endlink));
+
+ double_ftype_double = build_function_type (
+ double_type_node, tree_cons (NULL_TREE, double_type_node, math_endlink));
+
+ ldouble_ftype_ldouble = build_function_type (
+ long_double_type_node,
+ tree_cons (NULL_TREE, long_double_type_node, endlink));
+
+ builtin_ftype_int_var = build_function_type (
+ integer_type_node, tree_cons (NULL_TREE, double_type_node, endlink));
+
+ for (i = 0; list_of_builtins[i].name != NULL; i++)
+ create_function_prototype (location, &list_of_builtins[i]);
+
+ define_builtin (BUILT_IN_TRAP, "__builtin_trap",
+ build_function_type_list (void_type_node, NULL_TREE),
+ "__builtin_trap", ECF_NOTHROW | ECF_LEAF | ECF_NORETURN);
+ define_builtin (BUILT_IN_ISGREATER, "isgreater", builtin_ftype_int_var,
+ "__builtin_isgreater", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+ define_builtin (BUILT_IN_ISGREATEREQUAL, "isgreaterequal",
+ builtin_ftype_int_var, "__builtin_isgreaterequal",
+ ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+ define_builtin (BUILT_IN_ISLESS, "isless", builtin_ftype_int_var,
+ "__builtin_isless", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+ define_builtin (BUILT_IN_ISLESSEQUAL, "islessequal", builtin_ftype_int_var,
+ "__builtin_islessequal", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+ define_builtin (BUILT_IN_ISLESSGREATER, "islessgreater",
+ builtin_ftype_int_var, "__builtin_islessgreater",
+ ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+ define_builtin (BUILT_IN_ISUNORDERED, "isunordered", builtin_ftype_int_var,
+ "__builtin_isunordered", ECF_CONST | ECF_NOTHROW | ECF_LEAF);
+
+ gm2_alloca_node = find_builtin_tree ("__builtin_alloca");
+ gm2_memcpy_node = find_builtin_tree ("__builtin_memcpy");
+ gm2_huge_valf_node = find_builtin_tree ("__builtin_huge_valf");
+ gm2_huge_val_node = find_builtin_tree ("__builtin_huge_val");
+ gm2_huge_vall_node = find_builtin_tree ("__builtin_huge_vall");
+ gm2_isfinite_node = find_builtin_tree ("__builtin_isfinite");
+ m2block_popGlobalScope ();
+}
+
+#include "gt-m2-m2builtins.h"
+
+/* END m2builtins. */
diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2color.cc
--- /dev/null 2022-08-24 16:22:16.888000070 +0100
+++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2color.cc 2022-10-07 20:21:18.650096940 +0100
@@ -0,0 +1,66 @@
+/* m2color.cc interface to gcc colorization.
+
+Copyright (C) 2019-2022 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <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/>. */
+
+#define m2color_c
+#include "m2color.h"
+
+#include "gcc-consolidation.h"
+#include "diagnostic-color.h"
+
+
+char *
+m2color_colorize_start (bool show_color, char *name, unsigned int name_len)
+{
+ return const_cast<char*> (colorize_start (show_color, name, name_len));
+}
+
+
+char *
+m2color_colorize_stop (bool show_color)
+{
+ return const_cast<char*> (colorize_stop (show_color));
+}
+
+
+char *
+m2color_open_quote (void)
+{
+ return const_cast<char*> (open_quote);
+}
+
+
+char *
+m2color_close_quote (void)
+{
+ return const_cast<char*> (close_quote);
+}
+
+
+void
+_M2_m2color_init ()
+{
+}
+
+
+void
+_M2_m2color_finish ()
+{
+}
diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2configure.cc
--- /dev/null 2022-08-24 16:22:16.888000070 +0100
+++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2configure.cc 2022-10-07 20:21:18.650096940 +0100
@@ -0,0 +1,101 @@
+/* m2configure.cc provides an interface to some configuration values.
+
+Copyright (C) 2022 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <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 "config.h"
+#include "system.h"
+#include "libiberty.h"
+
+#include "config.h"
+#include "system.h"
+#include "libiberty.h"
+
+#include "gcc-consolidation.h"
+
+#include "../gm2-lang.h"
+#include "../m2-tree.h"
+#include "m2convert.h"
+
+/* Prototypes. */
+
+#define m2configure_c
+
+#include "m2assert.h"
+#include "m2builtins.h"
+#include "m2convert.h"
+#include "m2decl.h"
+#include "m2expr.h"
+#include "m2options.h"
+#include "m2configure.h"
+
+#include "m2/gm2version.h"
+#include "m2/gm2config.h"
+
+#define CPPPROGRAM "cc1"
+
+
+/* gen_gm2_libexec returns a string containing libexec /
+ DEFAULT_TARGET_MACHINE string / DEFAULT_TARGET_MACHINE. */
+
+static char *
+gen_gm2_libexec (const char *libexec)
+{
+ int l = strlen (libexec) + 1 + strlen (DEFAULT_TARGET_MACHINE) + 1
+ + strlen (DEFAULT_TARGET_VERSION) + 1;
+ char *s = (char *)xmalloc (l);
+ char dir_sep[2];
+
+ dir_sep[0] = DIR_SEPARATOR;
+ dir_sep[1] = (char)0;
+
+ strcpy (s, libexec);
+ strcat (s, dir_sep);
+ strcat (s, DEFAULT_TARGET_MACHINE);
+ strcat (s, dir_sep);
+ strcat (s, DEFAULT_TARGET_VERSION);
+ return s;
+}
+
+/* FullPathCPP returns the fullpath and program name to cpp. */
+
+char *
+m2configure_FullPathCPP (void)
+{
+ if (M2Options_GetCpp ())
+ {
+ char *path = (char *) M2Options_GetB ();
+
+ if (path == NULL)
+ path = gen_gm2_libexec (STANDARD_LIBEXEC_PREFIX);
+
+ if (strcmp (path, "") == 0)
+ return xstrdup (CPPPROGRAM);
+
+ char *full = (char *)xmalloc (strlen (path) + 1 + strlen (CPPPROGRAM) + 1);
+ strcpy (full, path);
+ char *sep = (char *)alloca (2);
+ sep[0] = DIR_SEPARATOR;
+ sep[1] = (char)0;
+ strcat (full, sep);
+ strcat (full, CPPPROGRAM);
+ return full;
+ }
+ return NULL;
+}
diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2convert.cc
--- /dev/null 2022-08-24 16:22:16.888000070 +0100
+++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2convert.cc 2022-10-07 20:21:18.650096940 +0100
@@ -0,0 +1,659 @@
+/* m2convert.cc provides GCC tree conversion for the Modula-2 language.
+
+Copyright (C) 2012-2022 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <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 m2convert_c
+#include "m2assert.h"
+#include "m2block.h"
+#include "m2convert.h"
+#include "m2decl.h"
+#include "m2expr.h"
+#include "m2expr.h"
+#include "m2statement.h"
+#include "m2tree.h"
+#include "m2treelib.h"
+#include "m2type.h"
+
+static tree const_to_ISO_type (location_t location, tree expr, tree iso_type);
+static tree const_to_ISO_aggregate_type (location_t location, tree expr,
+ tree iso_type);
+
+/* These enumerators are possible types of unsafe conversions.
+ SAFE_CONVERSION The conversion is safe UNSAFE_OTHER Another type of
+ conversion with problems UNSAFE_SIGN Conversion between signed and
+ unsigned integers which are all warned about immediately, so this is
+ unused UNSAFE_REAL Conversions that reduce the precision of reals
+ including conversions from reals to integers. */
+enum conversion_safety
+{
+ SAFE_CONVERSION = 0,
+ UNSAFE_OTHER,
+ UNSAFE_SIGN,
+ UNSAFE_REAL
+};
+
+/* ConvertString - converts string, expr, into a string of type,
+ type. */
+
+tree
+m2convert_ConvertString (tree type, tree expr)
+{
+ const char *str = TREE_STRING_POINTER (expr);
+ int len = TREE_STRING_LENGTH (expr);
+ return m2decl_BuildStringConstantType (len, str, type);
+}
+
+
+/* (Taken from c-common.cc and trimmed for Modula-2)
+
+ Checks if expression EXPR of real/integer type cannot be converted to
+ the real/integer type TYPE. Function returns non-zero when:
+ EXPR is a constant which cannot be exactly converted to TYPE.
+ EXPR is not a constant and size of EXPR's type > than size of
+ TYPE, for EXPR type and TYPE being both integers or both real.
+ EXPR is not a constant of real type and TYPE is an integer.
+ EXPR is not a constant of integer type which cannot be exactly
+ converted to real type. Function allows conversions between types
+ of different signedness and can return SAFE_CONVERSION (zero) in
+ that case. Function can produce signedness warnings if
+ PRODUCE_WARNS is true. */
+
+enum conversion_safety
+unsafe_conversion_p (location_t loc, tree type, tree expr, bool produce_warns)
+{
+ enum conversion_safety give_warning = SAFE_CONVERSION; /* Is 0 or false. */
+ tree expr_type = TREE_TYPE (expr);
+
+ if (TREE_CODE (expr) == REAL_CST || TREE_CODE (expr) == INTEGER_CST)
+ {
+
+ /* Warn for real constant that is not an exact integer converted to
+ integer type. */
+ if (TREE_CODE (expr_type) == REAL_TYPE
+ && TREE_CODE (type) == INTEGER_TYPE)
+ {
+ if (!real_isinteger (TREE_REAL_CST_PTR (expr),
+ TYPE_MODE (expr_type)))
+ give_warning = UNSAFE_REAL;
+ }
+ /* Warn for an integer constant that does not fit into integer type. */
+ else if (TREE_CODE (expr_type) == INTEGER_TYPE
+ && TREE_CODE (type) == INTEGER_TYPE
+ && !int_fits_type_p (expr, type))
+ {
+ if (TYPE_UNSIGNED (type) && !TYPE_UNSIGNED (expr_type)
+ && tree_int_cst_sgn (expr) < 0)
+ {
+ if (produce_warns)
+ warning_at (loc, OPT_Wsign_conversion,
+ "negative integer"
+ " implicitly converted to unsigned type");
+ }
+ else if (!TYPE_UNSIGNED (type) && TYPE_UNSIGNED (expr_type))
+ {
+ if (produce_warns)
+ warning_at (loc, OPT_Wsign_conversion,
+ "conversion of unsigned"
+ " constant value to negative integer");
+ }
+ else
+ give_warning = UNSAFE_OTHER;
+ }
+ else if (TREE_CODE (type) == REAL_TYPE)
+ {
+ /* Warn for an integer constant that does not fit into real type. */
+ if (TREE_CODE (expr_type) == INTEGER_TYPE)
+ {
+ REAL_VALUE_TYPE a = real_value_from_int_cst (0, expr);
+ if (!exact_real_truncate (TYPE_MODE (type), &a))
+ give_warning = UNSAFE_REAL;
+ }
+
+ /* Warn for a real constant that does not fit into a smaller real
+ type. */
+ else if (TREE_CODE (expr_type) == REAL_TYPE
+ && TYPE_PRECISION (type) < TYPE_PRECISION (expr_type))
+ {
+ REAL_VALUE_TYPE a = TREE_REAL_CST (expr);
+ if (!exact_real_truncate (TYPE_MODE (type), &a))
+ give_warning = UNSAFE_REAL;
+ }
+ }
+ }
+ else
+ {
+ /* Warn for real types converted to integer types. */
+ if (TREE_CODE (expr_type) == REAL_TYPE
+ && TREE_CODE (type) == INTEGER_TYPE)
+ give_warning = UNSAFE_REAL;
+
+ }
+
+ return give_warning;
+}
+
+/* (Taken from c-common.cc and trimmed for Modula-2)
+
+ Warns if the conversion of EXPR to TYPE may alter a value. This is
+ a helper function for warnings_for_convert_and_check. */
+
+static void
+conversion_warning (location_t loc, tree type, tree expr)
+{
+ tree expr_type = TREE_TYPE (expr);
+ enum conversion_safety conversion_kind;
+
+ if (!warn_conversion && !warn_sign_conversion && !warn_float_conversion)
+ return;
+
+ switch (TREE_CODE (expr))
+ {
+ case EQ_EXPR:
+ case NE_EXPR:
+ case LE_EXPR:
+ case GE_EXPR:
+ case LT_EXPR:
+ case GT_EXPR:
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case TRUTH_AND_EXPR:
+ case TRUTH_OR_EXPR:
+ case TRUTH_XOR_EXPR:
+ case TRUTH_NOT_EXPR:
+
+ /* Conversion from boolean to a signed:1 bit-field (which only can
+ hold the values 0 and -1) doesn't lose information - but it does
+ change the value. */
+ if (TYPE_PRECISION (type) == 1 && !TYPE_UNSIGNED (type))
+ warning_at (loc, OPT_Wconversion,
+ "conversion to %qT from boolean expression", type);
+ return;
+
+ case REAL_CST:
+ case INTEGER_CST:
+ conversion_kind = unsafe_conversion_p (loc, type, expr, true);
+ if (conversion_kind == UNSAFE_REAL)
+ warning_at (loc, OPT_Wfloat_conversion,
+ "conversion to %qT alters %qT constant value", type,
+ expr_type);
+ else if (conversion_kind)
+ warning_at (loc, OPT_Wconversion,
+ "conversion to %qT alters %qT constant value", type,
+ expr_type);
+ return;
+
+ case COND_EXPR:
+ {
+
+ /* In case of COND_EXPR, we do not care about the type of COND_EXPR,
+ only about the conversion of each operand. */
+ tree op1 = TREE_OPERAND (expr, 1);
+ tree op2 = TREE_OPERAND (expr, 2);
+
+ conversion_warning (loc, type, op1);
+ conversion_warning (loc, type, op2);
+ return;
+ }
+
+ default: /* 'expr' is not a constant. */
+ conversion_kind = unsafe_conversion_p (loc, type, expr, true);
+ if (conversion_kind == UNSAFE_REAL)
+ warning_at (loc, OPT_Wfloat_conversion,
+ "conversion to %qT from %qT may alter its value", type,
+ expr_type);
+ else if (conversion_kind)
+ warning_at (loc, OPT_Wconversion,
+ "conversion to %qT from %qT may alter its value", type,
+ expr_type);
+ }
+}
+
+/* (Taken from c-common.cc and trimmed for Modula-2)
+
+ Produce warnings after a conversion. RESULT is the result of
+ converting EXPR to TYPE. This is a helper function for
+ convert_and_check and cp_convert_and_check. */
+
+void
+warnings_for_convert_and_check (location_t loc, tree type, tree expr,
+ tree result)
+{
+ if (TREE_CODE (expr) == INTEGER_CST && (TREE_CODE (type) == INTEGER_TYPE
+ || TREE_CODE (type) == ENUMERAL_TYPE)
+ && !int_fits_type_p (expr, type))
+ {
+
+ /* Do not diagnose overflow in a constant expression merely because a
+ conversion overflowed. */
+ if (TREE_OVERFLOW (result))
+ TREE_OVERFLOW (result) = TREE_OVERFLOW (expr);
+
+ if (TYPE_UNSIGNED (type))
+ {
+
+ /* This detects cases like converting -129 or 256 to unsigned
+ char. */
+ if (!int_fits_type_p (expr, m2type_gm2_signed_type (type)))
+ warning_at (loc, OPT_Woverflow,
+ "large integer implicitly truncated to unsigned type");
+ else
+ conversion_warning (loc, type, expr);
+ }
+ else if (!int_fits_type_p (expr, m2type_gm2_unsigned_type (type)))
+ warning_at (loc, OPT_Woverflow,
+ "overflow in implicit constant conversion");
+ /* No warning for converting 0x80000000 to int. */
+ else if (pedantic && (TREE_CODE (TREE_TYPE (expr)) != INTEGER_TYPE
+ || TYPE_PRECISION (TREE_TYPE (expr))
+ != TYPE_PRECISION (type)))
+ warning_at (loc, OPT_Woverflow,
+ "overflow in implicit constant conversion");
+
+ else
+ conversion_warning (loc, type, expr);
+ }
+ else if ((TREE_CODE (result) == INTEGER_CST
+ || TREE_CODE (result) == FIXED_CST)
+ && TREE_OVERFLOW (result))
+ warning_at (loc, OPT_Woverflow,
+ "overflow in implicit constant conversion");
+ else
+ conversion_warning (loc, type, expr);
+}
+
+/* (Taken from c-common.cc and trimmed for Modula-2)
+
+ Convert EXPR to TYPE, warning about conversion problems with
+ constants. Invoke this function on every expression that is
+ converted implicitly, i.e. because of language rules and not
+ because of an explicit cast. */
+
+static tree
+convert_and_check (location_t loc, tree type, tree expr)
+{
+ tree result;
+ tree expr_for_warning;
+
+ /* Convert from a value with possible excess precision rather than
+ via the semantic type, but do not warn about values not fitting
+ exactly in the semantic type. */
+ if (TREE_CODE (expr) == EXCESS_PRECISION_EXPR)
+ {
+ tree orig_type = TREE_TYPE (expr);
+ expr = TREE_OPERAND (expr, 0);
+ expr_for_warning = convert (orig_type, expr);
+ if (orig_type == type)
+ return expr_for_warning;
+ }
+ else
+ expr_for_warning = expr;
+
+ if (TREE_TYPE (expr) == type)
+ return expr;
+
+ result = convert_loc (loc, type, expr);
+
+ if (!TREE_OVERFLOW_P (expr) && result != error_mark_node)
+ warnings_for_convert_and_check (loc, type, expr_for_warning, result);
+
+ return result;
+}
+
+
+static tree
+doOrdinal (tree value)
+{
+ if (TREE_CODE (value) == STRING_CST && (m2expr_StringLength (value) <= 1))
+ {
+ const char *p = TREE_STRING_POINTER (value);
+ int i = p[0];
+
+ return m2decl_BuildIntegerConstant (i);
+ }
+ return value;
+}
+
+static int
+same_size_types (location_t location, tree t1, tree t2)
+{
+ tree n1 = m2expr_GetSizeOf (location, t1);
+ tree n2 = m2expr_GetSizeOf (location, t2);
+
+ return m2expr_CompareTrees (n1, n2) == 0;
+}
+
+static int
+converting_ISO_generic (location_t location, tree type, tree value,
+ tree generic_type, tree *result)
+{
+ tree value_type = m2tree_skip_type_decl (TREE_TYPE (value));
+
+ if (value_type == type)
+ /* We let the caller deal with this. */
+ return FALSE;
+
+ if ((TREE_CODE (value) == INTEGER_CST) && (type == generic_type))
+ {
+ *result = const_to_ISO_type (location, value, generic_type);
+ return TRUE;
+ }
+
+ if (same_size_types (location, type, value_type))
+ {
+ if (value_type == generic_type)
+ {
+ tree pt = build_pointer_type (type);
+ tree a = build1 (ADDR_EXPR, pt, value);
+ tree t = build1 (INDIRECT_REF, type, a);
+ *result = build1 (NOP_EXPR, type, t);
+ return TRUE;
+ }
+ else if (type == generic_type)
+ {
+ tree pt = build_pointer_type (type);
+ tree a = build1 (ADDR_EXPR, pt, value);
+ tree t = build1 (INDIRECT_REF, type, a);
+ *result = build1 (NOP_EXPR, type, t);
+ return TRUE;
+ }
+ }
+ return FALSE;
+}
+
+/* convert_char_to_array - convert a single char, value, into an
+ type. The type will be array [..] of char. The array type
+ returned will have nuls appended to pad the single char to the
+ correct array length. */
+
+static tree
+convert_char_to_array (location_t location, tree type, tree value)
+{
+ tree i = m2decl_BuildIntegerConstant (0);
+ struct struct_constructor *c
+ = (struct struct_constructor *)m2type_BuildStartArrayConstructor (type);
+ tree n = m2type_GetArrayNoOfElements (location, type);
+ char nul[1];
+
+ nul[0] = (char)0;
+
+ /* Store the initial char. */
+ m2type_BuildArrayConstructorElement (c, value, i);
+ i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1), FALSE);
+
+ /* Now pad out the remaining elements with nul chars. */
+ while (m2expr_CompareTrees (i, n) < 0)
+ {
+ m2type_BuildArrayConstructorElement (
+ c, m2type_BuildCharConstant (location, &nul[0]), i);
+ i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1),
+ FALSE);
+ }
+ return m2type_BuildEndArrayConstructor (c);
+}
+
+/* convert_string_to_array - convert a STRING_CST into an array type.
+ array [..] of char. The array constant returned will have nuls
+ appended to pad the contents to the correct length. */
+
+static tree
+convert_string_to_array (location_t location, tree type, tree value)
+{
+ tree n = m2type_GetArrayNoOfElements (location, type);
+
+ return m2type_BuildArrayStringConstructor (location, type, value, n);
+}
+
+/* BuildConvert - build and return tree VAL (type, value).
+ checkOverflow determines whether we should suppress overflow
+ checking. */
+
+tree
+m2convert_BuildConvert (location_t location, tree type, tree value,
+ int checkOverflow)
+{
+ type = m2tree_skip_type_decl (type);
+ tree t;
+
+ value = fold (value);
+ STRIP_NOPS (value);
+ value = m2expr_FoldAndStrip (value);
+
+ if (TREE_CODE (value) == STRING_CST && (m2expr_StringLength (value) <= 1)
+ && (m2tree_IsOrdinal (type)))
+ value = doOrdinal (value);
+ else if (TREE_CODE (value) == FUNCTION_DECL && TREE_TYPE (value) != type)
+ value = m2expr_BuildAddr (0, value, FALSE);
+
+ if (converting_ISO_generic (location, type, value, m2type_GetByteType (), &t)
+ || converting_ISO_generic (location, type, value,
+ m2type_GetISOLocType (), &t)
+ || converting_ISO_generic (location, type, value,
+ m2type_GetISOByteType (), &t)
+ || converting_ISO_generic (location, type, value,
+ m2type_GetISOWordType (), &t)
+ || converting_ISO_generic (location, type, value, m2type_GetM2Word16 (),
+ &t)
+ || converting_ISO_generic (location, type, value, m2type_GetM2Word32 (),
+ &t)
+ || converting_ISO_generic (location, type, value, m2type_GetM2Word64 (),
+ &t))
+ return t;
+
+ if (TREE_CODE (type) == ARRAY_TYPE
+ && TREE_TYPE (type) == m2type_GetM2CharType ())
+ {
+ if (TREE_TYPE (value) == m2type_GetM2CharType ())
+
+ /* Passing a const char to an array [..] of char. So we convert
+ const char into the correct length string. */
+ return convert_char_to_array (location, type, value);
+ if (TREE_CODE (value) == STRING_CST)
+ /* Convert a string into an array constant, padding with zeros if
+ necessary. */
+ return convert_string_to_array (location, type, value);
+ }
+
+ if (checkOverflow)
+ return convert_and_check (location, type, value);
+ else
+ return convert (type, value);
+}
+
+/* const_to_ISO_type - perform VAL (iso_type, expr). */
+
+static tree
+const_to_ISO_type (location_t location, tree expr, tree iso_type)
+{
+ tree n = m2expr_GetSizeOf (location, iso_type);
+
+ if ((m2expr_CompareTrees (n, m2decl_BuildIntegerConstant (1)) == 0)
+ && (iso_type == m2type_GetByteType ()
+ || iso_type == m2type_GetISOLocType ()
+ || iso_type == m2type_GetISOByteType ()))
+ return build1 (NOP_EXPR, iso_type, expr);
+ return const_to_ISO_aggregate_type (location, expr, iso_type);
+}
+
+/* const_to_ISO_aggregate_type - perform VAL (iso_type, expr). The
+ iso_type will be declared by the SYSTEM module as: TYPE iso_type =
+ ARRAY [0..n] OF LOC
+
+ this function will store a constant into the iso_type in the correct
+ endian order. It converts the expr into a unsigned int or signed
+ int and then strips it a byte at a time. */
+
+static tree
+const_to_ISO_aggregate_type (location_t location, tree expr, tree iso_type)
+{
+ tree byte;
+ m2type_Constructor c;
+ tree i = m2decl_BuildIntegerConstant (0);
+ tree n = m2expr_GetSizeOf (location, iso_type);
+ tree max_uint = m2decl_BuildIntegerConstant (256);
+
+ while (m2expr_CompareTrees (i, n) < 0)
+ {
+ max_uint = m2expr_BuildMult (location, max_uint,
+ m2decl_BuildIntegerConstant (256), FALSE);
+ i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1),
+ FALSE);
+ }
+ max_uint = m2expr_BuildDivFloor (location, max_uint,
+ m2decl_BuildIntegerConstant (2), FALSE);
+
+ if (m2expr_CompareTrees (expr, m2decl_BuildIntegerConstant (0)) < 0)
+ expr = m2expr_BuildAdd (location, expr, max_uint, FALSE);
+
+ i = m2decl_BuildIntegerConstant (0);
+ c = m2type_BuildStartArrayConstructor (iso_type);
+ while (m2expr_CompareTrees (i, n) < 0)
+ {
+ byte = m2expr_BuildModTrunc (location, expr,
+ m2decl_BuildIntegerConstant (256), FALSE);
+ if (BYTES_BIG_ENDIAN)
+ m2type_BuildArrayConstructorElement (
+ c, m2convert_ToLoc (location, byte),
+ m2expr_BuildSub (location, m2expr_BuildSub (location, n, i, FALSE),
+ m2decl_BuildIntegerConstant (1), FALSE));
+ else
+ m2type_BuildArrayConstructorElement (
+ c, m2convert_ToLoc (location, byte), i);
+
+ i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1),
+ FALSE);
+ expr = m2expr_BuildDivFloor (location, expr,
+ m2decl_BuildIntegerConstant (256), FALSE);
+ }
+
+ return m2type_BuildEndArrayConstructor (c);
+}
+
+/* ConvertConstantAndCheck - in Modula-2 sementics: RETURN( VAL(type,
+ expr) ). Only to be used for a constant expr, overflow checking
+ is performed. */
+
+tree
+m2convert_ConvertConstantAndCheck (location_t location, tree type, tree expr)
+{
+ tree etype;
+ expr = fold (expr);
+ STRIP_NOPS (expr);
+ expr = m2expr_FoldAndStrip (expr);
+ etype = TREE_TYPE (expr);
+
+ m2assert_AssertLocation (location);
+ if (etype == type)
+ return expr;
+
+ if (TREE_CODE (expr) == FUNCTION_DECL)
+ expr = m2expr_BuildAddr (location, expr, FALSE);
+
+ type = m2tree_skip_type_decl (type);
+ if (type == m2type_GetByteType () || type == m2type_GetISOLocType ()
+ || type == m2type_GetISOByteType () || type == m2type_GetISOWordType ()
+ || type == m2type_GetM2Word16 () || type == m2type_GetM2Word32 ()
+ || type == m2type_GetM2Word64 ())
+ return const_to_ISO_type (location, expr, type);
+
+ return convert_and_check (location, type, m2expr_FoldAndStrip (expr));
+}
+
+/* ToWord - converts an expression (Integer or Ordinal type) into a
+ WORD. */
+
+tree
+m2convert_ToWord (location_t location, tree expr)
+{
+ return m2convert_BuildConvert (location, m2type_GetWordType (), expr, FALSE);
+}
+
+/* ToCardinal - convert an expression, expr, to a CARDINAL. */
+
+tree
+m2convert_ToCardinal (location_t location, tree expr)
+{
+ return m2convert_BuildConvert (location, m2type_GetCardinalType (), expr,
+ FALSE);
+}
+
+/* convertToPtr - if the type of tree, t, is not a ptr_type_node then
+ convert it. */
+
+tree
+m2convert_convertToPtr (location_t location, tree type)
+{
+ if (TREE_CODE (TREE_TYPE (type)) == POINTER_TYPE)
+ return type;
+ else
+ return m2convert_BuildConvert (location, m2type_GetPointerType (), type,
+ FALSE);
+}
+
+/* ToInteger - convert an expression, expr, to an INTEGER. */
+
+tree
+m2convert_ToInteger (location_t location, tree expr)
+{
+ return m2convert_BuildConvert (location, m2type_GetIntegerType (), expr,
+ FALSE);
+}
+
+/* ToBitset - convert an expression, expr, to a BITSET type. */
+
+tree
+m2convert_ToBitset (location_t location, tree expr)
+{
+ return m2convert_BuildConvert (location, m2type_GetBitsetType (), expr,
+ FALSE);
+}
+
+/* ToLoc - convert an expression, expr, to a LOC. */
+
+tree
+m2convert_ToLoc (location_t location, tree expr)
+{
+ return m2convert_BuildConvert (location, m2type_GetISOByteType (), expr,
+ FALSE);
+}
+
+/* GenericToType - converts, expr, into, type, providing that expr is
+ a generic system type (byte, word etc). Otherwise expr is
+ returned unaltered. */
+
+tree
+m2convert_GenericToType (location_t location, tree type, tree expr)
+{
+ tree etype = TREE_TYPE (expr);
+
+ type = m2tree_skip_type_decl (type);
+ if (type == etype)
+ return expr;
+
+ if (type == m2type_GetISOWordType () || type == m2type_GetM2Word16 ()
+ || type == m2type_GetM2Word32 () || type == m2type_GetM2Word64 ())
+ return const_to_ISO_type (location, expr, type);
+
+ return expr;
+}
diff -ruw /dev/null gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2decl.cc
--- /dev/null 2022-08-24 16:22:16.888000070 +0100
+++ gcc-git-devel-modula2/gcc/m2/gm2-gcc/m2decl.cc 2022-10-07 20:21:18.650096940 +0100
@@ -0,0 +1,438 @@
+/* m2decl.cc provides an interface to GCC decl trees.
+
+Copyright (C) 2012-2022 Free Software Foundation, Inc.
+Contributed by Gaius Mulley <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 m2decl_c
+#include "m2assert.h"
+#include "m2block.h"
+#include "m2decl.h"
+#include "m2expr.h"
+#include "m2tree.h"
+#include "m2treelib.h"
+#include "m2type.h"
+#include "m2convert.h"
+
+extern GTY (()) tree current_function_decl;
+
+/* Used in BuildStartFunctionType. */
+static GTY (()) tree param_type_list;
+static GTY (()) tree param_list = NULL_TREE; /* Ready for the next time we
+ call/define a function. */
+
+/* DeclareM2linkGlobals creates the following code in the application
+ module globals:
+
+ int StaticInitialization = ScaffoldStatic;
+ const char *ForcedModuleInitOrder = RuntimeOverride; */
+
+void
+m2decl_DeclareM2linkGlobals (location_t location,
+ int ScaffoldStatic, const char *RuntimeOverride)
+{
+ m2block_pushGlobalScope ();
+ /* Generate: int StaticInitialization = ScaffoldStatic; */
+ tree static_init = m2decl_DeclareKnownVariable (location, "StaticInitialization",
+ integer_type_node,
+ TRUE, FALSE, FALSE, TRUE, NULL_TREE);
+ DECL_INITIAL (static_init) = m2decl_BuildIntegerConstant (ScaffoldStatic);
+ /* Generate: const char *ForcedModuleInitOrder = RuntimeOverride; */
+ tree ptr_to_char = build_pointer_type (char_type_node);
+ TYPE_READONLY (ptr_to_char) = TRUE;
+ tree forced_order = m2decl_DeclareKnownVariable (location, "ForcedModuleInitOrder",
+ ptr_to_char,
+ TRUE, FALSE, FALSE, TRUE, NULL_TREE);
+ if (RuntimeOverride == NULL || (strlen (RuntimeOverride) == 0))
+ DECL_INITIAL (forced_order) = m2convert_BuildConvert (location, ptr_to_char,
+ m2decl_BuildIntegerConstant (0),
+ FALSE);
+ else
+ DECL_INITIAL (forced_order) = build_string_literal (strlen (RuntimeOverride), RuntimeOverride);
+ m2block_popGlobalScope ();
+}
+
+
+/* DeclareKnownVariable declares a variable to GCC. */
+
+tree
+m2decl_DeclareKnownVariable (location_t location, const char *name, tree type,
+ int exported, int imported, int istemporary,
+ int isglobal, tree scope)
+{
+ tree id;
+ tree decl;
+
+ m2assert_AssertLocation (location);
+ ASSERT (m2tree_is_type (type), type);
+ ASSERT_BOOL (isglobal);
+
+ id = get_identifier (name);
+ type = m2tree_skip_type_decl (type);
+ decl = build_decl (location, VAR_DECL, id, type);
+
+ DECL_SOURCE_LOCATION (decl) = location;
+
+ DECL_EXTERNAL (decl) = imported;
+ TREE_STATIC (decl) = isglobal;
+ TREE_PUBLIC (decl) = exported || imported;
+
+ gcc_assert ((istemporary == 0) || (istemporary == 1));
+
+ /* The variable was not declared by GCC, but by the front end. */
+ DECL_ARTIFICIAL (decl) = istemporary;
+ /* If istemporary then we don't want debug info for it. */
+ DECL_IGNORED_P (decl) = istemporary;
+ /* If istemporary we don't want even the fancy names of those printed in
+ -fdump-final-insns= dumps. */
+ DECL_NAMELESS (decl) = istemporary;
+
+ /* Make the variable writable. */
+ TREE_READONLY (decl) = 0;
+
+ DECL_CONTEXT (decl) = scope;
+
+ m2block_pushDecl (decl);
+
+ if (DECL_SIZE (decl) == 0)
+ error ("storage size of %qD has not been resolved", decl);
+
+ if ((TREE_PUBLIC (decl) == 0) && DECL_EXTERNAL (decl))
+ internal_error ("inconsistant because %qs",
+ "PUBLIC_DECL(decl) == 0 && DECL_EXTERNAL(decl) == 1");
+
+ m2block_addDeclExpr (build_stmt (location, DECL_EXPR, decl));
+
+ return decl;
+}
+
+/* DeclareKnownConstant - given a constant, value, of, type, create a
+ constant in the GCC symbol table. Note that the name of the
+ constant is not used as _all_ constants are declared in the global
+ scope. The front end deals with scoping rules - here we declare
+ all constants with no names in the global scope. This allows
+ M2SubExp and constant folding routines the liberty of operating
+ with quadruples which all assume constants can always be
+ referenced. */
+
+tree
+m2decl_DeclareKnownConstant (location_t location, tree type, tree value)
+{
+ tree id = make_node (IDENTIFIER_NODE); /* Ignore the name of the constant. */
+ tree decl;
+
+ m2assert_AssertLocation (location);
+ m2expr_ConstantExpressionWarning (value);
+ type = m2tree_skip_type_decl (type);
+ layout_type (type);
+
+ decl = build_decl (location, CONST_DECL, id, type);
+
+ DECL_INITIAL (decl) = value;
+ TREE_TYPE (decl) = type;
+
+ decl = m2block_global_constant (decl);
+
+ return decl;
+}
+
+/* BuildParameterDeclaration - creates and returns one parameter
+ from, name, and, type. It appends this parameter to the internal
+ param_type_list. */
+
+tree
+m2decl_BuildParameterDeclaration (location_t location, char *name, tree type,
+ int isreference)
+{
+ tree parm_decl;
+
+ m2assert_AssertLocation (location);
+ ASSERT_BOOL (isreference);
+ type = m2tree_skip_type_decl (type);
+ layout_type (type);
+ if (isreference)
+ type = build_reference_type (type);
+
+ if (name == NULL)
+ parm_decl = build_decl (location, PARM_DECL, NULL, type);
+ else
+ parm_decl = build_decl (location, PARM_DECL, get_identifier (name), type);
+ DECL_ARG_TYPE (parm_decl) = type;
+ if (isreference)
+ TREE_READONLY (parm_decl) = TRUE;
+
+ param_list = chainon (parm_decl, param_list);
+ layout_type (type);
+ param_type_list = tree_cons (NULL_TREE, type, param_type_list);
+ return parm_decl;
+}
+
+/* BuildStartFunctionDeclaration - initializes global variables ready
+ for building a function. */
+
+void
+m2decl_BuildStartFunctionDeclaration (int uses_varargs)
+{
+ if (uses_varargs)
+ param_type_list = NULL_TREE;
+ else
+ param_type_list = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
+ param_list = NULL_TREE; /* Ready for when we define a function. */
+}
+
+/* BuildEndFunctionDeclaration - build a function which will return a
+ value of returntype. The arguments have been created by
+ BuildParameterDeclaration. */
+
+tree
+m2decl_BuildEndFunctionDeclaration (location_t location_begin,
+ location_t location_end, const char *name,
+ tree returntype, int isexternal,
+ int isnested, int ispublic)
+{
+ tree fntype;
+ tree fndecl;
+
+ m2assert_AssertLocation (location_begin);
+ m2assert_AssertLocation (location_end);
+ ASSERT_BOOL (isexternal);
+ ASSERT_BOOL (isnested);
+ ASSERT_BOOL (ispublic);
+ returntype = m2tree_skip_type_decl (returntype);
+ /* The function type depends on the return type and type of args,
+ both of which we have created in BuildParameterDeclaration */
+ if (returntype == NULL_TREE)
+ returntype = void_type_node;
+ else if (TREE_CODE (returntype) == FUNCTION_TYPE)
+ returntype = ptr_type_node;
+
+ fntype = build_function_type (returntype, param_type_list);
+ fndecl = build_decl (location_begin, FUNCTION_DECL, get_identifier (name),
+ fntype);
+
+ if (isexternal)
+ ASSERT_CONDITION (ispublic);
+
+ DECL_EXTERNAL (fndecl) = isexternal;
+ TREE_PUBLIC (fndecl) = ispublic;
+ TREE_STATIC (fndecl) = (!isexternal);
+ DECL_ARGUMENTS (fndecl) = param_list;
+ DECL_RESULT (fndecl)
+ = build_decl (location_end, RESULT_DECL, NULL_TREE, returntype);
+ DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
+ TREE_TYPE (fndecl) = fntype;
+
+ DECL_SOURCE_LOCATION (fndecl) = location_begin;
+
+ /* Prevent the optimizer from removing it if it is public. */
+ if (TREE_PUBLIC (fndecl))
+ gm2_mark_addressable (fndecl);
+
+ m2block_pushDecl (fndecl);
+
+ rest_of_decl_compilation (fndecl, 1, 0);
+ param_list
+ = NULL_TREE; /* Ready for the next time we call/define a function. */
+ return fndecl;
+}
+
+/* BuildModuleCtor creates the per module constructor used as part of
+ the dynamic linking scaffold. */
+
+void
+m2decl_BuildModuleCtor (tree module_ctor)
+{
+ decl_init_priority_insert (module_ctor, DEFAULT_INIT_PRIORITY);
+}
+
+/* DeclareModuleCtor configures the function to be used as a ctor. */
+
+tree
+m2decl_DeclareModuleCtor (tree decl)
+{
+ /* Declare module_ctor (). */
+ TREE_PUBLIC (decl) = 1;
+ DECL_ARTIFICIAL (decl) = 1;
+ DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN;
+ DECL_VISIBILITY_SPECIFIED (decl) = 1;
+ DECL_STATIC_CONSTRUCTOR (decl) = 1;
+ return decl;
+}
+
+
+/* DetermineSizeOfConstant - given, str, and, base, fill in needsLong
+ and needsUnsigned appropriately. */
+
+void
+m2decl_DetermineSizeOfConstant (location_t location,
+ const char *str, unsigned int base,
+ int *needsLong, int *needsUnsigned)
+{
+ unsigned int ulow;
+ int high;
+ int overflow = m2expr_interpret_m2_integer (str, base, &ulow, &high,
+ needsLong, needsUnsigned);
+ if (overflow)
+ error_at (location, "constant %qs is too large", str);
+}
+
+/* BuildConstLiteralNumber - returns a GCC TREE built from the
+ string, str. It assumes that, str, represents a legal number in
+ Modula-2. It always returns a positive value. */
+
+tree
+m2decl_BuildConstLiteralNumber (location_t location, const char *str, unsigned int base)
+{
+ tree value, type;
+ unsigned HOST_WIDE_INT low;
+ HOST_WIDE_INT high;
+ HOST_WIDE_INT ival[3];
+ int overflow = m2expr_interpret_integer (str, base, &low, &high);
+ int needLong, needUnsigned;
+
+ ival[0] = low;
+ ival[1] = high;
+ ival[2] = 0;
+
+ widest_int wval = widest_int::from_array (ival, 3);
+
+ m2decl_DetermineSizeOfConstant (location, str, base, &needLong, &needUnsigned);
+
+ if (needUnsigned && needLong)
+ type = m2type_GetM2LongCardType ();
+ else
+ type = m2type_GetM2LongIntType ();
+
+ value = wide_int_to_tree (type, wval);
+
+ if (overflow || m2expr_TreeOverflow (value))
+ error_at (location, "constant %qs is too large", str);
+
+ return m2block_RememberConstant (value);
+}
+
+/* BuildCStringConstant - creates a string constant given a, string,
+ and, length. */
+
+tree
+m2decl_BuildCStringConstant (const char *string, int length)
+{
+ tree elem, index, type;
+
+ /* +1 ensures that we always nul terminate our strings. */
+ elem = build_type_variant (char_type_node, 1, 0);
+ index = build_index_type (build_int_cst (integer_type_node, length + 1));
+ type = build_array_type (elem, index);
+ return m2decl_BuildStringConstantType (length + 1, string, type);
+}
+
+/* BuildStringConstant - creates a string constant given a, string,
+ and, length. */
+
+tree
+m2decl_BuildStringConstant (const char *string, int length)
+{
+ tree elem, index, type;
+
+ elem = build_type_variant (char_type_node, 1, 0);
+ index = build_index_type (build_int_cst (integer_type_node, length));
+ type = build_array_type (elem, index);
+ return m2decl_BuildStringConstantType (length, string, type);
+ // maybe_wrap_with_location
+}
+
+/* BuildIntegerConstant - return a tree containing the integer value. */
+
+tree
+m2decl_BuildIntegerConstant (int value)
+{
+ switch (value)
+ {
+
+ case 0:
+ return integer_zero_node;
+ case 1:
+ return integer_one_node;
+
+ default:
+ return m2block_RememberConstant (
+ build_int_cst (integer_type_node, value));
+ }
+}
+
+/* BuildStringConstantType - builds a string constant with a type. */
+
+tree
+m2decl_BuildStringConstantType (int length, const char *string, tree type)
+{
+ tree id = build_string (length, string);
+
+ TREE_TYPE (id) = type;
+ TREE_CONSTANT (id) = TRUE;
+ TREE_READONLY (id) = TRUE;
+ TREE_STATIC (id) = TRUE;
+
+ return m2block_RememberConstant (id);
+}
+
+/* GetBitsPerWord - returns the number of bits in a WORD. */
+
+int
+m2decl_GetBitsPerWord (void)
+{
+ return BITS_PER_WORD;
+}
+
+/* GetBitsPerInt - returns the number of bits in a INTEGER. */
+
+int
+m2decl_GetBitsPerInt (void)
+{
+ return INT_TYPE_SIZE;
+}
+
+/* GetBitsPerBitset - returns the number of bits in a BITSET. */
+
+int
+m2decl_GetBitsPerBitset (void)
+{
+ return SET_WORD_SIZE;
+}
+
+/* GetBitsPerUnit - returns the number of bits in a UNIT. */
+
+int
+m2decl_GetBitsPerUnit (void)
+{
+ return BITS_PER_UNIT;
+}
+
+/* m2decl_GetDeclContext - returns the DECL_CONTEXT of tree, t. */
+
+tree
+m2decl_GetDeclContext (tree t)
+{
+ return DECL_CONTEXT (t);
+}
+
+#include "gt-m2-m2decl.h"
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-10-10 15:31 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-10-10 15:31 [PATCH] 11/19 modula2 front end: gimple interface *[a-d]*.cc Gaius Mulley
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).